-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, 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. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
with GNAT.HTable;
+with Alloc;
+with Debug;
with Fmap; use Fmap;
with Gnatvsn; use Gnatvsn;
with Hostparm;
-- that are used to locate the actual file and for the purpose of message
-- construction. These names need not be accessible by Name_Find, and can
-- be therefore created by using routine Name_Enter. The files in question
- -- are file names with a prefix directory (ie the files not in the current
- -- directory). File names without a prefix directory are entered with
- -- Name_Find because special values might be attached to the various Info
- -- fields of the corresponding name table entry.
+ -- are file names with a prefix directory (i.e., the files not in the
+ -- current directory). File names without a prefix directory are entered
+ -- with Name_Find because special values might be attached to the various
+ -- Info fields of the corresponding name table entry.
-----------------------
-- Local Subprograms --
-- Appends Suffix to Name and returns the new name
function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type;
- -- Convert OS format time to GNAT format time stamp
+ -- Convert OS format time to GNAT format time stamp. If T is Invalid_Time,
+ -- then returns Empty_Time_Stamp.
function Executable_Prefix return String_Ptr;
-- Returns the name of the root directory where the executable is stored.
-- "/foo/bar/". Return "" if location is not recognized as described above.
function Update_Path (Path : String_Ptr) return String_Ptr;
- -- Update the specified path to replace the prefix with the location
- -- where GNAT is installed. See the file prefix.c in GCC for details.
-
- function Locate_File
- (N : File_Name_Type;
- T : File_Type;
- Dir : Natural;
- Name : String) return File_Name_Type;
+ -- Update the specified path to replace the prefix with the location where
+ -- GNAT is installed. See the file prefix.c in GCC for details.
+
+ procedure Locate_File
+ (N : File_Name_Type;
+ T : File_Type;
+ Dir : Natural;
+ Name : String;
+ Found : out File_Name_Type;
+ Attr : access File_Attributes);
-- See if the file N whose name is Name exists in directory Dir. Dir is an
-- index into the Lib_Search_Directories table if T = Library. Otherwise
-- if T = Source, Dir is an index into the Src_Search_Directories table.
-- Returns the File_Name_Type of the full file name if file found, or
-- No_File if not found.
+ --
+ -- On exit, Found is set to the file that was found, and Attr to a cache of
+ -- its attributes (at least those that have been computed so far). Reusing
+ -- the cache will save some system calls.
+ --
+ -- Attr is always reset in this call to Unknown_Attributes, even in case of
+ -- failure
+
+ procedure Find_File
+ (N : File_Name_Type;
+ T : File_Type;
+ Found : out File_Name_Type;
+ Attr : access File_Attributes);
+ -- A version of Find_File that also returns a cache of the file attributes
+ -- for later reuse
+
+ procedure Smart_Find_File
+ (N : File_Name_Type;
+ T : File_Type;
+ Found : out File_Name_Type;
+ Attr : out File_Attributes);
+ -- A version of Smart_Find_File that also returns a cache of the file
+ -- attributes for later reuse
function C_String_Length (S : Address) return Integer;
-- Returns length of a C string (zero for a null address)
Path_Len : Integer) return String_Access;
-- Converts a C String to an Ada String. Are we doing this to avoid withing
-- Interfaces.C.Strings ???
+ -- Caller must free result.
+
+ function Include_Dir_Default_Prefix return String_Access;
+ -- Same as exported version, except returns a String_Access
------------------------------
-- Other Local Declarations --
-- End of line character
Number_File_Names : Int := 0;
- -- Number of file names founde on command line and placed in File_Names
+ -- Number of file names found on command line and placed in File_Names
Look_In_Primary_Directory_For_Current_Main : Boolean := False;
-- When this variable is True, Find_File only looks in Primary_Directory
-- for the Current_Main file. This variable is always set to True for the
- -- compiler. It is also True for gnatmake, when the soucr name given on
+ -- compiler. It is also True for gnatmake, when the source name given on
-- the command line has directory information.
Current_Full_Source_Name : File_Name_Type := No_File;
-- latest source, library and object files opened by Read_Source_File and
-- Read_Library_Info.
+ package File_Name_Chars is new Table.Table (
+ Table_Component_Type => Character,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 1,
+ Table_Initial => Alloc.File_Name_Chars_Initial,
+ Table_Increment => Alloc.File_Name_Chars_Increment,
+ Table_Name => "File_Name_Chars");
+ -- Table to store text to be printed by Dump_Source_File_Names
+
+ The_Include_Dir_Default_Prefix : String_Access := null;
+ -- Value returned by Include_Dir_Default_Prefix. We don't initialize it
+ -- here, because that causes an elaboration cycle with Sdefault; we
+ -- initialize it lazily instead.
+
------------------
-- Search Paths --
------------------
-- The file hash table is provided to free the programmer from any
-- efficiency concern when retrieving full file names or time stamps of
-- source files. If the programmer calls Source_File_Data (Cache => True)
- -- he is guaranteed that the price to retrieve the full name (ie with
+ -- he is guaranteed that the price to retrieve the full name (i.e. with
-- directory info) or time stamp of the file will be payed only once, the
-- first time the full name is actually searched (or the first time the
-- time stamp is actually retrieved). This is achieved by employing a hash
function File_Hash (F : File_Name_Type) return File_Hash_Num;
-- Compute hash index for use by Simple_HTable
- package File_Name_Hash_Table is new GNAT.HTable.Simple_HTable (
- Header_Num => File_Hash_Num,
- Element => File_Name_Type,
- No_Element => No_File,
- Key => File_Name_Type,
- Hash => File_Hash,
- Equal => "=");
+ type File_Info_Cache is record
+ File : File_Name_Type;
+ Attr : aliased File_Attributes;
+ end record;
+
+ No_File_Info_Cache : constant File_Info_Cache :=
+ (No_File, Unknown_Attributes);
- package File_Stamp_Hash_Table is new GNAT.HTable.Simple_HTable (
+ package File_Name_Hash_Table is new GNAT.HTable.Simple_HTable (
Header_Num => File_Hash_Num,
- Element => Time_Stamp_Type,
- No_Element => Empty_Time_Stamp,
+ Element => File_Info_Cache,
+ No_Element => No_File_Info_Cache,
Key => File_Name_Type,
Hash => File_Hash,
Equal => "=");
--
-- HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\
-- GNAT\Standard Libraries
- -- Return an empty string on other systems
+ -- Return an empty string on other systems.
+ --
+ -- Note that this is an undocumented legacy feature, and that it
+ -- works only when using the default runtime library (i.e. no --RTS=
+ -- command line switch).
--------------------
-- Add_Search_Dir --
Ch : Character;
Status : Boolean;
- -- For the call to Close
+ pragma Warnings (Off, Status);
+ -- For the call to Close where status is ignored
begin
File_FD := Open_Read (Buffer'Address, Binary);
procedure Strncpy (X : Address; Y : Address; Length : Integer);
pragma Import (C, Strncpy, "strncpy");
+ procedure C_Free (Str : Address);
+ pragma Import (C, C_Free, "free");
+
Result_Ptr : Address;
Result_Length : Integer;
Out_String : String_Ptr;
Out_String := new String (1 .. Result_Length);
Strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
+
+ C_Free (Result_Ptr);
+
return Out_String;
end Get_Libraries_From_Registry;
Fail ("missing library directory name");
end if;
- Lib_Search_Directories.Increment_Last;
- Lib_Search_Directories.Table (Lib_Search_Directories.Last) :=
- Normalize_Directory_Name (Dir);
+ declare
+ Norm : String_Ptr := Normalize_Directory_Name (Dir);
+
+ begin
+ -- Do nothing if the directory is already in the list. This saves
+ -- system calls and avoid unneeded work
+
+ for D in Lib_Search_Directories.First ..
+ Lib_Search_Directories.Last
+ loop
+ if Lib_Search_Directories.Table (D).all = Norm.all then
+ Free (Norm);
+ return;
+ end if;
+ end loop;
+
+ Lib_Search_Directories.Increment_Last;
+ Lib_Search_Directories.Table (Lib_Search_Directories.Last) := Norm;
+ end;
end Add_Lib_Search_Dir;
---------------------
Fdesc := Create_File (Name_Buffer'Address, Fmode);
if Fdesc = Invalid_FD then
- Fail ("Cannot create: ", Name_Buffer (1 .. Name_Len));
+ Fail ("Cannot create: " & Name_Buffer (1 .. Name_Len));
end if;
end Create_File_And_Check;
end if;
end Dir_In_Src_Search_Path;
+ ----------------------------
+ -- Dump_Source_File_Names --
+ ----------------------------
+
+ procedure Dump_Source_File_Names is
+ subtype Rng is Int range File_Name_Chars.First .. File_Name_Chars.Last;
+ begin
+ Write_Str (String (File_Name_Chars.Table (Rng)));
+ end Dump_Source_File_Names;
+
---------------------
-- Executable_Name --
---------------------
- function Executable_Name (Name : File_Name_Type) return File_Name_Type is
+ function Executable_Name
+ (Name : File_Name_Type;
+ Only_If_No_Suffix : Boolean := False) return File_Name_Type
+ is
Exec_Suffix : String_Access;
+ Add_Suffix : Boolean;
begin
if Name = No_File then
Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len));
end if;
- Get_Name_String (Name);
-
if Exec_Suffix'Length /= 0 then
- declare
- Buffer : String := Name_Buffer (1 .. Name_Len);
-
- begin
- -- Get the file name in canonical case to accept as is names
- -- ending with ".EXE" on VMS and Windows.
-
- Canonical_Case_File_Name (Buffer);
+ Get_Name_String (Name);
+
+ Add_Suffix := True;
+ if Only_If_No_Suffix then
+ for J in reverse 1 .. Name_Len loop
+ if Name_Buffer (J) = '.' then
+ Add_Suffix := False;
+ exit;
+
+ elsif Name_Buffer (J) = '/' or else
+ Name_Buffer (J) = Directory_Separator
+ then
+ exit;
+ end if;
+ end loop;
+ end if;
- -- If Executable does not end with the executable suffix, add it
+ if Add_Suffix then
+ declare
+ Buffer : String := Name_Buffer (1 .. Name_Len);
- if Buffer'Length <= Exec_Suffix'Length
- or else
- Buffer (Buffer'Last - Exec_Suffix'Length + 1 .. Buffer'Last)
- /= Exec_Suffix.all
- then
- Name_Buffer (Name_Len + 1 .. Name_Len + Exec_Suffix'Length) :=
- Exec_Suffix.all;
- Name_Len := Name_Len + Exec_Suffix'Length;
- Free (Exec_Suffix);
- return Name_Find;
- end if;
- end;
+ begin
+ -- Get the file name in canonical case to accept as is names
+ -- ending with ".EXE" on VMS and Windows.
+
+ Canonical_Case_File_Name (Buffer);
+
+ -- If Executable does not end with the executable suffix, add
+ -- it.
+
+ if Buffer'Length <= Exec_Suffix'Length
+ or else
+ Buffer (Buffer'Last - Exec_Suffix'Length + 1 .. Buffer'Last)
+ /= Exec_Suffix.all
+ then
+ Name_Buffer
+ (Name_Len + 1 .. Name_Len + Exec_Suffix'Length) :=
+ Exec_Suffix.all;
+ Name_Len := Name_Len + Exec_Suffix'Length;
+ Free (Exec_Suffix);
+ return Name_Find;
+ end if;
+ end;
+ end if;
end if;
Free (Exec_Suffix);
return Name;
end Executable_Name;
- function Executable_Name (Name : String) return String is
+ function Executable_Name
+ (Name : String;
+ Only_If_No_Suffix : Boolean := False) return String
+ is
Exec_Suffix : String_Access;
+ Add_Suffix : Boolean;
Canonical_Name : String := Name;
begin
Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len));
end if;
- declare
- Suffix : constant String := Exec_Suffix.all;
-
- begin
+ if Exec_Suffix'Length = 0 then
Free (Exec_Suffix);
- Canonical_Case_File_Name (Canonical_Name);
+ return Name;
- if Suffix'Length /= 0
- and then
- (Canonical_Name'Length <= Suffix'Length
+ else
+ declare
+ Suffix : constant String := Exec_Suffix.all;
+
+ begin
+ Free (Exec_Suffix);
+ Canonical_Case_File_Name (Canonical_Name);
+
+ Add_Suffix := True;
+ if Only_If_No_Suffix then
+ for J in reverse Canonical_Name'Range loop
+ if Canonical_Name (J) = '.' then
+ Add_Suffix := False;
+ exit;
+
+ elsif Canonical_Name (J) = '/' or else
+ Canonical_Name (J) = Directory_Separator
+ then
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ if Add_Suffix and then
+ (Canonical_Name'Length <= Suffix'Length
or else Canonical_Name (Canonical_Name'Last - Suffix'Length + 1
- .. Canonical_Name'Last) /= Suffix)
- then
- declare
- Result : String (1 .. Name'Length + Suffix'Length);
- begin
- Result (1 .. Name'Length) := Name;
- Result (Name'Length + 1 .. Result'Last) := Suffix;
- return Result;
- end;
- else
- return Name;
- end if;
- end;
+ .. Canonical_Name'Last) /= Suffix)
+ then
+ declare
+ Result : String (1 .. Name'Length + Suffix'Length);
+ begin
+ Result (1 .. Name'Length) := Name;
+ Result (Name'Length + 1 .. Result'Last) := Suffix;
+ return Result;
+ end;
+ else
+ return Name;
+ end if;
+ end;
+ end if;
end Executable_Name;
-----------------------
function Executable_Prefix return String_Ptr is
function Get_Install_Dir (Exec : String) return String_Ptr;
- -- S is the executable name preceeded by the absolute or relative
+ -- S is the executable name preceded by the absolute or relative
-- path, e.g. "c:\usr\bin\gcc.exe" or "..\bin\gcc".
---------------------
-- If we come here, the user has typed the executable name with no
-- directory prefix.
- return Get_Install_Dir
- (System.OS_Lib.Locate_Exec_On_Path (Exec_Name.all).all);
+ return Get_Install_Dir (Locate_Exec_On_Path (Exec_Name.all).all);
end Executable_Prefix;
------------------
-- Fail --
----------
- procedure Fail (S1 : String; S2 : String := ""; S3 : String := "") is
+ procedure Fail (S : String) is
begin
-- We use Output in case there is a special output set up.
-- In this case Set_Standard_Error will have no immediate effect.
Set_Standard_Error;
Osint.Write_Program_Name;
Write_Str (": ");
- Write_Str (S1);
- Write_Str (S2);
- Write_Str (S3);
+ Write_Str (S);
Write_Eol;
Exit_Program (E_Fatal);
return File_Hash_Num (Int (F) rem File_Hash_Num'Range_Length);
end File_Hash;
+ -----------------
+ -- File_Length --
+ -----------------
+
+ function File_Length
+ (Name : C_File_Name;
+ Attr : access File_Attributes) return Long_Integer
+ is
+ function Internal
+ (F : Integer;
+ N : C_File_Name;
+ A : System.Address) return Long_Integer;
+ pragma Import (C, Internal, "__gnat_file_length_attr");
+ begin
+ return Internal (-1, Name, Attr.all'Address);
+ end File_Length;
+
+ ---------------------
+ -- File_Time_Stamp --
+ ---------------------
+
+ function File_Time_Stamp
+ (Name : C_File_Name;
+ Attr : access File_Attributes) return OS_Time
+ is
+ function Internal (N : C_File_Name; A : System.Address) return OS_Time;
+ pragma Import (C, Internal, "__gnat_file_time_name_attr");
+ begin
+ return Internal (Name, Attr.all'Address);
+ end File_Time_Stamp;
+
+ function File_Time_Stamp
+ (Name : Path_Name_Type;
+ Attr : access File_Attributes) return Time_Stamp_Type
+ is
+ begin
+ if Name = No_Path then
+ return Empty_Time_Stamp;
+ end if;
+
+ Get_Name_String (Name);
+ Name_Buffer (Name_Len + 1) := ASCII.NUL;
+ return OS_Time_To_GNAT_Time
+ (File_Time_Stamp (Name_Buffer'Address, Attr));
+ end File_Time_Stamp;
+
----------------
-- File_Stamp --
----------------
Get_Name_String (Name);
- if not Is_Regular_File (Name_Buffer (1 .. Name_Len)) then
- return Empty_Time_Stamp;
- else
- Name_Buffer (Name_Len + 1) := ASCII.NUL;
- return OS_Time_To_GNAT_Time (File_Time_Stamp (Name_Buffer));
- end if;
+ -- File_Time_Stamp will always return Invalid_Time if the file does
+ -- not exist, and OS_Time_To_GNAT_Time will convert this value to
+ -- Empty_Time_Stamp. Therefore we do not need to first test whether
+ -- the file actually exists, which saves a system call.
+
+ return OS_Time_To_GNAT_Time
+ (File_Time_Stamp (Name_Buffer (1 .. Name_Len)));
end File_Stamp;
function File_Stamp (Name : Path_Name_Type) return Time_Stamp_Type is
(N : File_Name_Type;
T : File_Type) return File_Name_Type
is
+ Attr : aliased File_Attributes;
+ Found : File_Name_Type;
+ begin
+ Find_File (N, T, Found, Attr'Access);
+ return Found;
+ end Find_File;
+
+ ---------------
+ -- Find_File --
+ ---------------
+
+ procedure Find_File
+ (N : File_Name_Type;
+ T : File_Type;
+ Found : out File_Name_Type;
+ Attr : access File_Attributes) is
begin
Get_Name_String (N);
begin
-- If we are looking for a config file, look only in the current
- -- directory, i.e. return input argument unchanged. Also look
- -- only in the current directory if we are looking for a .dg
- -- file (happens in -gnatD mode).
+ -- directory, i.e. return input argument unchanged. Also look only in
+ -- the curren directory if we are looking for a .dg file (happens in
+ -- -gnatD mode).
if T = Config
or else (Debug_Generated_Code
(Hostparm.OpenVMS and then
Name_Buffer (Name_Len - 2 .. Name_Len) = "_dg")))
then
- return N;
+ Found := N;
+ Attr.all := Unknown_Attributes;
+ return;
-- If we are trying to find the current main file just look in the
-- directory where the user said it was.
elsif Look_In_Primary_Directory_For_Current_Main
and then Current_Main = N
then
- return Locate_File (N, T, Primary_Directory, File_Name);
+ Locate_File (N, T, Primary_Directory, File_Name, Found, Attr);
+ return;
-- Otherwise do standard search for source file
-- return No_File, indicating the file is not a source.
if File = Error_File_Name then
- return No_File;
-
+ Found := No_File;
else
- return File;
+ Found := File;
end if;
+
+ Attr.all := Unknown_Attributes;
+ return;
end if;
-- First place to look is in the primary directory (i.e. the same
-- directory as the source) unless this has been disabled with -I-
if Opt.Look_In_Primary_Dir then
- File := Locate_File (N, T, Primary_Directory, File_Name);
+ Locate_File (N, T, Primary_Directory, File_Name, Found, Attr);
- if File /= No_File then
- return File;
+ if Found /= No_File then
+ return;
end if;
end if;
end if;
for D in Primary_Directory + 1 .. Last_Dir loop
- File := Locate_File (N, T, D, File_Name);
+ Locate_File (N, T, D, File_Name, Found, Attr);
- if File /= No_File then
- return File;
+ if Found /= No_File then
+ return;
end if;
end loop;
- return No_File;
+ Attr.all := Unknown_Attributes;
+ Found := No_File;
end if;
end;
end Find_File;
begin
Fill_Arg (Command_Name'Address, 0);
+ if Command_Name = "" then
+ Name_Len := 0;
+ return;
+ end if;
+
-- The program name might be specified by a full path name. However,
-- we don't want to print that all out in an error message, so the
-- path might need to be stripped away.
if Command_Name (Cindex2) in '0' .. '9' then
for J in reverse Cindex1 .. Cindex2 loop
- if Command_Name (J) = '.' or Command_Name (J) = ';' then
+ if Command_Name (J) = '.' or else Command_Name (J) = ';' then
Cindex2 := J - 1;
exit;
end if;
-- Full_Lib_File_Name --
------------------------
+ procedure Full_Lib_File_Name
+ (N : File_Name_Type;
+ Lib_File : out File_Name_Type;
+ Attr : out File_Attributes)
+ is
+ A : aliased File_Attributes;
+ begin
+ -- ??? seems we could use Smart_Find_File here
+ Find_File (N, Library, Lib_File, A'Access);
+ Attr := A;
+ end Full_Lib_File_Name;
+
+ ------------------------
+ -- Full_Lib_File_Name --
+ ------------------------
+
function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type is
+ Attr : File_Attributes;
+ File : File_Name_Type;
begin
- return Find_File (N, Library);
+ Full_Lib_File_Name (N, File, Attr);
+ return File;
end Full_Lib_File_Name;
----------------------------
return Smart_Find_File (N, Source);
end Full_Source_Name;
+ ----------------------
+ -- Full_Source_Name --
+ ----------------------
+
+ procedure Full_Source_Name
+ (N : File_Name_Type;
+ Full_File : out File_Name_Type;
+ Attr : access File_Attributes) is
+ begin
+ Smart_Find_File (N, Source, Full_File, Attr.all);
+ end Full_Source_Name;
+
-------------------
-- Get_Directory --
-------------------
-- Include_Dir_Default_Prefix --
--------------------------------
- function Include_Dir_Default_Prefix return String is
- Include_Dir : String_Access :=
- String_Access (Update_Path (Include_Dir_Default_Name));
-
+ function Include_Dir_Default_Prefix return String_Access is
begin
- if Include_Dir = null then
- return "";
-
- else
- declare
- Result : constant String := Include_Dir.all;
- begin
- Free (Include_Dir);
- return Result;
- end;
+ if The_Include_Dir_Default_Prefix = null then
+ The_Include_Dir_Default_Prefix :=
+ String_Access (Update_Path (Include_Dir_Default_Name));
end if;
+
+ return The_Include_Dir_Default_Prefix;
+ end Include_Dir_Default_Prefix;
+
+ function Include_Dir_Default_Prefix return String is
+ begin
+ return Include_Dir_Default_Prefix.all;
end Include_Dir_Default_Prefix;
----------------
Lib_Search_Directories.Table (Primary_Directory) := new String'("");
end Initialize;
+ ------------------
+ -- Is_Directory --
+ ------------------
+
+ function Is_Directory
+ (Name : C_File_Name; Attr : access File_Attributes) return Boolean
+ is
+ function Internal (N : C_File_Name; A : System.Address) return Integer;
+ pragma Import (C, Internal, "__gnat_is_directory_attr");
+ begin
+ return Internal (Name, Attr.all'Address) /= 0;
+ end Is_Directory;
+
----------------------------
-- Is_Directory_Separator --
----------------------------
return not Is_Writable_File (Name_Buffer (1 .. Name_Len));
end Is_Readonly_Library;
+ ------------------------
+ -- Is_Executable_File --
+ ------------------------
+
+ function Is_Executable_File
+ (Name : C_File_Name; Attr : access File_Attributes) return Boolean
+ is
+ function Internal (N : C_File_Name; A : System.Address) return Integer;
+ pragma Import (C, Internal, "__gnat_is_executable_file_attr");
+ begin
+ return Internal (Name, Attr.all'Address) /= 0;
+ end Is_Executable_File;
+
+ ----------------------
+ -- Is_Readable_File --
+ ----------------------
+
+ function Is_Readable_File
+ (Name : C_File_Name; Attr : access File_Attributes) return Boolean
+ is
+ function Internal (N : C_File_Name; A : System.Address) return Integer;
+ pragma Import (C, Internal, "__gnat_is_readable_file_attr");
+ begin
+ return Internal (Name, Attr.all'Address) /= 0;
+ end Is_Readable_File;
+
+ ---------------------
+ -- Is_Regular_File --
+ ---------------------
+
+ function Is_Regular_File
+ (Name : C_File_Name; Attr : access File_Attributes) return Boolean
+ is
+ function Internal (N : C_File_Name; A : System.Address) return Integer;
+ pragma Import (C, Internal, "__gnat_is_regular_file_attr");
+ begin
+ return Internal (Name, Attr.all'Address) /= 0;
+ end Is_Regular_File;
+
+ ----------------------
+ -- Is_Symbolic_Link --
+ ----------------------
+
+ function Is_Symbolic_Link
+ (Name : C_File_Name; Attr : access File_Attributes) return Boolean
+ is
+ function Internal (N : C_File_Name; A : System.Address) return Integer;
+ pragma Import (C, Internal, "__gnat_is_symbolic_link_attr");
+ begin
+ return Internal (Name, Attr.all'Address) /= 0;
+ end Is_Symbolic_Link;
+
+ ----------------------
+ -- Is_Writable_File --
+ ----------------------
+
+ function Is_Writable_File
+ (Name : C_File_Name; Attr : access File_Attributes) return Boolean
+ is
+ function Internal (N : C_File_Name; A : System.Address) return Integer;
+ pragma Import (C, Internal, "__gnat_is_writable_file_attr");
+ begin
+ return Internal (Name, Attr.all'Address) /= 0;
+ end Is_Writable_File;
+
-------------------
-- Lib_File_Name --
-------------------
return Name_Find;
end Lib_File_Name;
- ------------------------
- -- Library_File_Stamp --
- ------------------------
-
- function Library_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is
- begin
- return File_Stamp (Find_File (N, Library));
- end Library_File_Stamp;
-
-----------------
-- Locate_File --
-----------------
- function Locate_File
- (N : File_Name_Type;
- T : File_Type;
- Dir : Natural;
- Name : String) return File_Name_Type
+ procedure Locate_File
+ (N : File_Name_Type;
+ T : File_Type;
+ Dir : Natural;
+ Name : String;
+ Found : out File_Name_Type;
+ Attr : access File_Attributes)
is
Dir_Name : String_Ptr;
elsif T = Library then
Dir_Name := Lib_Search_Directories.Table (Dir);
- else pragma Assert (T /= Config);
+ else
+ pragma Assert (T /= Config);
Dir_Name := Src_Search_Directories.Table (Dir);
end if;
declare
- Full_Name : String (1 .. Dir_Name'Length + Name'Length);
+ Full_Name : String (1 .. Dir_Name'Length + Name'Length + 1);
begin
Full_Name (1 .. Dir_Name'Length) := Dir_Name.all;
- Full_Name (Dir_Name'Length + 1 .. Full_Name'Length) := Name;
+ Full_Name (Dir_Name'Length + 1 .. Full_Name'Last - 1) := Name;
+ Full_Name (Full_Name'Last) := ASCII.NUL;
- if not Is_Regular_File (Full_Name) then
- return No_File;
+ Attr.all := Unknown_Attributes;
+
+ if not Is_Regular_File (Full_Name'Address, Attr) then
+ Found := No_File;
else
-- If the file is in the current directory then return N itself
if Dir_Name'Length = 0 then
- return N;
+ Found := N;
else
- Name_Len := Full_Name'Length;
- Name_Buffer (1 .. Name_Len) := Full_Name;
- return Name_Enter;
+ Name_Len := Full_Name'Length - 1;
+ Name_Buffer (1 .. Name_Len) :=
+ Full_Name (1 .. Full_Name'Last - 1);
+ Found := Name_Find; -- ??? Was Name_Enter, no obvious reason
end if;
end if;
end;
declare
File_Name : constant String := Name_Buffer (1 .. Name_Len);
File : File_Name_Type := No_File;
+ Attr : aliased File_Attributes;
Last_Dir : Natural;
begin
if Opt.Look_In_Primary_Dir then
- File := Locate_File (N, Source, Primary_Directory, File_Name);
+ Locate_File
+ (N, Source, Primary_Directory, File_Name, File, Attr'Access);
if File /= No_File and then T = File_Stamp (N) then
return File;
Last_Dir := Src_Search_Directories.Last;
for D in Primary_Directory + 1 .. Last_Dir loop
- File := Locate_File (N, Source, D, File_Name);
+ Locate_File (N, Source, D, File_Name, File, Attr'Access);
if File /= No_File and then T = File_Stamp (File) then
return File;
return Name_Enter;
end Object_File_Name;
+ -------------------------------
+ -- OS_Exit_Through_Exception --
+ -------------------------------
+
+ procedure OS_Exit_Through_Exception (Status : Integer) is
+ begin
+ Current_Exit_Status := Status;
+ raise Types.Terminate_Program;
+ end OS_Exit_Through_Exception;
+
--------------------------
-- OS_Time_To_GNAT_Time --
--------------------------
S : Second_Type;
begin
+ if T = Invalid_Time then
+ return Empty_Time_Stamp;
+ end if;
+
GM_Split (T, Y, Mo, D, H, Mn, S);
Make_Time_Stamp
(Year => Nat (Y),
-- Program_Name --
------------------
- function Program_Name (Nam : String) return String_Access is
- Res : String_Access;
+ function Program_Name (Nam : String; Prog : String) return String_Access is
+ End_Of_Prefix : Natural := 0;
+ Start_Of_Prefix : Positive := 1;
+ Start_Of_Suffix : Positive;
begin
+ -- GNAAMP tool names require special treatment
+
+ if AAMP_On_Target then
+
+ -- The name "gcc" is mapped to "gnaamp" (the compiler driver)
+
+ if Nam = "gcc" then
+ return new String'("gnaamp");
+
+ -- Tool names starting with "gnat" are mapped by substituting the
+ -- string "gnaamp" for "gnat" (for example, "gnatpp" => "gnaamppp").
+
+ elsif Nam'Length >= 4
+ and then Nam (Nam'First .. Nam'First + 3) = "gnat"
+ then
+ return new String'("gnaamp" & Nam (Nam'First + 4 .. Nam'Last));
+
+ -- No other mapping rules, so we continue and handle any other forms
+ -- of tool names the same as on other targets.
+
+ else
+ null;
+ end if;
+ end if;
+
-- Get the name of the current program being executed
Find_Program_Name;
- -- Find the target prefix if any, for the cross compilation case.
- -- For instance in "alpha-dec-vxworks-gcc" the target prefix is
- -- "alpha-dec-vxworks-"
-
- while Name_Len > 0 loop
+ Start_Of_Suffix := Name_Len + 1;
- -- All done if we find the last hyphen
+ -- Find the target prefix if any, for the cross compilation case.
+ -- For instance in "powerpc-elf-gcc" the target prefix is
+ -- "powerpc-elf-"
+ -- Ditto for suffix, e.g. in "gcc-4.1", the suffix is "-4.1"
- if Name_Buffer (Name_Len) = '-' then
+ for J in reverse 1 .. Name_Len loop
+ if Name_Buffer (J) = '/'
+ or else Name_Buffer (J) = Directory_Separator
+ or else Name_Buffer (J) = ':'
+ then
+ Start_Of_Prefix := J + 1;
exit;
+ end if;
+ end loop;
- -- If directory separator found, we don't want to look further
- -- since in this case, no prefix has been found.
+ -- Find End_Of_Prefix
- elsif Is_Directory_Separator (Name_Buffer (Name_Len)) then
- Name_Len := 0;
+ for J in Start_Of_Prefix .. Name_Len - Prog'Length + 1 loop
+ if Name_Buffer (J .. J + Prog'Length - 1) = Prog then
+ End_Of_Prefix := J - 1;
exit;
end if;
-
- Name_Len := Name_Len - 1;
end loop;
+ if End_Of_Prefix > 1 then
+ Start_Of_Suffix := End_Of_Prefix + Prog'Length + 1;
+ end if;
+
-- Create the new program name
- Res := new String (1 .. Name_Len + Nam'Length);
- Res.all (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
- Res.all (Name_Len + 1 .. Name_Len + Nam'Length) := Nam;
- return Res;
+ return new String'
+ (Name_Buffer (Start_Of_Prefix .. End_Of_Prefix)
+ & Nam
+ & Name_Buffer (Start_Of_Suffix .. Name_Len));
end Program_Name;
------------------------------
Curr := Curr + Actual_Len;
end loop;
- -- Process the file, translating line and file ending
- -- control characters to a path separator character.
+ -- Process the file, dealing with path separators
Prev_Was_Separator := True;
Nb_Relative_Dir := 0;
for J in 1 .. Len loop
- if S (J) in ASCII.NUL .. ASCII.US or else S (J) = ' ' then
+
+ -- Treat any control character as a path separator. Note that we do
+ -- not treat space as a path separator (we used to treat space as a
+ -- path separator in an earlier version). That way space can appear
+ -- as a legitimate character in a path name.
+
+ -- Why do we treat all control characters as path separators???
+
+ if S (J) in ASCII.NUL .. ASCII.US then
S (J) := Path_Separator;
end if;
+ -- Test for explicit path separator (or control char as above)
+
if S (J) = Path_Separator then
Prev_Was_Separator := True;
+ -- If not path separator, register use of relative directory
+
else
if Prev_Was_Separator and then Is_Relative (S.all, J) then
Nb_Relative_Dir := Nb_Relative_Dir + 1;
(Lib_File : File_Name_Type;
Fatal_Err : Boolean := False) return Text_Buffer_Ptr
is
+ File : File_Name_Type;
+ Attr : aliased File_Attributes;
+ begin
+ Find_File (Lib_File, Library, File, Attr'Access);
+ return Read_Library_Info_From_Full
+ (Full_Lib_File => File,
+ Lib_File_Attr => Attr'Access,
+ Fatal_Err => Fatal_Err);
+ end Read_Library_Info;
+
+ ---------------------------------
+ -- Read_Library_Info_From_Full --
+ ---------------------------------
+
+ function Read_Library_Info_From_Full
+ (Full_Lib_File : File_Name_Type;
+ Lib_File_Attr : access File_Attributes;
+ Fatal_Err : Boolean := False) return Text_Buffer_Ptr
+ is
Lib_FD : File_Descriptor;
-- The file descriptor for the current library file. A negative value
-- indicates failure to open the specified source file.
+ Len : Integer;
+ -- Length of source file text (ALI). If it doesn't fit in an integer
+ -- we're probably stuck anyway (>2 gigs of source seems a lot!)
+
Text : Text_Buffer_Ptr;
-- Allocated text buffer
Status : Boolean;
+ pragma Warnings (Off, Status);
-- For the calls to Close
begin
- Current_Full_Lib_Name := Find_File (Lib_File, Library);
+ Current_Full_Lib_Name := Full_Lib_File;
Current_Full_Obj_Name := Object_File_Name (Current_Full_Lib_Name);
if Current_Full_Lib_Name = No_File then
if Fatal_Err then
- Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
+ Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
else
Current_Full_Obj_Stamp := Empty_Time_Stamp;
return null;
if Lib_FD = Invalid_FD then
if Fatal_Err then
- Fail ("Cannot open: ", Name_Buffer (1 .. Name_Len));
+ Fail ("Cannot open: " & Name_Buffer (1 .. Name_Len));
else
Current_Full_Obj_Stamp := Empty_Time_Stamp;
return null;
end if;
end if;
+ -- Compute the length of the file (potentially also preparing other data
+ -- like the timestamp and whether the file is read-only, for future use)
+
+ Len := Integer (File_Length (Name_Buffer'Address, Lib_File_Attr));
+
-- Check for object file consistency if requested
if Opt.Check_Object_Consistency then
- Current_Full_Lib_Stamp := File_Stamp (Current_Full_Lib_Name);
+ -- On most systems, this does not result in an extra system call
+
+ Current_Full_Lib_Stamp :=
+ OS_Time_To_GNAT_Time
+ (File_Time_Stamp (Name_Buffer'Address, Lib_File_Attr));
+
+ -- ??? One system call here
+
Current_Full_Obj_Stamp := File_Stamp (Current_Full_Obj_Name);
if Current_Full_Obj_Stamp (1) = ' ' then
-- When the library is readonly always assume object is consistent
+ -- The call to Is_Writable_File only results in a system call on
+ -- some systems, but in most cases it has already been computed as
+ -- part of the call to File_Length above.
+
+ Get_Name_String (Current_Full_Lib_Name);
+ Name_Buffer (Name_Len + 1) := ASCII.NUL;
- if Is_Readonly_Library (Current_Full_Lib_Name) then
+ if not Is_Writable_File (Name_Buffer'Address, Lib_File_Attr) then
Current_Full_Obj_Stamp := Current_Full_Lib_Stamp;
elsif Fatal_Err then
-- No need to check the status, we fail anyway
- Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
+ Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
else
Current_Full_Obj_Stamp := Empty_Time_Stamp;
-- Read data from the file
declare
- Len : constant Integer := Integer (File_Length (Lib_FD));
- -- Length of source file text. If it doesn't fit in an integer
- -- we're probably stuck anyway (>2 gigs of source seems a lot!)
-
Actual_Len : Integer := 0;
Lo : constant Text_Ptr := 0;
loop
Actual_Len := Read (Lib_FD, Text (Hi)'Address, Len);
Hi := Hi + Text_Ptr (Actual_Len);
- exit when Actual_Len = Len or Actual_Len <= 0;
+ exit when Actual_Len = Len or else Actual_Len <= 0;
end loop;
Text (Hi) := EOF;
return Text;
- end Read_Library_Info;
+ end Read_Library_Info_From_Full;
----------------------
-- Read_Source_File --
Actual_Len : Integer;
Status : Boolean;
+ pragma Warnings (Off, Status);
-- For the call to Close
begin
if N = Current_Main then
Get_Name_String (N);
- Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
+ Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
end if;
Src := null;
return;
end if;
+ -- Print out the file name, if requested, and if it's not part of the
+ -- runtimes, store it in File_Name_Chars.
+
+ declare
+ Name : String renames Name_Buffer (1 .. Name_Len);
+ Inc : String renames Include_Dir_Default_Prefix.all;
+
+ begin
+ if Debug.Debug_Flag_Dot_N then
+ Write_Line (Name);
+ end if;
+
+ if Inc /= ""
+ and then Inc'Length < Name_Len
+ and then Name_Buffer (1 .. Inc'Length) = Inc
+ then
+ -- Part of runtimes, so ignore it
+
+ null;
+
+ else
+ File_Name_Chars.Append_All (File_Name_Chars.Table_Type (Name));
+ File_Name_Chars.Append (ASCII.LF);
+ end if;
+ end;
+
-- Prepare to read data from the file
Len := Integer (File_Length (Source_File_FD));
begin
-- Allocate source buffer, allowing extra character at end for EOF
- -- Some systems (e.g. VMS) have file types that require one
- -- read per line, so read until we get the Len bytes or until
- -- there are no more characters.
+ -- Some systems (e.g. VMS) have file types that require one read per
+ -- line, so read until we get the Len bytes or until there are no
+ -- more characters.
Hi := Lo;
loop
Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len);
Hi := Hi + Source_Ptr (Actual_Len);
- exit when Actual_Len = Len or Actual_Len <= 0;
+ exit when Actual_Len = Len or else Actual_Len <= 0;
end loop;
Actual_Ptr (Hi) := EOF;
-- Now we need to work out the proper virtual origin pointer to
- -- return. This is exactly Actual_Ptr (0)'Address, but we have
- -- to be careful to suppress checks to compute this address.
+ -- return. This is exactly Actual_Ptr (0)'Address, but we have to
+ -- be careful to suppress checks to compute this address.
declare
pragma Suppress (All_Checks);
(N : File_Name_Type;
T : File_Type) return Time_Stamp_Type
is
- Time_Stamp : Time_Stamp_Type;
+ File : File_Name_Type;
+ Attr : aliased File_Attributes;
begin
if not File_Cache_Enabled then
- return File_Stamp (Find_File (N, T));
+ Find_File (N, T, File, Attr'Access);
+ else
+ Smart_Find_File (N, T, File, Attr);
end if;
- Time_Stamp := File_Stamp_Hash_Table.Get (N);
-
- if Time_Stamp (1) = ' ' then
- Time_Stamp := File_Stamp (Smart_Find_File (N, T));
- File_Stamp_Hash_Table.Set (N, Time_Stamp);
+ if File = No_File then
+ return Empty_Time_Stamp;
+ else
+ Get_Name_String (File);
+ Name_Buffer (Name_Len + 1) := ASCII.NUL;
+ return
+ OS_Time_To_GNAT_Time
+ (File_Time_Stamp (Name_Buffer'Address, Attr'Access));
end if;
-
- return Time_Stamp;
end Smart_File_Stamp;
---------------------
(N : File_Name_Type;
T : File_Type) return File_Name_Type
is
- Full_File_Name : File_Name_Type;
+ File : File_Name_Type;
+ Attr : File_Attributes;
+ begin
+ Smart_Find_File (N, T, File, Attr);
+ return File;
+ end Smart_Find_File;
+
+ ---------------------
+ -- Smart_Find_File --
+ ---------------------
+
+ procedure Smart_Find_File
+ (N : File_Name_Type;
+ T : File_Type;
+ Found : out File_Name_Type;
+ Attr : out File_Attributes)
+ is
+ Info : File_Info_Cache;
begin
if not File_Cache_Enabled then
- return Find_File (N, T);
- end if;
+ Find_File (N, T, Info.File, Info.Attr'Access);
- Full_File_Name := File_Name_Hash_Table.Get (N);
+ else
+ Info := File_Name_Hash_Table.Get (N);
- if Full_File_Name = No_File then
- Full_File_Name := Find_File (N, T);
- File_Name_Hash_Table.Set (N, Full_File_Name);
+ if Info.File = No_File then
+ Find_File (N, T, Info.File, Info.Attr'Access);
+ File_Name_Hash_Table.Set (N, Info);
+ end if;
end if;
- return Full_File_Name;
+ Found := Info.File;
+ Attr := Info.Attr;
end Smart_Find_File;
----------------------
if Is_Directory_Separator (Name_Buffer (J)) then
- -- Return the part of Name that follows this last directory
- -- separator.
+ -- Return part of Name that follows this last directory separator
Name_Buffer (1 .. Name_Len - J) := Name_Buffer (J + 1 .. Name_Len);
Name_Len := Name_Len - J;
Prefix_Flag : Integer) return Address;
pragma Import (C, To_Canonical_Dir_Spec, "__gnat_to_canonical_dir_spec");
- C_Host_Dir : String (1 .. Host_Dir'Length + 1);
+ C_Host_Dir : String (1 .. Host_Dir'Length + 1);
Canonical_Dir_Addr : Address;
Canonical_Dir_Len : Integer;
else
Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 0);
end if;
+
Canonical_Dir_Len := C_String_Length (Canonical_Dir_Addr);
if Canonical_Dir_Len = 0 then
exception
when others =>
- Fail ("erroneous directory spec: ", Host_Dir);
+ Fail ("erroneous directory spec: " & Host_Dir);
return null;
end To_Canonical_Dir_Spec;
Canonical_File_Len : Integer;
begin
- -- Retrieve the expanded directoy names and build the list
+ -- Retrieve the expanded directory names and build the list
for J in 1 .. Num_Files loop
Canonical_File_Addr := To_Canonical_File_List_Next;
exception
when others =>
- Fail ("erroneous file spec: ", Host_File);
+ Fail ("erroneous file spec: " & Host_File);
return null;
end To_Canonical_File_Spec;
exception
when others =>
- Fail ("erroneous path spec: ", Host_Path);
+ Fail ("erroneous path spec: " & Host_Path);
return null;
end To_Canonical_Path_Spec;
procedure Write_With_Check (A : Address; N : Integer) is
Ignore : Boolean;
+ pragma Warnings (Off, Ignore);
begin
if N = Write (Output_FD, A, N) then
-- Package Initialization --
----------------------------
+ procedure Reset_File_Attributes (Attr : System.Address);
+ pragma Import (C, Reset_File_Attributes, "__gnat_reset_attributes");
+
begin
Initialization : declare
"__gnat_get_maximum_file_name_length");
-- Function to get maximum file name length for system
+ Sizeof_File_Attributes : Integer;
+ pragma Import (C, Sizeof_File_Attributes,
+ "__gnat_size_of_file_attributes");
+
begin
+ pragma Assert (Sizeof_File_Attributes <= File_Attributes_Size);
+
+ Reset_File_Attributes (Unknown_Attributes'Address);
+
Identifier_Character_Set := Get_Default_Identifier_Character_Set;
Maximum_File_Name_Length := Get_Maximum_File_Name_Length;
OSDN Git Service
