-- --
-- B o d y --
-- --
--- $Revision: 1.1 $
--- --
--- Copyright (C) 2001, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-with Namet; use Namet;
+with Opt; use Opt;
with Osint; use Osint;
with Output; use Output;
with Table;
+with Types; use Types;
+
+pragma Warnings (Off);
+-- This package is used also by gnatcoll
+with System.OS_Lib; use System.OS_Lib;
+pragma Warnings (On);
with Unchecked_Conversion;
package body Fmap is
- subtype Big_String is String (Positive);
- type Big_String_Ptr is access all Big_String;
+ No_Mapping_File : Boolean := False;
+ -- Set to True when the specified mapping file cannot be read in
+ -- procedure Initialize, so that no attempt is made to open the mapping
+ -- file in procedure Update_Mapping_File.
function To_Big_String_Ptr is new Unchecked_Conversion
(Source_Buffer_Ptr, Big_String_Ptr);
+ Max_Buffer : constant := 1_500;
+ Buffer : String (1 .. Max_Buffer);
+ -- Used to bufferize output when writing to a new mapping file
+
+ Buffer_Last : Natural := 0;
+ -- Index of last valid character in Buffer
+
+ type Mapping is record
+ Uname : Unit_Name_Type;
+ Fname : File_Name_Type;
+ end record;
+
package File_Mapping is new Table.Table (
- Table_Component_Type => File_Name_Type,
+ Table_Component_Type => Mapping,
Table_Index_Type => Int,
Table_Low_Bound => 0,
Table_Initial => 1_000,
Table_Increment => 1_000,
Table_Name => "Fmap.File_Mapping");
- -- Mapping table to map unit names to file names.
+ -- Mapping table to map unit names to file names
package Path_Mapping is new Table.Table (
- Table_Component_Type => File_Name_Type,
+ Table_Component_Type => Mapping,
Table_Index_Type => Int,
Table_Low_Bound => 0,
Table_Initial => 1_000,
-- Hash table to map unit names to file names. Used in conjunction with
-- table File_Mapping above.
+ function Hash (F : File_Name_Type) return Header_Num;
+ -- Function used to compute hash of file name
+
package File_Hash_Table is new GNAT.HTable.Simple_HTable (
Header_Num => Header_Num,
Element => Int,
-- Hash table to map file names to path names. Used in conjunction with
-- table Path_Mapping above.
+ Last_In_Table : Int := 0;
+
+ package Forbidden_Names is new GNAT.HTable.Simple_HTable (
+ Header_Num => Header_Num,
+ Element => Boolean,
+ No_Element => False,
+ Key => File_Name_Type,
+ Hash => Hash,
+ Equal => "=");
+
+ -----------------------------
+ -- Add_Forbidden_File_Name --
+ -----------------------------
+
+ procedure Add_Forbidden_File_Name (Name : File_Name_Type) is
+ begin
+ Forbidden_Names.Set (Name, True);
+ end Add_Forbidden_File_Name;
+
---------------------
-- Add_To_File_Map --
---------------------
File_Name : File_Name_Type;
Path_Name : File_Name_Type)
is
+ Unit_Entry : constant Int := Unit_Hash_Table.Get (Unit_Name);
+ File_Entry : constant Int := File_Hash_Table.Get (File_Name);
begin
- File_Mapping.Increment_Last;
- Unit_Hash_Table.Set (Unit_Name, File_Mapping.Last);
- File_Mapping.Table (File_Mapping.Last) := File_Name;
- Path_Mapping.Increment_Last;
- File_Hash_Table.Set (File_Name, Path_Mapping.Last);
- Path_Mapping.Table (Path_Mapping.Last) := Path_Name;
+ if Unit_Entry = No_Entry or else
+ File_Mapping.Table (Unit_Entry).Fname /= File_Name
+ then
+ File_Mapping.Increment_Last;
+ Unit_Hash_Table.Set (Unit_Name, File_Mapping.Last);
+ File_Mapping.Table (File_Mapping.Last) :=
+ (Uname => Unit_Name, Fname => File_Name);
+ end if;
+
+ if File_Entry = No_Entry or else
+ Path_Mapping.Table (File_Entry).Fname /= Path_Name
+ then
+ Path_Mapping.Increment_Last;
+ File_Hash_Table.Set (File_Name, Path_Mapping.Last);
+ Path_Mapping.Table (Path_Mapping.Last) :=
+ (Uname => Unit_Name, Fname => Path_Name);
+ end if;
end Add_To_File_Map;
----------
-- Hash --
----------
+ function Hash (F : File_Name_Type) return Header_Num is
+ begin
+ return Header_Num (Int (F) rem Header_Num'Range_Length);
+ end Hash;
+
function Hash (F : Unit_Name_Type) return Header_Num is
begin
return Header_Num (Int (F) rem Header_Num'Range_Length);
BS : Big_String_Ptr;
SP : String_Ptr;
- Deb : Positive := 1;
- Fin : Natural := 0;
+ First : Positive := 1;
+ Last : Natural := 0;
Uname : Unit_Name_Type;
- Fname : Name_Id;
- Pname : Name_Id;
+ Fname : File_Name_Type;
+ Pname : File_Name_Type;
procedure Empty_Tables;
-- Remove all entries in case of incorrect mapping file
+ function Find_File_Name return File_Name_Type;
+ -- Return Error_File_Name if the name buffer contains "/", otherwise
+ -- call Name_Find. "/" is the path name in the mapping file to indicate
+ -- that a source has been suppressed, and thus should not be found by
+ -- the compiler.
+
+ function Find_Unit_Name return Unit_Name_Type;
+ -- Return the unit name in the name buffer. Return Error_Unit_Name if
+ -- the name buffer contains "/".
+
procedure Get_Line;
- -- Get a line from the mapping file
+ -- Get a line from the mapping file, where a line is SP (First .. Last)
procedure Report_Truncated;
-- Report a warning when the mapping file is truncated
File_Hash_Table.Reset;
Path_Mapping.Set_Last (0);
File_Mapping.Set_Last (0);
+ Last_In_Table := 0;
end Empty_Tables;
+ --------------------
+ -- Find_File_Name --
+ --------------------
+
+ function Find_File_Name return File_Name_Type is
+ begin
+ if Name_Buffer (1 .. Name_Len) = "/" then
+
+ -- A path name of "/" is the indication that the source has been
+ -- "suppressed". Return Error_File_Name so that the compiler does
+ -- not find the source, even if it is in the include path.
+
+ return Error_File_Name;
+
+ else
+ return Name_Find;
+ end if;
+ end Find_File_Name;
+
+ --------------------
+ -- Find_Unit_Name --
+ --------------------
+
+ function Find_Unit_Name return Unit_Name_Type is
+ begin
+ return Unit_Name_Type (Find_File_Name);
+ end Find_Unit_Name;
+
--------------
-- Get_Line --
--------------
use ASCII;
begin
- Deb := Fin + 1;
+ First := Last + 1;
-- If not at the end of file, skip the end of line
- while Deb < SP'Last
- and then (SP (Deb) = CR
- or else SP (Deb) = LF
- or else SP (Deb) = EOF)
+ while First < SP'Last
+ and then (SP (First) = CR
+ or else SP (First) = LF
+ or else SP (First) = EOF)
loop
- Deb := Deb + 1;
+ First := First + 1;
end loop;
- -- If not at the end of line, find the end of this new line
+ -- If not at the end of file, find the end of this new line
- if Deb < SP'Last and then SP (Deb) /= EOF then
- Fin := Deb;
+ if First < SP'Last and then SP (First) /= EOF then
+ Last := First;
- while Fin < SP'Last
- and then SP (Fin + 1) /= CR
- and then SP (Fin + 1) /= LF
- and then SP (Fin + 1) /= EOF
+ while Last < SP'Last
+ and then SP (Last + 1) /= CR
+ and then SP (Last + 1) /= LF
+ and then SP (Last + 1) /= EOF
loop
- Fin := Fin + 1;
+ Last := Last + 1;
end loop;
end if;
Write_Line (""" is truncated");
end Report_Truncated;
- -- Start of procedure Initialize
+ -- Start of processing for Initialize
begin
+ Empty_Tables;
Name_Len := File_Name'Length;
Name_Buffer (1 .. Name_Len) := File_Name;
Read_Source_File (Name_Enter, 0, Hi, Src, Config);
Write_Str ("warning: could not read mapping file """);
Write_Str (File_Name);
Write_Line ("""");
+ No_Mapping_File := True;
else
BS := To_Big_String_Ptr (Src);
-- Exit if end of file has been reached
- exit when Deb > Fin;
+ exit when First > Last;
- pragma Assert (Fin >= Deb + 2);
- pragma Assert (SP (Fin - 1) = '%');
- pragma Assert (SP (Fin) = 's' or else SP (Fin) = 'b');
+ if (Last < First + 2) or else (SP (Last - 1) /= '%')
+ or else (SP (Last) /= 's' and then SP (Last) /= 'b')
+ then
+ Write_Line
+ ("warning: mapping file """ & File_Name &
+ """ is incorrectly formatted");
+ Write_Line ("Line = """ & SP (First .. Last) & '"');
+ Empty_Tables;
+ return;
+ end if;
- Name_Len := Fin - Deb + 1;
- Name_Buffer (1 .. Name_Len) := SP (Deb .. Fin);
- Uname := Name_Find;
+ Name_Len := Last - First + 1;
+ Name_Buffer (1 .. Name_Len) := SP (First .. Last);
+ Uname := Find_Unit_Name;
-- Get the file name
-- If end of line has been reached, file is truncated
- if Deb > Fin then
+ if First > Last then
Report_Truncated;
Empty_Tables;
return;
end if;
- Name_Len := Fin - Deb + 1;
- Name_Buffer (1 .. Name_Len) := SP (Deb .. Fin);
- Fname := Name_Find;
+ Name_Len := Last - First + 1;
+ Name_Buffer (1 .. Name_Len) := SP (First .. Last);
+ Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+ Fname := Find_File_Name;
-- Get the path name
-- If end of line has been reached, file is truncated
- if Deb > Fin then
+ if First > Last then
Report_Truncated;
Empty_Tables;
return;
end if;
- Name_Len := Fin - Deb + 1;
- Name_Buffer (1 .. Name_Len) := SP (Deb .. Fin);
- Pname := Name_Find;
-
- -- Check for duplicate entries
-
- if Unit_Hash_Table.Get (Uname) /= No_Entry then
- Write_Str ("warning: duplicate entry """);
- Write_Str (Get_Name_String (Uname));
- Write_Str (""" in mapping file """);
- Write_Str (File_Name);
- Write_Line ("""");
- Empty_Tables;
- return;
- end if;
-
- if File_Hash_Table.Get (Fname) /= No_Entry then
- Write_Str ("warning: duplicate entry """);
- Write_Str (Get_Name_String (Fname));
- Write_Str (""" in mapping file """);
- Write_Str (File_Name);
- Write_Line ("""");
- Empty_Tables;
- return;
- end if;
+ Name_Len := Last - First + 1;
+ Name_Buffer (1 .. Name_Len) := SP (First .. Last);
+ Pname := Find_File_Name;
-- Add the mappings for this unit name
Add_To_File_Map (Uname, Fname, Pname);
end loop;
end if;
+
+ -- Record the length of the two mapping tables
+
+ Last_In_Table := File_Mapping.Last;
end Initialize;
----------------------
if The_Index = No_Entry then
return No_File;
else
- return File_Mapping.Table (The_Index);
+ return File_Mapping.Table (The_Index).Fname;
end if;
end Mapped_File_Name;
Index : Int := No_Entry;
begin
+ if Forbidden_Names.Get (File) then
+ return Error_File_Name;
+ end if;
+
Index := File_Hash_Table.Get (File);
if Index = No_Entry then
return No_File;
else
- return Path_Mapping.Table (Index);
+ return Path_Mapping.Table (Index).Fname;
end if;
end Mapped_Path_Name;
+ ------------------
+ -- Reset_Tables --
+ ------------------
+
+ procedure Reset_Tables is
+ begin
+ File_Mapping.Init;
+ Path_Mapping.Init;
+ Unit_Hash_Table.Reset;
+ File_Hash_Table.Reset;
+ Forbidden_Names.Reset;
+ Last_In_Table := 0;
+ end Reset_Tables;
+
+ -------------------------
+ -- Update_Mapping_File --
+ -------------------------
+
+ procedure Update_Mapping_File (File_Name : String) is
+ File : File_Descriptor;
+ N_Bytes : Integer;
+
+ File_Entry : Int;
+
+ Status : Boolean;
+ -- For the call to Close
+
+ procedure Put_Line (Name : Name_Id);
+ -- Put Name as a line in the Mapping File
+
+ --------------
+ -- Put_Line --
+ --------------
+
+ procedure Put_Line (Name : Name_Id) is
+ begin
+ Get_Name_String (Name);
+
+ -- If the Buffer is full, write it to the file
+
+ if Buffer_Last + Name_Len + 1 > Buffer'Last then
+ N_Bytes := Write (File, Buffer (1)'Address, Buffer_Last);
+
+ if N_Bytes < Buffer_Last then
+ Fail ("disk full");
+ end if;
+
+ Buffer_Last := 0;
+ end if;
+
+ -- Add the line to the Buffer
+
+ Buffer (Buffer_Last + 1 .. Buffer_Last + Name_Len) :=
+ Name_Buffer (1 .. Name_Len);
+ Buffer_Last := Buffer_Last + Name_Len + 1;
+ Buffer (Buffer_Last) := ASCII.LF;
+ end Put_Line;
+
+ -- Start of Update_Mapping_File
+
+ begin
+ -- If the mapping file could not be read, then it will not be possible
+ -- to update it.
+
+ if No_Mapping_File then
+ return;
+ end if;
+ -- Only Update if there are new entries in the mappings
+
+ if Last_In_Table < File_Mapping.Last then
+
+ File := Open_Read_Write (Name => File_Name, Fmode => Binary);
+
+ if File /= Invalid_FD then
+ if Last_In_Table > 0 then
+ Lseek (File, 0, Seek_End);
+ end if;
+
+ for Unit in Last_In_Table + 1 .. File_Mapping.Last loop
+ Put_Line (Name_Id (File_Mapping.Table (Unit).Uname));
+ Put_Line (Name_Id (File_Mapping.Table (Unit).Fname));
+ File_Entry :=
+ File_Hash_Table.Get (File_Mapping.Table (Unit).Fname);
+ Put_Line (Name_Id (Path_Mapping.Table (File_Entry).Fname));
+ end loop;
+
+ -- Before closing the file, write the buffer to the file. It is
+ -- guaranteed that the Buffer is not empty, because Put_Line has
+ -- been called at least 3 times, and after a call to Put_Line, the
+ -- Buffer is not empty.
+
+ N_Bytes := Write (File, Buffer (1)'Address, Buffer_Last);
+
+ if N_Bytes < Buffer_Last then
+ Fail ("disk full");
+ end if;
+
+ Close (File, Status);
+
+ if not Status then
+ Fail ("disk full");
+ end if;
+
+ elsif not Quiet_Output then
+ Write_Str ("warning: could not open mapping file """);
+ Write_Str (File_Name);
+ Write_Line (""" for update");
+ end if;
+
+ end if;
+ end Update_Mapping_File;
+
end Fmap;
OSDN Git Service
