diff options
Diffstat (limited to 'gcc-4.2.1/gcc/ada/fname-uf.adb')
| -rw-r--r-- | gcc-4.2.1/gcc/ada/fname-uf.adb | 612 |
1 files changed, 0 insertions, 612 deletions
diff --git a/gcc-4.2.1/gcc/ada/fname-uf.adb b/gcc-4.2.1/gcc/ada/fname-uf.adb deleted file mode 100644 index 35f2bd6ba..000000000 --- a/gcc-4.2.1/gcc/ada/fname-uf.adb +++ /dev/null @@ -1,612 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- F N A M E . U F -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2004, 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 2, 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 COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- 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 Namet; use Namet; -with Opt; use Opt; -with Osint; use Osint; -with Table; -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 <= Error_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); - - -- 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 := File_Name_Type (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; |