| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- O S I N T -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- $Revision$ |
| -- -- |
| -- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 2, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING. If not, write -- |
| -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- |
| -- MA 02111-1307, USA. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Fmap; use Fmap; |
| with Hostparm; |
| with Namet; use Namet; |
| with Opt; use Opt; |
| with Output; use Output; |
| with Sdefault; use Sdefault; |
| with Table; |
| with Tree_IO; use Tree_IO; |
| |
| with Unchecked_Conversion; |
| |
| with GNAT.OS_Lib; use GNAT.OS_Lib; |
| with GNAT.HTable; |
| |
| package body Osint is |
| |
| ------------------------------------- |
| -- Use of Name_Find and Name_Enter -- |
| ------------------------------------- |
| |
| -- This package creates a number of source, ALI and object file names |
| -- that are used to locate the actual file and for the purpose of |
| -- message construction. These names need not be accessible by Name_Find, |
| -- and can be therefore created by using routine Name_Enter. The files in |
| -- question are file names with a prefix directory (ie the files not |
| -- in the current directory). File names without a prefix directory are |
| -- entered with Name_Find because special values might be attached to |
| -- the various Info fields of the corresponding name table entry. |
| |
| ----------------------- |
| -- Local Subprograms -- |
| ----------------------- |
| |
| function Append_Suffix_To_File_Name |
| (Name : Name_Id; |
| Suffix : String) |
| return Name_Id; |
| -- Appends Suffix to Name and returns the new name. |
| |
| function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type; |
| -- Convert OS format time to GNAT format time stamp |
| |
| procedure Create_File_And_Check |
| (Fdesc : out File_Descriptor; |
| Fmode : Mode); |
| -- Create file whose name (NUL terminated) is in Name_Buffer (with the |
| -- length in Name_Len), and place the resulting descriptor in Fdesc. |
| -- Issue message and exit with fatal error if file cannot be created. |
| -- The Fmode parameter is set to either Text or Binary (see description |
| -- of GNAT.OS_Lib.Create_File). |
| |
| procedure Set_Library_Info_Name; |
| -- Sets a default ali file name from the main compiler source name. |
| -- This is used by Create_Output_Library_Info, and by the version of |
| -- Read_Library_Info that takes a default file name. |
| |
| procedure Write_Info (Info : String); |
| -- Implementation of Write_Binder_Info, Write_Debug_Info and |
| -- Write_Library_Info (identical) |
| |
| procedure Write_With_Check (A : Address; N : Integer); |
| -- Writes N bytes from buffer starting at address A to file whose FD is |
| -- stored in Output_FD, and whose file name is stored as a File_Name_Type |
| -- in Output_File_Name. A check is made for disk full, and if this is |
| -- detected, the file being written is deleted, and a fatal error is |
| -- signalled. |
| |
| function More_Files return Boolean; |
| -- Implements More_Source_Files and More_Lib_Files. |
| |
| function Next_Main_File return File_Name_Type; |
| -- Implements Next_Main_Source and Next_Main_Lib_File. |
| |
| function Locate_File |
| (N : File_Name_Type; |
| T : File_Type; |
| Dir : Natural; |
| Name : String) |
| return File_Name_Type; |
| -- See if the file N whose name is Name exists in directory Dir. Dir is |
| -- an index into the Lib_Search_Directories table if T = Library. |
| -- Otherwise if T = Source, Dir is an index into the |
| -- Src_Search_Directories table. Returns the File_Name_Type of the |
| -- full file name if file found, or No_File if not found. |
| |
| function C_String_Length (S : Address) return Integer; |
| -- Returns length of a C string. Returns 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 -- |
| ------------------------------ |
| |
| ALI_Suffix : constant String_Ptr := new String'("ali"); |
| -- The suffix used for the library files (also known as ALI files). |
| |
| Object_Suffix : constant String := Get_Object_Suffix.all; |
| -- The suffix used for the object files. |
| |
| EOL : constant Character := ASCII.LF; |
| -- End of line character |
| |
| Argument_Count : constant Integer := Arg_Count - 1; |
| -- Number of arguments (excluding program name) |
| |
| type File_Name_Array is array (Int range <>) of String_Ptr; |
| type File_Name_Array_Ptr is access File_Name_Array; |
| File_Names : File_Name_Array_Ptr := |
| new File_Name_Array (1 .. Int (Argument_Count) + 2); |
| -- As arguments are scanned in Initialize, file names are stored |
| -- in this array. The string does not contain a terminating NUL. |
| -- The array is "extensible" because when using project files, |
| -- there may be more file names than argument on the command line. |
| |
| Number_File_Names : Int := 0; |
| -- The total number of file names found on command line and placed in |
| -- File_Names. |
| |
| Current_File_Name_Index : Int := 0; |
| -- The index in File_Names of the last file opened by Next_Main_Source |
| -- or Next_Main_Lib_File. The value 0 indicates that no files have been |
| -- opened yet. |
| |
| Current_Main : File_Name_Type := No_File; |
| -- Used to save a simple file name between calls to Next_Main_Source and |
| -- Read_Source_File. If the file name argument to Read_Source_File is |
| -- No_File, that indicates that the file whose name was returned by the |
| -- last call to Next_Main_Source (and stored here) is to be read. |
| |
| Look_In_Primary_Directory_For_Current_Main : Boolean := False; |
| -- When this variable is True, Find_File will only look in |
| -- the Primary_Directory for the Current_Main file. |
| -- This variable is always True for the compiler. |
| -- It is also True for gnatmake, when the soucr name given |
| -- on the command line has directory information. |
| |
| 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. |
| |
| Old_Binder_Output_Time_Stamp : Time_Stamp_Type; |
| New_Binder_Output_Time_Stamp : Time_Stamp_Type; |
| Recording_Time_From_Last_Bind : Boolean := False; |
| Binder_Output_Time_Stamps_Set : Boolean := False; |
| |
| In_Binder : Boolean := False; |
| In_Compiler : Boolean := False; |
| In_Make : Boolean := False; |
| -- Exactly one of these flags is set True to indicate which program |
| -- is bound and executing with Osint, which is used by all these programs. |
| |
| Output_FD : File_Descriptor; |
| -- The file descriptor for the current library info, tree or binder output |
| |
| Output_File_Name : File_Name_Type; |
| -- File_Name_Type for name of open file whose FD is in Output_FD, the name |
| -- stored does not include the trailing NUL character. |
| |
| Output_Object_File_Name : String_Ptr; |
| -- Argument of -o compiler option, if given. This is needed to |
| -- verify consistency with the ALI file name. |
| |
| ------------------ |
| -- 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 => Natural, |
| 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 => Natural, |
| 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 (ie with |
| -- directory info) or time stamp of the file will be payed only once, |
| -- the first time the full name is actually searched (or the first time |
| -- the time stamp is actually retrieved). This is achieved by employing |
| -- a hash table that stores as a key the File_Name_Type of the file and |
| -- associates to that File_Name_Type the full file name of the file and its |
| -- time stamp. |
| |
| 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; |
| |
| procedure Add_Search_Dir |
| (Search_Dir : String_Access; |
| Additional_Source_Dir : Boolean); |
| -- Needs documentation ??? |
| |
| function Get_Libraries_From_Registry return String_Ptr; |
| -- On Windows systems, get the list of installed standard libraries |
| -- from the registry key: |
| -- HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\ |
| -- GNAT\Standard Libraries |
| -- Return an empty string on other systems |
| |
| function Update_Path (Path : String_Ptr) return String_Ptr; |
| -- Update the specified path to replace the prefix with |
| -- the location where GNAT is installed. See the file prefix.c |
| -- in GCC for more details. |
| |
| -------------------- |
| -- 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_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; |
| |
| ----------------- |
| -- Update_Path -- |
| ----------------- |
| |
| function Update_Path (Path : String_Ptr) return String_Ptr is |
| |
| function C_Update_Path (Path, Component : Address) return Address; |
| pragma Import (C, C_Update_Path, "update_path"); |
| |
| function Strlen (Str : Address) return Integer; |
| pragma Import (C, Strlen, "strlen"); |
| |
| procedure Strncpy (X : Address; Y : Address; Length : Integer); |
| pragma Import (C, Strncpy, "strncpy"); |
| |
| In_Length : constant Integer := Path'Length; |
| In_String : String (1 .. In_Length + 1); |
| Component_Name : aliased String := "GNAT" & ASCII.NUL; |
| Result_Ptr : Address; |
| Result_Length : Integer; |
| Out_String : String_Ptr; |
| |
| begin |
| In_String (1 .. In_Length) := Path.all; |
| In_String (In_Length + 1) := ASCII.NUL; |
| Result_Ptr := C_Update_Path (In_String'Address, |
| Component_Name'Address); |
| Result_Length := Strlen (Result_Ptr); |
| |
| Out_String := new String (1 .. Result_Length); |
| Strncpy (Out_String.all'Address, Result_Ptr, Result_Length); |
| return Out_String; |
| end Update_Path; |
| |
| -- 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. |
| |
| -- 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; |
| |
| 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 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 Add_Default_Search_Dirs; |
| |
| -------------- |
| -- Add_File -- |
| -------------- |
| |
| procedure Add_File (File_Name : String) 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); |
| end if; |
| |
| File_Names (Number_File_Names) := new String'(File_Name); |
| 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_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 : Name_Id; |
| Suffix : String) |
| return Name_Id |
| 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; |
| |
| ------------------------- |
| -- Close_Binder_Output -- |
| ------------------------- |
| |
| procedure Close_Binder_Output is |
| begin |
| pragma Assert (In_Binder); |
| Close (Output_FD); |
| |
| if Recording_Time_From_Last_Bind then |
| New_Binder_Output_Time_Stamp := File_Stamp (Output_File_Name); |
| Binder_Output_Time_Stamps_Set := True; |
| end if; |
| end Close_Binder_Output; |
| |
| ---------------------- |
| -- Close_Debug_File -- |
| ---------------------- |
| |
| procedure Close_Debug_File is |
| begin |
| pragma Assert (In_Compiler); |
| Close (Output_FD); |
| end Close_Debug_File; |
| |
| ------------------------------- |
| -- Close_Output_Library_Info -- |
| ------------------------------- |
| |
| procedure Close_Output_Library_Info is |
| begin |
| pragma Assert (In_Compiler); |
| Close (Output_FD); |
| end Close_Output_Library_Info; |
| |
| -------------------------- |
| -- Create_Binder_Output -- |
| -------------------------- |
| |
| procedure Create_Binder_Output |
| (Output_File_Name : String; |
| Typ : Character; |
| Bfile : out Name_Id) |
| is |
| File_Name : String_Ptr; |
| Findex1 : Natural; |
| Findex2 : Natural; |
| Flength : Natural; |
| |
| begin |
| pragma Assert (In_Binder); |
| |
| if Output_File_Name /= "" then |
| Name_Buffer (Output_File_Name'Range) := Output_File_Name; |
| Name_Buffer (Output_File_Name'Last + 1) := ASCII.NUL; |
| |
| if Typ = 's' then |
| Name_Buffer (Output_File_Name'Last) := 's'; |
| end if; |
| |
| Name_Len := Output_File_Name'Last; |
| |
| else |
| Name_Buffer (1) := 'b'; |
| File_Name := File_Names (Current_File_Name_Index); |
| |
| Findex1 := File_Name'First; |
| |
| -- The ali file might be specified by a full path name. However, |
| -- the binder generated file should always be created in the |
| -- current directory, so the path might need to be stripped away. |
| -- In addition to the default directory_separator allow the '/' to |
| -- act as separator since this is allowed in MS-DOS and OS2 ports. |
| |
| for J in reverse File_Name'Range loop |
| if File_Name (J) = Directory_Separator |
| or else File_Name (J) = '/' |
| then |
| Findex1 := J + 1; |
| exit; |
| end if; |
| end loop; |
| |
| Findex2 := File_Name'Last; |
| while File_Name (Findex2) /= '.' loop |
| Findex2 := Findex2 - 1; |
| end loop; |
| |
| Flength := Findex2 - Findex1; |
| |
| if Maximum_File_Name_Length > 0 then |
| |
| -- Make room for the extra two characters in "b?" |
| |
| while Int (Flength) > Maximum_File_Name_Length - 2 loop |
| Findex2 := Findex2 - 1; |
| Flength := Findex2 - Findex1; |
| end loop; |
| end if; |
| |
| Name_Buffer (3 .. Flength + 2) := File_Name (Findex1 .. Findex2 - 1); |
| Name_Buffer (Flength + 3) := '.'; |
| |
| -- C bind file, name is b_xxx.c |
| |
| if Typ = 'c' then |
| Name_Buffer (2) := '_'; |
| Name_Buffer (Flength + 4) := 'c'; |
| Name_Buffer (Flength + 5) := ASCII.NUL; |
| Name_Len := Flength + 4; |
| |
| -- Ada bind file, name is b~xxx.adb or b~xxx.ads |
| -- (with $ instead of ~ in VMS) |
| |
| else |
| if Hostparm.OpenVMS then |
| Name_Buffer (2) := '$'; |
| else |
| Name_Buffer (2) := '~'; |
| end if; |
| |
| Name_Buffer (Flength + 4) := 'a'; |
| Name_Buffer (Flength + 5) := 'd'; |
| Name_Buffer (Flength + 6) := Typ; |
| Name_Buffer (Flength + 7) := ASCII.NUL; |
| Name_Len := Flength + 6; |
| end if; |
| end if; |
| |
| Bfile := Name_Find; |
| |
| if Recording_Time_From_Last_Bind then |
| Old_Binder_Output_Time_Stamp := File_Stamp (Bfile); |
| end if; |
| |
| Create_File_And_Check (Output_FD, Text); |
| end Create_Binder_Output; |
| |
| ----------------------- |
| -- Create_Debug_File -- |
| ----------------------- |
| |
| function Create_Debug_File (Src : File_Name_Type) return File_Name_Type is |
| Result : File_Name_Type; |
| |
| begin |
| Get_Name_String (Src); |
| |
| if Hostparm.OpenVMS then |
| Name_Buffer (Name_Len + 1 .. Name_Len + 3) := "_dg"; |
| else |
| Name_Buffer (Name_Len + 1 .. Name_Len + 3) := ".dg"; |
| end if; |
| |
| Name_Len := Name_Len + 3; |
| |
| if Output_Object_File_Name /= null then |
| |
| for Index in reverse Output_Object_File_Name'Range loop |
| |
| if Output_Object_File_Name (Index) = Directory_Separator then |
| declare |
| File_Name : constant String := Name_Buffer (1 .. Name_Len); |
| |
| begin |
| Name_Len := Index - Output_Object_File_Name'First + 1; |
| Name_Buffer (1 .. Name_Len) := |
| Output_Object_File_Name |
| (Output_Object_File_Name'First .. Index); |
| Name_Buffer (Name_Len + 1 .. Name_Len + File_Name'Length) := |
| File_Name; |
| Name_Len := Name_Len + File_Name'Length; |
| end; |
| |
| exit; |
| end if; |
| end loop; |
| end if; |
| |
| Result := Name_Find; |
| Name_Buffer (Name_Len + 1) := ASCII.NUL; |
| Create_File_And_Check (Output_FD, Text); |
| return Result; |
| end Create_Debug_File; |
| |
| --------------------------- |
| -- Create_File_And_Check -- |
| --------------------------- |
| |
| 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; |
| |
| -------------------------------- |
| -- Create_Output_Library_Info -- |
| -------------------------------- |
| |
| procedure Create_Output_Library_Info is |
| begin |
| Set_Library_Info_Name; |
| Create_File_And_Check (Output_FD, Text); |
| end Create_Output_Library_Info; |
| |
| -------------------------------- |
| -- 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; |
| |
| --------------------------- |
| -- Debug_File_Eol_Length -- |
| --------------------------- |
| |
| function Debug_File_Eol_Length return Nat is |
| begin |
| -- There has to be a cleaner way to do this! ??? |
| |
| if Directory_Separator = '/' then |
| return 1; |
| else |
| return 2; |
| end if; |
| end Debug_File_Eol_Length; |
| |
| ---------------------------- |
| -- Dir_In_Obj_Search_Path -- |
| ---------------------------- |
| |
| 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; |
| |
| Get_Name_String (Name); |
| Exec_Suffix := Get_Executable_Suffix; |
| |
| for J in Exec_Suffix.all'Range loop |
| Name_Len := Name_Len + 1; |
| Name_Buffer (Name_Len) := Exec_Suffix.all (J); |
| end loop; |
| |
| return Name_Enter; |
| end Executable_Name; |
| |
| ------------------ |
| -- Exit_Program -- |
| ------------------ |
| |
| procedure Exit_Program (Exit_Code : Exit_Code_Type) is |
| begin |
| -- The program will exit with the following status: |
| -- 0 if the object file has been generated (with or without warnings) |
| -- 1 if recompilation was not needed (smart recompilation) |
| -- 2 if gnat1 has been killed by a signal (detected by GCC) |
| -- 3 if no code has been generated (spec) |
| -- 4 for a fatal error |
| -- 5 if there were errors |
| |
| case Exit_Code is |
| when E_Success => OS_Exit (0); |
| when E_Warnings => OS_Exit (0); |
| when E_No_Compile => OS_Exit (1); |
| when E_No_Code => OS_Exit (3); |
| when E_Fatal => OS_Exit (4); |
| when E_Errors => OS_Exit (5); |
| when E_Abort => OS_Abort; |
| end case; |
| end Exit_Program; |
| |
| ---------- |
| -- Fail -- |
| ---------- |
| |
| procedure Fail (S1 : String; S2 : String := ""; S3 : String := "") is |
| begin |
| Set_Standard_Error; |
| Osint.Write_Program_Name; |
| Write_Str (": "); |
| Write_Str (S1); |
| Write_Str (S2); |
| Write_Str (S3); |
| Write_Eol; |
| |
| -- ??? Using Output is ugly, should do direct writes |
| -- ??? shouldn't this go to standard error instead of stdout? |
| |
| Exit_Program (E_Fatal); |
| end Fail; |
| |
| --------------- |
| -- 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; |
| |
| --------------- |
| -- 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 |
| return File; |
| 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); |
| |
| -- 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; |
| |
| for J in reverse Cindex1 .. Cindex2 loop |
| if Command_Name (J) = '.' then |
| Cindex2 := J - 1; |
| exit; |
| end if; |
| end loop; |
| |
| 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; |
| |
| ---------------- |
| -- Initialize -- |
| ---------------- |
| |
| procedure Initialize (P : Program_Type) is |
| function Get_Default_Identifier_Character_Set return Character; |
| pragma Import (C, Get_Default_Identifier_Character_Set, |
| "__gnat_get_default_identifier_character_set"); |
| -- Function to determine the default identifier character set, |
| -- which is system dependent. See Opt package spec for a list of |
| -- the possible character codes and their interpretations. |
| |
| function Get_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 |
| |
| procedure Adjust_OS_Resource_Limits; |
| pragma Import (C, Adjust_OS_Resource_Limits, |
| "__gnat_adjust_os_resource_limits"); |
| -- Procedure to make system specific adjustments to make GNAT |
| -- run better. |
| |
| -- Start of processing for Initialize |
| |
| begin |
| Program := P; |
| |
| case Program is |
| when Binder => In_Binder := True; |
| when Compiler => In_Compiler := True; |
| when Make => In_Make := True; |
| end case; |
| |
| if In_Compiler then |
| Adjust_OS_Resource_Limits; |
| end if; |
| |
| Src_Search_Directories.Init; |
| Lib_Search_Directories.Init; |
| |
| 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; |
| |
| -- Start off by setting all suppress options to False, these will |
| -- be reset later (turning some on if -gnato is not specified, and |
| -- turning all of them on if -gnatp is specified). |
| |
| Suppress_Options := (others => False); |
| |
| -- Set software overflow check flag. For now all targets require the |
| -- use of software overflow checks. Later on, this will have to be |
| -- specialized to the backend target. Also, if software overflow |
| -- checking mode is set, then the default for suppressing overflow |
| -- checks is True, since the software approach is expensive. |
| |
| Software_Overflow_Checking := True; |
| Suppress_Options.Overflow_Checks := True; |
| |
| -- Reserve the first slot in the search paths table. This is the |
| -- directory of the main source file or main library file and is |
| -- filled in by each call to Next_Main_Source/Next_Main_Lib_File with |
| -- the directory specified for this main source or library file. This |
| -- is the directory which is searched first by default. This default |
| -- search is inhibited by the option -I- for both source and library |
| -- files. |
| |
| 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 : in 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) |
| return File_Name_Type |
| is |
| Fptr : Natural; |
| -- Pointer to location to set extension in place |
| |
| begin |
| Get_Name_String (Source_File); |
| Fptr := Name_Len + 1; |
| |
| for J in reverse 1 .. Name_Len loop |
| if Name_Buffer (J) = '.' then |
| Fptr := J; |
| exit; |
| end if; |
| end loop; |
| |
| Name_Buffer (Fptr) := '.'; |
| Name_Buffer (Fptr + 1 .. Fptr + ALI_Suffix'Length) := ALI_Suffix.all; |
| Name_Buffer (Fptr + ALI_Suffix'Length + 1) := ASCII.NUL; |
| Name_Len := Fptr + ALI_Suffix'Length; |
| 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 T = Library then |
| Dir_Name := Lib_Search_Directories.Table (Dir); |
| |
| else pragma Assert (T = Source); |
| 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; |
| |
| -------------------- |
| -- More_Lib_Files -- |
| -------------------- |
| |
| function More_Lib_Files return Boolean is |
| begin |
| pragma Assert (In_Binder); |
| return More_Files; |
| end More_Lib_Files; |
| |
| ----------------------- |
| -- More_Source_Files -- |
| ----------------------- |
| |
| function More_Source_Files return Boolean is |
| begin |
| pragma Assert (In_Compiler or else In_Make); |
| return More_Files; |
| end More_Source_Files; |
| |
| ------------------------------- |
| -- Nb_Dir_In_Obj_Search_Path -- |
| ------------------------------- |
| |
| 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)); |
| |
| if In_Compiler then |
| Src_Search_Directories.Table (Primary_Directory) := Dir_Name; |
| Look_In_Primary_Directory_For_Current_Main := True; |
| |
| elsif In_Make then |
| Src_Search_Directories.Table (Primary_Directory) := Dir_Name; |
| if Fptr > File_Name'First then |
| Look_In_Primary_Directory_For_Current_Main := True; |
| end if; |
| |
| else pragma Assert (In_Binder); |
| Dir_Name := Normalize_Directory_Name (Dir_Name.all); |
| Lib_Search_Directories.Table (Primary_Directory) := Dir_Name; |
| end if; |
| |
| Name_Len := File_Name'Last - Fptr + 1; |
| Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last); |
| Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); |
| Current_Main := File_Name_Type (Name_Find); |
| |
| -- In the gnatmake case, the main file may have not have the |
| -- extension. Try ".adb" first then ".ads" |
| |
| if In_Make then |
| declare |
| Orig_Main : 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; |
| |
| ------------------------ |
| -- Next_Main_Lib_File -- |
| ------------------------ |
| |
| function Next_Main_Lib_File return File_Name_Type is |
| begin |
| pragma Assert (In_Binder); |
| return Next_Main_File; |
| end Next_Main_Lib_File; |
| |
| ---------------------- |
| -- Next_Main_Source -- |
| ---------------------- |
| |
| function Next_Main_Source return File_Name_Type is |
| Main_File : File_Name_Type := Next_Main_File; |
| |
| begin |
| pragma Assert (In_Compiler or else In_Make); |
| return Main_File; |
| end Next_Main_Source; |
| |
| ------------------------------ |
| -- Normalize_Directory_Name -- |
| ------------------------------ |
| |
| function Normalize_Directory_Name (Directory : String) return String_Ptr is |
| Result : String_Ptr; |
| |
| begin |
| if Directory'Length = 0 then |
| Result := new String'(Hostparm.Normalized_CWD); |
| |
| elsif Is_Directory_Separator (Directory (Directory'Last)) then |
| Result := new String'(Directory); |
| 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_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 Object_Suffix'Range loop |
| Name_Len := Name_Len + 1; |
| Name_Buffer (Name_Len) := Object_Suffix (J); |
| end loop; |
| |
| return Name_Enter; |
| end Object_File_Name; |
| |
| -------------------------- |
| -- 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) return String_Access is |
| Res : String_Access; |
| |
| begin |
| -- Get the name of the current program being executed |
| |
| Find_Program_Name; |
| |
| -- Find the target prefix if any, for the cross compilation case |
| -- for instance in "alpha-dec-vxworks-gcc" the target prefix is |
| -- "alpha-dec-vxworks-" |
| |
| while Name_Len > 0 loop |
| if Name_Buffer (Name_Len) = '-' then |
| exit; |
| end if; |
| |
| Name_Len := Name_Len - 1; |
| end loop; |
| |
| -- Create the new program name |
| |
| Res := new String (1 .. Name_Len + Nam'Length); |
| Res.all (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); |
| Res.all (Name_Len + 1 .. Name_Len + Nam'Length) := Nam; |
| return Res; |
| 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, translating line and file ending |
| -- control characters to a path separator character. |
| |
| Prev_Was_Separator := True; |
| Nb_Relative_Dir := 0; |
| for J in 1 .. Len loop |
| if S (J) in ASCII.NUL .. ASCII.US |
| or else S (J) = ' ' |
| then |
| S (J) := Path_Separator; |
| end if; |
| |
| if S (J) = Path_Separator then |
| Prev_Was_Separator := True; |
| 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) := 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. |
| |
| 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 that |
| -- the 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); |
| Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len)); |
| |
| else |
| Current_Full_Obj_Stamp := Empty_Time_Stamp; |
| Close (Lib_FD); |
| return null; |
| end if; |
| end if; |
| |
| -- Object file exists, compare object and ALI time stamps |
| |
| if Current_Full_Lib_Stamp > Current_Full_Obj_Stamp then |
| if Fatal_Err then |
| Get_Name_String (Current_Full_Obj_Name); |
| Close (Lib_FD); |
| Fail ("Bad time stamp: ", Name_Buffer (1 .. Name_Len)); |
| else |
| Current_Full_Obj_Stamp := Empty_Time_Stamp; |
| Close (Lib_FD); |
| return null; |
| end if; |
| end if; |
| end if; |
| |
| -- Read data from the file |
| |
| declare |
| Len : Integer := Integer (File_Length (Lib_FD)); |
| -- Length of source file text. If it doesn't fit in an integer |
| -- we're probably stuck anyway (>2 gigs of source seems a lot!) |
| |
| Actual_Len : Integer := 0; |
| |
| Lo : Text_Ptr := 0; |
| -- 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); |
| return Text; |
| |
| end Read_Library_Info; |
| |
| -- Version with default file name |
| |
| procedure Read_Library_Info |
| (Name : out File_Name_Type; |
| Text : out Text_Buffer_Ptr) |
| is |
| begin |
| Set_Library_Info_Name; |
| Name := Name_Find; |
| Text := Read_Library_Info (Name, Fatal_Err => False); |
| end Read_Library_Info; |
| |
| ---------------------- |
| -- 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; |
| |
| 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 : 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); |
| |
| function To_Source_Buffer_Ptr is new |
| Unchecked_Conversion (Address, Source_Buffer_Ptr); |
| |
| 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); |
| |
| end Read_Source_File; |
| |
| -------------------------------- |
| -- Record_Time_From_Last_Bind -- |
| -------------------------------- |
| |
| procedure Record_Time_From_Last_Bind is |
| begin |
| Recording_Time_From_Last_Bind := True; |
| end Record_Time_From_Last_Bind; |
| |
| --------------------------- |
| -- Set_Library_Info_Name -- |
| --------------------------- |
| |
| procedure Set_Library_Info_Name is |
| Dot_Index : Natural; |
| |
| begin |
| pragma Assert (In_Compiler); |
| Get_Name_String (Current_Main); |
| |
| -- Find last dot since we replace the existing extension by .ali. The |
| -- initialization to Name_Len + 1 provides for simply adding the .ali |
| -- extension if the source file name has no extension. |
| |
| Dot_Index := Name_Len + 1; |
| for J in reverse 1 .. Name_Len loop |
| if Name_Buffer (J) = '.' then |
| Dot_Index := J; |
| exit; |
| end if; |
| end loop; |
| |
| -- Make sure that the output file name matches the source file name. |
| -- To compare them, remove file name directories and extensions. |
| |
| if Output_Object_File_Name /= null then |
| declare |
| Name : constant String := Name_Buffer (1 .. Dot_Index); |
| Len : constant Natural := Dot_Index; |
| |
| begin |
| Name_Buffer (1 .. Output_Object_File_Name'Length) |
| := Output_Object_File_Name.all; |
| Dot_Index := 0; |
| |
| for J in reverse Output_Object_File_Name'Range loop |
| if Name_Buffer (J) = '.' then |
| Dot_Index := J; |
| exit; |
| end if; |
| end loop; |
| |
| pragma Assert (Dot_Index /= 0); |
| -- We check for the extension elsewhere |
| |
| if Name /= Name_Buffer (Dot_Index - Len + 1 .. Dot_Index) then |
| Fail ("incorrect object file name"); |
| end if; |
| end; |
| end if; |
| |
| Name_Buffer (Dot_Index) := '.'; |
| Name_Buffer (Dot_Index + 1 .. Dot_Index + 3) := ALI_Suffix.all; |
| Name_Buffer (Dot_Index + 4) := ASCII.NUL; |
| Name_Len := Dot_Index + 3; |
| end Set_Library_Info_Name; |
| |
| --------------------------------- |
| -- Set_Output_Object_File_Name -- |
| --------------------------------- |
| |
| procedure Set_Output_Object_File_Name (Name : String) is |
| Ext : constant String := Object_Suffix; |
| NL : constant Natural := Name'Length; |
| EL : constant Natural := Ext'Length; |
| |
| begin |
| -- Make sure that the object file has the expected extension. |
| |
| if NL <= EL |
| or else Name (NL - EL + Name'First .. Name'Last) /= Ext |
| then |
| Fail ("incorrect object file extension"); |
| end if; |
| |
| Output_Object_File_Name := new String'(Name); |
| end Set_Output_Object_File_Name; |
| |
| ------------------------ |
| -- Set_Main_File_Name -- |
| ------------------------ |
| |
| procedure Set_Main_File_Name (Name : String) is |
| begin |
| Number_File_Names := Number_File_Names + 1; |
| File_Names (Number_File_Names) := new String'(Name); |
| end Set_Main_File_Name; |
| |
| ---------------------- |
| -- 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); |
| |
| declare |
| S : String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); |
| Fptr : Natural := S'First; |
| |
| begin |
| for J in reverse S'Range loop |
| if Is_Directory_Separator (S (J)) then |
| Fptr := J + 1; |
| exit; |
| end if; |
| end loop; |
| |
| if Fptr = S'First then |
| return Name; |
| end if; |
| |
| Name_Buffer (1 .. S'Last - Fptr + 1) := S (Fptr .. S'Last); |
| Name_Len := S'Last - Fptr + 1; |
| return Name_Find; |
| end; |
| 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 1 .. Name_Len loop |
| if Name_Buffer (J) = '.' then |
| Name_Len := J - 1; |
| return Name_Enter; |
| end if; |
| end loop; |
| |
| return Name; |
| end Strip_Suffix; |
| |
| ------------------------- |
| -- Time_From_Last_Bind -- |
| ------------------------- |
| |
| function Time_From_Last_Bind return Nat is |
| Old_Y : Nat; |
| Old_M : Nat; |
| Old_D : Nat; |
| Old_H : Nat; |
| Old_Mi : Nat; |
| Old_S : Nat; |
| New_Y : Nat; |
| New_M : Nat; |
| New_D : Nat; |
| New_H : Nat; |
| New_Mi : Nat; |
| New_S : Nat; |
| |
| type Month_Data is array (Int range 1 .. 12) of Int; |
| Cumul : constant Month_Data := (0, 0, 3, 3, 4, 4, 5, 5, 5, 6, 6, 7); |
| -- Represents the difference in days from a period compared to the |
| -- same period if all months had 31 days, i.e: |
| -- |
| -- Cumul (m) = 31x(m-1) - (number of days from 01/01 to m/01) |
| |
| Res : Int; |
| |
| begin |
| if not Recording_Time_From_Last_Bind |
| or else not Binder_Output_Time_Stamps_Set |
| or else Old_Binder_Output_Time_Stamp = Empty_Time_Stamp |
| then |
| return Nat'Last; |
| end if; |
| |
| Split_Time_Stamp |
| (Old_Binder_Output_Time_Stamp, |
| Old_Y, Old_M, Old_D, Old_H, Old_Mi, Old_S); |
| |
| Split_Time_Stamp |
| (New_Binder_Output_Time_Stamp, |
| New_Y, New_M, New_D, New_H, New_Mi, New_S); |
| |
| Res := New_Mi - Old_Mi; |
| |
| -- 60 minutes in an hour |
| |
| Res := Res + 60 * (New_H - Old_H); |
| |
| -- 24 hours in a day |
| |
| Res := Res + 60 * 24 * (New_D - Old_D); |
| |
| -- Almost 31 days in a month |
| |
| Res := Res + 60 * 24 * |
| (31 * (New_M - Old_M) - Cumul (New_M) + Cumul (Old_M)); |
| |
| -- 365 days in a year |
| |
| Res := Res + 60 * 24 * 365 * (New_Y - Old_Y); |
| |
| return Res; |
| end Time_From_Last_Bind; |
| |
| --------------------------- |
| -- To_Canonical_Dir_Spec -- |
| --------------------------- |
| |
| function To_Canonical_Dir_Spec |
| (Host_Dir : String; |
| Prefix_Style : Boolean) |
| return String_Access |
| 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 directoy 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 : 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; |
| |
| ---------------- |
| -- Tree_Close -- |
| ---------------- |
| |
| procedure Tree_Close is |
| begin |
| pragma Assert (In_Compiler); |
| Tree_Write_Terminate; |
| Close (Output_FD); |
| end Tree_Close; |
| |
| ----------------- |
| -- Tree_Create -- |
| ----------------- |
| |
| procedure Tree_Create is |
| Dot_Index : Natural; |
| |
| begin |
| pragma Assert (In_Compiler); |
| Get_Name_String (Current_Main); |
| |
| -- If an object file has been specified, then the ALI file |
| -- will be in the same directory as the object file; |
| -- so, we put the tree file in this same directory, |
| -- even though no object file needs to be generated. |
| |
| if Output_Object_File_Name /= null then |
| Name_Len := Output_Object_File_Name'Length; |
| Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all; |
| end if; |
| |
| Dot_Index := 0; |
| for J in reverse 1 .. Name_Len loop |
| if Name_Buffer (J) = '.' then |
| Dot_Index := J; |
| exit; |
| end if; |
| end loop; |
| |
| -- Should be impossible to not have an extension |
| |
| pragma Assert (Dot_Index /= 0); |
| |
| -- Change exctension to adt |
| |
| Name_Buffer (Dot_Index + 1) := 'a'; |
| Name_Buffer (Dot_Index + 2) := 'd'; |
| Name_Buffer (Dot_Index + 3) := 't'; |
| Name_Buffer (Dot_Index + 4) := ASCII.NUL; |
| Name_Len := Dot_Index + 3; |
| Create_File_And_Check (Output_FD, Binary); |
| |
| Tree_Write_Initialize (Output_FD); |
| end Tree_Create; |
| |
| ---------------- |
| -- Write_Info -- |
| ---------------- |
| |
| procedure Write_Info (Info : String) is |
| begin |
| pragma Assert (In_Binder or In_Compiler); |
| Write_With_Check (Info'Address, Info'Length); |
| Write_With_Check (EOL'Address, 1); |
| end Write_Info; |
| |
| ----------------------- |
| -- Write_Binder_Info -- |
| ----------------------- |
| |
| procedure Write_Binder_Info (Info : String) renames Write_Info; |
| |
| ----------------------- |
| -- Write_Debug_Info -- |
| ----------------------- |
| |
| procedure Write_Debug_Info (Info : String) renames Write_Info; |
| |
| ------------------------ |
| -- Write_Library_Info -- |
| ------------------------ |
| |
| procedure Write_Library_Info (Info : String) renames Write_Info; |
| |
| ------------------------ |
| -- Write_Program_Name -- |
| ------------------------ |
| |
| procedure Write_Program_Name is |
| Save_Buffer : String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); |
| |
| 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; |
| |
| 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; |
| |
| end Osint; |