blob: cfaf7c4c7c076d3aadf38b277d24578d542ac176 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- F N A M E . U F --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2021, 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;
<<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
-- 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;