1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2017, 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
;
31 with Fname
; use Fname
;
34 with Osint
; use Osint
;
35 with Output
; use Output
;
37 with Prepcomp
; use Prepcomp
;
38 with Scans
; use Scans
;
40 with Sem_Aux
; use Sem_Aux
;
41 with Sem_Util
; use Sem_Util
;
42 with Sinfo
; use Sinfo
;
43 with Snames
; use Snames
;
44 with System
; use System
;
46 with System
.OS_Lib
; use System
.OS_Lib
;
48 package body Sinput
.L
is
50 Prep_Buffer
: Text_Buffer_Ptr
:= null;
51 -- A buffer to temporarily stored the result of preprocessing a source.
52 -- It is only allocated if there is at least one source to preprocess.
54 Prep_Buffer_Last
: Text_Ptr
:= 0;
55 -- Index of the last significant character in Prep_Buffer
57 Initial_Size_Of_Prep_Buffer
: constant := 10_000
;
58 -- Size of Prep_Buffer when it is first allocated
60 -- When a file is to be preprocessed and the options to list symbols
61 -- has been selected (switch -s), Prep.List_Symbols is called with a
62 -- "foreword", a single line indicating what source the symbols apply to.
63 -- The following two constant String are the start and the end of this
66 Foreword_Start
: constant String :=
67 "Preprocessing Symbols for source """;
69 Foreword_End
: constant String := """";
75 procedure Put_Char_In_Prep_Buffer
(C
: Character);
76 -- Add one character in Prep_Buffer, extending Prep_Buffer if need be.
77 -- Used to initialize the preprocessor.
79 procedure New_EOL_In_Prep_Buffer
;
80 -- Add an LF to Prep_Buffer (used to initialize the preprocessor)
84 T
: Osint
.File_Type
) return Source_File_Index
;
85 -- Load a source file, a configuration pragmas file or a definition file
86 -- Coding also allows preprocessing file, but not a library file ???
88 -------------------------------
89 -- Adjust_Instantiation_Sloc --
90 -------------------------------
92 procedure Adjust_Instantiation_Sloc
94 Factor
: Sloc_Adjustment
)
96 Loc
: constant Source_Ptr
:= Sloc
(N
);
99 -- We only do the adjustment if the value is between the appropriate low
100 -- and high values. It is not clear that this should ever not be the
101 -- case, but in practice there seem to be some nodes that get copied
102 -- twice, and this is a defence against that happening.
104 if Loc
in Factor
.Lo
.. Factor
.Hi
then
105 Set_Sloc
(N
, Loc
+ Factor
.Adjust
);
107 end Adjust_Instantiation_Sloc
;
109 --------------------------------
110 -- Complete_Source_File_Entry --
111 --------------------------------
113 procedure Complete_Source_File_Entry
is
114 CSF
: constant Source_File_Index
:= Current_Source_File
;
116 Trim_Lines_Table
(CSF
);
117 Source_File
.Table
(CSF
).Source_Checksum
:= Checksum
;
118 end Complete_Source_File_Entry
;
120 ---------------------------------
121 -- Create_Instantiation_Source --
122 ---------------------------------
124 procedure Create_Instantiation_Source
125 (Inst_Node
: Entity_Id
;
126 Template_Id
: Entity_Id
;
127 Factor
: out Sloc_Adjustment
;
128 Inlined_Body
: Boolean := False;
129 Inherited_Pragma
: Boolean := False)
131 Dnod
: constant Node_Id
:= Declaration_Node
(Template_Id
);
132 Xold
: Source_File_Index
;
133 Xnew
: Source_File_Index
;
136 Xold
:= Get_Source_File_Index
(Sloc
(Template_Id
));
137 Factor
.Lo
:= Source_File
.Table
(Xold
).Source_First
;
138 Factor
.Hi
:= Source_File
.Table
(Xold
).Source_Last
;
140 Source_File
.Append
(Source_File
.Table
(Xold
));
141 Xnew
:= Source_File
.Last
;
145 Write_Str
("*** Create_Instantiation_Source: created source ");
146 Write_Int
(Int
(Xnew
));
151 Sold
: Source_File_Record
renames Source_File
.Table
(Xold
);
152 Snew
: Source_File_Record
renames Source_File
.Table
(Xnew
);
158 Snew
.Inlined_Body
:= Inlined_Body
;
159 Snew
.Inherited_Pragma
:= Inherited_Pragma
;
160 Snew
.Template
:= Xold
;
162 -- For a genuine generic instantiation, assign new instance id. For
163 -- inlined bodies or inherited pragmas, we retain that of the
164 -- template, but we save the call location.
166 if Inlined_Body
or Inherited_Pragma
then
167 Snew
.Inlined_Call
:= Sloc
(Inst_Node
);
170 -- If the spec has been instantiated already, and we are now
171 -- creating the instance source for the corresponding body now,
172 -- retrieve the instance id that was assigned to the spec, which
173 -- corresponds to the same instantiation sloc.
175 Inst_Spec
:= Instance_Spec
(Inst_Node
);
176 if Present
(Inst_Spec
) then
178 Inst_Spec_Ent
: Entity_Id
;
179 -- Instance spec entity
181 Inst_Spec_Sloc
: Source_Ptr
;
182 -- Virtual sloc of the spec instance source
184 Inst_Spec_Inst_Id
: Instance_Id
;
185 -- Instance id assigned to the instance spec
188 Inst_Spec_Ent
:= Defining_Entity
(Inst_Spec
);
190 -- For a subprogram instantiation, we want the subprogram
191 -- instance, not the wrapper package.
193 if Present
(Related_Instance
(Inst_Spec_Ent
)) then
194 Inst_Spec_Ent
:= Related_Instance
(Inst_Spec_Ent
);
197 -- The specification of the instance entity has a virtual
198 -- sloc within the instance sloc range.
200 -- ??? But the Unit_Declaration_Node has the sloc of the
201 -- instantiation, which is somewhat of an oddity.
205 (Specification
(Unit_Declaration_Node
(Inst_Spec_Ent
)));
208 (Get_Source_File_Index
(Inst_Spec_Sloc
)).Instance
;
211 (Sloc
(Inst_Node
) = Instances
.Table
(Inst_Spec_Inst_Id
));
212 Snew
.Instance
:= Inst_Spec_Inst_Id
;
216 Instances
.Append
(Sloc
(Inst_Node
));
217 Snew
.Instance
:= Instances
.Last
;
221 -- Now compute the new values of Source_First and Source_Last and
222 -- adjust the source file pointer to have the correct bounds for the
223 -- new range of values.
225 -- Source_First must be greater than the last Source_Last value and
226 -- also must be a multiple of Source_Align.
229 ((Source_File
.Table
(Xnew
- 1).Source_Last
+ Source_Align
) /
230 Source_Align
) * Source_Align
;
231 Factor
.Adjust
:= Snew
.Source_First
- Factor
.Lo
;
232 Snew
.Source_Last
:= Factor
.Hi
+ Factor
.Adjust
;
234 Set_Source_File_Index_Table
(Xnew
);
236 Snew
.Sloc_Adjust
:= Sold
.Sloc_Adjust
- Factor
.Adjust
;
238 -- Modify the Dope of the instance Source_Text to use the
239 -- above-computed bounds.
242 Dope
: constant Dope_Ptr
:=
243 new Dope_Rec
'(Snew.Source_First, Snew.Source_Last);
245 Snew.Source_Text := Sold.Source_Text;
246 Set_Dope (Snew.Source_Text'Address, Dope);
247 pragma Assert (Snew.Source_Text'First = Snew.Source_First);
248 pragma Assert (Snew.Source_Text'Last = Snew.Source_Last);
254 if Nkind (Dnod) in N_Proper_Body
255 and then Was_Originally_Stub (Dnod)
257 Write_Str ("subunit ");
259 elsif Ekind (Template_Id) = E_Generic_Package then
260 if Nkind (Dnod) = N_Package_Body then
261 Write_Str ("body of package ");
263 Write_Str ("spec of package ");
266 elsif Ekind (Template_Id) = E_Function then
267 Write_Str ("body of function ");
269 elsif Ekind (Template_Id) = E_Procedure then
270 Write_Str ("body of procedure ");
272 elsif Ekind (Template_Id) = E_Generic_Function then
273 Write_Str ("spec of function ");
275 elsif Ekind (Template_Id) = E_Generic_Procedure then
276 Write_Str ("spec of procedure ");
278 elsif Ekind (Template_Id) = E_Package_Body then
279 Write_Str ("body of package ");
281 else pragma Assert (Ekind (Template_Id) = E_Subprogram_Body);
282 if Nkind (Dnod) = N_Procedure_Specification then
283 Write_Str ("body of procedure ");
285 Write_Str ("body of function ");
289 Write_Name (Chars (Template_Id));
292 Write_Str (" copying from file name = ");
293 Write_Name (File_Name (Xold));
296 Write_Str (" old source index = ");
297 Write_Int (Int (Xold));
300 Write_Str (" old lo = ");
301 Write_Int (Int (Factor.Lo));
304 Write_Str (" old hi = ");
305 Write_Int (Int (Factor.Hi));
308 Write_Str (" new lo = ");
309 Write_Int (Int (Snew.Source_First));
312 Write_Str (" new hi = ");
313 Write_Int (Int (Snew.Source_Last));
316 Write_Str (" adjustment factor = ");
317 Write_Int (Int (Factor.Adjust));
320 Write_Str (" instantiation location: ");
321 Write_Location (Sloc (Inst_Node));
325 end Create_Instantiation_Source;
327 ----------------------
328 -- Load_Config_File --
329 ----------------------
331 function Load_Config_File
332 (N : File_Name_Type) return Source_File_Index
335 return Load_File (N, Osint.Config);
336 end Load_Config_File;
338 --------------------------
339 -- Load_Definition_File --
340 --------------------------
342 function Load_Definition_File
343 (N : File_Name_Type) return Source_File_Index
346 return Load_File (N, Osint.Definition);
347 end Load_Definition_File;
355 T : Osint.File_Type) return Source_File_Index
357 Src : Source_Buffer_Ptr;
358 X : Source_File_Index;
362 Preprocessing_Needed : Boolean := False;
365 -- If already there, don't need to reload file. An exception occurs
366 -- in multiple unit per file mode. It would be nice in this case to
367 -- share the same source file for each unit, but this leads to many
368 -- difficulties with assumptions (e.g. in the body of lib), that a
369 -- unit can be found by locating its source file index. Since we do
370 -- not expect much use of this mode, it's no big deal to waste a bit
371 -- of space and time by reading and storing the source multiple times.
373 if Multiple_Unit_Index = 0 then
374 for J in 1 .. Source_File.Last loop
375 if Source_File.Table (J).File_Name = N then
381 -- Here we must build a new entry in the file table
383 -- But first, we must check if a source needs to be preprocessed,
384 -- because we may have to load and parse a definition file, and we want
385 -- to do that before we load the source, so that the buffer of the
386 -- source will be the last created, and we will be able to replace it
387 -- and modify Hi without stepping on another buffer.
389 if T = Osint.Source and then not Is_Internal_File_Name (N) then
390 Prepare_To_Preprocess
391 (Source => N, Preprocessing_Needed => Preprocessing_Needed);
394 Source_File.Increment_Last;
395 X := Source_File.Last;
399 Write_Str ("Sinput.L.Load_File: created source ");
402 Write_Str (Get_Name_String (N));
405 -- Compute starting index, respecting alignment requirement
407 if X = Source_File.First then
408 Lo := First_Source_Ptr;
410 Lo := ((Source_File.Table (X - 1).Source_Last + Source_Align) /
411 Source_Align) * Source_Align;
414 Osint.Read_Source_File (N, Lo, Hi, Src, T);
416 if Null_Source_Buffer_Ptr (Src) then
417 Source_File.Decrement_Last;
418 return No_Source_File;
423 Write_Str ("*** Build source file table entry, Index = ");
425 Write_Str (", file name = ");
428 Write_Str (" lo = ");
429 Write_Int (Int (Lo));
431 Write_Str (" hi = ");
432 Write_Int (Int (Hi));
435 Write_Str (" first 10 chars -->");
438 procedure Wchar (C : Character);
439 -- Writes character or ? for control character
445 procedure Wchar (C : Character) is
448 or else C in ASCII.DEL .. Character'Val (16#9F#)
457 for J in Lo .. Lo + 9 loop
464 Write_Str (" last 10 chars -->");
466 for J in Hi - 10 .. Hi - 1 loop
473 if Src (Hi) /= EOF then
474 Write_Str (" error: no EOF at end");
481 S : Source_File_Record renames Source_File.Table (X);
482 File_Type : Type_Of_File;
487 File_Type := Sinput.Src;
489 when Osint.Library =>
493 File_Type := Sinput.Config;
495 when Osint.Definition =>
498 when Osint.Preprocessing_Data =>
499 File_Type := Preproc;
502 S := (Debug_Source_Name => N,
504 File_Type => File_Type,
505 First_Mapped_Line => No_Line_Number,
506 Full_Debug_Name => Osint.Full_Source_Name,
507 Full_File_Name => Osint.Full_Source_Name,
508 Full_Ref_Name => Osint.Full_Source_Name,
509 Instance => No_Instance_Id,
510 Identifier_Casing => Unknown,
511 Inlined_Call => No_Location,
512 Inlined_Body => False,
513 Inherited_Pragma => False,
514 Keyword_Casing => Unknown,
515 Last_Source_Line => 1,
518 Lines_Table_Max => 1,
519 Logical_Lines_Table => null,
520 Num_SRef_Pragmas => 0,
523 Source_Checksum => 0,
527 Template => No_Source_File,
529 Time_Stamp => Osint.Current_Source_File_Stamp,
532 Alloc_Line_Tables (S, Opt.Table_Factor * Alloc.Lines_Initial);
533 S.Lines_Table (1) := Lo;
536 -- Preprocess the source if it needs to be preprocessed
538 if Preprocessing_Needed then
540 -- Temporarily set the Source_File_Index_Table entries for the
541 -- source, to avoid crash when reporting an error.
543 Set_Source_File_Index_Table (X);
545 if Opt.List_Preprocessing_Symbols then
549 Foreword : String (1 .. Foreword_Start'Length +
550 Name_Len + Foreword_End'Length);
553 Foreword (1 .. Foreword_Start'Length) := Foreword_Start;
554 Foreword (Foreword_Start'Length + 1 ..
555 Foreword_Start'Length + Name_Len) :=
556 Name_Buffer (1 .. Name_Len);
557 Foreword (Foreword'Last - Foreword_End'Length + 1 ..
558 Foreword'Last) := Foreword_End;
559 Prep.List_Symbols (Foreword);
564 T : constant Nat := Total_Errors_Detected;
565 -- Used to check if there were errors during preprocessing
567 Save_Style_Check : Boolean;
568 -- Saved state of the Style_Check flag (which needs to be
569 -- temporarily set to False during preprocessing, see below).
574 -- If this is the first time we preprocess a source, allocate
575 -- the preprocessing buffer.
577 if Prep_Buffer = null then
579 new Text_Buffer (1 .. Initial_Size_Of_Prep_Buffer);
582 -- Make sure the preprocessing buffer is empty
584 Prep_Buffer_Last := 0;
586 -- Initialize the preprocessor hooks
589 (Error_Msg => Errout.Error_Msg'Access,
590 Scan => Scn.Scanner.Scan'Access,
591 Set_Ignore_Errors => Errout.Set_Ignore_Errors'Access,
592 Put_Char => Put_Char_In_Prep_Buffer'Access,
593 New_EOL => New_EOL_In_Prep_Buffer'Access);
595 -- Initialize scanner and set its behavior for preprocessing,
596 -- then preprocess. Also disable style checks, since some of
597 -- them are done in the scanner (specifically, those dealing
598 -- with line length and line termination), and cannot be done
599 -- during preprocessing (because the source file index table
600 -- has not been set yet).
602 Scn.Scanner.Initialize_Scanner (X);
604 Scn.Scanner.Set_Special_Character ('#
');
605 Scn.Scanner.Set_Special_Character ('$
');
606 Scn.Scanner.Set_End_Of_Line_As_Token (True);
607 Save_Style_Check := Opt.Style_Check;
608 Opt.Style_Check := False;
610 -- The actual preprocessing step
612 Preprocess (Modified);
614 -- Reset the scanner to its standard behavior, and restore the
615 -- Style_Checks flag.
617 Scn.Scanner.Reset_Special_Characters;
618 Scn.Scanner.Set_End_Of_Line_As_Token (False);
619 Opt.Style_Check := Save_Style_Check;
621 -- If there were errors during preprocessing, record an error
622 -- at the start of the file, and do not change the source
625 if T /= Total_Errors_Detected then
627 ("file could not be successfully preprocessed", Lo);
628 return No_Source_File;
631 -- Output the result of the preprocessing, if requested and
632 -- the source has been modified by the preprocessing. Only
633 -- do that for the main unit (spec, body and subunits).
635 if Generate_Processed_File
638 ((Compiler_State = Parsing
639 and then Parsing_Main_Extended_Source)
641 (Compiler_State = Analyzing
642 and then Analysing_Subunit_Of_Main))
645 FD : File_Descriptor;
651 Add_Str_To_Name_Buffer (Prep_Suffix);
653 Delete_File (Name_Buffer (1 .. Name_Len), Status);
656 Create_New_File (Name_Buffer (1 .. Name_Len), Text);
658 Status := FD /= Invalid_FD;
664 Prep_Buffer (1)'Address,
665 Integer (Prep_Buffer_Last));
666 Status := NB = Integer (Prep_Buffer_Last);
675 ("??could not write processed file """ &
676 Name_Buffer (1 .. Name_Len) & '"',
682 -- Set the new value of Hi
684 Hi := Lo + Source_Ptr (Prep_Buffer_Last);
686 -- Create the new source buffer
689 Var_Ptr : constant Source_Buffer_Ptr_Var :=
690 new Source_Buffer (Lo .. Hi);
691 -- Allocate source buffer, allowing extra character at
695 Var_Ptr (Lo .. Hi - 1) :=
696 Prep_Buffer (1 .. Prep_Buffer_Last);
698 Src := Var_Ptr.all'Access;
701 -- Record in the table the new source buffer and the
704 Source_File.Table (X).Source_Text := Src;
705 Source_File.Table (X).Source_Last := Hi;
707 -- Reset Last_Line to 1, because the lines do not
708 -- have necessarily the same starts and lengths.
710 Source_File.Table (X).Last_Source_Line := 1;
715 Set_Source_File_Index_Table (X);
720 ----------------------------------
721 -- Load_Preprocessing_Data_File --
722 ----------------------------------
724 function Load_Preprocessing_Data_File
725 (N : File_Name_Type) return Source_File_Index
728 return Load_File (N, Osint.Preprocessing_Data);
729 end Load_Preprocessing_Data_File;
731 ----------------------
732 -- Load_Source_File --
733 ----------------------
735 function Load_Source_File
736 (N : File_Name_Type) return Source_File_Index
739 return Load_File (N, Osint.Source);
740 end Load_Source_File;
742 ----------------------------
743 -- New_EOL_In_Prep_Buffer --
744 ----------------------------
746 procedure New_EOL_In_Prep_Buffer is
748 Put_Char_In_Prep_Buffer (ASCII.LF);
749 end New_EOL_In_Prep_Buffer;
751 -----------------------------
752 -- Put_Char_In_Prep_Buffer --
753 -----------------------------
755 procedure Put_Char_In_Prep_Buffer (C : Character) is
757 -- If preprocessing buffer is not large enough, double it
759 if Prep_Buffer_Last = Prep_Buffer'Last then
761 New_Prep_Buffer : constant Text_Buffer_Ptr :=
762 new Text_Buffer (1 .. 2 * Prep_Buffer_Last);
765 New_Prep_Buffer (Prep_Buffer'Range) := Prep_Buffer.all;
767 Prep_Buffer := New_Prep_Buffer;
771 Prep_Buffer_Last := Prep_Buffer_Last + 1;
772 Prep_Buffer (Prep_Buffer_Last) := C;
773 end Put_Char_In_Prep_Buffer;
775 -------------------------
776 -- Source_File_Is_Body --
777 -------------------------
779 function Source_File_Is_Body (X : Source_File_Index) return Boolean is
783 Initialize_Scanner (No_Unit, X);
785 -- Loop to look for subprogram or package body
790 -- PRAGMA, WITH, USE (which can appear before a body)
796 -- We just want to skip any of these, do it by skipping to a
797 -- semicolon, but check for EOF, in case we have bad syntax.
800 if Token = Tok_Semicolon then
803 elsif Token = Tok_EOF then
813 Scan; -- Past PACKAGE
815 -- We have a body if and only if BODY follows
817 return Token = Tok_Body;
819 -- FUNCTION or PROCEDURE
826 -- Loop through tokens following PROCEDURE or FUNCTION
833 -- For parens, count paren level (note that paren level
834 -- can get greater than 1 if we have default parameters).
836 when Tok_Left_Paren =>
837 Pcount := Pcount + 1;
839 when Tok_Right_Paren =>
840 Pcount := Pcount - 1;
842 -- EOF means something weird, probably no body
847 -- BEGIN or IS or END definitely means body is present
855 -- Semicolon means no body present if at outside any
856 -- parens. If within parens, ignore, since it could be
857 -- a parameter separator.
859 when Tok_Semicolon =>
864 -- Skip anything else
871 -- Anything else in main scan means we don't have a body
877 end Source_File_Is_Body;
879 ----------------------------
880 -- Source_File_Is_No_Body --
881 ----------------------------
883 function Source_File_Is_No_Body (X : Source_File_Index) return Boolean is
885 Initialize_Scanner (No_Unit, X);
887 if Token /= Tok_Pragma then
893 if Token /= Tok_Identifier
894 or else Chars (Token_Node) /= Name_No_Body
899 Scan; -- past No_Body
901 if Token /= Tok_Semicolon then
905 Scan; -- past semicolon
907 return Token = Tok_EOF;
908 end Source_File_Is_No_Body;