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