diff options
Diffstat (limited to 'gcc-4.4.0/gcc/ada/fname-uf.adb')
| -rw-r--r-- | gcc-4.4.0/gcc/ada/fname-uf.adb | 612 |
1 files changed, 612 insertions, 0 deletions
diff --git a/gcc-4.4.0/gcc/ada/fname-uf.adb b/gcc-4.4.0/gcc/ada/fname-uf.adb new file mode 100644 index 000000000..8f4e66f85 --- /dev/null +++ b/gcc-4.4.0/gcc/ada/fname-uf.adb @@ -0,0 +1,612 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; |