|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- S I N P U T --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
145
|
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
|
|
111
|
10 -- --
|
|
|
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. --
|
|
|
17 -- --
|
|
|
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
|
|
|
19 -- additional permissions described in the GCC Runtime Library Exception, --
|
|
|
20 -- version 3.1, as published by the Free Software Foundation. --
|
|
|
21 -- --
|
|
|
22 -- You should have received a copy of the GNU General Public License and --
|
|
|
23 -- a copy of the GCC Runtime Library Exception along with this program; --
|
|
|
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
|
|
25 -- <http://www.gnu.org/licenses/>. --
|
|
|
26 -- --
|
|
|
27 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
29 -- --
|
|
|
30 ------------------------------------------------------------------------------
|
|
|
31
|
|
|
32 pragma Style_Checks (All_Checks);
|
|
|
33 -- Subprograms not all in alpha order
|
|
|
34
|
|
|
35 with Atree; use Atree;
|
|
|
36 with Debug; use Debug;
|
|
|
37 with Opt; use Opt;
|
|
|
38 with Output; use Output;
|
|
|
39 with Scans; use Scans;
|
|
|
40 with Tree_IO; use Tree_IO;
|
|
|
41 with Widechar; use Widechar;
|
|
|
42
|
|
|
43 with GNAT.Byte_Order_Mark; use GNAT.Byte_Order_Mark;
|
|
|
44
|
|
|
45 with System.Storage_Elements;
|
|
|
46 with System.Memory;
|
|
|
47 with System.WCh_Con; use System.WCh_Con;
|
|
|
48
|
|
|
49 with Unchecked_Conversion;
|
|
|
50 with Unchecked_Deallocation;
|
|
|
51
|
|
|
52 package body Sinput is
|
|
|
53
|
|
|
54 use ASCII, System;
|
|
|
55
|
|
|
56 -- Routines to support conversion between types Lines_Table_Ptr,
|
|
|
57 -- Logical_Lines_Table_Ptr and System.Address.
|
|
|
58
|
|
|
59 pragma Warnings (Off);
|
|
|
60 -- These unchecked conversions are aliasing safe, since they are never
|
|
|
61 -- used to construct improperly aliased pointer values.
|
|
|
62
|
|
|
63 function To_Address is
|
|
|
64 new Unchecked_Conversion (Lines_Table_Ptr, Address);
|
|
|
65
|
|
|
66 function To_Address is
|
|
|
67 new Unchecked_Conversion (Logical_Lines_Table_Ptr, Address);
|
|
|
68
|
|
|
69 function To_Pointer is
|
|
|
70 new Unchecked_Conversion (Address, Lines_Table_Ptr);
|
|
|
71
|
|
|
72 function To_Pointer is
|
|
|
73 new Unchecked_Conversion (Address, Logical_Lines_Table_Ptr);
|
|
|
74
|
|
|
75 pragma Warnings (On);
|
|
|
76
|
|
|
77 -----------------------------
|
|
|
78 -- Source_File_Index_Table --
|
|
|
79 -----------------------------
|
|
|
80
|
|
|
81 -- The Get_Source_File_Index function is called very frequently. Earlier
|
|
|
82 -- versions cached a single entry, but then reverted to a serial search,
|
|
|
83 -- and this proved to be a significant source of inefficiency. We then
|
|
|
84 -- switched to using a table with a start point followed by a serial
|
|
|
85 -- search. Now we make sure source buffers are on a reasonable boundary
|
|
|
86 -- (see Types.Source_Align), and we can just use a direct look up in the
|
|
|
87 -- following table.
|
|
|
88
|
|
|
89 -- Note that this array is pretty large, but in most operating systems
|
|
|
90 -- it will not be allocated in physical memory unless it is actually used.
|
|
|
91
|
|
|
92 Source_File_Index_Table :
|
|
|
93 array (Int range 0 .. 1 + (Int'Last / Source_Align)) of Source_File_Index;
|
|
|
94
|
|
|
95 ---------------------------
|
|
|
96 -- Add_Line_Tables_Entry --
|
|
|
97 ---------------------------
|
|
|
98
|
|
|
99 procedure Add_Line_Tables_Entry
|
|
|
100 (S : in out Source_File_Record;
|
|
|
101 P : Source_Ptr)
|
|
|
102 is
|
|
|
103 LL : Physical_Line_Number;
|
|
|
104
|
|
|
105 begin
|
|
|
106 -- Reallocate the lines tables if necessary
|
|
|
107
|
|
|
108 -- Note: the reason we do not use the normal Table package
|
|
|
109 -- mechanism is that we have several of these tables. We could
|
|
|
110 -- use the new GNAT.Dynamic_Tables package and that would probably
|
|
|
111 -- be a good idea ???
|
|
|
112
|
|
|
113 if S.Last_Source_Line = S.Lines_Table_Max then
|
|
|
114 Alloc_Line_Tables
|
|
|
115 (S,
|
|
|
116 Int (S.Last_Source_Line) *
|
|
|
117 ((100 + Alloc.Lines_Increment) / 100));
|
|
|
118
|
|
|
119 if Debug_Flag_D then
|
|
|
120 Write_Str ("--> Reallocating lines table, size = ");
|
|
|
121 Write_Int (Int (S.Lines_Table_Max));
|
|
|
122 Write_Eol;
|
|
|
123 end if;
|
|
|
124 end if;
|
|
|
125
|
|
|
126 S.Last_Source_Line := S.Last_Source_Line + 1;
|
|
|
127 LL := S.Last_Source_Line;
|
|
|
128
|
|
|
129 S.Lines_Table (LL) := P;
|
|
|
130
|
|
|
131 -- Deal with setting new entry in logical lines table if one is
|
|
|
132 -- present. Note that there is always space (because the call to
|
|
|
133 -- Alloc_Line_Tables makes sure both tables are the same length),
|
|
|
134
|
|
|
135 if S.Logical_Lines_Table /= null then
|
|
|
136
|
|
|
137 -- We can always set the entry from the previous one, because
|
|
|
138 -- the processing for a Source_Reference pragma ensures that
|
|
|
139 -- at least one entry following the pragma is set up correctly.
|
|
|
140
|
|
|
141 S.Logical_Lines_Table (LL) := S.Logical_Lines_Table (LL - 1) + 1;
|
|
|
142 end if;
|
|
|
143 end Add_Line_Tables_Entry;
|
|
|
144
|
|
|
145 -----------------------
|
|
|
146 -- Alloc_Line_Tables --
|
|
|
147 -----------------------
|
|
|
148
|
|
|
149 procedure Alloc_Line_Tables
|
|
|
150 (S : in out Source_File_Record;
|
|
|
151 New_Max : Nat)
|
|
|
152 is
|
|
|
153 subtype size_t is Memory.size_t;
|
|
|
154
|
|
|
155 New_Table : Lines_Table_Ptr;
|
|
|
156
|
|
|
157 New_Logical_Table : Logical_Lines_Table_Ptr;
|
|
|
158
|
|
|
159 New_Size : constant size_t :=
|
|
|
160 size_t (New_Max * Lines_Table_Type'Component_Size /
|
|
|
161 Storage_Unit);
|
|
|
162
|
|
|
163 begin
|
|
|
164 if S.Lines_Table = null then
|
|
|
165 New_Table := To_Pointer (Memory.Alloc (New_Size));
|
|
|
166
|
|
|
167 else
|
|
|
168 New_Table :=
|
|
|
169 To_Pointer (Memory.Realloc (To_Address (S.Lines_Table), New_Size));
|
|
|
170 end if;
|
|
|
171
|
|
|
172 if New_Table = null then
|
|
|
173 raise Storage_Error;
|
|
|
174 else
|
|
|
175 S.Lines_Table := New_Table;
|
|
|
176 S.Lines_Table_Max := Physical_Line_Number (New_Max);
|
|
|
177 end if;
|
|
|
178
|
|
|
179 if S.Num_SRef_Pragmas /= 0 then
|
|
|
180 if S.Logical_Lines_Table = null then
|
|
|
181 New_Logical_Table := To_Pointer (Memory.Alloc (New_Size));
|
|
|
182 else
|
|
|
183 New_Logical_Table := To_Pointer
|
|
|
184 (Memory.Realloc (To_Address (S.Logical_Lines_Table), New_Size));
|
|
|
185 end if;
|
|
|
186
|
|
|
187 if New_Logical_Table = null then
|
|
|
188 raise Storage_Error;
|
|
|
189 else
|
|
|
190 S.Logical_Lines_Table := New_Logical_Table;
|
|
|
191 end if;
|
|
|
192 end if;
|
|
|
193 end Alloc_Line_Tables;
|
|
|
194
|
|
|
195 -----------------
|
|
|
196 -- Backup_Line --
|
|
|
197 -----------------
|
|
|
198
|
|
|
199 procedure Backup_Line (P : in out Source_Ptr) is
|
|
|
200 Sindex : constant Source_File_Index := Get_Source_File_Index (P);
|
|
|
201 Src : constant Source_Buffer_Ptr :=
|
|
|
202 Source_File.Table (Sindex).Source_Text;
|
|
|
203 Sfirst : constant Source_Ptr :=
|
|
|
204 Source_File.Table (Sindex).Source_First;
|
|
|
205
|
|
|
206 begin
|
|
|
207 P := P - 1;
|
|
|
208
|
|
|
209 if P = Sfirst then
|
|
|
210 return;
|
|
|
211 end if;
|
|
|
212
|
|
|
213 if Src (P) = CR then
|
|
|
214 if Src (P - 1) = LF then
|
|
|
215 P := P - 1;
|
|
|
216 end if;
|
|
|
217
|
|
|
218 else -- Src (P) = LF
|
|
|
219 if Src (P - 1) = CR then
|
|
|
220 P := P - 1;
|
|
|
221 end if;
|
|
|
222 end if;
|
|
|
223
|
|
|
224 -- Now find first character of the previous line
|
|
|
225
|
|
|
226 while P > Sfirst
|
|
|
227 and then Src (P - 1) /= LF
|
|
|
228 and then Src (P - 1) /= CR
|
|
|
229 loop
|
|
|
230 P := P - 1;
|
|
|
231 end loop;
|
|
|
232 end Backup_Line;
|
|
|
233
|
|
|
234 ---------------------------
|
|
|
235 -- Build_Location_String --
|
|
|
236 ---------------------------
|
|
|
237
|
|
|
238 procedure Build_Location_String
|
|
|
239 (Buf : in out Bounded_String;
|
|
|
240 Loc : Source_Ptr)
|
|
|
241 is
|
|
|
242 Ptr : Source_Ptr := Loc;
|
|
|
243
|
|
|
244 begin
|
|
|
245 -- Loop through instantiations
|
|
|
246
|
|
|
247 loop
|
|
|
248 Append (Buf, Reference_Name (Get_Source_File_Index (Ptr)));
|
|
|
249 Append (Buf, ':');
|
|
|
250 Append (Buf, Nat (Get_Logical_Line_Number (Ptr)));
|
|
|
251
|
|
|
252 Ptr := Instantiation_Location (Ptr);
|
|
|
253 exit when Ptr = No_Location;
|
|
|
254 Append (Buf, " instantiated at ");
|
|
|
255 end loop;
|
|
|
256 end Build_Location_String;
|
|
|
257
|
|
|
258 function Build_Location_String (Loc : Source_Ptr) return String is
|
|
|
259 Buf : Bounded_String;
|
|
|
260 begin
|
|
|
261 Build_Location_String (Buf, Loc);
|
|
|
262 return +Buf;
|
|
|
263 end Build_Location_String;
|
|
|
264
|
|
|
265 -------------------
|
|
|
266 -- Check_For_BOM --
|
|
|
267 -------------------
|
|
|
268
|
|
|
269 procedure Check_For_BOM is
|
|
|
270 BOM : BOM_Kind;
|
|
|
271 Len : Natural;
|
|
|
272 Tst : String (1 .. 5);
|
|
|
273 C : Character;
|
|
|
274
|
|
|
275 begin
|
|
|
276 for J in 1 .. 5 loop
|
|
|
277 C := Source (Scan_Ptr + Source_Ptr (J) - 1);
|
|
|
278
|
|
|
279 -- Definitely no BOM if EOF character marks either end of file, or
|
|
|
280 -- an illegal non-BOM character if not at the end of file.
|
|
|
281
|
|
|
282 if C = EOF then
|
|
|
283 return;
|
|
|
284 end if;
|
|
|
285
|
|
|
286 Tst (J) := C;
|
|
|
287 end loop;
|
|
|
288
|
|
|
289 Read_BOM (Tst, Len, BOM, XML_Support => False);
|
|
|
290
|
|
|
291 case BOM is
|
|
|
292 when UTF8_All =>
|
|
|
293 Scan_Ptr := Scan_Ptr + Source_Ptr (Len);
|
|
|
294 First_Non_Blank_Location := Scan_Ptr;
|
|
|
295 Current_Line_Start := Scan_Ptr;
|
|
|
296 Wide_Character_Encoding_Method := WCEM_UTF8;
|
|
|
297 Upper_Half_Encoding := True;
|
|
|
298
|
|
|
299 when UTF16_BE
|
|
|
300 | UTF16_LE
|
|
|
301 =>
|
|
|
302 Set_Standard_Error;
|
|
|
303 Write_Line ("UTF-16 encoding format not recognized");
|
|
|
304 Set_Standard_Output;
|
|
|
305 raise Unrecoverable_Error;
|
|
|
306
|
|
|
307 when UTF32_BE
|
|
|
308 | UTF32_LE
|
|
|
309 =>
|
|
|
310 Set_Standard_Error;
|
|
|
311 Write_Line ("UTF-32 encoding format not recognized");
|
|
|
312 Set_Standard_Output;
|
|
|
313 raise Unrecoverable_Error;
|
|
|
314
|
|
|
315 when Unknown =>
|
|
|
316 null;
|
|
|
317
|
|
|
318 when others =>
|
|
|
319 raise Program_Error;
|
|
|
320 end case;
|
|
|
321 end Check_For_BOM;
|
|
|
322
|
|
|
323 -----------------------------
|
|
|
324 -- Clear_Source_File_Table --
|
|
|
325 -----------------------------
|
|
|
326
|
|
|
327 procedure Free is new Unchecked_Deallocation
|
|
|
328 (Lines_Table_Type, Lines_Table_Ptr);
|
|
|
329
|
|
|
330 procedure Free is new Unchecked_Deallocation
|
|
|
331 (Logical_Lines_Table_Type, Logical_Lines_Table_Ptr);
|
|
|
332
|
|
|
333 procedure Clear_Source_File_Table is
|
|
|
334 begin
|
|
|
335 for X in 1 .. Source_File.Last loop
|
|
|
336 declare
|
|
|
337 S : Source_File_Record renames Source_File.Table (X);
|
|
|
338 begin
|
|
|
339 if S.Instance = No_Instance_Id then
|
|
|
340 Free_Source_Buffer (S.Source_Text);
|
|
|
341 else
|
|
|
342 Free_Dope (S.Source_Text'Address);
|
|
|
343 S.Source_Text := null;
|
|
|
344 end if;
|
|
|
345
|
|
|
346 Free (S.Lines_Table);
|
|
|
347 Free (S.Logical_Lines_Table);
|
|
|
348 end;
|
|
|
349 end loop;
|
|
|
350
|
|
|
351 Source_File.Free;
|
|
|
352 Sinput.Initialize;
|
|
|
353 end Clear_Source_File_Table;
|
|
|
354
|
|
|
355 ---------------------------------
|
|
|
356 -- Comes_From_Inherited_Pragma --
|
|
|
357 ---------------------------------
|
|
|
358
|
|
|
359 function Comes_From_Inherited_Pragma (S : Source_Ptr) return Boolean is
|
|
|
360 SIE : Source_File_Record renames
|
|
|
361 Source_File.Table (Get_Source_File_Index (S));
|
|
|
362 begin
|
|
|
363 return SIE.Inherited_Pragma;
|
|
|
364 end Comes_From_Inherited_Pragma;
|
|
|
365
|
|
|
366 -----------------------------
|
|
|
367 -- Comes_From_Inlined_Body --
|
|
|
368 -----------------------------
|
|
|
369
|
|
|
370 function Comes_From_Inlined_Body (S : Source_Ptr) return Boolean is
|
|
|
371 SIE : Source_File_Record renames
|
|
|
372 Source_File.Table (Get_Source_File_Index (S));
|
|
|
373 begin
|
|
|
374 return SIE.Inlined_Body;
|
|
|
375 end Comes_From_Inlined_Body;
|
|
|
376
|
|
|
377 ------------------------
|
|
|
378 -- Free_Source_Buffer --
|
|
|
379 ------------------------
|
|
|
380
|
|
|
381 procedure Free_Source_Buffer (Src : in out Source_Buffer_Ptr) is
|
|
|
382 -- Unchecked_Deallocation doesn't work for access-to-constant; we need
|
|
|
383 -- to first Unchecked_Convert to access-to-variable.
|
|
|
384
|
|
|
385 function To_Source_Buffer_Ptr_Var is new
|
|
|
386 Unchecked_Conversion (Source_Buffer_Ptr, Source_Buffer_Ptr_Var);
|
|
|
387
|
|
|
388 Temp : Source_Buffer_Ptr_Var := To_Source_Buffer_Ptr_Var (Src);
|
|
|
389
|
|
|
390 procedure Free_Ptr is new
|
|
|
391 Unchecked_Deallocation (Source_Buffer, Source_Buffer_Ptr_Var);
|
|
|
392 begin
|
|
|
393 Free_Ptr (Temp);
|
|
|
394 Src := null;
|
|
|
395 end Free_Source_Buffer;
|
|
|
396
|
|
|
397 -----------------------
|
|
|
398 -- Get_Column_Number --
|
|
|
399 -----------------------
|
|
|
400
|
|
|
401 function Get_Column_Number (P : Source_Ptr) return Column_Number is
|
|
|
402 S : Source_Ptr;
|
|
|
403 C : Column_Number;
|
|
|
404 Sindex : Source_File_Index;
|
|
|
405 Src : Source_Buffer_Ptr;
|
|
|
406
|
|
|
407 begin
|
|
|
408 -- If the input source pointer is not a meaningful value then return
|
|
|
409 -- at once with column number 1. This can happen for a file not found
|
|
|
410 -- condition for a file loaded indirectly by RTE, and also perhaps on
|
|
|
411 -- some unknown internal error conditions. In either case we certainly
|
|
|
412 -- don't want to blow up.
|
|
|
413
|
|
|
414 if P < 1 then
|
|
|
415 return 1;
|
|
|
416
|
|
|
417 else
|
|
|
418 Sindex := Get_Source_File_Index (P);
|
|
|
419 Src := Source_File.Table (Sindex).Source_Text;
|
|
|
420 S := Line_Start (P);
|
|
|
421 C := 1;
|
|
|
422
|
|
|
423 while S < P loop
|
|
|
424 if Src (S) = HT then
|
|
|
425 C := (C - 1) / 8 * 8 + (8 + 1);
|
|
|
426 S := S + 1;
|
|
|
427
|
|
|
428 -- Deal with wide character case, but don't include brackets
|
|
|
429 -- notation in this circuit, since we know that this will
|
|
|
430 -- display unencoded (no one encodes brackets notation).
|
|
|
431
|
|
|
432 elsif Src (S) /= '[' and then Is_Start_Of_Wide_Char (Src, S) then
|
|
|
433 C := C + 1;
|
|
|
434 Skip_Wide (Src, S);
|
|
|
435
|
|
|
436 -- Normal (non-wide) character case or brackets sequence
|
|
|
437
|
|
|
438 else
|
|
|
439 C := C + 1;
|
|
|
440 S := S + 1;
|
|
|
441 end if;
|
|
|
442 end loop;
|
|
|
443
|
|
|
444 return C;
|
|
|
445 end if;
|
|
|
446 end Get_Column_Number;
|
|
|
447
|
|
|
448 -----------------------------
|
|
|
449 -- Get_Logical_Line_Number --
|
|
|
450 -----------------------------
|
|
|
451
|
|
|
452 function Get_Logical_Line_Number
|
|
|
453 (P : Source_Ptr) return Logical_Line_Number
|
|
|
454 is
|
|
|
455 SFR : Source_File_Record
|
|
|
456 renames Source_File.Table (Get_Source_File_Index (P));
|
|
|
457
|
|
|
458 L : constant Physical_Line_Number := Get_Physical_Line_Number (P);
|
|
|
459
|
|
|
460 begin
|
|
|
461 if SFR.Num_SRef_Pragmas = 0 then
|
|
|
462 return Logical_Line_Number (L);
|
|
|
463 else
|
|
|
464 return SFR.Logical_Lines_Table (L);
|
|
|
465 end if;
|
|
|
466 end Get_Logical_Line_Number;
|
|
|
467
|
|
|
468 ---------------------------------
|
|
|
469 -- Get_Logical_Line_Number_Img --
|
|
|
470 ---------------------------------
|
|
|
471
|
|
|
472 function Get_Logical_Line_Number_Img
|
|
|
473 (P : Source_Ptr) return String
|
|
|
474 is
|
|
|
475 begin
|
|
|
476 Name_Len := 0;
|
|
|
477 Add_Nat_To_Name_Buffer (Nat (Get_Logical_Line_Number (P)));
|
|
|
478 return Name_Buffer (1 .. Name_Len);
|
|
|
479 end Get_Logical_Line_Number_Img;
|
|
|
480
|
|
|
481 ------------------------------
|
|
|
482 -- Get_Physical_Line_Number --
|
|
|
483 ------------------------------
|
|
|
484
|
|
|
485 function Get_Physical_Line_Number
|
|
|
486 (P : Source_Ptr) return Physical_Line_Number
|
|
|
487 is
|
|
|
488 Sfile : Source_File_Index;
|
|
|
489 Table : Lines_Table_Ptr;
|
|
|
490 Lo : Physical_Line_Number;
|
|
|
491 Hi : Physical_Line_Number;
|
|
|
492 Mid : Physical_Line_Number;
|
|
|
493 Loc : Source_Ptr;
|
|
|
494
|
|
|
495 begin
|
|
|
496 -- If the input source pointer is not a meaningful value then return
|
|
|
497 -- at once with line number 1. This can happen for a file not found
|
|
|
498 -- condition for a file loaded indirectly by RTE, and also perhaps on
|
|
|
499 -- some unknown internal error conditions. In either case we certainly
|
|
|
500 -- don't want to blow up.
|
|
|
501
|
|
|
502 if P < 1 then
|
|
|
503 return 1;
|
|
|
504
|
|
|
505 -- Otherwise we can do the binary search
|
|
|
506
|
|
|
507 else
|
|
|
508 Sfile := Get_Source_File_Index (P);
|
|
|
509 Loc := P + Source_File.Table (Sfile).Sloc_Adjust;
|
|
|
510 Table := Source_File.Table (Sfile).Lines_Table;
|
|
|
511 Lo := 1;
|
|
|
512 Hi := Source_File.Table (Sfile).Last_Source_Line;
|
|
|
513
|
|
|
514 loop
|
|
|
515 Mid := (Lo + Hi) / 2;
|
|
|
516
|
|
|
517 if Loc < Table (Mid) then
|
|
|
518 Hi := Mid - 1;
|
|
|
519
|
|
|
520 else -- Loc >= Table (Mid)
|
|
|
521
|
|
|
522 if Mid = Hi or else
|
|
|
523 Loc < Table (Mid + 1)
|
|
|
524 then
|
|
|
525 return Mid;
|
|
|
526 else
|
|
|
527 Lo := Mid + 1;
|
|
|
528 end if;
|
|
|
529
|
|
|
530 end if;
|
|
|
531
|
|
|
532 end loop;
|
|
|
533 end if;
|
|
|
534 end Get_Physical_Line_Number;
|
|
|
535
|
|
|
536 ---------------------------
|
|
|
537 -- Get_Source_File_Index --
|
|
|
538 ---------------------------
|
|
|
539
|
|
|
540 function Get_Source_File_Index (S : Source_Ptr) return Source_File_Index is
|
|
|
541 Result : Source_File_Index;
|
|
|
542
|
|
|
543 procedure Assertions;
|
|
|
544 -- Assert various properties of the result
|
|
|
545
|
|
|
546 procedure Assertions is
|
|
|
547
|
|
|
548 -- ???The old version using zero-origin array indexing without array
|
|
|
549 -- bounds checks returned 1 (i.e. system.ads) for these special
|
|
|
550 -- locations, presumably by accident. We are mimicing that here.
|
|
|
551
|
|
|
552 Special : constant Boolean :=
|
|
|
553 S = No_Location
|
|
|
554 or else S = Standard_Location
|
|
|
555 or else S = Standard_ASCII_Location
|
|
|
556 or else S = System_Location;
|
|
|
557
|
|
|
558 pragma Assert ((S > No_Location) xor Special);
|
|
|
559 pragma Assert (Result in Source_File.First .. Source_File.Last);
|
|
|
560
|
|
|
561 SFR : Source_File_Record renames Source_File.Table (Result);
|
|
|
562
|
|
|
563 begin
|
|
|
564 -- SFR.Source_Text = null if and only if this is the SFR for a debug
|
|
|
565 -- output file (*.dg), and that file is under construction. S can be
|
|
|
566 -- slightly past Source_Last in that case because we haven't updated
|
|
|
567 -- Source_Last.
|
|
|
568
|
|
|
569 if Null_Source_Buffer_Ptr (SFR.Source_Text) then
|
|
|
570 pragma Assert (S >= SFR.Source_First); null;
|
|
|
571 else
|
|
|
572 pragma Assert (SFR.Source_Text'First = SFR.Source_First);
|
|
|
573 pragma Assert (SFR.Source_Text'Last = SFR.Source_Last);
|
|
|
574
|
|
|
575 if not Special then
|
|
|
576 pragma Assert (S in SFR.Source_First .. SFR.Source_Last);
|
|
|
577 null;
|
|
|
578 end if;
|
|
|
579 end if;
|
|
|
580 end Assertions;
|
|
|
581
|
|
|
582 -- Start of processing for Get_Source_File_Index
|
|
|
583
|
|
|
584 begin
|
|
|
585 if S > No_Location then
|
|
|
586 Result := Source_File_Index_Table (Int (S) / Source_Align);
|
|
|
587 else
|
|
|
588 Result := 1;
|
|
|
589 end if;
|
|
|
590
|
|
|
591 pragma Debug (Assertions);
|
|
|
592
|
|
|
593 return Result;
|
|
|
594 end Get_Source_File_Index;
|
|
|
595
|
|
|
596 ----------------
|
|
|
597 -- Initialize --
|
|
|
598 ----------------
|
|
|
599
|
|
|
600 procedure Initialize is
|
|
|
601 begin
|
|
|
602 Source_gnat_adc := No_Source_File;
|
|
|
603 Source_File.Init;
|
|
|
604 Instances.Init;
|
|
|
605 Instances.Append (No_Location);
|
|
|
606 pragma Assert (Instances.Last = No_Instance_Id);
|
|
|
607 end Initialize;
|
|
|
608
|
|
|
609 -------------------
|
|
|
610 -- Instantiation --
|
|
|
611 -------------------
|
|
|
612
|
|
|
613 function Instantiation (S : SFI) return Source_Ptr is
|
|
|
614 SIE : Source_File_Record renames Source_File.Table (S);
|
|
|
615 begin
|
|
|
616 if SIE.Inlined_Body or SIE.Inherited_Pragma then
|
|
|
617 return SIE.Inlined_Call;
|
|
|
618 else
|
|
|
619 return Instances.Table (SIE.Instance);
|
|
|
620 end if;
|
|
|
621 end Instantiation;
|
|
|
622
|
|
|
623 -------------------------
|
|
|
624 -- Instantiation_Depth --
|
|
|
625 -------------------------
|
|
|
626
|
|
|
627 function Instantiation_Depth (S : Source_Ptr) return Nat is
|
|
|
628 Sind : Source_File_Index;
|
|
|
629 Sval : Source_Ptr;
|
|
|
630 Depth : Nat;
|
|
|
631
|
|
|
632 begin
|
|
|
633 Sval := S;
|
|
|
634 Depth := 0;
|
|
|
635
|
|
|
636 loop
|
|
|
637 Sind := Get_Source_File_Index (Sval);
|
|
|
638 Sval := Instantiation (Sind);
|
|
|
639 exit when Sval = No_Location;
|
|
|
640 Depth := Depth + 1;
|
|
|
641 end loop;
|
|
|
642
|
|
|
643 return Depth;
|
|
|
644 end Instantiation_Depth;
|
|
|
645
|
|
|
646 ----------------------------
|
|
|
647 -- Instantiation_Location --
|
|
|
648 ----------------------------
|
|
|
649
|
|
|
650 function Instantiation_Location (S : Source_Ptr) return Source_Ptr is
|
|
|
651 begin
|
|
|
652 return Instantiation (Get_Source_File_Index (S));
|
|
|
653 end Instantiation_Location;
|
|
|
654
|
|
|
655 --------------------------
|
|
|
656 -- Iterate_On_Instances --
|
|
|
657 --------------------------
|
|
|
658
|
|
|
659 procedure Iterate_On_Instances is
|
|
|
660 begin
|
|
|
661 for J in 1 .. Instances.Last loop
|
|
|
662 Process (J, Instances.Table (J));
|
|
|
663 end loop;
|
|
|
664 end Iterate_On_Instances;
|
|
|
665
|
|
|
666 ----------------------
|
|
|
667 -- Last_Source_File --
|
|
|
668 ----------------------
|
|
|
669
|
|
|
670 function Last_Source_File return Source_File_Index is
|
|
|
671 begin
|
|
|
672 return Source_File.Last;
|
|
|
673 end Last_Source_File;
|
|
|
674
|
|
|
675 ----------------
|
|
|
676 -- Line_Start --
|
|
|
677 ----------------
|
|
|
678
|
|
|
679 function Line_Start (P : Source_Ptr) return Source_Ptr is
|
|
|
680 Sindex : constant Source_File_Index := Get_Source_File_Index (P);
|
|
|
681 Src : constant Source_Buffer_Ptr :=
|
|
|
682 Source_File.Table (Sindex).Source_Text;
|
|
|
683 Sfirst : constant Source_Ptr :=
|
|
|
684 Source_File.Table (Sindex).Source_First;
|
|
|
685 S : Source_Ptr;
|
|
|
686
|
|
|
687 begin
|
|
|
688 S := P;
|
|
|
689 while S > Sfirst
|
|
|
690 and then Src (S - 1) /= CR
|
|
|
691 and then Src (S - 1) /= LF
|
|
|
692 loop
|
|
|
693 S := S - 1;
|
|
|
694 end loop;
|
|
|
695
|
|
|
696 return S;
|
|
|
697 end Line_Start;
|
|
|
698
|
|
|
699 function Line_Start
|
|
|
700 (L : Physical_Line_Number;
|
|
|
701 S : Source_File_Index) return Source_Ptr
|
|
|
702 is
|
|
|
703 begin
|
|
|
704 return Source_File.Table (S).Lines_Table (L);
|
|
|
705 end Line_Start;
|
|
|
706
|
|
|
707 ----------
|
|
|
708 -- Lock --
|
|
|
709 ----------
|
|
|
710
|
|
|
711 procedure Lock is
|
|
|
712 begin
|
|
|
713 Source_File.Release;
|
|
|
714 Source_File.Locked := True;
|
|
|
715 end Lock;
|
|
|
716
|
|
|
717 ----------------------
|
|
|
718 -- Num_Source_Files --
|
|
|
719 ----------------------
|
|
|
720
|
|
|
721 function Num_Source_Files return Nat is
|
|
|
722 begin
|
|
|
723 return Int (Source_File.Last) - Int (Source_File.First) + 1;
|
|
|
724 end Num_Source_Files;
|
|
|
725
|
|
|
726 ----------------------
|
|
|
727 -- Num_Source_Lines --
|
|
|
728 ----------------------
|
|
|
729
|
|
|
730 function Num_Source_Lines (S : Source_File_Index) return Nat is
|
|
|
731 begin
|
|
|
732 return Nat (Source_File.Table (S).Last_Source_Line);
|
|
|
733 end Num_Source_Lines;
|
|
|
734
|
|
|
735 -----------------------
|
|
|
736 -- Original_Location --
|
|
|
737 -----------------------
|
|
|
738
|
|
|
739 function Original_Location (S : Source_Ptr) return Source_Ptr is
|
|
|
740 Sindex : Source_File_Index;
|
|
|
741 Tindex : Source_File_Index;
|
|
|
742
|
|
|
743 begin
|
|
|
744 if S <= No_Location then
|
|
|
745 return S;
|
|
|
746
|
|
|
747 else
|
|
|
748 Sindex := Get_Source_File_Index (S);
|
|
|
749
|
|
|
750 if Instantiation (Sindex) = No_Location then
|
|
|
751 return S;
|
|
|
752
|
|
|
753 else
|
|
|
754 Tindex := Template (Sindex);
|
|
|
755 while Instantiation (Tindex) /= No_Location loop
|
|
|
756 Tindex := Template (Tindex);
|
|
|
757 end loop;
|
|
|
758
|
|
|
759 return S - Source_First (Sindex) + Source_First (Tindex);
|
|
|
760 end if;
|
|
|
761 end if;
|
|
|
762 end Original_Location;
|
|
|
763
|
|
|
764 -------------------------
|
|
|
765 -- Physical_To_Logical --
|
|
|
766 -------------------------
|
|
|
767
|
|
|
768 function Physical_To_Logical
|
|
|
769 (Line : Physical_Line_Number;
|
|
|
770 S : Source_File_Index) return Logical_Line_Number
|
|
|
771 is
|
|
|
772 SFR : Source_File_Record renames Source_File.Table (S);
|
|
|
773
|
|
|
774 begin
|
|
|
775 if SFR.Num_SRef_Pragmas = 0 then
|
|
|
776 return Logical_Line_Number (Line);
|
|
|
777 else
|
|
|
778 return SFR.Logical_Lines_Table (Line);
|
|
|
779 end if;
|
|
|
780 end Physical_To_Logical;
|
|
|
781
|
|
|
782 --------------------------------
|
|
|
783 -- Register_Source_Ref_Pragma --
|
|
|
784 --------------------------------
|
|
|
785
|
|
|
786 procedure Register_Source_Ref_Pragma
|
|
|
787 (File_Name : File_Name_Type;
|
|
|
788 Stripped_File_Name : File_Name_Type;
|
|
|
789 Mapped_Line : Nat;
|
|
|
790 Line_After_Pragma : Physical_Line_Number)
|
|
|
791 is
|
|
|
792 subtype size_t is Memory.size_t;
|
|
|
793
|
|
|
794 SFR : Source_File_Record renames Source_File.Table (Current_Source_File);
|
|
|
795
|
|
|
796 ML : Logical_Line_Number;
|
|
|
797
|
|
|
798 begin
|
|
|
799 if File_Name /= No_File then
|
|
|
800 SFR.Reference_Name := Stripped_File_Name;
|
|
|
801 SFR.Full_Ref_Name := File_Name;
|
|
|
802
|
|
|
803 if not Debug_Generated_Code then
|
|
|
804 SFR.Debug_Source_Name := Stripped_File_Name;
|
|
|
805 SFR.Full_Debug_Name := File_Name;
|
|
|
806 end if;
|
|
|
807
|
|
|
808 SFR.Num_SRef_Pragmas := SFR.Num_SRef_Pragmas + 1;
|
|
|
809 end if;
|
|
|
810
|
|
|
811 if SFR.Num_SRef_Pragmas = 1 then
|
|
|
812 SFR.First_Mapped_Line := Logical_Line_Number (Mapped_Line);
|
|
|
813 end if;
|
|
|
814
|
|
|
815 if SFR.Logical_Lines_Table = null then
|
|
|
816 SFR.Logical_Lines_Table := To_Pointer
|
|
|
817 (Memory.Alloc
|
|
|
818 (size_t (SFR.Lines_Table_Max *
|
|
|
819 Logical_Lines_Table_Type'Component_Size /
|
|
|
820 Storage_Unit)));
|
|
|
821 end if;
|
|
|
822
|
|
|
823 SFR.Logical_Lines_Table (Line_After_Pragma - 1) := No_Line_Number;
|
|
|
824
|
|
|
825 ML := Logical_Line_Number (Mapped_Line);
|
|
|
826 for J in Line_After_Pragma .. SFR.Last_Source_Line loop
|
|
|
827 SFR.Logical_Lines_Table (J) := ML;
|
|
|
828 ML := ML + 1;
|
|
|
829 end loop;
|
|
|
830 end Register_Source_Ref_Pragma;
|
|
|
831
|
|
|
832 ---------------------------------
|
|
|
833 -- Set_Source_File_Index_Table --
|
|
|
834 ---------------------------------
|
|
|
835
|
|
|
836 procedure Set_Source_File_Index_Table (Xnew : Source_File_Index) is
|
|
|
837 Ind : Int;
|
|
|
838 SP : Source_Ptr;
|
|
|
839 SL : constant Source_Ptr := Source_File.Table (Xnew).Source_Last;
|
|
|
840 begin
|
|
|
841 SP := Source_File.Table (Xnew).Source_First;
|
|
|
842 pragma Assert (SP mod Source_Align = 0);
|
|
|
843 Ind := Int (SP) / Source_Align;
|
|
|
844 while SP <= SL loop
|
|
|
845 Source_File_Index_Table (Ind) := Xnew;
|
|
|
846 SP := SP + Source_Align;
|
|
|
847 Ind := Ind + 1;
|
|
|
848 end loop;
|
|
|
849 end Set_Source_File_Index_Table;
|
|
|
850
|
|
|
851 ---------------------------
|
|
|
852 -- Skip_Line_Terminators --
|
|
|
853 ---------------------------
|
|
|
854
|
|
|
855 procedure Skip_Line_Terminators
|
|
|
856 (P : in out Source_Ptr;
|
|
|
857 Physical : out Boolean)
|
|
|
858 is
|
|
|
859 Chr : constant Character := Source (P);
|
|
|
860
|
|
|
861 begin
|
|
|
862 if Chr = CR then
|
|
|
863 if Source (P + 1) = LF then
|
|
|
864 P := P + 2;
|
|
|
865 else
|
|
|
866 P := P + 1;
|
|
|
867 end if;
|
|
|
868
|
|
|
869 elsif Chr = LF then
|
|
|
870 P := P + 1;
|
|
|
871
|
|
|
872 elsif Chr = FF or else Chr = VT then
|
|
|
873 P := P + 1;
|
|
|
874 Physical := False;
|
|
|
875 return;
|
|
|
876
|
|
|
877 -- Otherwise we have a wide character
|
|
|
878
|
|
|
879 else
|
|
|
880 Skip_Wide (Source, P);
|
|
|
881 end if;
|
|
|
882
|
|
|
883 -- Fall through in the physical line terminator case. First deal with
|
|
|
884 -- making a possible entry into the lines table if one is needed.
|
|
|
885
|
|
|
886 -- Note: we are dealing with a real source file here, this cannot be
|
|
|
887 -- the instantiation case, so we need not worry about Sloc adjustment.
|
|
|
888
|
|
|
889 declare
|
|
|
890 S : Source_File_Record
|
|
|
891 renames Source_File.Table (Current_Source_File);
|
|
|
892
|
|
|
893 begin
|
|
|
894 Physical := True;
|
|
|
895
|
|
|
896 -- Make entry in lines table if not already made (in some scan backup
|
|
|
897 -- cases, we will be rescanning previously scanned source, so the
|
|
|
898 -- entry may have already been made on the previous forward scan).
|
|
|
899
|
|
|
900 if Source (P) /= EOF
|
|
|
901 and then P > S.Lines_Table (S.Last_Source_Line)
|
|
|
902 then
|
|
|
903 Add_Line_Tables_Entry (S, P);
|
|
|
904 end if;
|
|
|
905 end;
|
|
|
906 end Skip_Line_Terminators;
|
|
|
907
|
|
|
908 --------------
|
|
|
909 -- Set_Dope --
|
|
|
910 --------------
|
|
|
911
|
|
|
912 procedure Set_Dope
|
|
|
913 (Src : System.Address; New_Dope : Dope_Ptr)
|
|
|
914 is
|
|
|
915 -- A fat pointer is a pair consisting of data pointer and dope pointer,
|
|
|
916 -- in that order. So we want to overwrite the second word.
|
|
|
917 Dope : System.Address;
|
|
|
918 pragma Import (Ada, Dope);
|
|
|
919 use System.Storage_Elements;
|
|
|
920 for Dope'Address use Src + System.Address'Size / 8;
|
|
|
921 begin
|
|
|
922 Dope := New_Dope.all'Address;
|
|
|
923 end Set_Dope;
|
|
|
924
|
|
|
925 procedure Free_Dope (Src : System.Address) is
|
|
|
926 Dope : Dope_Ptr;
|
|
|
927 pragma Import (Ada, Dope);
|
|
|
928 use System.Storage_Elements;
|
|
|
929 for Dope'Address use Src + System.Address'Size / 8;
|
|
|
930 procedure Free is new Unchecked_Deallocation (Dope_Rec, Dope_Ptr);
|
|
|
931 begin
|
|
|
932 Free (Dope);
|
|
|
933 end Free_Dope;
|
|
|
934
|
|
|
935 ----------------
|
|
|
936 -- Sloc_Range --
|
|
|
937 ----------------
|
|
|
938
|
|
|
939 procedure Sloc_Range (N : Node_Id; Min, Max : out Source_Ptr) is
|
|
|
940
|
|
|
941 function Process (N : Node_Id) return Traverse_Result;
|
|
|
942 -- Process function for traversing the node tree
|
|
|
943
|
|
|
944 procedure Traverse is new Traverse_Proc (Process);
|
|
|
945
|
|
|
946 -------------
|
|
|
947 -- Process --
|
|
|
948 -------------
|
|
|
949
|
|
|
950 function Process (N : Node_Id) return Traverse_Result is
|
|
|
951 Orig : constant Node_Id := Original_Node (N);
|
|
|
952
|
|
|
953 begin
|
|
|
954 if Sloc (Orig) < Min then
|
|
|
955 if Sloc (Orig) > No_Location then
|
|
|
956 Min := Sloc (Orig);
|
|
|
957 end if;
|
|
|
958
|
|
|
959 elsif Sloc (Orig) > Max then
|
|
|
960 if Sloc (Orig) > No_Location then
|
|
|
961 Max := Sloc (Orig);
|
|
|
962 end if;
|
|
|
963 end if;
|
|
|
964
|
|
|
965 return OK_Orig;
|
|
|
966 end Process;
|
|
|
967
|
|
|
968 -- Start of processing for Sloc_Range
|
|
|
969
|
|
|
970 begin
|
|
|
971 Min := Sloc (N);
|
|
|
972 Max := Sloc (N);
|
|
|
973 Traverse (N);
|
|
|
974 end Sloc_Range;
|
|
|
975
|
|
|
976 -------------------
|
|
|
977 -- Source_Offset --
|
|
|
978 -------------------
|
|
|
979
|
|
|
980 function Source_Offset (S : Source_Ptr) return Nat is
|
|
|
981 Sindex : constant Source_File_Index := Get_Source_File_Index (S);
|
|
|
982 Sfirst : constant Source_Ptr :=
|
|
|
983 Source_File.Table (Sindex).Source_First;
|
|
|
984 begin
|
|
|
985 return Nat (S - Sfirst);
|
|
|
986 end Source_Offset;
|
|
|
987
|
|
|
988 ------------------------
|
|
|
989 -- Top_Level_Location --
|
|
|
990 ------------------------
|
|
|
991
|
|
|
992 function Top_Level_Location (S : Source_Ptr) return Source_Ptr is
|
|
|
993 Oldloc : Source_Ptr;
|
|
|
994 Newloc : Source_Ptr;
|
|
|
995
|
|
|
996 begin
|
|
|
997 Newloc := S;
|
|
|
998 loop
|
|
|
999 Oldloc := Newloc;
|
|
|
1000 Newloc := Instantiation_Location (Oldloc);
|
|
|
1001 exit when Newloc = No_Location;
|
|
|
1002 end loop;
|
|
|
1003
|
|
|
1004 return Oldloc;
|
|
|
1005 end Top_Level_Location;
|
|
|
1006
|
|
|
1007 ---------------
|
|
|
1008 -- Tree_Read --
|
|
|
1009 ---------------
|
|
|
1010
|
|
|
1011 procedure Tree_Read is
|
|
|
1012 begin
|
|
|
1013 -- First we must free any old source buffer pointers
|
|
|
1014
|
|
|
1015 for J in Source_File.First .. Source_File.Last loop
|
|
|
1016 declare
|
|
|
1017 S : Source_File_Record renames Source_File.Table (J);
|
|
|
1018 begin
|
|
|
1019 if S.Instance = No_Instance_Id then
|
|
|
1020 Free_Source_Buffer (S.Source_Text);
|
|
|
1021
|
|
|
1022 if S.Lines_Table /= null then
|
|
|
1023 Memory.Free (To_Address (S.Lines_Table));
|
|
|
1024 S.Lines_Table := null;
|
|
|
1025 end if;
|
|
|
1026
|
|
|
1027 if S.Logical_Lines_Table /= null then
|
|
|
1028 Memory.Free (To_Address (S.Logical_Lines_Table));
|
|
|
1029 S.Logical_Lines_Table := null;
|
|
|
1030 end if;
|
|
|
1031
|
|
|
1032 else
|
|
|
1033 Free_Dope (S.Source_Text'Address);
|
|
|
1034 S.Source_Text := null;
|
|
|
1035 end if;
|
|
|
1036 end;
|
|
|
1037 end loop;
|
|
|
1038
|
|
|
1039 -- Read in source file table and instance table
|
|
|
1040
|
|
|
1041 Source_File.Tree_Read;
|
|
|
1042 Instances.Tree_Read;
|
|
|
1043
|
|
|
1044 -- The pointers we read in there for the source buffer and lines table
|
|
|
1045 -- pointers are junk. We now read in the actual data that is referenced
|
|
|
1046 -- by these two fields.
|
|
|
1047
|
|
|
1048 for J in Source_File.First .. Source_File.Last loop
|
|
|
1049 declare
|
|
|
1050 S : Source_File_Record renames Source_File.Table (J);
|
|
|
1051 begin
|
|
|
1052 -- Normal case (non-instantiation)
|
|
|
1053
|
|
|
1054 if S.Instance = No_Instance_Id then
|
|
|
1055 S.Lines_Table := null;
|
|
|
1056 S.Logical_Lines_Table := null;
|
|
|
1057 Alloc_Line_Tables (S, Int (S.Last_Source_Line));
|
|
|
1058
|
|
|
1059 for J in 1 .. S.Last_Source_Line loop
|
|
|
1060 Tree_Read_Int (Int (S.Lines_Table (J)));
|
|
|
1061 end loop;
|
|
|
1062
|
|
|
1063 if S.Num_SRef_Pragmas /= 0 then
|
|
|
1064 for J in 1 .. S.Last_Source_Line loop
|
|
|
1065 Tree_Read_Int (Int (S.Logical_Lines_Table (J)));
|
|
|
1066 end loop;
|
|
|
1067 end if;
|
|
|
1068
|
|
|
1069 -- Allocate source buffer and read in the data
|
|
|
1070
|
|
|
1071 declare
|
|
|
1072 T : constant Source_Buffer_Ptr_Var :=
|
|
|
1073 new Source_Buffer (S.Source_First .. S.Source_Last);
|
|
|
1074 begin
|
|
|
1075 Tree_Read_Data (T (S.Source_First)'Address,
|
|
|
1076 Int (S.Source_Last) - Int (S.Source_First) + 1);
|
|
|
1077 S.Source_Text := T.all'Access;
|
|
|
1078 end;
|
|
|
1079
|
|
|
1080 -- For the instantiation case, we do not read in any data. Instead
|
|
|
1081 -- we share the data for the generic template entry. Since the
|
|
|
1082 -- template always occurs first, we can safely refer to its data.
|
|
|
1083
|
|
|
1084 else
|
|
|
1085 declare
|
|
|
1086 ST : Source_File_Record renames
|
|
|
1087 Source_File.Table (S.Template);
|
|
|
1088
|
|
|
1089 begin
|
|
|
1090 -- The lines tables are copied from the template entry
|
|
|
1091
|
|
|
1092 S.Lines_Table := ST.Lines_Table;
|
|
|
1093 S.Logical_Lines_Table := ST.Logical_Lines_Table;
|
|
|
1094
|
|
|
1095 -- The Source_Text of the instance is the same data as that
|
|
|
1096 -- of the template, but with different bounds.
|
|
|
1097
|
|
|
1098 declare
|
|
|
1099 Dope : constant Dope_Ptr :=
|
|
|
1100 new Dope_Rec'(S.Source_First, S.Source_Last);
|
|
|
1101 begin
|
|
|
1102 S.Source_Text := ST.Source_Text;
|
|
|
1103 Set_Dope (S.Source_Text'Address, Dope);
|
|
|
1104 end;
|
|
|
1105 end;
|
|
|
1106 end if;
|
|
|
1107 end;
|
|
|
1108
|
|
|
1109 Set_Source_File_Index_Table (J);
|
|
|
1110 end loop;
|
|
|
1111 end Tree_Read;
|
|
|
1112
|
|
|
1113 ----------------
|
|
|
1114 -- Tree_Write --
|
|
|
1115 ----------------
|
|
|
1116
|
|
|
1117 procedure Tree_Write is
|
|
|
1118 begin
|
|
|
1119 Source_File.Tree_Write;
|
|
|
1120 Instances.Tree_Write;
|
|
|
1121
|
|
|
1122 -- The pointers we wrote out there for the source buffer and lines
|
|
|
1123 -- table pointers are junk, we now write out the actual data that
|
|
|
1124 -- is referenced by these two fields.
|
|
|
1125
|
|
|
1126 for J in Source_File.First .. Source_File.Last loop
|
|
|
1127 declare
|
|
|
1128 S : Source_File_Record renames Source_File.Table (J);
|
|
|
1129
|
|
|
1130 begin
|
|
|
1131 -- For instantiations, there is nothing to do, since the data is
|
|
|
1132 -- shared with the generic template. When the tree is read, the
|
|
|
1133 -- pointers must be set, but no extra data needs to be written.
|
|
|
1134 -- For the normal case, write out the data of the tables.
|
|
|
1135
|
|
|
1136 if S.Instance = No_Instance_Id then
|
|
|
1137 -- Lines table
|
|
|
1138
|
|
|
1139 for J in 1 .. S.Last_Source_Line loop
|
|
|
1140 Tree_Write_Int (Int (S.Lines_Table (J)));
|
|
|
1141 end loop;
|
|
|
1142
|
|
|
1143 -- Logical lines table if present
|
|
|
1144
|
|
|
1145 if S.Num_SRef_Pragmas /= 0 then
|
|
|
1146 for J in 1 .. S.Last_Source_Line loop
|
|
|
1147 Tree_Write_Int (Int (S.Logical_Lines_Table (J)));
|
|
|
1148 end loop;
|
|
|
1149 end if;
|
|
|
1150
|
|
|
1151 -- Source buffer
|
|
|
1152
|
|
|
1153 Tree_Write_Data
|
|
|
1154 (S.Source_Text (S.Source_First)'Address,
|
|
|
1155 Int (S.Source_Last) - Int (S.Source_First) + 1);
|
|
|
1156 end if;
|
|
|
1157 end;
|
|
|
1158 end loop;
|
|
|
1159 end Tree_Write;
|
|
|
1160
|
|
|
1161 --------------------
|
|
|
1162 -- Write_Location --
|
|
|
1163 --------------------
|
|
|
1164
|
|
|
1165 procedure Write_Location (P : Source_Ptr) is
|
|
|
1166 begin
|
|
|
1167 if P = No_Location then
|
|
|
1168 Write_Str ("<no location>");
|
|
|
1169
|
|
|
1170 elsif P <= Standard_Location then
|
|
|
1171 Write_Str ("<standard location>");
|
|
|
1172
|
|
|
1173 else
|
|
|
1174 declare
|
|
|
1175 SI : constant Source_File_Index := Get_Source_File_Index (P);
|
|
|
1176
|
|
|
1177 begin
|
|
|
1178 Write_Name (Debug_Source_Name (SI));
|
|
|
1179 Write_Char (':');
|
|
|
1180 Write_Int (Int (Get_Logical_Line_Number (P)));
|
|
|
1181 Write_Char (':');
|
|
|
1182 Write_Int (Int (Get_Column_Number (P)));
|
|
|
1183
|
|
|
1184 if Instantiation (SI) /= No_Location then
|
|
|
1185 Write_Str (" [");
|
|
|
1186 Write_Location (Instantiation (SI));
|
|
|
1187 Write_Char (']');
|
|
|
1188 end if;
|
|
|
1189 end;
|
|
|
1190 end if;
|
|
|
1191 end Write_Location;
|
|
|
1192
|
|
|
1193 ----------------------
|
|
|
1194 -- Write_Time_Stamp --
|
|
|
1195 ----------------------
|
|
|
1196
|
|
|
1197 procedure Write_Time_Stamp (S : Source_File_Index) is
|
|
|
1198 T : constant Time_Stamp_Type := Time_Stamp (S);
|
|
|
1199 P : Natural;
|
|
|
1200
|
|
|
1201 begin
|
|
|
1202 if T (1) = '9' then
|
|
|
1203 Write_Str ("19");
|
|
|
1204 P := 0;
|
|
|
1205 else
|
|
|
1206 Write_Char (T (1));
|
|
|
1207 Write_Char (T (2));
|
|
|
1208 P := 2;
|
|
|
1209 end if;
|
|
|
1210
|
|
|
1211 Write_Char (T (P + 1));
|
|
|
1212 Write_Char (T (P + 2));
|
|
|
1213 Write_Char ('-');
|
|
|
1214
|
|
|
1215 Write_Char (T (P + 3));
|
|
|
1216 Write_Char (T (P + 4));
|
|
|
1217 Write_Char ('-');
|
|
|
1218
|
|
|
1219 Write_Char (T (P + 5));
|
|
|
1220 Write_Char (T (P + 6));
|
|
|
1221 Write_Char (' ');
|
|
|
1222
|
|
|
1223 Write_Char (T (P + 7));
|
|
|
1224 Write_Char (T (P + 8));
|
|
|
1225 Write_Char (':');
|
|
|
1226
|
|
|
1227 Write_Char (T (P + 9));
|
|
|
1228 Write_Char (T (P + 10));
|
|
|
1229 Write_Char (':');
|
|
|
1230
|
|
|
1231 Write_Char (T (P + 11));
|
|
|
1232 Write_Char (T (P + 12));
|
|
|
1233 end Write_Time_Stamp;
|
|
|
1234
|
|
|
1235 ----------------------------------------------
|
|
|
1236 -- Access Subprograms for Source File Table --
|
|
|
1237 ----------------------------------------------
|
|
|
1238
|
|
|
1239 function Debug_Source_Name (S : SFI) return File_Name_Type is
|
|
|
1240 begin
|
|
|
1241 return Source_File.Table (S).Debug_Source_Name;
|
|
|
1242 end Debug_Source_Name;
|
|
|
1243
|
|
|
1244 function Instance (S : SFI) return Instance_Id is
|
|
|
1245 begin
|
|
|
1246 return Source_File.Table (S).Instance;
|
|
|
1247 end Instance;
|
|
|
1248
|
|
|
1249 function File_Name (S : SFI) return File_Name_Type is
|
|
|
1250 begin
|
|
|
1251 return Source_File.Table (S).File_Name;
|
|
|
1252 end File_Name;
|
|
|
1253
|
|
|
1254 function File_Type (S : SFI) return Type_Of_File is
|
|
|
1255 begin
|
|
|
1256 return Source_File.Table (S).File_Type;
|
|
|
1257 end File_Type;
|
|
|
1258
|
|
|
1259 function First_Mapped_Line (S : SFI) return Logical_Line_Number is
|
|
|
1260 begin
|
|
|
1261 return Source_File.Table (S).First_Mapped_Line;
|
|
|
1262 end First_Mapped_Line;
|
|
|
1263
|
|
|
1264 function Full_Debug_Name (S : SFI) return File_Name_Type is
|
|
|
1265 begin
|
|
|
1266 return Source_File.Table (S).Full_Debug_Name;
|
|
|
1267 end Full_Debug_Name;
|
|
|
1268
|
|
|
1269 function Full_File_Name (S : SFI) return File_Name_Type is
|
|
|
1270 begin
|
|
|
1271 return Source_File.Table (S).Full_File_Name;
|
|
|
1272 end Full_File_Name;
|
|
|
1273
|
|
|
1274 function Full_Ref_Name (S : SFI) return File_Name_Type is
|
|
|
1275 begin
|
|
|
1276 return Source_File.Table (S).Full_Ref_Name;
|
|
|
1277 end Full_Ref_Name;
|
|
|
1278
|
|
|
1279 function Identifier_Casing (S : SFI) return Casing_Type is
|
|
|
1280 begin
|
|
|
1281 return Source_File.Table (S).Identifier_Casing;
|
|
|
1282 end Identifier_Casing;
|
|
|
1283
|
|
|
1284 function Inherited_Pragma (S : SFI) return Boolean is
|
|
|
1285 begin
|
|
|
1286 return Source_File.Table (S).Inherited_Pragma;
|
|
|
1287 end Inherited_Pragma;
|
|
|
1288
|
|
|
1289 function Inlined_Body (S : SFI) return Boolean is
|
|
|
1290 begin
|
|
|
1291 return Source_File.Table (S).Inlined_Body;
|
|
|
1292 end Inlined_Body;
|
|
|
1293
|
|
|
1294 function Inlined_Call (S : SFI) return Source_Ptr is
|
|
|
1295 begin
|
|
|
1296 return Source_File.Table (S).Inlined_Call;
|
|
|
1297 end Inlined_Call;
|
|
|
1298
|
|
|
1299 function Keyword_Casing (S : SFI) return Casing_Type is
|
|
|
1300 begin
|
|
|
1301 return Source_File.Table (S).Keyword_Casing;
|
|
|
1302 end Keyword_Casing;
|
|
|
1303
|
|
|
1304 function Last_Source_Line (S : SFI) return Physical_Line_Number is
|
|
|
1305 begin
|
|
|
1306 return Source_File.Table (S).Last_Source_Line;
|
|
|
1307 end Last_Source_Line;
|
|
|
1308
|
|
|
1309 function License (S : SFI) return License_Type is
|
|
|
1310 begin
|
|
|
1311 return Source_File.Table (S).License;
|
|
|
1312 end License;
|
|
|
1313
|
|
|
1314 function Num_SRef_Pragmas (S : SFI) return Nat is
|
|
|
1315 begin
|
|
|
1316 return Source_File.Table (S).Num_SRef_Pragmas;
|
|
|
1317 end Num_SRef_Pragmas;
|
|
|
1318
|
|
|
1319 function Reference_Name (S : SFI) return File_Name_Type is
|
|
|
1320 begin
|
|
|
1321 return Source_File.Table (S).Reference_Name;
|
|
|
1322 end Reference_Name;
|
|
|
1323
|
|
|
1324 function Source_Checksum (S : SFI) return Word is
|
|
|
1325 begin
|
|
|
1326 return Source_File.Table (S).Source_Checksum;
|
|
|
1327 end Source_Checksum;
|
|
|
1328
|
|
|
1329 function Source_First (S : SFI) return Source_Ptr is
|
|
|
1330 begin
|
|
|
1331 return Source_File.Table (S).Source_First;
|
|
|
1332 end Source_First;
|
|
|
1333
|
|
|
1334 function Source_Last (S : SFI) return Source_Ptr is
|
|
|
1335 begin
|
|
|
1336 return Source_File.Table (S).Source_Last;
|
|
|
1337 end Source_Last;
|
|
|
1338
|
|
|
1339 function Source_Text (S : SFI) return Source_Buffer_Ptr is
|
|
|
1340 begin
|
|
|
1341 return Source_File.Table (S).Source_Text;
|
|
|
1342 end Source_Text;
|
|
|
1343
|
|
|
1344 function Template (S : SFI) return SFI is
|
|
|
1345 begin
|
|
|
1346 return Source_File.Table (S).Template;
|
|
|
1347 end Template;
|
|
|
1348
|
|
|
1349 function Time_Stamp (S : SFI) return Time_Stamp_Type is
|
|
|
1350 begin
|
|
|
1351 return Source_File.Table (S).Time_Stamp;
|
|
|
1352 end Time_Stamp;
|
|
|
1353
|
|
|
1354 function Unit (S : SFI) return Unit_Number_Type is
|
|
|
1355 begin
|
|
|
1356 return Source_File.Table (S).Unit;
|
|
|
1357 end Unit;
|
|
|
1358
|
|
|
1359 ------------------------------------------
|
|
|
1360 -- Set Procedures for Source File Table --
|
|
|
1361 ------------------------------------------
|
|
|
1362
|
|
|
1363 procedure Set_Identifier_Casing (S : SFI; C : Casing_Type) is
|
|
|
1364 begin
|
|
|
1365 Source_File.Table (S).Identifier_Casing := C;
|
|
|
1366 end Set_Identifier_Casing;
|
|
|
1367
|
|
|
1368 procedure Set_Keyword_Casing (S : SFI; C : Casing_Type) is
|
|
|
1369 begin
|
|
|
1370 Source_File.Table (S).Keyword_Casing := C;
|
|
|
1371 end Set_Keyword_Casing;
|
|
|
1372
|
|
|
1373 procedure Set_License (S : SFI; L : License_Type) is
|
|
|
1374 begin
|
|
|
1375 Source_File.Table (S).License := L;
|
|
|
1376 end Set_License;
|
|
|
1377
|
|
|
1378 procedure Set_Unit (S : SFI; U : Unit_Number_Type) is
|
|
|
1379 begin
|
|
|
1380 Source_File.Table (S).Unit := U;
|
|
|
1381 end Set_Unit;
|
|
|
1382
|
|
|
1383 ----------------------
|
|
|
1384 -- Trim_Lines_Table --
|
|
|
1385 ----------------------
|
|
|
1386
|
|
|
1387 procedure Trim_Lines_Table (S : Source_File_Index) is
|
|
|
1388 Max : constant Nat := Nat (Source_File.Table (S).Last_Source_Line);
|
|
|
1389
|
|
|
1390 begin
|
|
|
1391 -- Release allocated storage that is no longer needed
|
|
|
1392
|
|
|
1393 Source_File.Table (S).Lines_Table := To_Pointer
|
|
|
1394 (Memory.Realloc
|
|
|
1395 (To_Address (Source_File.Table (S).Lines_Table),
|
|
|
1396 Memory.size_t
|
|
|
1397 (Max * (Lines_Table_Type'Component_Size / System.Storage_Unit))));
|
|
|
1398 Source_File.Table (S).Lines_Table_Max := Physical_Line_Number (Max);
|
|
|
1399 end Trim_Lines_Table;
|
|
|
1400
|
|
|
1401 ------------
|
|
|
1402 -- Unlock --
|
|
|
1403 ------------
|
|
|
1404
|
|
|
1405 procedure Unlock is
|
|
|
1406 begin
|
|
|
1407 Source_File.Locked := False;
|
|
|
1408 Source_File.Release;
|
|
|
1409 end Unlock;
|
|
|
1410
|
|
|
1411 --------
|
|
|
1412 -- wl --
|
|
|
1413 --------
|
|
|
1414
|
|
|
1415 procedure wl (P : Source_Ptr) is
|
|
|
1416 begin
|
|
|
1417 Write_Location (P);
|
|
|
1418 Write_Eol;
|
|
|
1419 end wl;
|
|
|
1420
|
|
|
1421 end Sinput;
|
