------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- F N A M E . U F -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2022, 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 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 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 we 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; <> -- 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 -- Determine if we have a predefined file name Is_Predef := Is_Predefined_Unit_Name (Uname, 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 := 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, or No_File if May_Fail is True. elsif SFN_Patterns.Last = 2 then if May_Fail then return No_File; else return Fnam; end if; -- 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.Release; SFN_Table.Locked := True; 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) mod 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;