Subversion Repositories openrisc_me

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             F N A M E . U F                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-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 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 Alloc;
with Debug;    use Debug;
with Fmap;     use Fmap;
with Krunch;
with Opt;      use Opt;
with Osint;    use Osint;
with Table;
with Targparm; use Targparm;
with Uname;    use Uname;
with Widechar; use Widechar;
 
with GNAT.HTable;
 
package body Fname.UF is
 
   --------------------------------------------------------
   -- Declarations for Handling Source_File_Name pragmas --
   --------------------------------------------------------
 
   type SFN_Entry is record
      U     : Unit_Name_Type; -- Unit name
      F     : File_Name_Type; -- Spec/Body file name
      Index : Nat;            -- Index from SFN pragma (0 if none)
   end record;
   --  Record single Unit_Name type call to Set_File_Name
 
   package SFN_Table is new Table.Table (
     Table_Component_Type => SFN_Entry,
     Table_Index_Type     => Int,
     Table_Low_Bound      => 0,
     Table_Initial        => Alloc.SFN_Table_Initial,
     Table_Increment      => Alloc.SFN_Table_Increment,
     Table_Name           => "SFN_Table");
   --  Table recording all Unit_Name calls to Set_File_Name
 
   type SFN_Header_Num is range 0 .. 100;
 
   function SFN_Hash (F : Unit_Name_Type) return SFN_Header_Num;
   --  Compute hash index for use by Simple_HTable
 
   No_Entry : constant Int := -1;
   --  Signals no entry in following table
 
   package SFN_HTable is new GNAT.HTable.Simple_HTable (
     Header_Num => SFN_Header_Num,
     Element    => Int,
     No_Element => No_Entry,
     Key        => Unit_Name_Type,
     Hash       => SFN_Hash,
     Equal      => "=");
   --  Hash table allowing rapid access to SFN_Table, the element value
   --  is an index into this table.
 
   type SFN_Pattern_Entry is record
      Pat : String_Ptr;   -- File name pattern (with asterisk in it)
      Typ : Character;    -- 'S'/'B'/'U' for spec/body/subunit
      Dot : String_Ptr;   -- Dot_Separator string
      Cas : Casing_Type;  -- Upper/Lower/Mixed
   end record;
   --  Records single call to Set_File_Name_Patterm
 
   package SFN_Patterns is new Table.Table (
     Table_Component_Type => SFN_Pattern_Entry,
     Table_Index_Type     => Int,
     Table_Low_Bound      => 1,
     Table_Initial        => 10,
     Table_Increment      => 100,
     Table_Name           => "SFN_Patterns");
   --  Table recording all calls to Set_File_Name_Pattern. Note that the
   --  first two entries are set to represent the standard GNAT rules
   --  for file naming.
 
   -----------------------
   -- File_Name_Of_Body --
   -----------------------
 
   function File_Name_Of_Body (Name : Name_Id) return File_Name_Type is
   begin
      Get_Name_String (Name);
      Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "%b";
      Name_Len := Name_Len + 2;
      return Get_File_Name (Name_Enter, Subunit => False);
   end File_Name_Of_Body;
 
   -----------------------
   -- File_Name_Of_Spec --
   -----------------------
 
   function File_Name_Of_Spec (Name : Name_Id) return File_Name_Type is
   begin
      Get_Name_String (Name);
      Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "%s";
      Name_Len := Name_Len + 2;
      return Get_File_Name (Name_Enter, Subunit => False);
   end File_Name_Of_Spec;
 
   ----------------------------
   -- Get_Expected_Unit_Type --
   ----------------------------
 
   function Get_Expected_Unit_Type
     (Fname : File_Name_Type) return Expected_Unit_Type
   is
   begin
      --  In syntax checking only mode or in multiple unit per file mode,
      --  there can be more than one unit in a file, so the file name is
      --  not a useful guide to the nature of the unit.
 
      if Operating_Mode = Check_Syntax
        or else Multiple_Unit_Index /= 0
      then
         return Unknown;
      end if;
 
      --  Search the file mapping table, if we find an entry for this
      --  file we know whether it is a spec or a body.
 
      for J in SFN_Table.First .. SFN_Table.Last loop
         if Fname = SFN_Table.Table (J).F then
            if Is_Body_Name (SFN_Table.Table (J).U) then
               return Expect_Body;
            else
               return Expect_Spec;
            end if;
         end if;
      end loop;
 
      --  If no entry in file naming table, assume .ads/.adb for spec/body
      --  and return unknown if we have neither of these two cases.
 
      Get_Name_String (Fname);
 
      if Name_Len > 4 then
         if Name_Buffer (Name_Len - 3 .. Name_Len) = ".ads" then
            return Expect_Spec;
         elsif Name_Buffer (Name_Len - 3 .. Name_Len) = ".adb" then
            return Expect_Body;
         end if;
      end if;
 
      return Unknown;
   end Get_Expected_Unit_Type;
 
   -------------------
   -- Get_File_Name --
   -------------------
 
   function Get_File_Name
     (Uname    : Unit_Name_Type;
      Subunit  : Boolean;
      May_Fail : Boolean := False) return File_Name_Type
   is
      Unit_Char : Character;
      --  Set to 's' or 'b' for spec or body or to 'u' for a subunit
 
      Unit_Char_Search : Character;
      --  Same as Unit_Char, except that in the case of 'u' for a subunit,
      --  we set Unit_Char_Search to 'b' if we do not find a subunit match.
 
      N : Int;
 
      Pname : File_Name_Type := No_File;
      Fname : File_Name_Type := No_File;
      --  Path name and File name for mapping
 
   begin
      --  Null or error name means that some previous error occurred
      --  This is an unrecoverable error, so signal it.
 
      if Uname in Error_Unit_Name_Or_No_Unit_Name then
         raise Unrecoverable_Error;
      end if;
 
      --  Look in the map from unit names to file names
 
      Fname := Mapped_File_Name (Uname);
 
      --  If the unit name is already mapped, return the corresponding
      --  file name from the map.
 
      if Fname /= No_File then
         return Fname;
      end if;
 
      --  If there is a specific SFN pragma, return the corresponding file name
 
      N := SFN_HTable.Get (Uname);
 
      if N /= No_Entry then
         return SFN_Table.Table (N).F;
      end if;
 
      --  Here for the case where the name was not found in the table
 
      Get_Decoded_Name_String (Uname);
 
      --  A special fudge, normally we don't have operator symbols present,
      --  since it is always an error to do so. However, if we do, at this
      --  stage it has a leading double quote.
 
      --  What we do in this case is to go back to the undecoded name, which
      --  is of the form, for example:
 
      --    Oand%s
 
      --  and build a file name that looks like:
 
      --    _and_.ads
 
      --  which is bit peculiar, but we keep it that way. This means that
      --  we avoid bombs due to writing a bad file name, and w get expected
      --  error processing downstream, e.g. a compilation following gnatchop.
 
      if Name_Buffer (1) = '"' then
         Get_Name_String (Uname);
         Name_Len := Name_Len + 1;
         Name_Buffer (Name_Len)     := Name_Buffer (Name_Len - 1);
         Name_Buffer (Name_Len - 1) := Name_Buffer (Name_Len - 2);
         Name_Buffer (Name_Len - 2) := '_';
         Name_Buffer (1)            := '_';
      end if;
 
      --  Deal with spec or body suffix
 
      Unit_Char := Name_Buffer (Name_Len);
      pragma Assert (Unit_Char = 'b' or else Unit_Char = 's');
      pragma Assert (Name_Len >= 3 and then Name_Buffer (Name_Len - 1) = '%');
      Name_Len := Name_Len - 2;
 
      if Subunit then
         Unit_Char := 'u';
      end if;
 
      --  Now we need to find the proper translation of the name
 
      declare
         Uname : constant String (1 .. Name_Len) :=
                   Name_Buffer (1 .. Name_Len);
 
         Pent : Nat;
         Plen : Natural;
         Fnam : File_Name_Type := No_File;
         J    : Natural;
         Dot  : String_Ptr;
         Dotl : Natural;
 
         Is_Predef : Boolean;
         --  Set True for predefined file
 
         function C (N : Natural) return Character;
         --  Return N'th character of pattern
 
         function C (N : Natural) return Character is
         begin
            return SFN_Patterns.Table (Pent).Pat (N);
         end C;
 
      --  Start of search through pattern table
 
      begin
         --  Search pattern table to find a matching entry. In the general
         --  case we do two complete searches. The first time through we
         --  stop only if a matching file is found, the second time through
         --  we accept the first match regardless. Note that there will
         --  always be a match the second time around, because of the
         --  default entries at the end of the table.
 
         for No_File_Check in False .. True loop
            Unit_Char_Search := Unit_Char;
 
         <<Repeat_Search>>
         --  The search is repeated with Unit_Char_Search set to b, if an
         --  initial search for the subunit case fails to find any match.
 
            Pent := SFN_Patterns.First;
            while Pent <= SFN_Patterns.Last loop
               if SFN_Patterns.Table (Pent).Typ = Unit_Char_Search then
                  Name_Len := 0;
 
                  --  Determine if we have a predefined file name
 
                  Name_Len := Uname'Length;
                  Name_Buffer (1 .. Name_Len) := Uname;
                  Is_Predef :=
                    Is_Predefined_File_Name (Renamings_Included => True);
 
                  --  Found a match, execute the pattern
 
                  Name_Len := Uname'Length;
                  Name_Buffer (1 .. Name_Len) := Uname;
 
                  --  Apply casing, except that we do not do this for the case
                  --  of a predefined library file. For the latter, we always
                  --  use the all lower case name, regardless of the setting.
 
                  if not Is_Predef then
                     Set_Casing (SFN_Patterns.Table (Pent).Cas);
                  end if;
 
                  --  If dot translation required do it
 
                  Dot  := SFN_Patterns.Table (Pent).Dot;
                  Dotl := Dot.all'Length;
 
                  if Dot.all /= "." then
                     J := 1;
 
                     while J <= Name_Len loop
                        if Name_Buffer (J) = '.' then
 
                           if Dotl = 1 then
                              Name_Buffer (J) := Dot (Dot'First);
 
                           else
                              Name_Buffer (J + Dotl .. Name_Len + Dotl - 1) :=
                                Name_Buffer (J + 1 .. Name_Len);
                              Name_Buffer (J .. J + Dotl - 1) := Dot.all;
                              Name_Len := Name_Len + Dotl - 1;
                           end if;
 
                           J := J + Dotl;
 
                        --  Skip past wide char sequences to avoid messing
                        --  with dot characters that are part of a sequence.
 
                        elsif Name_Buffer (J) = ASCII.ESC
                          or else (Upper_Half_Encoding
                                    and then
                                      Name_Buffer (J) in Upper_Half_Character)
                        then
                           Skip_Wide (Name_Buffer, J);
                        else
                           J := J + 1;
                        end if;
                     end loop;
                  end if;
 
                  --  Here move result to right if preinsertion before *
 
                  Plen := SFN_Patterns.Table (Pent).Pat'Length;
                  for K in 1 .. Plen loop
                     if C (K) = '*' then
                        if K /= 1 then
                           Name_Buffer (1 + K - 1 .. Name_Len + K - 1) :=
                             Name_Buffer (1 .. Name_Len);
 
                           for L in 1 .. K - 1 loop
                              Name_Buffer (L) := C (L);
                           end loop;
 
                           Name_Len := Name_Len + K - 1;
                        end if;
 
                        for L in K + 1 .. Plen loop
                           Name_Len := Name_Len + 1;
                           Name_Buffer (Name_Len) := C (L);
                        end loop;
 
                        exit;
                     end if;
                  end loop;
 
                  --  Execute possible crunch on constructed name. The krunch
                  --  operation excludes any extension that may be present.
 
                  J := Name_Len;
                  while J > 1 loop
                     exit when Name_Buffer (J) = '.';
                     J := J - 1;
                  end loop;
 
                  --  Case of extension present
 
                  if J > 1 then
                     declare
                        Ext : constant String := Name_Buffer (J .. Name_Len);
 
                     begin
                        --  Remove extension
 
                        Name_Len := J - 1;
 
                        --  Krunch what's left
 
                        Krunch
                          (Name_Buffer,
                           Name_Len,
                           Integer (Maximum_File_Name_Length),
                           Debug_Flag_4,
                           OpenVMS_On_Target);
 
                        --  Replace extension
 
                        Name_Buffer
                          (Name_Len + 1 .. Name_Len + Ext'Length) := Ext;
                        Name_Len := Name_Len + Ext'Length;
                     end;
 
                  --  Case of no extension present, straight krunch on
                  --  the entire file name.
 
                  else
                     Krunch
                       (Name_Buffer,
                        Name_Len,
                        Integer (Maximum_File_Name_Length),
                        Debug_Flag_4);
                  end if;
 
                  Fnam := Name_Find;
 
                  --  If we are in the second search of the table, we accept
                  --  the file name without checking, because we know that
                  --  the file does not exist, except when May_Fail is True,
                  --  in which case we return No_File.
 
                  if No_File_Check then
                     if May_Fail then
                        return No_File;
                     else
                        return Fnam;
                     end if;
 
                  --  Otherwise we check if the file exists
 
                  else
                     Pname := Find_File (Fnam, Source);
 
                     --  If it does exist, we add it to the mappings and
                     --  return the file name.
 
                     if Pname /= No_File then
 
                        --  Add to mapping, so that we don't do another
                        --  path search in Find_File for this file name
                        --  and, if we use a mapping file, we are ready
                        --  to update it at the end of this compilation
                        --  for the benefit of other compilation processes.
 
                        Add_To_File_Map (Get_File_Name.Uname, Fnam, Pname);
                        return Fnam;
 
                     --  If there are only two entries, they are those of
                     --  the default GNAT naming scheme. The file does
                     --  not exist, but there is no point doing the
                     --  second search, because we will end up with the
                     --  same file name. Just return the file name.
 
                     elsif SFN_Patterns.Last = 2 then
                        return Fnam;
 
                     --  The file does not exist, but there may be other
                     --  naming scheme. Keep on searching.
 
                     else
                        Fnam := No_File;
                     end if;
                  end if;
               end if;
 
               Pent := Pent + 1;
            end loop;
 
            --  If search failed, and was for a subunit, repeat the search
            --  with Unit_Char_Search reset to 'b', since in the normal case
            --  we simply treat subunits as bodies.
 
            if Fnam = No_File and then Unit_Char_Search = 'u' then
               Unit_Char_Search := 'b';
               goto Repeat_Search;
            end if;
 
            --  Repeat entire search in No_File_Check mode if necessary
 
         end loop;
 
         --  Something is wrong if search fails completely, since the
         --  default entries should catch all possibilities at this stage.
 
         raise Program_Error;
      end;
   end Get_File_Name;
 
   --------------------
   -- Get_Unit_Index --
   --------------------
 
   function Get_Unit_Index (Uname : Unit_Name_Type) return Nat is
      N : constant Int := SFN_HTable.Get (Uname);
   begin
      if N /= No_Entry then
         return SFN_Table.Table (N).Index;
      else
         return 0;
      end if;
   end Get_Unit_Index;
 
   ----------------
   -- Initialize --
   ----------------
 
   procedure Initialize is
   begin
      SFN_Table.Init;
      SFN_Patterns.Init;
 
      --  Add default entries to SFN_Patterns.Table to represent the
      --  standard default GNAT rules for file name translation.
 
      SFN_Patterns.Append (New_Val =>
        (Pat => new String'("*.ads"),
         Typ => 's',
         Dot => new String'("-"),
         Cas => All_Lower_Case));
 
      SFN_Patterns.Append (New_Val =>
        (Pat => new String'("*.adb"),
         Typ => 'b',
         Dot => new String'("-"),
         Cas => All_Lower_Case));
   end Initialize;
 
   ----------
   -- Lock --
   ----------
 
   procedure Lock is
   begin
      SFN_Table.Locked := True;
      SFN_Table.Release;
   end Lock;
 
   -------------------
   -- Set_File_Name --
   -------------------
 
   procedure Set_File_Name
     (U     : Unit_Name_Type;
      F     : File_Name_Type;
      Index : Nat)
   is
   begin
      SFN_Table.Increment_Last;
      SFN_Table.Table (SFN_Table.Last) := (U, F, Index);
      SFN_HTable.Set (U, SFN_Table.Last);
   end Set_File_Name;
 
   ---------------------------
   -- Set_File_Name_Pattern --
   ---------------------------
 
   procedure Set_File_Name_Pattern
     (Pat : String_Ptr;
      Typ : Character;
      Dot : String_Ptr;
      Cas : Casing_Type)
   is
      L : constant Nat := SFN_Patterns.Last;
 
   begin
      SFN_Patterns.Increment_Last;
 
      --  Move up the last two entries (the default ones) and then
      --  put the new entry into the table just before them (we
      --  always have the default entries be the last ones).
 
      SFN_Patterns.Table (L + 1) := SFN_Patterns.Table (L);
      SFN_Patterns.Table (L)     := SFN_Patterns.Table (L - 1);
      SFN_Patterns.Table (L - 1) := (Pat, Typ, Dot, Cas);
   end Set_File_Name_Pattern;
 
   --------------
   -- SFN_Hash --
   --------------
 
   function SFN_Hash (F : Unit_Name_Type) return SFN_Header_Num is
   begin
      return SFN_Header_Num (Int (F) rem SFN_Header_Num'Range_Length);
   end SFN_Hash;
 
begin
 
   --  We call the initialization routine from the package body, so that
   --  Fname.Init only needs to be called explicitly to reinitialize.
 
   Fname.UF.Initialize;
end Fname.UF;