1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, 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 ------------------------------------------------------------------------------
26 with Unchecked_Conversion;
28 with System.Case_Util; use System.Case_Util;
35 with Gnatvsn; use Gnatvsn;
38 with Output; use Output;
39 with Sdefault; use Sdefault;
41 with Targparm; use Targparm;
45 Running_Program : Program_Type := Unspecified;
46 -- comment required here ???
48 Program_Set : Boolean := False;
49 -- comment required here ???
51 Std_Prefix : String_Ptr;
52 -- Standard prefix, computed dynamically the first time Relocate_Path
53 -- is called, and cached for subsequent calls.
55 Empty : aliased String := "";
56 No_Dir : constant String_Ptr := Empty'Access;
57 -- Used in Locate_File as a fake directory when Name is already an
60 -------------------------------------
61 -- Use of Name_Find and Name_Enter --
62 -------------------------------------
64 -- This package creates a number of source, ALI and object file names
65 -- that are used to locate the actual file and for the purpose of message
66 -- construction. These names need not be accessible by Name_Find, and can
67 -- be therefore created by using routine Name_Enter. The files in question
68 -- are file names with a prefix directory (i.e., the files not in the
69 -- current directory). File names without a prefix directory are entered
70 -- with Name_Find because special values might be attached to the various
71 -- Info fields of the corresponding name table entry.
73 -----------------------
74 -- Local Subprograms --
75 -----------------------
77 function Append_Suffix_To_File_Name
78 (Name : File_Name_Type;
79 Suffix : String) return File_Name_Type;
80 -- Appends Suffix to Name and returns the new name
82 function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type;
83 -- Convert OS format time to GNAT format time stamp. If T is Invalid_Time,
84 -- then returns Empty_Time_Stamp.
86 function Executable_Prefix return String_Ptr;
87 -- Returns the name of the root directory where the executable is stored.
88 -- The executable must be located in a directory called "bin", or under
89 -- root/lib/gcc-lib/..., or under root/libexec/gcc/... For example, if
90 -- executable is stored in directory "/foo/bar/bin", this routine returns
91 -- "/foo/bar/". Return "" if location is not recognized as described above.
93 function Update_Path (Path : String_Ptr) return String_Ptr;
94 -- Update the specified path to replace the prefix with the location where
95 -- GNAT is installed. See the file prefix.c in GCC for details.
102 Found : out File_Name_Type;
103 Attr : access File_Attributes);
104 -- See if the file N whose name is Name exists in directory Dir. Dir is an
105 -- index into the Lib_Search_Directories table if T = Library. Otherwise
106 -- if T = Source, Dir is an index into the Src_Search_Directories table.
107 -- Returns the File_Name_Type of the full file name if file found, or
108 -- No_File if not found.
110 -- On exit, Found is set to the file that was found, and Attr to a cache of
111 -- its attributes (at least those that have been computed so far). Reusing
112 -- the cache will save some system calls.
114 -- Attr is always reset in this call to Unknown_Attributes, even in case of
120 Found : out File_Name_Type;
121 Attr : access File_Attributes);
122 -- A version of Find_File that also returns a cache of the file attributes
125 procedure Smart_Find_File
128 Found : out File_Name_Type;
129 Attr : out File_Attributes);
130 -- A version of Smart_Find_File that also returns a cache of the file
131 -- attributes for later reuse
133 function C_String_Length (S : Address) return Integer;
134 -- Returns length of a C string (zero for a null address)
136 function To_Path_String_Access
137 (Path_Addr : Address;
138 Path_Len : Integer) return String_Access;
139 -- Converts a C String to an Ada String. Are we doing this to avoid withing
140 -- Interfaces.C.Strings ???
141 -- Caller must free result.
143 function Include_Dir_Default_Prefix return String_Access;
144 -- Same as exported version, except returns a String_Access
146 ------------------------------
147 -- Other Local Declarations --
148 ------------------------------
150 EOL : constant Character := ASCII.LF;
151 -- End of line character
153 Number_File_Names : Int := 0;
154 -- Number of file names found on command line and placed in File_Names
156 Look_In_Primary_Directory_For_Current_Main : Boolean := False;
157 -- When this variable is True, Find_File only looks in Primary_Directory
158 -- for the Current_Main file. This variable is always set to True for the
159 -- compiler. It is also True for gnatmake, when the source name given on
160 -- the command line has directory information.
162 Current_Full_Source_Name : File_Name_Type := No_File;
163 Current_Full_Source_Stamp : Time_Stamp_Type := Empty_Time_Stamp;
164 Current_Full_Lib_Name : File_Name_Type := No_File;
165 Current_Full_Lib_Stamp : Time_Stamp_Type := Empty_Time_Stamp;
166 Current_Full_Obj_Name : File_Name_Type := No_File;
167 Current_Full_Obj_Stamp : Time_Stamp_Type := Empty_Time_Stamp;
168 -- Respectively full name (with directory info) and time stamp of the
169 -- latest source, library and object files opened by Read_Source_File and
170 -- Read_Library_Info.
172 package File_Name_Chars is new Table.Table (
173 Table_Component_Type => Character,
174 Table_Index_Type => Int,
175 Table_Low_Bound => 1,
176 Table_Initial => Alloc.File_Name_Chars_Initial,
177 Table_Increment => Alloc.File_Name_Chars_Increment,
178 Table_Name => "File_Name_Chars");
179 -- Table to store text to be printed by Dump_Source_File_Names
181 The_Include_Dir_Default_Prefix : String_Access := null;
182 -- Value returned by Include_Dir_Default_Prefix. We don't initialize it
183 -- here, because that causes an elaboration cycle with Sdefault; we
184 -- initialize it lazily instead.
190 Primary_Directory : constant := 0;
191 -- This is index in the tables created below for the first directory to
192 -- search in for source or library information files. This is the directory
193 -- containing the latest main input file (a source file for the compiler or
194 -- a library file for the binder).
196 package Src_Search_Directories is new Table.Table (
197 Table_Component_Type => String_Ptr,
198 Table_Index_Type => Integer,
199 Table_Low_Bound => Primary_Directory,
201 Table_Increment => 100,
202 Table_Name => "Osint.Src_Search_Directories");
203 -- Table of names of directories in which to search for source (Compiler)
204 -- files. This table is filled in the order in which the directories are
205 -- to be searched, and then used in that order.
207 package Lib_Search_Directories is new Table.Table (
208 Table_Component_Type => String_Ptr,
209 Table_Index_Type => Integer,
210 Table_Low_Bound => Primary_Directory,
212 Table_Increment => 100,
213 Table_Name => "Osint.Lib_Search_Directories");
214 -- Table of names of directories in which to search for library (Binder)
215 -- files. This table is filled in the order in which the directories are
216 -- to be searched and then used in that order. The reason for having two
217 -- distinct tables is that we need them both in gnatmake.
219 ---------------------
220 -- File Hash Table --
221 ---------------------
223 -- The file hash table is provided to free the programmer from any
224 -- efficiency concern when retrieving full file names or time stamps of
225 -- source files. If the programmer calls Source_File_Data (Cache => True)
226 -- he is guaranteed that the price to retrieve the full name (i.e. with
227 -- directory info) or time stamp of the file will be payed only once, the
228 -- first time the full name is actually searched (or the first time the
229 -- time stamp is actually retrieved). This is achieved by employing a hash
230 -- table that stores as a key the File_Name_Type of the file and associates
231 -- to that File_Name_Type the full file name and time stamp of the file.
233 File_Cache_Enabled : Boolean := False;
234 -- Set to true if you want the enable the file data caching mechanism
236 type File_Hash_Num is range 0 .. 1020;
238 function File_Hash (F : File_Name_Type) return File_Hash_Num;
239 -- Compute hash index for use by Simple_HTable
241 type File_Info_Cache is record
242 File : File_Name_Type;
243 Attr : aliased File_Attributes;
246 No_File_Info_Cache : constant File_Info_Cache :=
247 (No_File, Unknown_Attributes);
249 package File_Name_Hash_Table is new GNAT.HTable.Simple_HTable (
250 Header_Num => File_Hash_Num,
251 Element => File_Info_Cache,
252 No_Element => No_File_Info_Cache,
253 Key => File_Name_Type,
257 function Smart_Find_File
259 T : File_Type) return File_Name_Type;
260 -- Exactly like Find_File except that if File_Cache_Enabled is True this
261 -- routine looks first in the hash table to see if the full name of the
262 -- file is already available.
264 function Smart_File_Stamp
266 T : File_Type) return Time_Stamp_Type;
267 -- Takes the same parameter as the routine above (N is a file name without
268 -- any prefix directory information) and behaves like File_Stamp except
269 -- that if File_Cache_Enabled is True this routine looks first in the hash
270 -- table to see if the file stamp of the file is already available.
272 -----------------------------
273 -- Add_Default_Search_Dirs --
274 -----------------------------
276 procedure Add_Default_Search_Dirs is
277 Search_Dir : String_Access;
278 Search_Path : String_Access;
279 Path_File_Name : String_Access;
281 procedure Add_Search_Dir
282 (Search_Dir : String;
283 Additional_Source_Dir : Boolean);
284 procedure Add_Search_Dir
285 (Search_Dir : String_Access;
286 Additional_Source_Dir : Boolean);
287 -- Add a source search dir or a library search dir, depending on the
288 -- value of Additional_Source_Dir.
290 procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean);
291 -- Open a path file and read the directory to search, one per line
293 function Get_Libraries_From_Registry return String_Ptr;
294 -- On Windows systems, get the list of installed standard libraries
295 -- from the registry key:
297 -- HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\
298 -- GNAT\Standard Libraries
299 -- Return an empty string on other systems.
301 -- Note that this is an undocumented legacy feature, and that it
302 -- works only when using the default runtime library (i.e. no --RTS=
303 -- command line switch).
309 procedure Add_Search_Dir
310 (Search_Dir : String;
311 Additional_Source_Dir : Boolean)
314 if Additional_Source_Dir then
315 Add_Src_Search_Dir (Search_Dir);
317 Add_Lib_Search_Dir (Search_Dir);
321 procedure Add_Search_Dir
322 (Search_Dir : String_Access;
323 Additional_Source_Dir : Boolean)
326 if Additional_Source_Dir then
327 Add_Src_Search_Dir (Search_Dir.all);
329 Add_Lib_Search_Dir (Search_Dir.all);
333 ------------------------
334 -- Get_Dirs_From_File --
335 ------------------------
337 procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean) is
338 File_FD : File_Descriptor;
339 Buffer : constant String := Path_File_Name.all & ASCII.NUL;
341 Actual_Len : Natural;
348 pragma Warnings (Off, Status);
349 -- For the call to Close where status is ignored
352 File_FD := Open_Read (Buffer'Address, Binary);
354 -- If we cannot open the file, we ignore it, we don't fail
356 if File_FD = Invalid_FD then
360 Len := Integer (File_Length (File_FD));
362 S := new String (1 .. Len);
364 -- Read the file. Note that the loop is not necessary since the
365 -- whole file is read at once except on VMS.
369 while Curr <= Len and then Actual_Len /= 0 loop
370 Actual_Len := Read (File_FD, S (Curr)'Address, Len);
371 Curr := Curr + Actual_Len;
374 -- We are done with the file, so we close it (ignore any error on
375 -- the close, since we have successfully read the file).
377 Close (File_FD, Status);
379 -- Now, we read line by line
383 while Curr < Len loop
386 if Ch = ASCII.CR or else Ch = ASCII.LF
387 or else Ch = ASCII.FF or else Ch = ASCII.VT
389 if First <= Curr then
390 Add_Search_Dir (S (First .. Curr), Additional_Source_Dir);
399 -- Last line is a special case, if the file does not end with
400 -- an end of line mark.
402 if First <= S'Last then
403 Add_Search_Dir (S (First .. S'Last), Additional_Source_Dir);
405 end Get_Dirs_From_File;
407 ---------------------------------
408 -- Get_Libraries_From_Registry --
409 ---------------------------------
411 function Get_Libraries_From_Registry return String_Ptr is
412 function C_Get_Libraries_From_Registry return Address;
413 pragma Import (C, C_Get_Libraries_From_Registry,
414 "__gnat_get_libraries_from_registry");
416 function Strlen (Str : Address) return Integer;
417 pragma Import (C, Strlen, "strlen");
419 procedure Strncpy (X : Address; Y : Address; Length : Integer);
420 pragma Import (C, Strncpy, "strncpy");
422 procedure C_Free (Str : Address);
423 pragma Import (C, C_Free, "free");
425 Result_Ptr : Address;
426 Result_Length : Integer;
427 Out_String : String_Ptr;
430 Result_Ptr := C_Get_Libraries_From_Registry;
431 Result_Length := Strlen (Result_Ptr);
433 Out_String := new String (1 .. Result_Length);
434 Strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
439 end Get_Libraries_From_Registry;
441 -- Start of processing for Add_Default_Search_Dirs
444 -- After the locations specified on the command line, the next places
445 -- to look for files are the directories specified by the appropriate
446 -- environment variable. Get this value, extract the directory names
447 -- and store in the tables.
449 -- Check for eventual project path file env vars
451 Path_File_Name := Getenv (Project_Include_Path_File);
453 if Path_File_Name'Length > 0 then
454 Get_Dirs_From_File (Additional_Source_Dir => True);
457 Path_File_Name := Getenv (Project_Objects_Path_File);
459 if Path_File_Name'Length > 0 then
460 Get_Dirs_From_File (Additional_Source_Dir => False);
463 -- On VMS, don't expand the logical name (e.g. environment variable),
464 -- just put it into Unix (e.g. canonical) format. System services
465 -- will handle the expansion as part of the file processing.
467 for Additional_Source_Dir in False .. True loop
468 if Additional_Source_Dir then
469 Search_Path := Getenv (Ada_Include_Path);
471 if Search_Path'Length > 0 then
472 if Hostparm.OpenVMS then
473 Search_Path := To_Canonical_Path_Spec ("ADA_INCLUDE_PATH:");
475 Search_Path := To_Canonical_Path_Spec (Search_Path.all);
480 Search_Path := Getenv (Ada_Objects_Path);
482 if Search_Path'Length > 0 then
483 if Hostparm.OpenVMS then
484 Search_Path := To_Canonical_Path_Spec ("ADA_OBJECTS_PATH:");
486 Search_Path := To_Canonical_Path_Spec (Search_Path.all);
491 Get_Next_Dir_In_Path_Init (Search_Path);
493 Search_Dir := Get_Next_Dir_In_Path (Search_Path);
494 exit when Search_Dir = null;
495 Add_Search_Dir (Search_Dir, Additional_Source_Dir);
499 -- For the compiler, if --RTS= was specified, add the runtime
502 if RTS_Src_Path_Name /= null
503 and then RTS_Lib_Path_Name /= null
505 Add_Search_Dirs (RTS_Src_Path_Name, Include);
506 Add_Search_Dirs (RTS_Lib_Path_Name, Objects);
509 if not Opt.No_Stdinc then
511 -- For WIN32 systems, look for any system libraries defined in
512 -- the registry. These are added to both source and object
515 Search_Path := String_Access (Get_Libraries_From_Registry);
517 Get_Next_Dir_In_Path_Init (Search_Path);
519 Search_Dir := Get_Next_Dir_In_Path (Search_Path);
520 exit when Search_Dir = null;
521 Add_Search_Dir (Search_Dir, False);
522 Add_Search_Dir (Search_Dir, True);
525 -- The last place to look are the defaults
528 Read_Default_Search_Dirs
529 (String_Access (Update_Path (Search_Dir_Prefix)),
531 String_Access (Update_Path (Include_Dir_Default_Name)));
533 Get_Next_Dir_In_Path_Init (Search_Path);
535 Search_Dir := Get_Next_Dir_In_Path (Search_Path);
536 exit when Search_Dir = null;
537 Add_Search_Dir (Search_Dir, True);
541 if not Opt.No_Stdlib and not Opt.RTS_Switch then
543 Read_Default_Search_Dirs
544 (String_Access (Update_Path (Search_Dir_Prefix)),
546 String_Access (Update_Path (Object_Dir_Default_Name)));
548 Get_Next_Dir_In_Path_Init (Search_Path);
550 Search_Dir := Get_Next_Dir_In_Path (Search_Path);
551 exit when Search_Dir = null;
552 Add_Search_Dir (Search_Dir, False);
556 end Add_Default_Search_Dirs;
562 procedure Add_File (File_Name : String; Index : Int := No_Index) is
564 Number_File_Names := Number_File_Names + 1;
566 -- As Add_File may be called for mains specified inside a project file,
567 -- File_Names may be too short and needs to be extended.
569 if Number_File_Names > File_Names'Last then
570 File_Names := new File_Name_Array'(File_Names.all & File_Names.all);
572 new File_Index_Array'(File_Indexes.all & File_Indexes.all);
575 File_Names (Number_File_Names) := new String'(File_Name);
576 File_Indexes (Number_File_Names) := Index;
579 ------------------------
580 -- Add_Lib_Search_Dir --
581 ------------------------
583 procedure Add_Lib_Search_Dir (Dir : String) is
585 if Dir'Length = 0 then
586 Fail ("missing library directory name");
590 Norm : String_Ptr := Normalize_Directory_Name (Dir);
593 -- Do nothing if the directory is already in the list. This saves
594 -- system calls and avoid unneeded work
596 for D in Lib_Search_Directories.First ..
597 Lib_Search_Directories.Last
599 if Lib_Search_Directories.Table (D).all = Norm.all then
605 Lib_Search_Directories.Increment_Last;
606 Lib_Search_Directories.Table (Lib_Search_Directories.Last) := Norm;
608 end Add_Lib_Search_Dir;
610 ---------------------
611 -- Add_Search_Dirs --
612 ---------------------
614 procedure Add_Search_Dirs
615 (Search_Path : String_Ptr;
616 Path_Type : Search_File_Type)
618 Current_Search_Path : String_Access;
621 Get_Next_Dir_In_Path_Init (String_Access (Search_Path));
623 Current_Search_Path :=
624 Get_Next_Dir_In_Path (String_Access (Search_Path));
625 exit when Current_Search_Path = null;
627 if Path_Type = Include then
628 Add_Src_Search_Dir (Current_Search_Path.all);
630 Add_Lib_Search_Dir (Current_Search_Path.all);
635 ------------------------
636 -- Add_Src_Search_Dir --
637 ------------------------
639 procedure Add_Src_Search_Dir (Dir : String) is
641 if Dir'Length = 0 then
642 Fail ("missing source directory name");
645 Src_Search_Directories.Increment_Last;
646 Src_Search_Directories.Table (Src_Search_Directories.Last) :=
647 Normalize_Directory_Name (Dir);
648 end Add_Src_Search_Dir;
650 --------------------------------
651 -- Append_Suffix_To_File_Name --
652 --------------------------------
654 function Append_Suffix_To_File_Name
655 (Name : File_Name_Type;
656 Suffix : String) return File_Name_Type
659 Get_Name_String (Name);
660 Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
661 Name_Len := Name_Len + Suffix'Length;
663 end Append_Suffix_To_File_Name;
665 ---------------------
666 -- C_String_Length --
667 ---------------------
669 function C_String_Length (S : Address) return Integer is
670 function Strlen (S : Address) return Integer;
671 pragma Import (C, Strlen, "strlen");
673 if S = Null_Address then
680 ------------------------------
681 -- Canonical_Case_File_Name --
682 ------------------------------
684 -- For now, we only deal with the case of a-z. Eventually we should
685 -- worry about other Latin-1 letters on systems that support this ???
687 procedure Canonical_Case_File_Name (S : in out String) is
689 if not File_Names_Case_Sensitive then
690 for J in S'Range loop
691 if S (J) in 'A' .. 'Z' then
692 S (J) := Character'Val (
693 Character'Pos (S (J)) +
694 Character'Pos ('a') -
695 Character'Pos ('A'));
699 end Canonical_Case_File_Name;
701 ---------------------------
702 -- Create_File_And_Check --
703 ---------------------------
705 procedure Create_File_And_Check
706 (Fdesc : out File_Descriptor;
710 Output_File_Name := Name_Enter;
711 Fdesc := Create_File (Name_Buffer'Address, Fmode);
713 if Fdesc = Invalid_FD then
714 Fail ("Cannot create: " & Name_Buffer (1 .. Name_Len));
716 end Create_File_And_Check;
718 ------------------------
719 -- Current_File_Index --
720 ------------------------
722 function Current_File_Index return Int is
724 return File_Indexes (Current_File_Name_Index);
725 end Current_File_Index;
727 --------------------------------
728 -- Current_Library_File_Stamp --
729 --------------------------------
731 function Current_Library_File_Stamp return Time_Stamp_Type is
733 return Current_Full_Lib_Stamp;
734 end Current_Library_File_Stamp;
736 -------------------------------
737 -- Current_Object_File_Stamp --
738 -------------------------------
740 function Current_Object_File_Stamp return Time_Stamp_Type is
742 return Current_Full_Obj_Stamp;
743 end Current_Object_File_Stamp;
745 -------------------------------
746 -- Current_Source_File_Stamp --
747 -------------------------------
749 function Current_Source_File_Stamp return Time_Stamp_Type is
751 return Current_Full_Source_Stamp;
752 end Current_Source_File_Stamp;
754 ----------------------------
755 -- Dir_In_Obj_Search_Path --
756 ----------------------------
758 function Dir_In_Obj_Search_Path (Position : Natural) return String_Ptr is
760 if Opt.Look_In_Primary_Dir then
762 Lib_Search_Directories.Table (Primary_Directory + Position - 1);
764 return Lib_Search_Directories.Table (Primary_Directory + Position);
766 end Dir_In_Obj_Search_Path;
768 ----------------------------
769 -- Dir_In_Src_Search_Path --
770 ----------------------------
772 function Dir_In_Src_Search_Path (Position : Natural) return String_Ptr is
774 if Opt.Look_In_Primary_Dir then
776 Src_Search_Directories.Table (Primary_Directory + Position - 1);
778 return Src_Search_Directories.Table (Primary_Directory + Position);
780 end Dir_In_Src_Search_Path;
782 ----------------------------
783 -- Dump_Source_File_Names --
784 ----------------------------
786 procedure Dump_Source_File_Names is
787 subtype Rng is Int range File_Name_Chars.First .. File_Name_Chars.Last;
789 Write_Str (String (File_Name_Chars.Table (Rng)));
790 end Dump_Source_File_Names;
792 ---------------------
793 -- Executable_Name --
794 ---------------------
796 function Executable_Name
797 (Name : File_Name_Type;
798 Only_If_No_Suffix : Boolean := False) return File_Name_Type
800 Exec_Suffix : String_Access;
801 Add_Suffix : Boolean;
804 if Name = No_File then
808 if Executable_Extension_On_Target = No_Name then
809 Exec_Suffix := Get_Target_Executable_Suffix;
811 Get_Name_String (Executable_Extension_On_Target);
812 Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len));
815 if Exec_Suffix'Length /= 0 then
817 if Only_If_No_Suffix then
818 for J in reverse 1 .. Name_Len loop
819 if Name_Buffer (J) = '.' then
823 elsif Name_Buffer (J) = '/' or else
824 Name_Buffer (J) = Directory_Separator
832 Get_Name_String (Name);
835 Buffer : String := Name_Buffer (1 .. Name_Len);
838 -- Get the file name in canonical case to accept as is names
839 -- ending with ".EXE" on VMS and Windows.
841 Canonical_Case_File_Name (Buffer);
843 -- If Executable does not end with the executable suffix, add
846 if Buffer'Length <= Exec_Suffix'Length
848 Buffer (Buffer'Last - Exec_Suffix'Length + 1 .. Buffer'Last)
852 (Name_Len + 1 .. Name_Len + Exec_Suffix'Length) :=
854 Name_Len := Name_Len + Exec_Suffix'Length;
866 function Executable_Name
868 Only_If_No_Suffix : Boolean := False) return String
870 Exec_Suffix : String_Access;
871 Add_Suffix : Boolean;
872 Canonical_Name : String := Name;
875 if Executable_Extension_On_Target = No_Name then
876 Exec_Suffix := Get_Target_Executable_Suffix;
878 Get_Name_String (Executable_Extension_On_Target);
879 Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len));
882 if Exec_Suffix'Length = 0 then
888 Suffix : constant String := Exec_Suffix.all;
892 Canonical_Case_File_Name (Canonical_Name);
895 if Only_If_No_Suffix then
896 for J in reverse 1 .. Name_Len loop
897 if Name_Buffer (J) = '.' then
901 elsif Name_Buffer (J) = '/' or else
902 Name_Buffer (J) = Directory_Separator
909 if Add_Suffix and then
910 (Canonical_Name'Length <= Suffix'Length
911 or else Canonical_Name (Canonical_Name'Last - Suffix'Length + 1
912 .. Canonical_Name'Last) /= Suffix)
915 Result : String (1 .. Name'Length + Suffix'Length);
917 Result (1 .. Name'Length) := Name;
918 Result (Name'Length + 1 .. Result'Last) := Suffix;
928 -----------------------
929 -- Executable_Prefix --
930 -----------------------
932 function Executable_Prefix return String_Ptr is
934 function Get_Install_Dir (Exec : String) return String_Ptr;
935 -- S is the executable name preceded by the absolute or relative
936 -- path, e.g. "c:\usr\bin\gcc.exe" or "..\bin\gcc".
938 ---------------------
939 -- Get_Install_Dir --
940 ---------------------
942 function Get_Install_Dir (Exec : String) return String_Ptr is
943 Full_Path : constant String := Normalize_Pathname (Exec);
944 -- Use the full path, so that we find "lib" or "bin", even when
945 -- the tool has been invoked with a relative path, as in
946 -- "./gnatls -v" invoked in the GNAT bin directory.
949 for J in reverse Full_Path'Range loop
950 if Is_Directory_Separator (Full_Path (J)) then
951 if J < Full_Path'Last - 5 then
952 if (To_Lower (Full_Path (J + 1)) = 'l'
953 and then To_Lower (Full_Path (J + 2)) = 'i'
954 and then To_Lower (Full_Path (J + 3)) = 'b')
956 (To_Lower (Full_Path (J + 1)) = 'b'
957 and then To_Lower (Full_Path (J + 2)) = 'i'
958 and then To_Lower (Full_Path (J + 3)) = 'n')
960 return new String'(Full_Path (Full_Path'First .. J));
966 return new String'("");
969 -- Start of processing for Executable_Prefix
972 if Exec_Name = null then
973 Exec_Name := new String (1 .. Len_Arg (0));
974 Osint.Fill_Arg (Exec_Name (1)'Address, 0);
977 -- First determine if a path prefix was placed in front of the
980 for J in reverse Exec_Name'Range loop
981 if Is_Directory_Separator (Exec_Name (J)) then
982 return Get_Install_Dir (Exec_Name.all);
986 -- If we come here, the user has typed the executable name with no
989 return Get_Install_Dir (Locate_Exec_On_Path (Exec_Name.all).all);
990 end Executable_Prefix;
996 procedure Exit_Program (Exit_Code : Exit_Code_Type) is
998 -- The program will exit with the following status:
1000 -- 0 if the object file has been generated (with or without warnings)
1001 -- 1 if recompilation was not needed (smart recompilation)
1002 -- 2 if gnat1 has been killed by a signal (detected by GCC)
1003 -- 4 for a fatal error
1004 -- 5 if there were errors
1005 -- 6 if no code has been generated (spec)
1007 -- Note that exit code 3 is not used and must not be used as this is
1008 -- the code returned by a program aborted via C abort() routine on
1009 -- Windows. GCC checks for that case and thinks that the child process
1010 -- has been aborted. This code (exit code 3) used to be the code used
1011 -- for E_No_Code, but E_No_Code was changed to 6 for this reason.
1014 when E_Success => OS_Exit (0);
1015 when E_Warnings => OS_Exit (0);
1016 when E_No_Compile => OS_Exit (1);
1017 when E_Fatal => OS_Exit (4);
1018 when E_Errors => OS_Exit (5);
1019 when E_No_Code => OS_Exit (6);
1020 when E_Abort => OS_Abort;
1028 procedure Fail (S : String) is
1030 -- We use Output in case there is a special output set up.
1031 -- In this case Set_Standard_Error will have no immediate effect.
1034 Osint.Write_Program_Name;
1039 Exit_Program (E_Fatal);
1046 function File_Hash (F : File_Name_Type) return File_Hash_Num is
1048 return File_Hash_Num (Int (F) rem File_Hash_Num'Range_Length);
1055 function File_Length
1056 (Name : C_File_Name;
1057 Attr : access File_Attributes) return Long_Integer
1062 A : System.Address) return Long_Integer;
1063 pragma Import (C, Internal, "__gnat_file_length_attr");
1065 return Internal (-1, Name, Attr.all'Address);
1068 ---------------------
1069 -- File_Time_Stamp --
1070 ---------------------
1072 function File_Time_Stamp
1073 (Name : C_File_Name;
1074 Attr : access File_Attributes) return OS_Time
1076 function Internal (N : C_File_Name; A : System.Address) return OS_Time;
1077 pragma Import (C, Internal, "__gnat_file_time_name_attr");
1079 return Internal (Name, Attr.all'Address);
1080 end File_Time_Stamp;
1086 function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type is
1088 if Name = No_File then
1089 return Empty_Time_Stamp;
1092 Get_Name_String (Name);
1094 -- File_Time_Stamp will always return Invalid_Time if the file does
1095 -- not exist, and OS_Time_To_GNAT_Time will convert this value to
1096 -- Empty_Time_Stamp. Therefore we do not need to first test whether
1097 -- the file actually exists, which saves a system call.
1099 return OS_Time_To_GNAT_Time
1100 (File_Time_Stamp (Name_Buffer (1 .. Name_Len)));
1103 function File_Stamp (Name : Path_Name_Type) return Time_Stamp_Type is
1105 return File_Stamp (File_Name_Type (Name));
1113 (N : File_Name_Type;
1114 T : File_Type) return File_Name_Type
1116 Attr : aliased File_Attributes;
1117 Found : File_Name_Type;
1119 Find_File (N, T, Found, Attr'Access);
1128 (N : File_Name_Type;
1130 Found : out File_Name_Type;
1131 Attr : access File_Attributes) is
1133 Get_Name_String (N);
1136 File_Name : String renames Name_Buffer (1 .. Name_Len);
1137 File : File_Name_Type := No_File;
1141 -- If we are looking for a config file, look only in the current
1142 -- directory, i.e. return input argument unchanged. Also look only in
1143 -- the curren directory if we are looking for a .dg file (happens in
1147 or else (Debug_Generated_Code
1148 and then Name_Len > 3
1150 (Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg"
1152 (Hostparm.OpenVMS and then
1153 Name_Buffer (Name_Len - 2 .. Name_Len) = "_dg")))
1156 Attr.all := Unknown_Attributes;
1159 -- If we are trying to find the current main file just look in the
1160 -- directory where the user said it was.
1162 elsif Look_In_Primary_Directory_For_Current_Main
1163 and then Current_Main = N
1165 Locate_File (N, T, Primary_Directory, File_Name, Found, Attr);
1168 -- Otherwise do standard search for source file
1171 -- Check the mapping of this file name
1173 File := Mapped_Path_Name (N);
1175 -- If the file name is mapped to a path name, return the
1176 -- corresponding path name
1178 if File /= No_File then
1180 -- For locally removed file, Error_Name is returned; then
1181 -- return No_File, indicating the file is not a source.
1183 if File = Error_File_Name then
1189 Attr.all := Unknown_Attributes;
1193 -- First place to look is in the primary directory (i.e. the same
1194 -- directory as the source) unless this has been disabled with -I-
1196 if Opt.Look_In_Primary_Dir then
1197 Locate_File (N, T, Primary_Directory, File_Name, Found, Attr);
1199 if Found /= No_File then
1204 -- Finally look in directories specified with switches -I/-aI/-aO
1207 Last_Dir := Lib_Search_Directories.Last;
1209 Last_Dir := Src_Search_Directories.Last;
1212 for D in Primary_Directory + 1 .. Last_Dir loop
1213 Locate_File (N, T, D, File_Name, Found, Attr);
1215 if Found /= No_File then
1220 Attr.all := Unknown_Attributes;
1226 -----------------------
1227 -- Find_Program_Name --
1228 -----------------------
1230 procedure Find_Program_Name is
1231 Command_Name : String (1 .. Len_Arg (0));
1232 Cindex1 : Integer := Command_Name'First;
1233 Cindex2 : Integer := Command_Name'Last;
1236 Fill_Arg (Command_Name'Address, 0);
1238 if Command_Name = "" then
1243 -- The program name might be specified by a full path name. However,
1244 -- we don't want to print that all out in an error message, so the
1245 -- path might need to be stripped away.
1247 for J in reverse Cindex1 .. Cindex2 loop
1248 if Is_Directory_Separator (Command_Name (J)) then
1254 -- Command_Name(Cindex1 .. Cindex2) is now the equivalent of the
1255 -- POSIX command "basename argv[0]"
1257 -- Strip off any versioning information such as found on VMS.
1258 -- This would take the form of TOOL.exe followed by a ";" or "."
1259 -- and a sequence of one or more numbers.
1261 if Command_Name (Cindex2) in '0' .. '9' then
1262 for J in reverse Cindex1 .. Cindex2 loop
1263 if Command_Name (J) = '.' or else Command_Name (J) = ';' then
1268 exit when Command_Name (J) not in '0' .. '9';
1272 -- Strip off any executable extension (usually nothing or .exe)
1273 -- but formally reported by autoconf in the variable EXEEXT
1275 if Cindex2 - Cindex1 >= 4 then
1276 if To_Lower (Command_Name (Cindex2 - 3)) = '.'
1277 and then To_Lower (Command_Name (Cindex2 - 2)) = 'e'
1278 and then To_Lower (Command_Name (Cindex2 - 1)) = 'x'
1279 and then To_Lower (Command_Name (Cindex2)) = 'e'
1281 Cindex2 := Cindex2 - 4;
1285 Name_Len := Cindex2 - Cindex1 + 1;
1286 Name_Buffer (1 .. Name_Len) := Command_Name (Cindex1 .. Cindex2);
1287 end Find_Program_Name;
1289 ------------------------
1290 -- Full_Lib_File_Name --
1291 ------------------------
1293 procedure Full_Lib_File_Name
1294 (N : File_Name_Type;
1295 Lib_File : out File_Name_Type;
1296 Attr : out File_Attributes)
1298 A : aliased File_Attributes;
1300 -- ??? seems we could use Smart_Find_File here
1301 Find_File (N, Library, Lib_File, A'Access);
1303 end Full_Lib_File_Name;
1305 ------------------------
1306 -- Full_Lib_File_Name --
1307 ------------------------
1309 function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type is
1310 Attr : File_Attributes;
1311 File : File_Name_Type;
1313 Full_Lib_File_Name (N, File, Attr);
1315 end Full_Lib_File_Name;
1317 ----------------------------
1318 -- Full_Library_Info_Name --
1319 ----------------------------
1321 function Full_Library_Info_Name return File_Name_Type is
1323 return Current_Full_Lib_Name;
1324 end Full_Library_Info_Name;
1326 ---------------------------
1327 -- Full_Object_File_Name --
1328 ---------------------------
1330 function Full_Object_File_Name return File_Name_Type is
1332 return Current_Full_Obj_Name;
1333 end Full_Object_File_Name;
1335 ----------------------
1336 -- Full_Source_Name --
1337 ----------------------
1339 function Full_Source_Name return File_Name_Type is
1341 return Current_Full_Source_Name;
1342 end Full_Source_Name;
1344 ----------------------
1345 -- Full_Source_Name --
1346 ----------------------
1348 function Full_Source_Name (N : File_Name_Type) return File_Name_Type is
1350 return Smart_Find_File (N, Source);
1351 end Full_Source_Name;
1353 ----------------------
1354 -- Full_Source_Name --
1355 ----------------------
1357 procedure Full_Source_Name
1358 (N : File_Name_Type;
1359 Full_File : out File_Name_Type;
1360 Attr : access File_Attributes) is
1362 Smart_Find_File (N, Source, Full_File, Attr.all);
1363 end Full_Source_Name;
1369 function Get_Directory (Name : File_Name_Type) return File_Name_Type is
1371 Get_Name_String (Name);
1373 for J in reverse 1 .. Name_Len loop
1374 if Is_Directory_Separator (Name_Buffer (J)) then
1380 Name_Len := Hostparm.Normalized_CWD'Length;
1381 Name_Buffer (1 .. Name_Len) := Hostparm.Normalized_CWD;
1385 --------------------------
1386 -- Get_Next_Dir_In_Path --
1387 --------------------------
1389 Search_Path_Pos : Integer;
1390 -- Keeps track of current position in search path. Initialized by the
1391 -- call to Get_Next_Dir_In_Path_Init, updated by Get_Next_Dir_In_Path.
1393 function Get_Next_Dir_In_Path
1394 (Search_Path : String_Access) return String_Access
1396 Lower_Bound : Positive := Search_Path_Pos;
1397 Upper_Bound : Positive;
1401 while Lower_Bound <= Search_Path'Last
1402 and then Search_Path.all (Lower_Bound) = Path_Separator
1404 Lower_Bound := Lower_Bound + 1;
1407 exit when Lower_Bound > Search_Path'Last;
1409 Upper_Bound := Lower_Bound;
1410 while Upper_Bound <= Search_Path'Last
1411 and then Search_Path.all (Upper_Bound) /= Path_Separator
1413 Upper_Bound := Upper_Bound + 1;
1416 Search_Path_Pos := Upper_Bound;
1417 return new String'(Search_Path.all (Lower_Bound .. Upper_Bound - 1));
1421 end Get_Next_Dir_In_Path;
1423 -------------------------------
1424 -- Get_Next_Dir_In_Path_Init --
1425 -------------------------------
1427 procedure Get_Next_Dir_In_Path_Init (Search_Path : String_Access) is
1429 Search_Path_Pos := Search_Path'First;
1430 end Get_Next_Dir_In_Path_Init;
1432 --------------------------------------
1433 -- Get_Primary_Src_Search_Directory --
1434 --------------------------------------
1436 function Get_Primary_Src_Search_Directory return String_Ptr is
1438 return Src_Search_Directories.Table (Primary_Directory);
1439 end Get_Primary_Src_Search_Directory;
1441 ------------------------
1442 -- Get_RTS_Search_Dir --
1443 ------------------------
1445 function Get_RTS_Search_Dir
1446 (Search_Dir : String;
1447 File_Type : Search_File_Type) return String_Ptr
1449 procedure Get_Current_Dir
1450 (Dir : System.Address;
1451 Length : System.Address);
1452 pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir");
1455 pragma Import (C, Max_Path, "__gnat_max_path_len");
1456 -- Maximum length of a path name
1458 Current_Dir : String_Ptr;
1459 Default_Search_Dir : String_Access;
1460 Default_Suffix_Dir : String_Access;
1461 Local_Search_Dir : String_Access;
1462 Norm_Search_Dir : String_Access;
1463 Result_Search_Dir : String_Access;
1464 Search_File : String_Access;
1465 Temp_String : String_Ptr;
1468 -- Add a directory separator at the end of the directory if necessary
1469 -- so that we can directly append a file to the directory
1471 if Search_Dir (Search_Dir'Last) /= Directory_Separator then
1473 new String'(Search_Dir & String'(1 => Directory_Separator));
1475 Local_Search_Dir := new String'(Search_Dir);
1478 if File_Type = Include then
1479 Search_File := Include_Search_File;
1480 Default_Suffix_Dir := new String'("adainclude");
1482 Search_File := Objects_Search_File;
1483 Default_Suffix_Dir := new String'("adalib");
1486 Norm_Search_Dir := To_Canonical_Path_Spec (Local_Search_Dir.all);
1488 if Is_Absolute_Path (Norm_Search_Dir.all) then
1490 -- We first verify if there is a directory Include_Search_Dir
1491 -- containing default search directories
1493 Result_Search_Dir :=
1494 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1495 Default_Search_Dir :=
1496 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1497 Free (Norm_Search_Dir);
1499 if Result_Search_Dir /= null then
1500 return String_Ptr (Result_Search_Dir);
1501 elsif Is_Directory (Default_Search_Dir.all) then
1502 return String_Ptr (Default_Search_Dir);
1507 -- Search in the current directory
1510 -- Get the current directory
1513 Buffer : String (1 .. Max_Path + 2);
1514 Path_Len : Natural := Max_Path;
1517 Get_Current_Dir (Buffer'Address, Path_Len'Address);
1519 if Buffer (Path_Len) /= Directory_Separator then
1520 Path_Len := Path_Len + 1;
1521 Buffer (Path_Len) := Directory_Separator;
1524 Current_Dir := new String'(Buffer (1 .. Path_Len));
1528 new String'(Current_Dir.all & Local_Search_Dir.all);
1530 Result_Search_Dir :=
1531 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1533 Default_Search_Dir :=
1534 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1536 Free (Norm_Search_Dir);
1538 if Result_Search_Dir /= null then
1539 return String_Ptr (Result_Search_Dir);
1541 elsif Is_Directory (Default_Search_Dir.all) then
1542 return String_Ptr (Default_Search_Dir);
1545 -- Search in Search_Dir_Prefix/Search_Dir
1549 (Update_Path (Search_Dir_Prefix).all & Local_Search_Dir.all);
1551 Result_Search_Dir :=
1552 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1554 Default_Search_Dir :=
1555 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1557 Free (Norm_Search_Dir);
1559 if Result_Search_Dir /= null then
1560 return String_Ptr (Result_Search_Dir);
1562 elsif Is_Directory (Default_Search_Dir.all) then
1563 return String_Ptr (Default_Search_Dir);
1566 -- We finally search in Search_Dir_Prefix/rts-Search_Dir
1569 new String'(Update_Path (Search_Dir_Prefix).all & "rts-");
1572 new String'(Temp_String.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);
1579 Free (Norm_Search_Dir);
1581 if Result_Search_Dir /= null then
1582 return String_Ptr (Result_Search_Dir);
1584 elsif Is_Directory (Default_Search_Dir.all) then
1585 return String_Ptr (Default_Search_Dir);
1593 end Get_RTS_Search_Dir;
1595 --------------------------------
1596 -- Include_Dir_Default_Prefix --
1597 --------------------------------
1599 function Include_Dir_Default_Prefix return String_Access is
1601 if The_Include_Dir_Default_Prefix = null then
1602 The_Include_Dir_Default_Prefix :=
1603 String_Access (Update_Path (Include_Dir_Default_Name));
1606 return The_Include_Dir_Default_Prefix;
1607 end Include_Dir_Default_Prefix;
1609 function Include_Dir_Default_Prefix return String is
1611 return Include_Dir_Default_Prefix.all;
1612 end Include_Dir_Default_Prefix;
1618 procedure Initialize is
1620 Number_File_Names := 0;
1621 Current_File_Name_Index := 0;
1623 Src_Search_Directories.Init;
1624 Lib_Search_Directories.Init;
1626 -- Start off by setting all suppress options to False, these will
1627 -- be reset later (turning some on if -gnato is not specified, and
1628 -- turning all of them on if -gnatp is specified).
1630 Suppress_Options := (others => False);
1632 -- Reserve the first slot in the search paths table. This is the
1633 -- directory of the main source file or main library file and is filled
1634 -- in by each call to Next_Main_Source/Next_Main_Lib_File with the
1635 -- directory specified for this main source or library file. This is the
1636 -- directory which is searched first by default. This default search is
1637 -- inhibited by the option -I- for both source and library files.
1639 Src_Search_Directories.Set_Last (Primary_Directory);
1640 Src_Search_Directories.Table (Primary_Directory) := new String'("");
1642 Lib_Search_Directories.Set_Last (Primary_Directory);
1643 Lib_Search_Directories.Table (Primary_Directory) := new String'("");
1650 function Is_Directory
1651 (Name : C_File_Name; Attr : access File_Attributes) return Boolean
1653 function Internal (N : C_File_Name; A : System.Address) return Integer;
1654 pragma Import (C, Internal, "__gnat_is_directory_attr");
1656 return Internal (Name, Attr.all'Address) /= 0;
1659 ----------------------------
1660 -- Is_Directory_Separator --
1661 ----------------------------
1663 function Is_Directory_Separator (C : Character) return Boolean is
1665 -- In addition to the default directory_separator allow the '/' to
1666 -- act as separator since this is allowed in MS-DOS, Windows 95/NT,
1667 -- and OS2 ports. On VMS, the situation is more complicated because
1668 -- there are two characters to check for.
1671 C = Directory_Separator
1673 or else (Hostparm.OpenVMS
1674 and then (C = ']' or else C = ':'));
1675 end Is_Directory_Separator;
1677 -------------------------
1678 -- Is_Readonly_Library --
1679 -------------------------
1681 function Is_Readonly_Library (File : File_Name_Type) return Boolean is
1683 Get_Name_String (File);
1685 pragma Assert (Name_Buffer (Name_Len - 3 .. Name_Len) = ".ali");
1687 return not Is_Writable_File (Name_Buffer (1 .. Name_Len));
1688 end Is_Readonly_Library;
1690 ------------------------
1691 -- Is_Executable_File --
1692 ------------------------
1694 function Is_Executable_File
1695 (Name : C_File_Name; Attr : access File_Attributes) return Boolean
1697 function Internal (N : C_File_Name; A : System.Address) return Integer;
1698 pragma Import (C, Internal, "__gnat_is_executable_file_attr");
1700 return Internal (Name, Attr.all'Address) /= 0;
1701 end Is_Executable_File;
1703 ----------------------
1704 -- Is_Readable_File --
1705 ----------------------
1707 function Is_Readable_File
1708 (Name : C_File_Name; Attr : access File_Attributes) return Boolean
1710 function Internal (N : C_File_Name; A : System.Address) return Integer;
1711 pragma Import (C, Internal, "__gnat_is_readable_file_attr");
1713 return Internal (Name, Attr.all'Address) /= 0;
1714 end Is_Readable_File;
1716 ---------------------
1717 -- Is_Regular_File --
1718 ---------------------
1720 function Is_Regular_File
1721 (Name : C_File_Name; Attr : access File_Attributes) return Boolean
1723 function Internal (N : C_File_Name; A : System.Address) return Integer;
1724 pragma Import (C, Internal, "__gnat_is_regular_file_attr");
1726 return Internal (Name, Attr.all'Address) /= 0;
1727 end Is_Regular_File;
1729 ----------------------
1730 -- Is_Symbolic_Link --
1731 ----------------------
1733 function Is_Symbolic_Link
1734 (Name : C_File_Name; Attr : access File_Attributes) return Boolean
1736 function Internal (N : C_File_Name; A : System.Address) return Integer;
1737 pragma Import (C, Internal, "__gnat_is_symbolic_link_attr");
1739 return Internal (Name, Attr.all'Address) /= 0;
1740 end Is_Symbolic_Link;
1742 ----------------------
1743 -- Is_Writable_File --
1744 ----------------------
1746 function Is_Writable_File
1747 (Name : C_File_Name; Attr : access File_Attributes) return Boolean
1749 function Internal (N : C_File_Name; A : System.Address) return Integer;
1750 pragma Import (C, Internal, "__gnat_is_writable_file_attr");
1752 return Internal (Name, Attr.all'Address) /= 0;
1753 end Is_Writable_File;
1759 function Lib_File_Name
1760 (Source_File : File_Name_Type;
1761 Munit_Index : Nat := 0) return File_Name_Type
1764 Get_Name_String (Source_File);
1766 for J in reverse 2 .. Name_Len loop
1767 if Name_Buffer (J) = '.' then
1773 if Munit_Index /= 0 then
1774 Add_Char_To_Name_Buffer (Multi_Unit_Index_Character);
1775 Add_Nat_To_Name_Buffer (Munit_Index);
1778 Add_Char_To_Name_Buffer ('.');
1779 Add_Str_To_Name_Buffer (ALI_Suffix.all);
1787 procedure Locate_File
1788 (N : File_Name_Type;
1792 Found : out File_Name_Type;
1793 Attr : access File_Attributes)
1795 Dir_Name : String_Ptr;
1798 -- If Name is already an absolute path, do not look for a directory
1800 if Is_Absolute_Path (Name) then
1803 elsif T = Library then
1804 Dir_Name := Lib_Search_Directories.Table (Dir);
1807 pragma Assert (T /= Config);
1808 Dir_Name := Src_Search_Directories.Table (Dir);
1812 Full_Name : String (1 .. Dir_Name'Length + Name'Length + 1);
1815 Full_Name (1 .. Dir_Name'Length) := Dir_Name.all;
1816 Full_Name (Dir_Name'Length + 1 .. Full_Name'Last - 1) := Name;
1817 Full_Name (Full_Name'Last) := ASCII.NUL;
1819 Attr.all := Unknown_Attributes;
1821 if not Is_Regular_File (Full_Name'Address, Attr) then
1825 -- If the file is in the current directory then return N itself
1827 if Dir_Name'Length = 0 then
1830 Name_Len := Full_Name'Length - 1;
1831 Name_Buffer (1 .. Name_Len) :=
1832 Full_Name (1 .. Full_Name'Last - 1);
1833 Found := Name_Find; -- ??? Was Name_Enter, no obvious reason
1839 -------------------------------
1840 -- Matching_Full_Source_Name --
1841 -------------------------------
1843 function Matching_Full_Source_Name
1844 (N : File_Name_Type;
1845 T : Time_Stamp_Type) return File_Name_Type
1848 Get_Name_String (N);
1851 File_Name : constant String := Name_Buffer (1 .. Name_Len);
1852 File : File_Name_Type := No_File;
1853 Attr : aliased File_Attributes;
1857 if Opt.Look_In_Primary_Dir then
1859 (N, Source, Primary_Directory, File_Name, File, Attr'Access);
1861 if File /= No_File and then T = File_Stamp (N) then
1866 Last_Dir := Src_Search_Directories.Last;
1868 for D in Primary_Directory + 1 .. Last_Dir loop
1869 Locate_File (N, Source, D, File_Name, File, Attr'Access);
1871 if File /= No_File and then T = File_Stamp (File) then
1878 end Matching_Full_Source_Name;
1884 function More_Files return Boolean is
1886 return (Current_File_Name_Index < Number_File_Names);
1889 -------------------------------
1890 -- Nb_Dir_In_Obj_Search_Path --
1891 -------------------------------
1893 function Nb_Dir_In_Obj_Search_Path return Natural is
1895 if Opt.Look_In_Primary_Dir then
1896 return Lib_Search_Directories.Last - Primary_Directory + 1;
1898 return Lib_Search_Directories.Last - Primary_Directory;
1900 end Nb_Dir_In_Obj_Search_Path;
1902 -------------------------------
1903 -- Nb_Dir_In_Src_Search_Path --
1904 -------------------------------
1906 function Nb_Dir_In_Src_Search_Path return Natural is
1908 if Opt.Look_In_Primary_Dir then
1909 return Src_Search_Directories.Last - Primary_Directory + 1;
1911 return Src_Search_Directories.Last - Primary_Directory;
1913 end Nb_Dir_In_Src_Search_Path;
1915 --------------------
1916 -- Next_Main_File --
1917 --------------------
1919 function Next_Main_File return File_Name_Type is
1920 File_Name : String_Ptr;
1921 Dir_Name : String_Ptr;
1925 pragma Assert (More_Files);
1927 Current_File_Name_Index := Current_File_Name_Index + 1;
1929 -- Get the file and directory name
1931 File_Name := File_Names (Current_File_Name_Index);
1932 Fptr := File_Name'First;
1934 for J in reverse File_Name'Range loop
1935 if File_Name (J) = Directory_Separator
1936 or else File_Name (J) = '/'
1938 if J = File_Name'Last then
1939 Fail ("File name missing");
1947 -- Save name of directory in which main unit resides for use in
1948 -- locating other units
1950 Dir_Name := new String'(File_Name (File_Name'First .. Fptr - 1));
1952 case Running_Program is
1955 Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
1956 Look_In_Primary_Directory_For_Current_Main := True;
1959 Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
1961 if Fptr > File_Name'First then
1962 Look_In_Primary_Directory_For_Current_Main := True;
1965 when Binder | Gnatls =>
1966 Dir_Name := Normalize_Directory_Name (Dir_Name.all);
1967 Lib_Search_Directories.Table (Primary_Directory) := Dir_Name;
1973 Name_Len := File_Name'Last - Fptr + 1;
1974 Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last);
1975 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
1976 Current_Main := Name_Find;
1978 -- In the gnatmake case, the main file may have not have the
1979 -- extension. Try ".adb" first then ".ads"
1981 if Running_Program = Make then
1983 Orig_Main : constant File_Name_Type := Current_Main;
1986 if Strip_Suffix (Orig_Main) = Orig_Main then
1988 Append_Suffix_To_File_Name (Orig_Main, ".adb");
1990 if Full_Source_Name (Current_Main) = No_File then
1992 Append_Suffix_To_File_Name (Orig_Main, ".ads");
1994 if Full_Source_Name (Current_Main) = No_File then
1995 Current_Main := Orig_Main;
2002 return Current_Main;
2005 ------------------------------
2006 -- Normalize_Directory_Name --
2007 ------------------------------
2009 function Normalize_Directory_Name (Directory : String) return String_Ptr is
2011 function Is_Quoted (Path : String) return Boolean;
2012 pragma Inline (Is_Quoted);
2013 -- Returns true if Path is quoted (either double or single quotes)
2019 function Is_Quoted (Path : String) return Boolean is
2020 First : constant Character := Path (Path'First);
2021 Last : constant Character := Path (Path'Last);
2024 if (First = ''' and then Last = ''')
2026 (First = '"' and then Last = '"')
2034 Result : String_Ptr;
2036 -- Start of processing for Normalize_Directory_Name
2039 if Directory'Length = 0 then
2040 Result := new String'(Hostparm.Normalized_CWD);
2042 elsif Is_Directory_Separator (Directory (Directory'Last)) then
2043 Result := new String'(Directory);
2045 elsif Is_Quoted (Directory) then
2047 -- This is a quoted string, it certainly means that the directory
2048 -- contains some spaces for example. We can safely remove the quotes
2049 -- here as the OS_Lib.Normalize_Arguments will be called before any
2050 -- spawn routines. This ensure that quotes will be added when needed.
2052 Result := new String (1 .. Directory'Length - 1);
2053 Result (1 .. Directory'Length - 2) :=
2054 Directory (Directory'First + 1 .. Directory'Last - 1);
2055 Result (Result'Last) := Directory_Separator;
2058 Result := new String (1 .. Directory'Length + 1);
2059 Result (1 .. Directory'Length) := Directory;
2060 Result (Directory'Length + 1) := Directory_Separator;
2064 end Normalize_Directory_Name;
2066 ---------------------
2067 -- Number_Of_Files --
2068 ---------------------
2070 function Number_Of_Files return Int is
2072 return Number_File_Names;
2073 end Number_Of_Files;
2075 -------------------------------
2076 -- Object_Dir_Default_Prefix --
2077 -------------------------------
2079 function Object_Dir_Default_Prefix return String is
2080 Object_Dir : String_Access :=
2081 String_Access (Update_Path (Object_Dir_Default_Name));
2084 if Object_Dir = null then
2089 Result : constant String := Object_Dir.all;
2095 end Object_Dir_Default_Prefix;
2097 ----------------------
2098 -- Object_File_Name --
2099 ----------------------
2101 function Object_File_Name (N : File_Name_Type) return File_Name_Type is
2107 Get_Name_String (N);
2108 Name_Len := Name_Len - ALI_Suffix'Length - 1;
2110 for J in Target_Object_Suffix'Range loop
2111 Name_Len := Name_Len + 1;
2112 Name_Buffer (Name_Len) := Target_Object_Suffix (J);
2116 end Object_File_Name;
2118 -------------------------------
2119 -- OS_Exit_Through_Exception --
2120 -------------------------------
2122 procedure OS_Exit_Through_Exception (Status : Integer) is
2124 Current_Exit_Status := Status;
2125 raise Types.Terminate_Program;
2126 end OS_Exit_Through_Exception;
2128 --------------------------
2129 -- OS_Time_To_GNAT_Time --
2130 --------------------------
2132 function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type is
2133 GNAT_Time : Time_Stamp_Type;
2143 if T = Invalid_Time then
2144 return Empty_Time_Stamp;
2147 GM_Split (T, Y, Mo, D, H, Mn, S);
2153 Minutes => Nat (Mn),
2158 end OS_Time_To_GNAT_Time;
2164 function Program_Name (Nam : String; Prog : String) return String_Access is
2165 End_Of_Prefix : Natural := 0;
2166 Start_Of_Prefix : Positive := 1;
2167 Start_Of_Suffix : Positive;
2170 -- GNAAMP tool names require special treatment
2172 if AAMP_On_Target then
2174 -- The name "gcc" is mapped to "gnaamp" (the compiler driver)
2177 return new String'("gnaamp");
2179 -- Tool names starting with "gnat" are mapped by substituting the
2180 -- string "gnaamp" for "gnat" (for example, "gnatpp" => "gnaamppp").
2182 elsif Nam'Length >= 4
2183 and then Nam (Nam'First .. Nam'First + 3) = "gnat"
2185 return new String'("gnaamp" & Nam (Nam'First + 4 .. Nam'Last));
2187 -- No other mapping rules, so we continue and handle any other forms
2188 -- of tool names the same as on other targets.
2195 -- Get the name of the current program being executed
2199 Start_Of_Suffix := Name_Len + 1;
2201 -- Find the target prefix if any, for the cross compilation case.
2202 -- For instance in "powerpc-elf-gcc" the target prefix is
2204 -- Ditto for suffix, e.g. in "gcc-4.1", the suffix is "-4.1"
2206 for J in reverse 1 .. Name_Len loop
2207 if Name_Buffer (J) = '/'
2208 or else Name_Buffer (J) = Directory_Separator
2209 or else Name_Buffer (J) = ':'
2211 Start_Of_Prefix := J + 1;
2216 -- Find End_Of_Prefix
2218 for J in Start_Of_Prefix .. Name_Len - Prog'Length + 1 loop
2219 if Name_Buffer (J .. J + Prog'Length - 1) = Prog then
2220 End_Of_Prefix := J - 1;
2225 if End_Of_Prefix > 1 then
2226 Start_Of_Suffix := End_Of_Prefix + Prog'Length + 1;
2229 -- Create the new program name
2232 (Name_Buffer (Start_Of_Prefix .. End_Of_Prefix)
2234 & Name_Buffer (Start_Of_Suffix .. Name_Len));
2237 ------------------------------
2238 -- Read_Default_Search_Dirs --
2239 ------------------------------
2241 function Read_Default_Search_Dirs
2242 (Search_Dir_Prefix : String_Access;
2243 Search_File : String_Access;
2244 Search_Dir_Default_Name : String_Access) return String_Access
2246 Prefix_Len : constant Integer := Search_Dir_Prefix.all'Length;
2247 Buffer : String (1 .. Prefix_Len + Search_File.all'Length + 1);
2248 File_FD : File_Descriptor;
2249 S, S1 : String_Access;
2252 Actual_Len : Integer;
2255 Prev_Was_Separator : Boolean;
2256 Nb_Relative_Dir : Integer;
2258 function Is_Relative (S : String; K : Positive) return Boolean;
2259 pragma Inline (Is_Relative);
2260 -- Returns True if a relative directory specification is found
2261 -- in S at position K, False otherwise.
2267 function Is_Relative (S : String; K : Positive) return Boolean is
2269 return not Is_Absolute_Path (S (K .. S'Last));
2272 -- Start of processing for Read_Default_Search_Dirs
2275 -- Construct a C compatible character string buffer
2277 Buffer (1 .. Search_Dir_Prefix.all'Length)
2278 := Search_Dir_Prefix.all;
2279 Buffer (Search_Dir_Prefix.all'Length + 1 .. Buffer'Last - 1)
2281 Buffer (Buffer'Last) := ASCII.NUL;
2283 File_FD := Open_Read (Buffer'Address, Binary);
2284 if File_FD = Invalid_FD then
2285 return Search_Dir_Default_Name;
2288 Len := Integer (File_Length (File_FD));
2290 -- An extra character for a trailing Path_Separator is allocated
2292 S := new String (1 .. Len + 1);
2293 S (Len + 1) := Path_Separator;
2295 -- Read the file. Note that the loop is not necessary since the
2296 -- whole file is read at once except on VMS.
2300 while Actual_Len /= 0 loop
2301 Actual_Len := Read (File_FD, S (Curr)'Address, Len);
2302 Curr := Curr + Actual_Len;
2305 -- Process the file, dealing with path separators
2307 Prev_Was_Separator := True;
2308 Nb_Relative_Dir := 0;
2309 for J in 1 .. Len loop
2311 -- Treat any control character as a path separator. Note that we do
2312 -- not treat space as a path separator (we used to treat space as a
2313 -- path separator in an earlier version). That way space can appear
2314 -- as a legitimate character in a path name.
2316 -- Why do we treat all control characters as path separators???
2318 if S (J) in ASCII.NUL .. ASCII.US then
2319 S (J) := Path_Separator;
2322 -- Test for explicit path separator (or control char as above)
2324 if S (J) = Path_Separator then
2325 Prev_Was_Separator := True;
2327 -- If not path separator, register use of relative directory
2330 if Prev_Was_Separator and then Is_Relative (S.all, J) then
2331 Nb_Relative_Dir := Nb_Relative_Dir + 1;
2334 Prev_Was_Separator := False;
2338 if Nb_Relative_Dir = 0 then
2342 -- Add the Search_Dir_Prefix to all relative paths
2344 S1 := new String (1 .. S'Length + Nb_Relative_Dir * Prefix_Len);
2346 Prev_Was_Separator := True;
2347 for J in 1 .. Len + 1 loop
2348 if S (J) = Path_Separator then
2349 Prev_Was_Separator := True;
2352 if Prev_Was_Separator and then Is_Relative (S.all, J) then
2353 S1 (J1 .. J1 + Prefix_Len - 1) := Search_Dir_Prefix.all;
2354 J1 := J1 + Prefix_Len;
2357 Prev_Was_Separator := False;
2365 end Read_Default_Search_Dirs;
2367 -----------------------
2368 -- Read_Library_Info --
2369 -----------------------
2371 function Read_Library_Info
2372 (Lib_File : File_Name_Type;
2373 Fatal_Err : Boolean := False) return Text_Buffer_Ptr
2375 File : File_Name_Type;
2376 Attr : aliased File_Attributes;
2378 Find_File (Lib_File, Library, File, Attr'Access);
2379 return Read_Library_Info_From_Full
2380 (Full_Lib_File => File,
2381 Lib_File_Attr => Attr'Access,
2382 Fatal_Err => Fatal_Err);
2383 end Read_Library_Info;
2385 ---------------------------------
2386 -- Read_Library_Info_From_Full --
2387 ---------------------------------
2389 function Read_Library_Info_From_Full
2390 (Full_Lib_File : File_Name_Type;
2391 Lib_File_Attr : access File_Attributes;
2392 Fatal_Err : Boolean := False) return Text_Buffer_Ptr
2394 Lib_FD : File_Descriptor;
2395 -- The file descriptor for the current library file. A negative value
2396 -- indicates failure to open the specified source file.
2399 -- Length of source file text (ALI). If it doesn't fit in an integer
2400 -- we're probably stuck anyway (>2 gigs of source seems a lot!)
2402 Text : Text_Buffer_Ptr;
2403 -- Allocated text buffer
2406 pragma Warnings (Off, Status);
2407 -- For the calls to Close
2410 Current_Full_Lib_Name := Full_Lib_File;
2411 Current_Full_Obj_Name := Object_File_Name (Current_Full_Lib_Name);
2413 if Current_Full_Lib_Name = No_File then
2415 Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
2417 Current_Full_Obj_Stamp := Empty_Time_Stamp;
2422 Get_Name_String (Current_Full_Lib_Name);
2423 Name_Buffer (Name_Len + 1) := ASCII.NUL;
2425 -- Open the library FD, note that we open in binary mode, because as
2426 -- documented in the spec, the caller is expected to handle either
2427 -- DOS or Unix mode files, and there is no point in wasting time on
2428 -- text translation when it is not required.
2430 Lib_FD := Open_Read (Name_Buffer'Address, Binary);
2432 if Lib_FD = Invalid_FD then
2434 Fail ("Cannot open: " & Name_Buffer (1 .. Name_Len));
2436 Current_Full_Obj_Stamp := Empty_Time_Stamp;
2441 -- Compute the length of the file (potentially also preparing other data
2442 -- like the timestamp and whether the file is read-only, for future use)
2444 Len := Integer (File_Length (Name_Buffer'Address, Lib_File_Attr));
2446 -- Check for object file consistency if requested
2448 if Opt.Check_Object_Consistency then
2449 -- On most systems, this does not result in an extra system call
2451 Current_Full_Lib_Stamp :=
2452 OS_Time_To_GNAT_Time
2453 (File_Time_Stamp (Name_Buffer'Address, Lib_File_Attr));
2455 -- ??? One system call here
2457 Current_Full_Obj_Stamp := File_Stamp (Current_Full_Obj_Name);
2459 if Current_Full_Obj_Stamp (1) = ' ' then
2461 -- When the library is readonly always assume object is consistent
2462 -- The call to Is_Writable_File only results in a system call on
2463 -- some systems, but in most cases it has already been computed as
2464 -- part of the call to File_Length above.
2466 Get_Name_String (Current_Full_Lib_Name);
2467 Name_Buffer (Name_Len + 1) := ASCII.NUL;
2469 if not Is_Writable_File (Name_Buffer'Address, Lib_File_Attr) then
2470 Current_Full_Obj_Stamp := Current_Full_Lib_Stamp;
2472 elsif Fatal_Err then
2473 Get_Name_String (Current_Full_Obj_Name);
2474 Close (Lib_FD, Status);
2476 -- No need to check the status, we fail anyway
2478 Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
2481 Current_Full_Obj_Stamp := Empty_Time_Stamp;
2482 Close (Lib_FD, Status);
2484 -- No need to check the status, we return null anyway
2491 -- Read data from the file
2494 Actual_Len : Integer := 0;
2496 Lo : constant Text_Ptr := 0;
2497 -- Low bound for allocated text buffer
2499 Hi : Text_Ptr := Text_Ptr (Len);
2500 -- High bound for allocated text buffer. Note length is Len + 1
2501 -- which allows for extra EOF character at the end of the buffer.
2504 -- Allocate text buffer. Note extra character at end for EOF
2506 Text := new Text_Buffer (Lo .. Hi);
2508 -- Some systems (e.g. VMS) have file types that require one
2509 -- read per line, so read until we get the Len bytes or until
2510 -- there are no more characters.
2514 Actual_Len := Read (Lib_FD, Text (Hi)'Address, Len);
2515 Hi := Hi + Text_Ptr (Actual_Len);
2516 exit when Actual_Len = Len or else Actual_Len <= 0;
2522 -- Read is complete, close file and we are done
2524 Close (Lib_FD, Status);
2525 -- The status should never be False. But, if it is, what can we do?
2526 -- So, we don't test it.
2530 end Read_Library_Info_From_Full;
2532 ----------------------
2533 -- Read_Source_File --
2534 ----------------------
2536 procedure Read_Source_File
2537 (N : File_Name_Type;
2539 Hi : out Source_Ptr;
2540 Src : out Source_Buffer_Ptr;
2541 T : File_Type := Source)
2543 Source_File_FD : File_Descriptor;
2544 -- The file descriptor for the current source file. A negative value
2545 -- indicates failure to open the specified source file.
2548 -- Length of file. Assume no more than 2 gigabytes of source!
2550 Actual_Len : Integer;
2553 pragma Warnings (Off, Status);
2554 -- For the call to Close
2557 Current_Full_Source_Name := Find_File (N, T);
2558 Current_Full_Source_Stamp := File_Stamp (Current_Full_Source_Name);
2560 if Current_Full_Source_Name = No_File then
2562 -- If we were trying to access the main file and we could not find
2563 -- it, we have an error.
2565 if N = Current_Main then
2566 Get_Name_String (N);
2567 Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
2575 Get_Name_String (Current_Full_Source_Name);
2576 Name_Buffer (Name_Len + 1) := ASCII.NUL;
2578 -- Open the source FD, note that we open in binary mode, because as
2579 -- documented in the spec, the caller is expected to handle either
2580 -- DOS or Unix mode files, and there is no point in wasting time on
2581 -- text translation when it is not required.
2583 Source_File_FD := Open_Read (Name_Buffer'Address, Binary);
2585 if Source_File_FD = Invalid_FD then
2591 -- Print out the file name, if requested, and if it's not part of the
2592 -- runtimes, store it in File_Name_Chars.
2595 Name : String renames Name_Buffer (1 .. Name_Len);
2596 Inc : String renames Include_Dir_Default_Prefix.all;
2599 if Debug.Debug_Flag_Dot_N then
2604 and then Inc'Length < Name_Len
2605 and then Name_Buffer (1 .. Inc'Length) = Inc
2607 -- Part of runtimes, so ignore it
2612 File_Name_Chars.Append_All (File_Name_Chars.Table_Type (Name));
2613 File_Name_Chars.Append (ASCII.LF);
2617 -- Prepare to read data from the file
2619 Len := Integer (File_Length (Source_File_FD));
2621 -- Set Hi so that length is one more than the physical length,
2622 -- allowing for the extra EOF character at the end of the buffer
2624 Hi := Lo + Source_Ptr (Len);
2626 -- Do the actual read operation
2629 subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
2630 -- Physical buffer allocated
2632 type Actual_Source_Ptr is access Actual_Source_Buffer;
2633 -- This is the pointer type for the physical buffer allocated
2635 Actual_Ptr : constant Actual_Source_Ptr := new Actual_Source_Buffer;
2636 -- And this is the actual physical buffer
2639 -- Allocate source buffer, allowing extra character at end for EOF
2641 -- Some systems (e.g. VMS) have file types that require one read per
2642 -- line, so read until we get the Len bytes or until there are no
2647 Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len);
2648 Hi := Hi + Source_Ptr (Actual_Len);
2649 exit when Actual_Len = Len or else Actual_Len <= 0;
2652 Actual_Ptr (Hi) := EOF;
2654 -- Now we need to work out the proper virtual origin pointer to
2655 -- return. This is exactly Actual_Ptr (0)'Address, but we have to
2656 -- be careful to suppress checks to compute this address.
2659 pragma Suppress (All_Checks);
2661 pragma Warnings (Off);
2662 -- This use of unchecked conversion is aliasing safe
2664 function To_Source_Buffer_Ptr is new
2665 Unchecked_Conversion (Address, Source_Buffer_Ptr);
2667 pragma Warnings (On);
2670 Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
2674 -- Read is complete, get time stamp and close file and we are done
2676 Close (Source_File_FD, Status);
2678 -- The status should never be False. But, if it is, what can we do?
2679 -- So, we don't test it.
2681 end Read_Source_File;
2687 function Relocate_Path
2689 Path : String) return String_Ptr
2693 procedure set_std_prefix (S : String; Len : Integer);
2694 pragma Import (C, set_std_prefix);
2697 if Std_Prefix = null then
2698 Std_Prefix := Executable_Prefix;
2700 if Std_Prefix.all /= "" then
2702 -- Remove trailing directory separator when calling set_std_prefix
2704 set_std_prefix (Std_Prefix.all, Std_Prefix'Length - 1);
2708 if Path (Prefix'Range) = Prefix then
2709 if Std_Prefix.all /= "" then
2711 (1 .. Std_Prefix'Length + Path'Last - Prefix'Last);
2712 S (1 .. Std_Prefix'Length) := Std_Prefix.all;
2713 S (Std_Prefix'Length + 1 .. S'Last) :=
2714 Path (Prefix'Last + 1 .. Path'Last);
2719 return new String'(Path);
2726 procedure Set_Program (P : Program_Type) is
2729 Fail ("Set_Program called twice");
2732 Program_Set := True;
2733 Running_Program := P;
2740 function Shared_Lib (Name : String) return String is
2741 Library : String (1 .. Name'Length + Library_Version'Length + 3);
2742 -- 3 = 2 for "-l" + 1 for "-" before lib version
2745 Library (1 .. 2) := "-l";
2746 Library (3 .. 2 + Name'Length) := Name;
2747 Library (3 + Name'Length) := '-';
2748 Library (4 + Name'Length .. Library'Last) := Library_Version;
2750 if OpenVMS_On_Target then
2751 for K in Library'First + 2 .. Library'Last loop
2752 if Library (K) = '.' or else Library (K) = '-' then
2761 ----------------------
2762 -- Smart_File_Stamp --
2763 ----------------------
2765 function Smart_File_Stamp
2766 (N : File_Name_Type;
2767 T : File_Type) return Time_Stamp_Type
2769 File : File_Name_Type;
2770 Attr : aliased File_Attributes;
2773 if not File_Cache_Enabled then
2774 Find_File (N, T, File, Attr'Access);
2776 Smart_Find_File (N, T, File, Attr);
2779 if File = No_File then
2780 return Empty_Time_Stamp;
2782 Get_Name_String (File);
2783 Name_Buffer (Name_Len + 1) := ASCII.NUL;
2785 OS_Time_To_GNAT_Time
2786 (File_Time_Stamp (Name_Buffer'Address, Attr'Access));
2788 end Smart_File_Stamp;
2790 ---------------------
2791 -- Smart_Find_File --
2792 ---------------------
2794 function Smart_Find_File
2795 (N : File_Name_Type;
2796 T : File_Type) return File_Name_Type
2798 File : File_Name_Type;
2799 Attr : File_Attributes;
2801 Smart_Find_File (N, T, File, Attr);
2803 end Smart_Find_File;
2805 ---------------------
2806 -- Smart_Find_File --
2807 ---------------------
2809 procedure Smart_Find_File
2810 (N : File_Name_Type;
2812 Found : out File_Name_Type;
2813 Attr : out File_Attributes)
2815 Info : File_Info_Cache;
2818 if not File_Cache_Enabled then
2819 Find_File (N, T, Info.File, Info.Attr'Access);
2822 Info := File_Name_Hash_Table.Get (N);
2824 if Info.File = No_File then
2825 Find_File (N, T, Info.File, Info.Attr'Access);
2826 File_Name_Hash_Table.Set (N, Info);
2832 end Smart_Find_File;
2834 ----------------------
2835 -- Source_File_Data --
2836 ----------------------
2838 procedure Source_File_Data (Cache : Boolean) is
2840 File_Cache_Enabled := Cache;
2841 end Source_File_Data;
2843 -----------------------
2844 -- Source_File_Stamp --
2845 -----------------------
2847 function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is
2849 return Smart_File_Stamp (N, Source);
2850 end Source_File_Stamp;
2852 ---------------------
2853 -- Strip_Directory --
2854 ---------------------
2856 function Strip_Directory (Name : File_Name_Type) return File_Name_Type is
2858 Get_Name_String (Name);
2860 for J in reverse 1 .. Name_Len - 1 loop
2862 -- If we find the last directory separator
2864 if Is_Directory_Separator (Name_Buffer (J)) then
2866 -- Return part of Name that follows this last directory separator
2868 Name_Buffer (1 .. Name_Len - J) := Name_Buffer (J + 1 .. Name_Len);
2869 Name_Len := Name_Len - J;
2874 -- There were no directory separator, just return Name
2877 end Strip_Directory;
2883 function Strip_Suffix (Name : File_Name_Type) return File_Name_Type is
2885 Get_Name_String (Name);
2887 for J in reverse 2 .. Name_Len loop
2889 -- If we found the last '.', return part of Name that precedes it
2891 if Name_Buffer (J) = '.' then
2900 ---------------------------
2901 -- To_Canonical_Dir_Spec --
2902 ---------------------------
2904 function To_Canonical_Dir_Spec
2906 Prefix_Style : Boolean) return String_Access
2908 function To_Canonical_Dir_Spec
2909 (Host_Dir : Address;
2910 Prefix_Flag : Integer) return Address;
2911 pragma Import (C, To_Canonical_Dir_Spec, "__gnat_to_canonical_dir_spec");
2913 C_Host_Dir : String (1 .. Host_Dir'Length + 1);
2914 Canonical_Dir_Addr : Address;
2915 Canonical_Dir_Len : Integer;
2918 C_Host_Dir (1 .. Host_Dir'Length) := Host_Dir;
2919 C_Host_Dir (C_Host_Dir'Last) := ASCII.NUL;
2921 if Prefix_Style then
2922 Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 1);
2924 Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 0);
2927 Canonical_Dir_Len := C_String_Length (Canonical_Dir_Addr);
2929 if Canonical_Dir_Len = 0 then
2932 return To_Path_String_Access (Canonical_Dir_Addr, Canonical_Dir_Len);
2937 Fail ("erroneous directory spec: " & Host_Dir);
2939 end To_Canonical_Dir_Spec;
2941 ---------------------------
2942 -- To_Canonical_File_List --
2943 ---------------------------
2945 function To_Canonical_File_List
2946 (Wildcard_Host_File : String;
2947 Only_Dirs : Boolean) return String_Access_List_Access
2949 function To_Canonical_File_List_Init
2950 (Host_File : Address;
2951 Only_Dirs : Integer) return Integer;
2952 pragma Import (C, To_Canonical_File_List_Init,
2953 "__gnat_to_canonical_file_list_init");
2955 function To_Canonical_File_List_Next return Address;
2956 pragma Import (C, To_Canonical_File_List_Next,
2957 "__gnat_to_canonical_file_list_next");
2959 procedure To_Canonical_File_List_Free;
2960 pragma Import (C, To_Canonical_File_List_Free,
2961 "__gnat_to_canonical_file_list_free");
2963 Num_Files : Integer;
2964 C_Wildcard_Host_File : String (1 .. Wildcard_Host_File'Length + 1);
2967 C_Wildcard_Host_File (1 .. Wildcard_Host_File'Length) :=
2969 C_Wildcard_Host_File (C_Wildcard_Host_File'Last) := ASCII.NUL;
2971 -- Do the expansion and say how many there are
2973 Num_Files := To_Canonical_File_List_Init
2974 (C_Wildcard_Host_File'Address, Boolean'Pos (Only_Dirs));
2977 Canonical_File_List : String_Access_List (1 .. Num_Files);
2978 Canonical_File_Addr : Address;
2979 Canonical_File_Len : Integer;
2982 -- Retrieve the expanded directory names and build the list
2984 for J in 1 .. Num_Files loop
2985 Canonical_File_Addr := To_Canonical_File_List_Next;
2986 Canonical_File_Len := C_String_Length (Canonical_File_Addr);
2987 Canonical_File_List (J) := To_Path_String_Access
2988 (Canonical_File_Addr, Canonical_File_Len);
2991 -- Free up the storage
2993 To_Canonical_File_List_Free;
2995 return new String_Access_List'(Canonical_File_List);
2997 end To_Canonical_File_List;
2999 ----------------------------
3000 -- To_Canonical_File_Spec --
3001 ----------------------------
3003 function To_Canonical_File_Spec
3004 (Host_File : String) return String_Access
3006 function To_Canonical_File_Spec (Host_File : Address) return Address;
3008 (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
3010 C_Host_File : String (1 .. Host_File'Length + 1);
3011 Canonical_File_Addr : Address;
3012 Canonical_File_Len : Integer;
3015 C_Host_File (1 .. Host_File'Length) := Host_File;
3016 C_Host_File (C_Host_File'Last) := ASCII.NUL;
3018 Canonical_File_Addr := To_Canonical_File_Spec (C_Host_File'Address);
3019 Canonical_File_Len := C_String_Length (Canonical_File_Addr);
3021 if Canonical_File_Len = 0 then
3024 return To_Path_String_Access
3025 (Canonical_File_Addr, Canonical_File_Len);
3030 Fail ("erroneous file spec: " & Host_File);
3032 end To_Canonical_File_Spec;
3034 ----------------------------
3035 -- To_Canonical_Path_Spec --
3036 ----------------------------
3038 function To_Canonical_Path_Spec
3039 (Host_Path : String) return String_Access
3041 function To_Canonical_Path_Spec (Host_Path : Address) return Address;
3043 (C, To_Canonical_Path_Spec, "__gnat_to_canonical_path_spec");
3045 C_Host_Path : String (1 .. Host_Path'Length + 1);
3046 Canonical_Path_Addr : Address;
3047 Canonical_Path_Len : Integer;
3050 C_Host_Path (1 .. Host_Path'Length) := Host_Path;
3051 C_Host_Path (C_Host_Path'Last) := ASCII.NUL;
3053 Canonical_Path_Addr := To_Canonical_Path_Spec (C_Host_Path'Address);
3054 Canonical_Path_Len := C_String_Length (Canonical_Path_Addr);
3056 -- Return a null string (vice a null) for zero length paths, for
3057 -- compatibility with getenv().
3059 return To_Path_String_Access (Canonical_Path_Addr, Canonical_Path_Len);
3063 Fail ("erroneous path spec: " & Host_Path);
3065 end To_Canonical_Path_Spec;
3067 ---------------------------
3068 -- To_Host_Dir_Spec --
3069 ---------------------------
3071 function To_Host_Dir_Spec
3072 (Canonical_Dir : String;
3073 Prefix_Style : Boolean) return String_Access
3075 function To_Host_Dir_Spec
3076 (Canonical_Dir : Address;
3077 Prefix_Flag : Integer) return Address;
3078 pragma Import (C, To_Host_Dir_Spec, "__gnat_to_host_dir_spec");
3080 C_Canonical_Dir : String (1 .. Canonical_Dir'Length + 1);
3081 Host_Dir_Addr : Address;
3082 Host_Dir_Len : Integer;
3085 C_Canonical_Dir (1 .. Canonical_Dir'Length) := Canonical_Dir;
3086 C_Canonical_Dir (C_Canonical_Dir'Last) := ASCII.NUL;
3088 if Prefix_Style then
3089 Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 1);
3091 Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 0);
3093 Host_Dir_Len := C_String_Length (Host_Dir_Addr);
3095 if Host_Dir_Len = 0 then
3098 return To_Path_String_Access (Host_Dir_Addr, Host_Dir_Len);
3100 end To_Host_Dir_Spec;
3102 ----------------------------
3103 -- To_Host_File_Spec --
3104 ----------------------------
3106 function To_Host_File_Spec
3107 (Canonical_File : String) return String_Access
3109 function To_Host_File_Spec (Canonical_File : Address) return Address;
3110 pragma Import (C, To_Host_File_Spec, "__gnat_to_host_file_spec");
3112 C_Canonical_File : String (1 .. Canonical_File'Length + 1);
3113 Host_File_Addr : Address;
3114 Host_File_Len : Integer;
3117 C_Canonical_File (1 .. Canonical_File'Length) := Canonical_File;
3118 C_Canonical_File (C_Canonical_File'Last) := ASCII.NUL;
3120 Host_File_Addr := To_Host_File_Spec (C_Canonical_File'Address);
3121 Host_File_Len := C_String_Length (Host_File_Addr);
3123 if Host_File_Len = 0 then
3126 return To_Path_String_Access
3127 (Host_File_Addr, Host_File_Len);
3129 end To_Host_File_Spec;
3131 ---------------------------
3132 -- To_Path_String_Access --
3133 ---------------------------
3135 function To_Path_String_Access
3136 (Path_Addr : Address;
3137 Path_Len : Integer) return String_Access
3139 subtype Path_String is String (1 .. Path_Len);
3140 type Path_String_Access is access Path_String;
3142 function Address_To_Access is new
3143 Unchecked_Conversion (Source => Address,
3144 Target => Path_String_Access);
3146 Path_Access : constant Path_String_Access :=
3147 Address_To_Access (Path_Addr);
3149 Return_Val : String_Access;
3152 Return_Val := new String (1 .. Path_Len);
3154 for J in 1 .. Path_Len loop
3155 Return_Val (J) := Path_Access (J);
3159 end To_Path_String_Access;
3165 function Update_Path (Path : String_Ptr) return String_Ptr is
3167 function C_Update_Path (Path, Component : Address) return Address;
3168 pragma Import (C, C_Update_Path, "update_path");
3170 function Strlen (Str : Address) return Integer;
3171 pragma Import (C, Strlen, "strlen");
3173 procedure Strncpy (X : Address; Y : Address; Length : Integer);
3174 pragma Import (C, Strncpy, "strncpy");
3176 In_Length : constant Integer := Path'Length;
3177 In_String : String (1 .. In_Length + 1);
3178 Component_Name : aliased String := "GCC" & ASCII.NUL;
3179 Result_Ptr : Address;
3180 Result_Length : Integer;
3181 Out_String : String_Ptr;
3184 In_String (1 .. In_Length) := Path.all;
3185 In_String (In_Length + 1) := ASCII.NUL;
3186 Result_Ptr := C_Update_Path (In_String'Address, Component_Name'Address);
3187 Result_Length := Strlen (Result_Ptr);
3189 Out_String := new String (1 .. Result_Length);
3190 Strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
3198 procedure Write_Info (Info : String) is
3200 Write_With_Check (Info'Address, Info'Length);
3201 Write_With_Check (EOL'Address, 1);
3204 ------------------------
3205 -- Write_Program_Name --
3206 ------------------------
3208 procedure Write_Program_Name is
3209 Save_Buffer : constant String (1 .. Name_Len) :=
3210 Name_Buffer (1 .. Name_Len);
3215 -- Convert the name to lower case so error messages are the same on
3218 for J in 1 .. Name_Len loop
3219 if Name_Buffer (J) in 'A' .. 'Z' then
3221 Character'Val (Character'Pos (Name_Buffer (J)) + 32);
3225 Write_Str (Name_Buffer (1 .. Name_Len));
3227 -- Restore Name_Buffer which was clobbered by the call to
3228 -- Find_Program_Name
3230 Name_Len := Save_Buffer'Last;
3231 Name_Buffer (1 .. Name_Len) := Save_Buffer;
3232 end Write_Program_Name;
3234 ----------------------
3235 -- Write_With_Check --
3236 ----------------------
3238 procedure Write_With_Check (A : Address; N : Integer) is
3240 pragma Warnings (Off, Ignore);
3243 if N = Write (Output_FD, A, N) then
3247 Write_Str ("error: disk full writing ");
3248 Write_Name_Decoded (Output_File_Name);
3250 Name_Len := Name_Len + 1;
3251 Name_Buffer (Name_Len) := ASCII.NUL;
3252 Delete_File (Name_Buffer'Address, Ignore);
3253 Exit_Program (E_Fatal);
3255 end Write_With_Check;
3257 ----------------------------
3258 -- Package Initialization --
3259 ----------------------------
3261 procedure Reset_File_Attributes (Attr : System.Address);
3262 pragma Import (C, Reset_File_Attributes, "__gnat_reset_attributes");
3265 Initialization : declare
3267 function Get_Default_Identifier_Character_Set return Character;
3268 pragma Import (C, Get_Default_Identifier_Character_Set,
3269 "__gnat_get_default_identifier_character_set");
3270 -- Function to determine the default identifier character set,
3271 -- which is system dependent. See Opt package spec for a list of
3272 -- the possible character codes and their interpretations.
3274 function Get_Maximum_File_Name_Length return Int;
3275 pragma Import (C, Get_Maximum_File_Name_Length,
3276 "__gnat_get_maximum_file_name_length");
3277 -- Function to get maximum file name length for system
3279 Sizeof_File_Attributes : Integer;
3280 pragma Import (C, Sizeof_File_Attributes,
3281 "__gnat_size_of_file_attributes");
3284 pragma Assert (Sizeof_File_Attributes <= File_Attributes_Size);
3286 Reset_File_Attributes (Unknown_Attributes'Address);
3288 Identifier_Character_Set := Get_Default_Identifier_Character_Set;
3289 Maximum_File_Name_Length := Get_Maximum_File_Name_Length;
3291 -- Following should be removed by having above function return
3292 -- Integer'Last as indication of no maximum instead of -1 ???
3294 if Maximum_File_Name_Length = -1 then
3295 Maximum_File_Name_Length := Int'Last;
3298 Src_Search_Directories.Set_Last (Primary_Directory);
3299 Src_Search_Directories.Table (Primary_Directory) := new String'("");
3301 Lib_Search_Directories.Set_Last (Primary_Directory);
3302 Lib_Search_Directories.Table (Primary_Directory) := new String'("");