1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
29 with Gnatvsn; use Gnatvsn;
32 with Output; use Output;
33 with Sdefault; use Sdefault;
35 with Targparm; use Targparm;
37 with Unchecked_Conversion;
39 pragma Warnings (Off);
40 -- This package is used also by gnatcoll
41 with System.Case_Util; use System.Case_Util;
48 Running_Program : Program_Type := Unspecified;
49 -- comment required here ???
51 Program_Set : Boolean := False;
52 -- comment required here ???
54 Std_Prefix : String_Ptr;
55 -- Standard prefix, computed dynamically the first time Relocate_Path
56 -- is called, and cached for subsequent calls.
58 Empty : aliased String := "";
59 No_Dir : constant String_Ptr := Empty'Access;
60 -- Used in Locate_File as a fake directory when Name is already an
63 -------------------------------------
64 -- Use of Name_Find and Name_Enter --
65 -------------------------------------
67 -- This package creates a number of source, ALI and object file names
68 -- that are used to locate the actual file and for the purpose of message
69 -- construction. These names need not be accessible by Name_Find, and can
70 -- be therefore created by using routine Name_Enter. The files in question
71 -- are file names with a prefix directory (i.e., the files not in the
72 -- current directory). File names without a prefix directory are entered
73 -- with Name_Find because special values might be attached to the various
74 -- Info fields of the corresponding name table entry.
76 -----------------------
77 -- Local Subprograms --
78 -----------------------
80 function Append_Suffix_To_File_Name
81 (Name : File_Name_Type;
82 Suffix : String) return File_Name_Type;
83 -- Appends Suffix to Name and returns the new name
85 function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type;
86 -- Convert OS format time to GNAT format time stamp. If T is Invalid_Time,
87 -- then returns Empty_Time_Stamp.
89 function Executable_Prefix return String_Ptr;
90 -- Returns the name of the root directory where the executable is stored.
91 -- The executable must be located in a directory called "bin", or under
92 -- root/lib/gcc-lib/..., or under root/libexec/gcc/... For example, if
93 -- executable is stored in directory "/foo/bar/bin", this routine returns
94 -- "/foo/bar/". Return "" if location is not recognized as described above.
96 function Update_Path (Path : String_Ptr) return String_Ptr;
97 -- Update the specified path to replace the prefix with the location where
98 -- GNAT is installed. See the file prefix.c in GCC for details.
100 procedure Locate_File
105 Found : out File_Name_Type;
106 Attr : access File_Attributes);
107 -- See if the file N whose name is Name exists in directory Dir. Dir is an
108 -- index into the Lib_Search_Directories table if T = Library. Otherwise
109 -- if T = Source, Dir is an index into the Src_Search_Directories table.
110 -- Returns the File_Name_Type of the full file name if file found, or
111 -- No_File if not found.
113 -- On exit, Found is set to the file that was found, and Attr to a cache of
114 -- its attributes (at least those that have been computed so far). Reusing
115 -- the cache will save some system calls.
117 -- Attr is always reset in this call to Unknown_Attributes, even in case of
123 Found : out File_Name_Type;
124 Attr : access File_Attributes);
125 -- A version of Find_File that also returns a cache of the file attributes
128 procedure Smart_Find_File
131 Found : out File_Name_Type;
132 Attr : out File_Attributes);
133 -- A version of Smart_Find_File that also returns a cache of the file
134 -- attributes for later reuse
136 function C_String_Length (S : Address) return Integer;
137 -- Returns length of a C string (zero for a null address)
139 function To_Path_String_Access
140 (Path_Addr : Address;
141 Path_Len : Integer) return String_Access;
142 -- Converts a C String to an Ada String. Are we doing this to avoid withing
143 -- Interfaces.C.Strings ???
144 -- Caller must free result.
146 function Include_Dir_Default_Prefix return String_Access;
147 -- Same as exported version, except returns a String_Access
149 ------------------------------
150 -- Other Local Declarations --
151 ------------------------------
153 EOL : constant Character := ASCII.LF;
154 -- End of line character
156 Number_File_Names : Int := 0;
157 -- Number of file names found on command line and placed in File_Names
159 Look_In_Primary_Directory_For_Current_Main : Boolean := False;
160 -- When this variable is True, Find_File only looks in Primary_Directory
161 -- for the Current_Main file. This variable is always set to True for the
162 -- compiler. It is also True for gnatmake, when the source name given on
163 -- the command line has directory information.
165 Current_Full_Source_Name : File_Name_Type := No_File;
166 Current_Full_Source_Stamp : Time_Stamp_Type := Empty_Time_Stamp;
167 Current_Full_Lib_Name : File_Name_Type := No_File;
168 Current_Full_Lib_Stamp : Time_Stamp_Type := Empty_Time_Stamp;
169 Current_Full_Obj_Name : File_Name_Type := No_File;
170 Current_Full_Obj_Stamp : Time_Stamp_Type := Empty_Time_Stamp;
171 -- Respectively full name (with directory info) and time stamp of the
172 -- latest source, library and object files opened by Read_Source_File and
173 -- Read_Library_Info.
175 package File_Name_Chars is new Table.Table (
176 Table_Component_Type => Character,
177 Table_Index_Type => Int,
178 Table_Low_Bound => 1,
179 Table_Initial => Alloc.File_Name_Chars_Initial,
180 Table_Increment => Alloc.File_Name_Chars_Increment,
181 Table_Name => "File_Name_Chars");
182 -- Table to store text to be printed by Dump_Source_File_Names
184 The_Include_Dir_Default_Prefix : String_Access := null;
185 -- Value returned by Include_Dir_Default_Prefix. We don't initialize it
186 -- here, because that causes an elaboration cycle with Sdefault; we
187 -- initialize it lazily instead.
193 Primary_Directory : constant := 0;
194 -- This is index in the tables created below for the first directory to
195 -- search in for source or library information files. This is the directory
196 -- containing the latest main input file (a source file for the compiler or
197 -- a library file for the binder).
199 package Src_Search_Directories is new Table.Table (
200 Table_Component_Type => String_Ptr,
201 Table_Index_Type => Integer,
202 Table_Low_Bound => Primary_Directory,
204 Table_Increment => 100,
205 Table_Name => "Osint.Src_Search_Directories");
206 -- Table of names of directories in which to search for source (Compiler)
207 -- files. This table is filled in the order in which the directories are
208 -- to be searched, and then used in that order.
210 package Lib_Search_Directories is new Table.Table (
211 Table_Component_Type => String_Ptr,
212 Table_Index_Type => Integer,
213 Table_Low_Bound => Primary_Directory,
215 Table_Increment => 100,
216 Table_Name => "Osint.Lib_Search_Directories");
217 -- Table of names of directories in which to search for library (Binder)
218 -- files. This table is filled in the order in which the directories are
219 -- to be searched and then used in that order. The reason for having two
220 -- distinct tables is that we need them both in gnatmake.
222 ---------------------
223 -- File Hash Table --
224 ---------------------
226 -- The file hash table is provided to free the programmer from any
227 -- efficiency concern when retrieving full file names or time stamps of
228 -- source files. If the programmer calls Source_File_Data (Cache => True)
229 -- he is guaranteed that the price to retrieve the full name (i.e. with
230 -- directory info) or time stamp of the file will be payed only once, the
231 -- first time the full name is actually searched (or the first time the
232 -- time stamp is actually retrieved). This is achieved by employing a hash
233 -- table that stores as a key the File_Name_Type of the file and associates
234 -- to that File_Name_Type the full file name and time stamp of the file.
236 File_Cache_Enabled : Boolean := False;
237 -- Set to true if you want the enable the file data caching mechanism
239 type File_Hash_Num is range 0 .. 1020;
241 function File_Hash (F : File_Name_Type) return File_Hash_Num;
242 -- Compute hash index for use by Simple_HTable
244 type File_Info_Cache is record
245 File : File_Name_Type;
246 Attr : aliased File_Attributes;
249 No_File_Info_Cache : constant File_Info_Cache :=
250 (No_File, Unknown_Attributes);
252 package File_Name_Hash_Table is new GNAT.HTable.Simple_HTable (
253 Header_Num => File_Hash_Num,
254 Element => File_Info_Cache,
255 No_Element => No_File_Info_Cache,
256 Key => File_Name_Type,
260 function Smart_Find_File
262 T : File_Type) return File_Name_Type;
263 -- Exactly like Find_File except that if File_Cache_Enabled is True this
264 -- routine looks first in the hash table to see if the full name of the
265 -- file is already available.
267 function Smart_File_Stamp
269 T : File_Type) return Time_Stamp_Type;
270 -- Takes the same parameter as the routine above (N is a file name without
271 -- any prefix directory information) and behaves like File_Stamp except
272 -- that if File_Cache_Enabled is True this routine looks first in the hash
273 -- table to see if the file stamp of the file is already available.
275 -----------------------------
276 -- Add_Default_Search_Dirs --
277 -----------------------------
279 procedure Add_Default_Search_Dirs is
280 Search_Dir : String_Access;
281 Search_Path : String_Access;
282 Path_File_Name : String_Access;
284 procedure Add_Search_Dir
285 (Search_Dir : String;
286 Additional_Source_Dir : Boolean);
287 procedure Add_Search_Dir
288 (Search_Dir : String_Access;
289 Additional_Source_Dir : Boolean);
290 -- Add a source search dir or a library search dir, depending on the
291 -- value of Additional_Source_Dir.
293 procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean);
294 -- Open a path file and read the directory to search, one per line
296 function Get_Libraries_From_Registry return String_Ptr;
297 -- On Windows systems, get the list of installed standard libraries
298 -- from the registry key:
300 -- HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\
301 -- GNAT\Standard Libraries
302 -- Return an empty string on other systems.
304 -- Note that this is an undocumented legacy feature, and that it
305 -- works only when using the default runtime library (i.e. no --RTS=
306 -- command line switch).
312 procedure Add_Search_Dir
313 (Search_Dir : String;
314 Additional_Source_Dir : Boolean)
317 if Additional_Source_Dir then
318 Add_Src_Search_Dir (Search_Dir);
320 Add_Lib_Search_Dir (Search_Dir);
324 procedure Add_Search_Dir
325 (Search_Dir : String_Access;
326 Additional_Source_Dir : Boolean)
329 if Additional_Source_Dir then
330 Add_Src_Search_Dir (Search_Dir.all);
332 Add_Lib_Search_Dir (Search_Dir.all);
336 ------------------------
337 -- Get_Dirs_From_File --
338 ------------------------
340 procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean) is
341 File_FD : File_Descriptor;
342 Buffer : constant String := Path_File_Name.all & ASCII.NUL;
344 Actual_Len : Natural;
351 pragma Warnings (Off, Status);
352 -- For the call to Close where status is ignored
355 File_FD := Open_Read (Buffer'Address, Binary);
357 -- If we cannot open the file, we ignore it, we don't fail
359 if File_FD = Invalid_FD then
363 Len := Integer (File_Length (File_FD));
365 S := new String (1 .. Len);
367 -- Read the file. Note that the loop is not necessary since the
368 -- whole file is read at once except on VMS.
372 while Curr <= Len and then Actual_Len /= 0 loop
373 Actual_Len := Read (File_FD, S (Curr)'Address, Len);
374 Curr := Curr + Actual_Len;
377 -- We are done with the file, so we close it (ignore any error on
378 -- the close, since we have successfully read the file).
380 Close (File_FD, Status);
382 -- Now, we read line by line
386 while Curr < Len loop
389 if Ch = ASCII.CR or else Ch = ASCII.LF
390 or else Ch = ASCII.FF or else Ch = ASCII.VT
392 if First <= Curr then
393 Add_Search_Dir (S (First .. Curr), Additional_Source_Dir);
402 -- Last line is a special case, if the file does not end with
403 -- an end of line mark.
405 if First <= S'Last then
406 Add_Search_Dir (S (First .. S'Last), Additional_Source_Dir);
408 end Get_Dirs_From_File;
410 ---------------------------------
411 -- Get_Libraries_From_Registry --
412 ---------------------------------
414 function Get_Libraries_From_Registry return String_Ptr is
415 function C_Get_Libraries_From_Registry return Address;
416 pragma Import (C, C_Get_Libraries_From_Registry,
417 "__gnat_get_libraries_from_registry");
419 function Strlen (Str : Address) return Integer;
420 pragma Import (C, Strlen, "strlen");
422 procedure Strncpy (X : Address; Y : Address; Length : Integer);
423 pragma Import (C, Strncpy, "strncpy");
425 procedure C_Free (Str : Address);
426 pragma Import (C, C_Free, "free");
428 Result_Ptr : Address;
429 Result_Length : Integer;
430 Out_String : String_Ptr;
433 Result_Ptr := C_Get_Libraries_From_Registry;
434 Result_Length := Strlen (Result_Ptr);
436 Out_String := new String (1 .. Result_Length);
437 Strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
442 end Get_Libraries_From_Registry;
444 -- Start of processing for Add_Default_Search_Dirs
447 -- After the locations specified on the command line, the next places
448 -- to look for files are the directories specified by the appropriate
449 -- environment variable. Get this value, extract the directory names
450 -- and store in the tables.
452 -- Check for eventual project path file env vars
454 Path_File_Name := Getenv (Project_Include_Path_File);
456 if Path_File_Name'Length > 0 then
457 Get_Dirs_From_File (Additional_Source_Dir => True);
460 Path_File_Name := Getenv (Project_Objects_Path_File);
462 if Path_File_Name'Length > 0 then
463 Get_Dirs_From_File (Additional_Source_Dir => False);
466 -- On VMS, don't expand the logical name (e.g. environment variable),
467 -- just put it into Unix (e.g. canonical) format. System services
468 -- will handle the expansion as part of the file processing.
470 for Additional_Source_Dir in False .. True loop
471 if Additional_Source_Dir then
472 Search_Path := Getenv (Ada_Include_Path);
474 if Search_Path'Length > 0 then
475 if Hostparm.OpenVMS then
476 Search_Path := To_Canonical_Path_Spec ("ADA_INCLUDE_PATH:");
478 Search_Path := To_Canonical_Path_Spec (Search_Path.all);
483 Search_Path := Getenv (Ada_Objects_Path);
485 if Search_Path'Length > 0 then
486 if Hostparm.OpenVMS then
487 Search_Path := To_Canonical_Path_Spec ("ADA_OBJECTS_PATH:");
489 Search_Path := To_Canonical_Path_Spec (Search_Path.all);
494 Get_Next_Dir_In_Path_Init (Search_Path);
496 Search_Dir := Get_Next_Dir_In_Path (Search_Path);
497 exit when Search_Dir = null;
498 Add_Search_Dir (Search_Dir, Additional_Source_Dir);
502 -- For the compiler, if --RTS= was specified, add the runtime
505 if RTS_Src_Path_Name /= null
506 and then RTS_Lib_Path_Name /= null
508 Add_Search_Dirs (RTS_Src_Path_Name, Include);
509 Add_Search_Dirs (RTS_Lib_Path_Name, Objects);
512 if not Opt.No_Stdinc then
514 -- For WIN32 systems, look for any system libraries defined in
515 -- the registry. These are added to both source and object
518 Search_Path := String_Access (Get_Libraries_From_Registry);
520 Get_Next_Dir_In_Path_Init (Search_Path);
522 Search_Dir := Get_Next_Dir_In_Path (Search_Path);
523 exit when Search_Dir = null;
524 Add_Search_Dir (Search_Dir, False);
525 Add_Search_Dir (Search_Dir, True);
528 -- The last place to look are the defaults
531 Read_Default_Search_Dirs
532 (String_Access (Update_Path (Search_Dir_Prefix)),
534 String_Access (Update_Path (Include_Dir_Default_Name)));
536 Get_Next_Dir_In_Path_Init (Search_Path);
538 Search_Dir := Get_Next_Dir_In_Path (Search_Path);
539 exit when Search_Dir = null;
540 Add_Search_Dir (Search_Dir, True);
544 -- Even when -nostdlib is used, we still want to have visibility on
545 -- the run-time object directory, as it is used by gnatbind to find
546 -- the run-time ALI files in "real" ZFP set up.
548 if not Opt.RTS_Switch then
550 Read_Default_Search_Dirs
551 (String_Access (Update_Path (Search_Dir_Prefix)),
553 String_Access (Update_Path (Object_Dir_Default_Name)));
555 Get_Next_Dir_In_Path_Init (Search_Path);
557 Search_Dir := Get_Next_Dir_In_Path (Search_Path);
558 exit when Search_Dir = null;
559 Add_Search_Dir (Search_Dir, False);
563 end Add_Default_Search_Dirs;
569 procedure Add_File (File_Name : String; Index : Int := No_Index) is
571 Number_File_Names := Number_File_Names + 1;
573 -- As Add_File may be called for mains specified inside a project file,
574 -- File_Names may be too short and needs to be extended.
576 if Number_File_Names > File_Names'Last then
577 File_Names := new File_Name_Array'(File_Names.all & File_Names.all);
579 new File_Index_Array'(File_Indexes.all & File_Indexes.all);
582 File_Names (Number_File_Names) := new String'(File_Name);
583 File_Indexes (Number_File_Names) := Index;
586 ------------------------
587 -- Add_Lib_Search_Dir --
588 ------------------------
590 procedure Add_Lib_Search_Dir (Dir : String) is
592 if Dir'Length = 0 then
593 Fail ("missing library directory name");
597 Norm : String_Ptr := Normalize_Directory_Name (Dir);
600 -- Do nothing if the directory is already in the list. This saves
601 -- system calls and avoid unneeded work
603 for D in Lib_Search_Directories.First ..
604 Lib_Search_Directories.Last
606 if Lib_Search_Directories.Table (D).all = Norm.all then
612 Lib_Search_Directories.Increment_Last;
613 Lib_Search_Directories.Table (Lib_Search_Directories.Last) := Norm;
615 end Add_Lib_Search_Dir;
617 ---------------------
618 -- Add_Search_Dirs --
619 ---------------------
621 procedure Add_Search_Dirs
622 (Search_Path : String_Ptr;
623 Path_Type : Search_File_Type)
625 Current_Search_Path : String_Access;
628 Get_Next_Dir_In_Path_Init (String_Access (Search_Path));
630 Current_Search_Path :=
631 Get_Next_Dir_In_Path (String_Access (Search_Path));
632 exit when Current_Search_Path = null;
634 if Path_Type = Include then
635 Add_Src_Search_Dir (Current_Search_Path.all);
637 Add_Lib_Search_Dir (Current_Search_Path.all);
642 ------------------------
643 -- Add_Src_Search_Dir --
644 ------------------------
646 procedure Add_Src_Search_Dir (Dir : String) is
648 if Dir'Length = 0 then
649 Fail ("missing source directory name");
652 Src_Search_Directories.Increment_Last;
653 Src_Search_Directories.Table (Src_Search_Directories.Last) :=
654 Normalize_Directory_Name (Dir);
655 end Add_Src_Search_Dir;
657 --------------------------------
658 -- Append_Suffix_To_File_Name --
659 --------------------------------
661 function Append_Suffix_To_File_Name
662 (Name : File_Name_Type;
663 Suffix : String) return File_Name_Type
666 Get_Name_String (Name);
667 Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
668 Name_Len := Name_Len + Suffix'Length;
670 end Append_Suffix_To_File_Name;
672 ---------------------
673 -- C_String_Length --
674 ---------------------
676 function C_String_Length (S : Address) return Integer is
677 function Strlen (S : Address) return Integer;
678 pragma Import (C, Strlen, "strlen");
680 if S = Null_Address then
687 ------------------------------
688 -- Canonical_Case_File_Name --
689 ------------------------------
691 procedure Canonical_Case_File_Name (S : in out String) is
693 if not File_Names_Case_Sensitive then
696 end Canonical_Case_File_Name;
698 ---------------------------------
699 -- Canonical_Case_Env_Var_Name --
700 ---------------------------------
702 procedure Canonical_Case_Env_Var_Name (S : in out String) is
704 if not Env_Vars_Case_Sensitive then
707 end Canonical_Case_Env_Var_Name;
709 ---------------------------
710 -- Create_File_And_Check --
711 ---------------------------
713 procedure Create_File_And_Check
714 (Fdesc : out File_Descriptor;
718 Output_File_Name := Name_Enter;
719 Fdesc := Create_File (Name_Buffer'Address, Fmode);
721 if Fdesc = Invalid_FD then
722 Fail ("Cannot create: " & Name_Buffer (1 .. Name_Len));
724 end Create_File_And_Check;
726 ------------------------
727 -- Current_File_Index --
728 ------------------------
730 function Current_File_Index return Int is
732 return File_Indexes (Current_File_Name_Index);
733 end Current_File_Index;
735 --------------------------------
736 -- Current_Library_File_Stamp --
737 --------------------------------
739 function Current_Library_File_Stamp return Time_Stamp_Type is
741 return Current_Full_Lib_Stamp;
742 end Current_Library_File_Stamp;
744 -------------------------------
745 -- Current_Object_File_Stamp --
746 -------------------------------
748 function Current_Object_File_Stamp return Time_Stamp_Type is
750 return Current_Full_Obj_Stamp;
751 end Current_Object_File_Stamp;
753 -------------------------------
754 -- Current_Source_File_Stamp --
755 -------------------------------
757 function Current_Source_File_Stamp return Time_Stamp_Type is
759 return Current_Full_Source_Stamp;
760 end Current_Source_File_Stamp;
762 ----------------------------
763 -- Dir_In_Obj_Search_Path --
764 ----------------------------
766 function Dir_In_Obj_Search_Path (Position : Natural) return String_Ptr is
768 if Opt.Look_In_Primary_Dir then
770 Lib_Search_Directories.Table (Primary_Directory + Position - 1);
772 return Lib_Search_Directories.Table (Primary_Directory + Position);
774 end Dir_In_Obj_Search_Path;
776 ----------------------------
777 -- Dir_In_Src_Search_Path --
778 ----------------------------
780 function Dir_In_Src_Search_Path (Position : Natural) return String_Ptr is
782 if Opt.Look_In_Primary_Dir then
784 Src_Search_Directories.Table (Primary_Directory + Position - 1);
786 return Src_Search_Directories.Table (Primary_Directory + Position);
788 end Dir_In_Src_Search_Path;
790 ----------------------------
791 -- Dump_Source_File_Names --
792 ----------------------------
794 procedure Dump_Source_File_Names is
795 subtype Rng is Int range File_Name_Chars.First .. File_Name_Chars.Last;
797 Write_Str (String (File_Name_Chars.Table (Rng)));
798 end Dump_Source_File_Names;
800 ---------------------
801 -- Executable_Name --
802 ---------------------
804 function Executable_Name
805 (Name : File_Name_Type;
806 Only_If_No_Suffix : Boolean := False) return File_Name_Type
808 Exec_Suffix : String_Access;
809 Add_Suffix : Boolean;
812 if Name = No_File then
816 if Executable_Extension_On_Target = No_Name then
817 Exec_Suffix := Get_Target_Executable_Suffix;
819 Get_Name_String (Executable_Extension_On_Target);
820 Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len));
823 if Exec_Suffix'Length /= 0 then
824 Get_Name_String (Name);
827 if Only_If_No_Suffix then
828 for J in reverse 1 .. Name_Len loop
829 if Name_Buffer (J) = '.' then
833 elsif Name_Buffer (J) = '/' or else
834 Name_Buffer (J) = Directory_Separator
843 Buffer : String := Name_Buffer (1 .. Name_Len);
846 -- Get the file name in canonical case to accept as is names
847 -- ending with ".EXE" on VMS and Windows.
849 Canonical_Case_File_Name (Buffer);
851 -- If Executable does not end with the executable suffix, add
854 if Buffer'Length <= Exec_Suffix'Length
856 Buffer (Buffer'Last - Exec_Suffix'Length + 1 .. Buffer'Last)
860 (Name_Len + 1 .. Name_Len + Exec_Suffix'Length) :=
862 Name_Len := Name_Len + Exec_Suffix'Length;
874 function Executable_Name
876 Only_If_No_Suffix : Boolean := False) return String
878 Exec_Suffix : String_Access;
879 Add_Suffix : Boolean;
880 Canonical_Name : String := Name;
883 if Executable_Extension_On_Target = No_Name then
884 Exec_Suffix := Get_Target_Executable_Suffix;
886 Get_Name_String (Executable_Extension_On_Target);
887 Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len));
890 if Exec_Suffix'Length = 0 then
896 Suffix : constant String := Exec_Suffix.all;
900 Canonical_Case_File_Name (Canonical_Name);
903 if Only_If_No_Suffix then
904 for J in reverse Canonical_Name'Range loop
905 if Canonical_Name (J) = '.' then
909 elsif Canonical_Name (J) = '/' or else
910 Canonical_Name (J) = Directory_Separator
917 if Add_Suffix and then
918 (Canonical_Name'Length <= Suffix'Length
919 or else Canonical_Name (Canonical_Name'Last - Suffix'Length + 1
920 .. Canonical_Name'Last) /= Suffix)
923 Result : String (1 .. Name'Length + Suffix'Length);
925 Result (1 .. Name'Length) := Name;
926 Result (Name'Length + 1 .. Result'Last) := Suffix;
936 -----------------------
937 -- Executable_Prefix --
938 -----------------------
940 function Executable_Prefix return String_Ptr is
942 function Get_Install_Dir (Exec : String) return String_Ptr;
943 -- S is the executable name preceded by the absolute or relative
944 -- path, e.g. "c:\usr\bin\gcc.exe" or "..\bin\gcc".
946 ---------------------
947 -- Get_Install_Dir --
948 ---------------------
950 function Get_Install_Dir (Exec : String) return String_Ptr is
951 Full_Path : constant String := Normalize_Pathname (Exec);
952 -- Use the full path, so that we find "lib" or "bin", even when
953 -- the tool has been invoked with a relative path, as in
954 -- "./gnatls -v" invoked in the GNAT bin directory.
957 for J in reverse Full_Path'Range loop
958 if Is_Directory_Separator (Full_Path (J)) then
959 if J < Full_Path'Last - 5 then
960 if (To_Lower (Full_Path (J + 1)) = 'l'
961 and then To_Lower (Full_Path (J + 2)) = 'i'
962 and then To_Lower (Full_Path (J + 3)) = 'b')
964 (To_Lower (Full_Path (J + 1)) = 'b'
965 and then To_Lower (Full_Path (J + 2)) = 'i'
966 and then To_Lower (Full_Path (J + 3)) = 'n')
968 return new String'(Full_Path (Full_Path'First .. J));
974 return new String'("");
977 -- Start of processing for Executable_Prefix
980 if Exec_Name = null then
981 Exec_Name := new String (1 .. Len_Arg (0));
982 Osint.Fill_Arg (Exec_Name (1)'Address, 0);
985 -- First determine if a path prefix was placed in front of the
988 for J in reverse Exec_Name'Range loop
989 if Is_Directory_Separator (Exec_Name (J)) then
990 return Get_Install_Dir (Exec_Name.all);
994 -- If we come here, the user has typed the executable name with no
997 return Get_Install_Dir (Locate_Exec_On_Path (Exec_Name.all).all);
998 end Executable_Prefix;
1004 procedure Exit_Program (Exit_Code : Exit_Code_Type) is
1006 -- The program will exit with the following status:
1008 -- 0 if the object file has been generated (with or without warnings)
1009 -- 1 if recompilation was not needed (smart recompilation)
1010 -- 2 if gnat1 has been killed by a signal (detected by GCC)
1011 -- 4 for a fatal error
1012 -- 5 if there were errors
1013 -- 6 if no code has been generated (spec)
1015 -- Note that exit code 3 is not used and must not be used as this is
1016 -- the code returned by a program aborted via C abort() routine on
1017 -- Windows. GCC checks for that case and thinks that the child process
1018 -- has been aborted. This code (exit code 3) used to be the code used
1019 -- for E_No_Code, but E_No_Code was changed to 6 for this reason.
1022 when E_Success => OS_Exit (0);
1023 when E_Warnings => OS_Exit (0);
1024 when E_No_Compile => OS_Exit (1);
1025 when E_Fatal => OS_Exit (4);
1026 when E_Errors => OS_Exit (5);
1027 when E_No_Code => OS_Exit (6);
1028 when E_Abort => OS_Abort;
1036 procedure Fail (S : String) is
1038 -- We use Output in case there is a special output set up.
1039 -- In this case Set_Standard_Error will have no immediate effect.
1042 Osint.Write_Program_Name;
1047 Exit_Program (E_Fatal);
1054 function File_Hash (F : File_Name_Type) return File_Hash_Num is
1056 return File_Hash_Num (Int (F) rem File_Hash_Num'Range_Length);
1063 function File_Length
1064 (Name : C_File_Name;
1065 Attr : access File_Attributes) return Long_Integer
1070 A : System.Address) return Long_Integer;
1071 pragma Import (C, Internal, "__gnat_file_length_attr");
1073 return Internal (-1, Name, Attr.all'Address);
1076 ---------------------
1077 -- File_Time_Stamp --
1078 ---------------------
1080 function File_Time_Stamp
1081 (Name : C_File_Name;
1082 Attr : access File_Attributes) return OS_Time
1084 function Internal (N : C_File_Name; A : System.Address) return OS_Time;
1085 pragma Import (C, Internal, "__gnat_file_time_name_attr");
1087 return Internal (Name, Attr.all'Address);
1088 end File_Time_Stamp;
1090 function File_Time_Stamp
1091 (Name : Path_Name_Type;
1092 Attr : access File_Attributes) return Time_Stamp_Type
1095 if Name = No_Path then
1096 return Empty_Time_Stamp;
1099 Get_Name_String (Name);
1100 Name_Buffer (Name_Len + 1) := ASCII.NUL;
1101 return OS_Time_To_GNAT_Time
1102 (File_Time_Stamp (Name_Buffer'Address, Attr));
1103 end File_Time_Stamp;
1109 function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type is
1111 if Name = No_File then
1112 return Empty_Time_Stamp;
1115 Get_Name_String (Name);
1117 -- File_Time_Stamp will always return Invalid_Time if the file does
1118 -- not exist, and OS_Time_To_GNAT_Time will convert this value to
1119 -- Empty_Time_Stamp. Therefore we do not need to first test whether
1120 -- the file actually exists, which saves a system call.
1122 return OS_Time_To_GNAT_Time
1123 (File_Time_Stamp (Name_Buffer (1 .. Name_Len)));
1126 function File_Stamp (Name : Path_Name_Type) return Time_Stamp_Type is
1128 return File_Stamp (File_Name_Type (Name));
1136 (N : File_Name_Type;
1137 T : File_Type) return File_Name_Type
1139 Attr : aliased File_Attributes;
1140 Found : File_Name_Type;
1142 Find_File (N, T, Found, Attr'Access);
1151 (N : File_Name_Type;
1153 Found : out File_Name_Type;
1154 Attr : access File_Attributes) is
1156 Get_Name_String (N);
1159 File_Name : String renames Name_Buffer (1 .. Name_Len);
1160 File : File_Name_Type := No_File;
1164 -- If we are looking for a config file, look only in the current
1165 -- directory, i.e. return input argument unchanged. Also look only in
1166 -- the current directory if we are looking for a .dg file (happens in
1170 or else (Debug_Generated_Code
1171 and then Name_Len > 3
1173 (Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg"
1175 (Hostparm.OpenVMS and then
1176 Name_Buffer (Name_Len - 2 .. Name_Len) = "_dg")))
1179 Attr.all := Unknown_Attributes;
1182 -- If we are trying to find the current main file just look in the
1183 -- directory where the user said it was.
1185 elsif Look_In_Primary_Directory_For_Current_Main
1186 and then Current_Main = N
1188 Locate_File (N, T, Primary_Directory, File_Name, Found, Attr);
1191 -- Otherwise do standard search for source file
1194 -- Check the mapping of this file name
1196 File := Mapped_Path_Name (N);
1198 -- If the file name is mapped to a path name, return the
1199 -- corresponding path name
1201 if File /= No_File then
1203 -- For locally removed file, Error_Name is returned; then
1204 -- return No_File, indicating the file is not a source.
1206 if File = Error_File_Name then
1212 Attr.all := Unknown_Attributes;
1216 -- First place to look is in the primary directory (i.e. the same
1217 -- directory as the source) unless this has been disabled with -I-
1219 if Opt.Look_In_Primary_Dir then
1220 Locate_File (N, T, Primary_Directory, File_Name, Found, Attr);
1222 if Found /= No_File then
1227 -- Finally look in directories specified with switches -I/-aI/-aO
1230 Last_Dir := Lib_Search_Directories.Last;
1232 Last_Dir := Src_Search_Directories.Last;
1235 for D in Primary_Directory + 1 .. Last_Dir loop
1236 Locate_File (N, T, D, File_Name, Found, Attr);
1238 if Found /= No_File then
1243 Attr.all := Unknown_Attributes;
1249 -----------------------
1250 -- Find_Program_Name --
1251 -----------------------
1253 procedure Find_Program_Name is
1254 Command_Name : String (1 .. Len_Arg (0));
1255 Cindex1 : Integer := Command_Name'First;
1256 Cindex2 : Integer := Command_Name'Last;
1259 Fill_Arg (Command_Name'Address, 0);
1261 if Command_Name = "" then
1266 -- The program name might be specified by a full path name. However,
1267 -- we don't want to print that all out in an error message, so the
1268 -- path might need to be stripped away.
1270 for J in reverse Cindex1 .. Cindex2 loop
1271 if Is_Directory_Separator (Command_Name (J)) then
1277 -- Command_Name(Cindex1 .. Cindex2) is now the equivalent of the
1278 -- POSIX command "basename argv[0]"
1280 -- Strip off any versioning information such as found on VMS.
1281 -- This would take the form of TOOL.exe followed by a ";" or "."
1282 -- and a sequence of one or more numbers.
1284 if Command_Name (Cindex2) in '0' .. '9' then
1285 for J in reverse Cindex1 .. Cindex2 loop
1286 if Command_Name (J) = '.' or else Command_Name (J) = ';' then
1291 exit when Command_Name (J) not in '0' .. '9';
1295 -- Strip off any executable extension (usually nothing or .exe)
1296 -- but formally reported by autoconf in the variable EXEEXT
1298 if Cindex2 - Cindex1 >= 4 then
1299 if To_Lower (Command_Name (Cindex2 - 3)) = '.'
1300 and then To_Lower (Command_Name (Cindex2 - 2)) = 'e'
1301 and then To_Lower (Command_Name (Cindex2 - 1)) = 'x'
1302 and then To_Lower (Command_Name (Cindex2)) = 'e'
1304 Cindex2 := Cindex2 - 4;
1308 Name_Len := Cindex2 - Cindex1 + 1;
1309 Name_Buffer (1 .. Name_Len) := Command_Name (Cindex1 .. Cindex2);
1310 end Find_Program_Name;
1312 ------------------------
1313 -- Full_Lib_File_Name --
1314 ------------------------
1316 procedure Full_Lib_File_Name
1317 (N : File_Name_Type;
1318 Lib_File : out File_Name_Type;
1319 Attr : out File_Attributes)
1321 A : aliased File_Attributes;
1323 -- ??? seems we could use Smart_Find_File here
1324 Find_File (N, Library, Lib_File, A'Access);
1326 end Full_Lib_File_Name;
1328 ------------------------
1329 -- Full_Lib_File_Name --
1330 ------------------------
1332 function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type is
1333 Attr : File_Attributes;
1334 File : File_Name_Type;
1336 Full_Lib_File_Name (N, File, Attr);
1338 end Full_Lib_File_Name;
1340 ----------------------------
1341 -- Full_Library_Info_Name --
1342 ----------------------------
1344 function Full_Library_Info_Name return File_Name_Type is
1346 return Current_Full_Lib_Name;
1347 end Full_Library_Info_Name;
1349 ---------------------------
1350 -- Full_Object_File_Name --
1351 ---------------------------
1353 function Full_Object_File_Name return File_Name_Type is
1355 return Current_Full_Obj_Name;
1356 end Full_Object_File_Name;
1358 ----------------------
1359 -- Full_Source_Name --
1360 ----------------------
1362 function Full_Source_Name return File_Name_Type is
1364 return Current_Full_Source_Name;
1365 end Full_Source_Name;
1367 ----------------------
1368 -- Full_Source_Name --
1369 ----------------------
1371 function Full_Source_Name (N : File_Name_Type) return File_Name_Type is
1373 return Smart_Find_File (N, Source);
1374 end Full_Source_Name;
1376 ----------------------
1377 -- Full_Source_Name --
1378 ----------------------
1380 procedure Full_Source_Name
1381 (N : File_Name_Type;
1382 Full_File : out File_Name_Type;
1383 Attr : access File_Attributes) is
1385 Smart_Find_File (N, Source, Full_File, Attr.all);
1386 end Full_Source_Name;
1392 function Get_Directory (Name : File_Name_Type) return File_Name_Type is
1394 Get_Name_String (Name);
1396 for J in reverse 1 .. Name_Len loop
1397 if Is_Directory_Separator (Name_Buffer (J)) then
1403 Name_Len := Hostparm.Normalized_CWD'Length;
1404 Name_Buffer (1 .. Name_Len) := Hostparm.Normalized_CWD;
1408 --------------------------
1409 -- Get_Next_Dir_In_Path --
1410 --------------------------
1412 Search_Path_Pos : Integer;
1413 -- Keeps track of current position in search path. Initialized by the
1414 -- call to Get_Next_Dir_In_Path_Init, updated by Get_Next_Dir_In_Path.
1416 function Get_Next_Dir_In_Path
1417 (Search_Path : String_Access) return String_Access
1419 Lower_Bound : Positive := Search_Path_Pos;
1420 Upper_Bound : Positive;
1424 while Lower_Bound <= Search_Path'Last
1425 and then Search_Path.all (Lower_Bound) = Path_Separator
1427 Lower_Bound := Lower_Bound + 1;
1430 exit when Lower_Bound > Search_Path'Last;
1432 Upper_Bound := Lower_Bound;
1433 while Upper_Bound <= Search_Path'Last
1434 and then Search_Path.all (Upper_Bound) /= Path_Separator
1436 Upper_Bound := Upper_Bound + 1;
1439 Search_Path_Pos := Upper_Bound;
1440 return new String'(Search_Path.all (Lower_Bound .. Upper_Bound - 1));
1444 end Get_Next_Dir_In_Path;
1446 -------------------------------
1447 -- Get_Next_Dir_In_Path_Init --
1448 -------------------------------
1450 procedure Get_Next_Dir_In_Path_Init (Search_Path : String_Access) is
1452 Search_Path_Pos := Search_Path'First;
1453 end Get_Next_Dir_In_Path_Init;
1455 --------------------------------------
1456 -- Get_Primary_Src_Search_Directory --
1457 --------------------------------------
1459 function Get_Primary_Src_Search_Directory return String_Ptr is
1461 return Src_Search_Directories.Table (Primary_Directory);
1462 end Get_Primary_Src_Search_Directory;
1464 ------------------------
1465 -- Get_RTS_Search_Dir --
1466 ------------------------
1468 function Get_RTS_Search_Dir
1469 (Search_Dir : String;
1470 File_Type : Search_File_Type) return String_Ptr
1472 procedure Get_Current_Dir
1473 (Dir : System.Address;
1474 Length : System.Address);
1475 pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir");
1478 pragma Import (C, Max_Path, "__gnat_max_path_len");
1479 -- Maximum length of a path name
1481 Current_Dir : String_Ptr;
1482 Default_Search_Dir : String_Access;
1483 Default_Suffix_Dir : String_Access;
1484 Local_Search_Dir : String_Access;
1485 Norm_Search_Dir : String_Access;
1486 Result_Search_Dir : String_Access;
1487 Search_File : String_Access;
1488 Temp_String : String_Ptr;
1491 -- Add a directory separator at the end of the directory if necessary
1492 -- so that we can directly append a file to the directory
1494 if Search_Dir (Search_Dir'Last) /= Directory_Separator then
1496 new String'(Search_Dir & String'(1 => Directory_Separator));
1498 Local_Search_Dir := new String'(Search_Dir);
1501 if File_Type = Include then
1502 Search_File := Include_Search_File;
1503 Default_Suffix_Dir := new String'("adainclude");
1505 Search_File := Objects_Search_File;
1506 Default_Suffix_Dir := new String'("adalib");
1509 Norm_Search_Dir := To_Canonical_Path_Spec (Local_Search_Dir.all);
1511 if Is_Absolute_Path (Norm_Search_Dir.all) then
1513 -- We first verify if there is a directory Include_Search_Dir
1514 -- containing default search directories
1516 Result_Search_Dir :=
1517 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1518 Default_Search_Dir :=
1519 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1520 Free (Norm_Search_Dir);
1522 if Result_Search_Dir /= null then
1523 return String_Ptr (Result_Search_Dir);
1524 elsif Is_Directory (Default_Search_Dir.all) then
1525 return String_Ptr (Default_Search_Dir);
1530 -- Search in the current directory
1533 -- Get the current directory
1536 Buffer : String (1 .. Max_Path + 2);
1537 Path_Len : Natural := Max_Path;
1540 Get_Current_Dir (Buffer'Address, Path_Len'Address);
1542 if Buffer (Path_Len) /= Directory_Separator then
1543 Path_Len := Path_Len + 1;
1544 Buffer (Path_Len) := Directory_Separator;
1547 Current_Dir := new String'(Buffer (1 .. Path_Len));
1551 new String'(Current_Dir.all & Local_Search_Dir.all);
1553 Result_Search_Dir :=
1554 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1556 Default_Search_Dir :=
1557 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1559 Free (Norm_Search_Dir);
1561 if Result_Search_Dir /= null then
1562 return String_Ptr (Result_Search_Dir);
1564 elsif Is_Directory (Default_Search_Dir.all) then
1565 return String_Ptr (Default_Search_Dir);
1568 -- Search in Search_Dir_Prefix/Search_Dir
1572 (Update_Path (Search_Dir_Prefix).all & Local_Search_Dir.all);
1574 Result_Search_Dir :=
1575 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1577 Default_Search_Dir :=
1578 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1580 Free (Norm_Search_Dir);
1582 if Result_Search_Dir /= null then
1583 return String_Ptr (Result_Search_Dir);
1585 elsif Is_Directory (Default_Search_Dir.all) then
1586 return String_Ptr (Default_Search_Dir);
1589 -- We finally search in Search_Dir_Prefix/rts-Search_Dir
1592 new String'(Update_Path (Search_Dir_Prefix).all & "rts-");
1595 new String'(Temp_String.all & Local_Search_Dir.all);
1597 Result_Search_Dir :=
1598 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1600 Default_Search_Dir :=
1601 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1602 Free (Norm_Search_Dir);
1604 if Result_Search_Dir /= null then
1605 return String_Ptr (Result_Search_Dir);
1607 elsif Is_Directory (Default_Search_Dir.all) then
1608 return String_Ptr (Default_Search_Dir);
1616 end Get_RTS_Search_Dir;
1618 --------------------------------
1619 -- Include_Dir_Default_Prefix --
1620 --------------------------------
1622 function Include_Dir_Default_Prefix return String_Access is
1624 if The_Include_Dir_Default_Prefix = null then
1625 The_Include_Dir_Default_Prefix :=
1626 String_Access (Update_Path (Include_Dir_Default_Name));
1629 return The_Include_Dir_Default_Prefix;
1630 end Include_Dir_Default_Prefix;
1632 function Include_Dir_Default_Prefix return String is
1634 return Include_Dir_Default_Prefix.all;
1635 end Include_Dir_Default_Prefix;
1641 procedure Initialize is
1643 Number_File_Names := 0;
1644 Current_File_Name_Index := 0;
1646 Src_Search_Directories.Init;
1647 Lib_Search_Directories.Init;
1649 -- Start off by setting all suppress options to False, these will
1650 -- be reset later (turning some on if -gnato is not specified, and
1651 -- turning all of them on if -gnatp is specified).
1653 Suppress_Options := (others => False);
1655 -- Reserve the first slot in the search paths table. This is the
1656 -- directory of the main source file or main library file and is filled
1657 -- in by each call to Next_Main_Source/Next_Main_Lib_File with the
1658 -- directory specified for this main source or library file. This is the
1659 -- directory which is searched first by default. This default search is
1660 -- inhibited by the option -I- for both source and library files.
1662 Src_Search_Directories.Set_Last (Primary_Directory);
1663 Src_Search_Directories.Table (Primary_Directory) := new String'("");
1665 Lib_Search_Directories.Set_Last (Primary_Directory);
1666 Lib_Search_Directories.Table (Primary_Directory) := new String'("");
1673 function Is_Directory
1674 (Name : C_File_Name; Attr : access File_Attributes) return Boolean
1676 function Internal (N : C_File_Name; A : System.Address) return Integer;
1677 pragma Import (C, Internal, "__gnat_is_directory_attr");
1679 return Internal (Name, Attr.all'Address) /= 0;
1682 ----------------------------
1683 -- Is_Directory_Separator --
1684 ----------------------------
1686 function Is_Directory_Separator (C : Character) return Boolean is
1688 -- In addition to the default directory_separator allow the '/' to
1689 -- act as separator since this is allowed in MS-DOS, Windows 95/NT,
1690 -- and OS2 ports. On VMS, the situation is more complicated because
1691 -- there are two characters to check for.
1694 C = Directory_Separator
1696 or else (Hostparm.OpenVMS
1697 and then (C = ']' or else C = ':'));
1698 end Is_Directory_Separator;
1700 -------------------------
1701 -- Is_Readonly_Library --
1702 -------------------------
1704 function Is_Readonly_Library (File : File_Name_Type) return Boolean is
1706 Get_Name_String (File);
1708 pragma Assert (Name_Buffer (Name_Len - 3 .. Name_Len) = ".ali");
1710 return not Is_Writable_File (Name_Buffer (1 .. Name_Len));
1711 end Is_Readonly_Library;
1713 ------------------------
1714 -- Is_Executable_File --
1715 ------------------------
1717 function Is_Executable_File
1718 (Name : C_File_Name; Attr : access File_Attributes) return Boolean
1720 function Internal (N : C_File_Name; A : System.Address) return Integer;
1721 pragma Import (C, Internal, "__gnat_is_executable_file_attr");
1723 return Internal (Name, Attr.all'Address) /= 0;
1724 end Is_Executable_File;
1726 ----------------------
1727 -- Is_Readable_File --
1728 ----------------------
1730 function Is_Readable_File
1731 (Name : C_File_Name; Attr : access File_Attributes) return Boolean
1733 function Internal (N : C_File_Name; A : System.Address) return Integer;
1734 pragma Import (C, Internal, "__gnat_is_readable_file_attr");
1736 return Internal (Name, Attr.all'Address) /= 0;
1737 end Is_Readable_File;
1739 ---------------------
1740 -- Is_Regular_File --
1741 ---------------------
1743 function Is_Regular_File
1744 (Name : C_File_Name; Attr : access File_Attributes) return Boolean
1746 function Internal (N : C_File_Name; A : System.Address) return Integer;
1747 pragma Import (C, Internal, "__gnat_is_regular_file_attr");
1749 return Internal (Name, Attr.all'Address) /= 0;
1750 end Is_Regular_File;
1752 ----------------------
1753 -- Is_Symbolic_Link --
1754 ----------------------
1756 function Is_Symbolic_Link
1757 (Name : C_File_Name; Attr : access File_Attributes) return Boolean
1759 function Internal (N : C_File_Name; A : System.Address) return Integer;
1760 pragma Import (C, Internal, "__gnat_is_symbolic_link_attr");
1762 return Internal (Name, Attr.all'Address) /= 0;
1763 end Is_Symbolic_Link;
1765 ----------------------
1766 -- Is_Writable_File --
1767 ----------------------
1769 function Is_Writable_File
1770 (Name : C_File_Name; Attr : access File_Attributes) return Boolean
1772 function Internal (N : C_File_Name; A : System.Address) return Integer;
1773 pragma Import (C, Internal, "__gnat_is_writable_file_attr");
1775 return Internal (Name, Attr.all'Address) /= 0;
1776 end Is_Writable_File;
1782 function Lib_File_Name
1783 (Source_File : File_Name_Type;
1784 Munit_Index : Nat := 0) return File_Name_Type
1787 Get_Name_String (Source_File);
1789 for J in reverse 2 .. Name_Len loop
1790 if Name_Buffer (J) = '.' then
1796 if Munit_Index /= 0 then
1797 Add_Char_To_Name_Buffer (Multi_Unit_Index_Character);
1798 Add_Nat_To_Name_Buffer (Munit_Index);
1801 Add_Char_To_Name_Buffer ('.');
1802 Add_Str_To_Name_Buffer (ALI_Suffix.all);
1810 procedure Locate_File
1811 (N : File_Name_Type;
1815 Found : out File_Name_Type;
1816 Attr : access File_Attributes)
1818 Dir_Name : String_Ptr;
1821 -- If Name is already an absolute path, do not look for a directory
1823 if Is_Absolute_Path (Name) then
1826 elsif T = Library then
1827 Dir_Name := Lib_Search_Directories.Table (Dir);
1830 pragma Assert (T /= Config);
1831 Dir_Name := Src_Search_Directories.Table (Dir);
1835 Full_Name : String (1 .. Dir_Name'Length + Name'Length + 1);
1838 Full_Name (1 .. Dir_Name'Length) := Dir_Name.all;
1839 Full_Name (Dir_Name'Length + 1 .. Full_Name'Last - 1) := Name;
1840 Full_Name (Full_Name'Last) := ASCII.NUL;
1842 Attr.all := Unknown_Attributes;
1844 if not Is_Regular_File (Full_Name'Address, Attr) then
1848 -- If the file is in the current directory then return N itself
1850 if Dir_Name'Length = 0 then
1853 Name_Len := Full_Name'Length - 1;
1854 Name_Buffer (1 .. Name_Len) :=
1855 Full_Name (1 .. Full_Name'Last - 1);
1856 Found := Name_Find; -- ??? Was Name_Enter, no obvious reason
1862 -------------------------------
1863 -- Matching_Full_Source_Name --
1864 -------------------------------
1866 function Matching_Full_Source_Name
1867 (N : File_Name_Type;
1868 T : Time_Stamp_Type) return File_Name_Type
1871 Get_Name_String (N);
1874 File_Name : constant String := Name_Buffer (1 .. Name_Len);
1875 File : File_Name_Type := No_File;
1876 Attr : aliased File_Attributes;
1880 if Opt.Look_In_Primary_Dir then
1882 (N, Source, Primary_Directory, File_Name, File, Attr'Access);
1884 if File /= No_File and then T = File_Stamp (N) then
1889 Last_Dir := Src_Search_Directories.Last;
1891 for D in Primary_Directory + 1 .. Last_Dir loop
1892 Locate_File (N, Source, D, File_Name, File, Attr'Access);
1894 if File /= No_File and then T = File_Stamp (File) then
1901 end Matching_Full_Source_Name;
1907 function More_Files return Boolean is
1909 return (Current_File_Name_Index < Number_File_Names);
1912 -------------------------------
1913 -- Nb_Dir_In_Obj_Search_Path --
1914 -------------------------------
1916 function Nb_Dir_In_Obj_Search_Path return Natural is
1918 if Opt.Look_In_Primary_Dir then
1919 return Lib_Search_Directories.Last - Primary_Directory + 1;
1921 return Lib_Search_Directories.Last - Primary_Directory;
1923 end Nb_Dir_In_Obj_Search_Path;
1925 -------------------------------
1926 -- Nb_Dir_In_Src_Search_Path --
1927 -------------------------------
1929 function Nb_Dir_In_Src_Search_Path return Natural is
1931 if Opt.Look_In_Primary_Dir then
1932 return Src_Search_Directories.Last - Primary_Directory + 1;
1934 return Src_Search_Directories.Last - Primary_Directory;
1936 end Nb_Dir_In_Src_Search_Path;
1938 --------------------
1939 -- Next_Main_File --
1940 --------------------
1942 function Next_Main_File return File_Name_Type is
1943 File_Name : String_Ptr;
1944 Dir_Name : String_Ptr;
1948 pragma Assert (More_Files);
1950 Current_File_Name_Index := Current_File_Name_Index + 1;
1952 -- Get the file and directory name
1954 File_Name := File_Names (Current_File_Name_Index);
1955 Fptr := File_Name'First;
1957 for J in reverse File_Name'Range loop
1958 if File_Name (J) = Directory_Separator
1959 or else File_Name (J) = '/'
1961 if J = File_Name'Last then
1962 Fail ("File name missing");
1970 -- Save name of directory in which main unit resides for use in
1971 -- locating other units
1973 Dir_Name := new String'(File_Name (File_Name'First .. Fptr - 1));
1975 case Running_Program is
1978 Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
1979 Look_In_Primary_Directory_For_Current_Main := True;
1982 Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
1984 if Fptr > File_Name'First then
1985 Look_In_Primary_Directory_For_Current_Main := True;
1988 when Binder | Gnatls =>
1989 Dir_Name := Normalize_Directory_Name (Dir_Name.all);
1990 Lib_Search_Directories.Table (Primary_Directory) := Dir_Name;
1996 Name_Len := File_Name'Last - Fptr + 1;
1997 Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last);
1998 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
1999 Current_Main := Name_Find;
2001 -- In the gnatmake case, the main file may have not have the
2002 -- extension. Try ".adb" first then ".ads"
2004 if Running_Program = Make then
2006 Orig_Main : constant File_Name_Type := Current_Main;
2009 if Strip_Suffix (Orig_Main) = Orig_Main then
2011 Append_Suffix_To_File_Name (Orig_Main, ".adb");
2013 if Full_Source_Name (Current_Main) = No_File then
2015 Append_Suffix_To_File_Name (Orig_Main, ".ads");
2017 if Full_Source_Name (Current_Main) = No_File then
2018 Current_Main := Orig_Main;
2025 return Current_Main;
2028 ------------------------------
2029 -- Normalize_Directory_Name --
2030 ------------------------------
2032 function Normalize_Directory_Name (Directory : String) return String_Ptr is
2034 function Is_Quoted (Path : String) return Boolean;
2035 pragma Inline (Is_Quoted);
2036 -- Returns true if Path is quoted (either double or single quotes)
2042 function Is_Quoted (Path : String) return Boolean is
2043 First : constant Character := Path (Path'First);
2044 Last : constant Character := Path (Path'Last);
2047 if (First = ''' and then Last = ''')
2049 (First = '"' and then Last = '"')
2057 Result : String_Ptr;
2059 -- Start of processing for Normalize_Directory_Name
2062 if Directory'Length = 0 then
2063 Result := new String'(Hostparm.Normalized_CWD);
2065 elsif Is_Directory_Separator (Directory (Directory'Last)) then
2066 Result := new String'(Directory);
2068 elsif Is_Quoted (Directory) then
2070 -- This is a quoted string, it certainly means that the directory
2071 -- contains some spaces for example. We can safely remove the quotes
2072 -- here as the OS_Lib.Normalize_Arguments will be called before any
2073 -- spawn routines. This ensure that quotes will be added when needed.
2075 Result := new String (1 .. Directory'Length - 1);
2076 Result (1 .. Directory'Length - 2) :=
2077 Directory (Directory'First + 1 .. Directory'Last - 1);
2078 Result (Result'Last) := Directory_Separator;
2081 Result := new String (1 .. Directory'Length + 1);
2082 Result (1 .. Directory'Length) := Directory;
2083 Result (Directory'Length + 1) := Directory_Separator;
2087 end Normalize_Directory_Name;
2089 ---------------------
2090 -- Number_Of_Files --
2091 ---------------------
2093 function Number_Of_Files return Int is
2095 return Number_File_Names;
2096 end Number_Of_Files;
2098 -------------------------------
2099 -- Object_Dir_Default_Prefix --
2100 -------------------------------
2102 function Object_Dir_Default_Prefix return String is
2103 Object_Dir : String_Access :=
2104 String_Access (Update_Path (Object_Dir_Default_Name));
2107 if Object_Dir = null then
2112 Result : constant String := Object_Dir.all;
2118 end Object_Dir_Default_Prefix;
2120 ----------------------
2121 -- Object_File_Name --
2122 ----------------------
2124 function Object_File_Name (N : File_Name_Type) return File_Name_Type is
2130 Get_Name_String (N);
2131 Name_Len := Name_Len - ALI_Suffix'Length - 1;
2133 for J in Target_Object_Suffix'Range loop
2134 Name_Len := Name_Len + 1;
2135 Name_Buffer (Name_Len) := Target_Object_Suffix (J);
2139 end Object_File_Name;
2141 -------------------------------
2142 -- OS_Exit_Through_Exception --
2143 -------------------------------
2145 procedure OS_Exit_Through_Exception (Status : Integer) is
2147 Current_Exit_Status := Status;
2148 raise Types.Terminate_Program;
2149 end OS_Exit_Through_Exception;
2151 --------------------------
2152 -- OS_Time_To_GNAT_Time --
2153 --------------------------
2155 function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type is
2156 GNAT_Time : Time_Stamp_Type;
2166 if T = Invalid_Time then
2167 return Empty_Time_Stamp;
2170 GM_Split (T, Y, Mo, D, H, Mn, S);
2176 Minutes => Nat (Mn),
2181 end OS_Time_To_GNAT_Time;
2187 function Program_Name (Nam : String; Prog : String) return String_Access is
2188 End_Of_Prefix : Natural := 0;
2189 Start_Of_Prefix : Positive := 1;
2190 Start_Of_Suffix : Positive;
2193 -- GNAAMP tool names require special treatment
2195 if AAMP_On_Target then
2197 -- The name "gcc" is mapped to "gnaamp" (the compiler driver)
2200 return new String'("gnaamp");
2202 -- Tool names starting with "gnat" are mapped by substituting the
2203 -- string "gnaamp" for "gnat" (for example, "gnatpp" => "gnaamppp").
2205 elsif Nam'Length >= 4
2206 and then Nam (Nam'First .. Nam'First + 3) = "gnat"
2208 return new String'("gnaamp" & Nam (Nam'First + 4 .. Nam'Last));
2210 -- No other mapping rules, so we continue and handle any other forms
2211 -- of tool names the same as on other targets.
2218 -- Get the name of the current program being executed
2222 Start_Of_Suffix := Name_Len + 1;
2224 -- Find the target prefix if any, for the cross compilation case.
2225 -- For instance in "powerpc-elf-gcc" the target prefix is
2227 -- Ditto for suffix, e.g. in "gcc-4.1", the suffix is "-4.1"
2229 for J in reverse 1 .. Name_Len loop
2230 if Name_Buffer (J) = '/'
2231 or else Name_Buffer (J) = Directory_Separator
2232 or else Name_Buffer (J) = ':'
2234 Start_Of_Prefix := J + 1;
2239 -- Find End_Of_Prefix
2241 for J in Start_Of_Prefix .. Name_Len - Prog'Length + 1 loop
2242 if Name_Buffer (J .. J + Prog'Length - 1) = Prog then
2243 End_Of_Prefix := J - 1;
2248 if End_Of_Prefix > 1 then
2249 Start_Of_Suffix := End_Of_Prefix + Prog'Length + 1;
2252 -- Create the new program name
2255 (Name_Buffer (Start_Of_Prefix .. End_Of_Prefix)
2257 & Name_Buffer (Start_Of_Suffix .. Name_Len));
2260 ------------------------------
2261 -- Read_Default_Search_Dirs --
2262 ------------------------------
2264 function Read_Default_Search_Dirs
2265 (Search_Dir_Prefix : String_Access;
2266 Search_File : String_Access;
2267 Search_Dir_Default_Name : String_Access) return String_Access
2269 Prefix_Len : constant Integer := Search_Dir_Prefix.all'Length;
2270 Buffer : String (1 .. Prefix_Len + Search_File.all'Length + 1);
2271 File_FD : File_Descriptor;
2272 S, S1 : String_Access;
2275 Actual_Len : Integer;
2278 Prev_Was_Separator : Boolean;
2279 Nb_Relative_Dir : Integer;
2281 function Is_Relative (S : String; K : Positive) return Boolean;
2282 pragma Inline (Is_Relative);
2283 -- Returns True if a relative directory specification is found
2284 -- in S at position K, False otherwise.
2290 function Is_Relative (S : String; K : Positive) return Boolean is
2292 return not Is_Absolute_Path (S (K .. S'Last));
2295 -- Start of processing for Read_Default_Search_Dirs
2298 -- Construct a C compatible character string buffer
2300 Buffer (1 .. Search_Dir_Prefix.all'Length)
2301 := Search_Dir_Prefix.all;
2302 Buffer (Search_Dir_Prefix.all'Length + 1 .. Buffer'Last - 1)
2304 Buffer (Buffer'Last) := ASCII.NUL;
2306 File_FD := Open_Read (Buffer'Address, Binary);
2307 if File_FD = Invalid_FD then
2308 return Search_Dir_Default_Name;
2311 Len := Integer (File_Length (File_FD));
2313 -- An extra character for a trailing Path_Separator is allocated
2315 S := new String (1 .. Len + 1);
2316 S (Len + 1) := Path_Separator;
2318 -- Read the file. Note that the loop is not necessary since the
2319 -- whole file is read at once except on VMS.
2323 while Actual_Len /= 0 loop
2324 Actual_Len := Read (File_FD, S (Curr)'Address, Len);
2325 Curr := Curr + Actual_Len;
2328 -- Process the file, dealing with path separators
2330 Prev_Was_Separator := True;
2331 Nb_Relative_Dir := 0;
2332 for J in 1 .. Len loop
2334 -- Treat any control character as a path separator. Note that we do
2335 -- not treat space as a path separator (we used to treat space as a
2336 -- path separator in an earlier version). That way space can appear
2337 -- as a legitimate character in a path name.
2339 -- Why do we treat all control characters as path separators???
2341 if S (J) in ASCII.NUL .. ASCII.US then
2342 S (J) := Path_Separator;
2345 -- Test for explicit path separator (or control char as above)
2347 if S (J) = Path_Separator then
2348 Prev_Was_Separator := True;
2350 -- If not path separator, register use of relative directory
2353 if Prev_Was_Separator and then Is_Relative (S.all, J) then
2354 Nb_Relative_Dir := Nb_Relative_Dir + 1;
2357 Prev_Was_Separator := False;
2361 if Nb_Relative_Dir = 0 then
2365 -- Add the Search_Dir_Prefix to all relative paths
2367 S1 := new String (1 .. S'Length + Nb_Relative_Dir * Prefix_Len);
2369 Prev_Was_Separator := True;
2370 for J in 1 .. Len + 1 loop
2371 if S (J) = Path_Separator then
2372 Prev_Was_Separator := True;
2375 if Prev_Was_Separator and then Is_Relative (S.all, J) then
2376 S1 (J1 .. J1 + Prefix_Len - 1) := Search_Dir_Prefix.all;
2377 J1 := J1 + Prefix_Len;
2380 Prev_Was_Separator := False;
2388 end Read_Default_Search_Dirs;
2390 -----------------------
2391 -- Read_Library_Info --
2392 -----------------------
2394 function Read_Library_Info
2395 (Lib_File : File_Name_Type;
2396 Fatal_Err : Boolean := False) return Text_Buffer_Ptr
2398 File : File_Name_Type;
2399 Attr : aliased File_Attributes;
2401 Find_File (Lib_File, Library, File, Attr'Access);
2402 return Read_Library_Info_From_Full
2403 (Full_Lib_File => File,
2404 Lib_File_Attr => Attr'Access,
2405 Fatal_Err => Fatal_Err);
2406 end Read_Library_Info;
2408 ---------------------------------
2409 -- Read_Library_Info_From_Full --
2410 ---------------------------------
2412 function Read_Library_Info_From_Full
2413 (Full_Lib_File : File_Name_Type;
2414 Lib_File_Attr : access File_Attributes;
2415 Fatal_Err : Boolean := False) return Text_Buffer_Ptr
2417 Lib_FD : File_Descriptor;
2418 -- The file descriptor for the current library file. A negative value
2419 -- indicates failure to open the specified source file.
2422 -- Length of source file text (ALI). If it doesn't fit in an integer
2423 -- we're probably stuck anyway (>2 gigs of source seems a lot!)
2425 Text : Text_Buffer_Ptr;
2426 -- Allocated text buffer
2429 pragma Warnings (Off, Status);
2430 -- For the calls to Close
2433 Current_Full_Lib_Name := Full_Lib_File;
2434 Current_Full_Obj_Name := Object_File_Name (Current_Full_Lib_Name);
2436 if Current_Full_Lib_Name = No_File then
2438 Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
2440 Current_Full_Obj_Stamp := Empty_Time_Stamp;
2445 Get_Name_String (Current_Full_Lib_Name);
2446 Name_Buffer (Name_Len + 1) := ASCII.NUL;
2448 -- Open the library FD, note that we open in binary mode, because as
2449 -- documented in the spec, the caller is expected to handle either
2450 -- DOS or Unix mode files, and there is no point in wasting time on
2451 -- text translation when it is not required.
2453 Lib_FD := Open_Read (Name_Buffer'Address, Binary);
2455 if Lib_FD = Invalid_FD then
2457 Fail ("Cannot open: " & Name_Buffer (1 .. Name_Len));
2459 Current_Full_Obj_Stamp := Empty_Time_Stamp;
2464 -- Compute the length of the file (potentially also preparing other data
2465 -- like the timestamp and whether the file is read-only, for future use)
2467 Len := Integer (File_Length (Name_Buffer'Address, Lib_File_Attr));
2469 -- Check for object file consistency if requested
2471 if Opt.Check_Object_Consistency then
2472 -- On most systems, this does not result in an extra system call
2474 Current_Full_Lib_Stamp :=
2475 OS_Time_To_GNAT_Time
2476 (File_Time_Stamp (Name_Buffer'Address, Lib_File_Attr));
2478 -- ??? One system call here
2480 Current_Full_Obj_Stamp := File_Stamp (Current_Full_Obj_Name);
2482 if Current_Full_Obj_Stamp (1) = ' ' then
2484 -- When the library is readonly always assume object is consistent
2485 -- The call to Is_Writable_File only results in a system call on
2486 -- some systems, but in most cases it has already been computed as
2487 -- part of the call to File_Length above.
2489 Get_Name_String (Current_Full_Lib_Name);
2490 Name_Buffer (Name_Len + 1) := ASCII.NUL;
2492 if not Is_Writable_File (Name_Buffer'Address, Lib_File_Attr) then
2493 Current_Full_Obj_Stamp := Current_Full_Lib_Stamp;
2495 elsif Fatal_Err then
2496 Get_Name_String (Current_Full_Obj_Name);
2497 Close (Lib_FD, Status);
2499 -- No need to check the status, we fail anyway
2501 Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
2504 Current_Full_Obj_Stamp := Empty_Time_Stamp;
2505 Close (Lib_FD, Status);
2507 -- No need to check the status, we return null anyway
2512 elsif Current_Full_Obj_Stamp < Current_Full_Lib_Stamp then
2513 Close (Lib_FD, Status);
2515 -- No need to check the status, we return null anyway
2521 -- Read data from the file
2524 Actual_Len : Integer := 0;
2526 Lo : constant Text_Ptr := 0;
2527 -- Low bound for allocated text buffer
2529 Hi : Text_Ptr := Text_Ptr (Len);
2530 -- High bound for allocated text buffer. Note length is Len + 1
2531 -- which allows for extra EOF character at the end of the buffer.
2534 -- Allocate text buffer. Note extra character at end for EOF
2536 Text := new Text_Buffer (Lo .. Hi);
2538 -- Some systems (e.g. VMS) have file types that require one
2539 -- read per line, so read until we get the Len bytes or until
2540 -- there are no more characters.
2544 Actual_Len := Read (Lib_FD, Text (Hi)'Address, Len);
2545 Hi := Hi + Text_Ptr (Actual_Len);
2546 exit when Actual_Len = Len or else Actual_Len <= 0;
2552 -- Read is complete, close file and we are done
2554 Close (Lib_FD, Status);
2555 -- The status should never be False. But, if it is, what can we do?
2556 -- So, we don't test it.
2560 end Read_Library_Info_From_Full;
2562 ----------------------
2563 -- Read_Source_File --
2564 ----------------------
2566 procedure Read_Source_File
2567 (N : File_Name_Type;
2569 Hi : out Source_Ptr;
2570 Src : out Source_Buffer_Ptr;
2571 T : File_Type := Source)
2573 Source_File_FD : File_Descriptor;
2574 -- The file descriptor for the current source file. A negative value
2575 -- indicates failure to open the specified source file.
2578 -- Length of file. Assume no more than 2 gigabytes of source!
2580 Actual_Len : Integer;
2583 pragma Warnings (Off, Status);
2584 -- For the call to Close
2587 Current_Full_Source_Name := Find_File (N, T);
2588 Current_Full_Source_Stamp := File_Stamp (Current_Full_Source_Name);
2590 if Current_Full_Source_Name = No_File then
2592 -- If we were trying to access the main file and we could not find
2593 -- it, we have an error.
2595 if N = Current_Main then
2596 Get_Name_String (N);
2597 Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
2605 Get_Name_String (Current_Full_Source_Name);
2606 Name_Buffer (Name_Len + 1) := ASCII.NUL;
2608 -- Open the source FD, note that we open in binary mode, because as
2609 -- documented in the spec, the caller is expected to handle either
2610 -- DOS or Unix mode files, and there is no point in wasting time on
2611 -- text translation when it is not required.
2613 Source_File_FD := Open_Read (Name_Buffer'Address, Binary);
2615 if Source_File_FD = Invalid_FD then
2621 -- Print out the file name, if requested, and if it's not part of the
2622 -- runtimes, store it in File_Name_Chars.
2625 Name : String renames Name_Buffer (1 .. Name_Len);
2626 Inc : String renames Include_Dir_Default_Prefix.all;
2629 if Debug.Debug_Flag_Dot_N then
2634 and then Inc'Length < Name_Len
2635 and then Name_Buffer (1 .. Inc'Length) = Inc
2637 -- Part of runtimes, so ignore it
2642 File_Name_Chars.Append_All (File_Name_Chars.Table_Type (Name));
2643 File_Name_Chars.Append (ASCII.LF);
2647 -- Prepare to read data from the file
2649 Len := Integer (File_Length (Source_File_FD));
2651 -- Set Hi so that length is one more than the physical length,
2652 -- allowing for the extra EOF character at the end of the buffer
2654 Hi := Lo + Source_Ptr (Len);
2656 -- Do the actual read operation
2659 subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
2660 -- Physical buffer allocated
2662 type Actual_Source_Ptr is access Actual_Source_Buffer;
2663 -- This is the pointer type for the physical buffer allocated
2665 Actual_Ptr : constant Actual_Source_Ptr := new Actual_Source_Buffer;
2666 -- And this is the actual physical buffer
2669 -- Allocate source buffer, allowing extra character at end for EOF
2671 -- Some systems (e.g. VMS) have file types that require one read per
2672 -- line, so read until we get the Len bytes or until there are no
2677 Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len);
2678 Hi := Hi + Source_Ptr (Actual_Len);
2679 exit when Actual_Len = Len or else Actual_Len <= 0;
2682 Actual_Ptr (Hi) := EOF;
2684 -- Now we need to work out the proper virtual origin pointer to
2685 -- return. This is exactly Actual_Ptr (0)'Address, but we have to
2686 -- be careful to suppress checks to compute this address.
2689 pragma Suppress (All_Checks);
2691 pragma Warnings (Off);
2692 -- This use of unchecked conversion is aliasing safe
2694 function To_Source_Buffer_Ptr is new
2695 Unchecked_Conversion (Address, Source_Buffer_Ptr);
2697 pragma Warnings (On);
2700 Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
2704 -- Read is complete, get time stamp and close file and we are done
2706 Close (Source_File_FD, Status);
2708 -- The status should never be False. But, if it is, what can we do?
2709 -- So, we don't test it.
2711 end Read_Source_File;
2717 function Relocate_Path
2719 Path : String) return String_Ptr
2723 procedure set_std_prefix (S : String; Len : Integer);
2724 pragma Import (C, set_std_prefix);
2727 if Std_Prefix = null then
2728 Std_Prefix := Executable_Prefix;
2730 if Std_Prefix.all /= "" then
2732 -- Remove trailing directory separator when calling set_std_prefix
2734 set_std_prefix (Std_Prefix.all, Std_Prefix'Length - 1);
2738 if Path (Prefix'Range) = Prefix then
2739 if Std_Prefix.all /= "" then
2741 (1 .. Std_Prefix'Length + Path'Last - Prefix'Last);
2742 S (1 .. Std_Prefix'Length) := Std_Prefix.all;
2743 S (Std_Prefix'Length + 1 .. S'Last) :=
2744 Path (Prefix'Last + 1 .. Path'Last);
2749 return new String'(Path);
2756 procedure Set_Program (P : Program_Type) is
2759 Fail ("Set_Program called twice");
2762 Program_Set := True;
2763 Running_Program := P;
2770 function Shared_Lib (Name : String) return String is
2771 Library : String (1 .. Name'Length + Library_Version'Length + 3);
2772 -- 3 = 2 for "-l" + 1 for "-" before lib version
2775 Library (1 .. 2) := "-l";
2776 Library (3 .. 2 + Name'Length) := Name;
2777 Library (3 + Name'Length) := '-';
2778 Library (4 + Name'Length .. Library'Last) := Library_Version;
2780 if OpenVMS_On_Target then
2781 for K in Library'First + 2 .. Library'Last loop
2782 if Library (K) = '.' or else Library (K) = '-' then
2791 ----------------------
2792 -- Smart_File_Stamp --
2793 ----------------------
2795 function Smart_File_Stamp
2796 (N : File_Name_Type;
2797 T : File_Type) return Time_Stamp_Type
2799 File : File_Name_Type;
2800 Attr : aliased File_Attributes;
2803 if not File_Cache_Enabled then
2804 Find_File (N, T, File, Attr'Access);
2806 Smart_Find_File (N, T, File, Attr);
2809 if File = No_File then
2810 return Empty_Time_Stamp;
2812 Get_Name_String (File);
2813 Name_Buffer (Name_Len + 1) := ASCII.NUL;
2815 OS_Time_To_GNAT_Time
2816 (File_Time_Stamp (Name_Buffer'Address, Attr'Access));
2818 end Smart_File_Stamp;
2820 ---------------------
2821 -- Smart_Find_File --
2822 ---------------------
2824 function Smart_Find_File
2825 (N : File_Name_Type;
2826 T : File_Type) return File_Name_Type
2828 File : File_Name_Type;
2829 Attr : File_Attributes;
2831 Smart_Find_File (N, T, File, Attr);
2833 end Smart_Find_File;
2835 ---------------------
2836 -- Smart_Find_File --
2837 ---------------------
2839 procedure Smart_Find_File
2840 (N : File_Name_Type;
2842 Found : out File_Name_Type;
2843 Attr : out File_Attributes)
2845 Info : File_Info_Cache;
2848 if not File_Cache_Enabled then
2849 Find_File (N, T, Info.File, Info.Attr'Access);
2852 Info := File_Name_Hash_Table.Get (N);
2854 if Info.File = No_File then
2855 Find_File (N, T, Info.File, Info.Attr'Access);
2856 File_Name_Hash_Table.Set (N, Info);
2862 end Smart_Find_File;
2864 ----------------------
2865 -- Source_File_Data --
2866 ----------------------
2868 procedure Source_File_Data (Cache : Boolean) is
2870 File_Cache_Enabled := Cache;
2871 end Source_File_Data;
2873 -----------------------
2874 -- Source_File_Stamp --
2875 -----------------------
2877 function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is
2879 return Smart_File_Stamp (N, Source);
2880 end Source_File_Stamp;
2882 ---------------------
2883 -- Strip_Directory --
2884 ---------------------
2886 function Strip_Directory (Name : File_Name_Type) return File_Name_Type is
2888 Get_Name_String (Name);
2890 for J in reverse 1 .. Name_Len - 1 loop
2892 -- If we find the last directory separator
2894 if Is_Directory_Separator (Name_Buffer (J)) then
2896 -- Return part of Name that follows this last directory separator
2898 Name_Buffer (1 .. Name_Len - J) := Name_Buffer (J + 1 .. Name_Len);
2899 Name_Len := Name_Len - J;
2904 -- There were no directory separator, just return Name
2907 end Strip_Directory;
2913 function Strip_Suffix (Name : File_Name_Type) return File_Name_Type is
2915 Get_Name_String (Name);
2917 for J in reverse 2 .. Name_Len loop
2919 -- If we found the last '.', return part of Name that precedes it
2921 if Name_Buffer (J) = '.' then
2930 ---------------------------
2931 -- To_Canonical_Dir_Spec --
2932 ---------------------------
2934 function To_Canonical_Dir_Spec
2936 Prefix_Style : Boolean) return String_Access
2938 function To_Canonical_Dir_Spec
2939 (Host_Dir : Address;
2940 Prefix_Flag : Integer) return Address;
2941 pragma Import (C, To_Canonical_Dir_Spec, "__gnat_to_canonical_dir_spec");
2943 C_Host_Dir : String (1 .. Host_Dir'Length + 1);
2944 Canonical_Dir_Addr : Address;
2945 Canonical_Dir_Len : Integer;
2948 C_Host_Dir (1 .. Host_Dir'Length) := Host_Dir;
2949 C_Host_Dir (C_Host_Dir'Last) := ASCII.NUL;
2951 if Prefix_Style then
2952 Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 1);
2954 Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 0);
2957 Canonical_Dir_Len := C_String_Length (Canonical_Dir_Addr);
2959 if Canonical_Dir_Len = 0 then
2962 return To_Path_String_Access (Canonical_Dir_Addr, Canonical_Dir_Len);
2967 Fail ("erroneous directory spec: " & Host_Dir);
2969 end To_Canonical_Dir_Spec;
2971 ---------------------------
2972 -- To_Canonical_File_List --
2973 ---------------------------
2975 function To_Canonical_File_List
2976 (Wildcard_Host_File : String;
2977 Only_Dirs : Boolean) return String_Access_List_Access
2979 function To_Canonical_File_List_Init
2980 (Host_File : Address;
2981 Only_Dirs : Integer) return Integer;
2982 pragma Import (C, To_Canonical_File_List_Init,
2983 "__gnat_to_canonical_file_list_init");
2985 function To_Canonical_File_List_Next return Address;
2986 pragma Import (C, To_Canonical_File_List_Next,
2987 "__gnat_to_canonical_file_list_next");
2989 procedure To_Canonical_File_List_Free;
2990 pragma Import (C, To_Canonical_File_List_Free,
2991 "__gnat_to_canonical_file_list_free");
2993 Num_Files : Integer;
2994 C_Wildcard_Host_File : String (1 .. Wildcard_Host_File'Length + 1);
2997 C_Wildcard_Host_File (1 .. Wildcard_Host_File'Length) :=
2999 C_Wildcard_Host_File (C_Wildcard_Host_File'Last) := ASCII.NUL;
3001 -- Do the expansion and say how many there are
3003 Num_Files := To_Canonical_File_List_Init
3004 (C_Wildcard_Host_File'Address, Boolean'Pos (Only_Dirs));
3007 Canonical_File_List : String_Access_List (1 .. Num_Files);
3008 Canonical_File_Addr : Address;
3009 Canonical_File_Len : Integer;
3012 -- Retrieve the expanded directory names and build the list
3014 for J in 1 .. Num_Files loop
3015 Canonical_File_Addr := To_Canonical_File_List_Next;
3016 Canonical_File_Len := C_String_Length (Canonical_File_Addr);
3017 Canonical_File_List (J) := To_Path_String_Access
3018 (Canonical_File_Addr, Canonical_File_Len);
3021 -- Free up the storage
3023 To_Canonical_File_List_Free;
3025 return new String_Access_List'(Canonical_File_List);
3027 end To_Canonical_File_List;
3029 ----------------------------
3030 -- To_Canonical_File_Spec --
3031 ----------------------------
3033 function To_Canonical_File_Spec
3034 (Host_File : String) return String_Access
3036 function To_Canonical_File_Spec (Host_File : Address) return Address;
3038 (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
3040 C_Host_File : String (1 .. Host_File'Length + 1);
3041 Canonical_File_Addr : Address;
3042 Canonical_File_Len : Integer;
3045 C_Host_File (1 .. Host_File'Length) := Host_File;
3046 C_Host_File (C_Host_File'Last) := ASCII.NUL;
3048 Canonical_File_Addr := To_Canonical_File_Spec (C_Host_File'Address);
3049 Canonical_File_Len := C_String_Length (Canonical_File_Addr);
3051 if Canonical_File_Len = 0 then
3054 return To_Path_String_Access
3055 (Canonical_File_Addr, Canonical_File_Len);
3060 Fail ("erroneous file spec: " & Host_File);
3062 end To_Canonical_File_Spec;
3064 ----------------------------
3065 -- To_Canonical_Path_Spec --
3066 ----------------------------
3068 function To_Canonical_Path_Spec
3069 (Host_Path : String) return String_Access
3071 function To_Canonical_Path_Spec (Host_Path : Address) return Address;
3073 (C, To_Canonical_Path_Spec, "__gnat_to_canonical_path_spec");
3075 C_Host_Path : String (1 .. Host_Path'Length + 1);
3076 Canonical_Path_Addr : Address;
3077 Canonical_Path_Len : Integer;
3080 C_Host_Path (1 .. Host_Path'Length) := Host_Path;
3081 C_Host_Path (C_Host_Path'Last) := ASCII.NUL;
3083 Canonical_Path_Addr := To_Canonical_Path_Spec (C_Host_Path'Address);
3084 Canonical_Path_Len := C_String_Length (Canonical_Path_Addr);
3086 -- Return a null string (vice a null) for zero length paths, for
3087 -- compatibility with getenv().
3089 return To_Path_String_Access (Canonical_Path_Addr, Canonical_Path_Len);
3093 Fail ("erroneous path spec: " & Host_Path);
3095 end To_Canonical_Path_Spec;
3097 ---------------------------
3098 -- To_Host_Dir_Spec --
3099 ---------------------------
3101 function To_Host_Dir_Spec
3102 (Canonical_Dir : String;
3103 Prefix_Style : Boolean) return String_Access
3105 function To_Host_Dir_Spec
3106 (Canonical_Dir : Address;
3107 Prefix_Flag : Integer) return Address;
3108 pragma Import (C, To_Host_Dir_Spec, "__gnat_to_host_dir_spec");
3110 C_Canonical_Dir : String (1 .. Canonical_Dir'Length + 1);
3111 Host_Dir_Addr : Address;
3112 Host_Dir_Len : Integer;
3115 C_Canonical_Dir (1 .. Canonical_Dir'Length) := Canonical_Dir;
3116 C_Canonical_Dir (C_Canonical_Dir'Last) := ASCII.NUL;
3118 if Prefix_Style then
3119 Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 1);
3121 Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 0);
3123 Host_Dir_Len := C_String_Length (Host_Dir_Addr);
3125 if Host_Dir_Len = 0 then
3128 return To_Path_String_Access (Host_Dir_Addr, Host_Dir_Len);
3130 end To_Host_Dir_Spec;
3132 ----------------------------
3133 -- To_Host_File_Spec --
3134 ----------------------------
3136 function To_Host_File_Spec
3137 (Canonical_File : String) return String_Access
3139 function To_Host_File_Spec (Canonical_File : Address) return Address;
3140 pragma Import (C, To_Host_File_Spec, "__gnat_to_host_file_spec");
3142 C_Canonical_File : String (1 .. Canonical_File'Length + 1);
3143 Host_File_Addr : Address;
3144 Host_File_Len : Integer;
3147 C_Canonical_File (1 .. Canonical_File'Length) := Canonical_File;
3148 C_Canonical_File (C_Canonical_File'Last) := ASCII.NUL;
3150 Host_File_Addr := To_Host_File_Spec (C_Canonical_File'Address);
3151 Host_File_Len := C_String_Length (Host_File_Addr);
3153 if Host_File_Len = 0 then
3156 return To_Path_String_Access
3157 (Host_File_Addr, Host_File_Len);
3159 end To_Host_File_Spec;
3161 ---------------------------
3162 -- To_Path_String_Access --
3163 ---------------------------
3165 function To_Path_String_Access
3166 (Path_Addr : Address;
3167 Path_Len : Integer) return String_Access
3169 subtype Path_String is String (1 .. Path_Len);
3170 type Path_String_Access is access Path_String;
3172 function Address_To_Access is new
3173 Unchecked_Conversion (Source => Address,
3174 Target => Path_String_Access);
3176 Path_Access : constant Path_String_Access :=
3177 Address_To_Access (Path_Addr);
3179 Return_Val : String_Access;
3182 Return_Val := new String (1 .. Path_Len);
3184 for J in 1 .. Path_Len loop
3185 Return_Val (J) := Path_Access (J);
3189 end To_Path_String_Access;
3195 function Update_Path (Path : String_Ptr) return String_Ptr is
3197 function C_Update_Path (Path, Component : Address) return Address;
3198 pragma Import (C, C_Update_Path, "update_path");
3200 function Strlen (Str : Address) return Integer;
3201 pragma Import (C, Strlen, "strlen");
3203 procedure Strncpy (X : Address; Y : Address; Length : Integer);
3204 pragma Import (C, Strncpy, "strncpy");
3206 In_Length : constant Integer := Path'Length;
3207 In_String : String (1 .. In_Length + 1);
3208 Component_Name : aliased String := "GCC" & ASCII.NUL;
3209 Result_Ptr : Address;
3210 Result_Length : Integer;
3211 Out_String : String_Ptr;
3214 In_String (1 .. In_Length) := Path.all;
3215 In_String (In_Length + 1) := ASCII.NUL;
3216 Result_Ptr := C_Update_Path (In_String'Address, Component_Name'Address);
3217 Result_Length := Strlen (Result_Ptr);
3219 Out_String := new String (1 .. Result_Length);
3220 Strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
3228 procedure Write_Info (Info : String) is
3230 Write_With_Check (Info'Address, Info'Length);
3231 Write_With_Check (EOL'Address, 1);
3234 ------------------------
3235 -- Write_Program_Name --
3236 ------------------------
3238 procedure Write_Program_Name is
3239 Save_Buffer : constant String (1 .. Name_Len) :=
3240 Name_Buffer (1 .. Name_Len);
3245 -- Convert the name to lower case so error messages are the same on
3248 for J in 1 .. Name_Len loop
3249 if Name_Buffer (J) in 'A' .. 'Z' then
3251 Character'Val (Character'Pos (Name_Buffer (J)) + 32);
3255 Write_Str (Name_Buffer (1 .. Name_Len));
3257 -- Restore Name_Buffer which was clobbered by the call to
3258 -- Find_Program_Name
3260 Name_Len := Save_Buffer'Last;
3261 Name_Buffer (1 .. Name_Len) := Save_Buffer;
3262 end Write_Program_Name;
3264 ----------------------
3265 -- Write_With_Check --
3266 ----------------------
3268 procedure Write_With_Check (A : Address; N : Integer) is
3270 pragma Warnings (Off, Ignore);
3273 if N = Write (Output_FD, A, N) then
3277 Write_Str ("error: disk full writing ");
3278 Write_Name_Decoded (Output_File_Name);
3280 Name_Len := Name_Len + 1;
3281 Name_Buffer (Name_Len) := ASCII.NUL;
3282 Delete_File (Name_Buffer'Address, Ignore);
3283 Exit_Program (E_Fatal);
3285 end Write_With_Check;
3287 ----------------------------
3288 -- Package Initialization --
3289 ----------------------------
3291 procedure Reset_File_Attributes (Attr : System.Address);
3292 pragma Import (C, Reset_File_Attributes, "__gnat_reset_attributes");
3295 Initialization : declare
3297 function Get_Default_Identifier_Character_Set return Character;
3298 pragma Import (C, Get_Default_Identifier_Character_Set,
3299 "__gnat_get_default_identifier_character_set");
3300 -- Function to determine the default identifier character set,
3301 -- which is system dependent. See Opt package spec for a list of
3302 -- the possible character codes and their interpretations.
3304 function Get_Maximum_File_Name_Length return Int;
3305 pragma Import (C, Get_Maximum_File_Name_Length,
3306 "__gnat_get_maximum_file_name_length");
3307 -- Function to get maximum file name length for system
3309 Sizeof_File_Attributes : Integer;
3310 pragma Import (C, Sizeof_File_Attributes,
3311 "__gnat_size_of_file_attributes");
3314 pragma Assert (Sizeof_File_Attributes <= File_Attributes_Size);
3316 Reset_File_Attributes (Unknown_Attributes'Address);
3318 Identifier_Character_Set := Get_Default_Identifier_Character_Set;
3319 Maximum_File_Name_Length := Get_Maximum_File_Name_Length;
3321 -- Following should be removed by having above function return
3322 -- Integer'Last as indication of no maximum instead of -1 ???
3324 if Maximum_File_Name_Length = -1 then
3325 Maximum_File_Name_Length := Int'Last;
3328 Src_Search_Directories.Set_Last (Primary_Directory);
3329 Src_Search_Directories.Table (Primary_Directory) := new String'("");
3331 Lib_Search_Directories.Set_Last (Primary_Directory);
3332 Lib_Search_Directories.Table (Primary_Directory) := new String'("");