Subversion Repositories openrisc

------------------------------------------------------------------------------
--                                                                          --
--                         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;