1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2007, 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 indicationg 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.
77 -- Used to initialize the preprocessor.
81 T
: Osint
.File_Type
) return Source_File_Index
;
82 -- Load a source file, a configuration pragmas file or a definition file
83 -- Coding also allows preprocessing file, but not a library file ???
85 -------------------------------
86 -- Adjust_Instantiation_Sloc --
87 -------------------------------
89 procedure Adjust_Instantiation_Sloc
(N
: Node_Id
; A
: Sloc_Adjustment
) is
90 Loc
: constant Source_Ptr
:= Sloc
(N
);
93 -- We only do the adjustment if the value is between the appropriate
94 -- low and high values. It is not clear that this should ever not be
95 -- the case, but in practice there seem to be some nodes that get
96 -- copied twice, and this is a defence against that happening.
98 if A
.Lo
<= Loc
and then Loc
<= A
.Hi
then
99 Set_Sloc
(N
, Loc
+ A
.Adjust
);
101 end Adjust_Instantiation_Sloc
;
103 --------------------------------
104 -- Complete_Source_File_Entry --
105 --------------------------------
107 procedure Complete_Source_File_Entry
is
108 CSF
: constant Source_File_Index
:= Current_Source_File
;
111 Trim_Lines_Table
(CSF
);
112 Source_File
.Table
(CSF
).Source_Checksum
:= Checksum
;
113 end Complete_Source_File_Entry
;
115 ---------------------------------
116 -- Create_Instantiation_Source --
117 ---------------------------------
119 procedure Create_Instantiation_Source
120 (Inst_Node
: Entity_Id
;
121 Template_Id
: Entity_Id
;
122 Inlined_Body
: Boolean;
123 A
: out Sloc_Adjustment
)
125 Dnod
: constant Node_Id
:= Declaration_Node
(Template_Id
);
126 Xold
: Source_File_Index
;
127 Xnew
: Source_File_Index
;
130 Xold
:= Get_Source_File_Index
(Sloc
(Template_Id
));
131 A
.Lo
:= Source_File
.Table
(Xold
).Source_First
;
132 A
.Hi
:= Source_File
.Table
(Xold
).Source_Last
;
134 Source_File
.Append
(Source_File
.Table
(Xold
));
135 Xnew
:= Source_File
.Last
;
137 Source_File
.Table
(Xnew
).Inlined_Body
:= Inlined_Body
;
138 Source_File
.Table
(Xnew
).Instantiation
:= Sloc
(Inst_Node
);
139 Source_File
.Table
(Xnew
).Template
:= Xold
;
141 -- Now we need to compute the new values of Source_First, Source_Last
142 -- and adjust the source file pointer to have the correct virtual
143 -- origin for the new range of values.
145 Source_File
.Table
(Xnew
).Source_First
:=
146 Source_File
.Table
(Xnew
- 1).Source_Last
+ 1;
147 A
.Adjust
:= Source_File
.Table
(Xnew
).Source_First
- A
.Lo
;
148 Source_File
.Table
(Xnew
).Source_Last
:= A
.Hi
+ A
.Adjust
;
150 Set_Source_File_Index_Table
(Xnew
);
152 Source_File
.Table
(Xnew
).Sloc_Adjust
:=
153 Source_File
.Table
(Xold
).Sloc_Adjust
- A
.Adjust
;
157 Write_Str
("*** Create instantiation source for ");
159 if Nkind
(Dnod
) in N_Proper_Body
160 and then Was_Originally_Stub
(Dnod
)
162 Write_Str
("subunit ");
164 elsif Ekind
(Template_Id
) = E_Generic_Package
then
165 if Nkind
(Dnod
) = N_Package_Body
then
166 Write_Str
("body of package ");
168 Write_Str
("spec of package ");
171 elsif Ekind
(Template_Id
) = E_Function
then
172 Write_Str
("body of function ");
174 elsif Ekind
(Template_Id
) = E_Procedure
then
175 Write_Str
("body of procedure ");
177 elsif Ekind
(Template_Id
) = E_Generic_Function
then
178 Write_Str
("spec of function ");
180 elsif Ekind
(Template_Id
) = E_Generic_Procedure
then
181 Write_Str
("spec of procedure ");
183 elsif Ekind
(Template_Id
) = E_Package_Body
then
184 Write_Str
("body of package ");
186 else pragma Assert
(Ekind
(Template_Id
) = E_Subprogram_Body
);
188 if Nkind
(Dnod
) = N_Procedure_Specification
then
189 Write_Str
("body of procedure ");
191 Write_Str
("body of function ");
195 Write_Name
(Chars
(Template_Id
));
198 Write_Str
(" new source index = ");
199 Write_Int
(Int
(Xnew
));
202 Write_Str
(" copying from file name = ");
203 Write_Name
(File_Name
(Xold
));
206 Write_Str
(" old source index = ");
207 Write_Int
(Int
(Xold
));
210 Write_Str
(" old lo = ");
211 Write_Int
(Int
(A
.Lo
));
214 Write_Str
(" old hi = ");
215 Write_Int
(Int
(A
.Hi
));
218 Write_Str
(" new lo = ");
219 Write_Int
(Int
(Source_File
.Table
(Xnew
).Source_First
));
222 Write_Str
(" new hi = ");
223 Write_Int
(Int
(Source_File
.Table
(Xnew
).Source_Last
));
226 Write_Str
(" adjustment factor = ");
227 Write_Int
(Int
(A
.Adjust
));
230 Write_Str
(" instantiation location: ");
231 Write_Location
(Sloc
(Inst_Node
));
235 -- For a given character in the source, a higher subscript will be
236 -- used to access the instantiation, which means that the virtual
237 -- origin must have a corresponding lower value. We compute this
238 -- new origin by taking the address of the appropriate adjusted
239 -- element in the old array. Since this adjusted element will be
240 -- at a negative subscript, we must suppress checks.
243 pragma Suppress
(All_Checks
);
245 pragma Warnings
(Off
);
246 -- This unchecked conversion is aliasing safe, since it is never
247 -- used to create improperly aliased pointer values.
249 function To_Source_Buffer_Ptr
is new
250 Unchecked_Conversion
(Address
, Source_Buffer_Ptr
);
252 pragma Warnings
(On
);
255 Source_File
.Table
(Xnew
).Source_Text
:=
257 (Source_File
.Table
(Xold
).Source_Text
(-A
.Adjust
)'Address);
259 end Create_Instantiation_Source
;
261 ----------------------
262 -- Load_Config_File --
263 ----------------------
265 function Load_Config_File
266 (N
: File_Name_Type
) return Source_File_Index
269 return Load_File
(N
, Osint
.Config
);
270 end Load_Config_File
;
272 --------------------------
273 -- Load_Definition_File --
274 --------------------------
276 function Load_Definition_File
277 (N
: File_Name_Type
) return Source_File_Index
280 return Load_File
(N
, Osint
.Definition
);
281 end Load_Definition_File
;
289 T
: Osint
.File_Type
) return Source_File_Index
291 Src
: Source_Buffer_Ptr
;
292 X
: Source_File_Index
;
296 Preprocessing_Needed
: Boolean := False;
299 -- If already there, don't need to reload file. An exception occurs
300 -- in multiple unit per file mode. It would be nice in this case to
301 -- share the same source file for each unit, but this leads to many
302 -- difficulties with assumptions (e.g. in the body of lib), that a
303 -- unit can be found by locating its source file index. Since we do
304 -- not expect much use of this mode, it's no big deal to waste a bit
305 -- of space and time by reading and storing the source multiple times.
307 if Multiple_Unit_Index
= 0 then
308 for J
in 1 .. Source_File
.Last
loop
309 if Source_File
.Table
(J
).File_Name
= N
then
315 -- Here we must build a new entry in the file table
317 -- But first, we must check if a source needs to be preprocessed,
318 -- because we may have to load and parse a definition file, and we want
319 -- to do that before we load the source, so that the buffer of the
320 -- source will be the last created, and we will be able to replace it
321 -- and modify Hi without stepping on another buffer.
323 if T
= Osint
.Source
then
324 Prepare_To_Preprocess
325 (Source
=> N
, Preprocessing_Needed
=> Preprocessing_Needed
);
328 Source_File
.Increment_Last
;
329 X
:= Source_File
.Last
;
331 if X
= Source_File
.First
then
332 Lo
:= First_Source_Ptr
;
334 Lo
:= Source_File
.Table
(X
- 1).Source_Last
+ 1;
337 Osint
.Read_Source_File
(N
, Lo
, Hi
, Src
, T
);
340 Source_File
.Decrement_Last
;
341 return No_Source_File
;
346 Write_Str
("*** Build source file table entry, Index = ");
348 Write_Str
(", file name = ");
351 Write_Str
(" lo = ");
352 Write_Int
(Int
(Lo
));
354 Write_Str
(" hi = ");
355 Write_Int
(Int
(Hi
));
358 Write_Str
(" first 10 chars -->");
361 procedure Wchar
(C
: Character);
362 -- Writes character or ? for control character
364 procedure Wchar
(C
: Character) is
366 if C
< ' ' or C
in ASCII
.DEL
.. Character'Val (16#
9F#
) then
374 for J
in Lo
.. Lo
+ 9 loop
381 Write_Str
(" last 10 chars -->");
383 for J
in Hi
- 10 .. Hi
- 1 loop
390 if Src
(Hi
) /= EOF
then
391 Write_Str
(" error: no EOF at end");
398 S
: Source_File_Record
renames Source_File
.Table
(X
);
399 File_Type
: Type_Of_File
;
404 File_Type
:= Sinput
.Src
;
406 when Osint
.Library
=>
410 File_Type
:= Sinput
.Config
;
412 when Osint
.Definition
=>
415 when Osint
.Preprocessing_Data
=>
416 File_Type
:= Preproc
;
419 S
:= (Debug_Source_Name
=> N
,
421 File_Type
=> File_Type
,
422 First_Mapped_Line
=> No_Line_Number
,
423 Full_Debug_Name
=> Osint
.Full_Source_Name
,
424 Full_File_Name
=> Osint
.Full_Source_Name
,
425 Full_Ref_Name
=> Osint
.Full_Source_Name
,
426 Identifier_Casing
=> Unknown
,
427 Inlined_Body
=> False,
428 Instantiation
=> No_Location
,
429 Keyword_Casing
=> Unknown
,
430 Last_Source_Line
=> 1,
433 Lines_Table_Max
=> 1,
434 Logical_Lines_Table
=> null,
435 Num_SRef_Pragmas
=> 0,
438 Source_Checksum
=> 0,
442 Template
=> No_Source_File
,
444 Time_Stamp
=> Osint
.Current_Source_File_Stamp
);
446 Alloc_Line_Tables
(S
, Opt
.Table_Factor
* Alloc
.Lines_Initial
);
447 S
.Lines_Table
(1) := Lo
;
450 -- Preprocess the source if it needs to be preprocessed
452 if Preprocessing_Needed
then
453 if Opt
.List_Preprocessing_Symbols
then
457 Foreword
: String (1 .. Foreword_Start
'Length +
458 Name_Len
+ Foreword_End
'Length);
461 Foreword
(1 .. Foreword_Start
'Length) := Foreword_Start
;
462 Foreword
(Foreword_Start
'Length + 1 ..
463 Foreword_Start
'Length + Name_Len
) :=
464 Name_Buffer
(1 .. Name_Len
);
465 Foreword
(Foreword
'Last - Foreword_End
'Length + 1 ..
466 Foreword
'Last) := Foreword_End
;
467 Prep
.List_Symbols
(Foreword
);
472 T
: constant Nat
:= Total_Errors_Detected
;
473 -- Used to check if there were errors during preprocessing
476 -- If this is the first time we preprocess a source, allocate
477 -- the preprocessing buffer.
479 if Prep_Buffer
= null then
481 new Text_Buffer
(1 .. Initial_Size_Of_Prep_Buffer
);
484 -- Make sure the preprocessing buffer is empty
486 Prep_Buffer_Last
:= 0;
488 -- Initialize the preprocessor
491 (Error_Msg
=> Errout
.Error_Msg
'Access,
492 Scan
=> Scn
.Scanner
.Scan
'Access,
493 Set_Ignore_Errors
=> Errout
.Set_Ignore_Errors
'Access,
494 Put_Char
=> Put_Char_In_Prep_Buffer
'Access,
495 New_EOL
=> New_EOL_In_Prep_Buffer
'Access);
497 -- Initialize the scanner and set its behavior for
498 -- preprocessing, then preprocess.
500 Scn
.Scanner
.Initialize_Scanner
(X
);
502 Scn
.Scanner
.Set_Special_Character
('#');
503 Scn
.Scanner
.Set_Special_Character
('$');
504 Scn
.Scanner
.Set_End_Of_Line_As_Token
(True);
508 -- Reset the scanner to its standard behavior
510 Scn
.Scanner
.Reset_Special_Characters
;
511 Scn
.Scanner
.Set_End_Of_Line_As_Token
(False);
513 -- If there were errors during preprocessing, record an
514 -- error at the start of the file, and do not change the
517 if T
/= Total_Errors_Detected
then
519 ("file could not be successfully preprocessed", Lo
);
520 return No_Source_File
;
523 -- Set the new value of Hi
525 Hi
:= Lo
+ Source_Ptr
(Prep_Buffer_Last
);
527 -- Create the new source buffer
530 subtype Actual_Source_Buffer
is Source_Buffer
(Lo
.. Hi
);
531 -- Physical buffer allocated
533 type Actual_Source_Ptr
is access Actual_Source_Buffer
;
534 -- This is the pointer type for the physical buffer
537 Actual_Ptr
: constant Actual_Source_Ptr
:=
538 new Actual_Source_Buffer
;
539 -- And this is the actual physical buffer
542 Actual_Ptr
(Lo
.. Hi
- 1) :=
543 Prep_Buffer
(1 .. Prep_Buffer_Last
);
544 Actual_Ptr
(Hi
) := EOF
;
546 -- Now we need to work out the proper virtual origin
547 -- pointer to return. This is exactly
548 -- Actual_Ptr (0)'Address, but we have to be careful to
549 -- suppress checks to compute this address.
552 pragma Suppress
(All_Checks
);
554 pragma Warnings
(Off
);
555 -- This unchecked conversion is aliasing safe, since
556 -- it is never used to create improperly aliased
559 function To_Source_Buffer_Ptr
is new
560 Unchecked_Conversion
(Address
, Source_Buffer_Ptr
);
562 pragma Warnings
(On
);
565 Src
:= To_Source_Buffer_Ptr
(Actual_Ptr
(0)'Address);
567 -- Record in the table the new source buffer and the
570 Source_File
.Table
(X
).Source_Text
:= Src
;
571 Source_File
.Table
(X
).Source_Last
:= Hi
;
573 -- Reset Last_Line to 1, because the lines do not
574 -- have neccessarily the same starts and lengths.
576 Source_File
.Table
(X
).Last_Source_Line
:= 1;
583 Set_Source_File_Index_Table
(X
);
588 ----------------------------------
589 -- Load_Preprocessing_Data_File --
590 ----------------------------------
592 function Load_Preprocessing_Data_File
593 (N
: File_Name_Type
) return Source_File_Index
596 return Load_File
(N
, Osint
.Preprocessing_Data
);
597 end Load_Preprocessing_Data_File
;
599 ----------------------
600 -- Load_Source_File --
601 ----------------------
603 function Load_Source_File
604 (N
: File_Name_Type
) return Source_File_Index
607 return Load_File
(N
, Osint
.Source
);
608 end Load_Source_File
;
610 ----------------------------
611 -- New_EOL_In_Prep_Buffer --
612 ----------------------------
614 procedure New_EOL_In_Prep_Buffer
is
616 Put_Char_In_Prep_Buffer
(ASCII
.LF
);
617 end New_EOL_In_Prep_Buffer
;
619 -----------------------------
620 -- Put_Char_In_Prep_Buffer --
621 -----------------------------
623 procedure Put_Char_In_Prep_Buffer
(C
: Character) is
625 -- If preprocessing buffer is not large enough, double it
627 if Prep_Buffer_Last
= Prep_Buffer
'Last then
629 New_Prep_Buffer
: constant Text_Buffer_Ptr
:=
630 new Text_Buffer
(1 .. 2 * Prep_Buffer_Last
);
633 New_Prep_Buffer
(Prep_Buffer
'Range) := Prep_Buffer
.all;
635 Prep_Buffer
:= New_Prep_Buffer
;
639 Prep_Buffer_Last
:= Prep_Buffer_Last
+ 1;
640 Prep_Buffer
(Prep_Buffer_Last
) := C
;
641 end Put_Char_In_Prep_Buffer
;
643 -----------------------------------
644 -- Source_File_Is_Pragma_No_Body --
645 -----------------------------------
647 function Source_File_Is_No_Body
(X
: Source_File_Index
) return Boolean is
649 Initialize_Scanner
(No_Unit
, X
);
651 if Token
/= Tok_Pragma
then
657 if Token
/= Tok_Identifier
658 or else Chars
(Token_Node
) /= Name_No_Body
663 Scan
; -- past No_Body
665 if Token
/= Tok_Semicolon
then
669 Scan
; -- past semicolon
671 return Token
= Tok_EOF
;
672 end Source_File_Is_No_Body
;
674 ----------------------------
675 -- Source_File_Is_Subunit --
676 ----------------------------
678 function Source_File_Is_Subunit
(X
: Source_File_Index
) return Boolean is
680 Initialize_Scanner
(No_Unit
, X
);
682 -- We scan past junk to the first interesting compilation unit
683 -- token, to see if it is SEPARATE. We ignore WITH keywords during
684 -- this and also PRIVATE. The reason for ignoring PRIVATE is that
685 -- it handles some error situations, and also to handle PRIVATE WITH
688 while Token
= Tok_With
689 or else Token
= Tok_Private
690 or else (Token
not in Token_Class_Cunit
and then Token
/= Tok_EOF
)
695 return Token
= Tok_Separate
;
696 end Source_File_Is_Subunit
;