-- --
-- B o d y --
-- --
--- $Revision$
--- --
--- Copyright (C) 1992-2001 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, 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 Hostparm;
-with Namet; use Namet;
-with Opt; use Opt;
-with Output; use Output;
-with Sdefault; use Sdefault;
-with Table;
-with Tree_IO; use Tree_IO;
-
with Unchecked_Conversion;
-with GNAT.OS_Lib; use GNAT.OS_Lib;
+with System.Case_Util; use System.Case_Util;
+
with GNAT.HTable;
+with Alloc;
+with Debug;
+with Fmap; use Fmap;
+with Gnatvsn; use Gnatvsn;
+with Hostparm;
+with Opt; use Opt;
+with Output; use Output;
+with Sdefault; use Sdefault;
+with Table;
+with Targparm; use Targparm;
+
package body Osint is
+ Running_Program : Program_Type := Unspecified;
+ -- comment required here ???
+
+ Program_Set : Boolean := False;
+ -- comment required here ???
+
+ Std_Prefix : String_Ptr;
+ -- Standard prefix, computed dynamically the first time Relocate_Path
+ -- is called, and cached for subsequent calls.
+
+ Empty : aliased String := "";
+ No_Dir : constant String_Ptr := Empty'Access;
+ -- Used in Locate_File as a fake directory when Name is already an
+ -- absolute path.
+
-------------------------------------
-- Use of Name_Find and Name_Enter --
-------------------------------------
-- This package creates a number of source, ALI and object file names
- -- 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.
+ -- 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 (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 --
-----------------------
function Append_Suffix_To_File_Name
- (Name : Name_Id;
- Suffix : String)
- return Name_Id;
- -- Appends Suffix to Name and returns the new name.
+ (Name : File_Name_Type;
+ Suffix : String) return File_Name_Type;
+ -- 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
-
- procedure Create_File_And_Check
- (Fdesc : out File_Descriptor;
- Fmode : Mode);
- -- Create file whose name (NUL terminated) is in Name_Buffer (with the
- -- length in Name_Len), and place the resulting descriptor in Fdesc.
- -- Issue message and exit with fatal error if file cannot be created.
- -- The Fmode parameter is set to either Text or Binary (see description
- -- of GNAT.OS_Lib.Create_File).
-
- procedure Set_Library_Info_Name;
- -- Sets a default ali file name from the main compiler source name.
- -- This is used by Create_Output_Library_Info, and by the version of
- -- Read_Library_Info that takes a default file name.
-
- procedure Write_Info (Info : String);
- -- Implementation of Write_Binder_Info, Write_Debug_Info and
- -- Write_Library_Info (identical)
-
- procedure Write_With_Check (A : Address; N : Integer);
- -- Writes N bytes from buffer starting at address A to file whose FD is
- -- stored in Output_FD, and whose file name is stored as a File_Name_Type
- -- in Output_File_Name. A check is made for disk full, and if this is
- -- detected, the file being written is deleted, and a fatal error is
- -- signalled.
-
- function More_Files return Boolean;
- -- Implements More_Source_Files and More_Lib_Files.
-
- function Next_Main_File return File_Name_Type;
- -- Implements Next_Main_Source and Next_Main_Lib_File.
-
- function Locate_File
- (N : File_Name_Type;
- T : File_Type;
- Dir : Natural;
- Name : String)
- return File_Name_Type;
- -- 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.
+ -- 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.
+ -- The executable must be located in a directory called "bin", or under
+ -- root/lib/gcc-lib/..., or under root/libexec/gcc/... For example, if
+ -- executable is stored in directory "/foo/bar/bin", this routine returns
+ -- "/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.
+
+ 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. Returns zero for a null address.
+ -- Returns length of a C string (zero for a null address)
function To_Path_String_Access
(Path_Addr : 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 ???
+ 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 --
------------------------------
- ALI_Suffix : constant String_Ptr := new String'("ali");
- -- The suffix used for the library files (also known as ALI files).
-
- Object_Suffix : constant String := Get_Object_Suffix.all;
- -- The suffix used for the object files.
-
EOL : constant Character := ASCII.LF;
-- End of line character
- Argument_Count : constant Integer := Arg_Count - 1;
- -- Number of arguments (excluding program name)
-
- type File_Name_Array is array (Int range <>) of String_Ptr;
- type File_Name_Array_Ptr is access File_Name_Array;
- File_Names : File_Name_Array_Ptr :=
- new File_Name_Array (1 .. Int (Argument_Count) + 2);
- -- As arguments are scanned in Initialize, file names are stored
- -- in this array. The string does not contain a terminating NUL.
- -- The array is "extensible" because when using project files,
- -- there may be more file names than argument on the command line.
-
Number_File_Names : Int := 0;
- -- The total number of file names found on command line and placed in
- -- File_Names.
-
- Current_File_Name_Index : Int := 0;
- -- The index in File_Names of the last file opened by Next_Main_Source
- -- or Next_Main_Lib_File. The value 0 indicates that no files have been
- -- opened yet.
-
- Current_Main : File_Name_Type := No_File;
- -- Used to save a simple file name between calls to Next_Main_Source and
- -- Read_Source_File. If the file name argument to Read_Source_File is
- -- No_File, that indicates that the file whose name was returned by the
- -- last call to Next_Main_Source (and stored here) is to be read.
+ -- 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 will only look in
- -- the Primary_Directory for the Current_Main file.
- -- This variable is always True for the compiler.
- -- It is also True for gnatmake, when the soucr name given
- -- on the command line has directory information.
+ -- 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 source name given on
+ -- the command line has directory information.
Current_Full_Source_Name : File_Name_Type := No_File;
Current_Full_Source_Stamp : Time_Stamp_Type := Empty_Time_Stamp;
Current_Full_Lib_Stamp : Time_Stamp_Type := Empty_Time_Stamp;
Current_Full_Obj_Name : File_Name_Type := No_File;
Current_Full_Obj_Stamp : Time_Stamp_Type := Empty_Time_Stamp;
- -- Respectively full name (with directory info) and time stamp of
- -- the latest source, library and object files opened by Read_Source_File
- -- and Read_Library_Info.
-
- Old_Binder_Output_Time_Stamp : Time_Stamp_Type;
- New_Binder_Output_Time_Stamp : Time_Stamp_Type;
- Recording_Time_From_Last_Bind : Boolean := False;
- Binder_Output_Time_Stamps_Set : Boolean := False;
-
- In_Binder : Boolean := False;
- In_Compiler : Boolean := False;
- In_Make : Boolean := False;
- -- Exactly one of these flags is set True to indicate which program
- -- is bound and executing with Osint, which is used by all these programs.
-
- Output_FD : File_Descriptor;
- -- The file descriptor for the current library info, tree or binder output
-
- Output_File_Name : File_Name_Type;
- -- File_Name_Type for name of open file whose FD is in Output_FD, the name
- -- stored does not include the trailing NUL character.
-
- Output_Object_File_Name : String_Ptr;
- -- Argument of -o compiler option, if given. This is needed to
- -- verify consistency with the ALI file name.
+ -- Respectively full name (with directory info) and time stamp of the
+ -- 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 --
Primary_Directory : constant := 0;
-- This is index in the tables created below for the first directory to
- -- search in for source or library information files. This is the
- -- directory containing the latest main input file (a source file for
- -- the compiler or a library file for the binder).
+ -- search in for source or library information files. This is the directory
+ -- containing the latest main input file (a source file for the compiler or
+ -- a library file for the binder).
package Src_Search_Directories is new Table.Table (
Table_Component_Type => String_Ptr,
- Table_Index_Type => Natural,
+ Table_Index_Type => Integer,
Table_Low_Bound => Primary_Directory,
Table_Initial => 10,
Table_Increment => 100,
package Lib_Search_Directories is new Table.Table (
Table_Component_Type => String_Ptr,
- Table_Index_Type => Natural,
+ Table_Index_Type => Integer,
Table_Low_Bound => Primary_Directory,
Table_Initial => 10,
Table_Increment => 100,
-- 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
- -- 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 table that stores as a key the File_Name_Type of the file and
- -- associates to that File_Name_Type the full file name of the file and its
- -- time stamp.
+ -- 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
+ -- table that stores as a key the File_Name_Type of the file and associates
+ -- to that File_Name_Type the full file name and time stamp of the file.
File_Cache_Enabled : Boolean := False;
- -- Set to true if you want the enable the file data caching mechanism.
+ -- Set to true if you want the enable the file data caching mechanism
type File_Hash_Num is range 0 .. 1020;
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 => "=");
function Smart_Find_File
- (N : File_Name_Type;
- T : File_Type)
- return File_Name_Type;
+ (N : File_Name_Type;
+ T : File_Type) return File_Name_Type;
-- Exactly like Find_File except that if File_Cache_Enabled is True this
-- routine looks first in the hash table to see if the full name of the
-- file is already available.
function Smart_File_Stamp
- (N : File_Name_Type;
- T : File_Type)
- return Time_Stamp_Type;
- -- Takes the same parameter as the routine above (N is a file name
- -- without any prefix directory information) and behaves like File_Stamp
- -- except that if File_Cache_Enabled is True this routine looks first in
- -- the hash table to see if the file stamp of the file is already
- -- available.
+ (N : File_Name_Type;
+ T : File_Type) return Time_Stamp_Type;
+ -- Takes the same parameter as the routine above (N is a file name without
+ -- any prefix directory information) and behaves like File_Stamp except
+ -- that if File_Cache_Enabled is True this routine looks first in the hash
+ -- table to see if the file stamp of the file is already available.
-----------------------------
-- Add_Default_Search_Dirs --
-----------------------------
procedure Add_Default_Search_Dirs is
- Search_Dir : String_Access;
- Search_Path : String_Access;
+ Search_Dir : String_Access;
+ Search_Path : String_Access;
+ Path_File_Name : String_Access;
procedure Add_Search_Dir
+ (Search_Dir : String;
+ Additional_Source_Dir : Boolean);
+ procedure Add_Search_Dir
(Search_Dir : String_Access;
Additional_Source_Dir : Boolean);
- -- Needs documentation ???
+ -- Add a source search dir or a library search dir, depending on the
+ -- value of Additional_Source_Dir.
+
+ procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean);
+ -- Open a path file and read the directory to search, one per line
function Get_Libraries_From_Registry return String_Ptr;
-- On Windows systems, get the list of installed standard libraries
-- from the registry key:
+ --
-- HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\
-- GNAT\Standard Libraries
- -- Return an empty string on other systems
-
- 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 more details.
+ -- 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 --
--------------------
procedure Add_Search_Dir
+ (Search_Dir : String;
+ Additional_Source_Dir : Boolean)
+ is
+ begin
+ if Additional_Source_Dir then
+ Add_Src_Search_Dir (Search_Dir);
+ else
+ Add_Lib_Search_Dir (Search_Dir);
+ end if;
+ end Add_Search_Dir;
+
+ procedure Add_Search_Dir
(Search_Dir : String_Access;
Additional_Source_Dir : Boolean)
is
end if;
end Add_Search_Dir;
+ ------------------------
+ -- Get_Dirs_From_File --
+ ------------------------
+
+ procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean) is
+ File_FD : File_Descriptor;
+ Buffer : constant String := Path_File_Name.all & ASCII.NUL;
+ Len : Natural;
+ Actual_Len : Natural;
+ S : String_Access;
+ Curr : Natural;
+ First : Natural;
+ Ch : Character;
+
+ Status : Boolean;
+ pragma Warnings (Off, Status);
+ -- For the call to Close where status is ignored
+
+ begin
+ File_FD := Open_Read (Buffer'Address, Binary);
+
+ -- If we cannot open the file, we ignore it, we don't fail
+
+ if File_FD = Invalid_FD then
+ return;
+ end if;
+
+ Len := Integer (File_Length (File_FD));
+
+ S := new String (1 .. Len);
+
+ -- Read the file. Note that the loop is not necessary since the
+ -- whole file is read at once except on VMS.
+
+ Curr := 1;
+ Actual_Len := Len;
+ while Curr <= Len and then Actual_Len /= 0 loop
+ Actual_Len := Read (File_FD, S (Curr)'Address, Len);
+ Curr := Curr + Actual_Len;
+ end loop;
+
+ -- We are done with the file, so we close it (ignore any error on
+ -- the close, since we have successfully read the file).
+
+ Close (File_FD, Status);
+
+ -- Now, we read line by line
+
+ First := 1;
+ Curr := 0;
+ while Curr < Len loop
+ Ch := S (Curr + 1);
+
+ if Ch = ASCII.CR or else Ch = ASCII.LF
+ or else Ch = ASCII.FF or else Ch = ASCII.VT
+ then
+ if First <= Curr then
+ Add_Search_Dir (S (First .. Curr), Additional_Source_Dir);
+ end if;
+
+ First := Curr + 2;
+ end if;
+
+ Curr := Curr + 1;
+ end loop;
+
+ -- Last line is a special case, if the file does not end with
+ -- an end of line mark.
+
+ if First <= S'Last then
+ Add_Search_Dir (S (First .. S'Last), Additional_Source_Dir);
+ end if;
+ end Get_Dirs_From_File;
+
---------------------------------
-- Get_Libraries_From_Registry --
---------------------------------
function C_Get_Libraries_From_Registry return Address;
pragma Import (C, C_Get_Libraries_From_Registry,
"__gnat_get_libraries_from_registry");
+
function Strlen (Str : Address) return Integer;
pragma Import (C, Strlen, "strlen");
+
procedure Strncpy (X : Address; Y : Address; Length : Integer);
pragma Import (C, Strncpy, "strncpy");
- Result_Ptr : Address;
+
+ procedure C_Free (Str : Address);
+ pragma Import (C, C_Free, "free");
+
+ Result_Ptr : Address;
Result_Length : Integer;
- Out_String : String_Ptr;
+ Out_String : String_Ptr;
begin
Result_Ptr := C_Get_Libraries_From_Registry;
Out_String := new String (1 .. Result_Length);
Strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
- return Out_String;
- end Get_Libraries_From_Registry;
-
- -----------------
- -- Update_Path --
- -----------------
-
- function Update_Path (Path : String_Ptr) return String_Ptr is
-
- function C_Update_Path (Path, Component : Address) return Address;
- pragma Import (C, C_Update_Path, "update_path");
-
- function Strlen (Str : Address) return Integer;
- pragma Import (C, Strlen, "strlen");
- procedure Strncpy (X : Address; Y : Address; Length : Integer);
- pragma Import (C, Strncpy, "strncpy");
-
- In_Length : constant Integer := Path'Length;
- In_String : String (1 .. In_Length + 1);
- Component_Name : aliased String := "GNAT" & ASCII.NUL;
- Result_Ptr : Address;
- Result_Length : Integer;
- Out_String : String_Ptr;
-
- begin
- In_String (1 .. In_Length) := Path.all;
- In_String (In_Length + 1) := ASCII.NUL;
- Result_Ptr := C_Update_Path (In_String'Address,
- Component_Name'Address);
- Result_Length := Strlen (Result_Ptr);
+ C_Free (Result_Ptr);
- Out_String := new String (1 .. Result_Length);
- Strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
return Out_String;
- end Update_Path;
+ end Get_Libraries_From_Registry;
-- Start of processing for Add_Default_Search_Dirs
-- environment variable. Get this value, extract the directory names
-- and store in the tables.
+ -- Check for eventual project path file env vars
+
+ Path_File_Name := Getenv (Project_Include_Path_File);
+
+ if Path_File_Name'Length > 0 then
+ Get_Dirs_From_File (Additional_Source_Dir => True);
+ end if;
+
+ Path_File_Name := Getenv (Project_Objects_Path_File);
+
+ if Path_File_Name'Length > 0 then
+ Get_Dirs_From_File (Additional_Source_Dir => False);
+ end if;
+
-- On VMS, don't expand the logical name (e.g. environment variable),
-- just put it into Unix (e.g. canonical) format. System services
-- will handle the expansion as part of the file processing.
for Additional_Source_Dir in False .. True loop
-
if Additional_Source_Dir then
- Search_Path := Getenv ("ADA_INCLUDE_PATH");
+ Search_Path := Getenv (Ada_Include_Path);
+
if Search_Path'Length > 0 then
if Hostparm.OpenVMS then
Search_Path := To_Canonical_Path_Spec ("ADA_INCLUDE_PATH:");
Search_Path := To_Canonical_Path_Spec (Search_Path.all);
end if;
end if;
+
else
- Search_Path := Getenv ("ADA_OBJECTS_PATH");
+ Search_Path := Getenv (Ada_Objects_Path);
+
if Search_Path'Length > 0 then
if Hostparm.OpenVMS then
Search_Path := To_Canonical_Path_Spec ("ADA_OBJECTS_PATH:");
end loop;
end loop;
- if not Opt.No_Stdinc then
- -- For WIN32 systems, look for any system libraries defined in
- -- the registry. These are added to both source and object
- -- directories.
+ -- For the compiler, if --RTS= was specified, add the runtime
+ -- directories.
- Search_Path := String_Access (Get_Libraries_From_Registry);
- Get_Next_Dir_In_Path_Init (Search_Path);
- loop
- Search_Dir := Get_Next_Dir_In_Path (Search_Path);
- exit when Search_Dir = null;
- Add_Search_Dir (Search_Dir, False);
- Add_Search_Dir (Search_Dir, True);
- end loop;
+ if RTS_Src_Path_Name /= null
+ and then RTS_Lib_Path_Name /= null
+ then
+ Add_Search_Dirs (RTS_Src_Path_Name, Include);
+ Add_Search_Dirs (RTS_Lib_Path_Name, Objects);
- -- The last place to look are the defaults
+ else
+ if not Opt.No_Stdinc then
- Search_Path := Read_Default_Search_Dirs
- (String_Access (Update_Path (Search_Dir_Prefix)),
- Include_Search_File,
- String_Access (Update_Path (Include_Dir_Default_Name)));
+ -- For WIN32 systems, look for any system libraries defined in
+ -- the registry. These are added to both source and object
+ -- directories.
- Get_Next_Dir_In_Path_Init (Search_Path);
- loop
- Search_Dir := Get_Next_Dir_In_Path (Search_Path);
- exit when Search_Dir = null;
- Add_Search_Dir (Search_Dir, True);
- end loop;
- end if;
+ Search_Path := String_Access (Get_Libraries_From_Registry);
- if not Opt.No_Stdlib then
- Search_Path := Read_Default_Search_Dirs
- (String_Access (Update_Path (Search_Dir_Prefix)),
- Objects_Search_File,
- String_Access (Update_Path (Object_Dir_Default_Name)));
+ Get_Next_Dir_In_Path_Init (Search_Path);
+ loop
+ Search_Dir := Get_Next_Dir_In_Path (Search_Path);
+ exit when Search_Dir = null;
+ Add_Search_Dir (Search_Dir, False);
+ Add_Search_Dir (Search_Dir, True);
+ end loop;
- Get_Next_Dir_In_Path_Init (Search_Path);
- loop
- Search_Dir := Get_Next_Dir_In_Path (Search_Path);
- exit when Search_Dir = null;
- Add_Search_Dir (Search_Dir, False);
- end loop;
- end if;
+ -- The last place to look are the defaults
+ Search_Path :=
+ Read_Default_Search_Dirs
+ (String_Access (Update_Path (Search_Dir_Prefix)),
+ Include_Search_File,
+ String_Access (Update_Path (Include_Dir_Default_Name)));
+
+ Get_Next_Dir_In_Path_Init (Search_Path);
+ loop
+ Search_Dir := Get_Next_Dir_In_Path (Search_Path);
+ exit when Search_Dir = null;
+ Add_Search_Dir (Search_Dir, True);
+ end loop;
+ end if;
+
+ if not Opt.No_Stdlib and not Opt.RTS_Switch then
+ Search_Path :=
+ Read_Default_Search_Dirs
+ (String_Access (Update_Path (Search_Dir_Prefix)),
+ Objects_Search_File,
+ String_Access (Update_Path (Object_Dir_Default_Name)));
+
+ Get_Next_Dir_In_Path_Init (Search_Path);
+ loop
+ Search_Dir := Get_Next_Dir_In_Path (Search_Path);
+ exit when Search_Dir = null;
+ Add_Search_Dir (Search_Dir, False);
+ end loop;
+ end if;
+ end if;
end Add_Default_Search_Dirs;
--------------
-- Add_File --
--------------
- procedure Add_File (File_Name : String) is
+ procedure Add_File (File_Name : String; Index : Int := No_Index) is
begin
Number_File_Names := Number_File_Names + 1;
- -- As Add_File may be called for mains specified inside
- -- a project file, File_Names may be too short and needs
- -- to be extended.
+ -- As Add_File may be called for mains specified inside a project file,
+ -- File_Names may be too short and needs to be extended.
if Number_File_Names > File_Names'Last then
File_Names := new File_Name_Array'(File_Names.all & File_Names.all);
+ File_Indexes :=
+ new File_Index_Array'(File_Indexes.all & File_Indexes.all);
end if;
- File_Names (Number_File_Names) := new String'(File_Name);
+ File_Names (Number_File_Names) := new String'(File_Name);
+ File_Indexes (Number_File_Names) := Index;
end Add_File;
------------------------
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;
+ ---------------------
+ -- Add_Search_Dirs --
+ ---------------------
+
+ procedure Add_Search_Dirs
+ (Search_Path : String_Ptr;
+ Path_Type : Search_File_Type)
+ is
+ Current_Search_Path : String_Access;
+
+ begin
+ Get_Next_Dir_In_Path_Init (String_Access (Search_Path));
+ loop
+ Current_Search_Path :=
+ Get_Next_Dir_In_Path (String_Access (Search_Path));
+ exit when Current_Search_Path = null;
+
+ if Path_Type = Include then
+ Add_Src_Search_Dir (Current_Search_Path.all);
+ else
+ Add_Lib_Search_Dir (Current_Search_Path.all);
+ end if;
+ end loop;
+ end Add_Search_Dirs;
+
------------------------
-- Add_Src_Search_Dir --
------------------------
--------------------------------
function Append_Suffix_To_File_Name
- (Name : Name_Id;
- Suffix : String)
- return Name_Id
+ (Name : File_Name_Type;
+ Suffix : String) return File_Name_Type
is
begin
Get_Name_String (Name);
function C_String_Length (S : Address) return Integer is
function Strlen (S : Address) return Integer;
pragma Import (C, Strlen, "strlen");
-
begin
if S = Null_Address then
return 0;
end if;
end Canonical_Case_File_Name;
- -------------------------
- -- Close_Binder_Output --
- -------------------------
-
- procedure Close_Binder_Output is
- begin
- pragma Assert (In_Binder);
- Close (Output_FD);
-
- if Recording_Time_From_Last_Bind then
- New_Binder_Output_Time_Stamp := File_Stamp (Output_File_Name);
- Binder_Output_Time_Stamps_Set := True;
- end if;
- end Close_Binder_Output;
-
- ----------------------
- -- Close_Debug_File --
- ----------------------
-
- procedure Close_Debug_File is
- begin
- pragma Assert (In_Compiler);
- Close (Output_FD);
- end Close_Debug_File;
-
- -------------------------------
- -- Close_Output_Library_Info --
- -------------------------------
-
- procedure Close_Output_Library_Info is
- begin
- pragma Assert (In_Compiler);
- Close (Output_FD);
- end Close_Output_Library_Info;
-
- --------------------------
- -- Create_Binder_Output --
- --------------------------
-
- procedure Create_Binder_Output
- (Output_File_Name : String;
- Typ : Character;
- Bfile : out Name_Id)
- is
- File_Name : String_Ptr;
- Findex1 : Natural;
- Findex2 : Natural;
- Flength : Natural;
-
- begin
- pragma Assert (In_Binder);
-
- if Output_File_Name /= "" then
- Name_Buffer (Output_File_Name'Range) := Output_File_Name;
- Name_Buffer (Output_File_Name'Last + 1) := ASCII.NUL;
-
- if Typ = 's' then
- Name_Buffer (Output_File_Name'Last) := 's';
- end if;
-
- Name_Len := Output_File_Name'Last;
-
- else
- Name_Buffer (1) := 'b';
- File_Name := File_Names (Current_File_Name_Index);
-
- Findex1 := File_Name'First;
-
- -- The ali file might be specified by a full path name. However,
- -- the binder generated file should always be created in the
- -- current directory, so the path might need to be stripped away.
- -- In addition to the default directory_separator allow the '/' to
- -- act as separator since this is allowed in MS-DOS and OS2 ports.
-
- for J in reverse File_Name'Range loop
- if File_Name (J) = Directory_Separator
- or else File_Name (J) = '/'
- then
- Findex1 := J + 1;
- exit;
- end if;
- end loop;
-
- Findex2 := File_Name'Last;
- while File_Name (Findex2) /= '.' loop
- Findex2 := Findex2 - 1;
- end loop;
-
- Flength := Findex2 - Findex1;
-
- if Maximum_File_Name_Length > 0 then
-
- -- Make room for the extra two characters in "b?"
-
- while Int (Flength) > Maximum_File_Name_Length - 2 loop
- Findex2 := Findex2 - 1;
- Flength := Findex2 - Findex1;
- end loop;
- end if;
-
- Name_Buffer (3 .. Flength + 2) := File_Name (Findex1 .. Findex2 - 1);
- Name_Buffer (Flength + 3) := '.';
-
- -- C bind file, name is b_xxx.c
-
- if Typ = 'c' then
- Name_Buffer (2) := '_';
- Name_Buffer (Flength + 4) := 'c';
- Name_Buffer (Flength + 5) := ASCII.NUL;
- Name_Len := Flength + 4;
-
- -- Ada bind file, name is b~xxx.adb or b~xxx.ads
- -- (with $ instead of ~ in VMS)
-
- else
- if Hostparm.OpenVMS then
- Name_Buffer (2) := '$';
- else
- Name_Buffer (2) := '~';
- end if;
-
- Name_Buffer (Flength + 4) := 'a';
- Name_Buffer (Flength + 5) := 'd';
- Name_Buffer (Flength + 6) := Typ;
- Name_Buffer (Flength + 7) := ASCII.NUL;
- Name_Len := Flength + 6;
- end if;
- end if;
-
- Bfile := Name_Find;
-
- if Recording_Time_From_Last_Bind then
- Old_Binder_Output_Time_Stamp := File_Stamp (Bfile);
- end if;
-
- Create_File_And_Check (Output_FD, Text);
- end Create_Binder_Output;
-
- -----------------------
- -- Create_Debug_File --
- -----------------------
-
- function Create_Debug_File (Src : File_Name_Type) return File_Name_Type is
- Result : File_Name_Type;
-
- begin
- Get_Name_String (Src);
- if Hostparm.OpenVMS then
- Name_Buffer (Name_Len + 1 .. Name_Len + 3) := "_dg";
- else
- Name_Buffer (Name_Len + 1 .. Name_Len + 3) := ".dg";
- end if;
- Name_Len := Name_Len + 3;
- Result := Name_Find;
- Name_Buffer (Name_Len + 1) := ASCII.NUL;
- Create_File_And_Check (Output_FD, Text);
- return Result;
- end Create_Debug_File;
-
---------------------------
-- Create_File_And_Check --
---------------------------
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;
- --------------------------------
- -- Create_Output_Library_Info --
- --------------------------------
+ ------------------------
+ -- Current_File_Index --
+ ------------------------
- procedure Create_Output_Library_Info is
+ function Current_File_Index return Int is
begin
- Set_Library_Info_Name;
- Create_File_And_Check (Output_FD, Text);
- end Create_Output_Library_Info;
+ return File_Indexes (Current_File_Name_Index);
+ end Current_File_Index;
--------------------------------
-- Current_Library_File_Stamp --
return Current_Full_Source_Stamp;
end Current_Source_File_Stamp;
- ---------------------------
- -- Debug_File_Eol_Length --
- ---------------------------
-
- function Debug_File_Eol_Length return Nat is
- begin
- -- There has to be a cleaner way to do this! ???
-
- if Directory_Separator = '/' then
- return 1;
- else
- return 2;
- end if;
- end Debug_File_Eol_Length;
-
----------------------------
-- Dir_In_Obj_Search_Path --
----------------------------
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
return No_File;
end if;
- Get_Name_String (Name);
- Exec_Suffix := Get_Executable_Suffix;
+ if Executable_Extension_On_Target = No_Name then
+ Exec_Suffix := Get_Target_Executable_Suffix;
+ else
+ Get_Name_String (Executable_Extension_On_Target);
+ Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len));
+ end if;
- for J in Exec_Suffix.all'Range loop
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := Exec_Suffix.all (J);
- end loop;
+ if Exec_Suffix'Length /= 0 then
+ Get_Name_String (Name);
- return Name_Enter;
+ 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 Add_Suffix 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);
+
+ -- 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;
+ Only_If_No_Suffix : Boolean := False) return String
+ is
+ Exec_Suffix : String_Access;
+ Add_Suffix : Boolean;
+ Canonical_Name : String := Name;
+
+ begin
+ if Executable_Extension_On_Target = No_Name then
+ Exec_Suffix := Get_Target_Executable_Suffix;
+ else
+ Get_Name_String (Executable_Extension_On_Target);
+ Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len));
+ end if;
+
+ if Exec_Suffix'Length = 0 then
+ Free (Exec_Suffix);
+ return Name;
+
+ 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;
+ end if;
+ end Executable_Name;
+
+ -----------------------
+ -- Executable_Prefix --
+ -----------------------
+
+ function Executable_Prefix return String_Ptr is
+
+ function Get_Install_Dir (Exec : String) return String_Ptr;
+ -- S is the executable name preceded by the absolute or relative
+ -- path, e.g. "c:\usr\bin\gcc.exe" or "..\bin\gcc".
+
+ ---------------------
+ -- Get_Install_Dir --
+ ---------------------
+
+ function Get_Install_Dir (Exec : String) return String_Ptr is
+ Full_Path : constant String := Normalize_Pathname (Exec);
+ -- Use the full path, so that we find "lib" or "bin", even when
+ -- the tool has been invoked with a relative path, as in
+ -- "./gnatls -v" invoked in the GNAT bin directory.
+
+ begin
+ for J in reverse Full_Path'Range loop
+ if Is_Directory_Separator (Full_Path (J)) then
+ if J < Full_Path'Last - 5 then
+ if (To_Lower (Full_Path (J + 1)) = 'l'
+ and then To_Lower (Full_Path (J + 2)) = 'i'
+ and then To_Lower (Full_Path (J + 3)) = 'b')
+ or else
+ (To_Lower (Full_Path (J + 1)) = 'b'
+ and then To_Lower (Full_Path (J + 2)) = 'i'
+ and then To_Lower (Full_Path (J + 3)) = 'n')
+ then
+ return new String'(Full_Path (Full_Path'First .. J));
+ end if;
+ end if;
+ end if;
+ end loop;
+
+ return new String'("");
+ end Get_Install_Dir;
+
+ -- Start of processing for Executable_Prefix
+
+ begin
+ if Exec_Name = null then
+ Exec_Name := new String (1 .. Len_Arg (0));
+ Osint.Fill_Arg (Exec_Name (1)'Address, 0);
+ end if;
+
+ -- First determine if a path prefix was placed in front of the
+ -- executable name.
+
+ for J in reverse Exec_Name'Range loop
+ if Is_Directory_Separator (Exec_Name (J)) then
+ return Get_Install_Dir (Exec_Name.all);
+ end if;
+ end loop;
+
+ -- If we come here, the user has typed the executable name with no
+ -- directory prefix.
+
+ return Get_Install_Dir (Locate_Exec_On_Path (Exec_Name.all).all);
+ end Executable_Prefix;
+
------------------
-- Exit_Program --
------------------
procedure Exit_Program (Exit_Code : Exit_Code_Type) is
begin
-- The program will exit with the following status:
+
-- 0 if the object file has been generated (with or without warnings)
-- 1 if recompilation was not needed (smart recompilation)
-- 2 if gnat1 has been killed by a signal (detected by GCC)
- -- 3 if no code has been generated (spec)
-- 4 for a fatal error
-- 5 if there were errors
+ -- 6 if no code has been generated (spec)
+
+ -- Note that exit code 3 is not used and must not be used as this is
+ -- the code returned by a program aborted via C abort() routine on
+ -- Windows. GCC checks for that case and thinks that the child process
+ -- has been aborted. This code (exit code 3) used to be the code used
+ -- for E_No_Code, but E_No_Code was changed to 6 for this reason.
case Exit_Code is
when E_Success => OS_Exit (0);
when E_Warnings => OS_Exit (0);
when E_No_Compile => OS_Exit (1);
- when E_No_Code => OS_Exit (3);
when E_Fatal => OS_Exit (4);
when E_Errors => OS_Exit (5);
+ when E_No_Code => OS_Exit (6);
when E_Abort => OS_Abort;
end case;
end Exit_Program;
-- 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;
- -- ??? Using Output is ugly, should do direct writes
- -- ??? shouldn't this go to standard error instead of stdout?
-
Exit_Program (E_Fatal);
end Fail;
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
+ begin
+ return File_Stamp (File_Name_Type (Name));
end File_Stamp;
---------------
---------------
function Find_File
- (N : File_Name_Type;
- T : File_Type)
- return File_Name_Type
+ (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);
+ and then Current_Main = N
+ then
+ Locate_File (N, T, Primary_Directory, File_Name, Found, Attr);
+ return;
-- Otherwise do standard search for source file
else
+ -- Check the mapping of this file name
+
+ File := Mapped_Path_Name (N);
+
+ -- If the file name is mapped to a path name, return the
+ -- corresponding path name
+
+ if File /= No_File then
+
+ -- For locally removed file, Error_Name is returned; then
+ -- return No_File, indicating the file is not a source.
+
+ if File = Error_File_Name then
+ Found := No_File;
+ else
+ 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;
procedure Find_Program_Name is
Command_Name : String (1 .. Len_Arg (0));
- Cindex1 : Integer := Command_Name'First;
- Cindex2 : Integer := Command_Name'Last;
+ Cindex1 : Integer := Command_Name'First;
+ Cindex2 : Integer := Command_Name'Last;
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.
end if;
end loop;
- for J in reverse Cindex1 .. Cindex2 loop
- if Command_Name (J) = '.' then
- Cindex2 := J - 1;
- exit;
+ -- Command_Name(Cindex1 .. Cindex2) is now the equivalent of the
+ -- POSIX command "basename argv[0]"
+
+ -- Strip off any versioning information such as found on VMS.
+ -- This would take the form of TOOL.exe followed by a ";" or "."
+ -- and a sequence of one or more numbers.
+
+ if Command_Name (Cindex2) in '0' .. '9' then
+ for J in reverse Cindex1 .. Cindex2 loop
+ if Command_Name (J) = '.' or else Command_Name (J) = ';' then
+ Cindex2 := J - 1;
+ exit;
+ end if;
+
+ exit when Command_Name (J) not in '0' .. '9';
+ end loop;
+ end if;
+
+ -- Strip off any executable extension (usually nothing or .exe)
+ -- but formally reported by autoconf in the variable EXEEXT
+
+ if Cindex2 - Cindex1 >= 4 then
+ if To_Lower (Command_Name (Cindex2 - 3)) = '.'
+ and then To_Lower (Command_Name (Cindex2 - 2)) = 'e'
+ and then To_Lower (Command_Name (Cindex2 - 1)) = 'x'
+ and then To_Lower (Command_Name (Cindex2)) = 'e'
+ then
+ Cindex2 := Cindex2 - 4;
end if;
- end loop;
+ end if;
Name_Len := Cindex2 - Cindex1 + 1;
Name_Buffer (1 .. Name_Len) := Command_Name (Cindex1 .. Cindex2);
-- 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 --
-------------------
-- call to Get_Next_Dir_In_Path_Init, updated by Get_Next_Dir_In_Path.
function Get_Next_Dir_In_Path
- (Search_Path : String_Access)
- return String_Access
+ (Search_Path : String_Access) return String_Access
is
Lower_Bound : Positive := Search_Path_Pos;
Upper_Bound : Positive;
return Src_Search_Directories.Table (Primary_Directory);
end Get_Primary_Src_Search_Directory;
- ----------------
- -- Initialize --
- ----------------
+ ------------------------
+ -- Get_RTS_Search_Dir --
+ ------------------------
- procedure Initialize (P : Program_Type) is
- function Get_Default_Identifier_Character_Set return Character;
- pragma Import (C, Get_Default_Identifier_Character_Set,
- "__gnat_get_default_identifier_character_set");
- -- Function to determine the default identifier character set,
- -- which is system dependent. See Opt package spec for a list of
- -- the possible character codes and their interpretations.
+ function Get_RTS_Search_Dir
+ (Search_Dir : String;
+ File_Type : Search_File_Type) return String_Ptr
+ is
+ procedure Get_Current_Dir
+ (Dir : System.Address;
+ Length : System.Address);
+ pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir");
+
+ Max_Path : Integer;
+ pragma Import (C, Max_Path, "__gnat_max_path_len");
+ -- Maximum length of a path name
+
+ Current_Dir : String_Ptr;
+ Default_Search_Dir : String_Access;
+ Default_Suffix_Dir : String_Access;
+ Local_Search_Dir : String_Access;
+ Norm_Search_Dir : String_Access;
+ Result_Search_Dir : String_Access;
+ Search_File : String_Access;
+ Temp_String : String_Ptr;
+
+ begin
+ -- Add a directory separator at the end of the directory if necessary
+ -- so that we can directly append a file to the directory
+
+ if Search_Dir (Search_Dir'Last) /= Directory_Separator then
+ Local_Search_Dir :=
+ new String'(Search_Dir & String'(1 => Directory_Separator));
+ else
+ Local_Search_Dir := new String'(Search_Dir);
+ end if;
- function Get_Maximum_File_Name_Length return Int;
- pragma Import (C, Get_Maximum_File_Name_Length,
- "__gnat_get_maximum_file_name_length");
- -- Function to get maximum file name length for system
+ if File_Type = Include then
+ Search_File := Include_Search_File;
+ Default_Suffix_Dir := new String'("adainclude");
+ else
+ Search_File := Objects_Search_File;
+ Default_Suffix_Dir := new String'("adalib");
+ end if;
- procedure Adjust_OS_Resource_Limits;
- pragma Import (C, Adjust_OS_Resource_Limits,
- "__gnat_adjust_os_resource_limits");
- -- Procedure to make system specific adjustments to make GNAT
- -- run better.
+ Norm_Search_Dir := To_Canonical_Path_Spec (Local_Search_Dir.all);
- -- Start of processing for Initialize
+ if Is_Absolute_Path (Norm_Search_Dir.all) then
- begin
- Program := P;
+ -- We first verify if there is a directory Include_Search_Dir
+ -- containing default search directories
- case Program is
- when Binder => In_Binder := True;
- when Compiler => In_Compiler := True;
- when Make => In_Make := True;
- end case;
+ Result_Search_Dir :=
+ Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
+ Default_Search_Dir :=
+ new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
+ Free (Norm_Search_Dir);
- if In_Compiler then
- Adjust_OS_Resource_Limits;
- end if;
+ if Result_Search_Dir /= null then
+ return String_Ptr (Result_Search_Dir);
+ elsif Is_Directory (Default_Search_Dir.all) then
+ return String_Ptr (Default_Search_Dir);
+ else
+ return null;
+ end if;
- Src_Search_Directories.Init;
- Lib_Search_Directories.Init;
+ -- Search in the current directory
- Identifier_Character_Set := Get_Default_Identifier_Character_Set;
- Maximum_File_Name_Length := Get_Maximum_File_Name_Length;
+ else
+ -- Get the current directory
- -- Following should be removed by having above function return
- -- Integer'Last as indication of no maximum instead of -1 ???
+ declare
+ Buffer : String (1 .. Max_Path + 2);
+ Path_Len : Natural := Max_Path;
- if Maximum_File_Name_Length = -1 then
- Maximum_File_Name_Length := Int'Last;
+ begin
+ Get_Current_Dir (Buffer'Address, Path_Len'Address);
+
+ if Buffer (Path_Len) /= Directory_Separator then
+ Path_Len := Path_Len + 1;
+ Buffer (Path_Len) := Directory_Separator;
+ end if;
+
+ Current_Dir := new String'(Buffer (1 .. Path_Len));
+ end;
+
+ Norm_Search_Dir :=
+ new String'(Current_Dir.all & Local_Search_Dir.all);
+
+ Result_Search_Dir :=
+ Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
+
+ Default_Search_Dir :=
+ new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
+
+ Free (Norm_Search_Dir);
+
+ if Result_Search_Dir /= null then
+ return String_Ptr (Result_Search_Dir);
+
+ elsif Is_Directory (Default_Search_Dir.all) then
+ return String_Ptr (Default_Search_Dir);
+
+ else
+ -- Search in Search_Dir_Prefix/Search_Dir
+
+ Norm_Search_Dir :=
+ new String'
+ (Update_Path (Search_Dir_Prefix).all & Local_Search_Dir.all);
+
+ Result_Search_Dir :=
+ Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
+
+ Default_Search_Dir :=
+ new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
+
+ Free (Norm_Search_Dir);
+
+ if Result_Search_Dir /= null then
+ return String_Ptr (Result_Search_Dir);
+
+ elsif Is_Directory (Default_Search_Dir.all) then
+ return String_Ptr (Default_Search_Dir);
+
+ else
+ -- We finally search in Search_Dir_Prefix/rts-Search_Dir
+
+ Temp_String :=
+ new String'(Update_Path (Search_Dir_Prefix).all & "rts-");
+
+ Norm_Search_Dir :=
+ new String'(Temp_String.all & Local_Search_Dir.all);
+
+ Result_Search_Dir :=
+ Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
+
+ Default_Search_Dir :=
+ new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
+ Free (Norm_Search_Dir);
+
+ if Result_Search_Dir /= null then
+ return String_Ptr (Result_Search_Dir);
+
+ elsif Is_Directory (Default_Search_Dir.all) then
+ return String_Ptr (Default_Search_Dir);
+
+ else
+ return null;
+ end if;
+ end if;
+ end if;
+ end if;
+ end Get_RTS_Search_Dir;
+
+ --------------------------------
+ -- Include_Dir_Default_Prefix --
+ --------------------------------
+
+ function Include_Dir_Default_Prefix return String_Access is
+ begin
+ 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;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ Number_File_Names := 0;
+ Current_File_Name_Index := 0;
+
+ Src_Search_Directories.Init;
+ Lib_Search_Directories.Init;
+
-- Start off by setting all suppress options to False, these will
-- be reset later (turning some on if -gnato is not specified, and
-- turning all of them on if -gnatp is specified).
Suppress_Options := (others => False);
- -- Set software overflow check flag. For now all targets require the
- -- use of software overflow checks. Later on, this will have to be
- -- specialized to the backend target. Also, if software overflow
- -- checking mode is set, then the default for suppressing overflow
- -- checks is True, since the software approach is expensive.
-
- Software_Overflow_Checking := True;
- Suppress_Options.Overflow_Checks := True;
-
-- Reserve the first slot in the search paths table. This is the
- -- directory of the main source file or main library file and is
- -- filled in by each call to Next_Main_Source/Next_Main_Lib_File with
- -- the directory specified for this main source or library file. This
- -- is the directory which is searched first by default. This default
- -- search is inhibited by the option -I- for both source and library
- -- files.
+ -- directory of the main source file or main library file and is filled
+ -- in by each call to Next_Main_Source/Next_Main_Lib_File with the
+ -- directory specified for this main source or library file. This is the
+ -- directory which is searched first by default. This default search is
+ -- inhibited by the option -I- for both source and library files.
Src_Search_Directories.Set_Last (Primary_Directory);
Src_Search_Directories.Table (Primary_Directory) := new String'("");
Lib_Search_Directories.Set_Last (Primary_Directory);
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 --
----------------------------
-- Is_Readonly_Library --
-------------------------
- function Is_Readonly_Library (File : in File_Name_Type) return Boolean is
+ function Is_Readonly_Library (File : File_Name_Type) return Boolean is
begin
Get_Name_String (File);
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 --
-------------------
function Lib_File_Name
- (Source_File : File_Name_Type)
- return File_Name_Type
+ (Source_File : File_Name_Type;
+ Munit_Index : Nat := 0) return File_Name_Type
is
- Fptr : Natural;
- -- Pointer to location to set extension in place
-
begin
Get_Name_String (Source_File);
- Fptr := Name_Len + 1;
- for J in reverse 1 .. Name_Len loop
+ for J in reverse 2 .. Name_Len loop
if Name_Buffer (J) = '.' then
- Fptr := J;
+ Name_Len := J - 1;
exit;
end if;
end loop;
- Name_Buffer (Fptr) := '.';
- Name_Buffer (Fptr + 1 .. Fptr + ALI_Suffix'Length) := ALI_Suffix.all;
- Name_Buffer (Fptr + ALI_Suffix'Length + 1) := ASCII.NUL;
- Name_Len := Fptr + ALI_Suffix'Length;
+ if Munit_Index /= 0 then
+ Add_Char_To_Name_Buffer (Multi_Unit_Index_Character);
+ Add_Nat_To_Name_Buffer (Munit_Index);
+ end if;
+
+ Add_Char_To_Name_Buffer ('.');
+ Add_Str_To_Name_Buffer (ALI_Suffix.all);
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;
begin
- if T = Library then
+ -- If Name is already an absolute path, do not look for a directory
+
+ if Is_Absolute_Path (Name) then
+ Dir_Name := No_Dir;
+
+ elsif T = Library then
Dir_Name := Lib_Search_Directories.Table (Dir);
- else pragma Assert (T = Source);
+ 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;
+
+ Attr.all := Unknown_Attributes;
- if not Is_Regular_File (Full_Name) then
- return No_File;
+ 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;
-------------------------------
function Matching_Full_Source_Name
- (N : File_Name_Type;
- T : Time_Stamp_Type)
- return File_Name_Type
+ (N : File_Name_Type;
+ T : Time_Stamp_Type) return File_Name_Type
is
begin
Get_Name_String (N);
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 (Current_File_Name_Index < Number_File_Names);
end More_Files;
- --------------------
- -- More_Lib_Files --
- --------------------
-
- function More_Lib_Files return Boolean is
- begin
- pragma Assert (In_Binder);
- return More_Files;
- end More_Lib_Files;
-
- -----------------------
- -- More_Source_Files --
- -----------------------
-
- function More_Source_Files return Boolean is
- begin
- pragma Assert (In_Compiler or else In_Make);
- return More_Files;
- end More_Source_Files;
-
-------------------------------
-- Nb_Dir_In_Obj_Search_Path --
-------------------------------
Dir_Name := new String'(File_Name (File_Name'First .. Fptr - 1));
- if In_Compiler then
- Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
- Look_In_Primary_Directory_For_Current_Main := True;
+ case Running_Program is
- elsif In_Make then
- Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
- if Fptr > File_Name'First then
+ when Compiler =>
+ Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
Look_In_Primary_Directory_For_Current_Main := True;
- end if;
- else pragma Assert (In_Binder);
- Dir_Name := Normalize_Directory_Name (Dir_Name.all);
- Lib_Search_Directories.Table (Primary_Directory) := Dir_Name;
- end if;
+ when Make =>
+ Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
+
+ if Fptr > File_Name'First then
+ Look_In_Primary_Directory_For_Current_Main := True;
+ end if;
+
+ when Binder | Gnatls =>
+ Dir_Name := Normalize_Directory_Name (Dir_Name.all);
+ Lib_Search_Directories.Table (Primary_Directory) := Dir_Name;
+
+ when Unspecified =>
+ null;
+ end case;
Name_Len := File_Name'Last - Fptr + 1;
Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last);
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
- Current_Main := File_Name_Type (Name_Find);
+ Current_Main := Name_Find;
-- In the gnatmake case, the main file may have not have the
-- extension. Try ".adb" first then ".ads"
- if In_Make then
+ if Running_Program = Make then
declare
- Orig_Main : File_Name_Type := Current_Main;
+ Orig_Main : constant File_Name_Type := Current_Main;
begin
if Strip_Suffix (Orig_Main) = Orig_Main then
- Current_Main := Append_Suffix_To_File_Name (Orig_Main, ".adb");
+ Current_Main :=
+ Append_Suffix_To_File_Name (Orig_Main, ".adb");
if Full_Source_Name (Current_Main) = No_File then
Current_Main :=
return Current_Main;
end Next_Main_File;
- ------------------------
- -- Next_Main_Lib_File --
- ------------------------
+ ------------------------------
+ -- Normalize_Directory_Name --
+ ------------------------------
- function Next_Main_Lib_File return File_Name_Type is
- begin
- pragma Assert (In_Binder);
- return Next_Main_File;
- end Next_Main_Lib_File;
+ function Normalize_Directory_Name (Directory : String) return String_Ptr is
- ----------------------
- -- Next_Main_Source --
- ----------------------
+ function Is_Quoted (Path : String) return Boolean;
+ pragma Inline (Is_Quoted);
+ -- Returns true if Path is quoted (either double or single quotes)
- function Next_Main_Source return File_Name_Type is
- Main_File : File_Name_Type := Next_Main_File;
+ ---------------
+ -- Is_Quoted --
+ ---------------
- begin
- pragma Assert (In_Compiler or else In_Make);
- return Main_File;
- end Next_Main_Source;
+ function Is_Quoted (Path : String) return Boolean is
+ First : constant Character := Path (Path'First);
+ Last : constant Character := Path (Path'Last);
- ------------------------------
- -- Normalize_Directory_Name --
- ------------------------------
+ begin
+ if (First = ''' and then Last = ''')
+ or else
+ (First = '"' and then Last = '"')
+ then
+ return True;
+ else
+ return False;
+ end if;
+ end Is_Quoted;
- function Normalize_Directory_Name (Directory : String) return String_Ptr is
Result : String_Ptr;
+ -- Start of processing for Normalize_Directory_Name
+
begin
if Directory'Length = 0 then
Result := new String'(Hostparm.Normalized_CWD);
elsif Is_Directory_Separator (Directory (Directory'Last)) then
Result := new String'(Directory);
+
+ elsif Is_Quoted (Directory) then
+
+ -- This is a quoted string, it certainly means that the directory
+ -- contains some spaces for example. We can safely remove the quotes
+ -- here as the OS_Lib.Normalize_Arguments will be called before any
+ -- spawn routines. This ensure that quotes will be added when needed.
+
+ Result := new String (1 .. Directory'Length - 1);
+ Result (1 .. Directory'Length - 2) :=
+ Directory (Directory'First + 1 .. Directory'Last - 1);
+ Result (Result'Last) := Directory_Separator;
+
else
Result := new String (1 .. Directory'Length + 1);
Result (1 .. Directory'Length) := Directory;
return Number_File_Names;
end Number_Of_Files;
+ -------------------------------
+ -- Object_Dir_Default_Prefix --
+ -------------------------------
+
+ function Object_Dir_Default_Prefix return String is
+ Object_Dir : String_Access :=
+ String_Access (Update_Path (Object_Dir_Default_Name));
+
+ begin
+ if Object_Dir = null then
+ return "";
+
+ else
+ declare
+ Result : constant String := Object_Dir.all;
+ begin
+ Free (Object_Dir);
+ return Result;
+ end;
+ end if;
+ end Object_Dir_Default_Prefix;
+
----------------------
-- Object_File_Name --
----------------------
Get_Name_String (N);
Name_Len := Name_Len - ALI_Suffix'Length - 1;
- for J in Object_Suffix'Range loop
+ for J in Target_Object_Suffix'Range loop
Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := Object_Suffix (J);
+ Name_Buffer (Name_Len) := Target_Object_Suffix (J);
end loop;
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 --
--------------------------
Mn : Minute_Type;
S : Second_Type;
- begin
+ 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-"
+ Start_Of_Suffix := Name_Len + 1;
+
+ -- 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"
- while Name_Len > 0 loop
- 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;
+
+ -- Find End_Of_Prefix
- Name_Len := Name_Len - 1;
+ 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;
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;
------------------------------
function Read_Default_Search_Dirs
(Search_Dir_Prefix : String_Access;
Search_File : String_Access;
- Search_Dir_Default_Name : String_Access)
- return String_Access
+ Search_Dir_Default_Name : String_Access) return String_Access
is
- function Is_Relative (S : String; K : Positive) return Boolean;
- -- Returns True if a relative directory specification is found in S at
- -- position K.
-
- function Is_Relative (S : String; K : Positive) return Boolean is
- begin
- return
- not (Is_Directory_Separator (S (K)) -- Unix style absolute pathname
-
- or else -- DOS style absolute pathname with drive letter
-
- (S'Last > K + 2
- and then
- (S (K) in 'a' .. 'z' or else S (K) in 'A' .. 'Z')
- and then
- S (K + 1) = ':'
- and then
- Is_Directory_Separator (S (K + 2))));
- end Is_Relative;
-
Prefix_Len : constant Integer := Search_Dir_Prefix.all'Length;
Buffer : String (1 .. Prefix_Len + Search_File.all'Length + 1);
File_FD : File_Descriptor;
-- Start of processing for Read_Default_Search_Dirs
begin
- -- Construct a C compatible character string buffer.
+ -- Construct a C compatible character string buffer
Buffer (1 .. Search_Dir_Prefix.all'Length)
:= Search_Dir_Prefix.all;
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;
else
if Prev_Was_Separator and then Is_Relative (S.all, J) then
- S1 (J1 .. J1 + Prefix_Len) := Search_Dir_Prefix.all;
+ S1 (J1 .. J1 + Prefix_Len - 1) := Search_Dir_Prefix.all;
J1 := J1 + Prefix_Len;
end if;
function Read_Library_Info
(Lib_File : File_Name_Type;
- Fatal_Err : Boolean := False)
- return Text_Buffer_Ptr
+ 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.
+ -- 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 that
- -- the object is consistent.
+ -- 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.
- if Is_Readonly_Library (Current_Full_Lib_Name) then
+ Get_Name_String (Current_Full_Lib_Name);
+ Name_Buffer (Name_Len + 1) := ASCII.NUL;
+
+ if not Is_Writable_File (Name_Buffer'Address, Lib_File_Attr) then
Current_Full_Obj_Stamp := Current_Full_Lib_Stamp;
elsif Fatal_Err then
Get_Name_String (Current_Full_Obj_Name);
- Close (Lib_FD);
- Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
+ Close (Lib_FD, Status);
- else
- Current_Full_Obj_Stamp := Empty_Time_Stamp;
- Close (Lib_FD);
- return null;
- end if;
- end if;
+ -- No need to check the status, we fail anyway
- -- Object file exists, compare object and ALI time stamps
+ Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
- if Current_Full_Lib_Stamp > Current_Full_Obj_Stamp then
- if Fatal_Err then
- Get_Name_String (Current_Full_Obj_Name);
- Close (Lib_FD);
- Fail ("Bad time stamp: ", Name_Buffer (1 .. Name_Len));
else
Current_Full_Obj_Stamp := Empty_Time_Stamp;
- Close (Lib_FD);
+ Close (Lib_FD, Status);
+
+ -- No need to check the status, we return null anyway
+
return null;
end if;
end if;
-- Read data from the file
declare
- Len : 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 : Text_Ptr := 0;
+ Lo : constant Text_Ptr := 0;
-- Low bound for allocated text buffer
Hi : Text_Ptr := Text_Ptr (Len);
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;
-- Read is complete, close file and we are done
- Close (Lib_FD);
- return Text;
-
- end Read_Library_Info;
+ Close (Lib_FD, Status);
+ -- The status should never be False. But, if it is, what can we do?
+ -- So, we don't test it.
- -- Version with default file name
+ return Text;
- procedure Read_Library_Info
- (Name : out File_Name_Type;
- Text : out Text_Buffer_Ptr)
- is
- begin
- Set_Library_Info_Name;
- Name := Name_Find;
- Text := Read_Library_Info (Name, Fatal_Err => False);
- 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
Current_Full_Source_Name := Find_File (N, T);
Current_Full_Source_Stamp := File_Stamp (Current_Full_Source_Name);
if Current_Full_Source_Name = No_File then
- -- If we were trying to access the main file and we could not
- -- find it we have an error.
+ -- If we were trying to access the main file and we could not find
+ -- it, we have an error.
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));
type Actual_Source_Ptr is access Actual_Source_Buffer;
-- This is the pointer type for the physical buffer allocated
- Actual_Ptr : Actual_Source_Ptr := new Actual_Source_Buffer;
+ Actual_Ptr : constant Actual_Source_Ptr := new Actual_Source_Buffer;
-- And this is the actual physical buffer
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);
+ pragma Warnings (Off);
+ -- This use of unchecked conversion is aliasing safe
+
function To_Source_Buffer_Ptr is new
Unchecked_Conversion (Address, Source_Buffer_Ptr);
+ pragma Warnings (On);
+
begin
Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
end;
-- Read is complete, get time stamp and close file and we are done
- Close (Source_File_FD);
+ Close (Source_File_FD, Status);
- end Read_Source_File;
+ -- The status should never be False. But, if it is, what can we do?
+ -- So, we don't test it.
- --------------------------------
- -- Record_Time_From_Last_Bind --
- --------------------------------
+ end Read_Source_File;
- procedure Record_Time_From_Last_Bind is
- begin
- Recording_Time_From_Last_Bind := True;
- end Record_Time_From_Last_Bind;
+ -------------------
+ -- Relocate_Path --
+ -------------------
- ---------------------------
- -- Set_Library_Info_Name --
- ---------------------------
+ function Relocate_Path
+ (Prefix : String;
+ Path : String) return String_Ptr
+ is
+ S : String_Ptr;
- procedure Set_Library_Info_Name is
- Dot_Index : Natural;
+ procedure set_std_prefix (S : String; Len : Integer);
+ pragma Import (C, set_std_prefix);
begin
- pragma Assert (In_Compiler);
- Get_Name_String (Current_Main);
+ if Std_Prefix = null then
+ Std_Prefix := Executable_Prefix;
- -- Find last dot since we replace the existing extension by .ali. The
- -- initialization to Name_Len + 1 provides for simply adding the .ali
- -- extension if the source file name has no extension.
-
- Dot_Index := Name_Len + 1;
- for J in reverse 1 .. Name_Len loop
- if Name_Buffer (J) = '.' then
- Dot_Index := J;
- exit;
- end if;
- end loop;
+ if Std_Prefix.all /= "" then
- -- Make sure that the output file name matches the source file name.
- -- To compare them, remove file name directories and extensions.
+ -- Remove trailing directory separator when calling set_std_prefix
- if Output_Object_File_Name /= null then
- declare
- Name : constant String := Name_Buffer (1 .. Dot_Index);
- Len : constant Natural := Dot_Index;
+ set_std_prefix (Std_Prefix.all, Std_Prefix'Length - 1);
+ end if;
+ end if;
- begin
- Name_Buffer (1 .. Output_Object_File_Name'Length)
- := Output_Object_File_Name.all;
- Dot_Index := 0;
+ if Path (Prefix'Range) = Prefix then
+ if Std_Prefix.all /= "" then
+ S := new String
+ (1 .. Std_Prefix'Length + Path'Last - Prefix'Last);
+ S (1 .. Std_Prefix'Length) := Std_Prefix.all;
+ S (Std_Prefix'Length + 1 .. S'Last) :=
+ Path (Prefix'Last + 1 .. Path'Last);
+ return S;
+ end if;
+ end if;
- for J in reverse Output_Object_File_Name'Range loop
- if Name_Buffer (J) = '.' then
- Dot_Index := J;
- exit;
- end if;
- end loop;
+ return new String'(Path);
+ end Relocate_Path;
- pragma Assert (Dot_Index /= 0);
- -- We check for the extension elsewhere
+ -----------------
+ -- Set_Program --
+ -----------------
- if Name /= Name_Buffer (Dot_Index - Len + 1 .. Dot_Index) then
- Fail ("incorrect object file name");
- end if;
- end;
+ procedure Set_Program (P : Program_Type) is
+ begin
+ if Program_Set then
+ Fail ("Set_Program called twice");
end if;
- Name_Buffer (Dot_Index) := '.';
- Name_Buffer (Dot_Index + 1 .. Dot_Index + 3) := ALI_Suffix.all;
- Name_Buffer (Dot_Index + 4) := ASCII.NUL;
- Name_Len := Dot_Index + 3;
- end Set_Library_Info_Name;
+ Program_Set := True;
+ Running_Program := P;
+ end Set_Program;
- ---------------------------------
- -- Set_Output_Object_File_Name --
- ---------------------------------
+ ----------------
+ -- Shared_Lib --
+ ----------------
- procedure Set_Output_Object_File_Name (Name : String) is
- Ext : constant String := Object_Suffix;
- NL : constant Natural := Name'Length;
- EL : constant Natural := Ext'Length;
+ function Shared_Lib (Name : String) return String is
+ Library : String (1 .. Name'Length + Library_Version'Length + 3);
+ -- 3 = 2 for "-l" + 1 for "-" before lib version
begin
- -- Make sure that the object file has the expected extension.
+ Library (1 .. 2) := "-l";
+ Library (3 .. 2 + Name'Length) := Name;
+ Library (3 + Name'Length) := '-';
+ Library (4 + Name'Length .. Library'Last) := Library_Version;
- if NL <= EL
- or else Name (NL - EL + Name'First .. Name'Last) /= Ext
- then
- Fail ("incorrect object file extension");
+ if OpenVMS_On_Target then
+ for K in Library'First + 2 .. Library'Last loop
+ if Library (K) = '.' or else Library (K) = '-' then
+ Library (K) := '_';
+ end if;
+ end loop;
end if;
- Output_Object_File_Name := new String'(Name);
- end Set_Output_Object_File_Name;
-
- ------------------------
- -- Set_Main_File_Name --
- ------------------------
-
- procedure Set_Main_File_Name (Name : String) is
- begin
- Number_File_Names := Number_File_Names + 1;
- File_Names (Number_File_Names) := new String'(Name);
- end Set_Main_File_Name;
+ return Library;
+ end Shared_Lib;
----------------------
-- Smart_File_Stamp --
----------------------
function Smart_File_Stamp
- (N : File_Name_Type;
- T : File_Type)
- return Time_Stamp_Type
+ (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;
---------------------
function Smart_Find_File
(N : File_Name_Type;
- T : File_Type)
- return File_Name_Type
+ T : File_Type) return File_Name_Type
+ is
+ 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
- Full_File_Name : File_Name_Type;
+ 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;
----------------------
begin
Get_Name_String (Name);
- declare
- S : String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
- Fptr : Natural := S'First;
+ for J in reverse 1 .. Name_Len - 1 loop
- begin
- for J in reverse S'Range loop
- if Is_Directory_Separator (S (J)) then
- Fptr := J + 1;
- exit;
- end if;
- end loop;
+ -- If we find the last directory separator
- if Fptr = S'First then
- return Name;
+ if Is_Directory_Separator (Name_Buffer (J)) then
+
+ -- 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;
+ return Name_Find;
end if;
+ end loop;
- Name_Buffer (1 .. S'Last - Fptr + 1) := S (Fptr .. S'Last);
- Name_Len := S'Last - Fptr + 1;
- return Name_Find;
- end;
+ -- There were no directory separator, just return Name
+
+ return Name;
end Strip_Directory;
------------------
begin
Get_Name_String (Name);
- for J in reverse 1 .. Name_Len loop
+ for J in reverse 2 .. Name_Len loop
+
+ -- If we found the last '.', return part of Name that precedes it
+
if Name_Buffer (J) = '.' then
Name_Len := J - 1;
return Name_Enter;
return Name;
end Strip_Suffix;
- -------------------------
- -- Time_From_Last_Bind --
- -------------------------
-
- function Time_From_Last_Bind return Nat is
- Old_Y : Nat;
- Old_M : Nat;
- Old_D : Nat;
- Old_H : Nat;
- Old_Mi : Nat;
- Old_S : Nat;
- New_Y : Nat;
- New_M : Nat;
- New_D : Nat;
- New_H : Nat;
- New_Mi : Nat;
- New_S : Nat;
-
- type Month_Data is array (Int range 1 .. 12) of Int;
- Cumul : constant Month_Data := (0, 0, 3, 3, 4, 4, 5, 5, 5, 6, 6, 7);
- -- Represents the difference in days from a period compared to the
- -- same period if all months had 31 days, i.e:
- --
- -- Cumul (m) = 31x(m-1) - (number of days from 01/01 to m/01)
-
- Res : Int;
-
- begin
- if not Recording_Time_From_Last_Bind
- or else not Binder_Output_Time_Stamps_Set
- or else Old_Binder_Output_Time_Stamp = Empty_Time_Stamp
- then
- return Nat'Last;
- end if;
-
- Split_Time_Stamp
- (Old_Binder_Output_Time_Stamp,
- Old_Y, Old_M, Old_D, Old_H, Old_Mi, Old_S);
-
- Split_Time_Stamp
- (New_Binder_Output_Time_Stamp,
- New_Y, New_M, New_D, New_H, New_Mi, New_S);
-
- Res := New_Mi - Old_Mi;
-
- -- 60 minutes in an hour
-
- Res := Res + 60 * (New_H - Old_H);
-
- -- 24 hours in a day
-
- Res := Res + 60 * 24 * (New_D - Old_D);
-
- -- Almost 31 days in a month
-
- Res := Res + 60 * 24 *
- (31 * (New_M - Old_M) - Cumul (New_M) + Cumul (Old_M));
-
- -- 365 days in a year
-
- Res := Res + 60 * 24 * 365 * (New_Y - Old_Y);
-
- return Res;
- end Time_From_Last_Bind;
-
---------------------------
-- To_Canonical_Dir_Spec --
---------------------------
function To_Canonical_Dir_Spec
(Host_Dir : String;
- Prefix_Style : Boolean)
- return String_Access
+ Prefix_Style : Boolean) return String_Access
is
function To_Canonical_Dir_Spec
(Host_Dir : Address;
- Prefix_Flag : Integer)
- return Address;
+ 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;
function To_Canonical_File_List
(Wildcard_Host_File : String;
- Only_Dirs : Boolean)
- return String_Access_List_Access
+ Only_Dirs : Boolean) return String_Access_List_Access
is
function To_Canonical_File_List_Init
(Host_File : Address;
- Only_Dirs : Integer)
- return Integer;
+ Only_Dirs : Integer) return Integer;
pragma Import (C, To_Canonical_File_List_Init,
"__gnat_to_canonical_file_list_init");
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;
----------------------------
function To_Canonical_File_Spec
- (Host_File : String)
- return String_Access
+ (Host_File : String) return String_Access
is
function To_Canonical_File_Spec (Host_File : Address) return Address;
pragma Import
(C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
- C_Host_File : String (1 .. Host_File'Length + 1);
+ C_Host_File : String (1 .. Host_File'Length + 1);
Canonical_File_Addr : Address;
Canonical_File_Len : Integer;
exception
when others =>
- Fail ("erroneous file spec: ", Host_File);
+ Fail ("erroneous file spec: " & Host_File);
return null;
end To_Canonical_File_Spec;
----------------------------
function To_Canonical_Path_Spec
- (Host_Path : String)
- return String_Access
+ (Host_Path : String) return String_Access
is
function To_Canonical_Path_Spec (Host_Path : Address) return Address;
pragma Import
exception
when others =>
- Fail ("erroneous path spec: ", Host_Path);
+ Fail ("erroneous path spec: " & Host_Path);
return null;
end To_Canonical_Path_Spec;
function To_Host_Dir_Spec
(Canonical_Dir : String;
- Prefix_Style : Boolean)
- return String_Access
+ Prefix_Style : Boolean) return String_Access
is
function To_Host_Dir_Spec
(Canonical_Dir : Address;
- Prefix_Flag : Integer)
- return Address;
+ Prefix_Flag : Integer) return Address;
pragma Import (C, To_Host_Dir_Spec, "__gnat_to_host_dir_spec");
C_Canonical_Dir : String (1 .. Canonical_Dir'Length + 1);
----------------------------
function To_Host_File_Spec
- (Canonical_File : String)
- return String_Access
+ (Canonical_File : String) return String_Access
is
function To_Host_File_Spec (Canonical_File : Address) return Address;
pragma Import (C, To_Host_File_Spec, "__gnat_to_host_file_spec");
function To_Path_String_Access
(Path_Addr : Address;
- Path_Len : Integer)
- return String_Access
+ Path_Len : Integer) return String_Access
is
subtype Path_String is String (1 .. Path_Len);
- type Path_String_Access is access Path_String;
+ type Path_String_Access is access Path_String;
function Address_To_Access is new
Unchecked_Conversion (Source => Address,
Target => Path_String_Access);
- Path_Access : Path_String_Access := Address_To_Access (Path_Addr);
+ Path_Access : constant Path_String_Access :=
+ Address_To_Access (Path_Addr);
- Return_Val : String_Access;
+ Return_Val : String_Access;
begin
Return_Val := new String (1 .. Path_Len);
return Return_Val;
end To_Path_String_Access;
- ----------------
- -- Tree_Close --
- ----------------
-
- procedure Tree_Close is
- begin
- pragma Assert (In_Compiler);
- Tree_Write_Terminate;
- Close (Output_FD);
- end Tree_Close;
-
-----------------
- -- Tree_Create --
+ -- Update_Path --
-----------------
- procedure Tree_Create is
- Dot_Index : Natural;
-
- begin
- pragma Assert (In_Compiler);
- Get_Name_String (Current_Main);
-
- -- If an object file has been specified, then the ALI file
- -- will be in the same directory as the object file;
- -- so, we put the tree file in this same directory,
- -- even though no object file needs to be generated.
-
- if Output_Object_File_Name /= null then
- Name_Len := Output_Object_File_Name'Length;
- Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all;
- end if;
+ function Update_Path (Path : String_Ptr) return String_Ptr is
- Dot_Index := 0;
- for J in reverse 1 .. Name_Len loop
- if Name_Buffer (J) = '.' then
- Dot_Index := J;
- exit;
- end if;
- end loop;
+ function C_Update_Path (Path, Component : Address) return Address;
+ pragma Import (C, C_Update_Path, "update_path");
- -- Should be impossible to not have an extension
+ function Strlen (Str : Address) return Integer;
+ pragma Import (C, Strlen, "strlen");
- pragma Assert (Dot_Index /= 0);
+ procedure Strncpy (X : Address; Y : Address; Length : Integer);
+ pragma Import (C, Strncpy, "strncpy");
- -- Change exctension to adt
+ In_Length : constant Integer := Path'Length;
+ In_String : String (1 .. In_Length + 1);
+ Component_Name : aliased String := "GCC" & ASCII.NUL;
+ Result_Ptr : Address;
+ Result_Length : Integer;
+ Out_String : String_Ptr;
- Name_Buffer (Dot_Index + 1) := 'a';
- Name_Buffer (Dot_Index + 2) := 'd';
- Name_Buffer (Dot_Index + 3) := 't';
- Name_Buffer (Dot_Index + 4) := ASCII.NUL;
- Name_Len := Dot_Index + 3;
- Create_File_And_Check (Output_FD, Binary);
+ begin
+ In_String (1 .. In_Length) := Path.all;
+ In_String (In_Length + 1) := ASCII.NUL;
+ Result_Ptr := C_Update_Path (In_String'Address, Component_Name'Address);
+ Result_Length := Strlen (Result_Ptr);
- Tree_Write_Initialize (Output_FD);
- end Tree_Create;
+ Out_String := new String (1 .. Result_Length);
+ Strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
+ return Out_String;
+ end Update_Path;
----------------
-- Write_Info --
procedure Write_Info (Info : String) is
begin
- pragma Assert (In_Binder or In_Compiler);
Write_With_Check (Info'Address, Info'Length);
Write_With_Check (EOL'Address, 1);
end Write_Info;
- -----------------------
- -- Write_Binder_Info --
- -----------------------
-
- procedure Write_Binder_Info (Info : String) renames Write_Info;
-
- -----------------------
- -- Write_Debug_Info --
- -----------------------
-
- procedure Write_Debug_Info (Info : String) renames Write_Info;
-
- ------------------------
- -- Write_Library_Info --
- ------------------------
-
- procedure Write_Library_Info (Info : String) renames Write_Info;
-
------------------------
-- Write_Program_Name --
------------------------
procedure Write_Program_Name is
- Save_Buffer : String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
+ Save_Buffer : constant String (1 .. Name_Len) :=
+ Name_Buffer (1 .. Name_Len);
begin
-
Find_Program_Name;
-- Convert the name to lower case so error messages are the same on
procedure Write_With_Check (A : Address; N : Integer) is
Ignore : Boolean;
+ pragma Warnings (Off, Ignore);
begin
if N = Write (Output_FD, A, N) then
end if;
end Write_With_Check;
+----------------------------
+-- Package Initialization --
+----------------------------
+
+ procedure Reset_File_Attributes (Attr : System.Address);
+ pragma Import (C, Reset_File_Attributes, "__gnat_reset_attributes");
+
+begin
+ Initialization : declare
+
+ function Get_Default_Identifier_Character_Set return Character;
+ pragma Import (C, Get_Default_Identifier_Character_Set,
+ "__gnat_get_default_identifier_character_set");
+ -- Function to determine the default identifier character set,
+ -- which is system dependent. See Opt package spec for a list of
+ -- the possible character codes and their interpretations.
+
+ function Get_Maximum_File_Name_Length return Int;
+ pragma Import (C, Get_Maximum_File_Name_Length,
+ "__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;
+
+ -- Following should be removed by having above function return
+ -- Integer'Last as indication of no maximum instead of -1 ???
+
+ if Maximum_File_Name_Length = -1 then
+ Maximum_File_Name_Length := Int'Last;
+ end if;
+
+ Src_Search_Directories.Set_Last (Primary_Directory);
+ Src_Search_Directories.Table (Primary_Directory) := new String'("");
+
+ Lib_Search_Directories.Set_Last (Primary_Directory);
+ Lib_Search_Directories.Table (Primary_Directory) := new String'("");
+
+ Osint.Initialize;
+ end Initialization;
+
end Osint;
OSDN Git Service
