diff options
Diffstat (limited to 'gcc-4.4.0/gcc/ada/osint.adb')
-rw-r--r-- | gcc-4.4.0/gcc/ada/osint.adb | 2923 |
1 files changed, 0 insertions, 2923 deletions
diff --git a/gcc-4.4.0/gcc/ada/osint.adb b/gcc-4.4.0/gcc/ada/osint.adb deleted file mode 100644 index 993ecdf35..000000000 --- a/gcc-4.4.0/gcc/ada/osint.adb +++ /dev/null @@ -1,2923 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- O S I N T -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2008, 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 Unchecked_Conversion; - -with System.Case_Util; use System.Case_Util; - -with GNAT.HTable; - -with Fmap; use Fmap; -with Gnatvsn; use Gnatvsn; -with Hostparm; -with Opt; use Opt; -with Output; use Output; -with Sdefault; use Sdefault; -with Table; -with Targparm; use Targparm; - -package body Osint is - - Running_Program : Program_Type := Unspecified; - -- comment required here ??? - - Program_Set : Boolean := False; - -- comment required here ??? - - Std_Prefix : String_Ptr; - -- Standard prefix, computed dynamically the first time Relocate_Path - -- is called, and cached for subsequent calls. - - Empty : aliased String := ""; - No_Dir : constant String_Ptr := Empty'Access; - -- Used in Locate_File as a fake directory when Name is already an - -- absolute path. - - ------------------------------------- - -- Use of Name_Find and Name_Enter -- - ------------------------------------- - - -- This package creates a number of source, ALI and object file names - -- that are used to locate the actual file and for the purpose of message - -- construction. These names need not be accessible by Name_Find, and can - -- be therefore created by using routine Name_Enter. The files in question - -- are file names with a prefix directory (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 - - 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. - - function Locate_File - (N : File_Name_Type; - T : File_Type; - Dir : Natural; - Name : String) return File_Name_Type; - -- See if the file N whose name is Name exists in directory Dir. Dir is an - -- index into the Lib_Search_Directories table if T = Library. Otherwise - -- if T = Source, Dir is an index into the Src_Search_Directories table. - -- Returns the File_Name_Type of the full file name if file found, or - -- No_File if not found. - - 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 ??? - - ------------------------------ - -- 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. - - ------------------ - -- 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 - - package File_Name_Hash_Table is new GNAT.HTable.Simple_HTable ( - Header_Num => File_Hash_Num, - Element => File_Name_Type, - No_Element => No_File, - Key => File_Name_Type, - Hash => File_Hash, - Equal => "="); - - package File_Stamp_Hash_Table is new GNAT.HTable.Simple_HTable ( - Header_Num => File_Hash_Num, - Element => Time_Stamp_Type, - No_Element => Empty_Time_Stamp, - 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 - - 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"); - - 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); - 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; - - if not Opt.No_Stdlib and not Opt.RTS_Switch then - Search_Path := - Read_Default_Search_Dirs - (String_Access (Update_Path (Search_Dir_Prefix)), - Objects_Search_File, - String_Access (Update_Path (Object_Dir_Default_Name))); - - Get_Next_Dir_In_Path_Init (Search_Path); - loop - Search_Dir := Get_Next_Dir_In_Path (Search_Path); - exit when Search_Dir = null; - Add_Search_Dir (Search_Dir, False); - end loop; - end if; - end if; - end Add_Default_Search_Dirs; - - -------------- - -- Add_File -- - -------------- - - procedure Add_File (File_Name : String; 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; - - Lib_Search_Directories.Increment_Last; - Lib_Search_Directories.Table (Lib_Search_Directories.Last) := - Normalize_Directory_Name (Dir); - 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 -- - ------------------------------ - - -- For now, we only deal with the case of a-z. Eventually we should - -- worry about other Latin-1 letters on systems that support this ??? - - procedure Canonical_Case_File_Name (S : in out String) is - begin - if not File_Names_Case_Sensitive then - for J in S'Range loop - if S (J) in 'A' .. 'Z' then - S (J) := Character'Val ( - Character'Pos (S (J)) + - Character'Pos ('a') - - Character'Pos ('A')); - end if; - end loop; - end if; - end Canonical_Case_File_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; - - --------------------- - -- Executable_Name -- - --------------------- - - function Executable_Name (Name : File_Name_Type) return File_Name_Type is - Exec_Suffix : String_Access; - - 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; - - Get_Name_String (Name); - - if Exec_Suffix'Length /= 0 then - declare - Buffer : String := Name_Buffer (1 .. Name_Len); - - begin - -- Get the file name in canonical case to accept as is names - -- ending with ".EXE" on VMS and Windows. - - Canonical_Case_File_Name (Buffer); - - -- 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; - - Free (Exec_Suffix); - return Name; - end Executable_Name; - - function Executable_Name (Name : String) return String is - Exec_Suffix : String_Access; - 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; - - declare - Suffix : constant String := Exec_Suffix.all; - - begin - Free (Exec_Suffix); - Canonical_Case_File_Name (Canonical_Name); - - if Suffix'Length /= 0 - 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 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 (S1 : String; S2 : String := ""; S3 : String := "") is - begin - -- We use Output in case there is a special output set up. - -- In this case Set_Standard_Error will have no immediate effect. - - Set_Standard_Error; - Osint.Write_Program_Name; - Write_Str (": "); - Write_Str (S1); - Write_Str (S2); - Write_Str (S3); - Write_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_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); - - if not Is_Regular_File (Name_Buffer (1 .. Name_Len)) then - return Empty_Time_Stamp; - else - Name_Buffer (Name_Len + 1) := ASCII.NUL; - return OS_Time_To_GNAT_Time (File_Time_Stamp (Name_Buffer)); - end if; - 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 - 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 - return N; - - -- If we are trying to find the current main file just look in the - -- directory where the user said it was. - - elsif Look_In_Primary_Directory_For_Current_Main - and then Current_Main = N - then - return Locate_File (N, T, Primary_Directory, File_Name); - - -- 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 - return No_File; - - else - return File; - end if; - end if; - - -- First place to look is in the primary directory (i.e. the same - -- directory as the source) unless this has been disabled with -I- - - if Opt.Look_In_Primary_Dir then - File := Locate_File (N, T, Primary_Directory, File_Name); - - if File /= No_File then - return File; - 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 - File := Locate_File (N, T, D, File_Name); - - if File /= No_File then - return File; - end if; - end loop; - - return 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 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 -- - ------------------------ - - function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type is - begin - return Find_File (N, Library); - 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; - - ------------------- - -- 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 is - Include_Dir : String_Access := - String_Access (Update_Path (Include_Dir_Default_Name)); - - begin - if Include_Dir = null then - return ""; - - else - declare - Result : constant String := Include_Dir.all; - begin - Free (Include_Dir); - return Result; - end; - end if; - 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_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; - - ------------------- - -- 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; - - ------------------------ - -- Library_File_Stamp -- - ------------------------ - - function Library_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is - begin - return File_Stamp (Find_File (N, Library)); - end Library_File_Stamp; - - ----------------- - -- Locate_File -- - ----------------- - - function Locate_File - (N : File_Name_Type; - T : File_Type; - Dir : Natural; - Name : String) return File_Name_Type - 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); - - begin - Full_Name (1 .. Dir_Name'Length) := Dir_Name.all; - Full_Name (Dir_Name'Length + 1 .. Full_Name'Length) := Name; - - if not Is_Regular_File (Full_Name) then - return No_File; - - else - -- If the file is in the current directory then return N itself - - if Dir_Name'Length = 0 then - return N; - else - Name_Len := Full_Name'Length; - Name_Buffer (1 .. Name_Len) := Full_Name; - return Name_Enter; - 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; - Last_Dir : Natural; - - begin - if Opt.Look_In_Primary_Dir then - File := Locate_File (N, Source, Primary_Directory, File_Name); - - 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 - File := Locate_File (N, Source, D, File_Name); - - 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 - 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 - Lib_FD : File_Descriptor; - -- The file descriptor for the current library file. A negative value - -- indicates failure to open the specified source file. - - Text : Text_Buffer_Ptr; - -- Allocated text buffer - - Status : Boolean; - pragma Warnings (Off, Status); - -- For the calls to Close - - begin - Current_Full_Lib_Name := Find_File (Lib_File, Library); - Current_Full_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; - - -- Check for object file consistency if requested - - if Opt.Check_Object_Consistency then - Current_Full_Lib_Stamp := File_Stamp (Current_Full_Lib_Name); - 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 - - if Is_Readonly_Library (Current_Full_Lib_Name) 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; - end if; - end if; - - -- Read data from the file - - declare - Len : constant Integer := Integer (File_Length (Lib_FD)); - -- Length of source file text. If it doesn't fit in an integer - -- we're probably stuck anyway (>2 gigs of source seems a lot!) - - Actual_Len : Integer := 0; - - Lo : constant Text_Ptr := 0; - -- 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 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; - - ---------------------- - -- 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; - - -- 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 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 - Time_Stamp : Time_Stamp_Type; - - begin - if not File_Cache_Enabled then - return File_Stamp (Find_File (N, T)); - end if; - - Time_Stamp := File_Stamp_Hash_Table.Get (N); - - if Time_Stamp (1) = ' ' then - Time_Stamp := File_Stamp (Smart_Find_File (N, T)); - File_Stamp_Hash_Table.Set (N, Time_Stamp); - end if; - - return Time_Stamp; - end Smart_File_Stamp; - - --------------------- - -- Smart_Find_File -- - --------------------- - - function Smart_Find_File - (N : File_Name_Type; - T : File_Type) return File_Name_Type - is - Full_File_Name : File_Name_Type; - - begin - if not File_Cache_Enabled then - return Find_File (N, T); - end if; - - Full_File_Name := File_Name_Hash_Table.Get (N); - - if Full_File_Name = No_File then - Full_File_Name := Find_File (N, T); - File_Name_Hash_Table.Set (N, Full_File_Name); - end if; - - return Full_File_Name; - 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 the 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 -- ----------------------------- - -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 - - begin - 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; |