536 lines
16 KiB
Ada
536 lines
16 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- F M A P --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 2001-2015, 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 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 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. --
|
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
|
|
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;
|
|
|
|
with GNAT.HTable;
|
|
|
|
package body Fmap is
|
|
|
|
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 buffer 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 => 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
|
|
|
|
package Path_Mapping is new Table.Table (
|
|
Table_Component_Type => Mapping,
|
|
Table_Index_Type => Int,
|
|
Table_Low_Bound => 0,
|
|
Table_Initial => 1_000,
|
|
Table_Increment => 1_000,
|
|
Table_Name => "Fmap.Path_Mapping");
|
|
-- Mapping table to map file names to path names
|
|
|
|
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
|
|
|
|
package Unit_Hash_Table is new GNAT.HTable.Simple_HTable (
|
|
Header_Num => Header_Num,
|
|
Element => Int,
|
|
No_Element => No_Entry,
|
|
Key => Unit_Name_Type,
|
|
Hash => Hash,
|
|
Equal => "=");
|
|
-- 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,
|
|
No_Element => No_Entry,
|
|
Key => File_Name_Type,
|
|
Hash => Hash,
|
|
Equal => "=");
|
|
-- 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 --
|
|
---------------------
|
|
|
|
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;
|
|
|
|
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);
|
|
end Hash;
|
|
|
|
----------------
|
|
-- Initialize --
|
|
----------------
|
|
|
|
procedure Initialize (File_Name : String) is
|
|
Src : Source_Buffer_Ptr;
|
|
Hi : Source_Ptr;
|
|
BS : Big_String_Ptr;
|
|
SP : String_Ptr;
|
|
|
|
First : Positive := 1;
|
|
Last : Natural := 0;
|
|
|
|
Uname : Unit_Name_Type;
|
|
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, where a line is SP (First .. Last)
|
|
|
|
procedure Report_Truncated;
|
|
-- Report a warning when the mapping file is truncated
|
|
-- (number of lines is not a multiple of 3).
|
|
|
|
------------------
|
|
-- Empty_Tables --
|
|
------------------
|
|
|
|
procedure Empty_Tables is
|
|
begin
|
|
Unit_Hash_Table.Reset;
|
|
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 --
|
|
--------------
|
|
|
|
procedure Get_Line is
|
|
use ASCII;
|
|
|
|
begin
|
|
First := Last + 1;
|
|
|
|
-- If not at the end of file, skip the end of line
|
|
|
|
while First < SP'Last
|
|
and then (SP (First) = CR
|
|
or else SP (First) = LF
|
|
or else SP (First) = EOF)
|
|
loop
|
|
First := First + 1;
|
|
end loop;
|
|
|
|
-- If not at the end of file, find the end of this new line
|
|
|
|
if First < SP'Last and then SP (First) /= EOF then
|
|
Last := First;
|
|
|
|
while Last < SP'Last
|
|
and then SP (Last + 1) /= CR
|
|
and then SP (Last + 1) /= LF
|
|
and then SP (Last + 1) /= EOF
|
|
loop
|
|
Last := Last + 1;
|
|
end loop;
|
|
|
|
end if;
|
|
end Get_Line;
|
|
|
|
----------------------
|
|
-- Report_Truncated --
|
|
----------------------
|
|
|
|
procedure Report_Truncated is
|
|
begin
|
|
Write_Str ("warning: mapping file """);
|
|
Write_Str (File_Name);
|
|
Write_Line (""" is truncated");
|
|
end Report_Truncated;
|
|
|
|
-- 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);
|
|
|
|
if Src = null then
|
|
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);
|
|
SP := BS (1 .. Natural (Hi))'Unrestricted_Access;
|
|
|
|
loop
|
|
-- Get the unit name
|
|
|
|
Get_Line;
|
|
|
|
-- Exit if end of file has been reached
|
|
|
|
exit when First > Last;
|
|
|
|
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 := Last - First + 1;
|
|
Name_Buffer (1 .. Name_Len) := SP (First .. Last);
|
|
Uname := Find_Unit_Name;
|
|
|
|
-- Get the file name
|
|
|
|
Get_Line;
|
|
|
|
-- If end of line has been reached, file is truncated
|
|
|
|
if First > Last then
|
|
Report_Truncated;
|
|
Empty_Tables;
|
|
return;
|
|
end if;
|
|
|
|
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
|
|
|
|
Get_Line;
|
|
|
|
-- If end of line has been reached, file is truncated
|
|
|
|
if First > Last then
|
|
Report_Truncated;
|
|
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;
|
|
|
|
----------------------
|
|
-- Mapped_File_Name --
|
|
----------------------
|
|
|
|
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;
|
|
|
|
----------------------
|
|
-- Mapped_Path_Name --
|
|
----------------------
|
|
|
|
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).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 processing for 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;
|