1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
26 ------------------------------------------------------------------------------
29 with Atree; use Atree;
30 with Debug; use Debug;
31 with Einfo; use Einfo;
32 with Namet; use Namet;
34 with Osint; use Osint;
35 with Output; use Output;
36 with Scans; use Scans;
38 with Sinfo; use Sinfo;
39 with System; use System;
41 with Unchecked_Conversion;
43 package body Sinput.L is
45 -- Routines to support conversion between types Lines_Table_Ptr
46 -- and System.Address.
55 return Source_File_Index;
56 -- Load a source file or a configuration pragma file.
58 -------------------------------
59 -- Adjust_Instantiation_Sloc --
60 -------------------------------
62 procedure Adjust_Instantiation_Sloc (N : Node_Id; A : Sloc_Adjustment) is
63 Loc : constant Source_Ptr := Sloc (N);
66 -- We only do the adjustment if the value is between the appropriate
67 -- low and high values. It is not clear that this should ever not be
68 -- the case, but in practice there seem to be some nodes that get
69 -- copied twice, and this is a defence against that happening.
71 if A.Lo <= Loc and then Loc <= A.Hi then
72 Set_Sloc (N, Loc + A.Adjust);
74 end Adjust_Instantiation_Sloc;
76 --------------------------------
77 -- Complete_Source_File_Entry --
78 --------------------------------
80 procedure Complete_Source_File_Entry is
81 CSF : constant Source_File_Index := Current_Source_File;
84 Trim_Lines_Table (CSF);
85 Source_File.Table (CSF).Source_Checksum := Checksum;
86 end Complete_Source_File_Entry;
88 ---------------------------------
89 -- Create_Instantiation_Source --
90 ---------------------------------
92 procedure Create_Instantiation_Source
93 (Inst_Node : Entity_Id;
94 Template_Id : Entity_Id;
95 A : out Sloc_Adjustment)
97 Dnod : constant Node_Id := Declaration_Node (Template_Id);
98 Xold : Source_File_Index;
99 Xnew : Source_File_Index;
102 Xold := Get_Source_File_Index (Sloc (Template_Id));
103 A.Lo := Source_File.Table (Xold).Source_First;
104 A.Hi := Source_File.Table (Xold).Source_Last;
106 Source_File.Increment_Last;
107 Xnew := Source_File.Last;
109 Source_File.Table (Xnew) := Source_File.Table (Xold);
110 Source_File.Table (Xnew).Instantiation := Sloc (Inst_Node);
111 Source_File.Table (Xnew).Template := Xold;
113 -- Now we need to compute the new values of Source_First, Source_Last
114 -- and adjust the source file pointer to have the correct virtual
115 -- origin for the new range of values.
117 Source_File.Table (Xnew).Source_First :=
118 Source_File.Table (Xnew - 1).Source_Last + 1;
120 A.Adjust := Source_File.Table (Xnew).Source_First - A.Lo;
121 Source_File.Table (Xnew).Source_Last := A.Hi + A.Adjust;
123 Source_File.Table (Xnew).Sloc_Adjust :=
124 Source_File.Table (Xold).Sloc_Adjust - A.Adjust;
128 Write_Str ("*** Create instantiation source for ");
130 if Nkind (Dnod) in N_Proper_Body
131 and then Was_Originally_Stub (Dnod)
133 Write_Str ("subunit ");
135 elsif Ekind (Template_Id) = E_Generic_Package then
136 if Nkind (Dnod) = N_Package_Body then
137 Write_Str ("body of package ");
139 Write_Str ("spec of package ");
142 elsif Ekind (Template_Id) = E_Function then
143 Write_Str ("body of function ");
145 elsif Ekind (Template_Id) = E_Procedure then
146 Write_Str ("body of procedure ");
148 elsif Ekind (Template_Id) = E_Generic_Function then
149 Write_Str ("spec of function ");
151 elsif Ekind (Template_Id) = E_Generic_Procedure then
152 Write_Str ("spec of procedure ");
154 elsif Ekind (Template_Id) = E_Package_Body then
155 Write_Str ("body of package ");
157 else pragma Assert (Ekind (Template_Id) = E_Subprogram_Body);
159 if Nkind (Dnod) = N_Procedure_Specification then
160 Write_Str ("body of procedure ");
162 Write_Str ("body of function ");
166 Write_Name (Chars (Template_Id));
169 Write_Str (" new source index = ");
170 Write_Int (Int (Xnew));
173 Write_Str (" copying from file name = ");
174 Write_Name (File_Name (Xold));
177 Write_Str (" old source index = ");
178 Write_Int (Int (Xold));
181 Write_Str (" old lo = ");
182 Write_Int (Int (A.Lo));
185 Write_Str (" old hi = ");
186 Write_Int (Int (A.Hi));
189 Write_Str (" new lo = ");
190 Write_Int (Int (Source_File.Table (Xnew).Source_First));
193 Write_Str (" new hi = ");
194 Write_Int (Int (Source_File.Table (Xnew).Source_Last));
197 Write_Str (" adjustment factor = ");
198 Write_Int (Int (A.Adjust));
201 Write_Str (" instantiation location: ");
202 Write_Location (Sloc (Inst_Node));
206 -- For a given character in the source, a higher subscript will be
207 -- used to access the instantiation, which means that the virtual
208 -- origin must have a corresponding lower value. We compute this
209 -- new origin by taking the address of the appropriate adjusted
210 -- element in the old array. Since this adjusted element will be
211 -- at a negative subscript, we must suppress checks.
214 pragma Suppress (All_Checks);
216 function To_Source_Buffer_Ptr is new
217 Unchecked_Conversion (Address, Source_Buffer_Ptr);
220 Source_File.Table (Xnew).Source_Text :=
222 (Source_File.Table (Xold).Source_Text (-A.Adjust)'Address);
225 end Create_Instantiation_Source;
227 ----------------------
228 -- Load_Config_File --
229 ----------------------
231 function Load_Config_File
233 return Source_File_Index
236 return Load_File (N, Osint.Config);
237 end Load_Config_File;
246 return Source_File_Index
248 Src : Source_Buffer_Ptr;
249 X : Source_File_Index;
254 for J in 1 .. Source_File.Last loop
255 if Source_File.Table (J).File_Name = N then
260 -- Here we must build a new entry in the file table
262 Source_File.Increment_Last;
263 X := Source_File.Last;
265 if X = Source_File.First then
266 Lo := First_Source_Ptr;
268 Lo := Source_File.Table (X - 1).Source_Last + 1;
271 Read_Source_File (N, Lo, Hi, Src, T);
274 Source_File.Decrement_Last;
275 return No_Source_File;
280 Write_Str ("*** Build source file table entry, Index = ");
282 Write_Str (", file name = ");
285 Write_Str (" lo = ");
286 Write_Int (Int (Lo));
288 Write_Str (" hi = ");
289 Write_Int (Int (Hi));
292 Write_Str (" first 10 chars -->");
295 procedure Wchar (C : Character);
296 -- Writes character or ? for control character
298 procedure Wchar (C : Character) is
300 if C < ' ' or C in ASCII.DEL .. Character'Val (16#9F#) then
308 for J in Lo .. Lo + 9 loop
315 Write_Str (" last 10 chars -->");
317 for J in Hi - 10 .. Hi - 1 loop
324 if Src (Hi) /= EOF then
325 Write_Str (" error: no EOF at end");
332 S : Source_File_Record renames Source_File.Table (X);
335 S := (Debug_Source_Name => Full_Source_Name,
337 First_Mapped_Line => No_Line_Number,
338 Full_File_Name => Full_Source_Name,
339 Full_Ref_Name => Full_Source_Name,
340 Identifier_Casing => Unknown,
341 Instantiation => No_Location,
342 Keyword_Casing => Unknown,
343 Last_Source_Line => 1,
346 Lines_Table_Max => 1,
347 Logical_Lines_Table => null,
348 Num_SRef_Pragmas => 0,
351 Source_Checksum => 0,
355 Template => No_Source_File,
356 Time_Stamp => Current_Source_File_Stamp);
358 Alloc_Line_Tables (S, Opt.Table_Factor * Alloc.Lines_Initial);
359 S.Lines_Table (1) := Lo;
366 ----------------------
367 -- Load_Source_File --
368 ----------------------
370 function Load_Source_File
372 return Source_File_Index
375 return Load_File (N, Osint.Source);
376 end Load_Source_File;
378 ----------------------------
379 -- Source_File_Is_Subunit --
380 ----------------------------
382 function Source_File_Is_Subunit (X : Source_File_Index) return Boolean is
384 Initialize_Scanner (No_Unit, X);
386 -- We scan past junk to the first interesting compilation unit
387 -- token, to see if it is SEPARATE. We ignore WITH keywords during
388 -- this and also PRIVATE. The reason for ignoring PRIVATE is that
389 -- it handles some error situations, and also it is possible that
390 -- a PRIVATE WITH feature might be approved some time in the future.
392 while Token = Tok_With
393 or else Token = Tok_Private
394 or else (Token not in Token_Class_Cunit and then Token /= Tok_EOF)
399 return Token = Tok_Separate;
400 end Source_File_Is_Subunit;