-- --
-- B o d y --
-- --
--- $Revision$
--- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2007, 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 GNAT.HTable;
-with Namet; use Namet;
-with Osint; use Osint;
-with Output; use Output;
+with Opt; use Opt;
+with Osint; use Osint;
+with Output; use Output;
with Table;
+with Types; use Types;
+
+with System.OS_Lib; use System.OS_Lib;
with Unchecked_Conversion;
+with GNAT.HTable;
+
package body Fmap is
subtype Big_String is String (Positive);
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,
type Header_Num is range 0 .. 1_000;
function Hash (F : Unit_Name_Type) return Header_Num;
+ -- Function used to compute hash of unit name
No_Entry : constant Int := -1;
-- Signals no entry in following table
-- 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.
- ---------
- -- Add --
- ---------
+ Last_In_Table : Int := 0;
- procedure Add
- (Unit_Name : Unit_Name_Type;
- File_Name : File_Name_Type;
- Path_Name : File_Name_Type) is
- 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;
- end Add;
+ 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 => "=");
- ------------------
- -- File_Name_Of --
- ------------------
+ -----------------------------
+ -- Add_Forbidden_File_Name --
+ -----------------------------
- function File_Name_Of (Unit : Unit_Name_Type) return File_Name_Type is
- The_Index : constant Int := Unit_Hash_Table.Get (Unit);
+ procedure Add_Forbidden_File_Name (Name : File_Name_Type) is
begin
- if The_Index = No_Entry then
- return No_File;
+ Forbidden_Names.Set (Name, True);
+ end Add_Forbidden_File_Name;
- else
- return File_Mapping.Table (The_Index);
+ ---------------------
+ -- Add_To_File_Map --
+ ---------------------
+
+ procedure Add_To_File_Map
+ (Unit_Name : Unit_Name_Type;
+ 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
+ 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;
- end File_Name_Of;
+ 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 for "/", otherwise call Name_Find
+ -- What is this about, explanation required ???
+
+ function Find_Unit_Name return Unit_Name_Type;
+ -- Return Error_Unit_Name for "/", otherwise call Name_Find
+ -- Even more mysterious??? function appeared when Find_Name was split
+ -- for the two types, but this routine is definitely called!
+
procedure Get_Line;
-- Get a line from the mapping file
File_Hash_Table.Reset;
Path_Mapping.Set_Last (0);
File_Mapping.Set_Last (0);
+ Last_In_Table := 0;
end Empty_Tables;
+ --------------------
+ -- Find_File_Name --
+ --------------------
+
+ -- Why is only / illegal, why not \ on windows ???
+
+ function Find_File_Name return File_Name_Type is
+ begin
+ if Name_Buffer (1 .. Name_Len) = "/" then
+ 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);
+ -- very odd ???
+ end Find_Unit_Name;
+
--------------
-- Get_Line --
--------------
procedure Get_Line is
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);
SP := BS (1 .. Natural (Hi))'Unrestricted_Access;
loop
-
-- Get the unit name
Get_Line;
-- 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_Str ("warning: mapping file """);
+ Write_Str (File_Name);
+ Write_Line (""" is incorrectly formatted");
+ 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;
+ Name_Len := Last - First + 1;
+ Name_Buffer (1 .. Name_Len) := SP (First .. Last);
+ Pname := Find_File_Name;
- -- Check for duplicate entries
+ -- Add the mappings for this unit name
- 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;
+ Add_To_File_Map (Uname, Fname, Pname);
+ end loop;
+ 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;
+ -- Record the length of the two mapping tables
- -- Add the mappings for this unit name
+ Last_In_Table := File_Mapping.Last;
+ end Initialize;
- Add (Uname, Fname, Pname);
+ ----------------------
+ -- Mapped_File_Name --
+ ----------------------
- end loop;
+ function Mapped_File_Name (Unit : Unit_Name_Type) return File_Name_Type is
+ The_Index : constant Int := Unit_Hash_Table.Get (Unit);
+ begin
+ if The_Index = No_Entry then
+ return No_File;
+ else
+ return File_Mapping.Table (The_Index).Fname;
end if;
+ end Mapped_File_Name;
- end Initialize;
-
- ------------------
- -- Path_Name_Of --
- ------------------
+ ----------------------
+ -- Mapped_Path_Name --
+ ----------------------
- function Path_Name_Of (File : File_Name_Type) return File_Name_Type is
+ function Mapped_Path_Name (File : File_Name_Type) return File_Name_Type is
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;
+
+ --------------------------------
+ -- Remove_Forbidden_File_Name --
+ --------------------------------
+
+ procedure Remove_Forbidden_File_Name (Name : File_Name_Type) is
+ begin
+ Forbidden_Names.Set (Name, False);
+ end Remove_Forbidden_File_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);
- end Path_Name_Of;
+ 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
+
+ -- Only Update if there are new entries in the mappings
+
+ if Last_In_Table < File_Mapping.Last then
+
+ -- If the tables have been emptied, recreate the file.
+ -- Otherwise, append to it.
+
+ if Last_In_Table = 0 then
+ declare
+ Discard : Boolean;
+
+ begin
+ Delete_File (File_Name, Discard);
+ end;
+
+ File := Create_File (File_Name, Binary);
+
+ else
+ File := Open_Read_Write (Name => File_Name, Fmode => Binary);
+ end if;
+
+ 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
