X-Git-Url: https://oss.titaniummirror.com/gitweb/?a=blobdiff_plain;f=gcc%2Fada%2Ffname-uf.adb;fp=gcc%2Fada%2Ffname-uf.adb;h=0000000000000000000000000000000000000000;hb=6fed43773c9b0ce596dca5686f37ac3fc0fa11c0;hp=10e73dbe4639306443a6033b121909529c629bd0;hpb=27b11d56b743098deb193d510b337ba22dc52e5c;p=msp430-gcc.git diff --git a/gcc/ada/fname-uf.adb b/gcc/ada/fname-uf.adb deleted file mode 100644 index 10e73dbe..00000000 --- a/gcc/ada/fname-uf.adb +++ /dev/null @@ -1,517 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- F N A M E . U F -- --- -- --- B o d y -- --- -- --- $Revision: 1.4.10.1 $ --- -- --- Copyright (C) 1992-2001, 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, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, 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 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 - 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_File_Name -- - ------------------- - - function Get_File_Name - (Uname : Unit_Name_Type; - Subunit : Boolean) - 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; - - 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; - - <> - -- 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; - - -- Found a match, execute the pattern - - Name_Len := Uname'Length; - Name_Buffer (1 .. Name_Len) := Uname; - Set_Casing (SFN_Patterns.Table (Pent).Cas); - - -- 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 first search of the table, then - -- we check if the file is present, and only accept - -- the entry if it is indeed present. For the second - -- search, we accept the entry without this check. - - -- If we only have two entries in the table, then there - -- is no point in seeing if the file exists, since we - -- will end up accepting it anyway on the second search, - -- so just quit and accept it now to save time. - - if No_File_Check or else SFN_Patterns.Last = 2 then - return Fnam; - - -- Check if file exists and if so, return the entry - - else - Pname := Find_File (Fnam, Source); - - -- Check if file exists and if so, return the entry - - if Pname /= No_File then - - -- Add to mapping, so that we don't do another - -- path search in Find_File for this file name - - Add_To_File_Map (Get_File_Name.Uname, Fnam, Pname); - return Fnam; - - -- This entry does not match after all, because this is - -- the first search loop, and the file does not exist. - - 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; - - ---------------- - -- 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) is - begin - SFN_Table.Increment_Last; - SFN_Table.Table (SFN_Table.Last) := (U, F); - 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;