------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
-- --
|
-- --
|
-- GNAT COMPILER COMPONENTS --
|
-- GNAT COMPILER COMPONENTS --
|
-- --
|
-- --
|
-- O S I N T --
|
-- O S I N T --
|
-- --
|
-- --
|
-- B o d y --
|
-- B o d y --
|
-- --
|
-- --
|
-- Copyright (C) 1992-2009, 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 --
|
-- 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- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
-- 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- --
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
-- 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 --
|
-- for more details. You should have received a copy of the GNU General --
|
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
|
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
|
-- http://www.gnu.org/licenses for a complete copy of the license. --
|
-- http://www.gnu.org/licenses for a complete copy of the license. --
|
-- --
|
-- --
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
-- --
|
-- --
|
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
|
|
with Unchecked_Conversion;
|
with Unchecked_Conversion;
|
|
|
with System.Case_Util; use System.Case_Util;
|
with System.Case_Util; use System.Case_Util;
|
|
|
with GNAT.HTable;
|
with GNAT.HTable;
|
|
|
with Alloc;
|
with Alloc;
|
with Debug;
|
with Debug;
|
with Fmap; use Fmap;
|
with Fmap; use Fmap;
|
with Gnatvsn; use Gnatvsn;
|
with Gnatvsn; use Gnatvsn;
|
with Hostparm;
|
with Hostparm;
|
with Opt; use Opt;
|
with Opt; use Opt;
|
with Output; use Output;
|
with Output; use Output;
|
with Sdefault; use Sdefault;
|
with Sdefault; use Sdefault;
|
with Table;
|
with Table;
|
with Targparm; use Targparm;
|
with Targparm; use Targparm;
|
|
|
package body Osint is
|
package body Osint is
|
|
|
Running_Program : Program_Type := Unspecified;
|
Running_Program : Program_Type := Unspecified;
|
-- comment required here ???
|
-- comment required here ???
|
|
|
Program_Set : Boolean := False;
|
Program_Set : Boolean := False;
|
-- comment required here ???
|
-- comment required here ???
|
|
|
Std_Prefix : String_Ptr;
|
Std_Prefix : String_Ptr;
|
-- Standard prefix, computed dynamically the first time Relocate_Path
|
-- Standard prefix, computed dynamically the first time Relocate_Path
|
-- is called, and cached for subsequent calls.
|
-- is called, and cached for subsequent calls.
|
|
|
Empty : aliased String := "";
|
Empty : aliased String := "";
|
No_Dir : constant String_Ptr := Empty'Access;
|
No_Dir : constant String_Ptr := Empty'Access;
|
-- Used in Locate_File as a fake directory when Name is already an
|
-- Used in Locate_File as a fake directory when Name is already an
|
-- absolute path.
|
-- absolute path.
|
|
|
-------------------------------------
|
-------------------------------------
|
-- Use of Name_Find and Name_Enter --
|
-- Use of Name_Find and Name_Enter --
|
-------------------------------------
|
-------------------------------------
|
|
|
-- This package creates a number of source, ALI and object file names
|
-- 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
|
-- 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
|
-- construction. These names need not be accessible by Name_Find, and can
|
-- be therefore created by using routine Name_Enter. The files in question
|
-- 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
|
-- are file names with a prefix directory (i.e., the files not in the
|
-- current directory). File names without a prefix directory are entered
|
-- current directory). File names without a prefix directory are entered
|
-- with Name_Find because special values might be attached to the various
|
-- with Name_Find because special values might be attached to the various
|
-- Info fields of the corresponding name table entry.
|
-- Info fields of the corresponding name table entry.
|
|
|
-----------------------
|
-----------------------
|
-- Local Subprograms --
|
-- Local Subprograms --
|
-----------------------
|
-----------------------
|
|
|
function Append_Suffix_To_File_Name
|
function Append_Suffix_To_File_Name
|
(Name : File_Name_Type;
|
(Name : File_Name_Type;
|
Suffix : String) return File_Name_Type;
|
Suffix : String) return File_Name_Type;
|
-- Appends Suffix to Name and returns the new name
|
-- Appends Suffix to Name and returns the new name
|
|
|
function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type;
|
function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type;
|
-- Convert OS format time to GNAT format time stamp. If T is Invalid_Time,
|
-- Convert OS format time to GNAT format time stamp. If T is Invalid_Time,
|
-- then returns Empty_Time_Stamp.
|
-- then returns Empty_Time_Stamp.
|
|
|
function Executable_Prefix return String_Ptr;
|
function Executable_Prefix return String_Ptr;
|
-- Returns the name of the root directory where the executable is stored.
|
-- Returns the name of the root directory where the executable is stored.
|
-- The executable must be located in a directory called "bin", or under
|
-- The executable must be located in a directory called "bin", or under
|
-- root/lib/gcc-lib/..., or under root/libexec/gcc/... For example, if
|
-- root/lib/gcc-lib/..., or under root/libexec/gcc/... For example, if
|
-- executable is stored in directory "/foo/bar/bin", this routine returns
|
-- executable is stored in directory "/foo/bar/bin", this routine returns
|
-- "/foo/bar/". Return "" if location is not recognized as described above.
|
-- "/foo/bar/". Return "" if location is not recognized as described above.
|
|
|
function Update_Path (Path : String_Ptr) return String_Ptr;
|
function Update_Path (Path : String_Ptr) return String_Ptr;
|
-- Update the specified path to replace the prefix with the location where
|
-- Update the specified path to replace the prefix with the location where
|
-- GNAT is installed. See the file prefix.c in GCC for details.
|
-- GNAT is installed. See the file prefix.c in GCC for details.
|
|
|
procedure Locate_File
|
procedure Locate_File
|
(N : File_Name_Type;
|
(N : File_Name_Type;
|
T : File_Type;
|
T : File_Type;
|
Dir : Natural;
|
Dir : Natural;
|
Name : String;
|
Name : String;
|
Found : out File_Name_Type;
|
Found : out File_Name_Type;
|
Attr : access File_Attributes);
|
Attr : access File_Attributes);
|
-- See if the file N whose name is Name exists in directory Dir. Dir is an
|
-- 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
|
-- index into the Lib_Search_Directories table if T = Library. Otherwise
|
-- if T = Source, Dir is an index into the Src_Search_Directories table.
|
-- 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
|
-- Returns the File_Name_Type of the full file name if file found, or
|
-- No_File if not found.
|
-- No_File if not found.
|
--
|
--
|
-- On exit, Found is set to the file that was found, and Attr to a cache of
|
-- 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
|
-- its attributes (at least those that have been computed so far). Reusing
|
-- the cache will save some system calls.
|
-- the cache will save some system calls.
|
--
|
--
|
-- Attr is always reset in this call to Unknown_Attributes, even in case of
|
-- Attr is always reset in this call to Unknown_Attributes, even in case of
|
-- failure
|
-- failure
|
|
|
procedure Find_File
|
procedure Find_File
|
(N : File_Name_Type;
|
(N : File_Name_Type;
|
T : File_Type;
|
T : File_Type;
|
Found : out File_Name_Type;
|
Found : out File_Name_Type;
|
Attr : access File_Attributes);
|
Attr : access File_Attributes);
|
-- A version of Find_File that also returns a cache of the file attributes
|
-- A version of Find_File that also returns a cache of the file attributes
|
-- for later reuse
|
-- for later reuse
|
|
|
procedure Smart_Find_File
|
procedure Smart_Find_File
|
(N : File_Name_Type;
|
(N : File_Name_Type;
|
T : File_Type;
|
T : File_Type;
|
Found : out File_Name_Type;
|
Found : out File_Name_Type;
|
Attr : out File_Attributes);
|
Attr : out File_Attributes);
|
-- A version of Smart_Find_File that also returns a cache of the file
|
-- A version of Smart_Find_File that also returns a cache of the file
|
-- attributes for later reuse
|
-- attributes for later reuse
|
|
|
function C_String_Length (S : Address) return Integer;
|
function C_String_Length (S : Address) return Integer;
|
-- Returns length of a C string (zero for a null address)
|
-- Returns length of a C string (zero for a null address)
|
|
|
function To_Path_String_Access
|
function To_Path_String_Access
|
(Path_Addr : Address;
|
(Path_Addr : Address;
|
Path_Len : Integer) return String_Access;
|
Path_Len : Integer) return String_Access;
|
-- Converts a C String to an Ada String. Are we doing this to avoid withing
|
-- Converts a C String to an Ada String. Are we doing this to avoid withing
|
-- Interfaces.C.Strings ???
|
-- Interfaces.C.Strings ???
|
-- Caller must free result.
|
-- Caller must free result.
|
|
|
function Include_Dir_Default_Prefix return String_Access;
|
function Include_Dir_Default_Prefix return String_Access;
|
-- Same as exported version, except returns a String_Access
|
-- Same as exported version, except returns a String_Access
|
|
|
------------------------------
|
------------------------------
|
-- Other Local Declarations --
|
-- Other Local Declarations --
|
------------------------------
|
------------------------------
|
|
|
EOL : constant Character := ASCII.LF;
|
EOL : constant Character := ASCII.LF;
|
-- End of line character
|
-- End of line character
|
|
|
Number_File_Names : Int := 0;
|
Number_File_Names : Int := 0;
|
-- Number of file names found on command line and placed in File_Names
|
-- Number of file names found on command line and placed in File_Names
|
|
|
Look_In_Primary_Directory_For_Current_Main : Boolean := False;
|
Look_In_Primary_Directory_For_Current_Main : Boolean := False;
|
-- When this variable is True, Find_File only looks in Primary_Directory
|
-- 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
|
-- 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
|
-- compiler. It is also True for gnatmake, when the source name given on
|
-- the command line has directory information.
|
-- the command line has directory information.
|
|
|
Current_Full_Source_Name : File_Name_Type := No_File;
|
Current_Full_Source_Name : File_Name_Type := No_File;
|
Current_Full_Source_Stamp : Time_Stamp_Type := Empty_Time_Stamp;
|
Current_Full_Source_Stamp : Time_Stamp_Type := Empty_Time_Stamp;
|
Current_Full_Lib_Name : File_Name_Type := No_File;
|
Current_Full_Lib_Name : File_Name_Type := No_File;
|
Current_Full_Lib_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_Name : File_Name_Type := No_File;
|
Current_Full_Obj_Stamp : Time_Stamp_Type := Empty_Time_Stamp;
|
Current_Full_Obj_Stamp : Time_Stamp_Type := Empty_Time_Stamp;
|
-- Respectively full name (with directory info) and time stamp of the
|
-- Respectively full name (with directory info) and time stamp of the
|
-- latest source, library and object files opened by Read_Source_File and
|
-- latest source, library and object files opened by Read_Source_File and
|
-- Read_Library_Info.
|
-- Read_Library_Info.
|
|
|
package File_Name_Chars is new Table.Table (
|
package File_Name_Chars is new Table.Table (
|
Table_Component_Type => Character,
|
Table_Component_Type => Character,
|
Table_Index_Type => Int,
|
Table_Index_Type => Int,
|
Table_Low_Bound => 1,
|
Table_Low_Bound => 1,
|
Table_Initial => Alloc.File_Name_Chars_Initial,
|
Table_Initial => Alloc.File_Name_Chars_Initial,
|
Table_Increment => Alloc.File_Name_Chars_Increment,
|
Table_Increment => Alloc.File_Name_Chars_Increment,
|
Table_Name => "File_Name_Chars");
|
Table_Name => "File_Name_Chars");
|
-- Table to store text to be printed by Dump_Source_File_Names
|
-- Table to store text to be printed by Dump_Source_File_Names
|
|
|
The_Include_Dir_Default_Prefix : String_Access := null;
|
The_Include_Dir_Default_Prefix : String_Access := null;
|
-- Value returned by Include_Dir_Default_Prefix. We don't initialize it
|
-- Value returned by Include_Dir_Default_Prefix. We don't initialize it
|
-- here, because that causes an elaboration cycle with Sdefault; we
|
-- here, because that causes an elaboration cycle with Sdefault; we
|
-- initialize it lazily instead.
|
-- initialize it lazily instead.
|
|
|
------------------
|
------------------
|
-- Search Paths --
|
-- Search Paths --
|
------------------
|
------------------
|
|
|
Primary_Directory : constant := 0;
|
Primary_Directory : constant := 0;
|
-- This is index in the tables created below for the first directory to
|
-- 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
|
-- 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
|
-- containing the latest main input file (a source file for the compiler or
|
-- a library file for the binder).
|
-- a library file for the binder).
|
|
|
package Src_Search_Directories is new Table.Table (
|
package Src_Search_Directories is new Table.Table (
|
Table_Component_Type => String_Ptr,
|
Table_Component_Type => String_Ptr,
|
Table_Index_Type => Integer,
|
Table_Index_Type => Integer,
|
Table_Low_Bound => Primary_Directory,
|
Table_Low_Bound => Primary_Directory,
|
Table_Initial => 10,
|
Table_Initial => 10,
|
Table_Increment => 100,
|
Table_Increment => 100,
|
Table_Name => "Osint.Src_Search_Directories");
|
Table_Name => "Osint.Src_Search_Directories");
|
-- Table of names of directories in which to search for source (Compiler)
|
-- Table of names of directories in which to search for source (Compiler)
|
-- files. This table is filled in the order in which the directories are
|
-- files. This table is filled in the order in which the directories are
|
-- to be searched, and then used in that order.
|
-- to be searched, and then used in that order.
|
|
|
package Lib_Search_Directories is new Table.Table (
|
package Lib_Search_Directories is new Table.Table (
|
Table_Component_Type => String_Ptr,
|
Table_Component_Type => String_Ptr,
|
Table_Index_Type => Integer,
|
Table_Index_Type => Integer,
|
Table_Low_Bound => Primary_Directory,
|
Table_Low_Bound => Primary_Directory,
|
Table_Initial => 10,
|
Table_Initial => 10,
|
Table_Increment => 100,
|
Table_Increment => 100,
|
Table_Name => "Osint.Lib_Search_Directories");
|
Table_Name => "Osint.Lib_Search_Directories");
|
-- Table of names of directories in which to search for library (Binder)
|
-- Table of names of directories in which to search for library (Binder)
|
-- files. This table is filled in the order in which the directories are
|
-- files. This table is filled in the order in which the directories are
|
-- to be searched and then used in that order. The reason for having two
|
-- to be searched and then used in that order. The reason for having two
|
-- distinct tables is that we need them both in gnatmake.
|
-- distinct tables is that we need them both in gnatmake.
|
|
|
---------------------
|
---------------------
|
-- File Hash Table --
|
-- File Hash Table --
|
---------------------
|
---------------------
|
|
|
-- The file hash table is provided to free the programmer from any
|
-- The file hash table is provided to free the programmer from any
|
-- efficiency concern when retrieving full file names or time stamps of
|
-- efficiency concern when retrieving full file names or time stamps of
|
-- source files. If the programmer calls Source_File_Data (Cache => True)
|
-- source files. If the programmer calls Source_File_Data (Cache => True)
|
-- he is guaranteed that the price to retrieve the full name (i.e. with
|
-- he is guaranteed that the price to retrieve the full name (i.e. with
|
-- directory info) or time stamp of the file will be payed only once, the
|
-- 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
|
-- 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
|
-- 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
|
-- 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.
|
-- to that File_Name_Type the full file name and time stamp of the file.
|
|
|
File_Cache_Enabled : Boolean := False;
|
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;
|
type File_Hash_Num is range 0 .. 1020;
|
|
|
function File_Hash (F : File_Name_Type) return File_Hash_Num;
|
function File_Hash (F : File_Name_Type) return File_Hash_Num;
|
-- Compute hash index for use by Simple_HTable
|
-- Compute hash index for use by Simple_HTable
|
|
|
type File_Info_Cache is record
|
type File_Info_Cache is record
|
File : File_Name_Type;
|
File : File_Name_Type;
|
Attr : aliased File_Attributes;
|
Attr : aliased File_Attributes;
|
end record;
|
end record;
|
|
|
No_File_Info_Cache : constant File_Info_Cache :=
|
No_File_Info_Cache : constant File_Info_Cache :=
|
(No_File, Unknown_Attributes);
|
(No_File, Unknown_Attributes);
|
|
|
package File_Name_Hash_Table is new GNAT.HTable.Simple_HTable (
|
package File_Name_Hash_Table is new GNAT.HTable.Simple_HTable (
|
Header_Num => File_Hash_Num,
|
Header_Num => File_Hash_Num,
|
Element => File_Info_Cache,
|
Element => File_Info_Cache,
|
No_Element => No_File_Info_Cache,
|
No_Element => No_File_Info_Cache,
|
Key => File_Name_Type,
|
Key => File_Name_Type,
|
Hash => File_Hash,
|
Hash => File_Hash,
|
Equal => "=");
|
Equal => "=");
|
|
|
function Smart_Find_File
|
function Smart_Find_File
|
(N : File_Name_Type;
|
(N : File_Name_Type;
|
T : File_Type) return File_Name_Type;
|
T : File_Type) return File_Name_Type;
|
-- Exactly like Find_File except that if File_Cache_Enabled is True this
|
-- 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
|
-- routine looks first in the hash table to see if the full name of the
|
-- file is already available.
|
-- file is already available.
|
|
|
function Smart_File_Stamp
|
function Smart_File_Stamp
|
(N : File_Name_Type;
|
(N : File_Name_Type;
|
T : File_Type) return Time_Stamp_Type;
|
T : File_Type) return Time_Stamp_Type;
|
-- Takes the same parameter as the routine above (N is a file name without
|
-- Takes the same parameter as the routine above (N is a file name without
|
-- any prefix directory information) and behaves like File_Stamp except
|
-- any prefix directory information) and behaves like File_Stamp except
|
-- that if File_Cache_Enabled is True this routine looks first in the hash
|
-- 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.
|
-- table to see if the file stamp of the file is already available.
|
|
|
-----------------------------
|
-----------------------------
|
-- Add_Default_Search_Dirs --
|
-- Add_Default_Search_Dirs --
|
-----------------------------
|
-----------------------------
|
|
|
procedure Add_Default_Search_Dirs is
|
procedure Add_Default_Search_Dirs is
|
Search_Dir : String_Access;
|
Search_Dir : String_Access;
|
Search_Path : String_Access;
|
Search_Path : String_Access;
|
Path_File_Name : String_Access;
|
Path_File_Name : String_Access;
|
|
|
procedure Add_Search_Dir
|
procedure Add_Search_Dir
|
(Search_Dir : String;
|
(Search_Dir : String;
|
Additional_Source_Dir : Boolean);
|
Additional_Source_Dir : Boolean);
|
procedure Add_Search_Dir
|
procedure Add_Search_Dir
|
(Search_Dir : String_Access;
|
(Search_Dir : String_Access;
|
Additional_Source_Dir : Boolean);
|
Additional_Source_Dir : Boolean);
|
-- Add a source search dir or a library search dir, depending on the
|
-- Add a source search dir or a library search dir, depending on the
|
-- value of Additional_Source_Dir.
|
-- value of Additional_Source_Dir.
|
|
|
procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean);
|
procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean);
|
-- Open a path file and read the directory to search, one per line
|
-- Open a path file and read the directory to search, one per line
|
|
|
function Get_Libraries_From_Registry return String_Ptr;
|
function Get_Libraries_From_Registry return String_Ptr;
|
-- On Windows systems, get the list of installed standard libraries
|
-- On Windows systems, get the list of installed standard libraries
|
-- from the registry key:
|
-- from the registry key:
|
--
|
--
|
-- HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\
|
-- HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\
|
-- GNAT\Standard Libraries
|
-- GNAT\Standard Libraries
|
-- Return an empty string on other systems.
|
-- Return an empty string on other systems.
|
--
|
--
|
-- Note that this is an undocumented legacy feature, and that it
|
-- Note that this is an undocumented legacy feature, and that it
|
-- works only when using the default runtime library (i.e. no --RTS=
|
-- works only when using the default runtime library (i.e. no --RTS=
|
-- command line switch).
|
-- command line switch).
|
|
|
--------------------
|
--------------------
|
-- Add_Search_Dir --
|
-- Add_Search_Dir --
|
--------------------
|
--------------------
|
|
|
procedure Add_Search_Dir
|
procedure Add_Search_Dir
|
(Search_Dir : String;
|
(Search_Dir : String;
|
Additional_Source_Dir : Boolean)
|
Additional_Source_Dir : Boolean)
|
is
|
is
|
begin
|
begin
|
if Additional_Source_Dir then
|
if Additional_Source_Dir then
|
Add_Src_Search_Dir (Search_Dir);
|
Add_Src_Search_Dir (Search_Dir);
|
else
|
else
|
Add_Lib_Search_Dir (Search_Dir);
|
Add_Lib_Search_Dir (Search_Dir);
|
end if;
|
end if;
|
end Add_Search_Dir;
|
end Add_Search_Dir;
|
|
|
procedure Add_Search_Dir
|
procedure Add_Search_Dir
|
(Search_Dir : String_Access;
|
(Search_Dir : String_Access;
|
Additional_Source_Dir : Boolean)
|
Additional_Source_Dir : Boolean)
|
is
|
is
|
begin
|
begin
|
if Additional_Source_Dir then
|
if Additional_Source_Dir then
|
Add_Src_Search_Dir (Search_Dir.all);
|
Add_Src_Search_Dir (Search_Dir.all);
|
else
|
else
|
Add_Lib_Search_Dir (Search_Dir.all);
|
Add_Lib_Search_Dir (Search_Dir.all);
|
end if;
|
end if;
|
end Add_Search_Dir;
|
end Add_Search_Dir;
|
|
|
------------------------
|
------------------------
|
-- Get_Dirs_From_File --
|
-- Get_Dirs_From_File --
|
------------------------
|
------------------------
|
|
|
procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean) is
|
procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean) is
|
File_FD : File_Descriptor;
|
File_FD : File_Descriptor;
|
Buffer : constant String := Path_File_Name.all & ASCII.NUL;
|
Buffer : constant String := Path_File_Name.all & ASCII.NUL;
|
Len : Natural;
|
Len : Natural;
|
Actual_Len : Natural;
|
Actual_Len : Natural;
|
S : String_Access;
|
S : String_Access;
|
Curr : Natural;
|
Curr : Natural;
|
First : Natural;
|
First : Natural;
|
Ch : Character;
|
Ch : Character;
|
|
|
Status : Boolean;
|
Status : Boolean;
|
pragma Warnings (Off, Status);
|
pragma Warnings (Off, Status);
|
-- For the call to Close where status is ignored
|
-- For the call to Close where status is ignored
|
|
|
begin
|
begin
|
File_FD := Open_Read (Buffer'Address, Binary);
|
File_FD := Open_Read (Buffer'Address, Binary);
|
|
|
-- If we cannot open the file, we ignore it, we don't fail
|
-- If we cannot open the file, we ignore it, we don't fail
|
|
|
if File_FD = Invalid_FD then
|
if File_FD = Invalid_FD then
|
return;
|
return;
|
end if;
|
end if;
|
|
|
Len := Integer (File_Length (File_FD));
|
Len := Integer (File_Length (File_FD));
|
|
|
S := new String (1 .. Len);
|
S := new String (1 .. Len);
|
|
|
-- Read the file. Note that the loop is not necessary since the
|
-- Read the file. Note that the loop is not necessary since the
|
-- whole file is read at once except on VMS.
|
-- whole file is read at once except on VMS.
|
|
|
Curr := 1;
|
Curr := 1;
|
Actual_Len := Len;
|
Actual_Len := Len;
|
while Curr <= Len and then Actual_Len /= 0 loop
|
while Curr <= Len and then Actual_Len /= 0 loop
|
Actual_Len := Read (File_FD, S (Curr)'Address, Len);
|
Actual_Len := Read (File_FD, S (Curr)'Address, Len);
|
Curr := Curr + Actual_Len;
|
Curr := Curr + Actual_Len;
|
end loop;
|
end loop;
|
|
|
-- We are done with the file, so we close it (ignore any error on
|
-- We are done with the file, so we close it (ignore any error on
|
-- the close, since we have successfully read the file).
|
-- the close, since we have successfully read the file).
|
|
|
Close (File_FD, Status);
|
Close (File_FD, Status);
|
|
|
-- Now, we read line by line
|
-- Now, we read line by line
|
|
|
First := 1;
|
First := 1;
|
Curr := 0;
|
Curr := 0;
|
while Curr < Len loop
|
while Curr < Len loop
|
Ch := S (Curr + 1);
|
Ch := S (Curr + 1);
|
|
|
if Ch = ASCII.CR or else Ch = ASCII.LF
|
if Ch = ASCII.CR or else Ch = ASCII.LF
|
or else Ch = ASCII.FF or else Ch = ASCII.VT
|
or else Ch = ASCII.FF or else Ch = ASCII.VT
|
then
|
then
|
if First <= Curr then
|
if First <= Curr then
|
Add_Search_Dir (S (First .. Curr), Additional_Source_Dir);
|
Add_Search_Dir (S (First .. Curr), Additional_Source_Dir);
|
end if;
|
end if;
|
|
|
First := Curr + 2;
|
First := Curr + 2;
|
end if;
|
end if;
|
|
|
Curr := Curr + 1;
|
Curr := Curr + 1;
|
end loop;
|
end loop;
|
|
|
-- Last line is a special case, if the file does not end with
|
-- Last line is a special case, if the file does not end with
|
-- an end of line mark.
|
-- an end of line mark.
|
|
|
if First <= S'Last then
|
if First <= S'Last then
|
Add_Search_Dir (S (First .. S'Last), Additional_Source_Dir);
|
Add_Search_Dir (S (First .. S'Last), Additional_Source_Dir);
|
end if;
|
end if;
|
end Get_Dirs_From_File;
|
end Get_Dirs_From_File;
|
|
|
---------------------------------
|
---------------------------------
|
-- Get_Libraries_From_Registry --
|
-- Get_Libraries_From_Registry --
|
---------------------------------
|
---------------------------------
|
|
|
function Get_Libraries_From_Registry return String_Ptr is
|
function Get_Libraries_From_Registry return String_Ptr is
|
function C_Get_Libraries_From_Registry return Address;
|
function C_Get_Libraries_From_Registry return Address;
|
pragma Import (C, C_Get_Libraries_From_Registry,
|
pragma Import (C, C_Get_Libraries_From_Registry,
|
"__gnat_get_libraries_from_registry");
|
"__gnat_get_libraries_from_registry");
|
|
|
function Strlen (Str : Address) return Integer;
|
function Strlen (Str : Address) return Integer;
|
pragma Import (C, Strlen, "strlen");
|
pragma Import (C, Strlen, "strlen");
|
|
|
procedure Strncpy (X : Address; Y : Address; Length : Integer);
|
procedure Strncpy (X : Address; Y : Address; Length : Integer);
|
pragma Import (C, Strncpy, "strncpy");
|
pragma Import (C, Strncpy, "strncpy");
|
|
|
procedure C_Free (Str : Address);
|
procedure C_Free (Str : Address);
|
pragma Import (C, C_Free, "free");
|
pragma Import (C, C_Free, "free");
|
|
|
Result_Ptr : Address;
|
Result_Ptr : Address;
|
Result_Length : Integer;
|
Result_Length : Integer;
|
Out_String : String_Ptr;
|
Out_String : String_Ptr;
|
|
|
begin
|
begin
|
Result_Ptr := C_Get_Libraries_From_Registry;
|
Result_Ptr := C_Get_Libraries_From_Registry;
|
Result_Length := Strlen (Result_Ptr);
|
Result_Length := Strlen (Result_Ptr);
|
|
|
Out_String := new String (1 .. Result_Length);
|
Out_String := new String (1 .. Result_Length);
|
Strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
|
Strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
|
|
|
C_Free (Result_Ptr);
|
C_Free (Result_Ptr);
|
|
|
return Out_String;
|
return Out_String;
|
end Get_Libraries_From_Registry;
|
end Get_Libraries_From_Registry;
|
|
|
-- Start of processing for Add_Default_Search_Dirs
|
-- Start of processing for Add_Default_Search_Dirs
|
|
|
begin
|
begin
|
-- After the locations specified on the command line, the next places
|
-- After the locations specified on the command line, the next places
|
-- to look for files are the directories specified by the appropriate
|
-- to look for files are the directories specified by the appropriate
|
-- environment variable. Get this value, extract the directory names
|
-- environment variable. Get this value, extract the directory names
|
-- and store in the tables.
|
-- and store in the tables.
|
|
|
-- Check for eventual project path file env vars
|
-- Check for eventual project path file env vars
|
|
|
Path_File_Name := Getenv (Project_Include_Path_File);
|
Path_File_Name := Getenv (Project_Include_Path_File);
|
|
|
if Path_File_Name'Length > 0 then
|
if Path_File_Name'Length > 0 then
|
Get_Dirs_From_File (Additional_Source_Dir => True);
|
Get_Dirs_From_File (Additional_Source_Dir => True);
|
end if;
|
end if;
|
|
|
Path_File_Name := Getenv (Project_Objects_Path_File);
|
Path_File_Name := Getenv (Project_Objects_Path_File);
|
|
|
if Path_File_Name'Length > 0 then
|
if Path_File_Name'Length > 0 then
|
Get_Dirs_From_File (Additional_Source_Dir => False);
|
Get_Dirs_From_File (Additional_Source_Dir => False);
|
end if;
|
end if;
|
|
|
-- On VMS, don't expand the logical name (e.g. environment variable),
|
-- On VMS, don't expand the logical name (e.g. environment variable),
|
-- just put it into Unix (e.g. canonical) format. System services
|
-- just put it into Unix (e.g. canonical) format. System services
|
-- will handle the expansion as part of the file processing.
|
-- will handle the expansion as part of the file processing.
|
|
|
for Additional_Source_Dir in False .. True loop
|
for Additional_Source_Dir in False .. True loop
|
if Additional_Source_Dir then
|
if Additional_Source_Dir then
|
Search_Path := Getenv (Ada_Include_Path);
|
Search_Path := Getenv (Ada_Include_Path);
|
|
|
if Search_Path'Length > 0 then
|
if Search_Path'Length > 0 then
|
if Hostparm.OpenVMS then
|
if Hostparm.OpenVMS then
|
Search_Path := To_Canonical_Path_Spec ("ADA_INCLUDE_PATH:");
|
Search_Path := To_Canonical_Path_Spec ("ADA_INCLUDE_PATH:");
|
else
|
else
|
Search_Path := To_Canonical_Path_Spec (Search_Path.all);
|
Search_Path := To_Canonical_Path_Spec (Search_Path.all);
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
else
|
else
|
Search_Path := Getenv (Ada_Objects_Path);
|
Search_Path := Getenv (Ada_Objects_Path);
|
|
|
if Search_Path'Length > 0 then
|
if Search_Path'Length > 0 then
|
if Hostparm.OpenVMS then
|
if Hostparm.OpenVMS then
|
Search_Path := To_Canonical_Path_Spec ("ADA_OBJECTS_PATH:");
|
Search_Path := To_Canonical_Path_Spec ("ADA_OBJECTS_PATH:");
|
else
|
else
|
Search_Path := To_Canonical_Path_Spec (Search_Path.all);
|
Search_Path := To_Canonical_Path_Spec (Search_Path.all);
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
Get_Next_Dir_In_Path_Init (Search_Path);
|
Get_Next_Dir_In_Path_Init (Search_Path);
|
loop
|
loop
|
Search_Dir := Get_Next_Dir_In_Path (Search_Path);
|
Search_Dir := Get_Next_Dir_In_Path (Search_Path);
|
exit when Search_Dir = null;
|
exit when Search_Dir = null;
|
Add_Search_Dir (Search_Dir, Additional_Source_Dir);
|
Add_Search_Dir (Search_Dir, Additional_Source_Dir);
|
end loop;
|
end loop;
|
end loop;
|
end loop;
|
|
|
-- For the compiler, if --RTS= was specified, add the runtime
|
-- For the compiler, if --RTS= was specified, add the runtime
|
-- directories.
|
-- directories.
|
|
|
if RTS_Src_Path_Name /= null
|
if RTS_Src_Path_Name /= null
|
and then RTS_Lib_Path_Name /= null
|
and then RTS_Lib_Path_Name /= null
|
then
|
then
|
Add_Search_Dirs (RTS_Src_Path_Name, Include);
|
Add_Search_Dirs (RTS_Src_Path_Name, Include);
|
Add_Search_Dirs (RTS_Lib_Path_Name, Objects);
|
Add_Search_Dirs (RTS_Lib_Path_Name, Objects);
|
|
|
else
|
else
|
if not Opt.No_Stdinc then
|
if not Opt.No_Stdinc then
|
|
|
-- For WIN32 systems, look for any system libraries defined in
|
-- For WIN32 systems, look for any system libraries defined in
|
-- the registry. These are added to both source and object
|
-- the registry. These are added to both source and object
|
-- directories.
|
-- directories.
|
|
|
Search_Path := String_Access (Get_Libraries_From_Registry);
|
Search_Path := String_Access (Get_Libraries_From_Registry);
|
|
|
Get_Next_Dir_In_Path_Init (Search_Path);
|
Get_Next_Dir_In_Path_Init (Search_Path);
|
loop
|
loop
|
Search_Dir := Get_Next_Dir_In_Path (Search_Path);
|
Search_Dir := Get_Next_Dir_In_Path (Search_Path);
|
exit when Search_Dir = null;
|
exit when Search_Dir = null;
|
Add_Search_Dir (Search_Dir, False);
|
Add_Search_Dir (Search_Dir, False);
|
Add_Search_Dir (Search_Dir, True);
|
Add_Search_Dir (Search_Dir, True);
|
end loop;
|
end loop;
|
|
|
-- The last place to look are the defaults
|
-- The last place to look are the defaults
|
|
|
Search_Path :=
|
Search_Path :=
|
Read_Default_Search_Dirs
|
Read_Default_Search_Dirs
|
(String_Access (Update_Path (Search_Dir_Prefix)),
|
(String_Access (Update_Path (Search_Dir_Prefix)),
|
Include_Search_File,
|
Include_Search_File,
|
String_Access (Update_Path (Include_Dir_Default_Name)));
|
String_Access (Update_Path (Include_Dir_Default_Name)));
|
|
|
Get_Next_Dir_In_Path_Init (Search_Path);
|
Get_Next_Dir_In_Path_Init (Search_Path);
|
loop
|
loop
|
Search_Dir := Get_Next_Dir_In_Path (Search_Path);
|
Search_Dir := Get_Next_Dir_In_Path (Search_Path);
|
exit when Search_Dir = null;
|
exit when Search_Dir = null;
|
Add_Search_Dir (Search_Dir, True);
|
Add_Search_Dir (Search_Dir, True);
|
end loop;
|
end loop;
|
end if;
|
end if;
|
|
|
if not Opt.No_Stdlib and not Opt.RTS_Switch then
|
if not Opt.No_Stdlib and not Opt.RTS_Switch then
|
Search_Path :=
|
Search_Path :=
|
Read_Default_Search_Dirs
|
Read_Default_Search_Dirs
|
(String_Access (Update_Path (Search_Dir_Prefix)),
|
(String_Access (Update_Path (Search_Dir_Prefix)),
|
Objects_Search_File,
|
Objects_Search_File,
|
String_Access (Update_Path (Object_Dir_Default_Name)));
|
String_Access (Update_Path (Object_Dir_Default_Name)));
|
|
|
Get_Next_Dir_In_Path_Init (Search_Path);
|
Get_Next_Dir_In_Path_Init (Search_Path);
|
loop
|
loop
|
Search_Dir := Get_Next_Dir_In_Path (Search_Path);
|
Search_Dir := Get_Next_Dir_In_Path (Search_Path);
|
exit when Search_Dir = null;
|
exit when Search_Dir = null;
|
Add_Search_Dir (Search_Dir, False);
|
Add_Search_Dir (Search_Dir, False);
|
end loop;
|
end loop;
|
end if;
|
end if;
|
end if;
|
end if;
|
end Add_Default_Search_Dirs;
|
end Add_Default_Search_Dirs;
|
|
|
--------------
|
--------------
|
-- Add_File --
|
-- Add_File --
|
--------------
|
--------------
|
|
|
procedure Add_File (File_Name : String; Index : Int := No_Index) is
|
procedure Add_File (File_Name : String; Index : Int := No_Index) is
|
begin
|
begin
|
Number_File_Names := Number_File_Names + 1;
|
Number_File_Names := Number_File_Names + 1;
|
|
|
-- As Add_File may be called for mains specified inside a project file,
|
-- As Add_File may be called for mains specified inside a project file,
|
-- File_Names may be too short and needs to be extended.
|
-- File_Names may be too short and needs to be extended.
|
|
|
if Number_File_Names > File_Names'Last then
|
if Number_File_Names > File_Names'Last then
|
File_Names := new File_Name_Array'(File_Names.all & File_Names.all);
|
File_Names := new File_Name_Array'(File_Names.all & File_Names.all);
|
File_Indexes :=
|
File_Indexes :=
|
new File_Index_Array'(File_Indexes.all & File_Indexes.all);
|
new File_Index_Array'(File_Indexes.all & File_Indexes.all);
|
end if;
|
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;
|
File_Indexes (Number_File_Names) := Index;
|
end Add_File;
|
end Add_File;
|
|
|
------------------------
|
------------------------
|
-- Add_Lib_Search_Dir --
|
-- Add_Lib_Search_Dir --
|
------------------------
|
------------------------
|
|
|
procedure Add_Lib_Search_Dir (Dir : String) is
|
procedure Add_Lib_Search_Dir (Dir : String) is
|
begin
|
begin
|
if Dir'Length = 0 then
|
if Dir'Length = 0 then
|
Fail ("missing library directory name");
|
Fail ("missing library directory name");
|
end if;
|
end if;
|
|
|
declare
|
declare
|
Norm : String_Ptr := Normalize_Directory_Name (Dir);
|
Norm : String_Ptr := Normalize_Directory_Name (Dir);
|
|
|
begin
|
begin
|
-- Do nothing if the directory is already in the list. This saves
|
-- Do nothing if the directory is already in the list. This saves
|
-- system calls and avoid unneeded work
|
-- system calls and avoid unneeded work
|
|
|
for D in Lib_Search_Directories.First ..
|
for D in Lib_Search_Directories.First ..
|
Lib_Search_Directories.Last
|
Lib_Search_Directories.Last
|
loop
|
loop
|
if Lib_Search_Directories.Table (D).all = Norm.all then
|
if Lib_Search_Directories.Table (D).all = Norm.all then
|
Free (Norm);
|
Free (Norm);
|
return;
|
return;
|
end if;
|
end if;
|
end loop;
|
end loop;
|
|
|
Lib_Search_Directories.Increment_Last;
|
Lib_Search_Directories.Increment_Last;
|
Lib_Search_Directories.Table (Lib_Search_Directories.Last) := Norm;
|
Lib_Search_Directories.Table (Lib_Search_Directories.Last) := Norm;
|
end;
|
end;
|
end Add_Lib_Search_Dir;
|
end Add_Lib_Search_Dir;
|
|
|
---------------------
|
---------------------
|
-- Add_Search_Dirs --
|
-- Add_Search_Dirs --
|
---------------------
|
---------------------
|
|
|
procedure Add_Search_Dirs
|
procedure Add_Search_Dirs
|
(Search_Path : String_Ptr;
|
(Search_Path : String_Ptr;
|
Path_Type : Search_File_Type)
|
Path_Type : Search_File_Type)
|
is
|
is
|
Current_Search_Path : String_Access;
|
Current_Search_Path : String_Access;
|
|
|
begin
|
begin
|
Get_Next_Dir_In_Path_Init (String_Access (Search_Path));
|
Get_Next_Dir_In_Path_Init (String_Access (Search_Path));
|
loop
|
loop
|
Current_Search_Path :=
|
Current_Search_Path :=
|
Get_Next_Dir_In_Path (String_Access (Search_Path));
|
Get_Next_Dir_In_Path (String_Access (Search_Path));
|
exit when Current_Search_Path = null;
|
exit when Current_Search_Path = null;
|
|
|
if Path_Type = Include then
|
if Path_Type = Include then
|
Add_Src_Search_Dir (Current_Search_Path.all);
|
Add_Src_Search_Dir (Current_Search_Path.all);
|
else
|
else
|
Add_Lib_Search_Dir (Current_Search_Path.all);
|
Add_Lib_Search_Dir (Current_Search_Path.all);
|
end if;
|
end if;
|
end loop;
|
end loop;
|
end Add_Search_Dirs;
|
end Add_Search_Dirs;
|
|
|
------------------------
|
------------------------
|
-- Add_Src_Search_Dir --
|
-- Add_Src_Search_Dir --
|
------------------------
|
------------------------
|
|
|
procedure Add_Src_Search_Dir (Dir : String) is
|
procedure Add_Src_Search_Dir (Dir : String) is
|
begin
|
begin
|
if Dir'Length = 0 then
|
if Dir'Length = 0 then
|
Fail ("missing source directory name");
|
Fail ("missing source directory name");
|
end if;
|
end if;
|
|
|
Src_Search_Directories.Increment_Last;
|
Src_Search_Directories.Increment_Last;
|
Src_Search_Directories.Table (Src_Search_Directories.Last) :=
|
Src_Search_Directories.Table (Src_Search_Directories.Last) :=
|
Normalize_Directory_Name (Dir);
|
Normalize_Directory_Name (Dir);
|
end Add_Src_Search_Dir;
|
end Add_Src_Search_Dir;
|
|
|
--------------------------------
|
--------------------------------
|
-- Append_Suffix_To_File_Name --
|
-- Append_Suffix_To_File_Name --
|
--------------------------------
|
--------------------------------
|
|
|
function Append_Suffix_To_File_Name
|
function Append_Suffix_To_File_Name
|
(Name : File_Name_Type;
|
(Name : File_Name_Type;
|
Suffix : String) return File_Name_Type
|
Suffix : String) return File_Name_Type
|
is
|
is
|
begin
|
begin
|
Get_Name_String (Name);
|
Get_Name_String (Name);
|
Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
|
Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
|
Name_Len := Name_Len + Suffix'Length;
|
Name_Len := Name_Len + Suffix'Length;
|
return Name_Find;
|
return Name_Find;
|
end Append_Suffix_To_File_Name;
|
end Append_Suffix_To_File_Name;
|
|
|
---------------------
|
---------------------
|
-- C_String_Length --
|
-- C_String_Length --
|
---------------------
|
---------------------
|
|
|
function C_String_Length (S : Address) return Integer is
|
function C_String_Length (S : Address) return Integer is
|
function Strlen (S : Address) return Integer;
|
function Strlen (S : Address) return Integer;
|
pragma Import (C, Strlen, "strlen");
|
pragma Import (C, Strlen, "strlen");
|
begin
|
begin
|
if S = Null_Address then
|
if S = Null_Address then
|
return 0;
|
return 0;
|
else
|
else
|
return Strlen (S);
|
return Strlen (S);
|
end if;
|
end if;
|
end C_String_Length;
|
end C_String_Length;
|
|
|
------------------------------
|
------------------------------
|
-- Canonical_Case_File_Name --
|
-- Canonical_Case_File_Name --
|
------------------------------
|
------------------------------
|
|
|
-- For now, we only deal with the case of a-z. Eventually we should
|
-- For now, we only deal with the case of a-z. Eventually we should
|
-- worry about other Latin-1 letters on systems that support this ???
|
-- worry about other Latin-1 letters on systems that support this ???
|
|
|
procedure Canonical_Case_File_Name (S : in out String) is
|
procedure Canonical_Case_File_Name (S : in out String) is
|
begin
|
begin
|
if not File_Names_Case_Sensitive then
|
if not File_Names_Case_Sensitive then
|
for J in S'Range loop
|
for J in S'Range loop
|
if S (J) in 'A' .. 'Z' then
|
if S (J) in 'A' .. 'Z' then
|
S (J) := Character'Val (
|
S (J) := Character'Val (
|
Character'Pos (S (J)) +
|
Character'Pos (S (J)) +
|
Character'Pos ('a') -
|
Character'Pos ('a') -
|
Character'Pos ('A'));
|
Character'Pos ('A'));
|
end if;
|
end if;
|
end loop;
|
end loop;
|
end if;
|
end if;
|
end Canonical_Case_File_Name;
|
end Canonical_Case_File_Name;
|
|
|
---------------------------
|
---------------------------
|
-- Create_File_And_Check --
|
-- Create_File_And_Check --
|
---------------------------
|
---------------------------
|
|
|
procedure Create_File_And_Check
|
procedure Create_File_And_Check
|
(Fdesc : out File_Descriptor;
|
(Fdesc : out File_Descriptor;
|
Fmode : Mode)
|
Fmode : Mode)
|
is
|
is
|
begin
|
begin
|
Output_File_Name := Name_Enter;
|
Output_File_Name := Name_Enter;
|
Fdesc := Create_File (Name_Buffer'Address, Fmode);
|
Fdesc := Create_File (Name_Buffer'Address, Fmode);
|
|
|
if Fdesc = Invalid_FD then
|
if Fdesc = Invalid_FD then
|
Fail ("Cannot create: " & Name_Buffer (1 .. Name_Len));
|
Fail ("Cannot create: " & Name_Buffer (1 .. Name_Len));
|
end if;
|
end if;
|
end Create_File_And_Check;
|
end Create_File_And_Check;
|
|
|
------------------------
|
------------------------
|
-- Current_File_Index --
|
-- Current_File_Index --
|
------------------------
|
------------------------
|
|
|
function Current_File_Index return Int is
|
function Current_File_Index return Int is
|
begin
|
begin
|
return File_Indexes (Current_File_Name_Index);
|
return File_Indexes (Current_File_Name_Index);
|
end Current_File_Index;
|
end Current_File_Index;
|
|
|
--------------------------------
|
--------------------------------
|
-- Current_Library_File_Stamp --
|
-- Current_Library_File_Stamp --
|
--------------------------------
|
--------------------------------
|
|
|
function Current_Library_File_Stamp return Time_Stamp_Type is
|
function Current_Library_File_Stamp return Time_Stamp_Type is
|
begin
|
begin
|
return Current_Full_Lib_Stamp;
|
return Current_Full_Lib_Stamp;
|
end Current_Library_File_Stamp;
|
end Current_Library_File_Stamp;
|
|
|
-------------------------------
|
-------------------------------
|
-- Current_Object_File_Stamp --
|
-- Current_Object_File_Stamp --
|
-------------------------------
|
-------------------------------
|
|
|
function Current_Object_File_Stamp return Time_Stamp_Type is
|
function Current_Object_File_Stamp return Time_Stamp_Type is
|
begin
|
begin
|
return Current_Full_Obj_Stamp;
|
return Current_Full_Obj_Stamp;
|
end Current_Object_File_Stamp;
|
end Current_Object_File_Stamp;
|
|
|
-------------------------------
|
-------------------------------
|
-- Current_Source_File_Stamp --
|
-- Current_Source_File_Stamp --
|
-------------------------------
|
-------------------------------
|
|
|
function Current_Source_File_Stamp return Time_Stamp_Type is
|
function Current_Source_File_Stamp return Time_Stamp_Type is
|
begin
|
begin
|
return Current_Full_Source_Stamp;
|
return Current_Full_Source_Stamp;
|
end Current_Source_File_Stamp;
|
end Current_Source_File_Stamp;
|
|
|
----------------------------
|
----------------------------
|
-- Dir_In_Obj_Search_Path --
|
-- Dir_In_Obj_Search_Path --
|
----------------------------
|
----------------------------
|
|
|
function Dir_In_Obj_Search_Path (Position : Natural) return String_Ptr is
|
function Dir_In_Obj_Search_Path (Position : Natural) return String_Ptr is
|
begin
|
begin
|
if Opt.Look_In_Primary_Dir then
|
if Opt.Look_In_Primary_Dir then
|
return
|
return
|
Lib_Search_Directories.Table (Primary_Directory + Position - 1);
|
Lib_Search_Directories.Table (Primary_Directory + Position - 1);
|
else
|
else
|
return Lib_Search_Directories.Table (Primary_Directory + Position);
|
return Lib_Search_Directories.Table (Primary_Directory + Position);
|
end if;
|
end if;
|
end Dir_In_Obj_Search_Path;
|
end Dir_In_Obj_Search_Path;
|
|
|
----------------------------
|
----------------------------
|
-- Dir_In_Src_Search_Path --
|
-- Dir_In_Src_Search_Path --
|
----------------------------
|
----------------------------
|
|
|
function Dir_In_Src_Search_Path (Position : Natural) return String_Ptr is
|
function Dir_In_Src_Search_Path (Position : Natural) return String_Ptr is
|
begin
|
begin
|
if Opt.Look_In_Primary_Dir then
|
if Opt.Look_In_Primary_Dir then
|
return
|
return
|
Src_Search_Directories.Table (Primary_Directory + Position - 1);
|
Src_Search_Directories.Table (Primary_Directory + Position - 1);
|
else
|
else
|
return Src_Search_Directories.Table (Primary_Directory + Position);
|
return Src_Search_Directories.Table (Primary_Directory + Position);
|
end if;
|
end if;
|
end Dir_In_Src_Search_Path;
|
end Dir_In_Src_Search_Path;
|
|
|
----------------------------
|
----------------------------
|
-- Dump_Source_File_Names --
|
-- Dump_Source_File_Names --
|
----------------------------
|
----------------------------
|
|
|
procedure Dump_Source_File_Names is
|
procedure Dump_Source_File_Names is
|
subtype Rng is Int range File_Name_Chars.First .. File_Name_Chars.Last;
|
subtype Rng is Int range File_Name_Chars.First .. File_Name_Chars.Last;
|
begin
|
begin
|
Write_Str (String (File_Name_Chars.Table (Rng)));
|
Write_Str (String (File_Name_Chars.Table (Rng)));
|
end Dump_Source_File_Names;
|
end Dump_Source_File_Names;
|
|
|
---------------------
|
---------------------
|
-- Executable_Name --
|
-- Executable_Name --
|
---------------------
|
---------------------
|
|
|
function Executable_Name
|
function Executable_Name
|
(Name : File_Name_Type;
|
(Name : File_Name_Type;
|
Only_If_No_Suffix : Boolean := False) return File_Name_Type
|
Only_If_No_Suffix : Boolean := False) return File_Name_Type
|
is
|
is
|
Exec_Suffix : String_Access;
|
Exec_Suffix : String_Access;
|
Add_Suffix : Boolean;
|
Add_Suffix : Boolean;
|
|
|
begin
|
begin
|
if Name = No_File then
|
if Name = No_File then
|
return No_File;
|
return No_File;
|
end if;
|
end if;
|
|
|
if Executable_Extension_On_Target = No_Name then
|
if Executable_Extension_On_Target = No_Name then
|
Exec_Suffix := Get_Target_Executable_Suffix;
|
Exec_Suffix := Get_Target_Executable_Suffix;
|
else
|
else
|
Get_Name_String (Executable_Extension_On_Target);
|
Get_Name_String (Executable_Extension_On_Target);
|
Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len));
|
Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len));
|
end if;
|
end if;
|
|
|
if Exec_Suffix'Length /= 0 then
|
if Exec_Suffix'Length /= 0 then
|
Get_Name_String (Name);
|
Get_Name_String (Name);
|
|
|
Add_Suffix := True;
|
Add_Suffix := True;
|
if Only_If_No_Suffix then
|
if Only_If_No_Suffix then
|
for J in reverse 1 .. Name_Len loop
|
for J in reverse 1 .. Name_Len loop
|
if Name_Buffer (J) = '.' then
|
if Name_Buffer (J) = '.' then
|
Add_Suffix := False;
|
Add_Suffix := False;
|
exit;
|
exit;
|
|
|
elsif Name_Buffer (J) = '/' or else
|
elsif Name_Buffer (J) = '/' or else
|
Name_Buffer (J) = Directory_Separator
|
Name_Buffer (J) = Directory_Separator
|
then
|
then
|
exit;
|
exit;
|
end if;
|
end if;
|
end loop;
|
end loop;
|
end if;
|
end if;
|
|
|
if Add_Suffix then
|
if Add_Suffix then
|
declare
|
declare
|
Buffer : String := Name_Buffer (1 .. Name_Len);
|
Buffer : String := Name_Buffer (1 .. Name_Len);
|
|
|
begin
|
begin
|
-- Get the file name in canonical case to accept as is names
|
-- Get the file name in canonical case to accept as is names
|
-- ending with ".EXE" on VMS and Windows.
|
-- ending with ".EXE" on VMS and Windows.
|
|
|
Canonical_Case_File_Name (Buffer);
|
Canonical_Case_File_Name (Buffer);
|
|
|
-- If Executable does not end with the executable suffix, add
|
-- If Executable does not end with the executable suffix, add
|
-- it.
|
-- it.
|
|
|
if Buffer'Length <= Exec_Suffix'Length
|
if Buffer'Length <= Exec_Suffix'Length
|
or else
|
or else
|
Buffer (Buffer'Last - Exec_Suffix'Length + 1 .. Buffer'Last)
|
Buffer (Buffer'Last - Exec_Suffix'Length + 1 .. Buffer'Last)
|
/= Exec_Suffix.all
|
/= Exec_Suffix.all
|
then
|
then
|
Name_Buffer
|
Name_Buffer
|
(Name_Len + 1 .. Name_Len + Exec_Suffix'Length) :=
|
(Name_Len + 1 .. Name_Len + Exec_Suffix'Length) :=
|
Exec_Suffix.all;
|
Exec_Suffix.all;
|
Name_Len := Name_Len + Exec_Suffix'Length;
|
Name_Len := Name_Len + Exec_Suffix'Length;
|
Free (Exec_Suffix);
|
Free (Exec_Suffix);
|
return Name_Find;
|
return Name_Find;
|
end if;
|
end if;
|
end;
|
end;
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
Free (Exec_Suffix);
|
Free (Exec_Suffix);
|
return Name;
|
return Name;
|
end Executable_Name;
|
end Executable_Name;
|
|
|
function Executable_Name
|
function Executable_Name
|
(Name : String;
|
(Name : String;
|
Only_If_No_Suffix : Boolean := False) return String
|
Only_If_No_Suffix : Boolean := False) return String
|
is
|
is
|
Exec_Suffix : String_Access;
|
Exec_Suffix : String_Access;
|
Add_Suffix : Boolean;
|
Add_Suffix : Boolean;
|
Canonical_Name : String := Name;
|
Canonical_Name : String := Name;
|
|
|
begin
|
begin
|
if Executable_Extension_On_Target = No_Name then
|
if Executable_Extension_On_Target = No_Name then
|
Exec_Suffix := Get_Target_Executable_Suffix;
|
Exec_Suffix := Get_Target_Executable_Suffix;
|
else
|
else
|
Get_Name_String (Executable_Extension_On_Target);
|
Get_Name_String (Executable_Extension_On_Target);
|
Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len));
|
Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len));
|
end if;
|
end if;
|
|
|
if Exec_Suffix'Length = 0 then
|
if Exec_Suffix'Length = 0 then
|
Free (Exec_Suffix);
|
Free (Exec_Suffix);
|
return Name;
|
return Name;
|
|
|
else
|
else
|
declare
|
declare
|
Suffix : constant String := Exec_Suffix.all;
|
Suffix : constant String := Exec_Suffix.all;
|
|
|
begin
|
begin
|
Free (Exec_Suffix);
|
Free (Exec_Suffix);
|
Canonical_Case_File_Name (Canonical_Name);
|
Canonical_Case_File_Name (Canonical_Name);
|
|
|
Add_Suffix := True;
|
Add_Suffix := True;
|
if Only_If_No_Suffix then
|
if Only_If_No_Suffix then
|
for J in reverse Canonical_Name'Range loop
|
for J in reverse Canonical_Name'Range loop
|
if Canonical_Name (J) = '.' then
|
if Canonical_Name (J) = '.' then
|
Add_Suffix := False;
|
Add_Suffix := False;
|
exit;
|
exit;
|
|
|
elsif Canonical_Name (J) = '/' or else
|
elsif Canonical_Name (J) = '/' or else
|
Canonical_Name (J) = Directory_Separator
|
Canonical_Name (J) = Directory_Separator
|
then
|
then
|
exit;
|
exit;
|
end if;
|
end if;
|
end loop;
|
end loop;
|
end if;
|
end if;
|
|
|
if Add_Suffix and then
|
if Add_Suffix and then
|
(Canonical_Name'Length <= Suffix'Length
|
(Canonical_Name'Length <= Suffix'Length
|
or else Canonical_Name (Canonical_Name'Last - Suffix'Length + 1
|
or else Canonical_Name (Canonical_Name'Last - Suffix'Length + 1
|
.. Canonical_Name'Last) /= Suffix)
|
.. Canonical_Name'Last) /= Suffix)
|
then
|
then
|
declare
|
declare
|
Result : String (1 .. Name'Length + Suffix'Length);
|
Result : String (1 .. Name'Length + Suffix'Length);
|
begin
|
begin
|
Result (1 .. Name'Length) := Name;
|
Result (1 .. Name'Length) := Name;
|
Result (Name'Length + 1 .. Result'Last) := Suffix;
|
Result (Name'Length + 1 .. Result'Last) := Suffix;
|
return Result;
|
return Result;
|
end;
|
end;
|
else
|
else
|
return Name;
|
return Name;
|
end if;
|
end if;
|
end;
|
end;
|
end if;
|
end if;
|
end Executable_Name;
|
end Executable_Name;
|
|
|
-----------------------
|
-----------------------
|
-- Executable_Prefix --
|
-- Executable_Prefix --
|
-----------------------
|
-----------------------
|
|
|
function Executable_Prefix return String_Ptr is
|
function Executable_Prefix return String_Ptr is
|
|
|
function Get_Install_Dir (Exec : String) return String_Ptr;
|
function Get_Install_Dir (Exec : String) return String_Ptr;
|
-- S is the executable name preceded by the absolute or relative
|
-- S is the executable name preceded by the absolute or relative
|
-- path, e.g. "c:\usr\bin\gcc.exe" or "..\bin\gcc".
|
-- path, e.g. "c:\usr\bin\gcc.exe" or "..\bin\gcc".
|
|
|
---------------------
|
---------------------
|
-- Get_Install_Dir --
|
-- Get_Install_Dir --
|
---------------------
|
---------------------
|
|
|
function Get_Install_Dir (Exec : String) return String_Ptr is
|
function Get_Install_Dir (Exec : String) return String_Ptr is
|
Full_Path : constant String := Normalize_Pathname (Exec);
|
Full_Path : constant String := Normalize_Pathname (Exec);
|
-- Use the full path, so that we find "lib" or "bin", even when
|
-- Use the full path, so that we find "lib" or "bin", even when
|
-- the tool has been invoked with a relative path, as in
|
-- the tool has been invoked with a relative path, as in
|
-- "./gnatls -v" invoked in the GNAT bin directory.
|
-- "./gnatls -v" invoked in the GNAT bin directory.
|
|
|
begin
|
begin
|
for J in reverse Full_Path'Range loop
|
for J in reverse Full_Path'Range loop
|
if Is_Directory_Separator (Full_Path (J)) then
|
if Is_Directory_Separator (Full_Path (J)) then
|
if J < Full_Path'Last - 5 then
|
if J < Full_Path'Last - 5 then
|
if (To_Lower (Full_Path (J + 1)) = 'l'
|
if (To_Lower (Full_Path (J + 1)) = 'l'
|
and then To_Lower (Full_Path (J + 2)) = 'i'
|
and then To_Lower (Full_Path (J + 2)) = 'i'
|
and then To_Lower (Full_Path (J + 3)) = 'b')
|
and then To_Lower (Full_Path (J + 3)) = 'b')
|
or else
|
or else
|
(To_Lower (Full_Path (J + 1)) = 'b'
|
(To_Lower (Full_Path (J + 1)) = 'b'
|
and then To_Lower (Full_Path (J + 2)) = 'i'
|
and then To_Lower (Full_Path (J + 2)) = 'i'
|
and then To_Lower (Full_Path (J + 3)) = 'n')
|
and then To_Lower (Full_Path (J + 3)) = 'n')
|
then
|
then
|
return new String'(Full_Path (Full_Path'First .. J));
|
return new String'(Full_Path (Full_Path'First .. J));
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
end loop;
|
end loop;
|
|
|
return new String'("");
|
return new String'("");
|
end Get_Install_Dir;
|
end Get_Install_Dir;
|
|
|
-- Start of processing for Executable_Prefix
|
-- Start of processing for Executable_Prefix
|
|
|
begin
|
begin
|
if Exec_Name = null then
|
if Exec_Name = null then
|
Exec_Name := new String (1 .. Len_Arg (0));
|
Exec_Name := new String (1 .. Len_Arg (0));
|
Osint.Fill_Arg (Exec_Name (1)'Address, 0);
|
Osint.Fill_Arg (Exec_Name (1)'Address, 0);
|
end if;
|
end if;
|
|
|
-- First determine if a path prefix was placed in front of the
|
-- First determine if a path prefix was placed in front of the
|
-- executable name.
|
-- executable name.
|
|
|
for J in reverse Exec_Name'Range loop
|
for J in reverse Exec_Name'Range loop
|
if Is_Directory_Separator (Exec_Name (J)) then
|
if Is_Directory_Separator (Exec_Name (J)) then
|
return Get_Install_Dir (Exec_Name.all);
|
return Get_Install_Dir (Exec_Name.all);
|
end if;
|
end if;
|
end loop;
|
end loop;
|
|
|
-- If we come here, the user has typed the executable name with no
|
-- If we come here, the user has typed the executable name with no
|
-- directory prefix.
|
-- directory prefix.
|
|
|
return Get_Install_Dir (Locate_Exec_On_Path (Exec_Name.all).all);
|
return Get_Install_Dir (Locate_Exec_On_Path (Exec_Name.all).all);
|
end Executable_Prefix;
|
end Executable_Prefix;
|
|
|
------------------
|
------------------
|
-- Exit_Program --
|
-- Exit_Program --
|
------------------
|
------------------
|
|
|
procedure Exit_Program (Exit_Code : Exit_Code_Type) is
|
procedure Exit_Program (Exit_Code : Exit_Code_Type) is
|
begin
|
begin
|
-- The program will exit with the following status:
|
-- The program will exit with the following status:
|
|
|
-- 0 if the object file has been generated (with or without warnings)
|
-- 0 if the object file has been generated (with or without warnings)
|
-- 1 if recompilation was not needed (smart recompilation)
|
-- 1 if recompilation was not needed (smart recompilation)
|
-- 2 if gnat1 has been killed by a signal (detected by GCC)
|
-- 2 if gnat1 has been killed by a signal (detected by GCC)
|
-- 4 for a fatal error
|
-- 4 for a fatal error
|
-- 5 if there were errors
|
-- 5 if there were errors
|
-- 6 if no code has been generated (spec)
|
-- 6 if no code has been generated (spec)
|
|
|
-- Note that exit code 3 is not used and must not be used as this is
|
-- 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
|
-- the code returned by a program aborted via C abort() routine on
|
-- Windows. GCC checks for that case and thinks that the child process
|
-- 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
|
-- 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.
|
-- for E_No_Code, but E_No_Code was changed to 6 for this reason.
|
|
|
case Exit_Code is
|
case Exit_Code is
|
when E_Success => OS_Exit (0);
|
when E_Success => OS_Exit (0);
|
when E_Warnings => OS_Exit (0);
|
when E_Warnings => OS_Exit (0);
|
when E_No_Compile => OS_Exit (1);
|
when E_No_Compile => OS_Exit (1);
|
when E_Fatal => OS_Exit (4);
|
when E_Fatal => OS_Exit (4);
|
when E_Errors => OS_Exit (5);
|
when E_Errors => OS_Exit (5);
|
when E_No_Code => OS_Exit (6);
|
when E_No_Code => OS_Exit (6);
|
when E_Abort => OS_Abort;
|
when E_Abort => OS_Abort;
|
end case;
|
end case;
|
end Exit_Program;
|
end Exit_Program;
|
|
|
----------
|
----------
|
-- Fail --
|
-- Fail --
|
----------
|
----------
|
|
|
procedure Fail (S : String) is
|
procedure Fail (S : String) is
|
begin
|
begin
|
-- We use Output in case there is a special output set up.
|
-- We use Output in case there is a special output set up.
|
-- In this case Set_Standard_Error will have no immediate effect.
|
-- In this case Set_Standard_Error will have no immediate effect.
|
|
|
Set_Standard_Error;
|
Set_Standard_Error;
|
Osint.Write_Program_Name;
|
Osint.Write_Program_Name;
|
Write_Str (": ");
|
Write_Str (": ");
|
Write_Str (S);
|
Write_Str (S);
|
Write_Eol;
|
Write_Eol;
|
|
|
Exit_Program (E_Fatal);
|
Exit_Program (E_Fatal);
|
end Fail;
|
end Fail;
|
|
|
---------------
|
---------------
|
-- File_Hash --
|
-- File_Hash --
|
---------------
|
---------------
|
|
|
function File_Hash (F : File_Name_Type) return File_Hash_Num is
|
function File_Hash (F : File_Name_Type) return File_Hash_Num is
|
begin
|
begin
|
return File_Hash_Num (Int (F) rem File_Hash_Num'Range_Length);
|
return File_Hash_Num (Int (F) rem File_Hash_Num'Range_Length);
|
end File_Hash;
|
end File_Hash;
|
|
|
-----------------
|
-----------------
|
-- File_Length --
|
-- File_Length --
|
-----------------
|
-----------------
|
|
|
function File_Length
|
function File_Length
|
(Name : C_File_Name;
|
(Name : C_File_Name;
|
Attr : access File_Attributes) return Long_Integer
|
Attr : access File_Attributes) return Long_Integer
|
is
|
is
|
function Internal
|
function Internal
|
(F : Integer;
|
(F : Integer;
|
N : C_File_Name;
|
N : C_File_Name;
|
A : System.Address) return Long_Integer;
|
A : System.Address) return Long_Integer;
|
pragma Import (C, Internal, "__gnat_file_length_attr");
|
pragma Import (C, Internal, "__gnat_file_length_attr");
|
begin
|
begin
|
return Internal (-1, Name, Attr.all'Address);
|
return Internal (-1, Name, Attr.all'Address);
|
end File_Length;
|
end File_Length;
|
|
|
---------------------
|
---------------------
|
-- File_Time_Stamp --
|
-- File_Time_Stamp --
|
---------------------
|
---------------------
|
|
|
function File_Time_Stamp
|
function File_Time_Stamp
|
(Name : C_File_Name;
|
(Name : C_File_Name;
|
Attr : access File_Attributes) return OS_Time
|
Attr : access File_Attributes) return OS_Time
|
is
|
is
|
function Internal (N : C_File_Name; A : System.Address) return OS_Time;
|
function Internal (N : C_File_Name; A : System.Address) return OS_Time;
|
pragma Import (C, Internal, "__gnat_file_time_name_attr");
|
pragma Import (C, Internal, "__gnat_file_time_name_attr");
|
begin
|
begin
|
return Internal (Name, Attr.all'Address);
|
return Internal (Name, Attr.all'Address);
|
end File_Time_Stamp;
|
end File_Time_Stamp;
|
|
|
function File_Time_Stamp
|
function File_Time_Stamp
|
(Name : Path_Name_Type;
|
(Name : Path_Name_Type;
|
Attr : access File_Attributes) return Time_Stamp_Type
|
Attr : access File_Attributes) return Time_Stamp_Type
|
is
|
is
|
begin
|
begin
|
if Name = No_Path then
|
if Name = No_Path then
|
return Empty_Time_Stamp;
|
return Empty_Time_Stamp;
|
end if;
|
end if;
|
|
|
Get_Name_String (Name);
|
Get_Name_String (Name);
|
Name_Buffer (Name_Len + 1) := ASCII.NUL;
|
Name_Buffer (Name_Len + 1) := ASCII.NUL;
|
return OS_Time_To_GNAT_Time
|
return OS_Time_To_GNAT_Time
|
(File_Time_Stamp (Name_Buffer'Address, Attr));
|
(File_Time_Stamp (Name_Buffer'Address, Attr));
|
end File_Time_Stamp;
|
end File_Time_Stamp;
|
|
|
----------------
|
----------------
|
-- File_Stamp --
|
-- File_Stamp --
|
----------------
|
----------------
|
|
|
function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type is
|
function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type is
|
begin
|
begin
|
if Name = No_File then
|
if Name = No_File then
|
return Empty_Time_Stamp;
|
return Empty_Time_Stamp;
|
end if;
|
end if;
|
|
|
Get_Name_String (Name);
|
Get_Name_String (Name);
|
|
|
-- File_Time_Stamp will always return Invalid_Time if the file does
|
-- 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
|
-- 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
|
-- Empty_Time_Stamp. Therefore we do not need to first test whether
|
-- the file actually exists, which saves a system call.
|
-- the file actually exists, which saves a system call.
|
|
|
return OS_Time_To_GNAT_Time
|
return OS_Time_To_GNAT_Time
|
(File_Time_Stamp (Name_Buffer (1 .. Name_Len)));
|
(File_Time_Stamp (Name_Buffer (1 .. Name_Len)));
|
end File_Stamp;
|
end File_Stamp;
|
|
|
function File_Stamp (Name : Path_Name_Type) return Time_Stamp_Type is
|
function File_Stamp (Name : Path_Name_Type) return Time_Stamp_Type is
|
begin
|
begin
|
return File_Stamp (File_Name_Type (Name));
|
return File_Stamp (File_Name_Type (Name));
|
end File_Stamp;
|
end File_Stamp;
|
|
|
---------------
|
---------------
|
-- Find_File --
|
-- Find_File --
|
---------------
|
---------------
|
|
|
function Find_File
|
function Find_File
|
(N : File_Name_Type;
|
(N : File_Name_Type;
|
T : File_Type) return File_Name_Type
|
T : File_Type) return File_Name_Type
|
is
|
is
|
Attr : aliased File_Attributes;
|
Attr : aliased File_Attributes;
|
Found : File_Name_Type;
|
Found : File_Name_Type;
|
begin
|
begin
|
Find_File (N, T, Found, Attr'Access);
|
Find_File (N, T, Found, Attr'Access);
|
return Found;
|
return Found;
|
end Find_File;
|
end Find_File;
|
|
|
---------------
|
---------------
|
-- Find_File --
|
-- Find_File --
|
---------------
|
---------------
|
|
|
procedure Find_File
|
procedure Find_File
|
(N : File_Name_Type;
|
(N : File_Name_Type;
|
T : File_Type;
|
T : File_Type;
|
Found : out File_Name_Type;
|
Found : out File_Name_Type;
|
Attr : access File_Attributes) is
|
Attr : access File_Attributes) is
|
begin
|
begin
|
Get_Name_String (N);
|
Get_Name_String (N);
|
|
|
declare
|
declare
|
File_Name : String renames Name_Buffer (1 .. Name_Len);
|
File_Name : String renames Name_Buffer (1 .. Name_Len);
|
File : File_Name_Type := No_File;
|
File : File_Name_Type := No_File;
|
Last_Dir : Natural;
|
Last_Dir : Natural;
|
|
|
begin
|
begin
|
-- If we are looking for a config file, look only in the current
|
-- If we are looking for a config file, look only in the current
|
-- directory, i.e. return input argument unchanged. Also look only in
|
-- directory, i.e. return input argument unchanged. Also look only in
|
-- the curren directory if we are looking for a .dg file (happens in
|
-- the curren directory if we are looking for a .dg file (happens in
|
-- -gnatD mode).
|
-- -gnatD mode).
|
|
|
if T = Config
|
if T = Config
|
or else (Debug_Generated_Code
|
or else (Debug_Generated_Code
|
and then Name_Len > 3
|
and then Name_Len > 3
|
and then
|
and then
|
(Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg"
|
(Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg"
|
or else
|
or else
|
(Hostparm.OpenVMS and then
|
(Hostparm.OpenVMS and then
|
Name_Buffer (Name_Len - 2 .. Name_Len) = "_dg")))
|
Name_Buffer (Name_Len - 2 .. Name_Len) = "_dg")))
|
then
|
then
|
Found := N;
|
Found := N;
|
Attr.all := Unknown_Attributes;
|
Attr.all := Unknown_Attributes;
|
return;
|
return;
|
|
|
-- If we are trying to find the current main file just look in the
|
-- If we are trying to find the current main file just look in the
|
-- directory where the user said it was.
|
-- directory where the user said it was.
|
|
|
elsif Look_In_Primary_Directory_For_Current_Main
|
elsif Look_In_Primary_Directory_For_Current_Main
|
and then Current_Main = N
|
and then Current_Main = N
|
then
|
then
|
Locate_File (N, T, Primary_Directory, File_Name, Found, Attr);
|
Locate_File (N, T, Primary_Directory, File_Name, Found, Attr);
|
return;
|
return;
|
|
|
-- Otherwise do standard search for source file
|
-- Otherwise do standard search for source file
|
|
|
else
|
else
|
-- Check the mapping of this file name
|
-- Check the mapping of this file name
|
|
|
File := Mapped_Path_Name (N);
|
File := Mapped_Path_Name (N);
|
|
|
-- If the file name is mapped to a path name, return the
|
-- If the file name is mapped to a path name, return the
|
-- corresponding path name
|
-- corresponding path name
|
|
|
if File /= No_File then
|
if File /= No_File then
|
|
|
-- For locally removed file, Error_Name is returned; then
|
-- For locally removed file, Error_Name is returned; then
|
-- return No_File, indicating the file is not a source.
|
-- return No_File, indicating the file is not a source.
|
|
|
if File = Error_File_Name then
|
if File = Error_File_Name then
|
Found := No_File;
|
Found := No_File;
|
else
|
else
|
Found := File;
|
Found := File;
|
end if;
|
end if;
|
|
|
Attr.all := Unknown_Attributes;
|
Attr.all := Unknown_Attributes;
|
return;
|
return;
|
end if;
|
end if;
|
|
|
-- First place to look is in the primary directory (i.e. the same
|
-- First place to look is in the primary directory (i.e. the same
|
-- directory as the source) unless this has been disabled with -I-
|
-- directory as the source) unless this has been disabled with -I-
|
|
|
if Opt.Look_In_Primary_Dir then
|
if Opt.Look_In_Primary_Dir then
|
Locate_File (N, T, Primary_Directory, File_Name, Found, Attr);
|
Locate_File (N, T, Primary_Directory, File_Name, Found, Attr);
|
|
|
if Found /= No_File then
|
if Found /= No_File then
|
return;
|
return;
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
-- Finally look in directories specified with switches -I/-aI/-aO
|
-- Finally look in directories specified with switches -I/-aI/-aO
|
|
|
if T = Library then
|
if T = Library then
|
Last_Dir := Lib_Search_Directories.Last;
|
Last_Dir := Lib_Search_Directories.Last;
|
else
|
else
|
Last_Dir := Src_Search_Directories.Last;
|
Last_Dir := Src_Search_Directories.Last;
|
end if;
|
end if;
|
|
|
for D in Primary_Directory + 1 .. Last_Dir loop
|
for D in Primary_Directory + 1 .. Last_Dir loop
|
Locate_File (N, T, D, File_Name, Found, Attr);
|
Locate_File (N, T, D, File_Name, Found, Attr);
|
|
|
if Found /= No_File then
|
if Found /= No_File then
|
return;
|
return;
|
end if;
|
end if;
|
end loop;
|
end loop;
|
|
|
Attr.all := Unknown_Attributes;
|
Attr.all := Unknown_Attributes;
|
Found := No_File;
|
Found := No_File;
|
end if;
|
end if;
|
end;
|
end;
|
end Find_File;
|
end Find_File;
|
|
|
-----------------------
|
-----------------------
|
-- Find_Program_Name --
|
-- Find_Program_Name --
|
-----------------------
|
-----------------------
|
|
|
procedure Find_Program_Name is
|
procedure Find_Program_Name is
|
Command_Name : String (1 .. Len_Arg (0));
|
Command_Name : String (1 .. Len_Arg (0));
|
Cindex1 : Integer := Command_Name'First;
|
Cindex1 : Integer := Command_Name'First;
|
Cindex2 : Integer := Command_Name'Last;
|
Cindex2 : Integer := Command_Name'Last;
|
|
|
begin
|
begin
|
Fill_Arg (Command_Name'Address, 0);
|
Fill_Arg (Command_Name'Address, 0);
|
|
|
if Command_Name = "" then
|
if Command_Name = "" then
|
Name_Len := 0;
|
Name_Len := 0;
|
return;
|
return;
|
end if;
|
end if;
|
|
|
-- The program name might be specified by a full path name. However,
|
-- 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
|
-- we don't want to print that all out in an error message, so the
|
-- path might need to be stripped away.
|
-- path might need to be stripped away.
|
|
|
for J in reverse Cindex1 .. Cindex2 loop
|
for J in reverse Cindex1 .. Cindex2 loop
|
if Is_Directory_Separator (Command_Name (J)) then
|
if Is_Directory_Separator (Command_Name (J)) then
|
Cindex1 := J + 1;
|
Cindex1 := J + 1;
|
exit;
|
exit;
|
end if;
|
end if;
|
end loop;
|
end loop;
|
|
|
-- Command_Name(Cindex1 .. Cindex2) is now the equivalent of the
|
-- Command_Name(Cindex1 .. Cindex2) is now the equivalent of the
|
-- POSIX command "basename argv[0]"
|
-- POSIX command "basename argv[0]"
|
|
|
-- Strip off any versioning information such as found on VMS.
|
-- Strip off any versioning information such as found on VMS.
|
-- This would take the form of TOOL.exe followed by a ";" or "."
|
-- This would take the form of TOOL.exe followed by a ";" or "."
|
-- and a sequence of one or more numbers.
|
-- and a sequence of one or more numbers.
|
|
|
if Command_Name (Cindex2) in '0' .. '9' then
|
if Command_Name (Cindex2) in '0' .. '9' then
|
for J in reverse Cindex1 .. Cindex2 loop
|
for J in reverse Cindex1 .. Cindex2 loop
|
if Command_Name (J) = '.' or else Command_Name (J) = ';' then
|
if Command_Name (J) = '.' or else Command_Name (J) = ';' then
|
Cindex2 := J - 1;
|
Cindex2 := J - 1;
|
exit;
|
exit;
|
end if;
|
end if;
|
|
|
exit when Command_Name (J) not in '0' .. '9';
|
exit when Command_Name (J) not in '0' .. '9';
|
end loop;
|
end loop;
|
end if;
|
end if;
|
|
|
-- Strip off any executable extension (usually nothing or .exe)
|
-- Strip off any executable extension (usually nothing or .exe)
|
-- but formally reported by autoconf in the variable EXEEXT
|
-- but formally reported by autoconf in the variable EXEEXT
|
|
|
if Cindex2 - Cindex1 >= 4 then
|
if Cindex2 - Cindex1 >= 4 then
|
if To_Lower (Command_Name (Cindex2 - 3)) = '.'
|
if To_Lower (Command_Name (Cindex2 - 3)) = '.'
|
and then To_Lower (Command_Name (Cindex2 - 2)) = 'e'
|
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 - 1)) = 'x'
|
and then To_Lower (Command_Name (Cindex2)) = 'e'
|
and then To_Lower (Command_Name (Cindex2)) = 'e'
|
then
|
then
|
Cindex2 := Cindex2 - 4;
|
Cindex2 := Cindex2 - 4;
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
Name_Len := Cindex2 - Cindex1 + 1;
|
Name_Len := Cindex2 - Cindex1 + 1;
|
Name_Buffer (1 .. Name_Len) := Command_Name (Cindex1 .. Cindex2);
|
Name_Buffer (1 .. Name_Len) := Command_Name (Cindex1 .. Cindex2);
|
end Find_Program_Name;
|
end Find_Program_Name;
|
|
|
------------------------
|
------------------------
|
-- Full_Lib_File_Name --
|
-- Full_Lib_File_Name --
|
------------------------
|
------------------------
|
|
|
procedure Full_Lib_File_Name
|
procedure Full_Lib_File_Name
|
(N : File_Name_Type;
|
(N : File_Name_Type;
|
Lib_File : out File_Name_Type;
|
Lib_File : out File_Name_Type;
|
Attr : out File_Attributes)
|
Attr : out File_Attributes)
|
is
|
is
|
A : aliased File_Attributes;
|
A : aliased File_Attributes;
|
begin
|
begin
|
-- ??? seems we could use Smart_Find_File here
|
-- ??? seems we could use Smart_Find_File here
|
Find_File (N, Library, Lib_File, A'Access);
|
Find_File (N, Library, Lib_File, A'Access);
|
Attr := A;
|
Attr := A;
|
end Full_Lib_File_Name;
|
end Full_Lib_File_Name;
|
|
|
------------------------
|
------------------------
|
-- Full_Lib_File_Name --
|
-- Full_Lib_File_Name --
|
------------------------
|
------------------------
|
|
|
function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type is
|
function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type is
|
Attr : File_Attributes;
|
Attr : File_Attributes;
|
File : File_Name_Type;
|
File : File_Name_Type;
|
begin
|
begin
|
Full_Lib_File_Name (N, File, Attr);
|
Full_Lib_File_Name (N, File, Attr);
|
return File;
|
return File;
|
end Full_Lib_File_Name;
|
end Full_Lib_File_Name;
|
|
|
----------------------------
|
----------------------------
|
-- Full_Library_Info_Name --
|
-- Full_Library_Info_Name --
|
----------------------------
|
----------------------------
|
|
|
function Full_Library_Info_Name return File_Name_Type is
|
function Full_Library_Info_Name return File_Name_Type is
|
begin
|
begin
|
return Current_Full_Lib_Name;
|
return Current_Full_Lib_Name;
|
end Full_Library_Info_Name;
|
end Full_Library_Info_Name;
|
|
|
---------------------------
|
---------------------------
|
-- Full_Object_File_Name --
|
-- Full_Object_File_Name --
|
---------------------------
|
---------------------------
|
|
|
function Full_Object_File_Name return File_Name_Type is
|
function Full_Object_File_Name return File_Name_Type is
|
begin
|
begin
|
return Current_Full_Obj_Name;
|
return Current_Full_Obj_Name;
|
end Full_Object_File_Name;
|
end Full_Object_File_Name;
|
|
|
----------------------
|
----------------------
|
-- Full_Source_Name --
|
-- Full_Source_Name --
|
----------------------
|
----------------------
|
|
|
function Full_Source_Name return File_Name_Type is
|
function Full_Source_Name return File_Name_Type is
|
begin
|
begin
|
return Current_Full_Source_Name;
|
return Current_Full_Source_Name;
|
end Full_Source_Name;
|
end Full_Source_Name;
|
|
|
----------------------
|
----------------------
|
-- Full_Source_Name --
|
-- Full_Source_Name --
|
----------------------
|
----------------------
|
|
|
function Full_Source_Name (N : File_Name_Type) return File_Name_Type is
|
function Full_Source_Name (N : File_Name_Type) return File_Name_Type is
|
begin
|
begin
|
return Smart_Find_File (N, Source);
|
return Smart_Find_File (N, Source);
|
end Full_Source_Name;
|
end Full_Source_Name;
|
|
|
----------------------
|
----------------------
|
-- Full_Source_Name --
|
-- Full_Source_Name --
|
----------------------
|
----------------------
|
|
|
procedure Full_Source_Name
|
procedure Full_Source_Name
|
(N : File_Name_Type;
|
(N : File_Name_Type;
|
Full_File : out File_Name_Type;
|
Full_File : out File_Name_Type;
|
Attr : access File_Attributes) is
|
Attr : access File_Attributes) is
|
begin
|
begin
|
Smart_Find_File (N, Source, Full_File, Attr.all);
|
Smart_Find_File (N, Source, Full_File, Attr.all);
|
end Full_Source_Name;
|
end Full_Source_Name;
|
|
|
-------------------
|
-------------------
|
-- Get_Directory --
|
-- Get_Directory --
|
-------------------
|
-------------------
|
|
|
function Get_Directory (Name : File_Name_Type) return File_Name_Type is
|
function Get_Directory (Name : File_Name_Type) return File_Name_Type is
|
begin
|
begin
|
Get_Name_String (Name);
|
Get_Name_String (Name);
|
|
|
for J in reverse 1 .. Name_Len loop
|
for J in reverse 1 .. Name_Len loop
|
if Is_Directory_Separator (Name_Buffer (J)) then
|
if Is_Directory_Separator (Name_Buffer (J)) then
|
Name_Len := J;
|
Name_Len := J;
|
return Name_Find;
|
return Name_Find;
|
end if;
|
end if;
|
end loop;
|
end loop;
|
|
|
Name_Len := Hostparm.Normalized_CWD'Length;
|
Name_Len := Hostparm.Normalized_CWD'Length;
|
Name_Buffer (1 .. Name_Len) := Hostparm.Normalized_CWD;
|
Name_Buffer (1 .. Name_Len) := Hostparm.Normalized_CWD;
|
return Name_Find;
|
return Name_Find;
|
end Get_Directory;
|
end Get_Directory;
|
|
|
--------------------------
|
--------------------------
|
-- Get_Next_Dir_In_Path --
|
-- Get_Next_Dir_In_Path --
|
--------------------------
|
--------------------------
|
|
|
Search_Path_Pos : Integer;
|
Search_Path_Pos : Integer;
|
-- Keeps track of current position in search path. Initialized by the
|
-- Keeps track of current position in search path. Initialized by the
|
-- call to Get_Next_Dir_In_Path_Init, updated by Get_Next_Dir_In_Path.
|
-- call to Get_Next_Dir_In_Path_Init, updated by Get_Next_Dir_In_Path.
|
|
|
function 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
|
is
|
Lower_Bound : Positive := Search_Path_Pos;
|
Lower_Bound : Positive := Search_Path_Pos;
|
Upper_Bound : Positive;
|
Upper_Bound : Positive;
|
|
|
begin
|
begin
|
loop
|
loop
|
while Lower_Bound <= Search_Path'Last
|
while Lower_Bound <= Search_Path'Last
|
and then Search_Path.all (Lower_Bound) = Path_Separator
|
and then Search_Path.all (Lower_Bound) = Path_Separator
|
loop
|
loop
|
Lower_Bound := Lower_Bound + 1;
|
Lower_Bound := Lower_Bound + 1;
|
end loop;
|
end loop;
|
|
|
exit when Lower_Bound > Search_Path'Last;
|
exit when Lower_Bound > Search_Path'Last;
|
|
|
Upper_Bound := Lower_Bound;
|
Upper_Bound := Lower_Bound;
|
while Upper_Bound <= Search_Path'Last
|
while Upper_Bound <= Search_Path'Last
|
and then Search_Path.all (Upper_Bound) /= Path_Separator
|
and then Search_Path.all (Upper_Bound) /= Path_Separator
|
loop
|
loop
|
Upper_Bound := Upper_Bound + 1;
|
Upper_Bound := Upper_Bound + 1;
|
end loop;
|
end loop;
|
|
|
Search_Path_Pos := Upper_Bound;
|
Search_Path_Pos := Upper_Bound;
|
return new String'(Search_Path.all (Lower_Bound .. Upper_Bound - 1));
|
return new String'(Search_Path.all (Lower_Bound .. Upper_Bound - 1));
|
end loop;
|
end loop;
|
|
|
return null;
|
return null;
|
end Get_Next_Dir_In_Path;
|
end Get_Next_Dir_In_Path;
|
|
|
-------------------------------
|
-------------------------------
|
-- Get_Next_Dir_In_Path_Init --
|
-- Get_Next_Dir_In_Path_Init --
|
-------------------------------
|
-------------------------------
|
|
|
procedure Get_Next_Dir_In_Path_Init (Search_Path : String_Access) is
|
procedure Get_Next_Dir_In_Path_Init (Search_Path : String_Access) is
|
begin
|
begin
|
Search_Path_Pos := Search_Path'First;
|
Search_Path_Pos := Search_Path'First;
|
end Get_Next_Dir_In_Path_Init;
|
end Get_Next_Dir_In_Path_Init;
|
|
|
--------------------------------------
|
--------------------------------------
|
-- Get_Primary_Src_Search_Directory --
|
-- Get_Primary_Src_Search_Directory --
|
--------------------------------------
|
--------------------------------------
|
|
|
function Get_Primary_Src_Search_Directory return String_Ptr is
|
function Get_Primary_Src_Search_Directory return String_Ptr is
|
begin
|
begin
|
return Src_Search_Directories.Table (Primary_Directory);
|
return Src_Search_Directories.Table (Primary_Directory);
|
end Get_Primary_Src_Search_Directory;
|
end Get_Primary_Src_Search_Directory;
|
|
|
------------------------
|
------------------------
|
-- Get_RTS_Search_Dir --
|
-- Get_RTS_Search_Dir --
|
------------------------
|
------------------------
|
|
|
function Get_RTS_Search_Dir
|
function Get_RTS_Search_Dir
|
(Search_Dir : String;
|
(Search_Dir : String;
|
File_Type : Search_File_Type) return String_Ptr
|
File_Type : Search_File_Type) return String_Ptr
|
is
|
is
|
procedure Get_Current_Dir
|
procedure Get_Current_Dir
|
(Dir : System.Address;
|
(Dir : System.Address;
|
Length : System.Address);
|
Length : System.Address);
|
pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir");
|
pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir");
|
|
|
Max_Path : Integer;
|
Max_Path : Integer;
|
pragma Import (C, Max_Path, "__gnat_max_path_len");
|
pragma Import (C, Max_Path, "__gnat_max_path_len");
|
-- Maximum length of a path name
|
-- Maximum length of a path name
|
|
|
Current_Dir : String_Ptr;
|
Current_Dir : String_Ptr;
|
Default_Search_Dir : String_Access;
|
Default_Search_Dir : String_Access;
|
Default_Suffix_Dir : String_Access;
|
Default_Suffix_Dir : String_Access;
|
Local_Search_Dir : String_Access;
|
Local_Search_Dir : String_Access;
|
Norm_Search_Dir : String_Access;
|
Norm_Search_Dir : String_Access;
|
Result_Search_Dir : String_Access;
|
Result_Search_Dir : String_Access;
|
Search_File : String_Access;
|
Search_File : String_Access;
|
Temp_String : String_Ptr;
|
Temp_String : String_Ptr;
|
|
|
begin
|
begin
|
-- Add a directory separator at the end of the directory if necessary
|
-- Add a directory separator at the end of the directory if necessary
|
-- so that we can directly append a file to the directory
|
-- so that we can directly append a file to the directory
|
|
|
if Search_Dir (Search_Dir'Last) /= Directory_Separator then
|
if Search_Dir (Search_Dir'Last) /= Directory_Separator then
|
Local_Search_Dir :=
|
Local_Search_Dir :=
|
new String'(Search_Dir & String'(1 => Directory_Separator));
|
new String'(Search_Dir & String'(1 => Directory_Separator));
|
else
|
else
|
Local_Search_Dir := new String'(Search_Dir);
|
Local_Search_Dir := new String'(Search_Dir);
|
end if;
|
end if;
|
|
|
if File_Type = Include then
|
if File_Type = Include then
|
Search_File := Include_Search_File;
|
Search_File := Include_Search_File;
|
Default_Suffix_Dir := new String'("adainclude");
|
Default_Suffix_Dir := new String'("adainclude");
|
else
|
else
|
Search_File := Objects_Search_File;
|
Search_File := Objects_Search_File;
|
Default_Suffix_Dir := new String'("adalib");
|
Default_Suffix_Dir := new String'("adalib");
|
end if;
|
end if;
|
|
|
Norm_Search_Dir := To_Canonical_Path_Spec (Local_Search_Dir.all);
|
Norm_Search_Dir := To_Canonical_Path_Spec (Local_Search_Dir.all);
|
|
|
if Is_Absolute_Path (Norm_Search_Dir.all) then
|
if Is_Absolute_Path (Norm_Search_Dir.all) then
|
|
|
-- We first verify if there is a directory Include_Search_Dir
|
-- We first verify if there is a directory Include_Search_Dir
|
-- containing default search directories
|
-- containing default search directories
|
|
|
Result_Search_Dir :=
|
Result_Search_Dir :=
|
Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
|
Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
|
Default_Search_Dir :=
|
Default_Search_Dir :=
|
new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
|
new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
|
Free (Norm_Search_Dir);
|
Free (Norm_Search_Dir);
|
|
|
if Result_Search_Dir /= null then
|
if Result_Search_Dir /= null then
|
return String_Ptr (Result_Search_Dir);
|
return String_Ptr (Result_Search_Dir);
|
elsif Is_Directory (Default_Search_Dir.all) then
|
elsif Is_Directory (Default_Search_Dir.all) then
|
return String_Ptr (Default_Search_Dir);
|
return String_Ptr (Default_Search_Dir);
|
else
|
else
|
return null;
|
return null;
|
end if;
|
end if;
|
|
|
-- Search in the current directory
|
-- Search in the current directory
|
|
|
else
|
else
|
-- Get the current directory
|
-- Get the current directory
|
|
|
declare
|
declare
|
Buffer : String (1 .. Max_Path + 2);
|
Buffer : String (1 .. Max_Path + 2);
|
Path_Len : Natural := Max_Path;
|
Path_Len : Natural := Max_Path;
|
|
|
begin
|
begin
|
Get_Current_Dir (Buffer'Address, Path_Len'Address);
|
Get_Current_Dir (Buffer'Address, Path_Len'Address);
|
|
|
if Buffer (Path_Len) /= Directory_Separator then
|
if Buffer (Path_Len) /= Directory_Separator then
|
Path_Len := Path_Len + 1;
|
Path_Len := Path_Len + 1;
|
Buffer (Path_Len) := Directory_Separator;
|
Buffer (Path_Len) := Directory_Separator;
|
end if;
|
end if;
|
|
|
Current_Dir := new String'(Buffer (1 .. Path_Len));
|
Current_Dir := new String'(Buffer (1 .. Path_Len));
|
end;
|
end;
|
|
|
Norm_Search_Dir :=
|
Norm_Search_Dir :=
|
new String'(Current_Dir.all & Local_Search_Dir.all);
|
new String'(Current_Dir.all & Local_Search_Dir.all);
|
|
|
Result_Search_Dir :=
|
Result_Search_Dir :=
|
Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
|
Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
|
|
|
Default_Search_Dir :=
|
Default_Search_Dir :=
|
new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
|
new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
|
|
|
Free (Norm_Search_Dir);
|
Free (Norm_Search_Dir);
|
|
|
if Result_Search_Dir /= null then
|
if Result_Search_Dir /= null then
|
return String_Ptr (Result_Search_Dir);
|
return String_Ptr (Result_Search_Dir);
|
|
|
elsif Is_Directory (Default_Search_Dir.all) then
|
elsif Is_Directory (Default_Search_Dir.all) then
|
return String_Ptr (Default_Search_Dir);
|
return String_Ptr (Default_Search_Dir);
|
|
|
else
|
else
|
-- Search in Search_Dir_Prefix/Search_Dir
|
-- Search in Search_Dir_Prefix/Search_Dir
|
|
|
Norm_Search_Dir :=
|
Norm_Search_Dir :=
|
new String'
|
new String'
|
(Update_Path (Search_Dir_Prefix).all & Local_Search_Dir.all);
|
(Update_Path (Search_Dir_Prefix).all & Local_Search_Dir.all);
|
|
|
Result_Search_Dir :=
|
Result_Search_Dir :=
|
Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
|
Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
|
|
|
Default_Search_Dir :=
|
Default_Search_Dir :=
|
new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
|
new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
|
|
|
Free (Norm_Search_Dir);
|
Free (Norm_Search_Dir);
|
|
|
if Result_Search_Dir /= null then
|
if Result_Search_Dir /= null then
|
return String_Ptr (Result_Search_Dir);
|
return String_Ptr (Result_Search_Dir);
|
|
|
elsif Is_Directory (Default_Search_Dir.all) then
|
elsif Is_Directory (Default_Search_Dir.all) then
|
return String_Ptr (Default_Search_Dir);
|
return String_Ptr (Default_Search_Dir);
|
|
|
else
|
else
|
-- We finally search in Search_Dir_Prefix/rts-Search_Dir
|
-- We finally search in Search_Dir_Prefix/rts-Search_Dir
|
|
|
Temp_String :=
|
Temp_String :=
|
new String'(Update_Path (Search_Dir_Prefix).all & "rts-");
|
new String'(Update_Path (Search_Dir_Prefix).all & "rts-");
|
|
|
Norm_Search_Dir :=
|
Norm_Search_Dir :=
|
new String'(Temp_String.all & Local_Search_Dir.all);
|
new String'(Temp_String.all & Local_Search_Dir.all);
|
|
|
Result_Search_Dir :=
|
Result_Search_Dir :=
|
Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
|
Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
|
|
|
Default_Search_Dir :=
|
Default_Search_Dir :=
|
new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
|
new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
|
Free (Norm_Search_Dir);
|
Free (Norm_Search_Dir);
|
|
|
if Result_Search_Dir /= null then
|
if Result_Search_Dir /= null then
|
return String_Ptr (Result_Search_Dir);
|
return String_Ptr (Result_Search_Dir);
|
|
|
elsif Is_Directory (Default_Search_Dir.all) then
|
elsif Is_Directory (Default_Search_Dir.all) then
|
return String_Ptr (Default_Search_Dir);
|
return String_Ptr (Default_Search_Dir);
|
|
|
else
|
else
|
return null;
|
return null;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
end Get_RTS_Search_Dir;
|
end Get_RTS_Search_Dir;
|
|
|
--------------------------------
|
--------------------------------
|
-- Include_Dir_Default_Prefix --
|
-- Include_Dir_Default_Prefix --
|
--------------------------------
|
--------------------------------
|
|
|
function Include_Dir_Default_Prefix return String_Access is
|
function Include_Dir_Default_Prefix return String_Access is
|
begin
|
begin
|
if The_Include_Dir_Default_Prefix = null then
|
if The_Include_Dir_Default_Prefix = null then
|
The_Include_Dir_Default_Prefix :=
|
The_Include_Dir_Default_Prefix :=
|
String_Access (Update_Path (Include_Dir_Default_Name));
|
String_Access (Update_Path (Include_Dir_Default_Name));
|
end if;
|
end if;
|
|
|
return The_Include_Dir_Default_Prefix;
|
return The_Include_Dir_Default_Prefix;
|
end Include_Dir_Default_Prefix;
|
end Include_Dir_Default_Prefix;
|
|
|
function Include_Dir_Default_Prefix return String is
|
function Include_Dir_Default_Prefix return String is
|
begin
|
begin
|
return Include_Dir_Default_Prefix.all;
|
return Include_Dir_Default_Prefix.all;
|
end Include_Dir_Default_Prefix;
|
end Include_Dir_Default_Prefix;
|
|
|
----------------
|
----------------
|
-- Initialize --
|
-- Initialize --
|
----------------
|
----------------
|
|
|
procedure Initialize is
|
procedure Initialize is
|
begin
|
begin
|
Number_File_Names := 0;
|
Number_File_Names := 0;
|
Current_File_Name_Index := 0;
|
Current_File_Name_Index := 0;
|
|
|
Src_Search_Directories.Init;
|
Src_Search_Directories.Init;
|
Lib_Search_Directories.Init;
|
Lib_Search_Directories.Init;
|
|
|
-- Start off by setting all suppress options to False, these will
|
-- Start off by setting all suppress options to False, these will
|
-- be reset later (turning some on if -gnato is not specified, and
|
-- be reset later (turning some on if -gnato is not specified, and
|
-- turning all of them on if -gnatp is specified).
|
-- turning all of them on if -gnatp is specified).
|
|
|
Suppress_Options := (others => False);
|
Suppress_Options := (others => False);
|
|
|
-- Reserve the first slot in the search paths table. This is the
|
-- 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
|
-- 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
|
-- 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 specified for this main source or library file. This is the
|
-- directory which is searched first by default. This default search is
|
-- directory which is searched first by default. This default search is
|
-- inhibited by the option -I- for both source and library files.
|
-- inhibited by the option -I- for both source and library files.
|
|
|
Src_Search_Directories.Set_Last (Primary_Directory);
|
Src_Search_Directories.Set_Last (Primary_Directory);
|
Src_Search_Directories.Table (Primary_Directory) := new String'("");
|
Src_Search_Directories.Table (Primary_Directory) := new String'("");
|
|
|
Lib_Search_Directories.Set_Last (Primary_Directory);
|
Lib_Search_Directories.Set_Last (Primary_Directory);
|
Lib_Search_Directories.Table (Primary_Directory) := new String'("");
|
Lib_Search_Directories.Table (Primary_Directory) := new String'("");
|
end Initialize;
|
end Initialize;
|
|
|
------------------
|
------------------
|
-- Is_Directory --
|
-- Is_Directory --
|
------------------
|
------------------
|
|
|
function Is_Directory
|
function Is_Directory
|
(Name : C_File_Name; Attr : access File_Attributes) return Boolean
|
(Name : C_File_Name; Attr : access File_Attributes) return Boolean
|
is
|
is
|
function Internal (N : C_File_Name; A : System.Address) return Integer;
|
function Internal (N : C_File_Name; A : System.Address) return Integer;
|
pragma Import (C, Internal, "__gnat_is_directory_attr");
|
pragma Import (C, Internal, "__gnat_is_directory_attr");
|
begin
|
begin
|
return Internal (Name, Attr.all'Address) /= 0;
|
return Internal (Name, Attr.all'Address) /= 0;
|
end Is_Directory;
|
end Is_Directory;
|
|
|
----------------------------
|
----------------------------
|
-- Is_Directory_Separator --
|
-- Is_Directory_Separator --
|
----------------------------
|
----------------------------
|
|
|
function Is_Directory_Separator (C : Character) return Boolean is
|
function Is_Directory_Separator (C : Character) return Boolean is
|
begin
|
begin
|
-- In addition to the default directory_separator allow the '/' to
|
-- In addition to the default directory_separator allow the '/' to
|
-- act as separator since this is allowed in MS-DOS, Windows 95/NT,
|
-- act as separator since this is allowed in MS-DOS, Windows 95/NT,
|
-- and OS2 ports. On VMS, the situation is more complicated because
|
-- and OS2 ports. On VMS, the situation is more complicated because
|
-- there are two characters to check for.
|
-- there are two characters to check for.
|
|
|
return
|
return
|
C = Directory_Separator
|
C = Directory_Separator
|
or else C = '/'
|
or else C = '/'
|
or else (Hostparm.OpenVMS
|
or else (Hostparm.OpenVMS
|
and then (C = ']' or else C = ':'));
|
and then (C = ']' or else C = ':'));
|
end Is_Directory_Separator;
|
end Is_Directory_Separator;
|
|
|
-------------------------
|
-------------------------
|
-- Is_Readonly_Library --
|
-- Is_Readonly_Library --
|
-------------------------
|
-------------------------
|
|
|
function Is_Readonly_Library (File : File_Name_Type) return Boolean is
|
function Is_Readonly_Library (File : File_Name_Type) return Boolean is
|
begin
|
begin
|
Get_Name_String (File);
|
Get_Name_String (File);
|
|
|
pragma Assert (Name_Buffer (Name_Len - 3 .. Name_Len) = ".ali");
|
pragma Assert (Name_Buffer (Name_Len - 3 .. Name_Len) = ".ali");
|
|
|
return not Is_Writable_File (Name_Buffer (1 .. Name_Len));
|
return not Is_Writable_File (Name_Buffer (1 .. Name_Len));
|
end Is_Readonly_Library;
|
end Is_Readonly_Library;
|
|
|
------------------------
|
------------------------
|
-- Is_Executable_File --
|
-- Is_Executable_File --
|
------------------------
|
------------------------
|
|
|
function Is_Executable_File
|
function Is_Executable_File
|
(Name : C_File_Name; Attr : access File_Attributes) return Boolean
|
(Name : C_File_Name; Attr : access File_Attributes) return Boolean
|
is
|
is
|
function Internal (N : C_File_Name; A : System.Address) return Integer;
|
function Internal (N : C_File_Name; A : System.Address) return Integer;
|
pragma Import (C, Internal, "__gnat_is_executable_file_attr");
|
pragma Import (C, Internal, "__gnat_is_executable_file_attr");
|
begin
|
begin
|
return Internal (Name, Attr.all'Address) /= 0;
|
return Internal (Name, Attr.all'Address) /= 0;
|
end Is_Executable_File;
|
end Is_Executable_File;
|
|
|
----------------------
|
----------------------
|
-- Is_Readable_File --
|
-- Is_Readable_File --
|
----------------------
|
----------------------
|
|
|
function Is_Readable_File
|
function Is_Readable_File
|
(Name : C_File_Name; Attr : access File_Attributes) return Boolean
|
(Name : C_File_Name; Attr : access File_Attributes) return Boolean
|
is
|
is
|
function Internal (N : C_File_Name; A : System.Address) return Integer;
|
function Internal (N : C_File_Name; A : System.Address) return Integer;
|
pragma Import (C, Internal, "__gnat_is_readable_file_attr");
|
pragma Import (C, Internal, "__gnat_is_readable_file_attr");
|
begin
|
begin
|
return Internal (Name, Attr.all'Address) /= 0;
|
return Internal (Name, Attr.all'Address) /= 0;
|
end Is_Readable_File;
|
end Is_Readable_File;
|
|
|
---------------------
|
---------------------
|
-- Is_Regular_File --
|
-- Is_Regular_File --
|
---------------------
|
---------------------
|
|
|
function Is_Regular_File
|
function Is_Regular_File
|
(Name : C_File_Name; Attr : access File_Attributes) return Boolean
|
(Name : C_File_Name; Attr : access File_Attributes) return Boolean
|
is
|
is
|
function Internal (N : C_File_Name; A : System.Address) return Integer;
|
function Internal (N : C_File_Name; A : System.Address) return Integer;
|
pragma Import (C, Internal, "__gnat_is_regular_file_attr");
|
pragma Import (C, Internal, "__gnat_is_regular_file_attr");
|
begin
|
begin
|
return Internal (Name, Attr.all'Address) /= 0;
|
return Internal (Name, Attr.all'Address) /= 0;
|
end Is_Regular_File;
|
end Is_Regular_File;
|
|
|
----------------------
|
----------------------
|
-- Is_Symbolic_Link --
|
-- Is_Symbolic_Link --
|
----------------------
|
----------------------
|
|
|
function Is_Symbolic_Link
|
function Is_Symbolic_Link
|
(Name : C_File_Name; Attr : access File_Attributes) return Boolean
|
(Name : C_File_Name; Attr : access File_Attributes) return Boolean
|
is
|
is
|
function Internal (N : C_File_Name; A : System.Address) return Integer;
|
function Internal (N : C_File_Name; A : System.Address) return Integer;
|
pragma Import (C, Internal, "__gnat_is_symbolic_link_attr");
|
pragma Import (C, Internal, "__gnat_is_symbolic_link_attr");
|
begin
|
begin
|
return Internal (Name, Attr.all'Address) /= 0;
|
return Internal (Name, Attr.all'Address) /= 0;
|
end Is_Symbolic_Link;
|
end Is_Symbolic_Link;
|
|
|
----------------------
|
----------------------
|
-- Is_Writable_File --
|
-- Is_Writable_File --
|
----------------------
|
----------------------
|
|
|
function Is_Writable_File
|
function Is_Writable_File
|
(Name : C_File_Name; Attr : access File_Attributes) return Boolean
|
(Name : C_File_Name; Attr : access File_Attributes) return Boolean
|
is
|
is
|
function Internal (N : C_File_Name; A : System.Address) return Integer;
|
function Internal (N : C_File_Name; A : System.Address) return Integer;
|
pragma Import (C, Internal, "__gnat_is_writable_file_attr");
|
pragma Import (C, Internal, "__gnat_is_writable_file_attr");
|
begin
|
begin
|
return Internal (Name, Attr.all'Address) /= 0;
|
return Internal (Name, Attr.all'Address) /= 0;
|
end Is_Writable_File;
|
end Is_Writable_File;
|
|
|
-------------------
|
-------------------
|
-- Lib_File_Name --
|
-- Lib_File_Name --
|
-------------------
|
-------------------
|
|
|
function Lib_File_Name
|
function Lib_File_Name
|
(Source_File : File_Name_Type;
|
(Source_File : File_Name_Type;
|
Munit_Index : Nat := 0) return File_Name_Type
|
Munit_Index : Nat := 0) return File_Name_Type
|
is
|
is
|
begin
|
begin
|
Get_Name_String (Source_File);
|
Get_Name_String (Source_File);
|
|
|
for J in reverse 2 .. Name_Len loop
|
for J in reverse 2 .. Name_Len loop
|
if Name_Buffer (J) = '.' then
|
if Name_Buffer (J) = '.' then
|
Name_Len := J - 1;
|
Name_Len := J - 1;
|
exit;
|
exit;
|
end if;
|
end if;
|
end loop;
|
end loop;
|
|
|
if Munit_Index /= 0 then
|
if Munit_Index /= 0 then
|
Add_Char_To_Name_Buffer (Multi_Unit_Index_Character);
|
Add_Char_To_Name_Buffer (Multi_Unit_Index_Character);
|
Add_Nat_To_Name_Buffer (Munit_Index);
|
Add_Nat_To_Name_Buffer (Munit_Index);
|
end if;
|
end if;
|
|
|
Add_Char_To_Name_Buffer ('.');
|
Add_Char_To_Name_Buffer ('.');
|
Add_Str_To_Name_Buffer (ALI_Suffix.all);
|
Add_Str_To_Name_Buffer (ALI_Suffix.all);
|
return Name_Find;
|
return Name_Find;
|
end Lib_File_Name;
|
end Lib_File_Name;
|
|
|
-----------------
|
-----------------
|
-- Locate_File --
|
-- Locate_File --
|
-----------------
|
-----------------
|
|
|
procedure Locate_File
|
procedure Locate_File
|
(N : File_Name_Type;
|
(N : File_Name_Type;
|
T : File_Type;
|
T : File_Type;
|
Dir : Natural;
|
Dir : Natural;
|
Name : String;
|
Name : String;
|
Found : out File_Name_Type;
|
Found : out File_Name_Type;
|
Attr : access File_Attributes)
|
Attr : access File_Attributes)
|
is
|
is
|
Dir_Name : String_Ptr;
|
Dir_Name : String_Ptr;
|
|
|
begin
|
begin
|
-- If Name is already an absolute path, do not look for a directory
|
-- If Name is already an absolute path, do not look for a directory
|
|
|
if Is_Absolute_Path (Name) then
|
if Is_Absolute_Path (Name) then
|
Dir_Name := No_Dir;
|
Dir_Name := No_Dir;
|
|
|
elsif T = Library then
|
elsif T = Library then
|
Dir_Name := Lib_Search_Directories.Table (Dir);
|
Dir_Name := Lib_Search_Directories.Table (Dir);
|
|
|
else
|
else
|
pragma Assert (T /= Config);
|
pragma Assert (T /= Config);
|
Dir_Name := Src_Search_Directories.Table (Dir);
|
Dir_Name := Src_Search_Directories.Table (Dir);
|
end if;
|
end if;
|
|
|
declare
|
declare
|
Full_Name : String (1 .. Dir_Name'Length + Name'Length + 1);
|
Full_Name : String (1 .. Dir_Name'Length + Name'Length + 1);
|
|
|
begin
|
begin
|
Full_Name (1 .. Dir_Name'Length) := Dir_Name.all;
|
Full_Name (1 .. Dir_Name'Length) := Dir_Name.all;
|
Full_Name (Dir_Name'Length + 1 .. Full_Name'Last - 1) := Name;
|
Full_Name (Dir_Name'Length + 1 .. Full_Name'Last - 1) := Name;
|
Full_Name (Full_Name'Last) := ASCII.NUL;
|
Full_Name (Full_Name'Last) := ASCII.NUL;
|
|
|
Attr.all := Unknown_Attributes;
|
Attr.all := Unknown_Attributes;
|
|
|
if not Is_Regular_File (Full_Name'Address, Attr) then
|
if not Is_Regular_File (Full_Name'Address, Attr) then
|
Found := No_File;
|
Found := No_File;
|
|
|
else
|
else
|
-- If the file is in the current directory then return N itself
|
-- If the file is in the current directory then return N itself
|
|
|
if Dir_Name'Length = 0 then
|
if Dir_Name'Length = 0 then
|
Found := N;
|
Found := N;
|
else
|
else
|
Name_Len := Full_Name'Length - 1;
|
Name_Len := Full_Name'Length - 1;
|
Name_Buffer (1 .. Name_Len) :=
|
Name_Buffer (1 .. Name_Len) :=
|
Full_Name (1 .. Full_Name'Last - 1);
|
Full_Name (1 .. Full_Name'Last - 1);
|
Found := Name_Find; -- ??? Was Name_Enter, no obvious reason
|
Found := Name_Find; -- ??? Was Name_Enter, no obvious reason
|
end if;
|
end if;
|
end if;
|
end if;
|
end;
|
end;
|
end Locate_File;
|
end Locate_File;
|
|
|
-------------------------------
|
-------------------------------
|
-- Matching_Full_Source_Name --
|
-- Matching_Full_Source_Name --
|
-------------------------------
|
-------------------------------
|
|
|
function Matching_Full_Source_Name
|
function Matching_Full_Source_Name
|
(N : File_Name_Type;
|
(N : File_Name_Type;
|
T : Time_Stamp_Type) return File_Name_Type
|
T : Time_Stamp_Type) return File_Name_Type
|
is
|
is
|
begin
|
begin
|
Get_Name_String (N);
|
Get_Name_String (N);
|
|
|
declare
|
declare
|
File_Name : constant String := Name_Buffer (1 .. Name_Len);
|
File_Name : constant String := Name_Buffer (1 .. Name_Len);
|
File : File_Name_Type := No_File;
|
File : File_Name_Type := No_File;
|
Attr : aliased File_Attributes;
|
Attr : aliased File_Attributes;
|
Last_Dir : Natural;
|
Last_Dir : Natural;
|
|
|
begin
|
begin
|
if Opt.Look_In_Primary_Dir then
|
if Opt.Look_In_Primary_Dir then
|
Locate_File
|
Locate_File
|
(N, Source, Primary_Directory, File_Name, File, Attr'Access);
|
(N, Source, Primary_Directory, File_Name, File, Attr'Access);
|
|
|
if File /= No_File and then T = File_Stamp (N) then
|
if File /= No_File and then T = File_Stamp (N) then
|
return File;
|
return File;
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
Last_Dir := Src_Search_Directories.Last;
|
Last_Dir := Src_Search_Directories.Last;
|
|
|
for D in Primary_Directory + 1 .. Last_Dir loop
|
for D in Primary_Directory + 1 .. Last_Dir loop
|
Locate_File (N, Source, D, File_Name, File, Attr'Access);
|
Locate_File (N, Source, D, File_Name, File, Attr'Access);
|
|
|
if File /= No_File and then T = File_Stamp (File) then
|
if File /= No_File and then T = File_Stamp (File) then
|
return File;
|
return File;
|
end if;
|
end if;
|
end loop;
|
end loop;
|
|
|
return No_File;
|
return No_File;
|
end;
|
end;
|
end Matching_Full_Source_Name;
|
end Matching_Full_Source_Name;
|
|
|
----------------
|
----------------
|
-- More_Files --
|
-- More_Files --
|
----------------
|
----------------
|
|
|
function More_Files return Boolean is
|
function More_Files return Boolean is
|
begin
|
begin
|
return (Current_File_Name_Index < Number_File_Names);
|
return (Current_File_Name_Index < Number_File_Names);
|
end More_Files;
|
end More_Files;
|
|
|
-------------------------------
|
-------------------------------
|
-- Nb_Dir_In_Obj_Search_Path --
|
-- Nb_Dir_In_Obj_Search_Path --
|
-------------------------------
|
-------------------------------
|
|
|
function Nb_Dir_In_Obj_Search_Path return Natural is
|
function Nb_Dir_In_Obj_Search_Path return Natural is
|
begin
|
begin
|
if Opt.Look_In_Primary_Dir then
|
if Opt.Look_In_Primary_Dir then
|
return Lib_Search_Directories.Last - Primary_Directory + 1;
|
return Lib_Search_Directories.Last - Primary_Directory + 1;
|
else
|
else
|
return Lib_Search_Directories.Last - Primary_Directory;
|
return Lib_Search_Directories.Last - Primary_Directory;
|
end if;
|
end if;
|
end Nb_Dir_In_Obj_Search_Path;
|
end Nb_Dir_In_Obj_Search_Path;
|
|
|
-------------------------------
|
-------------------------------
|
-- Nb_Dir_In_Src_Search_Path --
|
-- Nb_Dir_In_Src_Search_Path --
|
-------------------------------
|
-------------------------------
|
|
|
function Nb_Dir_In_Src_Search_Path return Natural is
|
function Nb_Dir_In_Src_Search_Path return Natural is
|
begin
|
begin
|
if Opt.Look_In_Primary_Dir then
|
if Opt.Look_In_Primary_Dir then
|
return Src_Search_Directories.Last - Primary_Directory + 1;
|
return Src_Search_Directories.Last - Primary_Directory + 1;
|
else
|
else
|
return Src_Search_Directories.Last - Primary_Directory;
|
return Src_Search_Directories.Last - Primary_Directory;
|
end if;
|
end if;
|
end Nb_Dir_In_Src_Search_Path;
|
end Nb_Dir_In_Src_Search_Path;
|
|
|
--------------------
|
--------------------
|
-- Next_Main_File --
|
-- Next_Main_File --
|
--------------------
|
--------------------
|
|
|
function Next_Main_File return File_Name_Type is
|
function Next_Main_File return File_Name_Type is
|
File_Name : String_Ptr;
|
File_Name : String_Ptr;
|
Dir_Name : String_Ptr;
|
Dir_Name : String_Ptr;
|
Fptr : Natural;
|
Fptr : Natural;
|
|
|
begin
|
begin
|
pragma Assert (More_Files);
|
pragma Assert (More_Files);
|
|
|
Current_File_Name_Index := Current_File_Name_Index + 1;
|
Current_File_Name_Index := Current_File_Name_Index + 1;
|
|
|
-- Get the file and directory name
|
-- Get the file and directory name
|
|
|
File_Name := File_Names (Current_File_Name_Index);
|
File_Name := File_Names (Current_File_Name_Index);
|
Fptr := File_Name'First;
|
Fptr := File_Name'First;
|
|
|
for J in reverse File_Name'Range loop
|
for J in reverse File_Name'Range loop
|
if File_Name (J) = Directory_Separator
|
if File_Name (J) = Directory_Separator
|
or else File_Name (J) = '/'
|
or else File_Name (J) = '/'
|
then
|
then
|
if J = File_Name'Last then
|
if J = File_Name'Last then
|
Fail ("File name missing");
|
Fail ("File name missing");
|
end if;
|
end if;
|
|
|
Fptr := J + 1;
|
Fptr := J + 1;
|
exit;
|
exit;
|
end if;
|
end if;
|
end loop;
|
end loop;
|
|
|
-- Save name of directory in which main unit resides for use in
|
-- Save name of directory in which main unit resides for use in
|
-- locating other units
|
-- locating other units
|
|
|
Dir_Name := new String'(File_Name (File_Name'First .. Fptr - 1));
|
Dir_Name := new String'(File_Name (File_Name'First .. Fptr - 1));
|
|
|
case Running_Program is
|
case Running_Program is
|
|
|
when Compiler =>
|
when Compiler =>
|
Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
|
Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
|
Look_In_Primary_Directory_For_Current_Main := True;
|
Look_In_Primary_Directory_For_Current_Main := True;
|
|
|
when Make =>
|
when Make =>
|
Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
|
Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
|
|
|
if Fptr > File_Name'First then
|
if Fptr > File_Name'First then
|
Look_In_Primary_Directory_For_Current_Main := True;
|
Look_In_Primary_Directory_For_Current_Main := True;
|
end if;
|
end if;
|
|
|
when Binder | Gnatls =>
|
when Binder | Gnatls =>
|
Dir_Name := Normalize_Directory_Name (Dir_Name.all);
|
Dir_Name := Normalize_Directory_Name (Dir_Name.all);
|
Lib_Search_Directories.Table (Primary_Directory) := Dir_Name;
|
Lib_Search_Directories.Table (Primary_Directory) := Dir_Name;
|
|
|
when Unspecified =>
|
when Unspecified =>
|
null;
|
null;
|
end case;
|
end case;
|
|
|
Name_Len := File_Name'Last - Fptr + 1;
|
Name_Len := File_Name'Last - Fptr + 1;
|
Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last);
|
Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last);
|
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
|
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
|
Current_Main := Name_Find;
|
Current_Main := Name_Find;
|
|
|
-- In the gnatmake case, the main file may have not have the
|
-- In the gnatmake case, the main file may have not have the
|
-- extension. Try ".adb" first then ".ads"
|
-- extension. Try ".adb" first then ".ads"
|
|
|
if Running_Program = Make then
|
if Running_Program = Make then
|
declare
|
declare
|
Orig_Main : constant File_Name_Type := Current_Main;
|
Orig_Main : constant File_Name_Type := Current_Main;
|
|
|
begin
|
begin
|
if Strip_Suffix (Orig_Main) = Orig_Main then
|
if Strip_Suffix (Orig_Main) = Orig_Main then
|
Current_Main :=
|
Current_Main :=
|
Append_Suffix_To_File_Name (Orig_Main, ".adb");
|
Append_Suffix_To_File_Name (Orig_Main, ".adb");
|
|
|
if Full_Source_Name (Current_Main) = No_File then
|
if Full_Source_Name (Current_Main) = No_File then
|
Current_Main :=
|
Current_Main :=
|
Append_Suffix_To_File_Name (Orig_Main, ".ads");
|
Append_Suffix_To_File_Name (Orig_Main, ".ads");
|
|
|
if Full_Source_Name (Current_Main) = No_File then
|
if Full_Source_Name (Current_Main) = No_File then
|
Current_Main := Orig_Main;
|
Current_Main := Orig_Main;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
end;
|
end;
|
end if;
|
end if;
|
|
|
return Current_Main;
|
return Current_Main;
|
end Next_Main_File;
|
end Next_Main_File;
|
|
|
------------------------------
|
------------------------------
|
-- Normalize_Directory_Name --
|
-- Normalize_Directory_Name --
|
------------------------------
|
------------------------------
|
|
|
function Normalize_Directory_Name (Directory : String) return String_Ptr is
|
function Normalize_Directory_Name (Directory : String) return String_Ptr is
|
|
|
function Is_Quoted (Path : String) return Boolean;
|
function Is_Quoted (Path : String) return Boolean;
|
pragma Inline (Is_Quoted);
|
pragma Inline (Is_Quoted);
|
-- Returns true if Path is quoted (either double or single quotes)
|
-- Returns true if Path is quoted (either double or single quotes)
|
|
|
---------------
|
---------------
|
-- Is_Quoted --
|
-- Is_Quoted --
|
---------------
|
---------------
|
|
|
function Is_Quoted (Path : String) return Boolean is
|
function Is_Quoted (Path : String) return Boolean is
|
First : constant Character := Path (Path'First);
|
First : constant Character := Path (Path'First);
|
Last : constant Character := Path (Path'Last);
|
Last : constant Character := Path (Path'Last);
|
|
|
begin
|
begin
|
if (First = ''' and then Last = ''')
|
if (First = ''' and then Last = ''')
|
or else
|
or else
|
(First = '"' and then Last = '"')
|
(First = '"' and then Last = '"')
|
then
|
then
|
return True;
|
return True;
|
else
|
else
|
return False;
|
return False;
|
end if;
|
end if;
|
end Is_Quoted;
|
end Is_Quoted;
|
|
|
Result : String_Ptr;
|
Result : String_Ptr;
|
|
|
-- Start of processing for Normalize_Directory_Name
|
-- Start of processing for Normalize_Directory_Name
|
|
|
begin
|
begin
|
if Directory'Length = 0 then
|
if Directory'Length = 0 then
|
Result := new String'(Hostparm.Normalized_CWD);
|
Result := new String'(Hostparm.Normalized_CWD);
|
|
|
elsif Is_Directory_Separator (Directory (Directory'Last)) then
|
elsif Is_Directory_Separator (Directory (Directory'Last)) then
|
Result := new String'(Directory);
|
Result := new String'(Directory);
|
|
|
elsif Is_Quoted (Directory) then
|
elsif Is_Quoted (Directory) then
|
|
|
-- This is a quoted string, it certainly means that the directory
|
-- This is a quoted string, it certainly means that the directory
|
-- contains some spaces for example. We can safely remove the quotes
|
-- contains some spaces for example. We can safely remove the quotes
|
-- here as the OS_Lib.Normalize_Arguments will be called before any
|
-- here as the OS_Lib.Normalize_Arguments will be called before any
|
-- spawn routines. This ensure that quotes will be added when needed.
|
-- spawn routines. This ensure that quotes will be added when needed.
|
|
|
Result := new String (1 .. Directory'Length - 1);
|
Result := new String (1 .. Directory'Length - 1);
|
Result (1 .. Directory'Length - 2) :=
|
Result (1 .. Directory'Length - 2) :=
|
Directory (Directory'First + 1 .. Directory'Last - 1);
|
Directory (Directory'First + 1 .. Directory'Last - 1);
|
Result (Result'Last) := Directory_Separator;
|
Result (Result'Last) := Directory_Separator;
|
|
|
else
|
else
|
Result := new String (1 .. Directory'Length + 1);
|
Result := new String (1 .. Directory'Length + 1);
|
Result (1 .. Directory'Length) := Directory;
|
Result (1 .. Directory'Length) := Directory;
|
Result (Directory'Length + 1) := Directory_Separator;
|
Result (Directory'Length + 1) := Directory_Separator;
|
end if;
|
end if;
|
|
|
return Result;
|
return Result;
|
end Normalize_Directory_Name;
|
end Normalize_Directory_Name;
|
|
|
---------------------
|
---------------------
|
-- Number_Of_Files --
|
-- Number_Of_Files --
|
---------------------
|
---------------------
|
|
|
function Number_Of_Files return Int is
|
function Number_Of_Files return Int is
|
begin
|
begin
|
return Number_File_Names;
|
return Number_File_Names;
|
end Number_Of_Files;
|
end Number_Of_Files;
|
|
|
-------------------------------
|
-------------------------------
|
-- Object_Dir_Default_Prefix --
|
-- Object_Dir_Default_Prefix --
|
-------------------------------
|
-------------------------------
|
|
|
function Object_Dir_Default_Prefix return String is
|
function Object_Dir_Default_Prefix return String is
|
Object_Dir : String_Access :=
|
Object_Dir : String_Access :=
|
String_Access (Update_Path (Object_Dir_Default_Name));
|
String_Access (Update_Path (Object_Dir_Default_Name));
|
|
|
begin
|
begin
|
if Object_Dir = null then
|
if Object_Dir = null then
|
return "";
|
return "";
|
|
|
else
|
else
|
declare
|
declare
|
Result : constant String := Object_Dir.all;
|
Result : constant String := Object_Dir.all;
|
begin
|
begin
|
Free (Object_Dir);
|
Free (Object_Dir);
|
return Result;
|
return Result;
|
end;
|
end;
|
end if;
|
end if;
|
end Object_Dir_Default_Prefix;
|
end Object_Dir_Default_Prefix;
|
|
|
----------------------
|
----------------------
|
-- Object_File_Name --
|
-- Object_File_Name --
|
----------------------
|
----------------------
|
|
|
function Object_File_Name (N : File_Name_Type) return File_Name_Type is
|
function Object_File_Name (N : File_Name_Type) return File_Name_Type is
|
begin
|
begin
|
if N = No_File then
|
if N = No_File then
|
return No_File;
|
return No_File;
|
end if;
|
end if;
|
|
|
Get_Name_String (N);
|
Get_Name_String (N);
|
Name_Len := Name_Len - ALI_Suffix'Length - 1;
|
Name_Len := Name_Len - ALI_Suffix'Length - 1;
|
|
|
for J in Target_Object_Suffix'Range loop
|
for J in Target_Object_Suffix'Range loop
|
Name_Len := Name_Len + 1;
|
Name_Len := Name_Len + 1;
|
Name_Buffer (Name_Len) := Target_Object_Suffix (J);
|
Name_Buffer (Name_Len) := Target_Object_Suffix (J);
|
end loop;
|
end loop;
|
|
|
return Name_Enter;
|
return Name_Enter;
|
end Object_File_Name;
|
end Object_File_Name;
|
|
|
-------------------------------
|
-------------------------------
|
-- OS_Exit_Through_Exception --
|
-- OS_Exit_Through_Exception --
|
-------------------------------
|
-------------------------------
|
|
|
procedure OS_Exit_Through_Exception (Status : Integer) is
|
procedure OS_Exit_Through_Exception (Status : Integer) is
|
begin
|
begin
|
Current_Exit_Status := Status;
|
Current_Exit_Status := Status;
|
raise Types.Terminate_Program;
|
raise Types.Terminate_Program;
|
end OS_Exit_Through_Exception;
|
end OS_Exit_Through_Exception;
|
|
|
--------------------------
|
--------------------------
|
-- OS_Time_To_GNAT_Time --
|
-- OS_Time_To_GNAT_Time --
|
--------------------------
|
--------------------------
|
|
|
function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type is
|
function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type is
|
GNAT_Time : Time_Stamp_Type;
|
GNAT_Time : Time_Stamp_Type;
|
|
|
Y : Year_Type;
|
Y : Year_Type;
|
Mo : Month_Type;
|
Mo : Month_Type;
|
D : Day_Type;
|
D : Day_Type;
|
H : Hour_Type;
|
H : Hour_Type;
|
Mn : Minute_Type;
|
Mn : Minute_Type;
|
S : Second_Type;
|
S : Second_Type;
|
|
|
begin
|
begin
|
if T = Invalid_Time then
|
if T = Invalid_Time then
|
return Empty_Time_Stamp;
|
return Empty_Time_Stamp;
|
end if;
|
end if;
|
|
|
GM_Split (T, Y, Mo, D, H, Mn, S);
|
GM_Split (T, Y, Mo, D, H, Mn, S);
|
Make_Time_Stamp
|
Make_Time_Stamp
|
(Year => Nat (Y),
|
(Year => Nat (Y),
|
Month => Nat (Mo),
|
Month => Nat (Mo),
|
Day => Nat (D),
|
Day => Nat (D),
|
Hour => Nat (H),
|
Hour => Nat (H),
|
Minutes => Nat (Mn),
|
Minutes => Nat (Mn),
|
Seconds => Nat (S),
|
Seconds => Nat (S),
|
TS => GNAT_Time);
|
TS => GNAT_Time);
|
|
|
return GNAT_Time;
|
return GNAT_Time;
|
end OS_Time_To_GNAT_Time;
|
end OS_Time_To_GNAT_Time;
|
|
|
------------------
|
------------------
|
-- Program_Name --
|
-- Program_Name --
|
------------------
|
------------------
|
|
|
function Program_Name (Nam : String; Prog : String) return String_Access is
|
function Program_Name (Nam : String; Prog : String) return String_Access is
|
End_Of_Prefix : Natural := 0;
|
End_Of_Prefix : Natural := 0;
|
Start_Of_Prefix : Positive := 1;
|
Start_Of_Prefix : Positive := 1;
|
Start_Of_Suffix : Positive;
|
Start_Of_Suffix : Positive;
|
|
|
begin
|
begin
|
-- GNAAMP tool names require special treatment
|
-- GNAAMP tool names require special treatment
|
|
|
if AAMP_On_Target then
|
if AAMP_On_Target then
|
|
|
-- The name "gcc" is mapped to "gnaamp" (the compiler driver)
|
-- The name "gcc" is mapped to "gnaamp" (the compiler driver)
|
|
|
if Nam = "gcc" then
|
if Nam = "gcc" then
|
return new String'("gnaamp");
|
return new String'("gnaamp");
|
|
|
-- Tool names starting with "gnat" are mapped by substituting the
|
-- Tool names starting with "gnat" are mapped by substituting the
|
-- string "gnaamp" for "gnat" (for example, "gnatpp" => "gnaamppp").
|
-- string "gnaamp" for "gnat" (for example, "gnatpp" => "gnaamppp").
|
|
|
elsif Nam'Length >= 4
|
elsif Nam'Length >= 4
|
and then Nam (Nam'First .. Nam'First + 3) = "gnat"
|
and then Nam (Nam'First .. Nam'First + 3) = "gnat"
|
then
|
then
|
return new String'("gnaamp" & Nam (Nam'First + 4 .. Nam'Last));
|
return new String'("gnaamp" & Nam (Nam'First + 4 .. Nam'Last));
|
|
|
-- No other mapping rules, so we continue and handle any other forms
|
-- No other mapping rules, so we continue and handle any other forms
|
-- of tool names the same as on other targets.
|
-- of tool names the same as on other targets.
|
|
|
else
|
else
|
null;
|
null;
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
-- Get the name of the current program being executed
|
-- Get the name of the current program being executed
|
|
|
Find_Program_Name;
|
Find_Program_Name;
|
|
|
Start_Of_Suffix := Name_Len + 1;
|
Start_Of_Suffix := Name_Len + 1;
|
|
|
-- Find the target prefix if any, for the cross compilation case.
|
-- Find the target prefix if any, for the cross compilation case.
|
-- For instance in "powerpc-elf-gcc" the target prefix is
|
-- For instance in "powerpc-elf-gcc" the target prefix is
|
-- "powerpc-elf-"
|
-- "powerpc-elf-"
|
-- Ditto for suffix, e.g. in "gcc-4.1", the suffix is "-4.1"
|
-- Ditto for suffix, e.g. in "gcc-4.1", the suffix is "-4.1"
|
|
|
for J in reverse 1 .. Name_Len loop
|
for J in reverse 1 .. Name_Len loop
|
if Name_Buffer (J) = '/'
|
if Name_Buffer (J) = '/'
|
or else Name_Buffer (J) = Directory_Separator
|
or else Name_Buffer (J) = Directory_Separator
|
or else Name_Buffer (J) = ':'
|
or else Name_Buffer (J) = ':'
|
then
|
then
|
Start_Of_Prefix := J + 1;
|
Start_Of_Prefix := J + 1;
|
exit;
|
exit;
|
end if;
|
end if;
|
end loop;
|
end loop;
|
|
|
-- Find End_Of_Prefix
|
-- Find End_Of_Prefix
|
|
|
for J in Start_Of_Prefix .. Name_Len - Prog'Length + 1 loop
|
for J in Start_Of_Prefix .. Name_Len - Prog'Length + 1 loop
|
if Name_Buffer (J .. J + Prog'Length - 1) = Prog then
|
if Name_Buffer (J .. J + Prog'Length - 1) = Prog then
|
End_Of_Prefix := J - 1;
|
End_Of_Prefix := J - 1;
|
exit;
|
exit;
|
end if;
|
end if;
|
end loop;
|
end loop;
|
|
|
if End_Of_Prefix > 1 then
|
if End_Of_Prefix > 1 then
|
Start_Of_Suffix := End_Of_Prefix + Prog'Length + 1;
|
Start_Of_Suffix := End_Of_Prefix + Prog'Length + 1;
|
end if;
|
end if;
|
|
|
-- Create the new program name
|
-- Create the new program name
|
|
|
return new String'
|
return new String'
|
(Name_Buffer (Start_Of_Prefix .. End_Of_Prefix)
|
(Name_Buffer (Start_Of_Prefix .. End_Of_Prefix)
|
& Nam
|
& Nam
|
& Name_Buffer (Start_Of_Suffix .. Name_Len));
|
& Name_Buffer (Start_Of_Suffix .. Name_Len));
|
end Program_Name;
|
end Program_Name;
|
|
|
------------------------------
|
------------------------------
|
-- Read_Default_Search_Dirs --
|
-- Read_Default_Search_Dirs --
|
------------------------------
|
------------------------------
|
|
|
function Read_Default_Search_Dirs
|
function Read_Default_Search_Dirs
|
(Search_Dir_Prefix : String_Access;
|
(Search_Dir_Prefix : String_Access;
|
Search_File : 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
|
is
|
Prefix_Len : constant Integer := Search_Dir_Prefix.all'Length;
|
Prefix_Len : constant Integer := Search_Dir_Prefix.all'Length;
|
Buffer : String (1 .. Prefix_Len + Search_File.all'Length + 1);
|
Buffer : String (1 .. Prefix_Len + Search_File.all'Length + 1);
|
File_FD : File_Descriptor;
|
File_FD : File_Descriptor;
|
S, S1 : String_Access;
|
S, S1 : String_Access;
|
Len : Integer;
|
Len : Integer;
|
Curr : Integer;
|
Curr : Integer;
|
Actual_Len : Integer;
|
Actual_Len : Integer;
|
J1 : Integer;
|
J1 : Integer;
|
|
|
Prev_Was_Separator : Boolean;
|
Prev_Was_Separator : Boolean;
|
Nb_Relative_Dir : Integer;
|
Nb_Relative_Dir : Integer;
|
|
|
function Is_Relative (S : String; K : Positive) return Boolean;
|
function Is_Relative (S : String; K : Positive) return Boolean;
|
pragma Inline (Is_Relative);
|
pragma Inline (Is_Relative);
|
-- Returns True if a relative directory specification is found
|
-- Returns True if a relative directory specification is found
|
-- in S at position K, False otherwise.
|
-- in S at position K, False otherwise.
|
|
|
-----------------
|
-----------------
|
-- Is_Relative --
|
-- Is_Relative --
|
-----------------
|
-----------------
|
|
|
function Is_Relative (S : String; K : Positive) return Boolean is
|
function Is_Relative (S : String; K : Positive) return Boolean is
|
begin
|
begin
|
return not Is_Absolute_Path (S (K .. S'Last));
|
return not Is_Absolute_Path (S (K .. S'Last));
|
end Is_Relative;
|
end Is_Relative;
|
|
|
-- Start of processing for Read_Default_Search_Dirs
|
-- Start of processing for Read_Default_Search_Dirs
|
|
|
begin
|
begin
|
-- Construct a C compatible character string buffer
|
-- Construct a C compatible character string buffer
|
|
|
Buffer (1 .. Search_Dir_Prefix.all'Length)
|
Buffer (1 .. Search_Dir_Prefix.all'Length)
|
:= Search_Dir_Prefix.all;
|
:= Search_Dir_Prefix.all;
|
Buffer (Search_Dir_Prefix.all'Length + 1 .. Buffer'Last - 1)
|
Buffer (Search_Dir_Prefix.all'Length + 1 .. Buffer'Last - 1)
|
:= Search_File.all;
|
:= Search_File.all;
|
Buffer (Buffer'Last) := ASCII.NUL;
|
Buffer (Buffer'Last) := ASCII.NUL;
|
|
|
File_FD := Open_Read (Buffer'Address, Binary);
|
File_FD := Open_Read (Buffer'Address, Binary);
|
if File_FD = Invalid_FD then
|
if File_FD = Invalid_FD then
|
return Search_Dir_Default_Name;
|
return Search_Dir_Default_Name;
|
end if;
|
end if;
|
|
|
Len := Integer (File_Length (File_FD));
|
Len := Integer (File_Length (File_FD));
|
|
|
-- An extra character for a trailing Path_Separator is allocated
|
-- An extra character for a trailing Path_Separator is allocated
|
|
|
S := new String (1 .. Len + 1);
|
S := new String (1 .. Len + 1);
|
S (Len + 1) := Path_Separator;
|
S (Len + 1) := Path_Separator;
|
|
|
-- Read the file. Note that the loop is not necessary since the
|
-- Read the file. Note that the loop is not necessary since the
|
-- whole file is read at once except on VMS.
|
-- whole file is read at once except on VMS.
|
|
|
Curr := 1;
|
Curr := 1;
|
Actual_Len := Len;
|
Actual_Len := Len;
|
while Actual_Len /= 0 loop
|
while Actual_Len /= 0 loop
|
Actual_Len := Read (File_FD, S (Curr)'Address, Len);
|
Actual_Len := Read (File_FD, S (Curr)'Address, Len);
|
Curr := Curr + Actual_Len;
|
Curr := Curr + Actual_Len;
|
end loop;
|
end loop;
|
|
|
-- Process the file, dealing with path separators
|
-- Process the file, dealing with path separators
|
|
|
Prev_Was_Separator := True;
|
Prev_Was_Separator := True;
|
Nb_Relative_Dir := 0;
|
Nb_Relative_Dir := 0;
|
for J in 1 .. Len loop
|
for J in 1 .. Len loop
|
|
|
-- Treat any control character as a path separator. Note that we do
|
-- 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
|
-- 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
|
-- path separator in an earlier version). That way space can appear
|
-- as a legitimate character in a path name.
|
-- as a legitimate character in a path name.
|
|
|
-- Why do we treat all control characters as path separators???
|
-- Why do we treat all control characters as path separators???
|
|
|
if S (J) in ASCII.NUL .. ASCII.US then
|
if S (J) in ASCII.NUL .. ASCII.US then
|
S (J) := Path_Separator;
|
S (J) := Path_Separator;
|
end if;
|
end if;
|
|
|
-- Test for explicit path separator (or control char as above)
|
-- Test for explicit path separator (or control char as above)
|
|
|
if S (J) = Path_Separator then
|
if S (J) = Path_Separator then
|
Prev_Was_Separator := True;
|
Prev_Was_Separator := True;
|
|
|
-- If not path separator, register use of relative directory
|
-- If not path separator, register use of relative directory
|
|
|
else
|
else
|
if Prev_Was_Separator and then Is_Relative (S.all, J) then
|
if Prev_Was_Separator and then Is_Relative (S.all, J) then
|
Nb_Relative_Dir := Nb_Relative_Dir + 1;
|
Nb_Relative_Dir := Nb_Relative_Dir + 1;
|
end if;
|
end if;
|
|
|
Prev_Was_Separator := False;
|
Prev_Was_Separator := False;
|
end if;
|
end if;
|
end loop;
|
end loop;
|
|
|
if Nb_Relative_Dir = 0 then
|
if Nb_Relative_Dir = 0 then
|
return S;
|
return S;
|
end if;
|
end if;
|
|
|
-- Add the Search_Dir_Prefix to all relative paths
|
-- Add the Search_Dir_Prefix to all relative paths
|
|
|
S1 := new String (1 .. S'Length + Nb_Relative_Dir * Prefix_Len);
|
S1 := new String (1 .. S'Length + Nb_Relative_Dir * Prefix_Len);
|
J1 := 1;
|
J1 := 1;
|
Prev_Was_Separator := True;
|
Prev_Was_Separator := True;
|
for J in 1 .. Len + 1 loop
|
for J in 1 .. Len + 1 loop
|
if S (J) = Path_Separator then
|
if S (J) = Path_Separator then
|
Prev_Was_Separator := True;
|
Prev_Was_Separator := True;
|
|
|
else
|
else
|
if Prev_Was_Separator and then Is_Relative (S.all, J) then
|
if Prev_Was_Separator and then Is_Relative (S.all, J) then
|
S1 (J1 .. J1 + Prefix_Len - 1) := Search_Dir_Prefix.all;
|
S1 (J1 .. J1 + Prefix_Len - 1) := Search_Dir_Prefix.all;
|
J1 := J1 + Prefix_Len;
|
J1 := J1 + Prefix_Len;
|
end if;
|
end if;
|
|
|
Prev_Was_Separator := False;
|
Prev_Was_Separator := False;
|
end if;
|
end if;
|
S1 (J1) := S (J);
|
S1 (J1) := S (J);
|
J1 := J1 + 1;
|
J1 := J1 + 1;
|
end loop;
|
end loop;
|
|
|
Free (S);
|
Free (S);
|
return S1;
|
return S1;
|
end Read_Default_Search_Dirs;
|
end Read_Default_Search_Dirs;
|
|
|
-----------------------
|
-----------------------
|
-- Read_Library_Info --
|
-- Read_Library_Info --
|
-----------------------
|
-----------------------
|
|
|
function Read_Library_Info
|
function Read_Library_Info
|
(Lib_File : File_Name_Type;
|
(Lib_File : File_Name_Type;
|
Fatal_Err : Boolean := False) return Text_Buffer_Ptr
|
Fatal_Err : Boolean := False) return Text_Buffer_Ptr
|
is
|
is
|
File : File_Name_Type;
|
File : File_Name_Type;
|
Attr : aliased File_Attributes;
|
Attr : aliased File_Attributes;
|
begin
|
begin
|
Find_File (Lib_File, Library, File, Attr'Access);
|
Find_File (Lib_File, Library, File, Attr'Access);
|
return Read_Library_Info_From_Full
|
return Read_Library_Info_From_Full
|
(Full_Lib_File => File,
|
(Full_Lib_File => File,
|
Lib_File_Attr => Attr'Access,
|
Lib_File_Attr => Attr'Access,
|
Fatal_Err => Fatal_Err);
|
Fatal_Err => Fatal_Err);
|
end Read_Library_Info;
|
end Read_Library_Info;
|
|
|
---------------------------------
|
---------------------------------
|
-- Read_Library_Info_From_Full --
|
-- Read_Library_Info_From_Full --
|
---------------------------------
|
---------------------------------
|
|
|
function Read_Library_Info_From_Full
|
function Read_Library_Info_From_Full
|
(Full_Lib_File : File_Name_Type;
|
(Full_Lib_File : File_Name_Type;
|
Lib_File_Attr : access File_Attributes;
|
Lib_File_Attr : access File_Attributes;
|
Fatal_Err : Boolean := False) return Text_Buffer_Ptr
|
Fatal_Err : Boolean := False) return Text_Buffer_Ptr
|
is
|
is
|
Lib_FD : File_Descriptor;
|
Lib_FD : File_Descriptor;
|
-- The file descriptor for the current library file. A negative value
|
-- The file descriptor for the current library file. A negative value
|
-- indicates failure to open the specified source file.
|
-- indicates failure to open the specified source file.
|
|
|
Len : Integer;
|
Len : Integer;
|
-- Length of source file text (ALI). If it doesn't fit in an 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!)
|
-- we're probably stuck anyway (>2 gigs of source seems a lot!)
|
|
|
Text : Text_Buffer_Ptr;
|
Text : Text_Buffer_Ptr;
|
-- Allocated text buffer
|
-- Allocated text buffer
|
|
|
Status : Boolean;
|
Status : Boolean;
|
pragma Warnings (Off, Status);
|
pragma Warnings (Off, Status);
|
-- For the calls to Close
|
-- For the calls to Close
|
|
|
begin
|
begin
|
Current_Full_Lib_Name := Full_Lib_File;
|
Current_Full_Lib_Name := Full_Lib_File;
|
Current_Full_Obj_Name := Object_File_Name (Current_Full_Lib_Name);
|
Current_Full_Obj_Name := Object_File_Name (Current_Full_Lib_Name);
|
|
|
if Current_Full_Lib_Name = No_File then
|
if Current_Full_Lib_Name = No_File then
|
if Fatal_Err then
|
if Fatal_Err then
|
Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
|
Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
|
else
|
else
|
Current_Full_Obj_Stamp := Empty_Time_Stamp;
|
Current_Full_Obj_Stamp := Empty_Time_Stamp;
|
return null;
|
return null;
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
Get_Name_String (Current_Full_Lib_Name);
|
Get_Name_String (Current_Full_Lib_Name);
|
Name_Buffer (Name_Len + 1) := ASCII.NUL;
|
Name_Buffer (Name_Len + 1) := ASCII.NUL;
|
|
|
-- Open the library FD, note that we open in binary mode, because as
|
-- Open the library FD, note that we open in binary mode, because as
|
-- documented in the spec, the caller is expected to handle either
|
-- documented in the spec, the caller is expected to handle either
|
-- DOS or Unix mode files, and there is no point in wasting time on
|
-- DOS or Unix mode files, and there is no point in wasting time on
|
-- text translation when it is not required.
|
-- text translation when it is not required.
|
|
|
Lib_FD := Open_Read (Name_Buffer'Address, Binary);
|
Lib_FD := Open_Read (Name_Buffer'Address, Binary);
|
|
|
if Lib_FD = Invalid_FD then
|
if Lib_FD = Invalid_FD then
|
if Fatal_Err then
|
if Fatal_Err then
|
Fail ("Cannot open: " & Name_Buffer (1 .. Name_Len));
|
Fail ("Cannot open: " & Name_Buffer (1 .. Name_Len));
|
else
|
else
|
Current_Full_Obj_Stamp := Empty_Time_Stamp;
|
Current_Full_Obj_Stamp := Empty_Time_Stamp;
|
return null;
|
return null;
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
-- Compute the length of the file (potentially also preparing other data
|
-- Compute the length of the file (potentially also preparing other data
|
-- like the timestamp and whether the file is read-only, for future use)
|
-- like the timestamp and whether the file is read-only, for future use)
|
|
|
Len := Integer (File_Length (Name_Buffer'Address, Lib_File_Attr));
|
Len := Integer (File_Length (Name_Buffer'Address, Lib_File_Attr));
|
|
|
-- Check for object file consistency if requested
|
-- Check for object file consistency if requested
|
|
|
if Opt.Check_Object_Consistency then
|
if Opt.Check_Object_Consistency then
|
-- On most systems, this does not result in an extra system call
|
-- On most systems, this does not result in an extra system call
|
|
|
Current_Full_Lib_Stamp :=
|
Current_Full_Lib_Stamp :=
|
OS_Time_To_GNAT_Time
|
OS_Time_To_GNAT_Time
|
(File_Time_Stamp (Name_Buffer'Address, Lib_File_Attr));
|
(File_Time_Stamp (Name_Buffer'Address, Lib_File_Attr));
|
|
|
-- ??? One system call here
|
-- ??? One system call here
|
|
|
Current_Full_Obj_Stamp := File_Stamp (Current_Full_Obj_Name);
|
Current_Full_Obj_Stamp := File_Stamp (Current_Full_Obj_Name);
|
|
|
if Current_Full_Obj_Stamp (1) = ' ' then
|
if Current_Full_Obj_Stamp (1) = ' ' then
|
|
|
-- When the library is readonly always assume 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
|
-- 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
|
-- some systems, but in most cases it has already been computed as
|
-- part of the call to File_Length above.
|
-- part of the call to File_Length above.
|
|
|
Get_Name_String (Current_Full_Lib_Name);
|
Get_Name_String (Current_Full_Lib_Name);
|
Name_Buffer (Name_Len + 1) := ASCII.NUL;
|
Name_Buffer (Name_Len + 1) := ASCII.NUL;
|
|
|
if not Is_Writable_File (Name_Buffer'Address, Lib_File_Attr) then
|
if not Is_Writable_File (Name_Buffer'Address, Lib_File_Attr) then
|
Current_Full_Obj_Stamp := Current_Full_Lib_Stamp;
|
Current_Full_Obj_Stamp := Current_Full_Lib_Stamp;
|
|
|
elsif Fatal_Err then
|
elsif Fatal_Err then
|
Get_Name_String (Current_Full_Obj_Name);
|
Get_Name_String (Current_Full_Obj_Name);
|
Close (Lib_FD, Status);
|
Close (Lib_FD, Status);
|
|
|
-- No need to check the status, we fail anyway
|
-- No need to check the status, we fail anyway
|
|
|
Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
|
Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
|
|
|
else
|
else
|
Current_Full_Obj_Stamp := Empty_Time_Stamp;
|
Current_Full_Obj_Stamp := Empty_Time_Stamp;
|
Close (Lib_FD, Status);
|
Close (Lib_FD, Status);
|
|
|
-- No need to check the status, we return null anyway
|
-- No need to check the status, we return null anyway
|
|
|
return null;
|
return null;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
-- Read data from the file
|
-- Read data from the file
|
|
|
declare
|
declare
|
Actual_Len : Integer := 0;
|
Actual_Len : Integer := 0;
|
|
|
Lo : constant Text_Ptr := 0;
|
Lo : constant Text_Ptr := 0;
|
-- Low bound for allocated text buffer
|
-- Low bound for allocated text buffer
|
|
|
Hi : Text_Ptr := Text_Ptr (Len);
|
Hi : Text_Ptr := Text_Ptr (Len);
|
-- High bound for allocated text buffer. Note length is Len + 1
|
-- High bound for allocated text buffer. Note length is Len + 1
|
-- which allows for extra EOF character at the end of the buffer.
|
-- which allows for extra EOF character at the end of the buffer.
|
|
|
begin
|
begin
|
-- Allocate text buffer. Note extra character at end for EOF
|
-- Allocate text buffer. Note extra character at end for EOF
|
|
|
Text := new Text_Buffer (Lo .. Hi);
|
Text := new Text_Buffer (Lo .. Hi);
|
|
|
-- Some systems (e.g. VMS) have file types that require one
|
-- Some systems (e.g. VMS) have file types that require one
|
-- read per line, so read until we get the Len bytes or until
|
-- read per line, so read until we get the Len bytes or until
|
-- there are no more characters.
|
-- there are no more characters.
|
|
|
Hi := Lo;
|
Hi := Lo;
|
loop
|
loop
|
Actual_Len := Read (Lib_FD, Text (Hi)'Address, Len);
|
Actual_Len := Read (Lib_FD, Text (Hi)'Address, Len);
|
Hi := Hi + Text_Ptr (Actual_Len);
|
Hi := Hi + Text_Ptr (Actual_Len);
|
exit when Actual_Len = Len or else Actual_Len <= 0;
|
exit when Actual_Len = Len or else Actual_Len <= 0;
|
end loop;
|
end loop;
|
|
|
Text (Hi) := EOF;
|
Text (Hi) := EOF;
|
end;
|
end;
|
|
|
-- Read is complete, close file and we are done
|
-- Read is complete, close file and we are done
|
|
|
Close (Lib_FD, Status);
|
Close (Lib_FD, Status);
|
-- The status should never be False. But, if it is, what can we do?
|
-- The status should never be False. But, if it is, what can we do?
|
-- So, we don't test it.
|
-- So, we don't test it.
|
|
|
return Text;
|
return Text;
|
|
|
end Read_Library_Info_From_Full;
|
end Read_Library_Info_From_Full;
|
|
|
----------------------
|
----------------------
|
-- Read_Source_File --
|
-- Read_Source_File --
|
----------------------
|
----------------------
|
|
|
procedure Read_Source_File
|
procedure Read_Source_File
|
(N : File_Name_Type;
|
(N : File_Name_Type;
|
Lo : Source_Ptr;
|
Lo : Source_Ptr;
|
Hi : out Source_Ptr;
|
Hi : out Source_Ptr;
|
Src : out Source_Buffer_Ptr;
|
Src : out Source_Buffer_Ptr;
|
T : File_Type := Source)
|
T : File_Type := Source)
|
is
|
is
|
Source_File_FD : File_Descriptor;
|
Source_File_FD : File_Descriptor;
|
-- The file descriptor for the current source file. A negative value
|
-- The file descriptor for the current source file. A negative value
|
-- indicates failure to open the specified source file.
|
-- indicates failure to open the specified source file.
|
|
|
Len : Integer;
|
Len : Integer;
|
-- Length of file. Assume no more than 2 gigabytes of source!
|
-- Length of file. Assume no more than 2 gigabytes of source!
|
|
|
Actual_Len : Integer;
|
Actual_Len : Integer;
|
|
|
Status : Boolean;
|
Status : Boolean;
|
pragma Warnings (Off, Status);
|
pragma Warnings (Off, Status);
|
-- For the call to Close
|
-- For the call to Close
|
|
|
begin
|
begin
|
Current_Full_Source_Name := Find_File (N, T);
|
Current_Full_Source_Name := Find_File (N, T);
|
Current_Full_Source_Stamp := File_Stamp (Current_Full_Source_Name);
|
Current_Full_Source_Stamp := File_Stamp (Current_Full_Source_Name);
|
|
|
if Current_Full_Source_Name = No_File then
|
if Current_Full_Source_Name = No_File then
|
|
|
-- If we were trying to access the main file and we could not find
|
-- If we were trying to access the main file and we could not find
|
-- it, we have an error.
|
-- it, we have an error.
|
|
|
if N = Current_Main then
|
if N = Current_Main then
|
Get_Name_String (N);
|
Get_Name_String (N);
|
Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
|
Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
|
end if;
|
end if;
|
|
|
Src := null;
|
Src := null;
|
Hi := No_Location;
|
Hi := No_Location;
|
return;
|
return;
|
end if;
|
end if;
|
|
|
Get_Name_String (Current_Full_Source_Name);
|
Get_Name_String (Current_Full_Source_Name);
|
Name_Buffer (Name_Len + 1) := ASCII.NUL;
|
Name_Buffer (Name_Len + 1) := ASCII.NUL;
|
|
|
-- Open the source FD, note that we open in binary mode, because as
|
-- Open the source FD, note that we open in binary mode, because as
|
-- documented in the spec, the caller is expected to handle either
|
-- documented in the spec, the caller is expected to handle either
|
-- DOS or Unix mode files, and there is no point in wasting time on
|
-- DOS or Unix mode files, and there is no point in wasting time on
|
-- text translation when it is not required.
|
-- text translation when it is not required.
|
|
|
Source_File_FD := Open_Read (Name_Buffer'Address, Binary);
|
Source_File_FD := Open_Read (Name_Buffer'Address, Binary);
|
|
|
if Source_File_FD = Invalid_FD then
|
if Source_File_FD = Invalid_FD then
|
Src := null;
|
Src := null;
|
Hi := No_Location;
|
Hi := No_Location;
|
return;
|
return;
|
end if;
|
end if;
|
|
|
-- Print out the file name, if requested, and if it's not part of the
|
-- Print out the file name, if requested, and if it's not part of the
|
-- runtimes, store it in File_Name_Chars.
|
-- runtimes, store it in File_Name_Chars.
|
|
|
declare
|
declare
|
Name : String renames Name_Buffer (1 .. Name_Len);
|
Name : String renames Name_Buffer (1 .. Name_Len);
|
Inc : String renames Include_Dir_Default_Prefix.all;
|
Inc : String renames Include_Dir_Default_Prefix.all;
|
|
|
begin
|
begin
|
if Debug.Debug_Flag_Dot_N then
|
if Debug.Debug_Flag_Dot_N then
|
Write_Line (Name);
|
Write_Line (Name);
|
end if;
|
end if;
|
|
|
if Inc /= ""
|
if Inc /= ""
|
and then Inc'Length < Name_Len
|
and then Inc'Length < Name_Len
|
and then Name_Buffer (1 .. Inc'Length) = Inc
|
and then Name_Buffer (1 .. Inc'Length) = Inc
|
then
|
then
|
-- Part of runtimes, so ignore it
|
-- Part of runtimes, so ignore it
|
|
|
null;
|
null;
|
|
|
else
|
else
|
File_Name_Chars.Append_All (File_Name_Chars.Table_Type (Name));
|
File_Name_Chars.Append_All (File_Name_Chars.Table_Type (Name));
|
File_Name_Chars.Append (ASCII.LF);
|
File_Name_Chars.Append (ASCII.LF);
|
end if;
|
end if;
|
end;
|
end;
|
|
|
-- Prepare to read data from the file
|
-- Prepare to read data from the file
|
|
|
Len := Integer (File_Length (Source_File_FD));
|
Len := Integer (File_Length (Source_File_FD));
|
|
|
-- Set Hi so that length is one more than the physical length,
|
-- Set Hi so that length is one more than the physical length,
|
-- allowing for the extra EOF character at the end of the buffer
|
-- allowing for the extra EOF character at the end of the buffer
|
|
|
Hi := Lo + Source_Ptr (Len);
|
Hi := Lo + Source_Ptr (Len);
|
|
|
-- Do the actual read operation
|
-- Do the actual read operation
|
|
|
declare
|
declare
|
subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
|
subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
|
-- Physical buffer allocated
|
-- Physical buffer allocated
|
|
|
type Actual_Source_Ptr is access Actual_Source_Buffer;
|
type Actual_Source_Ptr is access Actual_Source_Buffer;
|
-- This is the pointer type for the physical buffer allocated
|
-- This is the pointer type for the physical buffer allocated
|
|
|
Actual_Ptr : constant Actual_Source_Ptr := new Actual_Source_Buffer;
|
Actual_Ptr : constant Actual_Source_Ptr := new Actual_Source_Buffer;
|
-- And this is the actual physical buffer
|
-- And this is the actual physical buffer
|
|
|
begin
|
begin
|
-- Allocate source buffer, allowing extra character at end for EOF
|
-- Allocate source buffer, allowing extra character at end for EOF
|
|
|
-- Some systems (e.g. VMS) have file types that require one read per
|
-- 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
|
-- line, so read until we get the Len bytes or until there are no
|
-- more characters.
|
-- more characters.
|
|
|
Hi := Lo;
|
Hi := Lo;
|
loop
|
loop
|
Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len);
|
Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len);
|
Hi := Hi + Source_Ptr (Actual_Len);
|
Hi := Hi + Source_Ptr (Actual_Len);
|
exit when Actual_Len = Len or else Actual_Len <= 0;
|
exit when Actual_Len = Len or else Actual_Len <= 0;
|
end loop;
|
end loop;
|
|
|
Actual_Ptr (Hi) := EOF;
|
Actual_Ptr (Hi) := EOF;
|
|
|
-- Now we need to work out the proper virtual origin pointer to
|
-- Now we need to work out the proper virtual origin pointer to
|
-- return. This is exactly Actual_Ptr (0)'Address, but we have to
|
-- return. This is exactly Actual_Ptr (0)'Address, but we have to
|
-- be careful to suppress checks to compute this address.
|
-- be careful to suppress checks to compute this address.
|
|
|
declare
|
declare
|
pragma Suppress (All_Checks);
|
pragma Suppress (All_Checks);
|
|
|
pragma Warnings (Off);
|
pragma Warnings (Off);
|
-- This use of unchecked conversion is aliasing safe
|
-- This use of unchecked conversion is aliasing safe
|
|
|
function To_Source_Buffer_Ptr is new
|
function To_Source_Buffer_Ptr is new
|
Unchecked_Conversion (Address, Source_Buffer_Ptr);
|
Unchecked_Conversion (Address, Source_Buffer_Ptr);
|
|
|
pragma Warnings (On);
|
pragma Warnings (On);
|
|
|
begin
|
begin
|
Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
|
Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
|
end;
|
end;
|
end;
|
end;
|
|
|
-- Read is complete, get time stamp and close file and we are done
|
-- Read is complete, get time stamp and close file and we are done
|
|
|
Close (Source_File_FD, Status);
|
Close (Source_File_FD, Status);
|
|
|
-- The status should never be False. But, if it is, what can we do?
|
-- The status should never be False. But, if it is, what can we do?
|
-- So, we don't test it.
|
-- So, we don't test it.
|
|
|
end Read_Source_File;
|
end Read_Source_File;
|
|
|
-------------------
|
-------------------
|
-- Relocate_Path --
|
-- Relocate_Path --
|
-------------------
|
-------------------
|
|
|
function Relocate_Path
|
function Relocate_Path
|
(Prefix : String;
|
(Prefix : String;
|
Path : String) return String_Ptr
|
Path : String) return String_Ptr
|
is
|
is
|
S : String_Ptr;
|
S : String_Ptr;
|
|
|
procedure set_std_prefix (S : String; Len : Integer);
|
procedure set_std_prefix (S : String; Len : Integer);
|
pragma Import (C, set_std_prefix);
|
pragma Import (C, set_std_prefix);
|
|
|
begin
|
begin
|
if Std_Prefix = null then
|
if Std_Prefix = null then
|
Std_Prefix := Executable_Prefix;
|
Std_Prefix := Executable_Prefix;
|
|
|
if Std_Prefix.all /= "" then
|
if Std_Prefix.all /= "" then
|
|
|
-- Remove trailing directory separator when calling set_std_prefix
|
-- Remove trailing directory separator when calling set_std_prefix
|
|
|
set_std_prefix (Std_Prefix.all, Std_Prefix'Length - 1);
|
set_std_prefix (Std_Prefix.all, Std_Prefix'Length - 1);
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
if Path (Prefix'Range) = Prefix then
|
if Path (Prefix'Range) = Prefix then
|
if Std_Prefix.all /= "" then
|
if Std_Prefix.all /= "" then
|
S := new String
|
S := new String
|
(1 .. Std_Prefix'Length + Path'Last - Prefix'Last);
|
(1 .. Std_Prefix'Length + Path'Last - Prefix'Last);
|
S (1 .. Std_Prefix'Length) := Std_Prefix.all;
|
S (1 .. Std_Prefix'Length) := Std_Prefix.all;
|
S (Std_Prefix'Length + 1 .. S'Last) :=
|
S (Std_Prefix'Length + 1 .. S'Last) :=
|
Path (Prefix'Last + 1 .. Path'Last);
|
Path (Prefix'Last + 1 .. Path'Last);
|
return S;
|
return S;
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
return new String'(Path);
|
return new String'(Path);
|
end Relocate_Path;
|
end Relocate_Path;
|
|
|
-----------------
|
-----------------
|
-- Set_Program --
|
-- Set_Program --
|
-----------------
|
-----------------
|
|
|
procedure Set_Program (P : Program_Type) is
|
procedure Set_Program (P : Program_Type) is
|
begin
|
begin
|
if Program_Set then
|
if Program_Set then
|
Fail ("Set_Program called twice");
|
Fail ("Set_Program called twice");
|
end if;
|
end if;
|
|
|
Program_Set := True;
|
Program_Set := True;
|
Running_Program := P;
|
Running_Program := P;
|
end Set_Program;
|
end Set_Program;
|
|
|
----------------
|
----------------
|
-- Shared_Lib --
|
-- Shared_Lib --
|
----------------
|
----------------
|
|
|
function Shared_Lib (Name : String) return String is
|
function Shared_Lib (Name : String) return String is
|
Library : String (1 .. Name'Length + Library_Version'Length + 3);
|
Library : String (1 .. Name'Length + Library_Version'Length + 3);
|
-- 3 = 2 for "-l" + 1 for "-" before lib version
|
-- 3 = 2 for "-l" + 1 for "-" before lib version
|
|
|
begin
|
begin
|
Library (1 .. 2) := "-l";
|
Library (1 .. 2) := "-l";
|
Library (3 .. 2 + Name'Length) := Name;
|
Library (3 .. 2 + Name'Length) := Name;
|
Library (3 + Name'Length) := '-';
|
Library (3 + Name'Length) := '-';
|
Library (4 + Name'Length .. Library'Last) := Library_Version;
|
Library (4 + Name'Length .. Library'Last) := Library_Version;
|
|
|
if OpenVMS_On_Target then
|
if OpenVMS_On_Target then
|
for K in Library'First + 2 .. Library'Last loop
|
for K in Library'First + 2 .. Library'Last loop
|
if Library (K) = '.' or else Library (K) = '-' then
|
if Library (K) = '.' or else Library (K) = '-' then
|
Library (K) := '_';
|
Library (K) := '_';
|
end if;
|
end if;
|
end loop;
|
end loop;
|
end if;
|
end if;
|
|
|
return Library;
|
return Library;
|
end Shared_Lib;
|
end Shared_Lib;
|
|
|
----------------------
|
----------------------
|
-- Smart_File_Stamp --
|
-- Smart_File_Stamp --
|
----------------------
|
----------------------
|
|
|
function Smart_File_Stamp
|
function Smart_File_Stamp
|
(N : File_Name_Type;
|
(N : File_Name_Type;
|
T : File_Type) return Time_Stamp_Type
|
T : File_Type) return Time_Stamp_Type
|
is
|
is
|
File : File_Name_Type;
|
File : File_Name_Type;
|
Attr : aliased File_Attributes;
|
Attr : aliased File_Attributes;
|
|
|
begin
|
begin
|
if not File_Cache_Enabled then
|
if not File_Cache_Enabled then
|
Find_File (N, T, File, Attr'Access);
|
Find_File (N, T, File, Attr'Access);
|
else
|
else
|
Smart_Find_File (N, T, File, Attr);
|
Smart_Find_File (N, T, File, Attr);
|
end if;
|
end if;
|
|
|
if File = No_File then
|
if File = No_File then
|
return Empty_Time_Stamp;
|
return Empty_Time_Stamp;
|
else
|
else
|
Get_Name_String (File);
|
Get_Name_String (File);
|
Name_Buffer (Name_Len + 1) := ASCII.NUL;
|
Name_Buffer (Name_Len + 1) := ASCII.NUL;
|
return
|
return
|
OS_Time_To_GNAT_Time
|
OS_Time_To_GNAT_Time
|
(File_Time_Stamp (Name_Buffer'Address, Attr'Access));
|
(File_Time_Stamp (Name_Buffer'Address, Attr'Access));
|
end if;
|
end if;
|
end Smart_File_Stamp;
|
end Smart_File_Stamp;
|
|
|
---------------------
|
---------------------
|
-- Smart_Find_File --
|
-- Smart_Find_File --
|
---------------------
|
---------------------
|
|
|
function Smart_Find_File
|
function Smart_Find_File
|
(N : File_Name_Type;
|
(N : File_Name_Type;
|
T : File_Type) return File_Name_Type
|
T : File_Type) return File_Name_Type
|
is
|
is
|
File : File_Name_Type;
|
File : File_Name_Type;
|
Attr : File_Attributes;
|
Attr : File_Attributes;
|
begin
|
begin
|
Smart_Find_File (N, T, File, Attr);
|
Smart_Find_File (N, T, File, Attr);
|
return File;
|
return File;
|
end Smart_Find_File;
|
end Smart_Find_File;
|
|
|
---------------------
|
---------------------
|
-- Smart_Find_File --
|
-- Smart_Find_File --
|
---------------------
|
---------------------
|
|
|
procedure Smart_Find_File
|
procedure Smart_Find_File
|
(N : File_Name_Type;
|
(N : File_Name_Type;
|
T : File_Type;
|
T : File_Type;
|
Found : out File_Name_Type;
|
Found : out File_Name_Type;
|
Attr : out File_Attributes)
|
Attr : out File_Attributes)
|
is
|
is
|
Info : File_Info_Cache;
|
Info : File_Info_Cache;
|
|
|
begin
|
begin
|
if not File_Cache_Enabled then
|
if not File_Cache_Enabled then
|
Find_File (N, T, Info.File, Info.Attr'Access);
|
Find_File (N, T, Info.File, Info.Attr'Access);
|
|
|
else
|
else
|
Info := File_Name_Hash_Table.Get (N);
|
Info := File_Name_Hash_Table.Get (N);
|
|
|
if Info.File = No_File then
|
if Info.File = No_File then
|
Find_File (N, T, Info.File, Info.Attr'Access);
|
Find_File (N, T, Info.File, Info.Attr'Access);
|
File_Name_Hash_Table.Set (N, Info);
|
File_Name_Hash_Table.Set (N, Info);
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
Found := Info.File;
|
Found := Info.File;
|
Attr := Info.Attr;
|
Attr := Info.Attr;
|
end Smart_Find_File;
|
end Smart_Find_File;
|
|
|
----------------------
|
----------------------
|
-- Source_File_Data --
|
-- Source_File_Data --
|
----------------------
|
----------------------
|
|
|
procedure Source_File_Data (Cache : Boolean) is
|
procedure Source_File_Data (Cache : Boolean) is
|
begin
|
begin
|
File_Cache_Enabled := Cache;
|
File_Cache_Enabled := Cache;
|
end Source_File_Data;
|
end Source_File_Data;
|
|
|
-----------------------
|
-----------------------
|
-- Source_File_Stamp --
|
-- Source_File_Stamp --
|
-----------------------
|
-----------------------
|
|
|
function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is
|
function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is
|
begin
|
begin
|
return Smart_File_Stamp (N, Source);
|
return Smart_File_Stamp (N, Source);
|
end Source_File_Stamp;
|
end Source_File_Stamp;
|
|
|
---------------------
|
---------------------
|
-- Strip_Directory --
|
-- Strip_Directory --
|
---------------------
|
---------------------
|
|
|
function Strip_Directory (Name : File_Name_Type) return File_Name_Type is
|
function Strip_Directory (Name : File_Name_Type) return File_Name_Type is
|
begin
|
begin
|
Get_Name_String (Name);
|
Get_Name_String (Name);
|
|
|
for J in reverse 1 .. Name_Len - 1 loop
|
for J in reverse 1 .. Name_Len - 1 loop
|
|
|
-- If we find the last directory separator
|
-- If we find the last directory separator
|
|
|
if Is_Directory_Separator (Name_Buffer (J)) then
|
if Is_Directory_Separator (Name_Buffer (J)) then
|
|
|
-- Return part of Name that follows this last directory separator
|
-- Return part of Name that follows this last directory separator
|
|
|
Name_Buffer (1 .. Name_Len - J) := Name_Buffer (J + 1 .. Name_Len);
|
Name_Buffer (1 .. Name_Len - J) := Name_Buffer (J + 1 .. Name_Len);
|
Name_Len := Name_Len - J;
|
Name_Len := Name_Len - J;
|
return Name_Find;
|
return Name_Find;
|
end if;
|
end if;
|
end loop;
|
end loop;
|
|
|
-- There were no directory separator, just return Name
|
-- There were no directory separator, just return Name
|
|
|
return Name;
|
return Name;
|
end Strip_Directory;
|
end Strip_Directory;
|
|
|
------------------
|
------------------
|
-- Strip_Suffix --
|
-- Strip_Suffix --
|
------------------
|
------------------
|
|
|
function Strip_Suffix (Name : File_Name_Type) return File_Name_Type is
|
function Strip_Suffix (Name : File_Name_Type) return File_Name_Type is
|
begin
|
begin
|
Get_Name_String (Name);
|
Get_Name_String (Name);
|
|
|
for J in reverse 2 .. Name_Len loop
|
for J in reverse 2 .. Name_Len loop
|
|
|
-- If we found the last '.', return part of Name that precedes it
|
-- If we found the last '.', return part of Name that precedes it
|
|
|
if Name_Buffer (J) = '.' then
|
if Name_Buffer (J) = '.' then
|
Name_Len := J - 1;
|
Name_Len := J - 1;
|
return Name_Enter;
|
return Name_Enter;
|
end if;
|
end if;
|
end loop;
|
end loop;
|
|
|
return Name;
|
return Name;
|
end Strip_Suffix;
|
end Strip_Suffix;
|
|
|
---------------------------
|
---------------------------
|
-- To_Canonical_Dir_Spec --
|
-- To_Canonical_Dir_Spec --
|
---------------------------
|
---------------------------
|
|
|
function To_Canonical_Dir_Spec
|
function To_Canonical_Dir_Spec
|
(Host_Dir : String;
|
(Host_Dir : String;
|
Prefix_Style : Boolean) return String_Access
|
Prefix_Style : Boolean) return String_Access
|
is
|
is
|
function To_Canonical_Dir_Spec
|
function To_Canonical_Dir_Spec
|
(Host_Dir : Address;
|
(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");
|
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_Addr : Address;
|
Canonical_Dir_Len : Integer;
|
Canonical_Dir_Len : Integer;
|
|
|
begin
|
begin
|
C_Host_Dir (1 .. Host_Dir'Length) := Host_Dir;
|
C_Host_Dir (1 .. Host_Dir'Length) := Host_Dir;
|
C_Host_Dir (C_Host_Dir'Last) := ASCII.NUL;
|
C_Host_Dir (C_Host_Dir'Last) := ASCII.NUL;
|
|
|
if Prefix_Style then
|
if Prefix_Style then
|
Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 1);
|
Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 1);
|
else
|
else
|
Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 0);
|
Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 0);
|
end if;
|
end if;
|
|
|
Canonical_Dir_Len := C_String_Length (Canonical_Dir_Addr);
|
Canonical_Dir_Len := C_String_Length (Canonical_Dir_Addr);
|
|
|
if Canonical_Dir_Len = 0 then
|
if Canonical_Dir_Len = 0 then
|
return null;
|
return null;
|
else
|
else
|
return To_Path_String_Access (Canonical_Dir_Addr, Canonical_Dir_Len);
|
return To_Path_String_Access (Canonical_Dir_Addr, Canonical_Dir_Len);
|
end if;
|
end if;
|
|
|
exception
|
exception
|
when others =>
|
when others =>
|
Fail ("erroneous directory spec: " & Host_Dir);
|
Fail ("erroneous directory spec: " & Host_Dir);
|
return null;
|
return null;
|
end To_Canonical_Dir_Spec;
|
end To_Canonical_Dir_Spec;
|
|
|
---------------------------
|
---------------------------
|
-- To_Canonical_File_List --
|
-- To_Canonical_File_List --
|
---------------------------
|
---------------------------
|
|
|
function To_Canonical_File_List
|
function To_Canonical_File_List
|
(Wildcard_Host_File : String;
|
(Wildcard_Host_File : String;
|
Only_Dirs : Boolean) return String_Access_List_Access
|
Only_Dirs : Boolean) return String_Access_List_Access
|
is
|
is
|
function To_Canonical_File_List_Init
|
function To_Canonical_File_List_Init
|
(Host_File : Address;
|
(Host_File : Address;
|
Only_Dirs : Integer) return Integer;
|
Only_Dirs : Integer) return Integer;
|
pragma Import (C, To_Canonical_File_List_Init,
|
pragma Import (C, To_Canonical_File_List_Init,
|
"__gnat_to_canonical_file_list_init");
|
"__gnat_to_canonical_file_list_init");
|
|
|
function To_Canonical_File_List_Next return Address;
|
function To_Canonical_File_List_Next return Address;
|
pragma Import (C, To_Canonical_File_List_Next,
|
pragma Import (C, To_Canonical_File_List_Next,
|
"__gnat_to_canonical_file_list_next");
|
"__gnat_to_canonical_file_list_next");
|
|
|
procedure To_Canonical_File_List_Free;
|
procedure To_Canonical_File_List_Free;
|
pragma Import (C, To_Canonical_File_List_Free,
|
pragma Import (C, To_Canonical_File_List_Free,
|
"__gnat_to_canonical_file_list_free");
|
"__gnat_to_canonical_file_list_free");
|
|
|
Num_Files : Integer;
|
Num_Files : Integer;
|
C_Wildcard_Host_File : String (1 .. Wildcard_Host_File'Length + 1);
|
C_Wildcard_Host_File : String (1 .. Wildcard_Host_File'Length + 1);
|
|
|
begin
|
begin
|
C_Wildcard_Host_File (1 .. Wildcard_Host_File'Length) :=
|
C_Wildcard_Host_File (1 .. Wildcard_Host_File'Length) :=
|
Wildcard_Host_File;
|
Wildcard_Host_File;
|
C_Wildcard_Host_File (C_Wildcard_Host_File'Last) := ASCII.NUL;
|
C_Wildcard_Host_File (C_Wildcard_Host_File'Last) := ASCII.NUL;
|
|
|
-- Do the expansion and say how many there are
|
-- Do the expansion and say how many there are
|
|
|
Num_Files := To_Canonical_File_List_Init
|
Num_Files := To_Canonical_File_List_Init
|
(C_Wildcard_Host_File'Address, Boolean'Pos (Only_Dirs));
|
(C_Wildcard_Host_File'Address, Boolean'Pos (Only_Dirs));
|
|
|
declare
|
declare
|
Canonical_File_List : String_Access_List (1 .. Num_Files);
|
Canonical_File_List : String_Access_List (1 .. Num_Files);
|
Canonical_File_Addr : Address;
|
Canonical_File_Addr : Address;
|
Canonical_File_Len : Integer;
|
Canonical_File_Len : Integer;
|
|
|
begin
|
begin
|
-- Retrieve the expanded directory names and build the list
|
-- Retrieve the expanded directory names and build the list
|
|
|
for J in 1 .. Num_Files loop
|
for J in 1 .. Num_Files loop
|
Canonical_File_Addr := To_Canonical_File_List_Next;
|
Canonical_File_Addr := To_Canonical_File_List_Next;
|
Canonical_File_Len := C_String_Length (Canonical_File_Addr);
|
Canonical_File_Len := C_String_Length (Canonical_File_Addr);
|
Canonical_File_List (J) := To_Path_String_Access
|
Canonical_File_List (J) := To_Path_String_Access
|
(Canonical_File_Addr, Canonical_File_Len);
|
(Canonical_File_Addr, Canonical_File_Len);
|
end loop;
|
end loop;
|
|
|
-- Free up the storage
|
-- Free up the storage
|
|
|
To_Canonical_File_List_Free;
|
To_Canonical_File_List_Free;
|
|
|
return new String_Access_List'(Canonical_File_List);
|
return new String_Access_List'(Canonical_File_List);
|
end;
|
end;
|
end To_Canonical_File_List;
|
end To_Canonical_File_List;
|
|
|
----------------------------
|
----------------------------
|
-- To_Canonical_File_Spec --
|
-- To_Canonical_File_Spec --
|
----------------------------
|
----------------------------
|
|
|
function To_Canonical_File_Spec
|
function To_Canonical_File_Spec
|
(Host_File : String) return String_Access
|
(Host_File : String) return String_Access
|
is
|
is
|
function To_Canonical_File_Spec (Host_File : Address) return Address;
|
function To_Canonical_File_Spec (Host_File : Address) return Address;
|
pragma Import
|
pragma Import
|
(C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
|
(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_Addr : Address;
|
Canonical_File_Len : Integer;
|
Canonical_File_Len : Integer;
|
|
|
begin
|
begin
|
C_Host_File (1 .. Host_File'Length) := Host_File;
|
C_Host_File (1 .. Host_File'Length) := Host_File;
|
C_Host_File (C_Host_File'Last) := ASCII.NUL;
|
C_Host_File (C_Host_File'Last) := ASCII.NUL;
|
|
|
Canonical_File_Addr := To_Canonical_File_Spec (C_Host_File'Address);
|
Canonical_File_Addr := To_Canonical_File_Spec (C_Host_File'Address);
|
Canonical_File_Len := C_String_Length (Canonical_File_Addr);
|
Canonical_File_Len := C_String_Length (Canonical_File_Addr);
|
|
|
if Canonical_File_Len = 0 then
|
if Canonical_File_Len = 0 then
|
return null;
|
return null;
|
else
|
else
|
return To_Path_String_Access
|
return To_Path_String_Access
|
(Canonical_File_Addr, Canonical_File_Len);
|
(Canonical_File_Addr, Canonical_File_Len);
|
end if;
|
end if;
|
|
|
exception
|
exception
|
when others =>
|
when others =>
|
Fail ("erroneous file spec: " & Host_File);
|
Fail ("erroneous file spec: " & Host_File);
|
return null;
|
return null;
|
end To_Canonical_File_Spec;
|
end To_Canonical_File_Spec;
|
|
|
----------------------------
|
----------------------------
|
-- To_Canonical_Path_Spec --
|
-- To_Canonical_Path_Spec --
|
----------------------------
|
----------------------------
|
|
|
function To_Canonical_Path_Spec
|
function To_Canonical_Path_Spec
|
(Host_Path : String) return String_Access
|
(Host_Path : String) return String_Access
|
is
|
is
|
function To_Canonical_Path_Spec (Host_Path : Address) return Address;
|
function To_Canonical_Path_Spec (Host_Path : Address) return Address;
|
pragma Import
|
pragma Import
|
(C, To_Canonical_Path_Spec, "__gnat_to_canonical_path_spec");
|
(C, To_Canonical_Path_Spec, "__gnat_to_canonical_path_spec");
|
|
|
C_Host_Path : String (1 .. Host_Path'Length + 1);
|
C_Host_Path : String (1 .. Host_Path'Length + 1);
|
Canonical_Path_Addr : Address;
|
Canonical_Path_Addr : Address;
|
Canonical_Path_Len : Integer;
|
Canonical_Path_Len : Integer;
|
|
|
begin
|
begin
|
C_Host_Path (1 .. Host_Path'Length) := Host_Path;
|
C_Host_Path (1 .. Host_Path'Length) := Host_Path;
|
C_Host_Path (C_Host_Path'Last) := ASCII.NUL;
|
C_Host_Path (C_Host_Path'Last) := ASCII.NUL;
|
|
|
Canonical_Path_Addr := To_Canonical_Path_Spec (C_Host_Path'Address);
|
Canonical_Path_Addr := To_Canonical_Path_Spec (C_Host_Path'Address);
|
Canonical_Path_Len := C_String_Length (Canonical_Path_Addr);
|
Canonical_Path_Len := C_String_Length (Canonical_Path_Addr);
|
|
|
-- Return a null string (vice a null) for zero length paths, for
|
-- Return a null string (vice a null) for zero length paths, for
|
-- compatibility with getenv().
|
-- compatibility with getenv().
|
|
|
return To_Path_String_Access (Canonical_Path_Addr, Canonical_Path_Len);
|
return To_Path_String_Access (Canonical_Path_Addr, Canonical_Path_Len);
|
|
|
exception
|
exception
|
when others =>
|
when others =>
|
Fail ("erroneous path spec: " & Host_Path);
|
Fail ("erroneous path spec: " & Host_Path);
|
return null;
|
return null;
|
end To_Canonical_Path_Spec;
|
end To_Canonical_Path_Spec;
|
|
|
---------------------------
|
---------------------------
|
-- To_Host_Dir_Spec --
|
-- To_Host_Dir_Spec --
|
---------------------------
|
---------------------------
|
|
|
function To_Host_Dir_Spec
|
function To_Host_Dir_Spec
|
(Canonical_Dir : String;
|
(Canonical_Dir : String;
|
Prefix_Style : Boolean) return String_Access
|
Prefix_Style : Boolean) return String_Access
|
is
|
is
|
function To_Host_Dir_Spec
|
function To_Host_Dir_Spec
|
(Canonical_Dir : Address;
|
(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");
|
pragma Import (C, To_Host_Dir_Spec, "__gnat_to_host_dir_spec");
|
|
|
C_Canonical_Dir : String (1 .. Canonical_Dir'Length + 1);
|
C_Canonical_Dir : String (1 .. Canonical_Dir'Length + 1);
|
Host_Dir_Addr : Address;
|
Host_Dir_Addr : Address;
|
Host_Dir_Len : Integer;
|
Host_Dir_Len : Integer;
|
|
|
begin
|
begin
|
C_Canonical_Dir (1 .. Canonical_Dir'Length) := Canonical_Dir;
|
C_Canonical_Dir (1 .. Canonical_Dir'Length) := Canonical_Dir;
|
C_Canonical_Dir (C_Canonical_Dir'Last) := ASCII.NUL;
|
C_Canonical_Dir (C_Canonical_Dir'Last) := ASCII.NUL;
|
|
|
if Prefix_Style then
|
if Prefix_Style then
|
Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 1);
|
Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 1);
|
else
|
else
|
Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 0);
|
Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 0);
|
end if;
|
end if;
|
Host_Dir_Len := C_String_Length (Host_Dir_Addr);
|
Host_Dir_Len := C_String_Length (Host_Dir_Addr);
|
|
|
if Host_Dir_Len = 0 then
|
if Host_Dir_Len = 0 then
|
return null;
|
return null;
|
else
|
else
|
return To_Path_String_Access (Host_Dir_Addr, Host_Dir_Len);
|
return To_Path_String_Access (Host_Dir_Addr, Host_Dir_Len);
|
end if;
|
end if;
|
end To_Host_Dir_Spec;
|
end To_Host_Dir_Spec;
|
|
|
----------------------------
|
----------------------------
|
-- To_Host_File_Spec --
|
-- To_Host_File_Spec --
|
----------------------------
|
----------------------------
|
|
|
function To_Host_File_Spec
|
function To_Host_File_Spec
|
(Canonical_File : String) return String_Access
|
(Canonical_File : String) return String_Access
|
is
|
is
|
function To_Host_File_Spec (Canonical_File : Address) return Address;
|
function To_Host_File_Spec (Canonical_File : Address) return Address;
|
pragma Import (C, To_Host_File_Spec, "__gnat_to_host_file_spec");
|
pragma Import (C, To_Host_File_Spec, "__gnat_to_host_file_spec");
|
|
|
C_Canonical_File : String (1 .. Canonical_File'Length + 1);
|
C_Canonical_File : String (1 .. Canonical_File'Length + 1);
|
Host_File_Addr : Address;
|
Host_File_Addr : Address;
|
Host_File_Len : Integer;
|
Host_File_Len : Integer;
|
|
|
begin
|
begin
|
C_Canonical_File (1 .. Canonical_File'Length) := Canonical_File;
|
C_Canonical_File (1 .. Canonical_File'Length) := Canonical_File;
|
C_Canonical_File (C_Canonical_File'Last) := ASCII.NUL;
|
C_Canonical_File (C_Canonical_File'Last) := ASCII.NUL;
|
|
|
Host_File_Addr := To_Host_File_Spec (C_Canonical_File'Address);
|
Host_File_Addr := To_Host_File_Spec (C_Canonical_File'Address);
|
Host_File_Len := C_String_Length (Host_File_Addr);
|
Host_File_Len := C_String_Length (Host_File_Addr);
|
|
|
if Host_File_Len = 0 then
|
if Host_File_Len = 0 then
|
return null;
|
return null;
|
else
|
else
|
return To_Path_String_Access
|
return To_Path_String_Access
|
(Host_File_Addr, Host_File_Len);
|
(Host_File_Addr, Host_File_Len);
|
end if;
|
end if;
|
end To_Host_File_Spec;
|
end To_Host_File_Spec;
|
|
|
---------------------------
|
---------------------------
|
-- To_Path_String_Access --
|
-- To_Path_String_Access --
|
---------------------------
|
---------------------------
|
|
|
function To_Path_String_Access
|
function To_Path_String_Access
|
(Path_Addr : Address;
|
(Path_Addr : Address;
|
Path_Len : Integer) return String_Access
|
Path_Len : Integer) return String_Access
|
is
|
is
|
subtype Path_String is String (1 .. Path_Len);
|
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
|
function Address_To_Access is new
|
Unchecked_Conversion (Source => Address,
|
Unchecked_Conversion (Source => Address,
|
Target => Path_String_Access);
|
Target => Path_String_Access);
|
|
|
Path_Access : constant Path_String_Access :=
|
Path_Access : constant Path_String_Access :=
|
Address_To_Access (Path_Addr);
|
Address_To_Access (Path_Addr);
|
|
|
Return_Val : String_Access;
|
Return_Val : String_Access;
|
|
|
begin
|
begin
|
Return_Val := new String (1 .. Path_Len);
|
Return_Val := new String (1 .. Path_Len);
|
|
|
for J in 1 .. Path_Len loop
|
for J in 1 .. Path_Len loop
|
Return_Val (J) := Path_Access (J);
|
Return_Val (J) := Path_Access (J);
|
end loop;
|
end loop;
|
|
|
return Return_Val;
|
return Return_Val;
|
end To_Path_String_Access;
|
end To_Path_String_Access;
|
|
|
-----------------
|
-----------------
|
-- Update_Path --
|
-- Update_Path --
|
-----------------
|
-----------------
|
|
|
function Update_Path (Path : String_Ptr) return String_Ptr is
|
function Update_Path (Path : String_Ptr) return String_Ptr is
|
|
|
function C_Update_Path (Path, Component : Address) return Address;
|
function C_Update_Path (Path, Component : Address) return Address;
|
pragma Import (C, C_Update_Path, "update_path");
|
pragma Import (C, C_Update_Path, "update_path");
|
|
|
function Strlen (Str : Address) return Integer;
|
function Strlen (Str : Address) return Integer;
|
pragma Import (C, Strlen, "strlen");
|
pragma Import (C, Strlen, "strlen");
|
|
|
procedure Strncpy (X : Address; Y : Address; Length : Integer);
|
procedure Strncpy (X : Address; Y : Address; Length : Integer);
|
pragma Import (C, Strncpy, "strncpy");
|
pragma Import (C, Strncpy, "strncpy");
|
|
|
In_Length : constant Integer := Path'Length;
|
In_Length : constant Integer := Path'Length;
|
In_String : String (1 .. In_Length + 1);
|
In_String : String (1 .. In_Length + 1);
|
Component_Name : aliased String := "GCC" & ASCII.NUL;
|
Component_Name : aliased String := "GCC" & ASCII.NUL;
|
Result_Ptr : Address;
|
Result_Ptr : Address;
|
Result_Length : Integer;
|
Result_Length : Integer;
|
Out_String : String_Ptr;
|
Out_String : String_Ptr;
|
|
|
begin
|
begin
|
In_String (1 .. In_Length) := Path.all;
|
In_String (1 .. In_Length) := Path.all;
|
In_String (In_Length + 1) := ASCII.NUL;
|
In_String (In_Length + 1) := ASCII.NUL;
|
Result_Ptr := C_Update_Path (In_String'Address, Component_Name'Address);
|
Result_Ptr := C_Update_Path (In_String'Address, Component_Name'Address);
|
Result_Length := Strlen (Result_Ptr);
|
Result_Length := Strlen (Result_Ptr);
|
|
|
Out_String := new String (1 .. Result_Length);
|
Out_String := new String (1 .. Result_Length);
|
Strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
|
Strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
|
return Out_String;
|
return Out_String;
|
end Update_Path;
|
end Update_Path;
|
|
|
----------------
|
----------------
|
-- Write_Info --
|
-- Write_Info --
|
----------------
|
----------------
|
|
|
procedure Write_Info (Info : String) is
|
procedure Write_Info (Info : String) is
|
begin
|
begin
|
Write_With_Check (Info'Address, Info'Length);
|
Write_With_Check (Info'Address, Info'Length);
|
Write_With_Check (EOL'Address, 1);
|
Write_With_Check (EOL'Address, 1);
|
end Write_Info;
|
end Write_Info;
|
|
|
------------------------
|
------------------------
|
-- Write_Program_Name --
|
-- Write_Program_Name --
|
------------------------
|
------------------------
|
|
|
procedure Write_Program_Name is
|
procedure Write_Program_Name is
|
Save_Buffer : constant String (1 .. Name_Len) :=
|
Save_Buffer : constant String (1 .. Name_Len) :=
|
Name_Buffer (1 .. Name_Len);
|
Name_Buffer (1 .. Name_Len);
|
|
|
begin
|
begin
|
Find_Program_Name;
|
Find_Program_Name;
|
|
|
-- Convert the name to lower case so error messages are the same on
|
-- Convert the name to lower case so error messages are the same on
|
-- all systems.
|
-- all systems.
|
|
|
for J in 1 .. Name_Len loop
|
for J in 1 .. Name_Len loop
|
if Name_Buffer (J) in 'A' .. 'Z' then
|
if Name_Buffer (J) in 'A' .. 'Z' then
|
Name_Buffer (J) :=
|
Name_Buffer (J) :=
|
Character'Val (Character'Pos (Name_Buffer (J)) + 32);
|
Character'Val (Character'Pos (Name_Buffer (J)) + 32);
|
end if;
|
end if;
|
end loop;
|
end loop;
|
|
|
Write_Str (Name_Buffer (1 .. Name_Len));
|
Write_Str (Name_Buffer (1 .. Name_Len));
|
|
|
-- Restore Name_Buffer which was clobbered by the call to
|
-- Restore Name_Buffer which was clobbered by the call to
|
-- Find_Program_Name
|
-- Find_Program_Name
|
|
|
Name_Len := Save_Buffer'Last;
|
Name_Len := Save_Buffer'Last;
|
Name_Buffer (1 .. Name_Len) := Save_Buffer;
|
Name_Buffer (1 .. Name_Len) := Save_Buffer;
|
end Write_Program_Name;
|
end Write_Program_Name;
|
|
|
----------------------
|
----------------------
|
-- Write_With_Check --
|
-- Write_With_Check --
|
----------------------
|
----------------------
|
|
|
procedure Write_With_Check (A : Address; N : Integer) is
|
procedure Write_With_Check (A : Address; N : Integer) is
|
Ignore : Boolean;
|
Ignore : Boolean;
|
pragma Warnings (Off, Ignore);
|
pragma Warnings (Off, Ignore);
|
|
|
begin
|
begin
|
if N = Write (Output_FD, A, N) then
|
if N = Write (Output_FD, A, N) then
|
return;
|
return;
|
|
|
else
|
else
|
Write_Str ("error: disk full writing ");
|
Write_Str ("error: disk full writing ");
|
Write_Name_Decoded (Output_File_Name);
|
Write_Name_Decoded (Output_File_Name);
|
Write_Eol;
|
Write_Eol;
|
Name_Len := Name_Len + 1;
|
Name_Len := Name_Len + 1;
|
Name_Buffer (Name_Len) := ASCII.NUL;
|
Name_Buffer (Name_Len) := ASCII.NUL;
|
Delete_File (Name_Buffer'Address, Ignore);
|
Delete_File (Name_Buffer'Address, Ignore);
|
Exit_Program (E_Fatal);
|
Exit_Program (E_Fatal);
|
end if;
|
end if;
|
end Write_With_Check;
|
end Write_With_Check;
|
|
|
----------------------------
|
----------------------------
|
-- Package Initialization --
|
-- Package Initialization --
|
----------------------------
|
----------------------------
|
|
|
procedure Reset_File_Attributes (Attr : System.Address);
|
procedure Reset_File_Attributes (Attr : System.Address);
|
pragma Import (C, Reset_File_Attributes, "__gnat_reset_attributes");
|
pragma Import (C, Reset_File_Attributes, "__gnat_reset_attributes");
|
|
|
begin
|
begin
|
Initialization : declare
|
Initialization : declare
|
|
|
function Get_Default_Identifier_Character_Set return Character;
|
function Get_Default_Identifier_Character_Set return Character;
|
pragma Import (C, Get_Default_Identifier_Character_Set,
|
pragma Import (C, Get_Default_Identifier_Character_Set,
|
"__gnat_get_default_identifier_character_set");
|
"__gnat_get_default_identifier_character_set");
|
-- Function to determine the default identifier character set,
|
-- Function to determine the default identifier character set,
|
-- which is system dependent. See Opt package spec for a list of
|
-- which is system dependent. See Opt package spec for a list of
|
-- the possible character codes and their interpretations.
|
-- the possible character codes and their interpretations.
|
|
|
function Get_Maximum_File_Name_Length return Int;
|
function Get_Maximum_File_Name_Length return Int;
|
pragma Import (C, Get_Maximum_File_Name_Length,
|
pragma Import (C, Get_Maximum_File_Name_Length,
|
"__gnat_get_maximum_file_name_length");
|
"__gnat_get_maximum_file_name_length");
|
-- Function to get maximum file name length for system
|
-- Function to get maximum file name length for system
|
|
|
Sizeof_File_Attributes : Integer;
|
Sizeof_File_Attributes : Integer;
|
pragma Import (C, Sizeof_File_Attributes,
|
pragma Import (C, Sizeof_File_Attributes,
|
"__gnat_size_of_file_attributes");
|
"__gnat_size_of_file_attributes");
|
|
|
begin
|
begin
|
pragma Assert (Sizeof_File_Attributes <= File_Attributes_Size);
|
pragma Assert (Sizeof_File_Attributes <= File_Attributes_Size);
|
|
|
Reset_File_Attributes (Unknown_Attributes'Address);
|
Reset_File_Attributes (Unknown_Attributes'Address);
|
|
|
Identifier_Character_Set := Get_Default_Identifier_Character_Set;
|
Identifier_Character_Set := Get_Default_Identifier_Character_Set;
|
Maximum_File_Name_Length := Get_Maximum_File_Name_Length;
|
Maximum_File_Name_Length := Get_Maximum_File_Name_Length;
|
|
|
-- Following should be removed by having above function return
|
-- Following should be removed by having above function return
|
-- Integer'Last as indication of no maximum instead of -1 ???
|
-- Integer'Last as indication of no maximum instead of -1 ???
|
|
|
if Maximum_File_Name_Length = -1 then
|
if Maximum_File_Name_Length = -1 then
|
Maximum_File_Name_Length := Int'Last;
|
Maximum_File_Name_Length := Int'Last;
|
end if;
|
end if;
|
|
|
Src_Search_Directories.Set_Last (Primary_Directory);
|
Src_Search_Directories.Set_Last (Primary_Directory);
|
Src_Search_Directories.Table (Primary_Directory) := new String'("");
|
Src_Search_Directories.Table (Primary_Directory) := new String'("");
|
|
|
Lib_Search_Directories.Set_Last (Primary_Directory);
|
Lib_Search_Directories.Set_Last (Primary_Directory);
|
Lib_Search_Directories.Table (Primary_Directory) := new String'("");
|
Lib_Search_Directories.Table (Primary_Directory) := new String'("");
|
|
|
Osint.Initialize;
|
Osint.Initialize;
|
end Initialization;
|
end Initialization;
|
|
|
end Osint;
|
end Osint;
|
|
|