------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- F N A M E . U F -- -- -- -- B o d y -- -- -- -- -- -- 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; <<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; -- 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 second search of the table, we accept -- the file name without checking, because we know that -- the file does not exist. if No_File_Check then return Fnam; -- 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; ---------------- -- 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;