1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2007, 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Unchecked_Conversion;
29 with System.Case_Util; use System.Case_Util;
34 with Gnatvsn; use Gnatvsn;
37 with Output; use Output;
38 with Sdefault; use Sdefault;
40 with Targparm; use Targparm;
44 Running_Program : Program_Type := Unspecified;
45 -- comment required here ???
47 Program_Set : Boolean := False;
48 -- comment required here ???
50 Std_Prefix : String_Ptr;
51 -- Standard prefix, computed dynamically the first time Relocate_Path
52 -- is called, and cached for subsequent calls.
54 Empty : aliased String := "";
55 No_Dir : constant String_Ptr := Empty'Access;
56 -- Used in Locate_File as a fake directory when Name is already an
59 -------------------------------------
60 -- Use of Name_Find and Name_Enter --
61 -------------------------------------
63 -- This package creates a number of source, ALI and object file names
64 -- that are used to locate the actual file and for the purpose of message
65 -- construction. These names need not be accessible by Name_Find, and can
66 -- be therefore created by using routine Name_Enter. The files in question
67 -- are file names with a prefix directory (ie the files not in the current
68 -- directory). File names without a prefix directory are entered with
69 -- Name_Find because special values might be attached to the various Info
70 -- fields of the corresponding name table entry.
72 -----------------------
73 -- Local Subprograms --
74 -----------------------
76 function Append_Suffix_To_File_Name
77 (Name : File_Name_Type;
78 Suffix : String) return File_Name_Type;
79 -- Appends Suffix to Name and returns the new name
81 function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type;
82 -- Convert OS format time to GNAT format time stamp
84 function Executable_Prefix return String_Ptr;
85 -- Returns the name of the root directory where the executable is stored.
86 -- The executable must be located in a directory called "bin", or under
87 -- root/lib/gcc-lib/..., or under root/libexec/gcc/... For example, if
88 -- executable is stored in directory "/foo/bar/bin", this routine returns
89 -- "/foo/bar/". Return "" if location is not recognized as described above.
91 function Update_Path (Path : String_Ptr) return String_Ptr;
92 -- Update the specified path to replace the prefix with the location
93 -- where GNAT is installed. See the file prefix.c in GCC for details.
99 Name : String) return File_Name_Type;
100 -- See if the file N whose name is Name exists in directory Dir. Dir is an
101 -- index into the Lib_Search_Directories table if T = Library. Otherwise
102 -- if T = Source, Dir is an index into the Src_Search_Directories table.
103 -- Returns the File_Name_Type of the full file name if file found, or
104 -- No_File if not found.
106 function C_String_Length (S : Address) return Integer;
107 -- Returns length of a C string (zero for a null address)
109 function To_Path_String_Access
110 (Path_Addr : Address;
111 Path_Len : Integer) return String_Access;
112 -- Converts a C String to an Ada String. Are we doing this to avoid withing
113 -- Interfaces.C.Strings ???
115 ------------------------------
116 -- Other Local Declarations --
117 ------------------------------
119 EOL : constant Character := ASCII.LF;
120 -- End of line character
122 Number_File_Names : Int := 0;
123 -- Number of file names founde on command line and placed in File_Names
125 Look_In_Primary_Directory_For_Current_Main : Boolean := False;
126 -- When this variable is True, Find_File only looks in Primary_Directory
127 -- for the Current_Main file. This variable is always set to True for the
128 -- compiler. It is also True for gnatmake, when the soucr name given on
129 -- the command line has directory information.
131 Current_Full_Source_Name : File_Name_Type := No_File;
132 Current_Full_Source_Stamp : Time_Stamp_Type := Empty_Time_Stamp;
133 Current_Full_Lib_Name : File_Name_Type := No_File;
134 Current_Full_Lib_Stamp : Time_Stamp_Type := Empty_Time_Stamp;
135 Current_Full_Obj_Name : File_Name_Type := No_File;
136 Current_Full_Obj_Stamp : Time_Stamp_Type := Empty_Time_Stamp;
137 -- Respectively full name (with directory info) and time stamp of the
138 -- latest source, library and object files opened by Read_Source_File and
139 -- Read_Library_Info.
145 Primary_Directory : constant := 0;
146 -- This is index in the tables created below for the first directory to
147 -- search in for source or library information files. This is the directory
148 -- containing the latest main input file (a source file for the compiler or
149 -- a library file for the binder).
151 package Src_Search_Directories is new Table.Table (
152 Table_Component_Type => String_Ptr,
153 Table_Index_Type => Integer,
154 Table_Low_Bound => Primary_Directory,
156 Table_Increment => 100,
157 Table_Name => "Osint.Src_Search_Directories");
158 -- Table of names of directories in which to search for source (Compiler)
159 -- files. This table is filled in the order in which the directories are
160 -- to be searched, and then used in that order.
162 package Lib_Search_Directories is new Table.Table (
163 Table_Component_Type => String_Ptr,
164 Table_Index_Type => Integer,
165 Table_Low_Bound => Primary_Directory,
167 Table_Increment => 100,
168 Table_Name => "Osint.Lib_Search_Directories");
169 -- Table of names of directories in which to search for library (Binder)
170 -- files. This table is filled in the order in which the directories are
171 -- to be searched and then used in that order. The reason for having two
172 -- distinct tables is that we need them both in gnatmake.
174 ---------------------
175 -- File Hash Table --
176 ---------------------
178 -- The file hash table is provided to free the programmer from any
179 -- efficiency concern when retrieving full file names or time stamps of
180 -- source files. If the programmer calls Source_File_Data (Cache => True)
181 -- he is guaranteed that the price to retrieve the full name (ie with
182 -- directory info) or time stamp of the file will be payed only once, the
183 -- first time the full name is actually searched (or the first time the
184 -- time stamp is actually retrieved). This is achieved by employing a hash
185 -- table that stores as a key the File_Name_Type of the file and associates
186 -- to that File_Name_Type the full file name and time stamp of the file.
188 File_Cache_Enabled : Boolean := False;
189 -- Set to true if you want the enable the file data caching mechanism
191 type File_Hash_Num is range 0 .. 1020;
193 function File_Hash (F : File_Name_Type) return File_Hash_Num;
194 -- Compute hash index for use by Simple_HTable
196 package File_Name_Hash_Table is new GNAT.HTable.Simple_HTable (
197 Header_Num => File_Hash_Num,
198 Element => File_Name_Type,
199 No_Element => No_File,
200 Key => File_Name_Type,
204 package File_Stamp_Hash_Table is new GNAT.HTable.Simple_HTable (
205 Header_Num => File_Hash_Num,
206 Element => Time_Stamp_Type,
207 No_Element => Empty_Time_Stamp,
208 Key => File_Name_Type,
212 function Smart_Find_File
214 T : File_Type) return File_Name_Type;
215 -- Exactly like Find_File except that if File_Cache_Enabled is True this
216 -- routine looks first in the hash table to see if the full name of the
217 -- file is already available.
219 function Smart_File_Stamp
221 T : File_Type) return Time_Stamp_Type;
222 -- Takes the same parameter as the routine above (N is a file name without
223 -- any prefix directory information) and behaves like File_Stamp except
224 -- that if File_Cache_Enabled is True this routine looks first in the hash
225 -- table to see if the file stamp of the file is already available.
227 -----------------------------
228 -- Add_Default_Search_Dirs --
229 -----------------------------
231 procedure Add_Default_Search_Dirs is
232 Search_Dir : String_Access;
233 Search_Path : String_Access;
234 Path_File_Name : String_Access;
236 procedure Add_Search_Dir
237 (Search_Dir : String;
238 Additional_Source_Dir : Boolean);
239 procedure Add_Search_Dir
240 (Search_Dir : String_Access;
241 Additional_Source_Dir : Boolean);
242 -- Add a source search dir or a library search dir, depending on the
243 -- value of Additional_Source_Dir.
245 procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean);
246 -- Open a path file and read the directory to search, one per line
248 function Get_Libraries_From_Registry return String_Ptr;
249 -- On Windows systems, get the list of installed standard libraries
250 -- from the registry key:
252 -- HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\
253 -- GNAT\Standard Libraries
254 -- Return an empty string on other systems
260 procedure Add_Search_Dir
261 (Search_Dir : String;
262 Additional_Source_Dir : Boolean)
265 if Additional_Source_Dir then
266 Add_Src_Search_Dir (Search_Dir);
268 Add_Lib_Search_Dir (Search_Dir);
272 procedure Add_Search_Dir
273 (Search_Dir : String_Access;
274 Additional_Source_Dir : Boolean)
277 if Additional_Source_Dir then
278 Add_Src_Search_Dir (Search_Dir.all);
280 Add_Lib_Search_Dir (Search_Dir.all);
284 ------------------------
285 -- Get_Dirs_From_File --
286 ------------------------
288 procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean) is
289 File_FD : File_Descriptor;
290 Buffer : constant String := Path_File_Name.all & ASCII.NUL;
292 Actual_Len : Natural;
299 -- For the call to Close
302 File_FD := Open_Read (Buffer'Address, Binary);
304 -- If we cannot open the file, we ignore it, we don't fail
306 if File_FD = Invalid_FD then
310 Len := Integer (File_Length (File_FD));
312 S := new String (1 .. Len);
314 -- Read the file. Note that the loop is not necessary since the
315 -- whole file is read at once except on VMS.
319 while Curr <= Len and then Actual_Len /= 0 loop
320 Actual_Len := Read (File_FD, S (Curr)'Address, Len);
321 Curr := Curr + Actual_Len;
324 -- We are done with the file, so we close it (ignore any error on
325 -- the close, since we have successfully read the file).
327 Close (File_FD, Status);
329 -- Now, we read line by line
333 while Curr < Len loop
336 if Ch = ASCII.CR or else Ch = ASCII.LF
337 or else Ch = ASCII.FF or else Ch = ASCII.VT
339 if First <= Curr then
340 Add_Search_Dir (S (First .. Curr), Additional_Source_Dir);
349 -- Last line is a special case, if the file does not end with
350 -- an end of line mark.
352 if First <= S'Last then
353 Add_Search_Dir (S (First .. S'Last), Additional_Source_Dir);
355 end Get_Dirs_From_File;
357 ---------------------------------
358 -- Get_Libraries_From_Registry --
359 ---------------------------------
361 function Get_Libraries_From_Registry return String_Ptr is
362 function C_Get_Libraries_From_Registry return Address;
363 pragma Import (C, C_Get_Libraries_From_Registry,
364 "__gnat_get_libraries_from_registry");
366 function Strlen (Str : Address) return Integer;
367 pragma Import (C, Strlen, "strlen");
369 procedure Strncpy (X : Address; Y : Address; Length : Integer);
370 pragma Import (C, Strncpy, "strncpy");
372 Result_Ptr : Address;
373 Result_Length : Integer;
374 Out_String : String_Ptr;
377 Result_Ptr := C_Get_Libraries_From_Registry;
378 Result_Length := Strlen (Result_Ptr);
380 Out_String := new String (1 .. Result_Length);
381 Strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
383 end Get_Libraries_From_Registry;
385 -- Start of processing for Add_Default_Search_Dirs
388 -- After the locations specified on the command line, the next places
389 -- to look for files are the directories specified by the appropriate
390 -- environment variable. Get this value, extract the directory names
391 -- and store in the tables.
393 -- Check for eventual project path file env vars
395 Path_File_Name := Getenv (Project_Include_Path_File);
397 if Path_File_Name'Length > 0 then
398 Get_Dirs_From_File (Additional_Source_Dir => True);
401 Path_File_Name := Getenv (Project_Objects_Path_File);
403 if Path_File_Name'Length > 0 then
404 Get_Dirs_From_File (Additional_Source_Dir => False);
407 -- On VMS, don't expand the logical name (e.g. environment variable),
408 -- just put it into Unix (e.g. canonical) format. System services
409 -- will handle the expansion as part of the file processing.
411 for Additional_Source_Dir in False .. True loop
412 if Additional_Source_Dir then
413 Search_Path := Getenv (Ada_Include_Path);
415 if Search_Path'Length > 0 then
416 if Hostparm.OpenVMS then
417 Search_Path := To_Canonical_Path_Spec ("ADA_INCLUDE_PATH:");
419 Search_Path := To_Canonical_Path_Spec (Search_Path.all);
424 Search_Path := Getenv (Ada_Objects_Path);
426 if Search_Path'Length > 0 then
427 if Hostparm.OpenVMS then
428 Search_Path := To_Canonical_Path_Spec ("ADA_OBJECTS_PATH:");
430 Search_Path := To_Canonical_Path_Spec (Search_Path.all);
435 Get_Next_Dir_In_Path_Init (Search_Path);
437 Search_Dir := Get_Next_Dir_In_Path (Search_Path);
438 exit when Search_Dir = null;
439 Add_Search_Dir (Search_Dir, Additional_Source_Dir);
443 -- For the compiler, if --RTS= was specified, add the runtime
446 if RTS_Src_Path_Name /= null
447 and then RTS_Lib_Path_Name /= null
449 Add_Search_Dirs (RTS_Src_Path_Name, Include);
450 Add_Search_Dirs (RTS_Lib_Path_Name, Objects);
453 if not Opt.No_Stdinc then
455 -- For WIN32 systems, look for any system libraries defined in
456 -- the registry. These are added to both source and object
459 Search_Path := String_Access (Get_Libraries_From_Registry);
461 Get_Next_Dir_In_Path_Init (Search_Path);
463 Search_Dir := Get_Next_Dir_In_Path (Search_Path);
464 exit when Search_Dir = null;
465 Add_Search_Dir (Search_Dir, False);
466 Add_Search_Dir (Search_Dir, True);
469 -- The last place to look are the defaults
472 Read_Default_Search_Dirs
473 (String_Access (Update_Path (Search_Dir_Prefix)),
475 String_Access (Update_Path (Include_Dir_Default_Name)));
477 Get_Next_Dir_In_Path_Init (Search_Path);
479 Search_Dir := Get_Next_Dir_In_Path (Search_Path);
480 exit when Search_Dir = null;
481 Add_Search_Dir (Search_Dir, True);
485 if not Opt.No_Stdlib and not Opt.RTS_Switch then
487 Read_Default_Search_Dirs
488 (String_Access (Update_Path (Search_Dir_Prefix)),
490 String_Access (Update_Path (Object_Dir_Default_Name)));
492 Get_Next_Dir_In_Path_Init (Search_Path);
494 Search_Dir := Get_Next_Dir_In_Path (Search_Path);
495 exit when Search_Dir = null;
496 Add_Search_Dir (Search_Dir, False);
500 end Add_Default_Search_Dirs;
506 procedure Add_File (File_Name : String; Index : Int := No_Index) is
508 Number_File_Names := Number_File_Names + 1;
510 -- As Add_File may be called for mains specified inside a project file,
511 -- File_Names may be too short and needs to be extended.
513 if Number_File_Names > File_Names'Last then
514 File_Names := new File_Name_Array'(File_Names.all & File_Names.all);
516 new File_Index_Array'(File_Indexes.all & File_Indexes.all);
519 File_Names (Number_File_Names) := new String'(File_Name);
520 File_Indexes (Number_File_Names) := Index;
523 ------------------------
524 -- Add_Lib_Search_Dir --
525 ------------------------
527 procedure Add_Lib_Search_Dir (Dir : String) is
529 if Dir'Length = 0 then
530 Fail ("missing library directory name");
533 Lib_Search_Directories.Increment_Last;
534 Lib_Search_Directories.Table (Lib_Search_Directories.Last) :=
535 Normalize_Directory_Name (Dir);
536 end Add_Lib_Search_Dir;
538 ---------------------
539 -- Add_Search_Dirs --
540 ---------------------
542 procedure Add_Search_Dirs
543 (Search_Path : String_Ptr;
544 Path_Type : Search_File_Type)
546 Current_Search_Path : String_Access;
549 Get_Next_Dir_In_Path_Init (String_Access (Search_Path));
551 Current_Search_Path :=
552 Get_Next_Dir_In_Path (String_Access (Search_Path));
553 exit when Current_Search_Path = null;
555 if Path_Type = Include then
556 Add_Src_Search_Dir (Current_Search_Path.all);
558 Add_Lib_Search_Dir (Current_Search_Path.all);
563 ------------------------
564 -- Add_Src_Search_Dir --
565 ------------------------
567 procedure Add_Src_Search_Dir (Dir : String) is
569 if Dir'Length = 0 then
570 Fail ("missing source directory name");
573 Src_Search_Directories.Increment_Last;
574 Src_Search_Directories.Table (Src_Search_Directories.Last) :=
575 Normalize_Directory_Name (Dir);
576 end Add_Src_Search_Dir;
578 --------------------------------
579 -- Append_Suffix_To_File_Name --
580 --------------------------------
582 function Append_Suffix_To_File_Name
583 (Name : File_Name_Type;
584 Suffix : String) return File_Name_Type
587 Get_Name_String (Name);
588 Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
589 Name_Len := Name_Len + Suffix'Length;
591 end Append_Suffix_To_File_Name;
593 ---------------------
594 -- C_String_Length --
595 ---------------------
597 function C_String_Length (S : Address) return Integer is
598 function Strlen (S : Address) return Integer;
599 pragma Import (C, Strlen, "strlen");
601 if S = Null_Address then
608 ------------------------------
609 -- Canonical_Case_File_Name --
610 ------------------------------
612 -- For now, we only deal with the case of a-z. Eventually we should
613 -- worry about other Latin-1 letters on systems that support this ???
615 procedure Canonical_Case_File_Name (S : in out String) is
617 if not File_Names_Case_Sensitive then
618 for J in S'Range loop
619 if S (J) in 'A' .. 'Z' then
620 S (J) := Character'Val (
621 Character'Pos (S (J)) +
622 Character'Pos ('a') -
623 Character'Pos ('A'));
627 end Canonical_Case_File_Name;
629 ---------------------------
630 -- Create_File_And_Check --
631 ---------------------------
633 procedure Create_File_And_Check
634 (Fdesc : out File_Descriptor;
638 Output_File_Name := Name_Enter;
639 Fdesc := Create_File (Name_Buffer'Address, Fmode);
641 if Fdesc = Invalid_FD then
642 Fail ("Cannot create: ", Name_Buffer (1 .. Name_Len));
644 end Create_File_And_Check;
646 ------------------------
647 -- Current_File_Index --
648 ------------------------
650 function Current_File_Index return Int is
652 return File_Indexes (Current_File_Name_Index);
653 end Current_File_Index;
655 --------------------------------
656 -- Current_Library_File_Stamp --
657 --------------------------------
659 function Current_Library_File_Stamp return Time_Stamp_Type is
661 return Current_Full_Lib_Stamp;
662 end Current_Library_File_Stamp;
664 -------------------------------
665 -- Current_Object_File_Stamp --
666 -------------------------------
668 function Current_Object_File_Stamp return Time_Stamp_Type is
670 return Current_Full_Obj_Stamp;
671 end Current_Object_File_Stamp;
673 -------------------------------
674 -- Current_Source_File_Stamp --
675 -------------------------------
677 function Current_Source_File_Stamp return Time_Stamp_Type is
679 return Current_Full_Source_Stamp;
680 end Current_Source_File_Stamp;
682 ----------------------------
683 -- Dir_In_Obj_Search_Path --
684 ----------------------------
686 function Dir_In_Obj_Search_Path (Position : Natural) return String_Ptr is
688 if Opt.Look_In_Primary_Dir then
690 Lib_Search_Directories.Table (Primary_Directory + Position - 1);
692 return Lib_Search_Directories.Table (Primary_Directory + Position);
694 end Dir_In_Obj_Search_Path;
696 ----------------------------
697 -- Dir_In_Src_Search_Path --
698 ----------------------------
700 function Dir_In_Src_Search_Path (Position : Natural) return String_Ptr is
702 if Opt.Look_In_Primary_Dir then
704 Src_Search_Directories.Table (Primary_Directory + Position - 1);
706 return Src_Search_Directories.Table (Primary_Directory + Position);
708 end Dir_In_Src_Search_Path;
710 ---------------------
711 -- Executable_Name --
712 ---------------------
714 function Executable_Name (Name : File_Name_Type) return File_Name_Type is
715 Exec_Suffix : String_Access;
718 if Name = No_File then
722 if Executable_Extension_On_Target = No_Name then
723 Exec_Suffix := Get_Target_Executable_Suffix;
725 Get_Name_String (Executable_Extension_On_Target);
726 Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len));
729 Get_Name_String (Name);
731 if Exec_Suffix'Length /= 0 then
733 Buffer : String := Name_Buffer (1 .. Name_Len);
736 -- Get the file name in canonical case to accept as is names
737 -- ending with ".EXE" on VMS and Windows.
739 Canonical_Case_File_Name (Buffer);
741 -- If Executable does not end with the executable suffix, add it
743 if Buffer'Length <= Exec_Suffix'Length
745 Buffer (Buffer'Last - Exec_Suffix'Length + 1 .. Buffer'Last)
748 Name_Buffer (Name_Len + 1 .. Name_Len + Exec_Suffix'Length) :=
750 Name_Len := Name_Len + Exec_Suffix'Length;
761 function Executable_Name (Name : String) return String is
762 Exec_Suffix : String_Access;
763 Canonical_Name : String := Name;
766 if Executable_Extension_On_Target = No_Name then
767 Exec_Suffix := Get_Target_Executable_Suffix;
769 Get_Name_String (Executable_Extension_On_Target);
770 Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len));
774 Suffix : constant String := Exec_Suffix.all;
778 Canonical_Case_File_Name (Canonical_Name);
780 if Suffix'Length /= 0
782 (Canonical_Name'Length <= Suffix'Length
783 or else Canonical_Name (Canonical_Name'Last - Suffix'Length + 1
784 .. Canonical_Name'Last) /= Suffix)
787 Result : String (1 .. Name'Length + Suffix'Length);
789 Result (1 .. Name'Length) := Name;
790 Result (Name'Length + 1 .. Result'Last) := Suffix;
799 -----------------------
800 -- Executable_Prefix --
801 -----------------------
803 function Executable_Prefix return String_Ptr is
805 function Get_Install_Dir (Exec : String) return String_Ptr;
806 -- S is the executable name preceeded by the absolute or relative
807 -- path, e.g. "c:\usr\bin\gcc.exe" or "..\bin\gcc".
809 ---------------------
810 -- Get_Install_Dir --
811 ---------------------
813 function Get_Install_Dir (Exec : String) return String_Ptr is
814 Full_Path : constant String := Normalize_Pathname (Exec);
815 -- Use the full path, so that we find "lib" or "bin", even when
816 -- the tool has been invoked with a relative path, as in
817 -- "./gnatls -v" invoked in the GNAT bin directory.
820 for J in reverse Full_Path'Range loop
821 if Is_Directory_Separator (Full_Path (J)) then
822 if J < Full_Path'Last - 5 then
823 if (To_Lower (Full_Path (J + 1)) = 'l'
824 and then To_Lower (Full_Path (J + 2)) = 'i'
825 and then To_Lower (Full_Path (J + 3)) = 'b')
827 (To_Lower (Full_Path (J + 1)) = 'b'
828 and then To_Lower (Full_Path (J + 2)) = 'i'
829 and then To_Lower (Full_Path (J + 3)) = 'n')
831 return new String'(Full_Path (Full_Path'First .. J));
837 return new String'("");
840 -- Start of processing for Executable_Prefix
843 if Exec_Name = null then
844 Exec_Name := new String (1 .. Len_Arg (0));
845 Osint.Fill_Arg (Exec_Name (1)'Address, 0);
848 -- First determine if a path prefix was placed in front of the
851 for J in reverse Exec_Name'Range loop
852 if Is_Directory_Separator (Exec_Name (J)) then
853 return Get_Install_Dir (Exec_Name.all);
857 -- If we come here, the user has typed the executable name with no
860 return Get_Install_Dir
861 (System.OS_Lib.Locate_Exec_On_Path (Exec_Name.all).all);
862 end Executable_Prefix;
868 procedure Exit_Program (Exit_Code : Exit_Code_Type) is
870 -- The program will exit with the following status:
872 -- 0 if the object file has been generated (with or without warnings)
873 -- 1 if recompilation was not needed (smart recompilation)
874 -- 2 if gnat1 has been killed by a signal (detected by GCC)
875 -- 4 for a fatal error
876 -- 5 if there were errors
877 -- 6 if no code has been generated (spec)
879 -- Note that exit code 3 is not used and must not be used as this is
880 -- the code returned by a program aborted via C abort() routine on
881 -- Windows. GCC checks for that case and thinks that the child process
882 -- has been aborted. This code (exit code 3) used to be the code used
883 -- for E_No_Code, but E_No_Code was changed to 6 for this reason.
886 when E_Success => OS_Exit (0);
887 when E_Warnings => OS_Exit (0);
888 when E_No_Compile => OS_Exit (1);
889 when E_Fatal => OS_Exit (4);
890 when E_Errors => OS_Exit (5);
891 when E_No_Code => OS_Exit (6);
892 when E_Abort => OS_Abort;
900 procedure Fail (S1 : String; S2 : String := ""; S3 : String := "") is
902 -- We use Output in case there is a special output set up.
903 -- In this case Set_Standard_Error will have no immediate effect.
906 Osint.Write_Program_Name;
913 Exit_Program (E_Fatal);
920 function File_Hash (F : File_Name_Type) return File_Hash_Num is
922 return File_Hash_Num (Int (F) rem File_Hash_Num'Range_Length);
929 function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type is
931 if Name = No_File then
932 return Empty_Time_Stamp;
935 Get_Name_String (Name);
937 if not Is_Regular_File (Name_Buffer (1 .. Name_Len)) then
938 return Empty_Time_Stamp;
940 Name_Buffer (Name_Len + 1) := ASCII.NUL;
941 return OS_Time_To_GNAT_Time (File_Time_Stamp (Name_Buffer));
945 function File_Stamp (Name : Path_Name_Type) return Time_Stamp_Type is
947 return File_Stamp (File_Name_Type (Name));
956 T : File_Type) return File_Name_Type
962 File_Name : String renames Name_Buffer (1 .. Name_Len);
963 File : File_Name_Type := No_File;
967 -- If we are looking for a config file, look only in the current
968 -- directory, i.e. return input argument unchanged. Also look
969 -- only in the current directory if we are looking for a .dg
970 -- file (happens in -gnatD mode).
973 or else (Debug_Generated_Code
974 and then Name_Len > 3
976 (Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg"
978 (Hostparm.OpenVMS and then
979 Name_Buffer (Name_Len - 2 .. Name_Len) = "_dg")))
983 -- If we are trying to find the current main file just look in the
984 -- directory where the user said it was.
986 elsif Look_In_Primary_Directory_For_Current_Main
987 and then Current_Main = N
989 return Locate_File (N, T, Primary_Directory, File_Name);
991 -- Otherwise do standard search for source file
994 -- Check the mapping of this file name
996 File := Mapped_Path_Name (N);
998 -- If the file name is mapped to a path name, return the
999 -- corresponding path name
1001 if File /= No_File then
1003 -- For locally removed file, Error_Name is returned; then
1004 -- return No_File, indicating the file is not a source.
1006 if File = Error_File_Name then
1014 -- First place to look is in the primary directory (i.e. the same
1015 -- directory as the source) unless this has been disabled with -I-
1017 if Opt.Look_In_Primary_Dir then
1018 File := Locate_File (N, T, Primary_Directory, File_Name);
1020 if File /= No_File then
1025 -- Finally look in directories specified with switches -I/-aI/-aO
1028 Last_Dir := Lib_Search_Directories.Last;
1030 Last_Dir := Src_Search_Directories.Last;
1033 for D in Primary_Directory + 1 .. Last_Dir loop
1034 File := Locate_File (N, T, D, File_Name);
1036 if File /= No_File then
1046 -----------------------
1047 -- Find_Program_Name --
1048 -----------------------
1050 procedure Find_Program_Name is
1051 Command_Name : String (1 .. Len_Arg (0));
1052 Cindex1 : Integer := Command_Name'First;
1053 Cindex2 : Integer := Command_Name'Last;
1056 Fill_Arg (Command_Name'Address, 0);
1058 -- The program name might be specified by a full path name. However,
1059 -- we don't want to print that all out in an error message, so the
1060 -- path might need to be stripped away.
1062 for J in reverse Cindex1 .. Cindex2 loop
1063 if Is_Directory_Separator (Command_Name (J)) then
1069 -- Command_Name(Cindex1 .. Cindex2) is now the equivalent of the
1070 -- POSIX command "basename argv[0]"
1072 -- Strip off any versioning information such as found on VMS.
1073 -- This would take the form of TOOL.exe followed by a ";" or "."
1074 -- and a sequence of one or more numbers.
1076 if Command_Name (Cindex2) in '0' .. '9' then
1077 for J in reverse Cindex1 .. Cindex2 loop
1078 if Command_Name (J) = '.' or Command_Name (J) = ';' then
1083 exit when Command_Name (J) not in '0' .. '9';
1087 -- Strip off any executable extension (usually nothing or .exe)
1088 -- but formally reported by autoconf in the variable EXEEXT
1090 if Cindex2 - Cindex1 >= 4 then
1091 if To_Lower (Command_Name (Cindex2 - 3)) = '.'
1092 and then To_Lower (Command_Name (Cindex2 - 2)) = 'e'
1093 and then To_Lower (Command_Name (Cindex2 - 1)) = 'x'
1094 and then To_Lower (Command_Name (Cindex2)) = 'e'
1096 Cindex2 := Cindex2 - 4;
1100 Name_Len := Cindex2 - Cindex1 + 1;
1101 Name_Buffer (1 .. Name_Len) := Command_Name (Cindex1 .. Cindex2);
1102 end Find_Program_Name;
1104 ------------------------
1105 -- Full_Lib_File_Name --
1106 ------------------------
1108 function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type is
1110 return Find_File (N, Library);
1111 end Full_Lib_File_Name;
1113 ----------------------------
1114 -- Full_Library_Info_Name --
1115 ----------------------------
1117 function Full_Library_Info_Name return File_Name_Type is
1119 return Current_Full_Lib_Name;
1120 end Full_Library_Info_Name;
1122 ---------------------------
1123 -- Full_Object_File_Name --
1124 ---------------------------
1126 function Full_Object_File_Name return File_Name_Type is
1128 return Current_Full_Obj_Name;
1129 end Full_Object_File_Name;
1131 ----------------------
1132 -- Full_Source_Name --
1133 ----------------------
1135 function Full_Source_Name return File_Name_Type is
1137 return Current_Full_Source_Name;
1138 end Full_Source_Name;
1140 ----------------------
1141 -- Full_Source_Name --
1142 ----------------------
1144 function Full_Source_Name (N : File_Name_Type) return File_Name_Type is
1146 return Smart_Find_File (N, Source);
1147 end Full_Source_Name;
1153 function Get_Directory (Name : File_Name_Type) return File_Name_Type is
1155 Get_Name_String (Name);
1157 for J in reverse 1 .. Name_Len loop
1158 if Is_Directory_Separator (Name_Buffer (J)) then
1164 Name_Len := Hostparm.Normalized_CWD'Length;
1165 Name_Buffer (1 .. Name_Len) := Hostparm.Normalized_CWD;
1169 --------------------------
1170 -- Get_Next_Dir_In_Path --
1171 --------------------------
1173 Search_Path_Pos : Integer;
1174 -- Keeps track of current position in search path. Initialized by the
1175 -- call to Get_Next_Dir_In_Path_Init, updated by Get_Next_Dir_In_Path.
1177 function Get_Next_Dir_In_Path
1178 (Search_Path : String_Access) return String_Access
1180 Lower_Bound : Positive := Search_Path_Pos;
1181 Upper_Bound : Positive;
1185 while Lower_Bound <= Search_Path'Last
1186 and then Search_Path.all (Lower_Bound) = Path_Separator
1188 Lower_Bound := Lower_Bound + 1;
1191 exit when Lower_Bound > Search_Path'Last;
1193 Upper_Bound := Lower_Bound;
1194 while Upper_Bound <= Search_Path'Last
1195 and then Search_Path.all (Upper_Bound) /= Path_Separator
1197 Upper_Bound := Upper_Bound + 1;
1200 Search_Path_Pos := Upper_Bound;
1201 return new String'(Search_Path.all (Lower_Bound .. Upper_Bound - 1));
1205 end Get_Next_Dir_In_Path;
1207 -------------------------------
1208 -- Get_Next_Dir_In_Path_Init --
1209 -------------------------------
1211 procedure Get_Next_Dir_In_Path_Init (Search_Path : String_Access) is
1213 Search_Path_Pos := Search_Path'First;
1214 end Get_Next_Dir_In_Path_Init;
1216 --------------------------------------
1217 -- Get_Primary_Src_Search_Directory --
1218 --------------------------------------
1220 function Get_Primary_Src_Search_Directory return String_Ptr is
1222 return Src_Search_Directories.Table (Primary_Directory);
1223 end Get_Primary_Src_Search_Directory;
1225 ------------------------
1226 -- Get_RTS_Search_Dir --
1227 ------------------------
1229 function Get_RTS_Search_Dir
1230 (Search_Dir : String;
1231 File_Type : Search_File_Type) return String_Ptr
1233 procedure Get_Current_Dir
1234 (Dir : System.Address;
1235 Length : System.Address);
1236 pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir");
1239 pragma Import (C, Max_Path, "__gnat_max_path_len");
1240 -- Maximum length of a path name
1242 Current_Dir : String_Ptr;
1243 Default_Search_Dir : String_Access;
1244 Default_Suffix_Dir : String_Access;
1245 Local_Search_Dir : String_Access;
1246 Norm_Search_Dir : String_Access;
1247 Result_Search_Dir : String_Access;
1248 Search_File : String_Access;
1249 Temp_String : String_Ptr;
1252 -- Add a directory separator at the end of the directory if necessary
1253 -- so that we can directly append a file to the directory
1255 if Search_Dir (Search_Dir'Last) /= Directory_Separator then
1257 new String'(Search_Dir & String'(1 => Directory_Separator));
1259 Local_Search_Dir := new String'(Search_Dir);
1262 if File_Type = Include then
1263 Search_File := Include_Search_File;
1264 Default_Suffix_Dir := new String'("adainclude");
1266 Search_File := Objects_Search_File;
1267 Default_Suffix_Dir := new String'("adalib");
1270 Norm_Search_Dir := To_Canonical_Path_Spec (Local_Search_Dir.all);
1272 if Is_Absolute_Path (Norm_Search_Dir.all) then
1274 -- We first verify if there is a directory Include_Search_Dir
1275 -- containing default search directories
1277 Result_Search_Dir :=
1278 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1279 Default_Search_Dir :=
1280 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1281 Free (Norm_Search_Dir);
1283 if Result_Search_Dir /= null then
1284 return String_Ptr (Result_Search_Dir);
1285 elsif Is_Directory (Default_Search_Dir.all) then
1286 return String_Ptr (Default_Search_Dir);
1291 -- Search in the current directory
1294 -- Get the current directory
1297 Buffer : String (1 .. Max_Path + 2);
1298 Path_Len : Natural := Max_Path;
1301 Get_Current_Dir (Buffer'Address, Path_Len'Address);
1303 if Buffer (Path_Len) /= Directory_Separator then
1304 Path_Len := Path_Len + 1;
1305 Buffer (Path_Len) := Directory_Separator;
1308 Current_Dir := new String'(Buffer (1 .. Path_Len));
1312 new String'(Current_Dir.all & Local_Search_Dir.all);
1314 Result_Search_Dir :=
1315 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1317 Default_Search_Dir :=
1318 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1320 Free (Norm_Search_Dir);
1322 if Result_Search_Dir /= null then
1323 return String_Ptr (Result_Search_Dir);
1325 elsif Is_Directory (Default_Search_Dir.all) then
1326 return String_Ptr (Default_Search_Dir);
1329 -- Search in Search_Dir_Prefix/Search_Dir
1333 (Update_Path (Search_Dir_Prefix).all & Local_Search_Dir.all);
1335 Result_Search_Dir :=
1336 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1338 Default_Search_Dir :=
1339 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1341 Free (Norm_Search_Dir);
1343 if Result_Search_Dir /= null then
1344 return String_Ptr (Result_Search_Dir);
1346 elsif Is_Directory (Default_Search_Dir.all) then
1347 return String_Ptr (Default_Search_Dir);
1350 -- We finally search in Search_Dir_Prefix/rts-Search_Dir
1353 new String'(Update_Path (Search_Dir_Prefix).all & "rts-");
1356 new String'(Temp_String.all & Local_Search_Dir.all);
1358 Result_Search_Dir :=
1359 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1361 Default_Search_Dir :=
1362 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1363 Free (Norm_Search_Dir);
1365 if Result_Search_Dir /= null then
1366 return String_Ptr (Result_Search_Dir);
1368 elsif Is_Directory (Default_Search_Dir.all) then
1369 return String_Ptr (Default_Search_Dir);
1377 end Get_RTS_Search_Dir;
1379 --------------------------------
1380 -- Include_Dir_Default_Prefix --
1381 --------------------------------
1383 function Include_Dir_Default_Prefix return String is
1384 Include_Dir : String_Access :=
1385 String_Access (Update_Path (Include_Dir_Default_Name));
1388 if Include_Dir = null then
1393 Result : constant String := Include_Dir.all;
1399 end Include_Dir_Default_Prefix;
1405 procedure Initialize is
1407 Number_File_Names := 0;
1408 Current_File_Name_Index := 0;
1410 Src_Search_Directories.Init;
1411 Lib_Search_Directories.Init;
1413 -- Start off by setting all suppress options to False, these will
1414 -- be reset later (turning some on if -gnato is not specified, and
1415 -- turning all of them on if -gnatp is specified).
1417 Suppress_Options := (others => False);
1419 -- Reserve the first slot in the search paths table. This is the
1420 -- directory of the main source file or main library file and is filled
1421 -- in by each call to Next_Main_Source/Next_Main_Lib_File with the
1422 -- directory specified for this main source or library file. This is the
1423 -- directory which is searched first by default. This default search is
1424 -- inhibited by the option -I- for both source and library files.
1426 Src_Search_Directories.Set_Last (Primary_Directory);
1427 Src_Search_Directories.Table (Primary_Directory) := new String'("");
1429 Lib_Search_Directories.Set_Last (Primary_Directory);
1430 Lib_Search_Directories.Table (Primary_Directory) := new String'("");
1433 ----------------------------
1434 -- Is_Directory_Separator --
1435 ----------------------------
1437 function Is_Directory_Separator (C : Character) return Boolean is
1439 -- In addition to the default directory_separator allow the '/' to
1440 -- act as separator since this is allowed in MS-DOS, Windows 95/NT,
1441 -- and OS2 ports. On VMS, the situation is more complicated because
1442 -- there are two characters to check for.
1445 C = Directory_Separator
1447 or else (Hostparm.OpenVMS
1448 and then (C = ']' or else C = ':'));
1449 end Is_Directory_Separator;
1451 -------------------------
1452 -- Is_Readonly_Library --
1453 -------------------------
1455 function Is_Readonly_Library (File : File_Name_Type) return Boolean is
1457 Get_Name_String (File);
1459 pragma Assert (Name_Buffer (Name_Len - 3 .. Name_Len) = ".ali");
1461 return not Is_Writable_File (Name_Buffer (1 .. Name_Len));
1462 end Is_Readonly_Library;
1468 function Lib_File_Name
1469 (Source_File : File_Name_Type;
1470 Munit_Index : Nat := 0) return File_Name_Type
1473 Get_Name_String (Source_File);
1475 for J in reverse 2 .. Name_Len loop
1476 if Name_Buffer (J) = '.' then
1482 if Munit_Index /= 0 then
1483 Add_Char_To_Name_Buffer (Multi_Unit_Index_Character);
1484 Add_Nat_To_Name_Buffer (Munit_Index);
1487 Add_Char_To_Name_Buffer ('.');
1488 Add_Str_To_Name_Buffer (ALI_Suffix.all);
1492 ------------------------
1493 -- Library_File_Stamp --
1494 ------------------------
1496 function Library_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is
1498 return File_Stamp (Find_File (N, Library));
1499 end Library_File_Stamp;
1505 function Locate_File
1506 (N : File_Name_Type;
1509 Name : String) return File_Name_Type
1511 Dir_Name : String_Ptr;
1514 -- If Name is already an absolute path, do not look for a directory
1516 if Is_Absolute_Path (Name) then
1519 elsif T = Library then
1520 Dir_Name := Lib_Search_Directories.Table (Dir);
1522 else pragma Assert (T /= Config);
1523 Dir_Name := Src_Search_Directories.Table (Dir);
1527 Full_Name : String (1 .. Dir_Name'Length + Name'Length);
1530 Full_Name (1 .. Dir_Name'Length) := Dir_Name.all;
1531 Full_Name (Dir_Name'Length + 1 .. Full_Name'Length) := Name;
1533 if not Is_Regular_File (Full_Name) then
1537 -- If the file is in the current directory then return N itself
1539 if Dir_Name'Length = 0 then
1542 Name_Len := Full_Name'Length;
1543 Name_Buffer (1 .. Name_Len) := Full_Name;
1550 -------------------------------
1551 -- Matching_Full_Source_Name --
1552 -------------------------------
1554 function Matching_Full_Source_Name
1555 (N : File_Name_Type;
1556 T : Time_Stamp_Type) return File_Name_Type
1559 Get_Name_String (N);
1562 File_Name : constant String := Name_Buffer (1 .. Name_Len);
1563 File : File_Name_Type := No_File;
1567 if Opt.Look_In_Primary_Dir then
1568 File := Locate_File (N, Source, Primary_Directory, File_Name);
1570 if File /= No_File and then T = File_Stamp (N) then
1575 Last_Dir := Src_Search_Directories.Last;
1577 for D in Primary_Directory + 1 .. Last_Dir loop
1578 File := Locate_File (N, Source, D, File_Name);
1580 if File /= No_File and then T = File_Stamp (File) then
1587 end Matching_Full_Source_Name;
1593 function More_Files return Boolean is
1595 return (Current_File_Name_Index < Number_File_Names);
1598 -------------------------------
1599 -- Nb_Dir_In_Obj_Search_Path --
1600 -------------------------------
1602 function Nb_Dir_In_Obj_Search_Path return Natural is
1604 if Opt.Look_In_Primary_Dir then
1605 return Lib_Search_Directories.Last - Primary_Directory + 1;
1607 return Lib_Search_Directories.Last - Primary_Directory;
1609 end Nb_Dir_In_Obj_Search_Path;
1611 -------------------------------
1612 -- Nb_Dir_In_Src_Search_Path --
1613 -------------------------------
1615 function Nb_Dir_In_Src_Search_Path return Natural is
1617 if Opt.Look_In_Primary_Dir then
1618 return Src_Search_Directories.Last - Primary_Directory + 1;
1620 return Src_Search_Directories.Last - Primary_Directory;
1622 end Nb_Dir_In_Src_Search_Path;
1624 --------------------
1625 -- Next_Main_File --
1626 --------------------
1628 function Next_Main_File return File_Name_Type is
1629 File_Name : String_Ptr;
1630 Dir_Name : String_Ptr;
1634 pragma Assert (More_Files);
1636 Current_File_Name_Index := Current_File_Name_Index + 1;
1638 -- Get the file and directory name
1640 File_Name := File_Names (Current_File_Name_Index);
1641 Fptr := File_Name'First;
1643 for J in reverse File_Name'Range loop
1644 if File_Name (J) = Directory_Separator
1645 or else File_Name (J) = '/'
1647 if J = File_Name'Last then
1648 Fail ("File name missing");
1656 -- Save name of directory in which main unit resides for use in
1657 -- locating other units
1659 Dir_Name := new String'(File_Name (File_Name'First .. Fptr - 1));
1661 case Running_Program is
1664 Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
1665 Look_In_Primary_Directory_For_Current_Main := True;
1668 Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
1670 if Fptr > File_Name'First then
1671 Look_In_Primary_Directory_For_Current_Main := True;
1674 when Binder | Gnatls =>
1675 Dir_Name := Normalize_Directory_Name (Dir_Name.all);
1676 Lib_Search_Directories.Table (Primary_Directory) := Dir_Name;
1682 Name_Len := File_Name'Last - Fptr + 1;
1683 Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last);
1684 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
1685 Current_Main := Name_Find;
1687 -- In the gnatmake case, the main file may have not have the
1688 -- extension. Try ".adb" first then ".ads"
1690 if Running_Program = Make then
1692 Orig_Main : constant File_Name_Type := Current_Main;
1695 if Strip_Suffix (Orig_Main) = Orig_Main then
1697 Append_Suffix_To_File_Name (Orig_Main, ".adb");
1699 if Full_Source_Name (Current_Main) = No_File then
1701 Append_Suffix_To_File_Name (Orig_Main, ".ads");
1703 if Full_Source_Name (Current_Main) = No_File then
1704 Current_Main := Orig_Main;
1711 return Current_Main;
1714 ------------------------------
1715 -- Normalize_Directory_Name --
1716 ------------------------------
1718 function Normalize_Directory_Name (Directory : String) return String_Ptr is
1720 function Is_Quoted (Path : String) return Boolean;
1721 pragma Inline (Is_Quoted);
1722 -- Returns true if Path is quoted (either double or single quotes)
1728 function Is_Quoted (Path : String) return Boolean is
1729 First : constant Character := Path (Path'First);
1730 Last : constant Character := Path (Path'Last);
1733 if (First = ''' and then Last = ''')
1735 (First = '"' and then Last = '"')
1743 Result : String_Ptr;
1745 -- Start of processing for Normalize_Directory_Name
1748 if Directory'Length = 0 then
1749 Result := new String'(Hostparm.Normalized_CWD);
1751 elsif Is_Directory_Separator (Directory (Directory'Last)) then
1752 Result := new String'(Directory);
1754 elsif Is_Quoted (Directory) then
1756 -- This is a quoted string, it certainly means that the directory
1757 -- contains some spaces for example. We can safely remove the quotes
1758 -- here as the OS_Lib.Normalize_Arguments will be called before any
1759 -- spawn routines. This ensure that quotes will be added when needed.
1761 Result := new String (1 .. Directory'Length - 1);
1762 Result (1 .. Directory'Length - 2) :=
1763 Directory (Directory'First + 1 .. Directory'Last - 1);
1764 Result (Result'Last) := Directory_Separator;
1767 Result := new String (1 .. Directory'Length + 1);
1768 Result (1 .. Directory'Length) := Directory;
1769 Result (Directory'Length + 1) := Directory_Separator;
1773 end Normalize_Directory_Name;
1775 ---------------------
1776 -- Number_Of_Files --
1777 ---------------------
1779 function Number_Of_Files return Int is
1781 return Number_File_Names;
1782 end Number_Of_Files;
1784 -------------------------------
1785 -- Object_Dir_Default_Prefix --
1786 -------------------------------
1788 function Object_Dir_Default_Prefix return String is
1789 Object_Dir : String_Access :=
1790 String_Access (Update_Path (Object_Dir_Default_Name));
1793 if Object_Dir = null then
1798 Result : constant String := Object_Dir.all;
1804 end Object_Dir_Default_Prefix;
1806 ----------------------
1807 -- Object_File_Name --
1808 ----------------------
1810 function Object_File_Name (N : File_Name_Type) return File_Name_Type is
1816 Get_Name_String (N);
1817 Name_Len := Name_Len - ALI_Suffix'Length - 1;
1819 for J in Target_Object_Suffix'Range loop
1820 Name_Len := Name_Len + 1;
1821 Name_Buffer (Name_Len) := Target_Object_Suffix (J);
1825 end Object_File_Name;
1827 --------------------------
1828 -- OS_Time_To_GNAT_Time --
1829 --------------------------
1831 function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type is
1832 GNAT_Time : Time_Stamp_Type;
1842 GM_Split (T, Y, Mo, D, H, Mn, S);
1848 Minutes => Nat (Mn),
1853 end OS_Time_To_GNAT_Time;
1859 function Program_Name (Nam : String) return String_Access is
1860 Res : String_Access;
1863 -- Get the name of the current program being executed
1867 -- Find the target prefix if any, for the cross compilation case.
1868 -- For instance in "alpha-dec-vxworks-gcc" the target prefix is
1869 -- "alpha-dec-vxworks-"
1871 while Name_Len > 0 loop
1873 -- All done if we find the last hyphen
1875 if Name_Buffer (Name_Len) = '-' then
1878 -- If directory separator found, we don't want to look further
1879 -- since in this case, no prefix has been found.
1881 elsif Is_Directory_Separator (Name_Buffer (Name_Len)) then
1886 Name_Len := Name_Len - 1;
1889 -- Create the new program name
1891 Res := new String (1 .. Name_Len + Nam'Length);
1892 Res.all (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
1893 Res.all (Name_Len + 1 .. Name_Len + Nam'Length) := Nam;
1897 ------------------------------
1898 -- Read_Default_Search_Dirs --
1899 ------------------------------
1901 function Read_Default_Search_Dirs
1902 (Search_Dir_Prefix : String_Access;
1903 Search_File : String_Access;
1904 Search_Dir_Default_Name : String_Access) return String_Access
1906 Prefix_Len : constant Integer := Search_Dir_Prefix.all'Length;
1907 Buffer : String (1 .. Prefix_Len + Search_File.all'Length + 1);
1908 File_FD : File_Descriptor;
1909 S, S1 : String_Access;
1912 Actual_Len : Integer;
1915 Prev_Was_Separator : Boolean;
1916 Nb_Relative_Dir : Integer;
1918 function Is_Relative (S : String; K : Positive) return Boolean;
1919 pragma Inline (Is_Relative);
1920 -- Returns True if a relative directory specification is found
1921 -- in S at position K, False otherwise.
1927 function Is_Relative (S : String; K : Positive) return Boolean is
1929 return not Is_Absolute_Path (S (K .. S'Last));
1932 -- Start of processing for Read_Default_Search_Dirs
1935 -- Construct a C compatible character string buffer
1937 Buffer (1 .. Search_Dir_Prefix.all'Length)
1938 := Search_Dir_Prefix.all;
1939 Buffer (Search_Dir_Prefix.all'Length + 1 .. Buffer'Last - 1)
1941 Buffer (Buffer'Last) := ASCII.NUL;
1943 File_FD := Open_Read (Buffer'Address, Binary);
1944 if File_FD = Invalid_FD then
1945 return Search_Dir_Default_Name;
1948 Len := Integer (File_Length (File_FD));
1950 -- An extra character for a trailing Path_Separator is allocated
1952 S := new String (1 .. Len + 1);
1953 S (Len + 1) := Path_Separator;
1955 -- Read the file. Note that the loop is not necessary since the
1956 -- whole file is read at once except on VMS.
1960 while Actual_Len /= 0 loop
1961 Actual_Len := Read (File_FD, S (Curr)'Address, Len);
1962 Curr := Curr + Actual_Len;
1965 -- Process the file, translating line and file ending
1966 -- control characters to a path separator character.
1968 Prev_Was_Separator := True;
1969 Nb_Relative_Dir := 0;
1970 for J in 1 .. Len loop
1971 if S (J) in ASCII.NUL .. ASCII.US or else S (J) = ' ' then
1972 S (J) := Path_Separator;
1975 if S (J) = Path_Separator then
1976 Prev_Was_Separator := True;
1979 if Prev_Was_Separator and then Is_Relative (S.all, J) then
1980 Nb_Relative_Dir := Nb_Relative_Dir + 1;
1983 Prev_Was_Separator := False;
1987 if Nb_Relative_Dir = 0 then
1991 -- Add the Search_Dir_Prefix to all relative paths
1993 S1 := new String (1 .. S'Length + Nb_Relative_Dir * Prefix_Len);
1995 Prev_Was_Separator := True;
1996 for J in 1 .. Len + 1 loop
1997 if S (J) = Path_Separator then
1998 Prev_Was_Separator := True;
2001 if Prev_Was_Separator and then Is_Relative (S.all, J) then
2002 S1 (J1 .. J1 + Prefix_Len - 1) := Search_Dir_Prefix.all;
2003 J1 := J1 + Prefix_Len;
2006 Prev_Was_Separator := False;
2014 end Read_Default_Search_Dirs;
2016 -----------------------
2017 -- Read_Library_Info --
2018 -----------------------
2020 function Read_Library_Info
2021 (Lib_File : File_Name_Type;
2022 Fatal_Err : Boolean := False) return Text_Buffer_Ptr
2024 Lib_FD : File_Descriptor;
2025 -- The file descriptor for the current library file. A negative value
2026 -- indicates failure to open the specified source file.
2028 Text : Text_Buffer_Ptr;
2029 -- Allocated text buffer
2032 -- For the calls to Close
2035 Current_Full_Lib_Name := Find_File (Lib_File, Library);
2036 Current_Full_Obj_Name := Object_File_Name (Current_Full_Lib_Name);
2038 if Current_Full_Lib_Name = No_File then
2040 Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
2042 Current_Full_Obj_Stamp := Empty_Time_Stamp;
2047 Get_Name_String (Current_Full_Lib_Name);
2048 Name_Buffer (Name_Len + 1) := ASCII.NUL;
2050 -- Open the library FD, note that we open in binary mode, because as
2051 -- documented in the spec, the caller is expected to handle either
2052 -- DOS or Unix mode files, and there is no point in wasting time on
2053 -- text translation when it is not required.
2055 Lib_FD := Open_Read (Name_Buffer'Address, Binary);
2057 if Lib_FD = Invalid_FD then
2059 Fail ("Cannot open: ", Name_Buffer (1 .. Name_Len));
2061 Current_Full_Obj_Stamp := Empty_Time_Stamp;
2066 -- Check for object file consistency if requested
2068 if Opt.Check_Object_Consistency then
2069 Current_Full_Lib_Stamp := File_Stamp (Current_Full_Lib_Name);
2070 Current_Full_Obj_Stamp := File_Stamp (Current_Full_Obj_Name);
2072 if Current_Full_Obj_Stamp (1) = ' ' then
2074 -- When the library is readonly always assume object is consistent
2076 if Is_Readonly_Library (Current_Full_Lib_Name) then
2077 Current_Full_Obj_Stamp := Current_Full_Lib_Stamp;
2079 elsif Fatal_Err then
2080 Get_Name_String (Current_Full_Obj_Name);
2081 Close (Lib_FD, Status);
2083 -- No need to check the status, we fail anyway
2085 Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
2088 Current_Full_Obj_Stamp := Empty_Time_Stamp;
2089 Close (Lib_FD, Status);
2091 -- No need to check the status, we return null anyway
2098 -- Read data from the file
2101 Len : constant Integer := Integer (File_Length (Lib_FD));
2102 -- Length of source file text. If it doesn't fit in an integer
2103 -- we're probably stuck anyway (>2 gigs of source seems a lot!)
2105 Actual_Len : Integer := 0;
2107 Lo : constant Text_Ptr := 0;
2108 -- Low bound for allocated text buffer
2110 Hi : Text_Ptr := Text_Ptr (Len);
2111 -- High bound for allocated text buffer. Note length is Len + 1
2112 -- which allows for extra EOF character at the end of the buffer.
2115 -- Allocate text buffer. Note extra character at end for EOF
2117 Text := new Text_Buffer (Lo .. Hi);
2119 -- Some systems (e.g. VMS) have file types that require one
2120 -- read per line, so read until we get the Len bytes or until
2121 -- there are no more characters.
2125 Actual_Len := Read (Lib_FD, Text (Hi)'Address, Len);
2126 Hi := Hi + Text_Ptr (Actual_Len);
2127 exit when Actual_Len = Len or Actual_Len <= 0;
2133 -- Read is complete, close file and we are done
2135 Close (Lib_FD, Status);
2136 -- The status should never be False. But, if it is, what can we do?
2137 -- So, we don't test it.
2141 end Read_Library_Info;
2143 ----------------------
2144 -- Read_Source_File --
2145 ----------------------
2147 procedure Read_Source_File
2148 (N : File_Name_Type;
2150 Hi : out Source_Ptr;
2151 Src : out Source_Buffer_Ptr;
2152 T : File_Type := Source)
2154 Source_File_FD : File_Descriptor;
2155 -- The file descriptor for the current source file. A negative value
2156 -- indicates failure to open the specified source file.
2159 -- Length of file. Assume no more than 2 gigabytes of source!
2161 Actual_Len : Integer;
2164 -- For the call to Close
2167 Current_Full_Source_Name := Find_File (N, T);
2168 Current_Full_Source_Stamp := File_Stamp (Current_Full_Source_Name);
2170 if Current_Full_Source_Name = No_File then
2172 -- If we were trying to access the main file and we could not find
2173 -- it, we have an error.
2175 if N = Current_Main then
2176 Get_Name_String (N);
2177 Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
2185 Get_Name_String (Current_Full_Source_Name);
2186 Name_Buffer (Name_Len + 1) := ASCII.NUL;
2188 -- Open the source FD, note that we open in binary mode, because as
2189 -- documented in the spec, the caller is expected to handle either
2190 -- DOS or Unix mode files, and there is no point in wasting time on
2191 -- text translation when it is not required.
2193 Source_File_FD := Open_Read (Name_Buffer'Address, Binary);
2195 if Source_File_FD = Invalid_FD then
2201 -- Prepare to read data from the file
2203 Len := Integer (File_Length (Source_File_FD));
2205 -- Set Hi so that length is one more than the physical length,
2206 -- allowing for the extra EOF character at the end of the buffer
2208 Hi := Lo + Source_Ptr (Len);
2210 -- Do the actual read operation
2213 subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
2214 -- Physical buffer allocated
2216 type Actual_Source_Ptr is access Actual_Source_Buffer;
2217 -- This is the pointer type for the physical buffer allocated
2219 Actual_Ptr : constant Actual_Source_Ptr := new Actual_Source_Buffer;
2220 -- And this is the actual physical buffer
2223 -- Allocate source buffer, allowing extra character at end for EOF
2225 -- Some systems (e.g. VMS) have file types that require one
2226 -- read per line, so read until we get the Len bytes or until
2227 -- there are no more characters.
2231 Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len);
2232 Hi := Hi + Source_Ptr (Actual_Len);
2233 exit when Actual_Len = Len or Actual_Len <= 0;
2236 Actual_Ptr (Hi) := EOF;
2238 -- Now we need to work out the proper virtual origin pointer to
2239 -- return. This is exactly Actual_Ptr (0)'Address, but we have
2240 -- to be careful to suppress checks to compute this address.
2243 pragma Suppress (All_Checks);
2245 pragma Warnings (Off);
2246 -- This use of unchecked conversion is aliasing safe
2248 function To_Source_Buffer_Ptr is new
2249 Unchecked_Conversion (Address, Source_Buffer_Ptr);
2251 pragma Warnings (On);
2254 Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
2258 -- Read is complete, get time stamp and close file and we are done
2260 Close (Source_File_FD, Status);
2262 -- The status should never be False. But, if it is, what can we do?
2263 -- So, we don't test it.
2265 end Read_Source_File;
2271 function Relocate_Path
2273 Path : String) return String_Ptr
2277 procedure set_std_prefix (S : String; Len : Integer);
2278 pragma Import (C, set_std_prefix);
2281 if Std_Prefix = null then
2282 Std_Prefix := Executable_Prefix;
2284 if Std_Prefix.all /= "" then
2286 -- Remove trailing directory separator when calling set_std_prefix
2288 set_std_prefix (Std_Prefix.all, Std_Prefix'Length - 1);
2292 if Path (Prefix'Range) = Prefix then
2293 if Std_Prefix.all /= "" then
2295 (1 .. Std_Prefix'Length + Path'Last - Prefix'Last);
2296 S (1 .. Std_Prefix'Length) := Std_Prefix.all;
2297 S (Std_Prefix'Length + 1 .. S'Last) :=
2298 Path (Prefix'Last + 1 .. Path'Last);
2303 return new String'(Path);
2310 procedure Set_Program (P : Program_Type) is
2313 Fail ("Set_Program called twice");
2316 Program_Set := True;
2317 Running_Program := P;
2324 function Shared_Lib (Name : String) return String is
2325 Library : String (1 .. Name'Length + Library_Version'Length + 3);
2326 -- 3 = 2 for "-l" + 1 for "-" before lib version
2329 Library (1 .. 2) := "-l";
2330 Library (3 .. 2 + Name'Length) := Name;
2331 Library (3 + Name'Length) := '-';
2332 Library (4 + Name'Length .. Library'Last) := Library_Version;
2334 if OpenVMS_On_Target then
2335 for K in Library'First + 2 .. Library'Last loop
2336 if Library (K) = '.' or else Library (K) = '-' then
2345 ----------------------
2346 -- Smart_File_Stamp --
2347 ----------------------
2349 function Smart_File_Stamp
2350 (N : File_Name_Type;
2351 T : File_Type) return Time_Stamp_Type
2353 Time_Stamp : Time_Stamp_Type;
2356 if not File_Cache_Enabled then
2357 return File_Stamp (Find_File (N, T));
2360 Time_Stamp := File_Stamp_Hash_Table.Get (N);
2362 if Time_Stamp (1) = ' ' then
2363 Time_Stamp := File_Stamp (Smart_Find_File (N, T));
2364 File_Stamp_Hash_Table.Set (N, Time_Stamp);
2368 end Smart_File_Stamp;
2370 ---------------------
2371 -- Smart_Find_File --
2372 ---------------------
2374 function Smart_Find_File
2375 (N : File_Name_Type;
2376 T : File_Type) return File_Name_Type
2378 Full_File_Name : File_Name_Type;
2381 if not File_Cache_Enabled then
2382 return Find_File (N, T);
2385 Full_File_Name := File_Name_Hash_Table.Get (N);
2387 if Full_File_Name = No_File then
2388 Full_File_Name := Find_File (N, T);
2389 File_Name_Hash_Table.Set (N, Full_File_Name);
2392 return Full_File_Name;
2393 end Smart_Find_File;
2395 ----------------------
2396 -- Source_File_Data --
2397 ----------------------
2399 procedure Source_File_Data (Cache : Boolean) is
2401 File_Cache_Enabled := Cache;
2402 end Source_File_Data;
2404 -----------------------
2405 -- Source_File_Stamp --
2406 -----------------------
2408 function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is
2410 return Smart_File_Stamp (N, Source);
2411 end Source_File_Stamp;
2413 ---------------------
2414 -- Strip_Directory --
2415 ---------------------
2417 function Strip_Directory (Name : File_Name_Type) return File_Name_Type is
2419 Get_Name_String (Name);
2421 for J in reverse 1 .. Name_Len - 1 loop
2423 -- If we find the last directory separator
2425 if Is_Directory_Separator (Name_Buffer (J)) then
2427 -- Return the part of Name that follows this last directory
2430 Name_Buffer (1 .. Name_Len - J) := Name_Buffer (J + 1 .. Name_Len);
2431 Name_Len := Name_Len - J;
2436 -- There were no directory separator, just return Name
2439 end Strip_Directory;
2445 function Strip_Suffix (Name : File_Name_Type) return File_Name_Type is
2447 Get_Name_String (Name);
2449 for J in reverse 2 .. Name_Len loop
2451 -- If we found the last '.', return part of Name that precedes it
2453 if Name_Buffer (J) = '.' then
2462 ---------------------------
2463 -- To_Canonical_Dir_Spec --
2464 ---------------------------
2466 function To_Canonical_Dir_Spec
2468 Prefix_Style : Boolean) return String_Access
2470 function To_Canonical_Dir_Spec
2471 (Host_Dir : Address;
2472 Prefix_Flag : Integer) return Address;
2473 pragma Import (C, To_Canonical_Dir_Spec, "__gnat_to_canonical_dir_spec");
2475 C_Host_Dir : String (1 .. Host_Dir'Length + 1);
2476 Canonical_Dir_Addr : Address;
2477 Canonical_Dir_Len : Integer;
2480 C_Host_Dir (1 .. Host_Dir'Length) := Host_Dir;
2481 C_Host_Dir (C_Host_Dir'Last) := ASCII.NUL;
2483 if Prefix_Style then
2484 Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 1);
2486 Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 0);
2488 Canonical_Dir_Len := C_String_Length (Canonical_Dir_Addr);
2490 if Canonical_Dir_Len = 0 then
2493 return To_Path_String_Access (Canonical_Dir_Addr, Canonical_Dir_Len);
2498 Fail ("erroneous directory spec: ", Host_Dir);
2500 end To_Canonical_Dir_Spec;
2502 ---------------------------
2503 -- To_Canonical_File_List --
2504 ---------------------------
2506 function To_Canonical_File_List
2507 (Wildcard_Host_File : String;
2508 Only_Dirs : Boolean) return String_Access_List_Access
2510 function To_Canonical_File_List_Init
2511 (Host_File : Address;
2512 Only_Dirs : Integer) return Integer;
2513 pragma Import (C, To_Canonical_File_List_Init,
2514 "__gnat_to_canonical_file_list_init");
2516 function To_Canonical_File_List_Next return Address;
2517 pragma Import (C, To_Canonical_File_List_Next,
2518 "__gnat_to_canonical_file_list_next");
2520 procedure To_Canonical_File_List_Free;
2521 pragma Import (C, To_Canonical_File_List_Free,
2522 "__gnat_to_canonical_file_list_free");
2524 Num_Files : Integer;
2525 C_Wildcard_Host_File : String (1 .. Wildcard_Host_File'Length + 1);
2528 C_Wildcard_Host_File (1 .. Wildcard_Host_File'Length) :=
2530 C_Wildcard_Host_File (C_Wildcard_Host_File'Last) := ASCII.NUL;
2532 -- Do the expansion and say how many there are
2534 Num_Files := To_Canonical_File_List_Init
2535 (C_Wildcard_Host_File'Address, Boolean'Pos (Only_Dirs));
2538 Canonical_File_List : String_Access_List (1 .. Num_Files);
2539 Canonical_File_Addr : Address;
2540 Canonical_File_Len : Integer;
2543 -- Retrieve the expanded directoy names and build the list
2545 for J in 1 .. Num_Files loop
2546 Canonical_File_Addr := To_Canonical_File_List_Next;
2547 Canonical_File_Len := C_String_Length (Canonical_File_Addr);
2548 Canonical_File_List (J) := To_Path_String_Access
2549 (Canonical_File_Addr, Canonical_File_Len);
2552 -- Free up the storage
2554 To_Canonical_File_List_Free;
2556 return new String_Access_List'(Canonical_File_List);
2558 end To_Canonical_File_List;
2560 ----------------------------
2561 -- To_Canonical_File_Spec --
2562 ----------------------------
2564 function To_Canonical_File_Spec
2565 (Host_File : String) return String_Access
2567 function To_Canonical_File_Spec (Host_File : Address) return Address;
2569 (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
2571 C_Host_File : String (1 .. Host_File'Length + 1);
2572 Canonical_File_Addr : Address;
2573 Canonical_File_Len : Integer;
2576 C_Host_File (1 .. Host_File'Length) := Host_File;
2577 C_Host_File (C_Host_File'Last) := ASCII.NUL;
2579 Canonical_File_Addr := To_Canonical_File_Spec (C_Host_File'Address);
2580 Canonical_File_Len := C_String_Length (Canonical_File_Addr);
2582 if Canonical_File_Len = 0 then
2585 return To_Path_String_Access
2586 (Canonical_File_Addr, Canonical_File_Len);
2591 Fail ("erroneous file spec: ", Host_File);
2593 end To_Canonical_File_Spec;
2595 ----------------------------
2596 -- To_Canonical_Path_Spec --
2597 ----------------------------
2599 function To_Canonical_Path_Spec
2600 (Host_Path : String) return String_Access
2602 function To_Canonical_Path_Spec (Host_Path : Address) return Address;
2604 (C, To_Canonical_Path_Spec, "__gnat_to_canonical_path_spec");
2606 C_Host_Path : String (1 .. Host_Path'Length + 1);
2607 Canonical_Path_Addr : Address;
2608 Canonical_Path_Len : Integer;
2611 C_Host_Path (1 .. Host_Path'Length) := Host_Path;
2612 C_Host_Path (C_Host_Path'Last) := ASCII.NUL;
2614 Canonical_Path_Addr := To_Canonical_Path_Spec (C_Host_Path'Address);
2615 Canonical_Path_Len := C_String_Length (Canonical_Path_Addr);
2617 -- Return a null string (vice a null) for zero length paths, for
2618 -- compatibility with getenv().
2620 return To_Path_String_Access (Canonical_Path_Addr, Canonical_Path_Len);
2624 Fail ("erroneous path spec: ", Host_Path);
2626 end To_Canonical_Path_Spec;
2628 ---------------------------
2629 -- To_Host_Dir_Spec --
2630 ---------------------------
2632 function To_Host_Dir_Spec
2633 (Canonical_Dir : String;
2634 Prefix_Style : Boolean) return String_Access
2636 function To_Host_Dir_Spec
2637 (Canonical_Dir : Address;
2638 Prefix_Flag : Integer) return Address;
2639 pragma Import (C, To_Host_Dir_Spec, "__gnat_to_host_dir_spec");
2641 C_Canonical_Dir : String (1 .. Canonical_Dir'Length + 1);
2642 Host_Dir_Addr : Address;
2643 Host_Dir_Len : Integer;
2646 C_Canonical_Dir (1 .. Canonical_Dir'Length) := Canonical_Dir;
2647 C_Canonical_Dir (C_Canonical_Dir'Last) := ASCII.NUL;
2649 if Prefix_Style then
2650 Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 1);
2652 Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 0);
2654 Host_Dir_Len := C_String_Length (Host_Dir_Addr);
2656 if Host_Dir_Len = 0 then
2659 return To_Path_String_Access (Host_Dir_Addr, Host_Dir_Len);
2661 end To_Host_Dir_Spec;
2663 ----------------------------
2664 -- To_Host_File_Spec --
2665 ----------------------------
2667 function To_Host_File_Spec
2668 (Canonical_File : String) return String_Access
2670 function To_Host_File_Spec (Canonical_File : Address) return Address;
2671 pragma Import (C, To_Host_File_Spec, "__gnat_to_host_file_spec");
2673 C_Canonical_File : String (1 .. Canonical_File'Length + 1);
2674 Host_File_Addr : Address;
2675 Host_File_Len : Integer;
2678 C_Canonical_File (1 .. Canonical_File'Length) := Canonical_File;
2679 C_Canonical_File (C_Canonical_File'Last) := ASCII.NUL;
2681 Host_File_Addr := To_Host_File_Spec (C_Canonical_File'Address);
2682 Host_File_Len := C_String_Length (Host_File_Addr);
2684 if Host_File_Len = 0 then
2687 return To_Path_String_Access
2688 (Host_File_Addr, Host_File_Len);
2690 end To_Host_File_Spec;
2692 ---------------------------
2693 -- To_Path_String_Access --
2694 ---------------------------
2696 function To_Path_String_Access
2697 (Path_Addr : Address;
2698 Path_Len : Integer) return String_Access
2700 subtype Path_String is String (1 .. Path_Len);
2701 type Path_String_Access is access Path_String;
2703 function Address_To_Access is new
2704 Unchecked_Conversion (Source => Address,
2705 Target => Path_String_Access);
2707 Path_Access : constant Path_String_Access :=
2708 Address_To_Access (Path_Addr);
2710 Return_Val : String_Access;
2713 Return_Val := new String (1 .. Path_Len);
2715 for J in 1 .. Path_Len loop
2716 Return_Val (J) := Path_Access (J);
2720 end To_Path_String_Access;
2726 function Update_Path (Path : String_Ptr) return String_Ptr is
2728 function C_Update_Path (Path, Component : Address) return Address;
2729 pragma Import (C, C_Update_Path, "update_path");
2731 function Strlen (Str : Address) return Integer;
2732 pragma Import (C, Strlen, "strlen");
2734 procedure Strncpy (X : Address; Y : Address; Length : Integer);
2735 pragma Import (C, Strncpy, "strncpy");
2737 In_Length : constant Integer := Path'Length;
2738 In_String : String (1 .. In_Length + 1);
2739 Component_Name : aliased String := "GCC" & ASCII.NUL;
2740 Result_Ptr : Address;
2741 Result_Length : Integer;
2742 Out_String : String_Ptr;
2745 In_String (1 .. In_Length) := Path.all;
2746 In_String (In_Length + 1) := ASCII.NUL;
2747 Result_Ptr := C_Update_Path (In_String'Address, Component_Name'Address);
2748 Result_Length := Strlen (Result_Ptr);
2750 Out_String := new String (1 .. Result_Length);
2751 Strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
2759 procedure Write_Info (Info : String) is
2761 Write_With_Check (Info'Address, Info'Length);
2762 Write_With_Check (EOL'Address, 1);
2765 ------------------------
2766 -- Write_Program_Name --
2767 ------------------------
2769 procedure Write_Program_Name is
2770 Save_Buffer : constant String (1 .. Name_Len) :=
2771 Name_Buffer (1 .. Name_Len);
2776 -- Convert the name to lower case so error messages are the same on
2779 for J in 1 .. Name_Len loop
2780 if Name_Buffer (J) in 'A' .. 'Z' then
2782 Character'Val (Character'Pos (Name_Buffer (J)) + 32);
2786 Write_Str (Name_Buffer (1 .. Name_Len));
2788 -- Restore Name_Buffer which was clobbered by the call to
2789 -- Find_Program_Name
2791 Name_Len := Save_Buffer'Last;
2792 Name_Buffer (1 .. Name_Len) := Save_Buffer;
2793 end Write_Program_Name;
2795 ----------------------
2796 -- Write_With_Check --
2797 ----------------------
2799 procedure Write_With_Check (A : Address; N : Integer) is
2803 if N = Write (Output_FD, A, N) then
2807 Write_Str ("error: disk full writing ");
2808 Write_Name_Decoded (Output_File_Name);
2810 Name_Len := Name_Len + 1;
2811 Name_Buffer (Name_Len) := ASCII.NUL;
2812 Delete_File (Name_Buffer'Address, Ignore);
2813 Exit_Program (E_Fatal);
2815 end Write_With_Check;
2817 ----------------------------
2818 -- Package Initialization --
2819 ----------------------------
2822 Initialization : declare
2824 function Get_Default_Identifier_Character_Set return Character;
2825 pragma Import (C, Get_Default_Identifier_Character_Set,
2826 "__gnat_get_default_identifier_character_set");
2827 -- Function to determine the default identifier character set,
2828 -- which is system dependent. See Opt package spec for a list of
2829 -- the possible character codes and their interpretations.
2831 function Get_Maximum_File_Name_Length return Int;
2832 pragma Import (C, Get_Maximum_File_Name_Length,
2833 "__gnat_get_maximum_file_name_length");
2834 -- Function to get maximum file name length for system
2837 Identifier_Character_Set := Get_Default_Identifier_Character_Set;
2838 Maximum_File_Name_Length := Get_Maximum_File_Name_Length;
2840 -- Following should be removed by having above function return
2841 -- Integer'Last as indication of no maximum instead of -1 ???
2843 if Maximum_File_Name_Length = -1 then
2844 Maximum_File_Name_Length := Int'Last;
2847 Src_Search_Directories.Set_Last (Primary_Directory);
2848 Src_Search_Directories.Table (Primary_Directory) := new String'("");
2850 Lib_Search_Directories.Set_Last (Primary_Directory);
2851 Lib_Search_Directories.Table (Primary_Directory) := new String'("");