hppa: Fix LO_SUM DLTIND14R address support in PRINT_OPERAND_ADDRESS
[official-gcc.git] / gcc / ada / sinput.adb
blobae86f1f5bd971f3c21982e458edde89624b9a51e
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S I N P U T --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2024, Free Software Foundation, Inc. --
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. 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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
26 pragma Style_Checks (All_Checks);
27 -- Subprograms not all in alpha order
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;
38 with GNAT.Byte_Order_Mark; use GNAT.Byte_Order_Mark;
40 with System.Storage_Elements;
41 with System.Memory;
42 with System.WCh_Con; use System.WCh_Con;
44 with Ada.Unchecked_Conversion;
45 with Ada.Unchecked_Deallocation;
47 package body Sinput is
49 use ASCII, System;
51 -- Routines to support conversion between types Lines_Table_Ptr,
52 -- Logical_Lines_Table_Ptr and System.Address.
54 pragma Warnings (Off);
55 -- These unchecked conversions are aliasing safe, since they are never
56 -- used to construct improperly aliased pointer values.
58 function To_Address is
59 new Ada.Unchecked_Conversion (Lines_Table_Ptr, Address);
61 function To_Address is
62 new Ada.Unchecked_Conversion (Logical_Lines_Table_Ptr, Address);
64 function To_Pointer is
65 new Ada.Unchecked_Conversion (Address, Lines_Table_Ptr);
67 function To_Pointer is
68 new Ada.Unchecked_Conversion (Address, Logical_Lines_Table_Ptr);
70 pragma Warnings (On);
72 -----------------------------
73 -- Source_File_Index_Table --
74 -----------------------------
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.
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.
87 Source_File_Index_Table :
88 array (Int range 0 .. 1 + (Int'Last / Source_Align)) of Source_File_Index;
90 ---------------------------
91 -- Add_Line_Tables_Entry --
92 ---------------------------
94 procedure Add_Line_Tables_Entry
95 (S : in out Source_File_Record;
96 P : Source_Ptr)
98 LL : Physical_Line_Number;
100 begin
101 -- Reallocate the lines tables if necessary
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 ???
108 if S.Last_Source_Line = S.Lines_Table_Max then
109 Alloc_Line_Tables
111 Int (S.Last_Source_Line) *
112 ((100 + Alloc.Lines_Increment) / 100));
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;
121 S.Last_Source_Line := S.Last_Source_Line + 1;
122 LL := S.Last_Source_Line;
124 S.Lines_Table (LL) := P;
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),
130 if S.Logical_Lines_Table /= null then
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.
136 S.Logical_Lines_Table (LL) := S.Logical_Lines_Table (LL - 1) + 1;
137 end if;
138 end Add_Line_Tables_Entry;
140 -----------------------
141 -- Alloc_Line_Tables --
142 -----------------------
144 procedure Alloc_Line_Tables
145 (S : in out Source_File_Record;
146 New_Max : Nat)
148 subtype size_t is Memory.size_t;
150 New_Table : Lines_Table_Ptr;
152 New_Logical_Table : Logical_Lines_Table_Ptr;
154 New_Size : constant size_t :=
155 size_t (New_Max * Lines_Table_Type'Component_Size /
156 Storage_Unit);
158 begin
159 if S.Lines_Table = null then
160 New_Table := To_Pointer (Memory.Alloc (New_Size));
162 else
163 New_Table :=
164 To_Pointer (Memory.Realloc (To_Address (S.Lines_Table), New_Size));
165 end if;
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;
174 if S.Num_SRef_Pragmas /= 0 then
175 if S.Logical_Lines_Table = null then
176 New_Logical_Table := To_Pointer (Memory.Alloc (New_Size));
177 else
178 New_Logical_Table := To_Pointer
179 (Memory.Realloc (To_Address (S.Logical_Lines_Table), New_Size));
180 end if;
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;
190 -----------------
191 -- Backup_Line --
192 -----------------
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;
201 begin
202 P := P - 1;
204 if P = Sfirst then
205 return;
206 end if;
208 if Src (P) = CR then
209 if Src (P - 1) = LF then
210 P := P - 1;
211 end if;
213 else -- Src (P) = LF
214 if Src (P - 1) = CR then
215 P := P - 1;
216 end if;
217 end if;
219 -- Now find first character of the previous line
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;
229 ---------------------------
230 -- Build_Location_String --
231 ---------------------------
233 procedure Build_Location_String
234 (Buf : in out Bounded_String;
235 Loc : Source_Ptr)
237 Ptr : Source_Ptr := Loc;
239 begin
240 -- Loop through instantiations
242 loop
243 Append (Buf, Reference_Name (Get_Source_File_Index (Ptr)));
244 Append (Buf, ':');
245 Append (Buf, Nat (Get_Logical_Line_Number (Ptr)));
247 Ptr := Instantiation_Location (Ptr);
248 exit when Ptr = No_Location;
249 Append (Buf, " instantiated at ");
250 end loop;
251 end Build_Location_String;
253 function Build_Location_String (Loc : Source_Ptr) return String is
254 Buf : Bounded_String;
255 begin
256 Build_Location_String (Buf, Loc);
257 return +Buf;
258 end Build_Location_String;
260 -------------------
261 -- Check_For_BOM --
262 -------------------
264 procedure Check_For_BOM is
265 BOM : BOM_Kind;
266 Len : Natural;
267 Tst : String (1 .. 5);
268 C : Character;
270 begin
271 for J in 1 .. 5 loop
272 C := Source (Scan_Ptr + Source_Ptr (J) - 1);
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.
277 if C = EOF then
278 return;
279 end if;
281 Tst (J) := C;
282 end loop;
284 Read_BOM (Tst, Len, BOM, XML_Support => False);
286 case BOM is
287 when UTF8_All =>
288 Scan_Ptr := Scan_Ptr + Source_Ptr (Len);
289 First_Non_Blank_Location := Scan_Ptr;
290 Current_Line_Start := Scan_Ptr;
291 Wide_Character_Encoding_Method := WCEM_UTF8;
292 Upper_Half_Encoding := True;
294 when UTF16_BE
295 | UTF16_LE
297 Set_Standard_Error;
298 Write_Line ("UTF-16 encoding format not recognized");
299 Set_Standard_Output;
300 raise Unrecoverable_Error;
302 when UTF32_BE
303 | UTF32_LE
305 Set_Standard_Error;
306 Write_Line ("UTF-32 encoding format not recognized");
307 Set_Standard_Output;
308 raise Unrecoverable_Error;
310 when Unknown =>
311 null;
313 when others =>
314 raise Program_Error;
315 end case;
316 end Check_For_BOM;
318 -----------------------------
319 -- Clear_Source_File_Table --
320 -----------------------------
322 procedure Free is new Ada.Unchecked_Deallocation
323 (Lines_Table_Type, Lines_Table_Ptr);
325 procedure Free is new Ada.Unchecked_Deallocation
326 (Logical_Lines_Table_Type, Logical_Lines_Table_Ptr);
328 procedure Clear_Source_File_Table is
329 begin
330 for X in 1 .. Source_File.Last loop
331 declare
332 S : Source_File_Record renames Source_File.Table (X);
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;
341 Free (S.Lines_Table);
342 Free (S.Logical_Lines_Table);
343 end;
344 end loop;
346 Source_File.Free;
347 Sinput.Initialize;
348 end Clear_Source_File_Table;
350 ---------------------------------
351 -- Comes_From_Inherited_Pragma --
352 ---------------------------------
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;
361 -----------------------------
362 -- Comes_From_Inlined_Body --
363 -----------------------------
365 function Comes_From_Inlined_Body (S : Source_Ptr) return Boolean is
366 SIE : Source_File_Record renames
367 Source_File.Table (Get_Source_File_Index (S));
368 begin
369 return SIE.Inlined_Body;
370 end Comes_From_Inlined_Body;
372 ------------------------
373 -- Free_Source_Buffer --
374 ------------------------
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.
380 function To_Source_Buffer_Ptr_Var is new
381 Ada.Unchecked_Conversion (Source_Buffer_Ptr, Source_Buffer_Ptr_Var);
383 Temp : Source_Buffer_Ptr_Var := To_Source_Buffer_Ptr_Var (Src);
385 procedure Free_Ptr is new
386 Ada.Unchecked_Deallocation (Source_Buffer, Source_Buffer_Ptr_Var);
387 begin
388 Free_Ptr (Temp);
389 Src := null;
390 end Free_Source_Buffer;
392 -----------------------
393 -- Get_Column_Number --
394 -----------------------
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;
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.
409 if P < 1 then
410 return 1;
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;
418 while S < P loop
419 if Src (S) = HT then
420 C := (C - 1) / 8 * 8 + (8 + 1);
421 S := S + 1;
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).
427 elsif Src (S) /= '[' and then Is_Start_Of_Wide_Char (Src, S) then
428 C := C + 1;
429 Skip_Wide (Src, S);
431 -- Normal (non-wide) character case or brackets sequence
433 else
434 C := C + 1;
435 S := S + 1;
436 end if;
437 end loop;
439 return C;
440 end if;
441 end Get_Column_Number;
443 -----------------------------
444 -- Get_Logical_Line_Number --
445 -----------------------------
447 function Get_Logical_Line_Number
448 (P : Source_Ptr) return Logical_Line_Number
450 SFR : Source_File_Record
451 renames Source_File.Table (Get_Source_File_Index (P));
453 L : constant Physical_Line_Number := Get_Physical_Line_Number (P);
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;
463 ------------------------------
464 -- Get_Physical_Line_Number --
465 ------------------------------
467 function Get_Physical_Line_Number
468 (P : Source_Ptr) return Physical_Line_Number
470 Sfile : Source_File_Index;
471 Table : Lines_Table_Ptr;
472 Lo : Physical_Line_Number;
473 Hi : Physical_Line_Number;
474 Mid : Physical_Line_Number;
475 Loc : Source_Ptr;
477 begin
478 -- If the input source pointer is not a meaningful value then return
479 -- at once with line number 1. This can happen for a file not found
480 -- condition for a file loaded indirectly by RTE, and also perhaps on
481 -- some unknown internal error conditions. In either case we certainly
482 -- don't want to blow up.
484 if P < 1 then
485 return 1;
487 -- Otherwise we can do the binary search
489 else
490 Sfile := Get_Source_File_Index (P);
491 Loc := P + Source_File.Table (Sfile).Sloc_Adjust;
492 Table := Source_File.Table (Sfile).Lines_Table;
493 Lo := 1;
494 Hi := Source_File.Table (Sfile).Last_Source_Line;
496 loop
497 Mid := (Lo + Hi) / 2;
499 if Loc < Table (Mid) then
500 Hi := Mid - 1;
502 else -- Loc >= Table (Mid)
504 if Mid = Hi or else
505 Loc < Table (Mid + 1)
506 then
507 return Mid;
508 else
509 Lo := Mid + 1;
510 end if;
512 end if;
514 end loop;
515 end if;
516 end Get_Physical_Line_Number;
518 ---------------------------
519 -- Get_Source_File_Index --
520 ---------------------------
522 function Get_Source_File_Index (S : Source_Ptr) return Source_File_Index is
523 Result : Source_File_Index;
525 procedure Assertions;
526 -- Assert various properties of the result
528 procedure Assertions is
530 -- ???The old version using zero-origin array indexing without array
531 -- bounds checks returned 1 (i.e. system.ads) for these special
532 -- locations, presumably by accident. We are mimicing that here.
534 Special : constant Boolean :=
535 S = No_Location
536 or else S = Standard_Location
537 or else S = Standard_ASCII_Location
538 or else S = System_Location;
540 pragma Assert (S > No_Location xor Special);
541 pragma Assert (Result in Source_File.First .. Source_File.Last);
543 SFR : Source_File_Record renames Source_File.Table (Result);
545 begin
546 -- SFR.Source_Text = null if and only if this is the SFR for a debug
547 -- output file (*.dg), and that file is under construction. S can be
548 -- slightly past Source_Last in that case because we haven't updated
549 -- Source_Last.
551 if Null_Source_Buffer_Ptr (SFR.Source_Text) then
552 pragma Assert (S >= SFR.Source_First); null;
553 else
554 pragma Assert (SFR.Source_Text'First = SFR.Source_First);
555 pragma Assert (SFR.Source_Text'Last = SFR.Source_Last);
557 if not Special then
558 pragma Assert (S in SFR.Source_First .. SFR.Source_Last);
559 null;
560 end if;
561 end if;
562 end Assertions;
564 -- Start of processing for Get_Source_File_Index
566 begin
567 if S > No_Location then
568 Result := Source_File_Index_Table (Int (S) / Source_Align);
569 else
570 Result := 1;
571 end if;
573 pragma Debug (Assertions);
575 return Result;
576 end Get_Source_File_Index;
578 ----------------
579 -- Initialize --
580 ----------------
582 procedure Initialize is
583 begin
584 Source_gnat_adc := No_Source_File;
585 Source_File.Init;
586 Instances.Init;
587 Instances.Append (No_Location);
588 pragma Assert (Instances.Last = No_Instance_Id);
589 end Initialize;
591 -------------------
592 -- Instantiation --
593 -------------------
595 function Instantiation (S : SFI) return Source_Ptr is
596 SIE : Source_File_Record renames Source_File.Table (S);
597 begin
598 if SIE.Inlined_Body or SIE.Inherited_Pragma then
599 return SIE.Inlined_Call;
600 else
601 return Instances.Table (SIE.Instance);
602 end if;
603 end Instantiation;
605 -------------------------
606 -- Instantiation_Depth --
607 -------------------------
609 function Instantiation_Depth (S : Source_Ptr) return Nat is
610 Sval : Source_Ptr;
611 Depth : Nat;
613 begin
614 Sval := S;
615 Depth := 0;
617 loop
618 Sval := Instantiation_Location (Sval);
619 exit when Sval = No_Location;
620 Depth := Depth + 1;
621 end loop;
623 return Depth;
624 end Instantiation_Depth;
626 ----------------------------
627 -- Instantiation_Location --
628 ----------------------------
630 function Instantiation_Location (S : Source_Ptr) return Source_Ptr is
631 begin
632 return Instantiation (Get_Source_File_Index (S));
633 end Instantiation_Location;
635 --------------------------
636 -- Iterate_On_Instances --
637 --------------------------
639 procedure Iterate_On_Instances is
640 begin
641 for J in 1 .. Instances.Last loop
642 Process (J, Instances.Table (J));
643 end loop;
644 end Iterate_On_Instances;
646 ----------------------
647 -- Last_Source_File --
648 ----------------------
650 function Last_Source_File return Source_File_Index is
651 begin
652 return Source_File.Last;
653 end Last_Source_File;
655 ----------------
656 -- Line_Start --
657 ----------------
659 function Line_Start (P : Source_Ptr) return Source_Ptr is
660 Sindex : constant Source_File_Index := Get_Source_File_Index (P);
661 Src : constant Source_Buffer_Ptr :=
662 Source_File.Table (Sindex).Source_Text;
663 Sfirst : constant Source_Ptr :=
664 Source_File.Table (Sindex).Source_First;
665 S : Source_Ptr;
667 begin
668 S := P;
669 while S > Sfirst
670 and then Src (S - 1) /= CR
671 and then Src (S - 1) /= LF
672 loop
673 S := S - 1;
674 end loop;
676 return S;
677 end Line_Start;
679 function Line_Start
680 (L : Physical_Line_Number;
681 S : Source_File_Index) return Source_Ptr
683 begin
684 return Source_File.Table (S).Lines_Table (L);
685 end Line_Start;
687 ----------
688 -- Lock --
689 ----------
691 procedure Lock is
692 begin
693 Source_File.Release;
694 Source_File.Locked := True;
695 end Lock;
697 ----------------------
698 -- Num_Source_Files --
699 ----------------------
701 function Num_Source_Files return Nat is
702 begin
703 return Int (Source_File.Last) - Int (Source_File.First) + 1;
704 end Num_Source_Files;
706 ----------------------
707 -- Num_Source_Lines --
708 ----------------------
710 function Num_Source_Lines (S : Source_File_Index) return Nat is
711 begin
712 return Nat (Source_File.Table (S).Last_Source_Line);
713 end Num_Source_Lines;
715 -----------------------
716 -- Original_Location --
717 -----------------------
719 function Original_Location (S : Source_Ptr) return Source_Ptr is
720 Sindex : Source_File_Index;
721 Tindex : Source_File_Index;
723 begin
724 if S <= No_Location then
725 return S;
727 else
728 Sindex := Get_Source_File_Index (S);
730 if Instantiation (Sindex) = No_Location then
731 return S;
733 else
734 Tindex := Template (Sindex);
735 while Instantiation (Tindex) /= No_Location loop
736 Tindex := Template (Tindex);
737 end loop;
739 return S - Source_First (Sindex) + Source_First (Tindex);
740 end if;
741 end if;
742 end Original_Location;
744 -------------------------
745 -- Physical_To_Logical --
746 -------------------------
748 function Physical_To_Logical
749 (Line : Physical_Line_Number;
750 S : Source_File_Index) return Logical_Line_Number
752 SFR : Source_File_Record renames Source_File.Table (S);
754 begin
755 if SFR.Num_SRef_Pragmas = 0 then
756 return Logical_Line_Number (Line);
757 else
758 return SFR.Logical_Lines_Table (Line);
759 end if;
760 end Physical_To_Logical;
762 --------------------------------
763 -- Register_Source_Ref_Pragma --
764 --------------------------------
766 procedure Register_Source_Ref_Pragma
767 (File_Name : File_Name_Type;
768 Stripped_File_Name : File_Name_Type;
769 Mapped_Line : Nat;
770 Line_After_Pragma : Physical_Line_Number)
772 subtype size_t is Memory.size_t;
774 SFR : Source_File_Record renames Source_File.Table (Current_Source_File);
776 ML : Logical_Line_Number;
778 begin
779 if File_Name /= No_File then
780 SFR.Reference_Name := Stripped_File_Name;
781 SFR.Full_Ref_Name := File_Name;
783 if not Debug_Generated_Code then
784 SFR.Debug_Source_Name := Stripped_File_Name;
785 SFR.Full_Debug_Name := File_Name;
786 end if;
788 SFR.Num_SRef_Pragmas := SFR.Num_SRef_Pragmas + 1;
789 end if;
791 if SFR.Num_SRef_Pragmas = 1 then
792 SFR.First_Mapped_Line := Logical_Line_Number (Mapped_Line);
793 end if;
795 if SFR.Logical_Lines_Table = null then
796 SFR.Logical_Lines_Table := To_Pointer
797 (Memory.Alloc
798 (size_t (SFR.Lines_Table_Max *
799 Logical_Lines_Table_Type'Component_Size /
800 Storage_Unit)));
801 end if;
803 SFR.Logical_Lines_Table (Line_After_Pragma - 1) := No_Line_Number;
805 ML := Logical_Line_Number (Mapped_Line);
806 for J in Line_After_Pragma .. SFR.Last_Source_Line loop
807 SFR.Logical_Lines_Table (J) := ML;
808 ML := ML + 1;
809 end loop;
810 end Register_Source_Ref_Pragma;
812 ---------------------------------
813 -- Set_Source_File_Index_Table --
814 ---------------------------------
816 procedure Set_Source_File_Index_Table (Xnew : Source_File_Index) is
817 Ind : Int;
818 SP : Source_Ptr;
819 SL : constant Source_Ptr := Source_File.Table (Xnew).Source_Last;
820 begin
821 SP := Source_File.Table (Xnew).Source_First;
822 pragma Assert (SP mod Source_Align = 0);
823 Ind := Int (SP) / Source_Align;
824 while SP <= SL loop
825 Source_File_Index_Table (Ind) := Xnew;
826 SP := SP + Source_Align;
827 Ind := Ind + 1;
828 end loop;
829 end Set_Source_File_Index_Table;
831 ---------------------------
832 -- Skip_Line_Terminators --
833 ---------------------------
835 procedure Skip_Line_Terminators
836 (P : in out Source_Ptr;
837 Physical : out Boolean)
839 Chr : constant Character := Source (P);
841 begin
842 if Chr = CR then
843 if Source (P + 1) = LF then
844 P := P + 2;
845 else
846 P := P + 1;
847 end if;
849 elsif Chr = LF then
850 P := P + 1;
852 elsif Chr = FF or else Chr = VT then
853 P := P + 1;
854 Physical := False;
855 return;
857 -- Otherwise we have a wide character
859 else
860 Skip_Wide (Source, P);
861 end if;
863 -- Fall through in the physical line terminator case. First deal with
864 -- making a possible entry into the lines table if one is needed.
866 -- Note: we are dealing with a real source file here, this cannot be
867 -- the instantiation case, so we need not worry about Sloc adjustment.
869 declare
870 S : Source_File_Record
871 renames Source_File.Table (Current_Source_File);
873 begin
874 Physical := True;
876 -- Make entry in lines table if not already made (in some scan backup
877 -- cases, we will be rescanning previously scanned source, so the
878 -- entry may have already been made on the previous forward scan).
880 if Source (P) /= EOF
881 and then P > S.Lines_Table (S.Last_Source_Line)
882 then
883 Add_Line_Tables_Entry (S, P);
884 end if;
885 end;
886 end Skip_Line_Terminators;
888 --------------
889 -- Set_Dope --
890 --------------
892 procedure Set_Dope
893 (Src : System.Address; New_Dope : Dope_Ptr)
895 -- A fat pointer is a pair consisting of data pointer and dope pointer,
896 -- in that order. So we want to overwrite the second word.
897 Dope : System.Address;
898 pragma Import (Ada, Dope);
899 use System.Storage_Elements;
900 for Dope'Address use Src + System.Address'Size / 8;
901 begin
902 Dope := New_Dope.all'Address;
903 end Set_Dope;
905 procedure Free_Dope (Src : System.Address) is
906 Dope : Dope_Ptr;
907 pragma Import (Ada, Dope);
908 use System.Storage_Elements;
909 for Dope'Address use Src + System.Address'Size / 8;
910 procedure Free is new Ada.Unchecked_Deallocation (Dope_Rec, Dope_Ptr);
911 begin
912 Free (Dope);
913 end Free_Dope;
915 ----------------
916 -- Sloc_Range --
917 ----------------
919 procedure Sloc_Range (N : Node_Id; Min, Max : out Source_Ptr) is
921 Indx : constant Source_File_Index := Get_Source_File_Index (Sloc (N));
923 function Process (N : Node_Id) return Traverse_Result;
924 -- Process function for traversing the node tree
926 procedure Traverse is new Traverse_Proc (Process);
928 -------------
929 -- Process --
930 -------------
932 function Process (N : Node_Id) return Traverse_Result is
933 Loc : constant Source_Ptr := Sloc (Original_Node (N));
935 begin
936 -- Skip nodes that may have been added during expansion and
937 -- that originate in other units, such as code for contracts
938 -- in subprogram bodies.
940 if Get_Source_File_Index (Loc) /= Indx then
941 return Skip;
942 end if;
944 if Loc > No_Location then
945 if Loc < Min then
946 Min := Loc;
947 elsif Loc > Max then
948 Max := Loc;
949 end if;
950 end if;
952 return OK_Orig;
953 end Process;
955 -- Start of processing for Sloc_Range
957 begin
958 Min := Sloc (N);
959 Max := Min;
960 Traverse (N);
961 end Sloc_Range;
963 -------------------
964 -- Source_Offset --
965 -------------------
967 function Source_Offset (S : Source_Ptr) return Nat is
968 Sindex : constant Source_File_Index := Get_Source_File_Index (S);
969 Sfirst : constant Source_Ptr :=
970 Source_File.Table (Sindex).Source_First;
971 begin
972 return Nat (S - Sfirst);
973 end Source_Offset;
975 ------------------------
976 -- Top_Level_Location --
977 ------------------------
979 function Top_Level_Location (S : Source_Ptr) return Source_Ptr is
980 Oldloc : Source_Ptr;
981 Newloc : Source_Ptr;
983 begin
984 Newloc := S;
985 loop
986 Oldloc := Newloc;
987 Newloc := Instantiation_Location (Oldloc);
988 exit when Newloc = No_Location;
989 end loop;
991 return Oldloc;
992 end Top_Level_Location;
994 --------------------
995 -- Write_Location --
996 --------------------
998 procedure Write_Location (P : Source_Ptr) is
999 begin
1000 if P = No_Location then
1001 Write_Str ("<no location>");
1003 elsif P <= Standard_Location then
1004 Write_Str ("<standard location>");
1006 else
1007 declare
1008 SI : constant Source_File_Index := Get_Source_File_Index (P);
1010 begin
1011 Write_Name_For_Debug (Debug_Source_Name (SI));
1012 Write_Char (':');
1013 Write_Int (Int (Get_Logical_Line_Number (P)));
1014 Write_Char (':');
1015 Write_Int (Int (Get_Column_Number (P)));
1017 if Instantiation (SI) /= No_Location then
1018 Write_Str (" [");
1019 Write_Location (Instantiation (SI));
1020 Write_Char (']');
1021 end if;
1022 end;
1023 end if;
1024 end Write_Location;
1026 ----------------------
1027 -- Write_Time_Stamp --
1028 ----------------------
1030 procedure Write_Time_Stamp (S : Source_File_Index) is
1031 T : constant Time_Stamp_Type := Time_Stamp (S);
1032 P : Natural;
1034 begin
1035 if T (1) = '9' then
1036 Write_Str ("19");
1037 P := 0;
1038 else
1039 Write_Char (T (1));
1040 Write_Char (T (2));
1041 P := 2;
1042 end if;
1044 Write_Char (T (P + 1));
1045 Write_Char (T (P + 2));
1046 Write_Char ('-');
1048 Write_Char (T (P + 3));
1049 Write_Char (T (P + 4));
1050 Write_Char ('-');
1052 Write_Char (T (P + 5));
1053 Write_Char (T (P + 6));
1054 Write_Char (' ');
1056 Write_Char (T (P + 7));
1057 Write_Char (T (P + 8));
1058 Write_Char (':');
1060 Write_Char (T (P + 9));
1061 Write_Char (T (P + 10));
1062 Write_Char (':');
1064 Write_Char (T (P + 11));
1065 Write_Char (T (P + 12));
1066 end Write_Time_Stamp;
1068 ----------------------------------------------
1069 -- Access Subprograms for Source File Table --
1070 ----------------------------------------------
1072 function Debug_Source_Name (S : SFI) return File_Name_Type is
1073 begin
1074 return Source_File.Table (S).Debug_Source_Name;
1075 end Debug_Source_Name;
1077 function Instance (S : SFI) return Instance_Id is
1078 begin
1079 return Source_File.Table (S).Instance;
1080 end Instance;
1082 function File_Name (S : SFI) return File_Name_Type is
1083 begin
1084 return Source_File.Table (S).File_Name;
1085 end File_Name;
1087 function File_Type (S : SFI) return Type_Of_File is
1088 begin
1089 return Source_File.Table (S).File_Type;
1090 end File_Type;
1092 function First_Mapped_Line (S : SFI) return Logical_Line_Number is
1093 begin
1094 return Source_File.Table (S).First_Mapped_Line;
1095 end First_Mapped_Line;
1097 function Full_Debug_Name (S : SFI) return File_Name_Type is
1098 begin
1099 return Source_File.Table (S).Full_Debug_Name;
1100 end Full_Debug_Name;
1102 function Full_File_Name (S : SFI) return File_Name_Type is
1103 begin
1104 return Source_File.Table (S).Full_File_Name;
1105 end Full_File_Name;
1107 function Full_Ref_Name (S : SFI) return File_Name_Type is
1108 begin
1109 return Source_File.Table (S).Full_Ref_Name;
1110 end Full_Ref_Name;
1112 function Identifier_Casing (S : SFI) return Casing_Type is
1113 begin
1114 return Source_File.Table (S).Identifier_Casing;
1115 end Identifier_Casing;
1117 function Inherited_Pragma (S : SFI) return Boolean is
1118 begin
1119 return Source_File.Table (S).Inherited_Pragma;
1120 end Inherited_Pragma;
1122 function Inlined_Body (S : SFI) return Boolean is
1123 begin
1124 return Source_File.Table (S).Inlined_Body;
1125 end Inlined_Body;
1127 function Inlined_Call (S : SFI) return Source_Ptr is
1128 begin
1129 return Source_File.Table (S).Inlined_Call;
1130 end Inlined_Call;
1132 function Keyword_Casing (S : SFI) return Casing_Type is
1133 begin
1134 return Source_File.Table (S).Keyword_Casing;
1135 end Keyword_Casing;
1137 function Last_Source_Line (S : SFI) return Physical_Line_Number is
1138 begin
1139 return Source_File.Table (S).Last_Source_Line;
1140 end Last_Source_Line;
1142 function License (S : SFI) return License_Type is
1143 begin
1144 return Source_File.Table (S).License;
1145 end License;
1147 function Num_SRef_Pragmas (S : SFI) return Nat is
1148 begin
1149 return Source_File.Table (S).Num_SRef_Pragmas;
1150 end Num_SRef_Pragmas;
1152 function Reference_Name (S : SFI) return File_Name_Type is
1153 begin
1154 return Source_File.Table (S).Reference_Name;
1155 end Reference_Name;
1157 function Source_Checksum (S : SFI) return Word is
1158 begin
1159 return Source_File.Table (S).Source_Checksum;
1160 end Source_Checksum;
1162 function Source_First (S : SFI) return Source_Ptr is
1163 begin
1164 return Source_File.Table (S).Source_First;
1165 end Source_First;
1167 function Source_Last (S : SFI) return Source_Ptr is
1168 begin
1169 return Source_File.Table (S).Source_Last;
1170 end Source_Last;
1172 function Source_Text (S : SFI) return Source_Buffer_Ptr is
1173 begin
1174 return Source_File.Table (S).Source_Text;
1175 end Source_Text;
1177 function Template (S : SFI) return SFI is
1178 begin
1179 return Source_File.Table (S).Template;
1180 end Template;
1182 function Time_Stamp (S : SFI) return Time_Stamp_Type is
1183 begin
1184 return Source_File.Table (S).Time_Stamp;
1185 end Time_Stamp;
1187 function Unit (S : SFI) return Unit_Number_Type is
1188 begin
1189 return Source_File.Table (S).Unit;
1190 end Unit;
1192 ------------------------------------------
1193 -- Set Procedures for Source File Table --
1194 ------------------------------------------
1196 procedure Set_Identifier_Casing (S : SFI; C : Casing_Type) is
1197 begin
1198 Source_File.Table (S).Identifier_Casing := C;
1199 end Set_Identifier_Casing;
1201 procedure Set_Keyword_Casing (S : SFI; C : Casing_Type) is
1202 begin
1203 Source_File.Table (S).Keyword_Casing := C;
1204 end Set_Keyword_Casing;
1206 procedure Set_License (S : SFI; L : License_Type) is
1207 begin
1208 Source_File.Table (S).License := L;
1209 end Set_License;
1211 procedure Set_Unit (S : SFI; U : Unit_Number_Type) is
1212 begin
1213 Source_File.Table (S).Unit := U;
1214 end Set_Unit;
1216 ----------------------
1217 -- Trim_Lines_Table --
1218 ----------------------
1220 procedure Trim_Lines_Table (S : Source_File_Index) is
1221 Max : constant Nat := Nat (Source_File.Table (S).Last_Source_Line);
1223 begin
1224 -- Release allocated storage that is no longer needed
1226 Source_File.Table (S).Lines_Table := To_Pointer
1227 (Memory.Realloc
1228 (To_Address (Source_File.Table (S).Lines_Table),
1229 Memory.size_t
1230 (Max * (Lines_Table_Type'Component_Size / System.Storage_Unit))));
1231 Source_File.Table (S).Lines_Table_Max := Physical_Line_Number (Max);
1232 end Trim_Lines_Table;
1234 ------------
1235 -- Unlock --
1236 ------------
1238 procedure Unlock is
1239 begin
1240 Source_File.Locked := False;
1241 Source_File.Release;
1242 end Unlock;
1244 --------
1245 -- wl --
1246 --------
1248 procedure wl (P : Source_Ptr) is
1249 begin
1250 Write_Location (P);
1251 Write_Eol;
1252 end wl;
1254 end Sinput;