1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Errout
; use Errout
;
32 with Osint
; use Osint
;
33 with Output
; use Output
;
35 with Prepcomp
; use Prepcomp
;
36 with Scans
; use Scans
;
38 with Sinfo
; use Sinfo
;
39 with Snames
; use Snames
;
40 with System
; use System
;
42 with Unchecked_Conversion
;
44 package body Sinput
.L
is
46 Prep_Buffer
: Text_Buffer_Ptr
:= null;
47 -- A buffer to temporarily stored the result of preprocessing a source.
48 -- It is only allocated if there is at least one source to preprocess.
50 Prep_Buffer_Last
: Text_Ptr
:= 0;
51 -- Index of the last significant character in Prep_Buffer
53 Initial_Size_Of_Prep_Buffer
: constant := 10_000
;
54 -- Size of Prep_Buffer when it is first allocated
56 -- When a file is to be preprocessed and the options to list symbols
57 -- has been selected (switch -s), Prep.List_Symbols is called with a
58 -- "foreword", a single line indicating what source the symbols apply to.
59 -- The following two constant String are the start and the end of this
62 Foreword_Start
: constant String :=
63 "Preprocessing Symbols for source """;
65 Foreword_End
: constant String := """";
71 procedure Put_Char_In_Prep_Buffer
(C
: Character);
72 -- Add one character in Prep_Buffer, extending Prep_Buffer if need be.
73 -- Used to initialize the preprocessor.
75 procedure New_EOL_In_Prep_Buffer
;
76 -- Add an LF to Prep_Buffer (used to initialize the preprocessor)
80 T
: Osint
.File_Type
) return Source_File_Index
;
81 -- Load a source file, a configuration pragmas file or a definition file
82 -- Coding also allows preprocessing file, but not a library file ???
84 -------------------------------
85 -- Adjust_Instantiation_Sloc --
86 -------------------------------
88 procedure Adjust_Instantiation_Sloc
(N
: Node_Id
; A
: Sloc_Adjustment
) is
89 Loc
: constant Source_Ptr
:= Sloc
(N
);
92 -- We only do the adjustment if the value is between the appropriate low
93 -- and high values. It is not clear that this should ever not be the
94 -- case, but in practice there seem to be some nodes that get copied
95 -- twice, and this is a defence against that happening.
97 if A
.Lo
<= Loc
and then Loc
<= A
.Hi
then
98 Set_Sloc
(N
, Loc
+ A
.Adjust
);
100 end Adjust_Instantiation_Sloc
;
102 --------------------------------
103 -- Complete_Source_File_Entry --
104 --------------------------------
106 procedure Complete_Source_File_Entry
is
107 CSF
: constant Source_File_Index
:= Current_Source_File
;
110 Trim_Lines_Table
(CSF
);
111 Source_File
.Table
(CSF
).Source_Checksum
:= Checksum
;
112 end Complete_Source_File_Entry
;
114 ---------------------------------
115 -- Create_Instantiation_Source --
116 ---------------------------------
118 procedure Create_Instantiation_Source
119 (Inst_Node
: Entity_Id
;
120 Template_Id
: Entity_Id
;
121 Inlined_Body
: Boolean;
122 A
: out Sloc_Adjustment
)
124 Dnod
: constant Node_Id
:= Declaration_Node
(Template_Id
);
125 Xold
: Source_File_Index
;
126 Xnew
: Source_File_Index
;
129 Xold
:= Get_Source_File_Index
(Sloc
(Template_Id
));
130 A
.Lo
:= Source_File
.Table
(Xold
).Source_First
;
131 A
.Hi
:= Source_File
.Table
(Xold
).Source_Last
;
133 Source_File
.Append
(Source_File
.Table
(Xold
));
134 Xnew
:= Source_File
.Last
;
136 Source_File
.Table
(Xnew
).Inlined_Body
:= Inlined_Body
;
137 Source_File
.Table
(Xnew
).Instantiation
:= Sloc
(Inst_Node
);
138 Source_File
.Table
(Xnew
).Template
:= Xold
;
140 -- Now we need to compute the new values of Source_First, Source_Last
141 -- and adjust the source file pointer to have the correct virtual
142 -- origin for the new range of values.
144 Source_File
.Table
(Xnew
).Source_First
:=
145 Source_File
.Table
(Xnew
- 1).Source_Last
+ 1;
146 A
.Adjust
:= Source_File
.Table
(Xnew
).Source_First
- A
.Lo
;
147 Source_File
.Table
(Xnew
).Source_Last
:= A
.Hi
+ A
.Adjust
;
149 Set_Source_File_Index_Table
(Xnew
);
151 Source_File
.Table
(Xnew
).Sloc_Adjust
:=
152 Source_File
.Table
(Xold
).Sloc_Adjust
- A
.Adjust
;
156 Write_Str
("*** Create instantiation source for ");
158 if Nkind
(Dnod
) in N_Proper_Body
159 and then Was_Originally_Stub
(Dnod
)
161 Write_Str
("subunit ");
163 elsif Ekind
(Template_Id
) = E_Generic_Package
then
164 if Nkind
(Dnod
) = N_Package_Body
then
165 Write_Str
("body of package ");
167 Write_Str
("spec of package ");
170 elsif Ekind
(Template_Id
) = E_Function
then
171 Write_Str
("body of function ");
173 elsif Ekind
(Template_Id
) = E_Procedure
then
174 Write_Str
("body of procedure ");
176 elsif Ekind
(Template_Id
) = E_Generic_Function
then
177 Write_Str
("spec of function ");
179 elsif Ekind
(Template_Id
) = E_Generic_Procedure
then
180 Write_Str
("spec of procedure ");
182 elsif Ekind
(Template_Id
) = E_Package_Body
then
183 Write_Str
("body of package ");
185 else pragma Assert
(Ekind
(Template_Id
) = E_Subprogram_Body
);
187 if Nkind
(Dnod
) = N_Procedure_Specification
then
188 Write_Str
("body of procedure ");
190 Write_Str
("body of function ");
194 Write_Name
(Chars
(Template_Id
));
197 Write_Str
(" new source index = ");
198 Write_Int
(Int
(Xnew
));
201 Write_Str
(" copying from file name = ");
202 Write_Name
(File_Name
(Xold
));
205 Write_Str
(" old source index = ");
206 Write_Int
(Int
(Xold
));
209 Write_Str
(" old lo = ");
210 Write_Int
(Int
(A
.Lo
));
213 Write_Str
(" old hi = ");
214 Write_Int
(Int
(A
.Hi
));
217 Write_Str
(" new lo = ");
218 Write_Int
(Int
(Source_File
.Table
(Xnew
).Source_First
));
221 Write_Str
(" new hi = ");
222 Write_Int
(Int
(Source_File
.Table
(Xnew
).Source_Last
));
225 Write_Str
(" adjustment factor = ");
226 Write_Int
(Int
(A
.Adjust
));
229 Write_Str
(" instantiation location: ");
230 Write_Location
(Sloc
(Inst_Node
));
234 -- For a given character in the source, a higher subscript will be used
235 -- to access the instantiation, which means that the virtual origin must
236 -- have a corresponding lower value. We compute this new origin by
237 -- taking the address of the appropriate adjusted element in the old
238 -- array. Since this adjusted element will be at a negative subscript,
239 -- we must suppress checks.
242 pragma Suppress
(All_Checks
);
244 pragma Warnings
(Off
);
245 -- This unchecked conversion is aliasing safe, since it is never used
246 -- to create improperly aliased pointer values.
248 function To_Source_Buffer_Ptr
is new
249 Unchecked_Conversion
(Address
, Source_Buffer_Ptr
);
251 pragma Warnings
(On
);
254 Source_File
.Table
(Xnew
).Source_Text
:=
256 (Source_File
.Table
(Xold
).Source_Text
(-A
.Adjust
)'Address);
258 end Create_Instantiation_Source
;
260 ----------------------
261 -- Load_Config_File --
262 ----------------------
264 function Load_Config_File
265 (N
: File_Name_Type
) return Source_File_Index
268 return Load_File
(N
, Osint
.Config
);
269 end Load_Config_File
;
271 --------------------------
272 -- Load_Definition_File --
273 --------------------------
275 function Load_Definition_File
276 (N
: File_Name_Type
) return Source_File_Index
279 return Load_File
(N
, Osint
.Definition
);
280 end Load_Definition_File
;
288 T
: Osint
.File_Type
) return Source_File_Index
290 Src
: Source_Buffer_Ptr
;
291 X
: Source_File_Index
;
295 Preprocessing_Needed
: Boolean := False;
298 -- If already there, don't need to reload file. An exception occurs
299 -- in multiple unit per file mode. It would be nice in this case to
300 -- share the same source file for each unit, but this leads to many
301 -- difficulties with assumptions (e.g. in the body of lib), that a
302 -- unit can be found by locating its source file index. Since we do
303 -- not expect much use of this mode, it's no big deal to waste a bit
304 -- of space and time by reading and storing the source multiple times.
306 if Multiple_Unit_Index
= 0 then
307 for J
in 1 .. Source_File
.Last
loop
308 if Source_File
.Table
(J
).File_Name
= N
then
314 -- Here we must build a new entry in the file table
316 -- But first, we must check if a source needs to be preprocessed,
317 -- because we may have to load and parse a definition file, and we want
318 -- to do that before we load the source, so that the buffer of the
319 -- source will be the last created, and we will be able to replace it
320 -- and modify Hi without stepping on another buffer.
322 if T
= Osint
.Source
then
323 Prepare_To_Preprocess
324 (Source
=> N
, Preprocessing_Needed
=> Preprocessing_Needed
);
327 Source_File
.Increment_Last
;
328 X
:= Source_File
.Last
;
330 if X
= Source_File
.First
then
331 Lo
:= First_Source_Ptr
;
333 Lo
:= Source_File
.Table
(X
- 1).Source_Last
+ 1;
336 Osint
.Read_Source_File
(N
, Lo
, Hi
, Src
, T
);
339 Source_File
.Decrement_Last
;
340 return No_Source_File
;
345 Write_Str
("*** Build source file table entry, Index = ");
347 Write_Str
(", file name = ");
350 Write_Str
(" lo = ");
351 Write_Int
(Int
(Lo
));
353 Write_Str
(" hi = ");
354 Write_Int
(Int
(Hi
));
357 Write_Str
(" first 10 chars -->");
360 procedure Wchar
(C
: Character);
361 -- Writes character or ? for control character
363 procedure Wchar
(C
: Character) is
365 if C
< ' ' or C
in ASCII
.DEL
.. Character'Val (16#
9F#
) then
373 for J
in Lo
.. Lo
+ 9 loop
380 Write_Str
(" last 10 chars -->");
382 for J
in Hi
- 10 .. Hi
- 1 loop
389 if Src
(Hi
) /= EOF
then
390 Write_Str
(" error: no EOF at end");
397 S
: Source_File_Record
renames Source_File
.Table
(X
);
398 File_Type
: Type_Of_File
;
403 File_Type
:= Sinput
.Src
;
405 when Osint
.Library
=>
409 File_Type
:= Sinput
.Config
;
411 when Osint
.Definition
=>
414 when Osint
.Preprocessing_Data
=>
415 File_Type
:= Preproc
;
418 S
:= (Debug_Source_Name
=> N
,
420 File_Type
=> File_Type
,
421 First_Mapped_Line
=> No_Line_Number
,
422 Full_Debug_Name
=> Osint
.Full_Source_Name
,
423 Full_File_Name
=> Osint
.Full_Source_Name
,
424 Full_Ref_Name
=> Osint
.Full_Source_Name
,
425 Identifier_Casing
=> Unknown
,
426 Inlined_Body
=> False,
427 Instantiation
=> No_Location
,
428 Keyword_Casing
=> Unknown
,
429 Last_Source_Line
=> 1,
432 Lines_Table_Max
=> 1,
433 Logical_Lines_Table
=> null,
434 Num_SRef_Pragmas
=> 0,
437 Source_Checksum
=> 0,
441 Template
=> No_Source_File
,
443 Time_Stamp
=> Osint
.Current_Source_File_Stamp
);
445 Alloc_Line_Tables
(S
, Opt
.Table_Factor
* Alloc
.Lines_Initial
);
446 S
.Lines_Table
(1) := Lo
;
449 -- Preprocess the source if it needs to be preprocessed
451 if Preprocessing_Needed
then
452 if Opt
.List_Preprocessing_Symbols
then
456 Foreword
: String (1 .. Foreword_Start
'Length +
457 Name_Len
+ Foreword_End
'Length);
460 Foreword
(1 .. Foreword_Start
'Length) := Foreword_Start
;
461 Foreword
(Foreword_Start
'Length + 1 ..
462 Foreword_Start
'Length + Name_Len
) :=
463 Name_Buffer
(1 .. Name_Len
);
464 Foreword
(Foreword
'Last - Foreword_End
'Length + 1 ..
465 Foreword
'Last) := Foreword_End
;
466 Prep
.List_Symbols
(Foreword
);
471 T
: constant Nat
:= Total_Errors_Detected
;
472 -- Used to check if there were errors during preprocessing
474 Save_Style_Check
: Boolean;
475 -- Saved state of the Style_Check flag (which needs to be
476 -- temporarily set to False during preprocessing, see below).
479 -- If this is the first time we preprocess a source, allocate
480 -- the preprocessing buffer.
482 if Prep_Buffer
= null then
484 new Text_Buffer
(1 .. Initial_Size_Of_Prep_Buffer
);
487 -- Make sure the preprocessing buffer is empty
489 Prep_Buffer_Last
:= 0;
491 -- Initialize the preprocessor
494 (Error_Msg
=> Errout
.Error_Msg
'Access,
495 Scan
=> Scn
.Scanner
.Scan
'Access,
496 Set_Ignore_Errors
=> Errout
.Set_Ignore_Errors
'Access,
497 Put_Char
=> Put_Char_In_Prep_Buffer
'Access,
498 New_EOL
=> New_EOL_In_Prep_Buffer
'Access);
500 -- Initialize scanner and set its behavior for preprocessing,
501 -- then preprocess. Also disable style checks, since some of
502 -- them are done in the scanner (specifically, those dealing
503 -- with line length and line termination), and cannot be done
504 -- during preprocessing (because the source file index table
505 -- has not been set yet).
507 Scn
.Scanner
.Initialize_Scanner
(X
);
509 Scn
.Scanner
.Set_Special_Character
('#');
510 Scn
.Scanner
.Set_Special_Character
('$');
511 Scn
.Scanner
.Set_End_Of_Line_As_Token
(True);
512 Save_Style_Check
:= Opt
.Style_Check
;
513 Opt
.Style_Check
:= False;
517 -- Reset the scanner to its standard behavior, and restore the
518 -- Style_Checks flag.
520 Scn
.Scanner
.Reset_Special_Characters
;
521 Scn
.Scanner
.Set_End_Of_Line_As_Token
(False);
522 Opt
.Style_Check
:= Save_Style_Check
;
524 -- If there were errors during preprocessing, record an error
525 -- at the start of the file, and do not change the source
528 if T
/= Total_Errors_Detected
then
530 ("file could not be successfully preprocessed", Lo
);
531 return No_Source_File
;
534 -- Set the new value of Hi
536 Hi
:= Lo
+ Source_Ptr
(Prep_Buffer_Last
);
538 -- Create the new source buffer
541 subtype Actual_Source_Buffer
is Source_Buffer
(Lo
.. Hi
);
542 -- Physical buffer allocated
544 type Actual_Source_Ptr
is access Actual_Source_Buffer
;
545 -- Pointer type for the physical buffer allocated
547 Actual_Ptr
: constant Actual_Source_Ptr
:=
548 new Actual_Source_Buffer
;
549 -- Actual physical buffer
552 Actual_Ptr
(Lo
.. Hi
- 1) :=
553 Prep_Buffer
(1 .. Prep_Buffer_Last
);
554 Actual_Ptr
(Hi
) := EOF
;
556 -- Now we need to work out the proper virtual origin
557 -- pointer to return. This is Actual_Ptr (0)'Address, but
558 -- we have to be careful to suppress checks to compute
562 pragma Suppress
(All_Checks
);
564 pragma Warnings
(Off
);
565 -- This unchecked conversion is aliasing safe, since
566 -- it is never used to create improperly aliased
569 function To_Source_Buffer_Ptr
is new
570 Unchecked_Conversion
(Address
, Source_Buffer_Ptr
);
572 pragma Warnings
(On
);
575 Src
:= To_Source_Buffer_Ptr
(Actual_Ptr
(0)'Address);
577 -- Record in the table the new source buffer and the
580 Source_File
.Table
(X
).Source_Text
:= Src
;
581 Source_File
.Table
(X
).Source_Last
:= Hi
;
583 -- Reset Last_Line to 1, because the lines do not
584 -- have necessarily the same starts and lengths.
586 Source_File
.Table
(X
).Last_Source_Line
:= 1;
593 Set_Source_File_Index_Table
(X
);
598 ----------------------------------
599 -- Load_Preprocessing_Data_File --
600 ----------------------------------
602 function Load_Preprocessing_Data_File
603 (N
: File_Name_Type
) return Source_File_Index
606 return Load_File
(N
, Osint
.Preprocessing_Data
);
607 end Load_Preprocessing_Data_File
;
609 ----------------------
610 -- Load_Source_File --
611 ----------------------
613 function Load_Source_File
614 (N
: File_Name_Type
) return Source_File_Index
617 return Load_File
(N
, Osint
.Source
);
618 end Load_Source_File
;
620 ----------------------------
621 -- New_EOL_In_Prep_Buffer --
622 ----------------------------
624 procedure New_EOL_In_Prep_Buffer
is
626 Put_Char_In_Prep_Buffer
(ASCII
.LF
);
627 end New_EOL_In_Prep_Buffer
;
629 -----------------------------
630 -- Put_Char_In_Prep_Buffer --
631 -----------------------------
633 procedure Put_Char_In_Prep_Buffer
(C
: Character) is
635 -- If preprocessing buffer is not large enough, double it
637 if Prep_Buffer_Last
= Prep_Buffer
'Last then
639 New_Prep_Buffer
: constant Text_Buffer_Ptr
:=
640 new Text_Buffer
(1 .. 2 * Prep_Buffer_Last
);
643 New_Prep_Buffer
(Prep_Buffer
'Range) := Prep_Buffer
.all;
645 Prep_Buffer
:= New_Prep_Buffer
;
649 Prep_Buffer_Last
:= Prep_Buffer_Last
+ 1;
650 Prep_Buffer
(Prep_Buffer_Last
) := C
;
651 end Put_Char_In_Prep_Buffer
;
653 -----------------------------------
654 -- Source_File_Is_Pragma_No_Body --
655 -----------------------------------
657 function Source_File_Is_No_Body
(X
: Source_File_Index
) return Boolean is
659 Initialize_Scanner
(No_Unit
, X
);
661 if Token
/= Tok_Pragma
then
667 if Token
/= Tok_Identifier
668 or else Chars
(Token_Node
) /= Name_No_Body
673 Scan
; -- past No_Body
675 if Token
/= Tok_Semicolon
then
679 Scan
; -- past semicolon
681 return Token
= Tok_EOF
;
682 end Source_File_Is_No_Body
;
684 ----------------------------
685 -- Source_File_Is_Subunit --
686 ----------------------------
688 function Source_File_Is_Subunit
(X
: Source_File_Index
) return Boolean is
690 Initialize_Scanner
(No_Unit
, X
);
692 -- We scan past junk to the first interesting compilation unit token, to
693 -- see if it is SEPARATE. We ignore WITH keywords during this and also
694 -- PRIVATE. The reason for ignoring PRIVATE is that it handles some
695 -- error situations, and also to handle PRIVATE WITH in Ada 2005 mode.
697 while Token
= Tok_With
698 or else Token
= Tok_Private
699 or else (Token
not in Token_Class_Cunit
and then Token
/= Tok_EOF
)
704 return Token
= Tok_Separate
;
705 end Source_File_Is_Subunit
;