URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [sinput.adb] - Rev 729
Go to most recent revision | Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S I N P U T -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2012, 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. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- <http://www.gnu.org/licenses/>. -- -- -- -- 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 Tree_IO; use Tree_IO; with Widechar; use Widechar; with GNAT.Byte_Order_Mark; use GNAT.Byte_Order_Mark; with System; use System; with System.Memory; with System.WCh_Con; use System.WCh_Con; with Unchecked_Conversion; with Unchecked_Deallocation; package body Sinput is use ASCII; -- Make control characters visible First_Time_Around : Boolean := True; -- This needs a comment ??? -- 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); --------------------------- -- 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 (Loc : Source_Ptr) is Ptr : Source_Ptr; begin -- Loop through instantiations Ptr := Loc; loop Get_Name_String_And_Append (Reference_Name (Get_Source_File_Index (Ptr))); Add_Char_To_Name_Buffer (':'); Add_Nat_To_Name_Buffer (Nat (Get_Logical_Line_Number (Ptr))); Ptr := Instantiation_Location (Ptr); exit when Ptr = No_Location; Add_Str_To_Name_Buffer (" instantiated at "); end loop; Name_Buffer (Name_Len + 1) := NUL; return; end Build_Location_String; function Build_Location_String (Loc : Source_Ptr) return String is begin Name_Len := 0; Build_Location_String (Loc); return Name_Buffer (1 .. Name_Len); end Build_Location_String; ------------------- -- Check_For_BOM -- ------------------- procedure Check_For_BOM is BOM : BOM_Kind; Len : Natural; Tst : String (1 .. 5); begin for J in 1 .. 5 loop Tst (J) := Source (Scan_Ptr + Source_Ptr (J) - 1); end loop; Read_BOM (Tst, Len, BOM, False); case BOM is when UTF8_All => Scan_Ptr := Scan_Ptr + Source_Ptr (Len); Wide_Character_Encoding_Method := WCEM_UTF8; Upper_Half_Encoding := True; when UTF16_LE | UTF16_BE => Set_Standard_Error; Write_Line ("UTF-16 encoding format not recognized"); Set_Standard_Output; raise Unrecoverable_Error; when UTF32_LE | UTF32_BE => 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; ----------------------- -- 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); else C := C + 1; end if; S := S + 1; 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 -- --------------------------- Source_Cache_First : Source_Ptr := 1; Source_Cache_Last : Source_Ptr := 0; -- Records the First and Last subscript values for the most recently -- referenced entry in the source table, to optimize the common case of -- repeated references to the same entry. The initial values force an -- initial search to set the cache value. Source_Cache_Index : Source_File_Index := No_Source_File; -- Contains the index of the entry corresponding to Source_Cache function Get_Source_File_Index (S : Source_Ptr) return Source_File_Index is begin if S in Source_Cache_First .. Source_Cache_Last then return Source_Cache_Index; else pragma Assert (Source_File_Index_Table (Int (S) / Chunk_Size) /= No_Source_File); for J in Source_File_Index_Table (Int (S) / Chunk_Size) .. Source_File.Last loop if S in Source_File.Table (J).Source_First .. Source_File.Table (J).Source_Last then Source_Cache_Index := J; Source_Cache_First := Source_File.Table (Source_Cache_Index).Source_First; Source_Cache_Last := Source_File.Table (Source_Cache_Index).Source_Last; return Source_Cache_Index; end if; end loop; end if; -- We must find a matching entry in the above loop! raise Program_Error; end Get_Source_File_Index; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Source_Cache_First := 1; Source_Cache_Last := 0; Source_Cache_Index := No_Source_File; Source_gnat_adc := No_Source_File; First_Time_Around := True; Source_File.Init; end Initialize; ------------------------- -- 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; ---------------------- -- 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.Locked := True; Source_File.Release; 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 + Chunk_Size - 1) / Chunk_Size * Chunk_Size; Ind := Int (SP) / Chunk_Size; while SP <= SL loop Source_File_Index_Table (Ind) := Xnew; SP := SP + Chunk_Size; 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; ---------------- -- Sloc_Range -- ---------------- procedure Sloc_Range (N : Node_Id; Min, Max : out Source_Ptr) is 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 begin if Sloc (N) < Min then if Sloc (N) > No_Location then Min := Sloc (N); end if; elsif Sloc (N) > Max then if Sloc (N) > No_Location then Max := Sloc (N); end if; end if; return OK; end Process; -- Start of processing for Sloc_Range begin Min := Sloc (N); Max := Sloc (N); 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; --------------- -- Tree_Read -- --------------- procedure Tree_Read is begin -- First we must free any old source buffer pointers if not First_Time_Around then for J in Source_File.First .. Source_File.Last loop declare S : Source_File_Record renames Source_File.Table (J); procedure Free_Ptr is new Unchecked_Deallocation (Big_Source_Buffer, Source_Buffer_Ptr); pragma Warnings (Off); -- This unchecked conversion is aliasing safe, since it is not -- used to create improperly aliased pointer values. function To_Source_Buffer_Ptr is new Unchecked_Conversion (Address, Source_Buffer_Ptr); pragma Warnings (On); Tmp1 : Source_Buffer_Ptr; begin if S.Instantiation /= No_Location then null; else -- Free the buffer, we use Free here, because we used malloc -- or realloc directly to allocate the tables. That is -- because we were playing the big array trick. -- We have to recreate a proper pointer to the actual array -- from the zero origin pointer stored in the source table. Tmp1 := To_Source_Buffer_Ptr (S.Source_Text (S.Source_First)'Address); Free_Ptr (Tmp1); if S.Lines_Table /= null then Memory.Free (To_Address (S.Lines_Table)); S.Lines_Table := null; end if; if S.Logical_Lines_Table /= null then Memory.Free (To_Address (S.Logical_Lines_Table)); S.Logical_Lines_Table := null; end if; end if; end; end loop; end if; -- Reset source cache pointers to force new read Source_Cache_First := 1; Source_Cache_Last := 0; -- Read in source file table Source_File.Tree_Read; -- The pointers we read in there for the source buffer and lines -- table pointers are junk. We now read in the actual data that -- is referenced by these two fields. for J in Source_File.First .. Source_File.Last loop declare S : Source_File_Record renames Source_File.Table (J); begin -- For the instantiation case, we do not read in any data. Instead -- we share the data for the generic template entry. Since the -- template always occurs first, we can safely refer to its data. if S.Instantiation /= No_Location then declare ST : Source_File_Record renames Source_File.Table (S.Template); begin -- The lines tables are copied from the template entry S.Lines_Table := Source_File.Table (S.Template).Lines_Table; S.Logical_Lines_Table := Source_File.Table (S.Template).Logical_Lines_Table; -- In the case of the source table pointer, we share the -- same data as the generic template, but the virtual origin -- is adjusted. For example, if the first subscript of the -- template is 100, and that of the instantiation is 200, -- then the instantiation pointer is obtained by subtracting -- 100 from the template pointer. declare pragma Suppress (All_Checks); pragma Warnings (Off); -- This unchecked conversion is aliasing safe since it -- not used to create improperly aliased pointer values. function To_Source_Buffer_Ptr is new Unchecked_Conversion (Address, Source_Buffer_Ptr); pragma Warnings (On); begin S.Source_Text := To_Source_Buffer_Ptr (ST.Source_Text (ST.Source_First - S.Source_First)'Address); end; end; -- Normal case (non-instantiation) else First_Time_Around := False; S.Lines_Table := null; S.Logical_Lines_Table := null; Alloc_Line_Tables (S, Int (S.Last_Source_Line)); for J in 1 .. S.Last_Source_Line loop Tree_Read_Int (Int (S.Lines_Table (J))); end loop; if S.Num_SRef_Pragmas /= 0 then for J in 1 .. S.Last_Source_Line loop Tree_Read_Int (Int (S.Logical_Lines_Table (J))); end loop; end if; -- Allocate source buffer and read in the data and then set the -- virtual origin to point to the logical zero'th element. This -- address must be computed with subscript checks turned off. declare subtype B is Text_Buffer (S.Source_First .. S.Source_Last); type Text_Buffer_Ptr is access B; T : Text_Buffer_Ptr; pragma Suppress (All_Checks); pragma Warnings (Off); -- This unchecked conversion is aliasing safe, since it is -- never used to create improperly aliased pointer values. function To_Source_Buffer_Ptr is new Unchecked_Conversion (Address, Source_Buffer_Ptr); pragma Warnings (On); begin T := new B; Tree_Read_Data (T (S.Source_First)'Address, Int (S.Source_Last) - Int (S.Source_First) + 1); S.Source_Text := To_Source_Buffer_Ptr (T (0)'Address); end; end if; end; Set_Source_File_Index_Table (J); end loop; end Tree_Read; ---------------- -- Tree_Write -- ---------------- procedure Tree_Write is begin Source_File.Tree_Write; -- The pointers we wrote out there for the source buffer and lines -- table pointers are junk, we now write out the actual data that -- is referenced by these two fields. for J in Source_File.First .. Source_File.Last loop declare S : Source_File_Record renames Source_File.Table (J); begin -- For instantiations, there is nothing to do, since the data is -- shared with the generic template. When the tree is read, the -- pointers must be set, but no extra data needs to be written. if S.Instantiation /= No_Location then null; -- For the normal case, write out the data of the tables else -- Lines table for J in 1 .. S.Last_Source_Line loop Tree_Write_Int (Int (S.Lines_Table (J))); end loop; -- Logical lines table if present if S.Num_SRef_Pragmas /= 0 then for J in 1 .. S.Last_Source_Line loop Tree_Write_Int (Int (S.Logical_Lines_Table (J))); end loop; end if; -- Source buffer Tree_Write_Data (S.Source_Text (S.Source_First)'Address, Int (S.Source_Last) - Int (S.Source_First) + 1); end if; end; end loop; end Tree_Write; -------------------- -- 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 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 Inlined_Body (S : SFI) return Boolean is begin return Source_File.Table (S).Inlined_Body; end Inlined_Body; function Instantiation (S : SFI) return Source_Ptr is begin return Source_File.Table (S).Instantiation; end Instantiation; 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 if S = Internal_Source_File then return Internal_Source'First; else return Source_File.Table (S).Source_First; end if; end Source_First; function Source_Last (S : SFI) return Source_Ptr is begin if S = Internal_Source_File then return Internal_Source'Last; else return Source_File.Table (S).Source_Last; end if; end Source_Last; function Source_Text (S : SFI) return Source_Buffer_Ptr is begin if S = Internal_Source_File then return Internal_Source_Ptr; else return Source_File.Table (S).Source_Text; end if; 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;
Go to most recent revision | Compare with Previous | Blame | View Log