-- Loading of source files.
-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
--
-- This program 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 of the License, or
-- (at your option) any later version.
--
-- This program 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 this program. If not, see <gnu.org/licenses>.
with Ada.Unchecked_Deallocation;
with GNAT.OS_Lib;
with GNAT.SHA1;
with GNAT.Directory_Operations;
with Logging; use Logging;
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);
-- Next location to use.
Next_Location : Location_Type := Location_Nil + 1;
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
declare
Dir : constant String := GNAT.Directory_Operations.Get_Current_Dir;
begin
Home_Dir := Get_Identifier (Dir);
end;
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 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 File_To_Location;
-- 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 : Positive; Pos : Source_Ptr)
is
use Lines_Tables;
-- Just check File is not out of bounds.
pragma Assert (File <= Source_Files.Last);
Source_File: Source_File_Record renames Source_Files.Table (File);
Old_Last : Natural;
begin
-- Can only add line number to a real file.
pragma Assert (Source_File.Kind = Source_File_File);
-- Debug trace.
if False then
Log_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);
Old_Last := Last (Source_File.Lines);
if Line > Old_Last then
Allocate (Source_File.Lines, Line - Old_Last);
Source_File.Lines.Table (Old_Last + 1 .. Line) :=
(others => Source_Ptr_Bad);
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 = Last (Source_File.Lines)
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
Log_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;
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;
end if;
Res := Res + 1;
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
use Lines_Tables;
Lines_Table : constant Table_Thin_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 := Last (Source_File.Lines);
else
Low := 1;
Hi := Source_File.Cache_Line;
end if;
loop
<< Again >> null;
pragma Assert (Hi >= Low);
pragma Assert (Low >= 1);
pragma Assert (Hi <= Last (Source_File.Lines));
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 = Last (Source_File.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
use Lines_Tables;
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 := Last (Source_File.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 := Line_Pos;
Source_File.Cache_Line := Line;
end Location_To_Coord;
procedure Location_To_Position (Location : Location_Type;
Name : out Name_Id;
Line : out Positive;
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 File_Pos_To_Coord (File : Source_File_Entry;
Pos : Source_Ptr;
Line_Pos : out Source_Ptr;
Line : out Positive;
Offset : out Natural) is
begin
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 File_Pos_To_Coord;
procedure Location_To_Coord (Location : Location_Type;
File : out Source_File_Entry;
Line_Pos : out Source_Ptr;
Line : out Positive;
Offset : out Natural)
is
Pos : Source_Ptr;
begin
-- Get FILE and position POS in the file.
Location_To_File_Pos (Location, File, Pos);
File_Pos_To_Coord (File, Pos, Line_Pos, Line, Offset);
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 Positive
is
Line_Pos : Source_Ptr;
Line : Positive;
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 : Positive)
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;
function Location_File_Line_To_Offset
(Loc : Location_Type; File : Source_File_Entry; Line : Positive)
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 Natural (Pos - Line_Pos);
end Location_File_Line_To_Offset;
-- 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) return String
is
Filename : constant String := Image (Name);
begin
if not GNAT.OS_Lib.Is_Absolute_Path (Filename) then
return Image (Directory) & Filename;
else
return Filename;
end if;
end Get_Pathname;
procedure Normalize_Pathname
(Directory : in out Name_Id; Name : in out Name_Id)
is
Filename : constant String := Image (Name);
Separator_Pos : Natural;
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.
declare
File_Dir : constant String :=
Filename (Filename'First .. Separator_Pos);
begin
if Directory /= Null_Identifier then
Directory := Get_Identifier (Image (Directory) & File_Dir);
else
Directory := Get_Identifier (File_Dir);
end if;
end;
Name := Get_Identifier (Filename (Separator_Pos + 1 .. Filename'Last));
end Normalize_Pathname;
function Find_Language (Filename : String) return Language_Type
is
P, E : Natural;
Ext : String (1 .. 5);
begin
P := Filename'Last;
E := Ext'Last;
loop
if P <= Filename'First
or else E < Ext'First
then
return Language_Unknown;
end if;
case Filename (P) is
when 'a' .. 'z' =>
Ext (E) := Filename (P);
when 'A' .. 'Z' =>
Ext (E) := Character'Val (Character'Pos (Filename (P))
- Character'Pos ('A')
+ Character'Pos ('a'));
when '.' =>
if Ext (E + 1 .. Ext'Last) = "vhd"
or else Ext (E + 1 .. Ext'Last) = "vhdl"
then
return Language_Vhdl;
end if;
if Ext (E + 1 .. Ext'Last) = "v"
or else Ext (E + 1 .. Ext'Last) = "v"
or else Ext (E + 1 .. Ext'Last) = "sv"
or else Ext (E + 1 .. Ext'Last) = "svh"
then
return Language_Verilog;
end if;
if Ext (E + 1 .. Ext'Last) = "psl" then
return Language_Psl;
end if;
when others =>
return Language_Unknown;
end case;
P := P - 1;
E := E - 1;
end loop;
end Find_Language;
-- 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,
Lines => <>,
Cache_Pos => Source_Ptr_Org,
Cache_Line => 1,
Gap_Start => Source_Ptr_Last,
Gap_Last => Source_Ptr_Last);
Lines_Tables.Init (Source_Files.Table (Res).Lines, Lines_Table_Init);
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;
-- 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 => 0);
Set_File_Length (Res, 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 : Vhdl.Types.Vhdl_Node)
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;
function Reserve_Source_File
(Directory : Name_Id; Name: Name_Id; Length : Source_Ptr)
return Source_File_Entry
is
pragma Assert (Length >= 2);
Res : Source_File_Entry;
begin
Res := Create_Source_File_Entry (Directory, Name);
declare
F : Source_File_Record renames Source_Files.Table (Res);
begin
F.Source := new File_Buffer (Source_Ptr_Org
.. Source_Ptr_Org + Length - 1);
-- Read_Source_File call must follow its Create_Source_File.
pragma Assert (F.First_Location = Next_Location);
F.Last_Location := Next_Location + Location_Type (Length) - 1;
Next_Location := F.Last_Location + 1;
end;
return Res;
end Reserve_Source_File;
-- 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
-- The file is not supposed to be already loaded, but this could happen
-- if the same file is compiled in two libraries.
Res := Find_Source_File (Directory, Name);
if Res /= No_Source_File_Entry then
return Res;
end if;
-- Open the file (punt on non regular files).
declare
Filename : constant String := Get_Pathname (Directory, Name);
Filename0 : constant String := Filename & ASCII.NUL;
begin
if not Is_Regular_File (Filename) then
return No_Source_File_Entry;
end if;
Fd := Open_Read (Filename0'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;
Length := Source_Ptr (Raw_Length);
Res := Reserve_Source_File (Directory, Name, Length + 2);
if Res = No_Source_File_Entry then
Close (Fd);
return No_Source_File_Entry;
end if;
Buffer := Get_File_Source (Res);
if Read (Fd, Buffer (Source_Ptr_Org)'Address, Integer (Length))
/= Integer (Length)
then
Close (Fd);
raise Internal_Error;
end if;
Close (Fd);
Set_File_Length (Res, Length);
-- Set the gap.
Source_Files.Table (Res).Gap_Start :=
Source_Ptr_Org + Length + 2;
Source_Files.Table (Res).Gap_Last :=
Source_Files.Table (Res).Source'Last;
-- 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;
return Res;
end Read_Source_File;
procedure Discard_Source_File (File : Source_File_Entry)
is
pragma Assert (File <= Source_Files.Last);
F : Source_File_Record renames Source_Files.Table (File);
begin
F.File_Name := Null_Identifier;
F.Directory := Null_Identifier;
end Discard_Source_File;
procedure Free_Source_File (File : Source_File_Entry)
is
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 =>
Lines_Tables.Free (F.Lines);
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;
procedure Skip_Gap (File : Source_File_Entry; Pos : in out Source_Ptr)
is
pragma Assert (File <= Source_Files.Last);
F : Source_File_Record renames Source_Files.Table (File);
begin
if Pos = F.Gap_Start then
Pos := F.Gap_Last + 1;
end if;
end Skip_Gap;
-- 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;
procedure Set_File_Length (File : Source_File_Entry; Length : Source_Ptr) is
begin
Check_File (File);
declare
F : Source_File_Record renames Source_Files.Table (File);
Buffer : File_Buffer_Acc renames F.Source;
begin
pragma Assert (Length <= Buffer'Length - 2);
F.File_Length := Length;
Buffer (Source_Ptr_Org + Length) := EOT;
Buffer (Source_Ptr_Org + Length + 1) := EOT;
end;
end Set_File_Length;
function Get_File_Length (File: Source_File_Entry) return Source_Ptr is
begin
Check_File (File);
return Source_Files.Table (File).File_Length;
end Get_File_Length;
function Get_Content_Length (File : Source_File_Entry) return Source_Ptr
is
pragma Assert (File <= Source_Files.Last);
F : Source_File_Record renames Source_Files.Table (File);
begin
if F.Gap_Start >= F.File_Length then
return F.File_Length;
else
return F.File_Length - (F.Gap_Last - F.Gap_Start + 1);
end if;
end Get_Content_Length;
function Get_Buffer_Length (File : Source_File_Entry) return Source_Ptr
is
pragma Assert (File <= Source_Files.Last);
F : Source_File_Record renames Source_Files.Table (File);
begin
return Source_Ptr (F.Last_Location - F.First_Location + 1);
end Get_Buffer_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_Directory_Name (File : Source_File_Entry) return Name_Id is
begin
Check_File (File);
return Source_Files.Table (File).Directory;
end Get_Directory_Name;
function File_Line_To_Position (File : Source_File_Entry; Line : Positive)
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 > Lines_Tables.Last (Source_File.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 File_Line_To_Position (Source_File.Base, Line);
end case;
end File_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 : Positive) return String
is
Start : constant Source_Ptr := File_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);
Log_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 Lines_Tables.First .. Lines_Tables.Last (Source_File.Lines) loop
Log_Line ("line" & Natural'Image (I) & " at offset"
& Source_Ptr'Image (Source_File.Lines.Table (I)));
end loop;
end Debug_Source_Lines;
procedure Debug_Source_File (File : Source_File_Entry)
is
F : Source_File_Record renames Source_Files.Table(File);
begin
Log ("*");
Log (Source_File_Entry'Image (File));
Log (" name: " & Image (F.File_Name));
Log (" dir:" & Image (F.Directory));
Log (" file length:" & Source_Ptr'Image (F.File_Length));
Log_Line;
Log (" location:" & Location_Type'Image (F.First_Location)
& " -" & Location_Type'Image (F.Last_Location));
Log_Line;
if F.Checksum /= No_File_Checksum_Id then
Log (" checksum: " & Get_File_Checksum_String (F.Checksum));
Log_Line;
end if;
case F.Kind is
when Source_File_File =>
if F.Source = null then
Log (" no buf");
else
Log (" buf:" & Source_Ptr'Image (F.Source'First)
& " -" & Source_Ptr'Image (F.Source'Last));
end if;
Log_Line;
Log (" nbr lines:"
& Natural'Image (Lines_Tables.Last (F.Lines)));
Log_Line;
Log (" Gap:" & Source_Ptr'Image (F.Gap_Start)
& " -" & Source_Ptr'Image (F.Gap_Last));
Log_Line;
when Source_File_String =>
null;
when Source_File_Instance =>
Log (" instance from:" & Source_File_Entry'Image (F.Ref));
Log (", base:" & Source_File_Entry'Image (F.Base));
Log (", loc:" & Image (F.Instance_Loc));
Log_Line;
end case;
end Debug_Source_File;
procedure Debug_Source_Files is
begin
for I in Source_Files.First .. Source_Files.Last loop
Debug_Source_File (I);
end loop;
end Debug_Source_Files;
pragma Unreferenced (Debug_Source_Lines);
pragma Unreferenced (Debug_Source_Loc);
procedure Finalize is
begin
for I in Source_Files.First .. Source_Files.Last loop
Free_Source_File (I);
end loop;
Source_Files.Free;
end Finalize;
procedure Initialize is
begin
Source_Files.Init;
Next_Location := Location_Nil + 1;
end Initialize;
end Files_Map;