-- 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
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 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) 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;
-- 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 : 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;
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 ('*');
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 Source_File_String =>
null;
when Source_File_Instance =>
Put (" instance from:" & Source_File_Entry'Image (F.Ref));
Put (", base:" & Source_File_Entry'Image (F.Base));
Put (", loc:" & Image (F.Instance_Loc));
New_Line;
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;