diff options
Diffstat (limited to 'gcc/ada/fmap.adb')
| -rw-r--r-- | gcc/ada/fmap.adb | 535 |
1 files changed, 535 insertions, 0 deletions
diff --git a/gcc/ada/fmap.adb b/gcc/ada/fmap.adb new file mode 100644 index 000000000..171f7a18e --- /dev/null +++ b/gcc/ada/fmap.adb @@ -0,0 +1,535 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- F M A P -- +-- -- +-- B o d y -- +-- -- +-- 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 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 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 => 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 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; |