-- --
-- B o d y --
-- --
--- $Revision: 1.6 $
--- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
+-- 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 COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- 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. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- 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 Targparm; use Targparm;
+with Uname; use Uname;
with Widechar; use Widechar;
with GNAT.HTable;
--------------------------------------------------------
type SFN_Entry is record
- U : Unit_Name_Type; -- Unit name
- F : File_Name_Type; -- Spec/Body file name
+ 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
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)
- return File_Name_Type
+ (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
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 occured
+ -- Null or error name means that some previous error occurred
-- This is an unrecoverable error, so signal it.
- if Uname <= Error_Name then
+ 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
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
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;
- Set_Casing (SFN_Patterns.Table (Pent).Cas);
+
+ -- 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
(Name_Buffer,
Name_Len,
Integer (Maximum_File_Name_Length),
- Debug_Flag_4);
+ Debug_Flag_4,
+ OpenVMS_On_Target);
-- Replace extension
Debug_Flag_4);
end if;
- Fnam := File_Name_Type (Name_Find);
+ Fnam := 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 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 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 then
+ if May_Fail then
+ return No_File;
+ else
+ return Fnam;
+ end if;
- if No_File_Check or else SFN_Patterns.Last = 2 then
- return Fnam;
+ -- Otherwise we check if the file exists
- -- Check if file exists and if so, return the entry
+ else
+ Pname := Find_File (Fnam, Source);
- elsif Find_File (Fnam, Source) /= No_File then
- return Fnam;
+ -- If it does exist, we add it to the mappings and
+ -- return the file name.
- -- This entry does not match after all, because this is
- -- the first search loop, and the file does not exist.
+ if Pname /= No_File then
- else
- Fnam := No_File;
+ -- 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;
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 --
----------------
-- Set_File_Name --
-------------------
- procedure Set_File_Name (U : Unit_Name_Type; F : File_Name_Type) is
+ 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);
+ SFN_Table.Table (SFN_Table.Last) := (U, F, Index);
SFN_HTable.Set (U, SFN_Table.Last);
end Set_File_Name;
Cas : Casing_Type)
is
L : constant Nat := SFN_Patterns.Last;
+
begin
SFN_Patterns.Increment_Last;
OSDN Git Service
