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