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