------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 1992-2021, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Containers.Hashed_Maps; with Ada.Unchecked_Deallocation; with Ada.Unchecked_Conversion; with GNAT.Byte_Order_Mark; use GNAT.Byte_Order_Mark; with System; use System; pragma Warnings (Off); with System.WCh_Con; use System.WCh_Con; with System.WCh_Cnv; use System.WCh_Cnv; with System.Memory; pragma Warnings (On); with GPR.Err; with GPR.Erroutc; use GPR.Erroutc; with GPR.Names; use GPR.Names; with GPR.Opt; use GPR.Opt; with GPR.Output; use GPR.Output; package body GPR.Sinput is Lines_Initial : constant := 500; First : Boolean := True; -- Flag used when Load_File is called the first time, to set -- Main_Source_File. -- The flag is reset to False at the first call to Load_Project_File. -- Calling Reset_First sets it back to True. function Hash (Name : File_Name_Type) return Ada.Containers.Hash_Type is (Ada.Containers.Hash_Type (Name)); package Source_Id_Maps is new Ada.Containers.Hashed_Maps (Key_Type => File_Name_Type, Element_Type => Source_File_Index, Hash => Hash, Equivalent_Keys => "="); Sources_Map : Source_Id_Maps.Map; procedure Free is new Ada.Unchecked_Deallocation (Lines_Table_Type, Lines_Table_Ptr); procedure Free (S : in out GPR.Sinput.Source_File_Record); -- Free allocated memory --------------------------- -- Add_Line_Tables_Entry -- --------------------------- procedure Add_Line_Tables_Entry (S : in out Source_File_Record; P : Source_Ptr) is LL : Line_Number; begin -- Reallocate the lines tables if necessary if S.Last_Source_Line = S.Lines_Table'Last then declare New_Table : constant Lines_Table_Ptr := new Lines_Table_Type (1 .. S.Last_Source_Line * 2); begin New_Table (1 .. S.Last_Source_Line) := S.Lines_Table (1 .. S.Last_Source_Line); Free (S.Lines_Table); S.Lines_Table := New_Table; end; end if; S.Last_Source_Line := S.Last_Source_Line + 1; LL := S.Last_Source_Line; S.Lines_Table (LL) := P; end Add_Line_Tables_Entry; ------------------- -- 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, 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"); raise Unrecoverable_Error; when UTF32_LE | UTF32_BE => Set_Standard_Error; Write_Line ("UTF-32 encoding format not recognized"); raise Unrecoverable_Error; when Unknown => null; when others => raise Program_Error; end case; end Check_For_BOM; ----------------------------- -- Clear_Source_File_Table -- ----------------------------- procedure Clear_Source_File_Table is begin for X in 1 .. Source_File.Last loop Free (Source_File.Table (X)); end loop; Sources_Map.Clear; Source_File.Free; Sinput.Initialize; end Clear_Source_File_Table; ---------- -- Free -- ---------- procedure Free (S : in out GPR.Sinput.Source_File_Record) is Lo : constant Source_Ptr := S.Source_First; Hi : constant Source_Ptr := S.Source_Last; subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi); -- Physical buffer allocated type Actual_Source_Ptr is access Actual_Source_Buffer; -- This is the pointer type for the physical buffer allocated procedure Free is new Ada.Unchecked_Deallocation (Actual_Source_Buffer, Actual_Source_Ptr); pragma Suppress (All_Checks); pragma Warnings (Off); -- The following unchecked conversion is aliased safe, since it -- is not used to create improperly aliased pointer values. function To_Actual_Source_Ptr is new Ada.Unchecked_Conversion (Address, Actual_Source_Ptr); pragma Warnings (On); Actual_Ptr : Actual_Source_Ptr := To_Actual_Source_Ptr (S.Source_Text (Lo)'Address); begin Free (Actual_Ptr); Free (S.Lines_Table); end Free; -------------------- -- Full_File_Name -- -------------------- function Full_File_Name (S : Source_File_Index) return File_Name_Type is begin return Source_File.Table (S).Full_File_Name; end Full_File_Name; ------------------- -- Full_Ref_Name -- ------------------- function Full_Ref_Name (S : Source_File_Index) return File_Name_Type is begin return Source_File.Table (S).Full_Ref_Name; end Full_Ref_Name; ----------------------- -- 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) = ASCII.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_Line_Number -- --------------------- function Get_Line_Number (P : Source_Ptr) return Line_Number is Sfile : Source_File_Index; Table : Lines_Table_Ptr; Lo : Line_Number; Hi : Line_Number; Mid : 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; 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_Line_Number; --------------------------- -- Get_Source_File_Index -- --------------------------- function Get_Source_File_Index (S : Source_Ptr) return Source_File_Index is begin return Source_File_Index_Table (Int (S) / Source_Align); end Get_Source_File_Index; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Source_File.Init; end Initialize; ---------------------- -- 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 if Src = null then return No_Location; end if; S := P; while S > Sfirst and then Src (S - 1) /= ASCII.CR and then Src (S - 1) /= ASCII.LF loop S := S - 1; end loop; return S; end Line_Start; function Line_Start (L : Line_Number; S : Source_File_Index) return Source_Ptr is begin return Source_File.Table (S).Lines_Table (L); end Line_Start; --------------- -- Load_File -- --------------- function Load_File (Path : String) return Source_File_Index is Src : Source_Buffer_Ptr; X : Source_File_Index; Lo : Source_Ptr; Hi : Source_Ptr; Source_File_FD : File_Descriptor; -- The file descriptor for the current source file. A negative value -- indicates failure to open the specified source file. Len : Integer; -- Length of file (assume no more than 2 gigabytes of source) Actual_Len : Integer; Position : Source_Id_Maps.Cursor; Inserted : Boolean; Path_Id : File_Name_Type; File_Id : File_Name_Type; begin if Path = "" then return No_Source_File; end if; Path_Id := Get_File_Name_Id (Path); Sources_Map.Insert (Path_Id, Source_File.Last + 1, Position, Inserted); if not Inserted then return Result : constant Source_File_Index := Source_Id_Maps.Element (Position) do pragma Assert (Source_File.Table (Result).Full_Debug_Name = Path_Id, "insertion failed for " & Get_Name_String (Source_File.Table (Result).Full_Debug_Name) & ' ' & Get_Name_String (Path_Id)); pragma Assert (Source_File.Table (Result).Full_File_Name = Path_Id, "insertion failed for " & Source_File.Table (Result).Full_File_Name'Img & Path_Id'Img); pragma Assert (Source_File.Table (Result).Full_Ref_Name = Path_Id, "insertion failed for " & Source_File.Table (Result).Full_Ref_Name'Img & Path_Id'Img); end return; end if; Source_File.Increment_Last; X := Source_File.Last; if X = Source_File.First then Lo := First_Source_Ptr; else Lo := ((Source_File.Table (X - 1).Source_Last + Source_Align) / Source_Align) * Source_Align; end if; Name_Buffer (Name_Len + 1) := ASCII.NUL; -- Open the source FD, note that we open in binary mode, because as -- documented in the spec, the caller is expected to handle either -- DOS or Unix mode files, and there is no point in wasting time on -- text translation when it is not required. Source_File_FD := Open_Read (Name_Buffer'Address, Binary); if Source_File_FD = Invalid_FD then Source_File.Decrement_Last; Sources_Map.Delete (Position); return No_Source_File; end if; Len := Integer (File_Length (Source_File_FD)); -- Set Hi so that length is one more than the physical length, allowing -- for the extra EOF character at the end of the buffer Hi := Lo + Source_Ptr (Len); -- Do the actual read operation declare subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi); -- Physical buffer allocated type Actual_Source_Ptr is access Actual_Source_Buffer; -- This is the pointer type for the physical buffer allocated Actual_Ptr : constant Actual_Source_Ptr := new Actual_Source_Buffer; -- And this is the actual physical buffer begin -- Allocate source buffer, allowing extra character at end for EOF -- Some systems have file types that require one read per line, -- so read until we get the Len bytes or until there are no more -- characters. Hi := Lo; loop Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len); Hi := Hi + Source_Ptr (Actual_Len); exit when Actual_Len = Len or else Actual_Len <= 0; end loop; Actual_Ptr (Hi) := EOF; -- Now we need to work out the proper virtual origin pointer to -- return. This is exactly Actual_Ptr (0)'Address, but we have to -- be careful to suppress checks to compute this address. declare pragma Suppress (All_Checks); pragma Warnings (Off); -- The following unchecked conversion is aliased safe, since it -- is not used to create improperly aliased pointer values. function To_Source_Buffer_Ptr is new Ada.Unchecked_Conversion (Address, Source_Buffer_Ptr); pragma Warnings (On); begin Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address); end; end; -- Read is complete, close the file and we are done (no need to test -- status from close, since we have successfully read the file). Close (Source_File_FD); -- Get the file name, without path information declare Index : Positive := Path'Last; begin while Index > Path'First loop exit when Is_Directory_Separator (Path (Index - 1)); Index := Index - 1; end loop; Name_Len := Path'Last - Index + 1; Name_Buffer (1 .. Name_Len) := Path (Index .. Path'Last); File_Id := Name_Find; end; declare S : Source_File_Record renames Source_File.Table (X); begin S := (File_Name => File_Id, Reference_Name => File_Id, Debug_Source_Name => File_Id, Full_Debug_Name => Path_Id, Full_File_Name => Path_Id, Full_Ref_Name => Path_Id, Source_Text => Src, Source_First => Lo, Source_Last => Hi, Last_Source_Line => 1, Lines_Table => new Lines_Table_Type (1 .. Lines_Initial)); S.Lines_Table (1) := Lo; end; Set_Source_File_Index_Table (X); if First then Main_Source_File := X; First := False; end if; return X; end Load_File; ---------------------- -- 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; -------------------- -- Reference_Name -- -------------------- function Reference_Name (S : Source_File_Index) return File_Name_Type is begin return Source_File.Table (S).Reference_Name; end Reference_Name; ----------------- -- Reset_First -- ----------------- procedure Reset_First is begin First := True; end Reset_First; -------------------------------- -- Restore_Project_Scan_State -- -------------------------------- procedure Restore_Project_Scan_State (Saved_State : Saved_Project_Scan_State) is begin Restore_Scan_State (Saved_State.Scan_State); Source := Saved_State.Source; Current_Source_File := Saved_State.Current_Source_File; end Restore_Project_Scan_State; ----------------------------- -- Save_Project_Scan_State -- ----------------------------- procedure Save_Project_Scan_State (Saved_State : out Saved_Project_Scan_State) is begin Save_Scan_State (Saved_State.Scan_State); Saved_State.Source := Source; Saved_State.Current_Source_File := Current_Source_File; end Save_Project_Scan_State; --------------------------------- -- 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_Wide -- --------------- procedure Skip_Wide (S : Source_Buffer_Ptr; P : in out Source_Ptr) is function Skip_Char return Character; -- Function to skip one character of wide character escape sequence --------------- -- Skip_Char -- --------------- function Skip_Char return Character is begin P := P + 1; return S (P - 1); end Skip_Char; function WC_Skip is new Char_Sequence_To_UTF_32 (Skip_Char); Discard : UTF_32_Code; pragma Warnings (Off, Discard); -- Start of processing for Skip_Wide begin Discard := WC_Skip (Skip_Char, Wide_Character_Encoding_Method); end Skip_Wide; ---------------------------- -- Source_File_Is_Subunit -- ---------------------------- function Source_File_Is_Subunit (X : Source_File_Index) return Boolean is begin -- Nothing to do if X is no source file, so simply return False if X = No_Source_File then return False; end if; Err.Scanner.Initialize_Scanner (X, Err.Scanner.Ada); -- No error for special characters that are used for preprocessing Err.Scanner.Set_Special_Character ('#'); Err.Scanner.Set_Special_Character ('$'); Check_For_BOM; -- We scan past junk to the first interesting compilation unit token, to -- see if it is SEPARATE. We ignore WITH keywords during this and also -- PRIVATE. The reason for ignoring PRIVATE is that it handles some -- error situations, and also to handle PRIVATE WITH in Ada 2005 mode. while Token = Tok_With or else Token = Tok_Private or else (Token not in Token_Class_Cunit and then Token /= Tok_EOF) loop Err.Scanner.Scan; end loop; Err.Scanner.Reset_Special_Characters; return Token = Tok_Separate; end Source_File_Is_Subunit; ---------------------- -- Source_File_Trim -- ---------------------- procedure Source_File_Trim (Last : Source_File_Index) is begin for Index in Last + 1 .. GPR.Sinput.Source_File.Last loop Sources_Map.Delete (GPR.Sinput.Source_File.Table (Index).Full_File_Name); Free (GPR.Sinput.Source_File.Table (Index)); end loop; GPR.Sinput.Source_File.Set_Last (Last); end Source_File_Trim; ------------------ -- Source_First -- ------------------ function Source_First (S : Source_File_Index) return Source_Ptr is begin return Source_File.Table (S).Source_First; end Source_First; ----------------- -- Source_Last -- ----------------- function Source_Last (S : Source_File_Index) return Source_Ptr is begin return Source_File.Table (S).Source_Last; end Source_Last; ----------------- -- Source_Text -- ----------------- function Source_Text (S : Source_File_Index) return Source_Buffer_Ptr is begin return Source_File.Table (S).Source_Text; end Source_Text; end GPR.Sinput;