-- Loading of source files. -- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold -- -- GHDL is free software; you can redistribute it and/or modify it under -- the terms of the GNU General Public License as published by the Free -- Software Foundation; either version 2, or (at your option) any later -- version. -- -- GHDL is distributed in the hope that it will be useful, but WITHOUT 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 -- along with GHDL; see the file COPYING. If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. with System; with Interfaces.C; with Ada.Text_IO; use Ada.Text_IO; with Ada.Unchecked_Deallocation; with Tables; with GNAT.OS_Lib; with GNAT.SHA1; with GNAT.Directory_Operations; with Name_Table; use Name_Table; with Str_Table; with Ada.Calendar; with Ada.Calendar.Time_Zones; package body Files_Map is -- Check validity of FILE. -- Raise an exception in case of error. procedure Check_File (File: in Source_File_Entry); pragma Inline (Check_File); type Lines_Table_Type is array (Positive) of Source_Ptr; type Lines_Table_Ptr is access all Lines_Table_Type; -- There are several kinds of source file. type Source_File_Kind is ( -- A *real* source file, read from the filesystem. Source_File_File, -- A virtual source file, created from a string. Source_File_String, -- A duplicated source file (there is no copy however), created by -- an instantiation. Source_File_Instance); -- Data associed with a file. type Source_File_Record (Kind : Source_File_Kind := Source_File_File) is record -- All location between first and last belong to this file. First_Location : Location_Type; Last_Location : Location_Type; -- The name_id that identify this file. -- FIXME: what about file aliasing (links) ? File_Name : Name_Id; Directory : Name_Id; -- The buffer containing the file. Source : File_Buffer_Acc; -- Length of the file, which is also the length of the buffer. File_Length : Natural; Checksum : File_Checksum_Id; case Kind is when Source_File_File => -- Line table -- Current number of line in Lines_Table. Nbr_Lines : Natural; Lines_Table : Lines_Table_Ptr; -- Current size of Lines_Table. Lines_Table_Max : Natural; -- Cache for line table. Cache_Line : Natural; Cache_Pos : Source_Ptr; when Source_File_String => -- There is only one line. null; when Source_File_Instance => -- The instance was created from REF. Ref : Source_File_Entry; -- The ultimate non-instance is BASE. Base : Source_File_Entry; Instance_Loc : Location_Type; end case; end record; -- Next location to use. Next_Location : Location_Type := Location_Nil + 1; package Source_Files is new Tables (Table_Index_Type => Source_File_Entry, Table_Component_Type => Source_File_Record, Table_Low_Bound => No_Source_File_Entry + 1, Table_Initial => 16); function Get_Last_Source_File_Entry return Source_File_Entry is begin return Source_Files.Last; end Get_Last_Source_File_Entry; Home_Dir : Name_Id := Null_Identifier; function Get_Home_Directory return Name_Id is begin if Home_Dir = Null_Identifier then GNAT.Directory_Operations.Get_Current_Dir (Nam_Buffer, Nam_Length); Home_Dir := Get_Identifier; end if; return Home_Dir; end Get_Home_Directory; function Location_To_File (Location : Location_Type) return Source_File_Entry is begin -- FIXME: use a cache -- FIXME: dicotomy for I in Source_Files.First .. Source_Files.Last loop declare F : Source_File_Record renames Source_Files.Table (I); begin if Location >= F.First_Location and then Location <= F.Last_Location then return I; end if; end; end loop; return No_Source_File_Entry; end Location_To_File; procedure Location_To_File_Pos (Location : Location_Type; File : out Source_File_Entry; Pos : out Source_Ptr) is begin File := Location_To_File (Location); if File = No_Source_File_Entry then -- File not found, location must be correct. raise Internal_Error; end if; Pos := Location_File_To_Pos (Location, File); end Location_To_File_Pos; function File_Pos_To_Location (File : Source_File_Entry; Pos : Source_Ptr) return Location_Type is pragma Assert (File <= Source_Files.Last); begin return Source_Files.Table (File).First_Location + Location_Type (Pos); end File_Pos_To_Location; function Source_File_To_Location (File : Source_File_Entry) return Location_Type is pragma Assert (File <= Source_Files.Last); begin return Source_Files.Table (File).First_Location; end Source_File_To_Location; procedure Reallocate_Lines_Table (File: in out Source_File_Record; New_Size: Natural) is use Interfaces.C; function realloc (memblock : Lines_Table_Ptr; size : size_t) return Lines_Table_Ptr; pragma Import (C, realloc); function malloc (size : size_t) return Lines_Table_Ptr; pragma Import (C, malloc); New_Table: Lines_Table_Ptr; New_Byte_Size : size_t; begin New_Byte_Size := size_t(New_Size * Lines_Table_Type'Component_Size / System.Storage_Unit); if File.Lines_Table = null then New_Table := malloc (New_Byte_Size); else New_Table := realloc (File.Lines_Table, New_Byte_Size); end if; if New_Table = null then raise Storage_Error; else File.Lines_Table := New_Table; File.Lines_Table (File.Lines_Table_Max + 1 .. New_Size) := (others => Source_Ptr_Bad); File.Lines_Table_Max := New_Size; end if; end Reallocate_Lines_Table; -- Add a new entry in the lines_table. -- The new entry must be the next one after the last entry. procedure File_Add_Line_Number (File: Source_File_Entry; Line: Natural; Pos: Source_Ptr) is -- Just check File is not out of bounds. pragma Assert (File <= Source_Files.Last); Source_File: Source_File_Record renames Source_Files.Table (File); begin -- Can only add line number to a real file. pragma Assert (Source_File.Kind = Source_File_File); -- Debug trace. if False then Put_Line ("file" & Source_File_Entry'Image (File) & " line" & Natural'Image (Line) & " at position" & Source_Ptr'Image (Pos)); end if; -- The position of the first line is well-known. pragma Assert (Line = 1 xor Pos /= Source_Ptr_Org); if Line > Source_File.Lines_Table_Max then Reallocate_Lines_Table (Source_File, (Line / 128 + 1) * 128); end if; -- Lines are in increasing order. pragma Assert (Line = 1 or else Source_File.Lines_Table (Line - 1) = Source_Ptr_Bad or else Source_File.Lines_Table (Line - 1) < Pos); pragma Assert (Line = Source_File.Lines_Table_Max or else Source_File.Lines_Table (Line + 1) = Source_Ptr_Bad or else Source_File.Lines_Table (Line + 1) > Pos); if Source_File.Lines_Table (Line) = Source_Ptr_Bad then Source_File.Lines_Table (Line) := Pos; else -- If the line position is already known, it must be the same. if Pos /= Source_File.Lines_Table (Line) then Put_Line ("file" & Source_File_Entry'Image (File) & " for line" & Natural'Image (Line) & " pos =" & Source_Ptr'Image (Pos) & ", lines_table = " & Source_Ptr'Image (Source_File.Lines_Table (Line))); raise Internal_Error; end if; end if; if Line > Source_File.Nbr_Lines then Source_File.Nbr_Lines := Line; end if; end File_Add_Line_Number; -- Convert a physical column to a logical column. -- A physical column is the offset in byte from the first byte of the line. -- A logical column is the position of the character when displayed. -- A HT (tabulation) moves the cursor to the next position multiple of the -- tab stop. -- The first character is at position 1 and at offset 0. function Coord_To_Col (File : Source_File_Entry; Line_Pos : Source_Ptr; Offset : Natural) return Natural is Source_File: Source_File_Record renames Source_Files.Table (File); Res : Positive := 1; begin if Offset = 0 then return Res; else for I in Line_Pos .. Line_Pos + Source_Ptr (Offset) - 1 loop if Source_File.Source (I) = ASCII.HT then Res := Res + Tab_Stop - Res mod Tab_Stop; else Res := Res + 1; end if; end loop; return Res; end if; end Coord_To_Col; procedure Coord_To_Position (File : Source_File_Entry; Line_Pos : Source_Ptr; Offset : Natural; Name : out Name_Id; Col : out Natural) is begin Name := Source_Files.Table (File).File_Name; Col := Coord_To_Col (File, Line_Pos, Offset); end Coord_To_Position; -- Should only be called by Location_To_Coord. function Location_To_Line (Source_File : Source_File_Record; Pos : Source_Ptr) return Natural is Lines_Table : constant Lines_Table_Ptr := Source_File.Lines_Table; Low, Hi, Mid : Natural; Mid1 : Natural; begin -- Look in the cache. if Pos >= Source_File.Cache_Pos then Low := Source_File.Cache_Line; Hi := Source_File.Nbr_Lines; else Low := 1; Hi := Source_File.Cache_Line; end if; loop << Again >> null; Mid := (Hi + Low) / 2; if Lines_Table (Mid) = Source_Ptr_Bad then -- There is a hole: no position for this line. -- Set MID1 to a line which has a position. -- Try downward. Mid1 := Mid; while Lines_Table (Mid1) = Source_Ptr_Bad loop -- Note: Low may have no line. exit when Mid1 = Low; Mid1 := Mid1 - 1; end loop; if Mid1 /= Low then -- Mid1 has a line. if Pos < Lines_Table (Mid1) then Hi := Mid1; goto Again; end if; if Pos > Lines_Table (Mid1) then Low := Mid1; goto Again; end if; -- Found, handled just below. else -- Failed (downward is LOW): try upward. Mid1 := Mid; while Lines_Table (Mid1) = Source_Ptr_Bad loop Mid1 := Mid1 + 1; end loop; if Mid1 = Hi then -- Failed: no lines between LOW and HI. if Pos >= Lines_Table (Hi) then Mid1 := Hi; else Mid1 := Low; end if; return Mid1; end if; -- Mid1 has a line. if Pos < Lines_Table (Mid1) then Hi := Mid1; goto Again; end if; if Pos > Lines_Table (Mid1) then Low := Mid1; goto Again; end if; end if; Mid := Mid1; end if; -- Mid is on a known line. pragma Assert (Lines_Table (Mid) /= Source_Ptr_Bad); if Pos >= Lines_Table (Mid) then if Mid = Source_File.Nbr_Lines or else (Lines_Table (Mid + 1) /= Source_Ptr_Bad and then Pos < Lines_Table (Mid + 1)) or else Pos = Lines_Table (Mid) or else (Hi <= Mid + 1 and Lines_Table (Mid + 1) = Source_Ptr_Bad) then return Mid; end if; end if; if Pos < Lines_Table (Mid) then Hi := Mid - 1; else if Lines_Table (Mid + 1) /= Source_Ptr_Bad then Low := Mid + 1; else Low := Mid; end if; end if; end loop; end Location_To_Line; -- Internal procedure procedure Location_To_Coord (Source_File : in out Source_File_Record; Pos : Source_Ptr; Line_Pos : out Source_Ptr; Line : out Natural; Offset : out Natural) is Line_P : Source_Ptr; Line_Threshold : constant Natural := 4; Low, Hi : Natural; begin -- Look in the cache. if Pos >= Source_File.Cache_Pos then Low := Source_File.Cache_Line; Hi := Source_File.Nbr_Lines; -- Maybe adjust the threshold. -- Quick look. if Pos - Source_File.Cache_Pos <= 120 and then Low + Line_Threshold <= Hi then for I in 1 .. Line_Threshold loop Line_P := Source_File.Lines_Table (Low + I); if Line_P > Pos and Line_P /= Source_Ptr_Bad then Line := Low + I - 1; goto Found; else exit when Line_P = Source_Ptr_Bad; end if; end loop; end if; end if; Line := Location_To_Line (Source_File, Pos); << Found >> null; Line_Pos := Source_File.Lines_Table (Line); Offset := Natural (Pos - Line_Pos); -- Update cache. Source_File.Cache_Pos := Pos; Source_File.Cache_Line := Line; end Location_To_Coord; procedure Location_To_Position (Location : Location_Type; Name : out Name_Id; Line : out Natural; Col : out Natural) is File : Source_File_Entry; Line_Pos : Source_Ptr; Offset : Natural; begin Location_To_Coord (Location, File, Line_Pos, Line, Offset); Coord_To_Position (File, Line_Pos, Offset, Name, Col); end Location_To_Position; procedure Location_To_Coord (Location : Location_Type; File : out Source_File_Entry; Line_Pos : out Source_Ptr; Line : out Natural; Offset : out Natural) is Pos : Source_Ptr; begin -- Get FILE and position POS in the file. Location_To_File_Pos (Location, File, Pos); case Source_Files.Table (File).Kind is when Source_File_File => Location_To_Coord (Source_Files.Table (File), Pos, Line_Pos, Line, Offset); when Source_File_String => Line_Pos := Source_Ptr_Org; Line := 1; Offset := Natural (Pos - Source_Ptr_Org); when Source_File_Instance => declare Base : constant Source_File_Entry := Source_Files.Table (File).Base; begin Location_To_Coord (Source_Files.Table (Base), Pos, Line_Pos, Line, Offset); end; end case; end Location_To_Coord; function Location_File_To_Pos (Location : Location_Type; File : Source_File_Entry) return Source_Ptr is begin return Source_Ptr (Location - Source_Files.Table (File).First_Location); end Location_File_To_Pos; function Location_File_To_Line (Location : Location_Type; File : Source_File_Entry) return Natural is Line_Pos : Source_Ptr; Line : Natural; Offset : Natural; begin Location_To_Coord (Source_Files.Table (File), Location_File_To_Pos (Location, File), Line_Pos, Line, Offset); return Line; end Location_File_To_Line; function Location_File_Line_To_Col (Loc : Location_Type; File : Source_File_Entry; Line : Natural) return Natural is F : Source_File_Record renames Source_Files.Table (File); Line_Pos : constant Source_Ptr := F.Lines_Table (Line); Pos : constant Source_Ptr := Location_File_To_Pos (Loc, File); begin return Coord_To_Col (File, Line_Pos, Natural (Pos - Line_Pos)); end Location_File_Line_To_Col; -- Convert the first digit of VAL into a character (base 10). function Digit_To_Char (Val: Natural) return Character is begin return Character'Val (Character'Pos ('0') + Val mod 10); end Digit_To_Char; function Get_Os_Time_Stamp return Time_Stamp_Id is use Ada.Calendar; use Ada.Calendar.Time_Zones; use Str_Table; Now : constant Time := Clock; Now_UTC : constant Time := Now - Duration (UTC_Time_Offset (Now) * 60); Year : Year_Number; Month : Month_Number; Day : Day_Number; Sec : Day_Duration; S : Integer; S1 : Integer; M : Integer; Res: Time_Stamp_Id; begin -- Use UTC time (like file time stamp). Split (Now_UTC, Year, Month, Day, Sec); Res := Time_Stamp_Id (Create_String8); Append_String8_Char (Digit_To_Char (Year / 1000)); Append_String8_Char (Digit_To_Char (Year / 100)); Append_String8_Char (Digit_To_Char (Year / 10)); Append_String8_Char (Digit_To_Char (Year / 1)); Append_String8_Char (Digit_To_Char (Month / 10)); Append_String8_Char (Digit_To_Char (Month / 1)); Append_String8_Char (Digit_To_Char (Day / 10)); Append_String8_Char (Digit_To_Char (Day / 1)); S := Integer (Sec); if Day_Duration (S) > Sec then -- We need a truncation. S := S - 1; end if; S1 := S / 3600; Append_String8_Char (Digit_To_Char (S1 / 10)); Append_String8_Char (Digit_To_Char (S1)); S1 := (S / 60) mod 60; Append_String8_Char (Digit_To_Char (S1 / 10)); Append_String8_Char (Digit_To_Char (S1)); S1 := S mod 60; Append_String8_Char (Digit_To_Char (S1 / 10)); Append_String8_Char (Digit_To_Char (S1)); Append_String8_Char ('.'); Sec := Sec - Day_Duration (S); M := Integer (Sec * 1000); if M = 1000 then -- We need truncation. M := 999; end if; Append_String8_Char (Digit_To_Char (M / 100)); Append_String8_Char (Digit_To_Char (M / 10)); Append_String8_Char (Digit_To_Char (M)); return Res; end Get_Os_Time_Stamp; function Get_Pathname (Directory : Name_Id; Name : Name_Id; Add_Nul : Boolean) return String is L : Natural; begin Image (Name); if not GNAT.OS_Lib.Is_Absolute_Path (Nam_Buffer (1 .. Nam_Length)) then L := Nam_Length; Image (Directory); Nam_Buffer (Nam_Length + 1 .. Nam_Length + L) := Image (Name); Nam_Length := Nam_Length + L; end if; if Add_Nul then Nam_Length := Nam_Length + 1; Nam_Buffer (Nam_Length) := Character'Val (0); end if; return Nam_Buffer (1 .. Nam_Length); end Get_Pathname; procedure Normalize_Pathname (Directory : in out Name_Id; Name : in out Name_Id) is Separator_Pos : Natural; Filename : constant String := Image (Name); begin -- Find a directory part in NAME, return now if none. Separator_Pos := 0; for I in Filename'Range loop if Filename (I) = '/' or Filename (I) = '\' then Separator_Pos := I; end if; end loop; if Separator_Pos = 0 then return; end if; -- Move the directory part to DIRECTORY. if Directory /= Null_Identifier then Image (Directory); else Nam_Length := 0; end if; for I in Filename'First .. Separator_Pos loop Nam_Length := Nam_Length + 1; Nam_Buffer (Nam_Length) := Filename (I); end loop; Directory := Get_Identifier; Name := Get_Identifier (Filename (Separator_Pos + 1 .. Filename'Last)); end Normalize_Pathname; -- Find a source_file by DIRECTORY and NAME. -- Return NO_SOURCE_FILE_ENTRY if not already opened. function Find_Source_File (Directory : Name_Id; Name: Name_Id) return Source_File_Entry is begin for I in Source_Files.First .. Source_Files.Last loop if Source_Files.Table (I).File_Name = Name and then Source_Files.Table (I).Directory = Directory then return I; end if; end loop; return No_Source_File_Entry; end Find_Source_File; -- Return an entry for a filename. -- The file is not loaded. function Create_Source_File_Entry (Directory : Name_Id; Name: Name_Id) return Source_File_Entry is Res: Source_File_Entry; begin -- File must not already exist. pragma Assert (Find_Source_File (Directory, Name) = No_Source_File_Entry); -- Create a new entry. Res := Source_Files.Allocate; Source_Files.Table (Res) := (Kind => Source_File_File, First_Location => Next_Location, Last_Location => Next_Location, File_Name => Name, Directory => Directory, Checksum => No_File_Checksum_Id, Source => null, File_Length => 0, Nbr_Lines => 0, Lines_Table_Max => 0, Lines_Table => null, Cache_Pos => Source_Ptr_Org, Cache_Line => 1); File_Add_Line_Number (Res, 1, Source_Ptr_Org); return Res; end Create_Source_File_Entry; function Create_Source_File_From_String (Name: Name_Id; Content : String) return Source_File_Entry is Len : constant Source_Ptr := Source_Ptr (Content'Length); Res : Source_File_Entry; Buffer: File_Buffer_Acc; begin -- Fill buffer. Buffer := new File_Buffer (Source_Ptr_Org .. Source_Ptr_Org + Len + 1); if Len /= 0 then Buffer (Source_Ptr_Org .. Source_Ptr_Org + Len - 1) := File_Buffer (Content); end if; Buffer (Source_Ptr_Org + Len) := EOT; Buffer (Source_Ptr_Org + Len + 1) := EOT; -- Create entry. Res := Source_Files.Allocate; Source_Files.Table (Res) := (Kind => Source_File_String, First_Location => Next_Location, Last_Location => Next_Location + Location_Type (Len) + 1, File_Name => Name, Directory => Null_Identifier, Checksum => No_File_Checksum_Id, Source => Buffer, File_Length => Natural (Len)); Next_Location := Source_Files.Table (Res).Last_Location + 1; return Res; end Create_Source_File_From_String; function Create_Virtual_Source_File (Name: Name_Id) return Source_File_Entry is begin return Create_Source_File_From_String (Name, ""); end Create_Virtual_Source_File; function Create_Instance_Source_File (Ref : Source_File_Entry; Loc : Location_Type; Inst : Nodes.Node_Type) return Source_File_Entry is pragma Unreferenced (Inst); Base : Source_File_Entry; Res : Source_File_Entry; begin if Source_Files.Table (Ref).Kind = Source_File_Instance then Base := Source_Files.Table (Ref).Base; else Base := Ref; end if; -- Create entry. Res := Source_Files.Allocate; declare F : Source_File_Record renames Source_Files.Table (Base); begin Source_Files.Table (Res) := (Kind => Source_File_Instance, First_Location => Next_Location, Last_Location => Next_Location + Location_Type (F.File_Length) + 1, File_Name => F.File_Name, Directory => F.Directory, Checksum => F.Checksum, Source => F.Source, File_Length => F.File_Length, Ref => Ref, Base => Base, Instance_Loc => Loc); Next_Location := Source_Files.Table (Res).Last_Location + 1; end; return Res; end Create_Instance_Source_File; function Instance_Relocate (Inst_File : Source_File_Entry; Loc : Location_Type) return Location_Type is pragma Assert (Inst_File <= Source_Files.Last); F : Source_File_Record renames Source_Files.Table (Inst_File); pragma Assert (F.Kind = Source_File_Instance); R : Source_File_Record renames Source_Files.Table (F.Ref); begin if Loc >= R.First_Location and Loc <= R.Last_Location then return F.First_Location + (Loc - R.First_Location); else return Loc; end if; end Instance_Relocate; function Location_Instance_To_Location (Loc : Location_Type) return Location_Type is File : Source_File_Entry; Pos : Source_Ptr; begin if Loc = No_Location then return No_Location; end if; Location_To_File_Pos (Loc, File, Pos); if Source_Files.Table (File).Kind = Source_File_Instance then return Source_Files.Table (File).Instance_Loc; else return No_Location; end if; end Location_Instance_To_Location; -- Return an entry for a filename. -- Load the filename if necessary. function Read_Source_File (Directory : Name_Id; Name: Name_Id) return Source_File_Entry is use GNAT.OS_Lib; Fd : File_Descriptor; Res : Source_File_Entry; Raw_Length : Long_Integer; Length : Source_Ptr; Buffer : File_Buffer_Acc; begin -- If the file is already loaded, nothing to do! Res := Find_Source_File (Directory, Name); if Res /= No_Source_File_Entry then pragma Assert (Source_Files.Table (Res).Source /= null); return Res; end if; -- Open the file (punt on non regular files). declare Filename : String := Get_Pathname (Directory, Name, True); begin if not Is_Regular_File (Filename) then return No_Source_File_Entry; end if; Fd := Open_Read (Filename'Address, Binary); if Fd = Invalid_FD then return No_Source_File_Entry; end if; end; Raw_Length := File_Length (Fd); -- Check for too large files. Use 'Pos (ie universal integer) to avoid -- errors in conversions. if Long_Integer'Pos (Raw_Length) > Source_Ptr'Pos (Source_Ptr'Last) or else Long_Integer'Pos (Raw_Length) > Integer'Pos (Integer'Last) then Close (Fd); return No_Source_File_Entry; end if; Res := Create_Source_File_Entry (Directory, Name); Length := Source_Ptr (Raw_Length); Buffer := new File_Buffer (Source_Ptr_Org .. Source_Ptr_Org + Length + 1); if Read (Fd, Buffer (Source_Ptr_Org)'Address, Integer (Length)) /= Integer (Length) then Close (Fd); raise Internal_Error; end if; Buffer (Source_Ptr_Org + Length) := EOT; Buffer (Source_Ptr_Org + Length + 1) := EOT; Close (Fd); -- Read_Source_File call must follow its Create_Source_File. pragma Assert (Source_Files.Table (Res).First_Location = Next_Location); -- Compute the SHA1. declare use GNAT.SHA1; use Str_Table; subtype Buffer_String is String (1 .. Buffer'Length - 2); Buffer_Digest : Message_Digest; begin if Length /= 0 then -- Avoid weird bounds for empty buffers. Buffer_Digest := Digest (Buffer_String (Buffer (Source_Ptr_Org .. Source_Ptr_Org + Length - 1))); end if; Source_Files.Table (Res).Checksum := File_Checksum_Id (Create_String8); for I in Buffer_Digest'Range loop Append_String8_Char (Buffer_Digest (I)); end loop; end; Source_Files.Table (Res).Last_Location := Next_Location + Location_Type (Length) + 1; Next_Location := Source_Files.Table (Res).Last_Location + 1; Source_Files.Table (Res).Source := Buffer; Source_Files.Table (Res).File_Length := Integer (Length); return Res; end Read_Source_File; procedure Free_Source_File (File : Source_File_Entry) is procedure free (Ptr : Lines_Table_Ptr); pragma Import (C, free); procedure Free is new Ada.Unchecked_Deallocation (File_Buffer, File_Buffer_Acc); F : Source_File_Record renames Source_Files.Table (File); begin case F.Kind is when Source_File_File => free (F.Lines_Table); Free (F.Source); when Source_File_String => Free (F.Source); when Source_File_Instance => null; end case; end Free_Source_File; procedure Unload_Last_Source_File (File : Source_File_Entry) is begin pragma Assert (File = Source_Files.Last); Free_Source_File (File); Source_Files.Decrement_Last; Next_Location := Source_Files.Table (Source_Files.Last).Last_Location + 1; end Unload_Last_Source_File; -- Check validity of FILE. -- Raise an exception in case of error. procedure Check_File (File : Source_File_Entry) is begin pragma Assert (File <= Source_Files.Last); null; end Check_File; -- Return a buffer (access to the contents of the file) for a file entry. function Get_File_Source (File: Source_File_Entry) return File_Buffer_Acc is begin Check_File (File); return Source_Files.Table (File).Source; end Get_File_Source; function Get_File_Buffer (File : Source_File_Entry) return File_Buffer_Ptr is begin return To_File_Buffer_Ptr (Source_Files.Table (File).Source (Source_Ptr_Org)'Address); end Get_File_Buffer; -- Return the length of the file (which is the size of the file buffer). function Get_File_Length (File: Source_File_Entry) return Source_Ptr is begin Check_File (File); return Source_Ptr (Source_Files.Table (File).File_Length); end Get_File_Length; -- Return the name of the file. function Get_File_Name (File: Source_File_Entry) return Name_Id is begin Check_File (File); return Source_Files.Table (File).File_Name; end Get_File_Name; function Get_File_Checksum (File : Source_File_Entry) return File_Checksum_Id is begin Check_File (File); return Source_Files.Table (File).Checksum; end Get_File_Checksum; function Get_Source_File_Directory (File : Source_File_Entry) return Name_Id is begin Check_File (File); return Source_Files.Table (File).Directory; end Get_Source_File_Directory; function Line_To_Position (File : Source_File_Entry; Line : Natural) return Source_Ptr is pragma Assert (File <= Source_Files.Last); Source_File: Source_File_Record renames Source_Files.Table (File); begin case Source_File.Kind is when Source_File_File => if Line > Source_File.Nbr_Lines then return Source_Ptr_Bad; else return Source_File.Lines_Table (Line); end if; when Source_File_String => if Line /= 1 then return Source_Ptr_Bad; else return Source_Ptr_Org; end if; when Source_File_Instance => return Line_To_Position (Source_File.Base, Line); end case; end Line_To_Position; function Is_Eq (L : Time_Stamp_Id; R : Time_Stamp_Id) return Boolean is use Str_Table; L_Str : constant String8_Id := String8_Id (L); R_Str : constant String8_Id := String8_Id (R); begin for I in 1 .. Nat32 (Time_Stamp_String'Length) loop if Element_String8 (L_Str, I) /= Element_String8 (R_Str, I) then return False; end if; end loop; return True; end Is_Eq; function Is_Eq (L, R : File_Checksum_Id) return Boolean is use Str_Table; L_Str : constant String8_Id := String8_Id (L); R_Str : constant String8_Id := String8_Id (R); begin for I in 1 .. Nat32 (File_Checksum_String'Length) loop if Element_String8 (L_Str, I) /= Element_String8 (R_Str, I) then return False; end if; end loop; return True; end Is_Eq; function Is_Gt (L : Time_Stamp_Id; R : Time_Stamp_Id) return Boolean is use Str_Table; L_Str : constant String8_Id := String8_Id (L); R_Str : constant String8_Id := String8_Id (R); E_L, E_R : Nat8; begin for I in 1 .. Nat32 (Time_Stamp_String'Length) loop E_L := Element_String8 (L_Str, I); E_R := Element_String8 (R_Str, I); if E_L /= E_R then return E_L > E_R; end if; end loop; return False; end Is_Gt; function Get_Time_Stamp_String (Ts : Time_Stamp_Id) return String is begin if Ts = Null_Time_Stamp then return "NULL_TS"; else return Str_Table.String_String8 (String8_Id (Ts), Time_Stamp_String'Length); end if; end Get_Time_Stamp_String; function Get_File_Checksum_String (Checksum : File_Checksum_Id) return String is begin if Checksum = No_File_Checksum_Id then return "NO_CHECKSUM"; else return Str_Table.String_String8 (String8_Id (Checksum), File_Checksum_String'Length); end if; end Get_File_Checksum_String; function Image (Loc : Location_Type; Filename : Boolean := True) return string is Line, Col : Natural; Name : Name_Id; begin if Loc = Location_Nil then -- Avoid a crash. return "??:??:??"; end if; Location_To_Position (Loc, Name, Line, Col); declare Line_Str : constant String := Natural'Image (Line); Col_Str : constant String := Natural'Image (Col); begin if Filename then return Name_Table.Image (Name) & ':' & Line_Str (Line_Str'First + 1 .. Line_Str'Last) & ':' & Col_Str (Col_Str'First + 1 .. Col_Str'Last); else return Line_Str (Line_Str'First + 1 .. Line_Str'Last) & ':' & Col_Str (Col_Str'First + 1 .. Col_Str'Last); end if; end; end Image; -- Compute the length of line that starts at START. Tabs are expanded to -- compute the length. function Compute_Expanded_Line_Length (File : Source_File_Entry; Start : Source_Ptr) return Natural is Buf : constant File_Buffer_Acc := Get_File_Source (File); Pos : Source_Ptr; Len : Natural; C : Character; begin -- Compute line length. Pos := Start; Len := 0; loop C := Buf (Pos); Pos := Pos + 1; exit when C = ASCII.CR or C = ASCII.LF or C = ASCII.EOT; if C = ASCII.HT then -- Expand tab. Len := Len + (Tab_Stop - Len mod Tab_Stop); else Len := Len + 1; end if; end loop; return Len; end Compute_Expanded_Line_Length; -- Return the line that starts at START in FILE. This is slow. function Extract_Expanded_Line (File : Source_File_Entry; Start : Source_Ptr) return String is Buf : constant File_Buffer_Acc := Get_File_Source (File); Len : constant Natural := Compute_Expanded_Line_Length (File, Start); Res : String (1 .. Len); P : Natural; Pos : Source_Ptr; C : Character; begin Pos := Start; P := 0; loop C := Buf (Pos); Pos := Pos + 1; exit when C = ASCII.CR or C = ASCII.LF or C = ASCII.EOT; if C = ASCII.HT then -- Expand tab. loop P := P + 1; Res (P) := ' '; exit when P mod Tab_Stop = 0; end loop; else P := P + 1; Res (P) := C; end if; end loop; pragma Assert (P = Res'Last); return Res; end Extract_Expanded_Line; function Extract_Expanded_Line (File : Source_File_Entry; Line : Natural) return String is Start : constant Source_Ptr := Line_To_Position (File, Line); begin return Extract_Expanded_Line (File, Start); end Extract_Expanded_Line; -- Debug procedures. procedure Debug_Source_Loc (Loc : Location_Type) is File : Source_File_Entry; Line_Pos : Source_Ptr; Line : Natural; Offset : Natural; begin Location_To_Coord (Loc, File, Line_Pos, Line, Offset); Put_Line (Extract_Expanded_Line (File, Line_Pos)); end Debug_Source_Loc; -- Disp sources lines of a file. procedure Debug_Source_Lines (File: Source_File_Entry) is Source_File: Source_File_Record renames Source_Files.Table (File); begin Check_File (File); for I in Positive'First .. Source_File.Nbr_Lines loop Put_Line ("line" & Natural'Image (I) & " at offset" & Source_Ptr'Image (Source_File.Lines_Table (I))); end loop; end Debug_Source_Lines; procedure Debug_Source_Files is begin for I in Source_Files.First .. Source_Files.Last loop declare F : Source_File_Record renames Source_Files.Table(I); begin Put (Source_File_Entry'Image (I)); Put (" name: " & Image (F.File_Name)); Put (" dir:" & Image (F.Directory)); Put (" length:" & Natural'Image (F.File_Length)); New_Line; Put (" location:" & Location_Type'Image (F.First_Location) & " -" & Location_Type'Image (F.Last_Location)); New_Line; if F.Checksum /= No_File_Checksum_Id then Put (" checksum: " & Get_File_Checksum_String (F.Checksum)); New_Line; end if; case F.Kind is when Source_File_File => Put (" nbr lines:" & Natural'Image (F.Nbr_Lines)); Put (" lines_table_max:" & Natural'Image (F.Lines_Table_Max)); New_Line; when others => null; end case; end; end loop; end Debug_Source_Files; pragma Unreferenced (Debug_Source_Lines); pragma Unreferenced (Debug_Source_Loc); procedure Initialize is begin for I in Source_Files.First .. Source_Files.Last loop Free_Source_File (I); end loop; Source_Files.Free; Source_Files.Init; Next_Location := Location_Nil + 1; end Initialize; end Files_Map;