1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2002 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
28 with Atree
; use Atree
;
29 with Debug
; use Debug
;
30 with Einfo
; use Einfo
;
31 with Namet
; use Namet
;
33 with Osint
; use Osint
;
34 with Output
; use Output
;
35 with Scans
; use Scans
;
37 with Sinfo
; use Sinfo
;
38 with System
; use System
;
40 with Unchecked_Conversion
;
42 package body Sinput
.L
is
44 -- Routines to support conversion between types Lines_Table_Ptr
45 -- and System.Address.
54 return Source_File_Index
;
55 -- Load a source file or a configuration pragma file.
57 -------------------------------
58 -- Adjust_Instantiation_Sloc --
59 -------------------------------
61 procedure Adjust_Instantiation_Sloc
(N
: Node_Id
; A
: Sloc_Adjustment
) is
62 Loc
: constant Source_Ptr
:= Sloc
(N
);
65 -- We only do the adjustment if the value is between the appropriate
66 -- low and high values. It is not clear that this should ever not be
67 -- the case, but in practice there seem to be some nodes that get
68 -- copied twice, and this is a defence against that happening.
70 if A
.Lo
<= Loc
and then Loc
<= A
.Hi
then
71 Set_Sloc
(N
, Loc
+ A
.Adjust
);
73 end Adjust_Instantiation_Sloc
;
75 --------------------------------
76 -- Complete_Source_File_Entry --
77 --------------------------------
79 procedure Complete_Source_File_Entry
is
80 CSF
: constant Source_File_Index
:= Current_Source_File
;
83 Trim_Lines_Table
(CSF
);
84 Source_File
.Table
(CSF
).Source_Checksum
:= Checksum
;
85 end Complete_Source_File_Entry
;
87 ---------------------------------
88 -- Create_Instantiation_Source --
89 ---------------------------------
91 procedure Create_Instantiation_Source
92 (Inst_Node
: Entity_Id
;
93 Template_Id
: Entity_Id
;
94 A
: out Sloc_Adjustment
)
96 Dnod
: constant Node_Id
:= Declaration_Node
(Template_Id
);
97 Xold
: Source_File_Index
;
98 Xnew
: Source_File_Index
;
101 Xold
:= Get_Source_File_Index
(Sloc
(Template_Id
));
102 A
.Lo
:= Source_File
.Table
(Xold
).Source_First
;
103 A
.Hi
:= Source_File
.Table
(Xold
).Source_Last
;
105 Source_File
.Increment_Last
;
106 Xnew
:= Source_File
.Last
;
108 Source_File
.Table
(Xnew
) := Source_File
.Table
(Xold
);
109 Source_File
.Table
(Xnew
).Instantiation
:= Sloc
(Inst_Node
);
110 Source_File
.Table
(Xnew
).Template
:= Xold
;
112 -- Now we need to compute the new values of Source_First, Source_Last
113 -- and adjust the source file pointer to have the correct virtual
114 -- origin for the new range of values.
116 Source_File
.Table
(Xnew
).Source_First
:=
117 Source_File
.Table
(Xnew
- 1).Source_Last
+ 1;
119 A
.Adjust
:= Source_File
.Table
(Xnew
).Source_First
- A
.Lo
;
120 Source_File
.Table
(Xnew
).Source_Last
:= A
.Hi
+ A
.Adjust
;
122 Source_File
.Table
(Xnew
).Sloc_Adjust
:=
123 Source_File
.Table
(Xold
).Sloc_Adjust
- A
.Adjust
;
127 Write_Str
("*** Create instantiation source for ");
129 if Nkind
(Dnod
) in N_Proper_Body
130 and then Was_Originally_Stub
(Dnod
)
132 Write_Str
("subunit ");
134 elsif Ekind
(Template_Id
) = E_Generic_Package
then
135 if Nkind
(Dnod
) = N_Package_Body
then
136 Write_Str
("body of package ");
138 Write_Str
("spec of package ");
141 elsif Ekind
(Template_Id
) = E_Function
then
142 Write_Str
("body of function ");
144 elsif Ekind
(Template_Id
) = E_Procedure
then
145 Write_Str
("body of procedure ");
147 elsif Ekind
(Template_Id
) = E_Generic_Function
then
148 Write_Str
("spec of function ");
150 elsif Ekind
(Template_Id
) = E_Generic_Procedure
then
151 Write_Str
("spec of procedure ");
153 elsif Ekind
(Template_Id
) = E_Package_Body
then
154 Write_Str
("body of package ");
156 else pragma Assert
(Ekind
(Template_Id
) = E_Subprogram_Body
);
158 if Nkind
(Dnod
) = N_Procedure_Specification
then
159 Write_Str
("body of procedure ");
161 Write_Str
("body of function ");
165 Write_Name
(Chars
(Template_Id
));
168 Write_Str
(" new source index = ");
169 Write_Int
(Int
(Xnew
));
172 Write_Str
(" copying from file name = ");
173 Write_Name
(File_Name
(Xold
));
176 Write_Str
(" old source index = ");
177 Write_Int
(Int
(Xold
));
180 Write_Str
(" old lo = ");
181 Write_Int
(Int
(A
.Lo
));
184 Write_Str
(" old hi = ");
185 Write_Int
(Int
(A
.Hi
));
188 Write_Str
(" new lo = ");
189 Write_Int
(Int
(Source_File
.Table
(Xnew
).Source_First
));
192 Write_Str
(" new hi = ");
193 Write_Int
(Int
(Source_File
.Table
(Xnew
).Source_Last
));
196 Write_Str
(" adjustment factor = ");
197 Write_Int
(Int
(A
.Adjust
));
200 Write_Str
(" instantiation location: ");
201 Write_Location
(Sloc
(Inst_Node
));
205 -- For a given character in the source, a higher subscript will be
206 -- used to access the instantiation, which means that the virtual
207 -- origin must have a corresponding lower value. We compute this
208 -- new origin by taking the address of the appropriate adjusted
209 -- element in the old array. Since this adjusted element will be
210 -- at a negative subscript, we must suppress checks.
213 pragma Suppress
(All_Checks
);
215 function To_Source_Buffer_Ptr
is new
216 Unchecked_Conversion
(Address
, Source_Buffer_Ptr
);
219 Source_File
.Table
(Xnew
).Source_Text
:=
221 (Source_File
.Table
(Xold
).Source_Text
(-A
.Adjust
)'Address);
224 end Create_Instantiation_Source
;
226 ----------------------
227 -- Load_Config_File --
228 ----------------------
230 function Load_Config_File
232 return Source_File_Index
235 return Load_File
(N
, Osint
.Config
);
236 end Load_Config_File
;
245 return Source_File_Index
247 Src
: Source_Buffer_Ptr
;
248 X
: Source_File_Index
;
253 for J
in 1 .. Source_File
.Last
loop
254 if Source_File
.Table
(J
).File_Name
= N
then
259 -- Here we must build a new entry in the file table
261 Source_File
.Increment_Last
;
262 X
:= Source_File
.Last
;
264 if X
= Source_File
.First
then
265 Lo
:= First_Source_Ptr
;
267 Lo
:= Source_File
.Table
(X
- 1).Source_Last
+ 1;
270 Read_Source_File
(N
, Lo
, Hi
, Src
, T
);
273 Source_File
.Decrement_Last
;
274 return No_Source_File
;
279 Write_Str
("*** Build source file table entry, Index = ");
281 Write_Str
(", file name = ");
284 Write_Str
(" lo = ");
285 Write_Int
(Int
(Lo
));
287 Write_Str
(" hi = ");
288 Write_Int
(Int
(Hi
));
291 Write_Str
(" first 10 chars -->");
294 procedure Wchar
(C
: Character);
295 -- Writes character or ? for control character
297 procedure Wchar
(C
: Character) is
299 if C
< ' ' or C
in ASCII
.DEL
.. Character'Val (16#
9F#
) then
307 for J
in Lo
.. Lo
+ 9 loop
314 Write_Str
(" last 10 chars -->");
316 for J
in Hi
- 10 .. Hi
- 1 loop
323 if Src
(Hi
) /= EOF
then
324 Write_Str
(" error: no EOF at end");
331 S
: Source_File_Record
renames Source_File
.Table
(X
);
334 S
:= (Debug_Source_Name
=> Full_Source_Name
,
336 First_Mapped_Line
=> No_Line_Number
,
337 Full_File_Name
=> Full_Source_Name
,
338 Full_Ref_Name
=> Full_Source_Name
,
339 Identifier_Casing
=> Unknown
,
340 Instantiation
=> No_Location
,
341 Keyword_Casing
=> Unknown
,
342 Last_Source_Line
=> 1,
345 Lines_Table_Max
=> 1,
346 Logical_Lines_Table
=> null,
347 Num_SRef_Pragmas
=> 0,
350 Source_Checksum
=> 0,
354 Template
=> No_Source_File
,
355 Time_Stamp
=> Current_Source_File_Stamp
);
357 Alloc_Line_Tables
(S
, Opt
.Table_Factor
* Alloc
.Lines_Initial
);
358 S
.Lines_Table
(1) := Lo
;
365 ----------------------
366 -- Load_Source_File --
367 ----------------------
369 function Load_Source_File
371 return Source_File_Index
374 return Load_File
(N
, Osint
.Source
);
375 end Load_Source_File
;
377 ----------------------------
378 -- Source_File_Is_Subunit --
379 ----------------------------
381 function Source_File_Is_Subunit
(X
: Source_File_Index
) return Boolean is
383 Initialize_Scanner
(No_Unit
, X
);
385 -- We scan past junk to the first interesting compilation unit
386 -- token, to see if it is SEPARATE. We ignore WITH keywords during
387 -- this and also PRIVATE. The reason for ignoring PRIVATE is that
388 -- it handles some error situations, and also it is possible that
389 -- a PRIVATE WITH feature might be approved some time in the future.
391 while Token
= Tok_With
392 or else Token
= Tok_Private
393 or else (Token
not in Token_Class_Cunit
and then Token
/= Tok_EOF
)
398 return Token
= Tok_Separate
;
399 end Source_File_Is_Subunit
;