| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- S I N P U T -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING3. If not, go to -- |
| -- http://www.gnu.org/licenses for a complete copy of the license. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| pragma Style_Checks (All_Checks); |
| -- Subprograms not all in alpha order |
| |
| with Atree; use Atree; |
| with Debug; use Debug; |
| with Opt; use Opt; |
| with Output; use Output; |
| with Scans; use Scans; |
| with Sinfo; use Sinfo; |
| with Sinfo.Nodes; use Sinfo.Nodes; |
| with Widechar; use Widechar; |
| |
| with GNAT.Byte_Order_Mark; use GNAT.Byte_Order_Mark; |
| |
| with System.Storage_Elements; |
| with System.Memory; |
| with System.WCh_Con; use System.WCh_Con; |
| |
| with Unchecked_Conversion; |
| with Unchecked_Deallocation; |
| |
| package body Sinput is |
| |
| use ASCII, System; |
| |
| -- Routines to support conversion between types Lines_Table_Ptr, |
| -- Logical_Lines_Table_Ptr and System.Address. |
| |
| pragma Warnings (Off); |
| -- These unchecked conversions are aliasing safe, since they are never |
| -- used to construct improperly aliased pointer values. |
| |
| function To_Address is |
| new Unchecked_Conversion (Lines_Table_Ptr, Address); |
| |
| function To_Address is |
| new Unchecked_Conversion (Logical_Lines_Table_Ptr, Address); |
| |
| function To_Pointer is |
| new Unchecked_Conversion (Address, Lines_Table_Ptr); |
| |
| function To_Pointer is |
| new Unchecked_Conversion (Address, Logical_Lines_Table_Ptr); |
| |
| pragma Warnings (On); |
| |
| ----------------------------- |
| -- Source_File_Index_Table -- |
| ----------------------------- |
| |
| -- The Get_Source_File_Index function is called very frequently. Earlier |
| -- versions cached a single entry, but then reverted to a serial search, |
| -- and this proved to be a significant source of inefficiency. We then |
| -- switched to using a table with a start point followed by a serial |
| -- search. Now we make sure source buffers are on a reasonable boundary |
| -- (see Types.Source_Align), and we can just use a direct look up in the |
| -- following table. |
| |
| -- Note that this array is pretty large, but in most operating systems |
| -- it will not be allocated in physical memory unless it is actually used. |
| |
| Source_File_Index_Table : |
| array (Int range 0 .. 1 + (Int'Last / Source_Align)) of Source_File_Index; |
| |
| --------------------------- |
| -- Add_Line_Tables_Entry -- |
| --------------------------- |
| |
| procedure Add_Line_Tables_Entry |
| (S : in out Source_File_Record; |
| P : Source_Ptr) |
| is |
| LL : Physical_Line_Number; |
| |
| begin |
| -- Reallocate the lines tables if necessary |
| |
| -- Note: the reason we do not use the normal Table package |
| -- mechanism is that we have several of these tables. We could |
| -- use the new GNAT.Dynamic_Tables package and that would probably |
| -- be a good idea ??? |
| |
| if S.Last_Source_Line = S.Lines_Table_Max then |
| Alloc_Line_Tables |
| (S, |
| Int (S.Last_Source_Line) * |
| ((100 + Alloc.Lines_Increment) / 100)); |
| |
| if Debug_Flag_D then |
| Write_Str ("--> Reallocating lines table, size = "); |
| Write_Int (Int (S.Lines_Table_Max)); |
| Write_Eol; |
| end if; |
| end if; |
| |
| S.Last_Source_Line := S.Last_Source_Line + 1; |
| LL := S.Last_Source_Line; |
| |
| S.Lines_Table (LL) := P; |
| |
| -- Deal with setting new entry in logical lines table if one is |
| -- present. Note that there is always space (because the call to |
| -- Alloc_Line_Tables makes sure both tables are the same length), |
| |
| if S.Logical_Lines_Table /= null then |
| |
| -- We can always set the entry from the previous one, because |
| -- the processing for a Source_Reference pragma ensures that |
| -- at least one entry following the pragma is set up correctly. |
| |
| S.Logical_Lines_Table (LL) := S.Logical_Lines_Table (LL - 1) + 1; |
| end if; |
| end Add_Line_Tables_Entry; |
| |
| ----------------------- |
| -- Alloc_Line_Tables -- |
| ----------------------- |
| |
| procedure Alloc_Line_Tables |
| (S : in out Source_File_Record; |
| New_Max : Nat) |
| is |
| subtype size_t is Memory.size_t; |
| |
| New_Table : Lines_Table_Ptr; |
| |
| New_Logical_Table : Logical_Lines_Table_Ptr; |
| |
| New_Size : constant size_t := |
| size_t (New_Max * Lines_Table_Type'Component_Size / |
| Storage_Unit); |
| |
| begin |
| if S.Lines_Table = null then |
| New_Table := To_Pointer (Memory.Alloc (New_Size)); |
| |
| else |
| New_Table := |
| To_Pointer (Memory.Realloc (To_Address (S.Lines_Table), New_Size)); |
| end if; |
| |
| if New_Table = null then |
| raise Storage_Error; |
| else |
| S.Lines_Table := New_Table; |
| S.Lines_Table_Max := Physical_Line_Number (New_Max); |
| end if; |
| |
| if S.Num_SRef_Pragmas /= 0 then |
| if S.Logical_Lines_Table = null then |
| New_Logical_Table := To_Pointer (Memory.Alloc (New_Size)); |
| else |
| New_Logical_Table := To_Pointer |
| (Memory.Realloc (To_Address (S.Logical_Lines_Table), New_Size)); |
| end if; |
| |
| if New_Logical_Table = null then |
| raise Storage_Error; |
| else |
| S.Logical_Lines_Table := New_Logical_Table; |
| end if; |
| end if; |
| end Alloc_Line_Tables; |
| |
| ----------------- |
| -- Backup_Line -- |
| ----------------- |
| |
| procedure Backup_Line (P : in out Source_Ptr) is |
| Sindex : constant Source_File_Index := Get_Source_File_Index (P); |
| Src : constant Source_Buffer_Ptr := |
| Source_File.Table (Sindex).Source_Text; |
| Sfirst : constant Source_Ptr := |
| Source_File.Table (Sindex).Source_First; |
| |
| begin |
| P := P - 1; |
| |
| if P = Sfirst then |
| return; |
| end if; |
| |
| if Src (P) = CR then |
| if Src (P - 1) = LF then |
| P := P - 1; |
| end if; |
| |
| else -- Src (P) = LF |
| if Src (P - 1) = CR then |
| P := P - 1; |
| end if; |
| end if; |
| |
| -- Now find first character of the previous line |
| |
| while P > Sfirst |
| and then Src (P - 1) /= LF |
| and then Src (P - 1) /= CR |
| loop |
| P := P - 1; |
| end loop; |
| end Backup_Line; |
| |
| --------------------------- |
| -- Build_Location_String -- |
| --------------------------- |
| |
| procedure Build_Location_String |
| (Buf : in out Bounded_String; |
| Loc : Source_Ptr) |
| is |
| Ptr : Source_Ptr := Loc; |
| |
| begin |
| -- Loop through instantiations |
| |
| loop |
| Append (Buf, Reference_Name (Get_Source_File_Index (Ptr))); |
| Append (Buf, ':'); |
| Append (Buf, Nat (Get_Logical_Line_Number (Ptr))); |
| |
| Ptr := Instantiation_Location (Ptr); |
| exit when Ptr = No_Location; |
| Append (Buf, " instantiated at "); |
| end loop; |
| end Build_Location_String; |
| |
| function Build_Location_String (Loc : Source_Ptr) return String is |
| Buf : Bounded_String; |
| begin |
| Build_Location_String (Buf, Loc); |
| return +Buf; |
| end Build_Location_String; |
| |
| ------------------- |
| -- Check_For_BOM -- |
| ------------------- |
| |
| procedure Check_For_BOM is |
| BOM : BOM_Kind; |
| Len : Natural; |
| Tst : String (1 .. 5); |
| C : Character; |
| |
| begin |
| for J in 1 .. 5 loop |
| C := Source (Scan_Ptr + Source_Ptr (J) - 1); |
| |
| -- Definitely no BOM if EOF character marks either end of file, or |
| -- an illegal non-BOM character if not at the end of file. |
| |
| if C = EOF then |
| return; |
| end if; |
| |
| Tst (J) := C; |
| end loop; |
| |
| Read_BOM (Tst, Len, BOM, XML_Support => False); |
| |
| case BOM is |
| when UTF8_All => |
| Scan_Ptr := Scan_Ptr + Source_Ptr (Len); |
| First_Non_Blank_Location := Scan_Ptr; |
| Current_Line_Start := Scan_Ptr; |
| Wide_Character_Encoding_Method := WCEM_UTF8; |
| Upper_Half_Encoding := True; |
| |
| when UTF16_BE |
| | UTF16_LE |
| => |
| Set_Standard_Error; |
| Write_Line ("UTF-16 encoding format not recognized"); |
| Set_Standard_Output; |
| raise Unrecoverable_Error; |
| |
| when UTF32_BE |
| | UTF32_LE |
| => |
| Set_Standard_Error; |
| Write_Line ("UTF-32 encoding format not recognized"); |
| Set_Standard_Output; |
| raise Unrecoverable_Error; |
| |
| when Unknown => |
| null; |
| |
| when others => |
| raise Program_Error; |
| end case; |
| end Check_For_BOM; |
| |
| ----------------------------- |
| -- Clear_Source_File_Table -- |
| ----------------------------- |
| |
| procedure Free is new Unchecked_Deallocation |
| (Lines_Table_Type, Lines_Table_Ptr); |
| |
| procedure Free is new Unchecked_Deallocation |
| (Logical_Lines_Table_Type, Logical_Lines_Table_Ptr); |
| |
| procedure Clear_Source_File_Table is |
| begin |
| for X in 1 .. Source_File.Last loop |
| declare |
| S : Source_File_Record renames Source_File.Table (X); |
| begin |
| if S.Instance = No_Instance_Id then |
| Free_Source_Buffer (S.Source_Text); |
| else |
| Free_Dope (S.Source_Text'Address); |
| S.Source_Text := null; |
| end if; |
| |
| Free (S.Lines_Table); |
| Free (S.Logical_Lines_Table); |
| end; |
| end loop; |
| |
| Source_File.Free; |
| Sinput.Initialize; |
| end Clear_Source_File_Table; |
| |
| --------------------------------- |
| -- Comes_From_Inherited_Pragma -- |
| --------------------------------- |
| |
| function Comes_From_Inherited_Pragma (S : Source_Ptr) return Boolean is |
| SIE : Source_File_Record renames |
| Source_File.Table (Get_Source_File_Index (S)); |
| begin |
| return SIE.Inherited_Pragma; |
| end Comes_From_Inherited_Pragma; |
| |
| ----------------------------- |
| -- Comes_From_Inlined_Body -- |
| ----------------------------- |
| |
| function Comes_From_Inlined_Body (S : Source_Ptr) return Boolean is |
| SIE : Source_File_Record renames |
| Source_File.Table (Get_Source_File_Index (S)); |
| begin |
| return SIE.Inlined_Body; |
| end Comes_From_Inlined_Body; |
| |
| ------------------------ |
| -- Free_Source_Buffer -- |
| ------------------------ |
| |
| procedure Free_Source_Buffer (Src : in out Source_Buffer_Ptr) is |
| -- Unchecked_Deallocation doesn't work for access-to-constant; we need |
| -- to first Unchecked_Convert to access-to-variable. |
| |
| function To_Source_Buffer_Ptr_Var is new |
| Unchecked_Conversion (Source_Buffer_Ptr, Source_Buffer_Ptr_Var); |
| |
| Temp : Source_Buffer_Ptr_Var := To_Source_Buffer_Ptr_Var (Src); |
| |
| procedure Free_Ptr is new |
| Unchecked_Deallocation (Source_Buffer, Source_Buffer_Ptr_Var); |
| begin |
| Free_Ptr (Temp); |
| Src := null; |
| end Free_Source_Buffer; |
| |
| ----------------------- |
| -- Get_Column_Number -- |
| ----------------------- |
| |
| function Get_Column_Number (P : Source_Ptr) return Column_Number is |
| S : Source_Ptr; |
| C : Column_Number; |
| Sindex : Source_File_Index; |
| Src : Source_Buffer_Ptr; |
| |
| begin |
| -- If the input source pointer is not a meaningful value then return |
| -- at once with column number 1. This can happen for a file not found |
| -- condition for a file loaded indirectly by RTE, and also perhaps on |
| -- some unknown internal error conditions. In either case we certainly |
| -- don't want to blow up. |
| |
| if P < 1 then |
| return 1; |
| |
| else |
| Sindex := Get_Source_File_Index (P); |
| Src := Source_File.Table (Sindex).Source_Text; |
| S := Line_Start (P); |
| C := 1; |
| |
| while S < P loop |
| if Src (S) = HT then |
| C := (C - 1) / 8 * 8 + (8 + 1); |
| S := S + 1; |
| |
| -- Deal with wide character case, but don't include brackets |
| -- notation in this circuit, since we know that this will |
| -- display unencoded (no one encodes brackets notation). |
| |
| elsif Src (S) /= '[' and then Is_Start_Of_Wide_Char (Src, S) then |
| C := C + 1; |
| Skip_Wide (Src, S); |
| |
| -- Normal (non-wide) character case or brackets sequence |
| |
| else |
| C := C + 1; |
| S := S + 1; |
| end if; |
| end loop; |
| |
| return C; |
| end if; |
| end Get_Column_Number; |
| |
| ----------------------------- |
| -- Get_Logical_Line_Number -- |
| ----------------------------- |
| |
| function Get_Logical_Line_Number |
| (P : Source_Ptr) return Logical_Line_Number |
| is |
| SFR : Source_File_Record |
| renames Source_File.Table (Get_Source_File_Index (P)); |
| |
| L : constant Physical_Line_Number := Get_Physical_Line_Number (P); |
| |
| begin |
| if SFR.Num_SRef_Pragmas = 0 then |
| return Logical_Line_Number (L); |
| else |
| return SFR.Logical_Lines_Table (L); |
| end if; |
| end Get_Logical_Line_Number; |
| |
| --------------------------------- |
| -- Get_Logical_Line_Number_Img -- |
| --------------------------------- |
| |
| function Get_Logical_Line_Number_Img |
| (P : Source_Ptr) return String |
| is |
| begin |
| Name_Len := 0; |
| Add_Nat_To_Name_Buffer (Nat (Get_Logical_Line_Number (P))); |
| return Name_Buffer (1 .. Name_Len); |
| end Get_Logical_Line_Number_Img; |
| |
| ------------------------------ |
| -- Get_Physical_Line_Number -- |
| ------------------------------ |
| |
| function Get_Physical_Line_Number |
| (P : Source_Ptr) return Physical_Line_Number |
| is |
| Sfile : Source_File_Index; |
| Table : Lines_Table_Ptr; |
| Lo : Physical_Line_Number; |
| Hi : Physical_Line_Number; |
| Mid : Physical_Line_Number; |
| Loc : Source_Ptr; |
| |
| begin |
| -- If the input source pointer is not a meaningful value then return |
| -- at once with line number 1. This can happen for a file not found |
| -- condition for a file loaded indirectly by RTE, and also perhaps on |
| -- some unknown internal error conditions. In either case we certainly |
| -- don't want to blow up. |
| |
| if P < 1 then |
| return 1; |
| |
| -- Otherwise we can do the binary search |
| |
| else |
| Sfile := Get_Source_File_Index (P); |
| Loc := P + Source_File.Table (Sfile).Sloc_Adjust; |
| Table := Source_File.Table (Sfile).Lines_Table; |
| Lo := 1; |
| Hi := Source_File.Table (Sfile).Last_Source_Line; |
| |
| loop |
| Mid := (Lo + Hi) / 2; |
| |
| if Loc < Table (Mid) then |
| Hi := Mid - 1; |
| |
| else -- Loc >= Table (Mid) |
| |
| if Mid = Hi or else |
| Loc < Table (Mid + 1) |
| then |
| return Mid; |
| else |
| Lo := Mid + 1; |
| end if; |
| |
| end if; |
| |
| end loop; |
| end if; |
| end Get_Physical_Line_Number; |
| |
| --------------------------- |
| -- Get_Source_File_Index -- |
| --------------------------- |
| |
| function Get_Source_File_Index (S : Source_Ptr) return Source_File_Index is |
| Result : Source_File_Index; |
| |
| procedure Assertions; |
| -- Assert various properties of the result |
| |
| procedure Assertions is |
| |
| -- ???The old version using zero-origin array indexing without array |
| -- bounds checks returned 1 (i.e. system.ads) for these special |
| -- locations, presumably by accident. We are mimicing that here. |
| |
| Special : constant Boolean := |
| S = No_Location |
| or else S = Standard_Location |
| or else S = Standard_ASCII_Location |
| or else S = System_Location; |
| |
| pragma Assert ((S > No_Location) xor Special); |
| pragma Assert (Result in Source_File.First .. Source_File.Last); |
| |
| SFR : Source_File_Record renames Source_File.Table (Result); |
| |
| begin |
| -- SFR.Source_Text = null if and only if this is the SFR for a debug |
| -- output file (*.dg), and that file is under construction. S can be |
| -- slightly past Source_Last in that case because we haven't updated |
| -- Source_Last. |
| |
| if Null_Source_Buffer_Ptr (SFR.Source_Text) then |
| pragma Assert (S >= SFR.Source_First); null; |
| else |
| pragma Assert (SFR.Source_Text'First = SFR.Source_First); |
| pragma Assert (SFR.Source_Text'Last = SFR.Source_Last); |
| |
| if not Special then |
| pragma Assert (S in SFR.Source_First .. SFR.Source_Last); |
| null; |
| end if; |
| end if; |
| end Assertions; |
| |
| -- Start of processing for Get_Source_File_Index |
| |
| begin |
| if S > No_Location then |
| Result := Source_File_Index_Table (Int (S) / Source_Align); |
| else |
| Result := 1; |
| end if; |
| |
| pragma Debug (Assertions); |
| |
| return Result; |
| end Get_Source_File_Index; |
| |
| ---------------- |
| -- Initialize -- |
| ---------------- |
| |
| procedure Initialize is |
| begin |
| Source_gnat_adc := No_Source_File; |
| Source_File.Init; |
| Instances.Init; |
| Instances.Append (No_Location); |
| pragma Assert (Instances.Last = No_Instance_Id); |
| end Initialize; |
| |
| ------------------- |
| -- Instantiation -- |
| ------------------- |
| |
| function Instantiation (S : SFI) return Source_Ptr is |
| SIE : Source_File_Record renames Source_File.Table (S); |
| begin |
| if SIE.Inlined_Body or SIE.Inherited_Pragma then |
| return SIE.Inlined_Call; |
| else |
| return Instances.Table (SIE.Instance); |
| end if; |
| end Instantiation; |
| |
| ------------------------- |
| -- Instantiation_Depth -- |
| ------------------------- |
| |
| function Instantiation_Depth (S : Source_Ptr) return Nat is |
| Sind : Source_File_Index; |
| Sval : Source_Ptr; |
| Depth : Nat; |
| |
| begin |
| Sval := S; |
| Depth := 0; |
| |
| loop |
| Sind := Get_Source_File_Index (Sval); |
| Sval := Instantiation (Sind); |
| exit when Sval = No_Location; |
| Depth := Depth + 1; |
| end loop; |
| |
| return Depth; |
| end Instantiation_Depth; |
| |
| ---------------------------- |
| -- Instantiation_Location -- |
| ---------------------------- |
| |
| function Instantiation_Location (S : Source_Ptr) return Source_Ptr is |
| begin |
| return Instantiation (Get_Source_File_Index (S)); |
| end Instantiation_Location; |
| |
| -------------------------- |
| -- Iterate_On_Instances -- |
| -------------------------- |
| |
| procedure Iterate_On_Instances is |
| begin |
| for J in 1 .. Instances.Last loop |
| Process (J, Instances.Table (J)); |
| end loop; |
| end Iterate_On_Instances; |
| |
| ---------------------- |
| -- Last_Source_File -- |
| ---------------------- |
| |
| function Last_Source_File return Source_File_Index is |
| begin |
| return Source_File.Last; |
| end Last_Source_File; |
| |
| ---------------- |
| -- Line_Start -- |
| ---------------- |
| |
| function Line_Start (P : Source_Ptr) return Source_Ptr is |
| Sindex : constant Source_File_Index := Get_Source_File_Index (P); |
| Src : constant Source_Buffer_Ptr := |
| Source_File.Table (Sindex).Source_Text; |
| Sfirst : constant Source_Ptr := |
| Source_File.Table (Sindex).Source_First; |
| S : Source_Ptr; |
| |
| begin |
| S := P; |
| while S > Sfirst |
| and then Src (S - 1) /= CR |
| and then Src (S - 1) /= LF |
| loop |
| S := S - 1; |
| end loop; |
| |
| return S; |
| end Line_Start; |
| |
| function Line_Start |
| (L : Physical_Line_Number; |
| S : Source_File_Index) return Source_Ptr |
| is |
| begin |
| return Source_File.Table (S).Lines_Table (L); |
| end Line_Start; |
| |
| ---------- |
| -- Lock -- |
| ---------- |
| |
| procedure Lock is |
| begin |
| Source_File.Release; |
| Source_File.Locked := True; |
| end Lock; |
| |
| ---------------------- |
| -- Num_Source_Files -- |
| ---------------------- |
| |
| function Num_Source_Files return Nat is |
| begin |
| return Int (Source_File.Last) - Int (Source_File.First) + 1; |
| end Num_Source_Files; |
| |
| ---------------------- |
| -- Num_Source_Lines -- |
| ---------------------- |
| |
| function Num_Source_Lines (S : Source_File_Index) return Nat is |
| begin |
| return Nat (Source_File.Table (S).Last_Source_Line); |
| end Num_Source_Lines; |
| |
| ----------------------- |
| -- Original_Location -- |
| ----------------------- |
| |
| function Original_Location (S : Source_Ptr) return Source_Ptr is |
| Sindex : Source_File_Index; |
| Tindex : Source_File_Index; |
| |
| begin |
| if S <= No_Location then |
| return S; |
| |
| else |
| Sindex := Get_Source_File_Index (S); |
| |
| if Instantiation (Sindex) = No_Location then |
| return S; |
| |
| else |
| Tindex := Template (Sindex); |
| while Instantiation (Tindex) /= No_Location loop |
| Tindex := Template (Tindex); |
| end loop; |
| |
| return S - Source_First (Sindex) + Source_First (Tindex); |
| end if; |
| end if; |
| end Original_Location; |
| |
| ------------------------- |
| -- Physical_To_Logical -- |
| ------------------------- |
| |
| function Physical_To_Logical |
| (Line : Physical_Line_Number; |
| S : Source_File_Index) return Logical_Line_Number |
| is |
| SFR : Source_File_Record renames Source_File.Table (S); |
| |
| begin |
| if SFR.Num_SRef_Pragmas = 0 then |
| return Logical_Line_Number (Line); |
| else |
| return SFR.Logical_Lines_Table (Line); |
| end if; |
| end Physical_To_Logical; |
| |
| -------------------------------- |
| -- Register_Source_Ref_Pragma -- |
| -------------------------------- |
| |
| procedure Register_Source_Ref_Pragma |
| (File_Name : File_Name_Type; |
| Stripped_File_Name : File_Name_Type; |
| Mapped_Line : Nat; |
| Line_After_Pragma : Physical_Line_Number) |
| is |
| subtype size_t is Memory.size_t; |
| |
| SFR : Source_File_Record renames Source_File.Table (Current_Source_File); |
| |
| ML : Logical_Line_Number; |
| |
| begin |
| if File_Name /= No_File then |
| SFR.Reference_Name := Stripped_File_Name; |
| SFR.Full_Ref_Name := File_Name; |
| |
| if not Debug_Generated_Code then |
| SFR.Debug_Source_Name := Stripped_File_Name; |
| SFR.Full_Debug_Name := File_Name; |
| end if; |
| |
| SFR.Num_SRef_Pragmas := SFR.Num_SRef_Pragmas + 1; |
| end if; |
| |
| if SFR.Num_SRef_Pragmas = 1 then |
| SFR.First_Mapped_Line := Logical_Line_Number (Mapped_Line); |
| end if; |
| |
| if SFR.Logical_Lines_Table = null then |
| SFR.Logical_Lines_Table := To_Pointer |
| (Memory.Alloc |
| (size_t (SFR.Lines_Table_Max * |
| Logical_Lines_Table_Type'Component_Size / |
| Storage_Unit))); |
| end if; |
| |
| SFR.Logical_Lines_Table (Line_After_Pragma - 1) := No_Line_Number; |
| |
| ML := Logical_Line_Number (Mapped_Line); |
| for J in Line_After_Pragma .. SFR.Last_Source_Line loop |
| SFR.Logical_Lines_Table (J) := ML; |
| ML := ML + 1; |
| end loop; |
| end Register_Source_Ref_Pragma; |
| |
| --------------------------------- |
| -- Set_Source_File_Index_Table -- |
| --------------------------------- |
| |
| procedure Set_Source_File_Index_Table (Xnew : Source_File_Index) is |
| Ind : Int; |
| SP : Source_Ptr; |
| SL : constant Source_Ptr := Source_File.Table (Xnew).Source_Last; |
| begin |
| SP := Source_File.Table (Xnew).Source_First; |
| pragma Assert (SP mod Source_Align = 0); |
| Ind := Int (SP) / Source_Align; |
| while SP <= SL loop |
| Source_File_Index_Table (Ind) := Xnew; |
| SP := SP + Source_Align; |
| Ind := Ind + 1; |
| end loop; |
| end Set_Source_File_Index_Table; |
| |
| --------------------------- |
| -- Skip_Line_Terminators -- |
| --------------------------- |
| |
| procedure Skip_Line_Terminators |
| (P : in out Source_Ptr; |
| Physical : out Boolean) |
| is |
| Chr : constant Character := Source (P); |
| |
| begin |
| if Chr = CR then |
| if Source (P + 1) = LF then |
| P := P + 2; |
| else |
| P := P + 1; |
| end if; |
| |
| elsif Chr = LF then |
| P := P + 1; |
| |
| elsif Chr = FF or else Chr = VT then |
| P := P + 1; |
| Physical := False; |
| return; |
| |
| -- Otherwise we have a wide character |
| |
| else |
| Skip_Wide (Source, P); |
| end if; |
| |
| -- Fall through in the physical line terminator case. First deal with |
| -- making a possible entry into the lines table if one is needed. |
| |
| -- Note: we are dealing with a real source file here, this cannot be |
| -- the instantiation case, so we need not worry about Sloc adjustment. |
| |
| declare |
| S : Source_File_Record |
| renames Source_File.Table (Current_Source_File); |
| |
| begin |
| Physical := True; |
| |
| -- Make entry in lines table if not already made (in some scan backup |
| -- cases, we will be rescanning previously scanned source, so the |
| -- entry may have already been made on the previous forward scan). |
| |
| if Source (P) /= EOF |
| and then P > S.Lines_Table (S.Last_Source_Line) |
| then |
| Add_Line_Tables_Entry (S, P); |
| end if; |
| end; |
| end Skip_Line_Terminators; |
| |
| -------------- |
| -- Set_Dope -- |
| -------------- |
| |
| procedure Set_Dope |
| (Src : System.Address; New_Dope : Dope_Ptr) |
| is |
| -- A fat pointer is a pair consisting of data pointer and dope pointer, |
| -- in that order. So we want to overwrite the second word. |
| Dope : System.Address; |
| pragma Import (Ada, Dope); |
| use System.Storage_Elements; |
| for Dope'Address use Src + System.Address'Size / 8; |
| begin |
| Dope := New_Dope.all'Address; |
| end Set_Dope; |
| |
| procedure Free_Dope (Src : System.Address) is |
| Dope : Dope_Ptr; |
| pragma Import (Ada, Dope); |
| use System.Storage_Elements; |
| for Dope'Address use Src + System.Address'Size / 8; |
| procedure Free is new Unchecked_Deallocation (Dope_Rec, Dope_Ptr); |
| begin |
| Free (Dope); |
| end Free_Dope; |
| |
| ---------------- |
| -- Sloc_Range -- |
| ---------------- |
| |
| procedure Sloc_Range (N : Node_Id; Min, Max : out Source_Ptr) is |
| |
| Indx : constant Source_File_Index := Get_Source_File_Index (Sloc (N)); |
| |
| function Process (N : Node_Id) return Traverse_Result; |
| -- Process function for traversing the node tree |
| |
| procedure Traverse is new Traverse_Proc (Process); |
| |
| ------------- |
| -- Process -- |
| ------------- |
| |
| function Process (N : Node_Id) return Traverse_Result is |
| Loc : constant Source_Ptr := Sloc (Original_Node (N)); |
| |
| begin |
| -- Skip nodes that may have been added during expansion and |
| -- that originate in other units, such as code for contracts |
| -- in subprogram bodies. |
| |
| if Get_Source_File_Index (Loc) /= Indx then |
| return Skip; |
| end if; |
| |
| if Loc > No_Location then |
| if Loc < Min then |
| Min := Loc; |
| elsif Loc > Max then |
| Max := Loc; |
| end if; |
| end if; |
| |
| return OK_Orig; |
| end Process; |
| |
| -- Start of processing for Sloc_Range |
| |
| begin |
| Min := Sloc (N); |
| Max := Min; |
| Traverse (N); |
| end Sloc_Range; |
| |
| ------------------- |
| -- Source_Offset -- |
| ------------------- |
| |
| function Source_Offset (S : Source_Ptr) return Nat is |
| Sindex : constant Source_File_Index := Get_Source_File_Index (S); |
| Sfirst : constant Source_Ptr := |
| Source_File.Table (Sindex).Source_First; |
| begin |
| return Nat (S - Sfirst); |
| end Source_Offset; |
| |
| ------------------------ |
| -- Top_Level_Location -- |
| ------------------------ |
| |
| function Top_Level_Location (S : Source_Ptr) return Source_Ptr is |
| Oldloc : Source_Ptr; |
| Newloc : Source_Ptr; |
| |
| begin |
| Newloc := S; |
| loop |
| Oldloc := Newloc; |
| Newloc := Instantiation_Location (Oldloc); |
| exit when Newloc = No_Location; |
| end loop; |
| |
| return Oldloc; |
| end Top_Level_Location; |
| |
| -------------------- |
| -- Write_Location -- |
| -------------------- |
| |
| procedure Write_Location (P : Source_Ptr) is |
| begin |
| if P = No_Location then |
| Write_Str ("<no location>"); |
| |
| elsif P <= Standard_Location then |
| Write_Str ("<standard location>"); |
| |
| else |
| declare |
| SI : constant Source_File_Index := Get_Source_File_Index (P); |
| |
| begin |
| Write_Name (Debug_Source_Name (SI)); |
| Write_Char (':'); |
| Write_Int (Int (Get_Logical_Line_Number (P))); |
| Write_Char (':'); |
| Write_Int (Int (Get_Column_Number (P))); |
| |
| if Instantiation (SI) /= No_Location then |
| Write_Str (" ["); |
| Write_Location (Instantiation (SI)); |
| Write_Char (']'); |
| end if; |
| end; |
| end if; |
| end Write_Location; |
| |
| ---------------------- |
| -- Write_Time_Stamp -- |
| ---------------------- |
| |
| procedure Write_Time_Stamp (S : Source_File_Index) is |
| T : constant Time_Stamp_Type := Time_Stamp (S); |
| P : Natural; |
| |
| begin |
| if T (1) = '9' then |
| Write_Str ("19"); |
| P := 0; |
| else |
| Write_Char (T (1)); |
| Write_Char (T (2)); |
| P := 2; |
| end if; |
| |
| Write_Char (T (P + 1)); |
| Write_Char (T (P + 2)); |
| Write_Char ('-'); |
| |
| Write_Char (T (P + 3)); |
| Write_Char (T (P + 4)); |
| Write_Char ('-'); |
| |
| Write_Char (T (P + 5)); |
| Write_Char (T (P + 6)); |
| Write_Char (' '); |
| |
| Write_Char (T (P + 7)); |
| Write_Char (T (P + 8)); |
| Write_Char (':'); |
| |
| Write_Char (T (P + 9)); |
| Write_Char (T (P + 10)); |
| Write_Char (':'); |
| |
| Write_Char (T (P + 11)); |
| Write_Char (T (P + 12)); |
| end Write_Time_Stamp; |
| |
| ---------------------------------------------- |
| -- Access Subprograms for Source File Table -- |
| ---------------------------------------------- |
| |
| function Debug_Source_Name (S : SFI) return File_Name_Type is |
| begin |
| return Source_File.Table (S).Debug_Source_Name; |
| end Debug_Source_Name; |
| |
| function Instance (S : SFI) return Instance_Id is |
| begin |
| return Source_File.Table (S).Instance; |
| end Instance; |
| |
| function File_Name (S : SFI) return File_Name_Type is |
| begin |
| return Source_File.Table (S).File_Name; |
| end File_Name; |
| |
| function File_Type (S : SFI) return Type_Of_File is |
| begin |
| return Source_File.Table (S).File_Type; |
| end File_Type; |
| |
| function First_Mapped_Line (S : SFI) return Logical_Line_Number is |
| begin |
| return Source_File.Table (S).First_Mapped_Line; |
| end First_Mapped_Line; |
| |
| function Full_Debug_Name (S : SFI) return File_Name_Type is |
| begin |
| return Source_File.Table (S).Full_Debug_Name; |
| end Full_Debug_Name; |
| |
| function Full_File_Name (S : SFI) return File_Name_Type is |
| begin |
| return Source_File.Table (S).Full_File_Name; |
| end Full_File_Name; |
| |
| function Full_Ref_Name (S : SFI) return File_Name_Type is |
| begin |
| return Source_File.Table (S).Full_Ref_Name; |
| end Full_Ref_Name; |
| |
| function Identifier_Casing (S : SFI) return Casing_Type is |
| begin |
| return Source_File.Table (S).Identifier_Casing; |
| end Identifier_Casing; |
| |
| function Inherited_Pragma (S : SFI) return Boolean is |
| begin |
| return Source_File.Table (S).Inherited_Pragma; |
| end Inherited_Pragma; |
| |
| function Inlined_Body (S : SFI) return Boolean is |
| begin |
| return Source_File.Table (S).Inlined_Body; |
| end Inlined_Body; |
| |
| function Inlined_Call (S : SFI) return Source_Ptr is |
| begin |
| return Source_File.Table (S).Inlined_Call; |
| end Inlined_Call; |
| |
| function Keyword_Casing (S : SFI) return Casing_Type is |
| begin |
| return Source_File.Table (S).Keyword_Casing; |
| end Keyword_Casing; |
| |
| function Last_Source_Line (S : SFI) return Physical_Line_Number is |
| begin |
| return Source_File.Table (S).Last_Source_Line; |
| end Last_Source_Line; |
| |
| function License (S : SFI) return License_Type is |
| begin |
| return Source_File.Table (S).License; |
| end License; |
| |
| function Num_SRef_Pragmas (S : SFI) return Nat is |
| begin |
| return Source_File.Table (S).Num_SRef_Pragmas; |
| end Num_SRef_Pragmas; |
| |
| function Reference_Name (S : SFI) return File_Name_Type is |
| begin |
| return Source_File.Table (S).Reference_Name; |
| end Reference_Name; |
| |
| function Source_Checksum (S : SFI) return Word is |
| begin |
| return Source_File.Table (S).Source_Checksum; |
| end Source_Checksum; |
| |
| function Source_First (S : SFI) return Source_Ptr is |
| begin |
| return Source_File.Table (S).Source_First; |
| end Source_First; |
| |
| function Source_Last (S : SFI) return Source_Ptr is |
| begin |
| return Source_File.Table (S).Source_Last; |
| end Source_Last; |
| |
| function Source_Text (S : SFI) return Source_Buffer_Ptr is |
| begin |
| return Source_File.Table (S).Source_Text; |
| end Source_Text; |
| |
| function Template (S : SFI) return SFI is |
| begin |
| return Source_File.Table (S).Template; |
| end Template; |
| |
| function Time_Stamp (S : SFI) return Time_Stamp_Type is |
| begin |
| return Source_File.Table (S).Time_Stamp; |
| end Time_Stamp; |
| |
| function Unit (S : SFI) return Unit_Number_Type is |
| begin |
| return Source_File.Table (S).Unit; |
| end Unit; |
| |
| ------------------------------------------ |
| -- Set Procedures for Source File Table -- |
| ------------------------------------------ |
| |
| procedure Set_Identifier_Casing (S : SFI; C : Casing_Type) is |
| begin |
| Source_File.Table (S).Identifier_Casing := C; |
| end Set_Identifier_Casing; |
| |
| procedure Set_Keyword_Casing (S : SFI; C : Casing_Type) is |
| begin |
| Source_File.Table (S).Keyword_Casing := C; |
| end Set_Keyword_Casing; |
| |
| procedure Set_License (S : SFI; L : License_Type) is |
| begin |
| Source_File.Table (S).License := L; |
| end Set_License; |
| |
| procedure Set_Unit (S : SFI; U : Unit_Number_Type) is |
| begin |
| Source_File.Table (S).Unit := U; |
| end Set_Unit; |
| |
| ---------------------- |
| -- Trim_Lines_Table -- |
| ---------------------- |
| |
| procedure Trim_Lines_Table (S : Source_File_Index) is |
| Max : constant Nat := Nat (Source_File.Table (S).Last_Source_Line); |
| |
| begin |
| -- Release allocated storage that is no longer needed |
| |
| Source_File.Table (S).Lines_Table := To_Pointer |
| (Memory.Realloc |
| (To_Address (Source_File.Table (S).Lines_Table), |
| Memory.size_t |
| (Max * (Lines_Table_Type'Component_Size / System.Storage_Unit)))); |
| Source_File.Table (S).Lines_Table_Max := Physical_Line_Number (Max); |
| end Trim_Lines_Table; |
| |
| ------------ |
| -- Unlock -- |
| ------------ |
| |
| procedure Unlock is |
| begin |
| Source_File.Locked := False; |
| Source_File.Release; |
| end Unlock; |
| |
| -------- |
| -- wl -- |
| -------- |
| |
| procedure wl (P : Source_Ptr) is |
| begin |
| Write_Location (P); |
| Write_Eol; |
| end wl; |
| |
| end Sinput; |
