1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2004 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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 ------------------------------------------------------------------------------
28 with Gnatvsn; use Gnatvsn;
30 with Namet; use Namet;
32 with Output; use Output;
33 with Sdefault; use Sdefault;
36 with System.Case_Util; use System.Case_Util;
38 with Unchecked_Conversion;
40 with GNAT.OS_Lib; use GNAT.OS_Lib;
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
66 -- message construction. These names need not be accessible by Name_Find,
67 -- and can be therefore created by using routine Name_Enter. The files in
68 -- question are file names with a prefix directory (ie the files not
69 -- in the current directory). File names without a prefix directory are
70 -- entered with Name_Find because special values might be attached to
71 -- the various Info fields of the corresponding name table entry.
73 -----------------------
74 -- Local Subprograms --
75 -----------------------
77 function Append_Suffix_To_File_Name
79 Suffix : String) return Name_Id;
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
85 function Concat (String_One : String; String_Two : String) return String;
86 -- Concatenates 2 strings and returns the result of the concatenation
88 function Executable_Prefix return String_Ptr;
89 -- Returns the name of the root directory where the executable is stored.
90 -- The executable must be located in a directory called "bin", or
91 -- under root/lib/gcc-lib/..., or under root/libexec/gcc/... Thus, if
92 -- the executable is stored in directory "/foo/bar/bin", this routine
93 -- returns "/foo/bar/". Return "" if the location is not recognized
94 -- as described above.
96 function Update_Path (Path : String_Ptr) return String_Ptr;
97 -- Update the specified path to replace the prefix with the location
98 -- where GNAT is installed. See the file prefix.c in GCC for details.
100 procedure Write_With_Check (A : Address; N : Integer);
101 -- Writes N bytes from buffer starting at address A to file whose FD is
102 -- stored in Output_FD, and whose file name is stored as a File_Name_Type
103 -- in Output_File_Name. A check is made for disk full, and if this is
104 -- detected, the file being written is deleted, and a fatal error is
111 Name : String) return File_Name_Type;
112 -- See if the file N whose name is Name exists in directory Dir. Dir is
113 -- an index into the Lib_Search_Directories table if T = Library.
114 -- Otherwise if T = Source, Dir is an index into the
115 -- Src_Search_Directories table. Returns the File_Name_Type of the
116 -- full file name if file found, or No_File if not found.
118 function C_String_Length (S : Address) return Integer;
119 -- Returns length of a C string. Returns zero for a null address.
121 function To_Path_String_Access
122 (Path_Addr : Address;
123 Path_Len : Integer) return String_Access;
124 -- Converts a C String to an Ada String. Are we doing this to avoid
125 -- withing Interfaces.C.Strings ???
127 ------------------------------
128 -- Other Local Declarations --
129 ------------------------------
131 EOL : constant Character := ASCII.LF;
132 -- End of line character
134 Number_File_Names : Int := 0;
135 -- The total number of file names found on command line and placed in
138 Look_In_Primary_Directory_For_Current_Main : Boolean := False;
139 -- When this variable is True, Find_File will only look in
140 -- the Primary_Directory for the Current_Main file.
141 -- This variable is always True for the compiler.
142 -- It is also True for gnatmake, when the soucr name given
143 -- on the command line has directory information.
145 Current_Full_Source_Name : File_Name_Type := No_File;
146 Current_Full_Source_Stamp : Time_Stamp_Type := Empty_Time_Stamp;
147 Current_Full_Lib_Name : File_Name_Type := No_File;
148 Current_Full_Lib_Stamp : Time_Stamp_Type := Empty_Time_Stamp;
149 Current_Full_Obj_Name : File_Name_Type := No_File;
150 Current_Full_Obj_Stamp : Time_Stamp_Type := Empty_Time_Stamp;
151 -- Respectively full name (with directory info) and time stamp of
152 -- the latest source, library and object files opened by Read_Source_File
153 -- and Read_Library_Info.
159 Primary_Directory : constant := 0;
160 -- This is index in the tables created below for the first directory to
161 -- search in for source or library information files. This is the
162 -- directory containing the latest main input file (a source file for
163 -- the compiler or a library file for the binder).
165 package Src_Search_Directories is new Table.Table (
166 Table_Component_Type => String_Ptr,
167 Table_Index_Type => Natural,
168 Table_Low_Bound => Primary_Directory,
170 Table_Increment => 100,
171 Table_Name => "Osint.Src_Search_Directories");
172 -- Table of names of directories in which to search for source (Compiler)
173 -- files. This table is filled in the order in which the directories are
174 -- to be searched, and then used in that order.
176 package Lib_Search_Directories is new Table.Table (
177 Table_Component_Type => String_Ptr,
178 Table_Index_Type => Natural,
179 Table_Low_Bound => Primary_Directory,
181 Table_Increment => 100,
182 Table_Name => "Osint.Lib_Search_Directories");
183 -- Table of names of directories in which to search for library (Binder)
184 -- files. This table is filled in the order in which the directories are
185 -- to be searched and then used in that order. The reason for having two
186 -- distinct tables is that we need them both in gnatmake.
188 ---------------------
189 -- File Hash Table --
190 ---------------------
192 -- The file hash table is provided to free the programmer from any
193 -- efficiency concern when retrieving full file names or time stamps of
194 -- source files. If the programmer calls Source_File_Data (Cache => True)
195 -- he is guaranteed that the price to retrieve the full name (ie with
196 -- directory info) or time stamp of the file will be payed only once,
197 -- the first time the full name is actually searched (or the first time
198 -- the time stamp is actually retrieved). This is achieved by employing
199 -- a hash table that stores as a key the File_Name_Type of the file and
200 -- associates to that File_Name_Type the full file name of the file and its
203 File_Cache_Enabled : Boolean := False;
204 -- Set to true if you want the enable the file data caching mechanism.
206 type File_Hash_Num is range 0 .. 1020;
208 function File_Hash (F : File_Name_Type) return File_Hash_Num;
209 -- Compute hash index for use by Simple_HTable
211 package File_Name_Hash_Table is new GNAT.HTable.Simple_HTable (
212 Header_Num => File_Hash_Num,
213 Element => File_Name_Type,
214 No_Element => No_File,
215 Key => File_Name_Type,
219 package File_Stamp_Hash_Table is new GNAT.HTable.Simple_HTable (
220 Header_Num => File_Hash_Num,
221 Element => Time_Stamp_Type,
222 No_Element => Empty_Time_Stamp,
223 Key => File_Name_Type,
227 function Smart_Find_File
229 T : File_Type) return File_Name_Type;
230 -- Exactly like Find_File except that if File_Cache_Enabled is True this
231 -- routine looks first in the hash table to see if the full name of the
232 -- file is already available.
234 function Smart_File_Stamp
236 T : File_Type) return Time_Stamp_Type;
237 -- Takes the same parameter as the routine above (N is a file name
238 -- without any prefix directory information) and behaves like File_Stamp
239 -- except that if File_Cache_Enabled is True this routine looks first in
240 -- the hash table to see if the file stamp of the file is already
243 -----------------------------
244 -- Add_Default_Search_Dirs --
245 -----------------------------
247 procedure Add_Default_Search_Dirs is
248 Search_Dir : String_Access;
249 Search_Path : String_Access;
250 Path_File_Name : String_Access;
252 procedure Add_Search_Dir
253 (Search_Dir : String;
254 Additional_Source_Dir : Boolean);
255 procedure Add_Search_Dir
256 (Search_Dir : String_Access;
257 Additional_Source_Dir : Boolean);
258 -- Add a source search dir or a library search dir, depending on the
259 -- value of Additional_Source_Dir.
261 procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean);
262 -- Open a path file and read the directory to search, one per line
264 function Get_Libraries_From_Registry return String_Ptr;
265 -- On Windows systems, get the list of installed standard libraries
266 -- from the registry key:
267 -- HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\
268 -- GNAT\Standard Libraries
269 -- Return an empty string on other systems
275 procedure Add_Search_Dir
276 (Search_Dir : String;
277 Additional_Source_Dir : Boolean)
280 if Additional_Source_Dir then
281 Add_Src_Search_Dir (Search_Dir);
283 Add_Lib_Search_Dir (Search_Dir);
287 procedure Add_Search_Dir
288 (Search_Dir : String_Access;
289 Additional_Source_Dir : Boolean)
292 if Additional_Source_Dir then
293 Add_Src_Search_Dir (Search_Dir.all);
295 Add_Lib_Search_Dir (Search_Dir.all);
299 ------------------------
300 -- Get_Dirs_From_File --
301 ------------------------
303 procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean) is
304 File_FD : File_Descriptor;
305 Buffer : String (1 .. Path_File_Name'Length + 1);
307 Actual_Len : Natural;
314 -- For the call to Close
317 -- Construct a C compatible character string buffer.
319 Buffer (1 .. Buffer'Last - 1) := Path_File_Name.all;
320 Buffer (Buffer'Last) := ASCII.NUL;
322 File_FD := Open_Read (Buffer'Address, Binary);
324 -- If we cannot open the file, we ignore it, we don't fail
326 if File_FD = Invalid_FD then
330 Len := Integer (File_Length (File_FD));
332 S := new String (1 .. Len);
334 -- Read the file. Note that the loop is not necessary since the
335 -- whole file is read at once except on VMS.
339 while Curr <= Len and then Actual_Len /= 0 loop
340 Actual_Len := Read (File_FD, S (Curr)'Address, Len);
341 Curr := Curr + Actual_Len;
344 -- We are done with the file, so we close it
346 Close (File_FD, Status);
347 -- We ignore any error here, because we have successfully read the
350 -- Now, we read line by line
355 while Curr < Len loop
358 if Ch = ASCII.CR or else Ch = ASCII.LF
359 or else Ch = ASCII.FF or else Ch = ASCII.VT
361 if First <= Curr then
362 Add_Search_Dir (S (First .. Curr), Additional_Source_Dir);
371 -- Last line is a special case, if the file does not end with
372 -- an end of line mark.
374 if First <= S'Last then
375 Add_Search_Dir (S (First .. S'Last), Additional_Source_Dir);
377 end Get_Dirs_From_File;
379 ---------------------------------
380 -- Get_Libraries_From_Registry --
381 ---------------------------------
383 function Get_Libraries_From_Registry return String_Ptr is
384 function C_Get_Libraries_From_Registry return Address;
385 pragma Import (C, C_Get_Libraries_From_Registry,
386 "__gnat_get_libraries_from_registry");
387 function Strlen (Str : Address) return Integer;
388 pragma Import (C, Strlen, "strlen");
389 procedure Strncpy (X : Address; Y : Address; Length : Integer);
390 pragma Import (C, Strncpy, "strncpy");
391 Result_Ptr : Address;
392 Result_Length : Integer;
393 Out_String : String_Ptr;
396 Result_Ptr := C_Get_Libraries_From_Registry;
397 Result_Length := Strlen (Result_Ptr);
399 Out_String := new String (1 .. Result_Length);
400 Strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
402 end Get_Libraries_From_Registry;
404 -- Start of processing for Add_Default_Search_Dirs
407 -- After the locations specified on the command line, the next places
408 -- to look for files are the directories specified by the appropriate
409 -- environment variable. Get this value, extract the directory names
410 -- and store in the tables.
412 -- On VMS, don't expand the logical name (e.g. environment variable),
413 -- just put it into Unix (e.g. canonical) format. System services
414 -- will handle the expansion as part of the file processing.
416 for Additional_Source_Dir in False .. True loop
418 if Additional_Source_Dir then
419 Search_Path := Getenv (Ada_Include_Path);
420 if Search_Path'Length > 0 then
421 if Hostparm.OpenVMS then
422 Search_Path := To_Canonical_Path_Spec ("ADA_INCLUDE_PATH:");
424 Search_Path := To_Canonical_Path_Spec (Search_Path.all);
428 Search_Path := Getenv (Ada_Objects_Path);
429 if Search_Path'Length > 0 then
430 if Hostparm.OpenVMS then
431 Search_Path := To_Canonical_Path_Spec ("ADA_OBJECTS_PATH:");
433 Search_Path := To_Canonical_Path_Spec (Search_Path.all);
438 Get_Next_Dir_In_Path_Init (Search_Path);
440 Search_Dir := Get_Next_Dir_In_Path (Search_Path);
441 exit when Search_Dir = null;
442 Add_Search_Dir (Search_Dir, Additional_Source_Dir);
446 -- Check for eventual project path file env vars
448 Path_File_Name := Getenv (Project_Include_Path_File);
450 if Path_File_Name'Length > 0 then
451 Get_Dirs_From_File (Additional_Source_Dir => True);
454 Path_File_Name := Getenv (Project_Objects_Path_File);
456 if Path_File_Name'Length > 0 then
457 Get_Dirs_From_File (Additional_Source_Dir => False);
460 -- For the compiler, if --RTS= was apecified, add the runtime
463 if RTS_Src_Path_Name /= null and then
464 RTS_Lib_Path_Name /= null
466 Add_Search_Dirs (RTS_Src_Path_Name, Include);
467 Add_Search_Dirs (RTS_Lib_Path_Name, Objects);
470 if not Opt.No_Stdinc then
472 -- For WIN32 systems, look for any system libraries defined in
473 -- the registry. These are added to both source and object
476 Search_Path := String_Access (Get_Libraries_From_Registry);
478 Get_Next_Dir_In_Path_Init (Search_Path);
480 Search_Dir := Get_Next_Dir_In_Path (Search_Path);
481 exit when Search_Dir = null;
482 Add_Search_Dir (Search_Dir, False);
483 Add_Search_Dir (Search_Dir, True);
486 -- The last place to look are the defaults
489 Read_Default_Search_Dirs
490 (String_Access (Update_Path (Search_Dir_Prefix)),
492 String_Access (Update_Path (Include_Dir_Default_Name)));
494 Get_Next_Dir_In_Path_Init (Search_Path);
496 Search_Dir := Get_Next_Dir_In_Path (Search_Path);
497 exit when Search_Dir = null;
498 Add_Search_Dir (Search_Dir, True);
502 if not Opt.No_Stdlib and not Opt.RTS_Switch then
504 Read_Default_Search_Dirs
505 (String_Access (Update_Path (Search_Dir_Prefix)),
507 String_Access (Update_Path (Object_Dir_Default_Name)));
509 Get_Next_Dir_In_Path_Init (Search_Path);
511 Search_Dir := Get_Next_Dir_In_Path (Search_Path);
512 exit when Search_Dir = null;
513 Add_Search_Dir (Search_Dir, False);
517 end Add_Default_Search_Dirs;
523 procedure Add_File (File_Name : String) is
525 Number_File_Names := Number_File_Names + 1;
527 -- As Add_File may be called for mains specified inside
528 -- a project file, File_Names may be too short and needs
531 if Number_File_Names > File_Names'Last then
532 File_Names := new File_Name_Array'(File_Names.all & File_Names.all);
535 File_Names (Number_File_Names) := new String'(File_Name);
538 ------------------------
539 -- Add_Lib_Search_Dir --
540 ------------------------
542 procedure Add_Lib_Search_Dir (Dir : String) is
544 if Dir'Length = 0 then
545 Fail ("missing library directory name");
548 Lib_Search_Directories.Increment_Last;
549 Lib_Search_Directories.Table (Lib_Search_Directories.Last) :=
550 Normalize_Directory_Name (Dir);
551 end Add_Lib_Search_Dir;
553 ---------------------
554 -- Add_Search_Dirs --
555 ---------------------
557 procedure Add_Search_Dirs
558 (Search_Path : String_Ptr;
559 Path_Type : Search_File_Type)
561 Current_Search_Path : String_Access;
564 Get_Next_Dir_In_Path_Init (String_Access (Search_Path));
566 Current_Search_Path :=
567 Get_Next_Dir_In_Path (String_Access (Search_Path));
568 exit when Current_Search_Path = null;
570 if Path_Type = Include then
571 Add_Src_Search_Dir (Current_Search_Path.all);
573 Add_Lib_Search_Dir (Current_Search_Path.all);
578 ------------------------
579 -- Add_Src_Search_Dir --
580 ------------------------
582 procedure Add_Src_Search_Dir (Dir : String) is
584 if Dir'Length = 0 then
585 Fail ("missing source directory name");
588 Src_Search_Directories.Increment_Last;
589 Src_Search_Directories.Table (Src_Search_Directories.Last) :=
590 Normalize_Directory_Name (Dir);
591 end Add_Src_Search_Dir;
593 --------------------------------
594 -- Append_Suffix_To_File_Name --
595 --------------------------------
597 function Append_Suffix_To_File_Name
599 Suffix : String) return Name_Id
602 Get_Name_String (Name);
603 Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
604 Name_Len := Name_Len + Suffix'Length;
606 end Append_Suffix_To_File_Name;
608 ---------------------
609 -- C_String_Length --
610 ---------------------
612 function C_String_Length (S : Address) return Integer is
613 function Strlen (S : Address) return Integer;
614 pragma Import (C, Strlen, "strlen");
616 if S = Null_Address then
623 ------------------------------
624 -- Canonical_Case_File_Name --
625 ------------------------------
627 -- For now, we only deal with the case of a-z. Eventually we should
628 -- worry about other Latin-1 letters on systems that support this ???
630 procedure Canonical_Case_File_Name (S : in out String) is
632 if not File_Names_Case_Sensitive then
633 for J in S'Range loop
634 if S (J) in 'A' .. 'Z' then
635 S (J) := Character'Val (
636 Character'Pos (S (J)) +
637 Character'Pos ('a') -
638 Character'Pos ('A'));
642 end Canonical_Case_File_Name;
648 function Concat (String_One : String; String_Two : String) return String is
649 Buffer : String (1 .. String_One'Length + String_Two'Length);
651 Buffer (1 .. String_One'Length) := String_One;
652 Buffer (String_One'Length + 1 .. Buffer'Last) := String_Two;
656 ---------------------------
657 -- Create_File_And_Check --
658 ---------------------------
660 procedure Create_File_And_Check
661 (Fdesc : out File_Descriptor;
665 Output_File_Name := Name_Enter;
666 Fdesc := Create_File (Name_Buffer'Address, Fmode);
668 if Fdesc = Invalid_FD then
669 Fail ("Cannot create: ", Name_Buffer (1 .. Name_Len));
671 end Create_File_And_Check;
673 --------------------------------
674 -- Current_Library_File_Stamp --
675 --------------------------------
677 function Current_Library_File_Stamp return Time_Stamp_Type is
679 return Current_Full_Lib_Stamp;
680 end Current_Library_File_Stamp;
682 -------------------------------
683 -- Current_Object_File_Stamp --
684 -------------------------------
686 function Current_Object_File_Stamp return Time_Stamp_Type is
688 return Current_Full_Obj_Stamp;
689 end Current_Object_File_Stamp;
691 -------------------------------
692 -- Current_Source_File_Stamp --
693 -------------------------------
695 function Current_Source_File_Stamp return Time_Stamp_Type is
697 return Current_Full_Source_Stamp;
698 end Current_Source_File_Stamp;
700 ----------------------------
701 -- Dir_In_Obj_Search_Path --
702 ----------------------------
704 function Dir_In_Obj_Search_Path (Position : Natural) return String_Ptr is
706 if Opt.Look_In_Primary_Dir then
708 Lib_Search_Directories.Table (Primary_Directory + Position - 1);
710 return Lib_Search_Directories.Table (Primary_Directory + Position);
712 end Dir_In_Obj_Search_Path;
714 ----------------------------
715 -- Dir_In_Src_Search_Path --
716 ----------------------------
718 function Dir_In_Src_Search_Path (Position : Natural) return String_Ptr is
720 if Opt.Look_In_Primary_Dir then
722 Src_Search_Directories.Table (Primary_Directory + Position - 1);
724 return Src_Search_Directories.Table (Primary_Directory + Position);
726 end Dir_In_Src_Search_Path;
728 ---------------------
729 -- Executable_Name --
730 ---------------------
732 function Executable_Name (Name : File_Name_Type) return File_Name_Type is
733 Exec_Suffix : String_Access;
736 if Name = No_File then
740 Get_Name_String (Name);
741 Exec_Suffix := Get_Executable_Suffix;
743 for J in Exec_Suffix'Range loop
744 Name_Len := Name_Len + 1;
745 Name_Buffer (Name_Len) := Exec_Suffix (J);
753 -----------------------
754 -- Executable_Prefix --
755 -----------------------
757 function Executable_Prefix return String_Ptr is
758 function Get_Install_Dir (Exec : String) return String_Ptr;
759 -- S is the executable name preceeded by the absolute or relative
760 -- path, e.g. "c:\usr\bin\gcc.exe" or "..\bin\gcc".
762 ---------------------
763 -- Get_Install_Dir --
764 ---------------------
766 function Get_Install_Dir (Exec : String) return String_Ptr is
768 for J in reverse Exec'Range loop
769 if Is_Directory_Separator (Exec (J)) then
770 if J < Exec'Last - 5 then
771 if (To_Lower (Exec (J + 1)) = 'l'
772 and then To_Lower (Exec (J + 2)) = 'i'
773 and then To_Lower (Exec (J + 3)) = 'b')
775 (To_Lower (Exec (J + 1)) = 'b'
776 and then To_Lower (Exec (J + 2)) = 'i'
777 and then To_Lower (Exec (J + 3)) = 'n')
779 return new String'(Exec (Exec'First .. J));
785 return new String'("");
788 -- Start of processing for Executable_Prefix
791 if Exec_Name = null then
792 Exec_Name := new String (1 .. Len_Arg (0));
793 Osint.Fill_Arg (Exec_Name (1)'Address, 0);
796 -- First determine if a path prefix was placed in front of the
799 for J in reverse Exec_Name'Range loop
800 if Is_Directory_Separator (Exec_Name (J)) then
801 return Get_Install_Dir (Exec_Name.all);
805 -- If we come here, the user has typed the executable name with no
808 return Get_Install_Dir
809 (GNAT.OS_Lib.Locate_Exec_On_Path (Exec_Name.all).all);
810 end Executable_Prefix;
816 procedure Exit_Program (Exit_Code : Exit_Code_Type) is
818 -- The program will exit with the following status:
820 -- 0 if the object file has been generated (with or without warnings)
821 -- 1 if recompilation was not needed (smart recompilation)
822 -- 2 if gnat1 has been killed by a signal (detected by GCC)
823 -- 4 for a fatal error
824 -- 5 if there were errors
825 -- 6 if no code has been generated (spec)
827 -- Note that exit code 3 is not used and must not be used as this is
828 -- the code returned by a program aborted via C abort() routine on
829 -- Windows. GCC checks for that case and thinks that the child process
830 -- has been aborted. This code (exit code 3) used to be the code used
831 -- for E_No_Code, but E_No_Code was changed to 6 for this reason.
834 when E_Success => OS_Exit (0);
835 when E_Warnings => OS_Exit (0);
836 when E_No_Compile => OS_Exit (1);
837 when E_Fatal => OS_Exit (4);
838 when E_Errors => OS_Exit (5);
839 when E_No_Code => OS_Exit (6);
840 when E_Abort => OS_Abort;
848 procedure Fail (S1 : String; S2 : String := ""; S3 : String := "") is
850 -- We use Output in case there is a special output set up.
851 -- In this case Set_Standard_Error will have no immediate effect.
854 Osint.Write_Program_Name;
861 Exit_Program (E_Fatal);
868 function File_Hash (F : File_Name_Type) return File_Hash_Num is
870 return File_Hash_Num (Int (F) rem File_Hash_Num'Range_Length);
877 function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type is
879 if Name = No_File then
880 return Empty_Time_Stamp;
883 Get_Name_String (Name);
885 if not Is_Regular_File (Name_Buffer (1 .. Name_Len)) then
886 return Empty_Time_Stamp;
888 Name_Buffer (Name_Len + 1) := ASCII.NUL;
889 return OS_Time_To_GNAT_Time (File_Time_Stamp (Name_Buffer));
899 T : File_Type) return File_Name_Type
905 File_Name : String renames Name_Buffer (1 .. Name_Len);
906 File : File_Name_Type := No_File;
910 -- If we are looking for a config file, look only in the current
911 -- directory, i.e. return input argument unchanged. Also look
912 -- only in the current directory if we are looking for a .dg
913 -- file (happens in -gnatD mode)
916 or else (Debug_Generated_Code
917 and then Name_Len > 3
919 (Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg"
921 (Hostparm.OpenVMS and then
922 Name_Buffer (Name_Len - 2 .. Name_Len) = "_dg")))
926 -- If we are trying to find the current main file just look in the
927 -- directory where the user said it was.
929 elsif Look_In_Primary_Directory_For_Current_Main
930 and then Current_Main = N
932 return Locate_File (N, T, Primary_Directory, File_Name);
934 -- Otherwise do standard search for source file
937 -- Check the mapping of this file name
939 File := Mapped_Path_Name (N);
941 -- If the file name is mapped to a path name, return the
942 -- corresponding path name
944 if File /= No_File then
945 -- For locally removed file, Error_Name is returned; then
946 -- return No_File, indicating the file is not a source.
948 if File = Error_Name then
956 -- First place to look is in the primary directory (i.e. the same
957 -- directory as the source) unless this has been disabled with -I-
959 if Opt.Look_In_Primary_Dir then
960 File := Locate_File (N, T, Primary_Directory, File_Name);
962 if File /= No_File then
967 -- Finally look in directories specified with switches -I/-aI/-aO
970 Last_Dir := Lib_Search_Directories.Last;
972 Last_Dir := Src_Search_Directories.Last;
975 for D in Primary_Directory + 1 .. Last_Dir loop
976 File := Locate_File (N, T, D, File_Name);
978 if File /= No_File then
988 -----------------------
989 -- Find_Program_Name --
990 -----------------------
992 procedure Find_Program_Name is
993 Command_Name : String (1 .. Len_Arg (0));
994 Cindex1 : Integer := Command_Name'First;
995 Cindex2 : Integer := Command_Name'Last;
998 Fill_Arg (Command_Name'Address, 0);
1000 -- The program name might be specified by a full path name. However,
1001 -- we don't want to print that all out in an error message, so the
1002 -- path might need to be stripped away.
1004 for J in reverse Cindex1 .. Cindex2 loop
1005 if Is_Directory_Separator (Command_Name (J)) then
1011 for J in reverse Cindex1 .. Cindex2 loop
1012 if Command_Name (J) = '.' then
1018 Name_Len := Cindex2 - Cindex1 + 1;
1019 Name_Buffer (1 .. Name_Len) := Command_Name (Cindex1 .. Cindex2);
1020 end Find_Program_Name;
1022 ------------------------
1023 -- Full_Lib_File_Name --
1024 ------------------------
1026 function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type is
1028 return Find_File (N, Library);
1029 end Full_Lib_File_Name;
1031 ----------------------------
1032 -- Full_Library_Info_Name --
1033 ----------------------------
1035 function Full_Library_Info_Name return File_Name_Type is
1037 return Current_Full_Lib_Name;
1038 end Full_Library_Info_Name;
1040 ---------------------------
1041 -- Full_Object_File_Name --
1042 ---------------------------
1044 function Full_Object_File_Name return File_Name_Type is
1046 return Current_Full_Obj_Name;
1047 end Full_Object_File_Name;
1049 ----------------------
1050 -- Full_Source_Name --
1051 ----------------------
1053 function Full_Source_Name return File_Name_Type is
1055 return Current_Full_Source_Name;
1056 end Full_Source_Name;
1058 ----------------------
1059 -- Full_Source_Name --
1060 ----------------------
1062 function Full_Source_Name (N : File_Name_Type) return File_Name_Type is
1064 return Smart_Find_File (N, Source);
1065 end Full_Source_Name;
1071 function Get_Directory (Name : File_Name_Type) return File_Name_Type is
1073 Get_Name_String (Name);
1075 for J in reverse 1 .. Name_Len loop
1076 if Is_Directory_Separator (Name_Buffer (J)) then
1082 Name_Len := Hostparm.Normalized_CWD'Length;
1083 Name_Buffer (1 .. Name_Len) := Hostparm.Normalized_CWD;
1087 --------------------------
1088 -- Get_Next_Dir_In_Path --
1089 --------------------------
1091 Search_Path_Pos : Integer;
1092 -- Keeps track of current position in search path. Initialized by the
1093 -- call to Get_Next_Dir_In_Path_Init, updated by Get_Next_Dir_In_Path.
1095 function Get_Next_Dir_In_Path
1096 (Search_Path : String_Access) return String_Access
1098 Lower_Bound : Positive := Search_Path_Pos;
1099 Upper_Bound : Positive;
1103 while Lower_Bound <= Search_Path'Last
1104 and then Search_Path.all (Lower_Bound) = Path_Separator
1106 Lower_Bound := Lower_Bound + 1;
1109 exit when Lower_Bound > Search_Path'Last;
1111 Upper_Bound := Lower_Bound;
1112 while Upper_Bound <= Search_Path'Last
1113 and then Search_Path.all (Upper_Bound) /= Path_Separator
1115 Upper_Bound := Upper_Bound + 1;
1118 Search_Path_Pos := Upper_Bound;
1119 return new String'(Search_Path.all (Lower_Bound .. Upper_Bound - 1));
1123 end Get_Next_Dir_In_Path;
1125 -------------------------------
1126 -- Get_Next_Dir_In_Path_Init --
1127 -------------------------------
1129 procedure Get_Next_Dir_In_Path_Init (Search_Path : String_Access) is
1131 Search_Path_Pos := Search_Path'First;
1132 end Get_Next_Dir_In_Path_Init;
1134 --------------------------------------
1135 -- Get_Primary_Src_Search_Directory --
1136 --------------------------------------
1138 function Get_Primary_Src_Search_Directory return String_Ptr is
1140 return Src_Search_Directories.Table (Primary_Directory);
1141 end Get_Primary_Src_Search_Directory;
1143 -------------------------
1144 -- Get_RTS_Search_Dir --
1145 -------------------------
1147 function Get_RTS_Search_Dir
1148 (Search_Dir : String;
1149 File_Type : Search_File_Type) return String_Ptr
1151 procedure Get_Current_Dir
1152 (Dir : System.Address;
1153 Length : System.Address);
1154 pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir");
1157 pragma Import (C, Max_Path, "__gnat_max_path_len");
1158 -- Maximum length of a path name
1160 Current_Dir : String_Ptr;
1161 Default_Search_Dir : String_Access;
1162 Default_Suffix_Dir : String_Access;
1163 Local_Search_Dir : String_Access;
1164 Norm_Search_Dir : String_Access;
1165 Result_Search_Dir : String_Access;
1166 Search_File : String_Access;
1167 Temp_String : String_Ptr;
1170 -- Add a directory separator at the end of the directory if necessary
1171 -- so that we can directly append a file to the directory
1173 if Search_Dir (Search_Dir'Last) /= Directory_Separator then
1174 Local_Search_Dir := new String'
1175 (Concat (Search_Dir, String'(1 => Directory_Separator)));
1177 Local_Search_Dir := new String'(Search_Dir);
1180 if File_Type = Include then
1181 Search_File := Include_Search_File;
1182 Default_Suffix_Dir := new String'("adainclude");
1184 Search_File := Objects_Search_File;
1185 Default_Suffix_Dir := new String'("adalib");
1188 Norm_Search_Dir := To_Canonical_Path_Spec (Local_Search_Dir.all);
1190 if Is_Absolute_Path (Norm_Search_Dir.all) then
1192 -- We first verify if there is a directory Include_Search_Dir
1193 -- containing default search directories
1196 := Read_Default_Search_Dirs (Norm_Search_Dir,
1199 Default_Search_Dir := new String'
1200 (Concat (Norm_Search_Dir.all, Default_Suffix_Dir.all));
1201 Free (Norm_Search_Dir);
1203 if Result_Search_Dir /= null then
1204 return String_Ptr (Result_Search_Dir);
1205 elsif Is_Directory (Default_Search_Dir.all) then
1206 return String_Ptr (Default_Search_Dir);
1211 -- Search in the current directory
1214 -- Get the current directory
1217 Buffer : String (1 .. Max_Path + 2);
1218 Path_Len : Natural := Max_Path;
1221 Get_Current_Dir (Buffer'Address, Path_Len'Address);
1223 if Buffer (Path_Len) /= Directory_Separator then
1224 Path_Len := Path_Len + 1;
1225 Buffer (Path_Len) := Directory_Separator;
1228 Current_Dir := new String'(Buffer (1 .. Path_Len));
1232 new String'(Concat (Current_Dir.all, Local_Search_Dir.all));
1234 Result_Search_Dir :=
1235 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1237 Default_Search_Dir :=
1239 (Concat (Norm_Search_Dir.all, Default_Suffix_Dir.all));
1241 Free (Norm_Search_Dir);
1243 if Result_Search_Dir /= null then
1244 return String_Ptr (Result_Search_Dir);
1246 elsif Is_Directory (Default_Search_Dir.all) then
1247 return String_Ptr (Default_Search_Dir);
1250 -- Search in Search_Dir_Prefix/Search_Dir
1254 (Concat (Update_Path (Search_Dir_Prefix).all,
1255 Local_Search_Dir.all));
1257 Result_Search_Dir :=
1258 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1260 Default_Search_Dir :=
1262 (Concat (Norm_Search_Dir.all, Default_Suffix_Dir.all));
1264 Free (Norm_Search_Dir);
1266 if Result_Search_Dir /= null then
1267 return String_Ptr (Result_Search_Dir);
1269 elsif Is_Directory (Default_Search_Dir.all) then
1270 return String_Ptr (Default_Search_Dir);
1273 -- We finally search in Search_Dir_Prefix/rts-Search_Dir
1277 (Concat (Update_Path (Search_Dir_Prefix).all, "rts-"));
1280 new String'(Concat (Temp_String.all, Local_Search_Dir.all));
1282 Result_Search_Dir :=
1283 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1285 Default_Search_Dir :=
1287 (Concat (Norm_Search_Dir.all, Default_Suffix_Dir.all));
1288 Free (Norm_Search_Dir);
1290 if Result_Search_Dir /= null then
1291 return String_Ptr (Result_Search_Dir);
1293 elsif Is_Directory (Default_Search_Dir.all) then
1294 return String_Ptr (Default_Search_Dir);
1302 end Get_RTS_Search_Dir;
1304 --------------------------------
1305 -- Include_Dir_Default_Prefix --
1306 --------------------------------
1308 function Include_Dir_Default_Prefix return String is
1309 Include_Dir : String_Access :=
1310 String_Access (Update_Path (Include_Dir_Default_Name));
1313 if Include_Dir = null then
1318 Result : constant String := Include_Dir.all;
1324 end Include_Dir_Default_Prefix;
1330 procedure Initialize is
1332 Number_File_Names := 0;
1333 Current_File_Name_Index := 0;
1335 Src_Search_Directories.Init;
1336 Lib_Search_Directories.Init;
1338 -- Start off by setting all suppress options to False, these will
1339 -- be reset later (turning some on if -gnato is not specified, and
1340 -- turning all of them on if -gnatp is specified).
1342 Suppress_Options := (others => False);
1344 -- Reserve the first slot in the search paths table. This is the
1345 -- directory of the main source file or main library file and is
1346 -- filled in by each call to Next_Main_Source/Next_Main_Lib_File with
1347 -- the directory specified for this main source or library file. This
1348 -- is the directory which is searched first by default. This default
1349 -- search is inhibited by the option -I- for both source and library
1352 Src_Search_Directories.Set_Last (Primary_Directory);
1353 Src_Search_Directories.Table (Primary_Directory) := new String'("");
1355 Lib_Search_Directories.Set_Last (Primary_Directory);
1356 Lib_Search_Directories.Table (Primary_Directory) := new String'("");
1359 ----------------------------
1360 -- Is_Directory_Separator --
1361 ----------------------------
1363 function Is_Directory_Separator (C : Character) return Boolean is
1365 -- In addition to the default directory_separator allow the '/' to
1366 -- act as separator since this is allowed in MS-DOS, Windows 95/NT,
1367 -- and OS2 ports. On VMS, the situation is more complicated because
1368 -- there are two characters to check for.
1371 C = Directory_Separator
1373 or else (Hostparm.OpenVMS
1374 and then (C = ']' or else C = ':'));
1375 end Is_Directory_Separator;
1377 -------------------------
1378 -- Is_Readonly_Library --
1379 -------------------------
1381 function Is_Readonly_Library (File : in File_Name_Type) return Boolean is
1383 Get_Name_String (File);
1385 pragma Assert (Name_Buffer (Name_Len - 3 .. Name_Len) = ".ali");
1387 return not Is_Writable_File (Name_Buffer (1 .. Name_Len));
1388 end Is_Readonly_Library;
1394 function Lib_File_Name
1395 (Source_File : File_Name_Type;
1396 Munit_Index : Nat := 0) return File_Name_Type
1399 Get_Name_String (Source_File);
1401 for J in reverse 2 .. Name_Len loop
1402 if Name_Buffer (J) = '.' then
1408 if Munit_Index /= 0 then
1409 Add_Char_To_Name_Buffer (Multi_Unit_Index_Character);
1410 Add_Nat_To_Name_Buffer (Munit_Index);
1413 Add_Char_To_Name_Buffer ('.');
1414 Add_Str_To_Name_Buffer (ALI_Suffix.all);
1418 ------------------------
1419 -- Library_File_Stamp --
1420 ------------------------
1422 function Library_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is
1424 return File_Stamp (Find_File (N, Library));
1425 end Library_File_Stamp;
1431 function Locate_File
1432 (N : File_Name_Type;
1435 Name : String) return File_Name_Type
1437 Dir_Name : String_Ptr;
1440 -- If Name is already an absolute path, do not look for a directory
1442 if Is_Absolute_Path (Name) then
1445 elsif T = Library then
1446 Dir_Name := Lib_Search_Directories.Table (Dir);
1448 else pragma Assert (T /= Config);
1449 Dir_Name := Src_Search_Directories.Table (Dir);
1453 Full_Name : String (1 .. Dir_Name'Length + Name'Length);
1456 Full_Name (1 .. Dir_Name'Length) := Dir_Name.all;
1457 Full_Name (Dir_Name'Length + 1 .. Full_Name'Length) := Name;
1459 if not Is_Regular_File (Full_Name) then
1463 -- If the file is in the current directory then return N itself
1465 if Dir_Name'Length = 0 then
1468 Name_Len := Full_Name'Length;
1469 Name_Buffer (1 .. Name_Len) := Full_Name;
1476 -------------------------------
1477 -- Matching_Full_Source_Name --
1478 -------------------------------
1480 function Matching_Full_Source_Name
1481 (N : File_Name_Type;
1482 T : Time_Stamp_Type) return File_Name_Type
1485 Get_Name_String (N);
1488 File_Name : constant String := Name_Buffer (1 .. Name_Len);
1489 File : File_Name_Type := No_File;
1493 if Opt.Look_In_Primary_Dir then
1494 File := Locate_File (N, Source, Primary_Directory, File_Name);
1496 if File /= No_File and then T = File_Stamp (N) then
1501 Last_Dir := Src_Search_Directories.Last;
1503 for D in Primary_Directory + 1 .. Last_Dir loop
1504 File := Locate_File (N, Source, D, File_Name);
1506 if File /= No_File and then T = File_Stamp (File) then
1513 end Matching_Full_Source_Name;
1519 function More_Files return Boolean is
1521 return (Current_File_Name_Index < Number_File_Names);
1524 -------------------------------
1525 -- Nb_Dir_In_Obj_Search_Path --
1526 -------------------------------
1528 function Nb_Dir_In_Obj_Search_Path return Natural is
1530 if Opt.Look_In_Primary_Dir then
1531 return Lib_Search_Directories.Last - Primary_Directory + 1;
1533 return Lib_Search_Directories.Last - Primary_Directory;
1535 end Nb_Dir_In_Obj_Search_Path;
1537 -------------------------------
1538 -- Nb_Dir_In_Src_Search_Path --
1539 -------------------------------
1541 function Nb_Dir_In_Src_Search_Path return Natural is
1543 if Opt.Look_In_Primary_Dir then
1544 return Src_Search_Directories.Last - Primary_Directory + 1;
1546 return Src_Search_Directories.Last - Primary_Directory;
1548 end Nb_Dir_In_Src_Search_Path;
1550 --------------------
1551 -- Next_Main_File --
1552 --------------------
1554 function Next_Main_File return File_Name_Type is
1555 File_Name : String_Ptr;
1556 Dir_Name : String_Ptr;
1560 pragma Assert (More_Files);
1562 Current_File_Name_Index := Current_File_Name_Index + 1;
1564 -- Get the file and directory name
1566 File_Name := File_Names (Current_File_Name_Index);
1567 Fptr := File_Name'First;
1569 for J in reverse File_Name'Range loop
1570 if File_Name (J) = Directory_Separator
1571 or else File_Name (J) = '/'
1573 if J = File_Name'Last then
1574 Fail ("File name missing");
1582 -- Save name of directory in which main unit resides for use in
1583 -- locating other units
1585 Dir_Name := new String'(File_Name (File_Name'First .. Fptr - 1));
1587 case Running_Program is
1590 Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
1591 Look_In_Primary_Directory_For_Current_Main := True;
1594 Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
1596 if Fptr > File_Name'First then
1597 Look_In_Primary_Directory_For_Current_Main := True;
1600 when Binder | Gnatls =>
1601 Dir_Name := Normalize_Directory_Name (Dir_Name.all);
1602 Lib_Search_Directories.Table (Primary_Directory) := Dir_Name;
1608 Name_Len := File_Name'Last - Fptr + 1;
1609 Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last);
1610 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
1611 Current_Main := File_Name_Type (Name_Find);
1613 -- In the gnatmake case, the main file may have not have the
1614 -- extension. Try ".adb" first then ".ads"
1616 if Running_Program = Make then
1618 Orig_Main : constant File_Name_Type := Current_Main;
1621 if Strip_Suffix (Orig_Main) = Orig_Main then
1622 Current_Main := Append_Suffix_To_File_Name (Orig_Main, ".adb");
1624 if Full_Source_Name (Current_Main) = No_File then
1626 Append_Suffix_To_File_Name (Orig_Main, ".ads");
1628 if Full_Source_Name (Current_Main) = No_File then
1629 Current_Main := Orig_Main;
1636 return Current_Main;
1639 ------------------------------
1640 -- Normalize_Directory_Name --
1641 ------------------------------
1643 function Normalize_Directory_Name (Directory : String) return String_Ptr is
1645 function Is_Quoted (Path : String) return Boolean;
1646 pragma Inline (Is_Quoted);
1647 -- Returns true if Path is quoted (either double or single quotes)
1653 function Is_Quoted (Path : String) return Boolean is
1654 First : constant Character := Path (Path'First);
1655 Last : constant Character := Path (Path'Last);
1658 if (First = ''' and then Last = ''')
1660 (First = '"' and then Last = '"')
1668 Result : String_Ptr;
1670 -- Start of processing for Normalize_Directory_Name
1673 if Directory'Length = 0 then
1674 Result := new String'(Hostparm.Normalized_CWD);
1676 elsif Is_Directory_Separator (Directory (Directory'Last)) then
1677 Result := new String'(Directory);
1679 elsif Is_Quoted (Directory) then
1681 -- This is a quoted string, it certainly means that the directory
1682 -- contains some spaces for example. We can safely remove the quotes
1683 -- here as the OS_Lib.Normalize_Arguments will be called before any
1684 -- spawn routines. This ensure that quotes will be added when needed.
1686 Result := new String (1 .. Directory'Length - 1);
1687 Result (1 .. Directory'Length - 1) :=
1688 Directory (Directory'First + 1 .. Directory'Last - 1);
1689 Result (Result'Last) := Directory_Separator;
1692 Result := new String (1 .. Directory'Length + 1);
1693 Result (1 .. Directory'Length) := Directory;
1694 Result (Directory'Length + 1) := Directory_Separator;
1698 end Normalize_Directory_Name;
1700 ---------------------
1701 -- Number_Of_Files --
1702 ---------------------
1704 function Number_Of_Files return Int is
1706 return Number_File_Names;
1707 end Number_Of_Files;
1709 -------------------------------
1710 -- Object_Dir_Default_Prefix --
1711 -------------------------------
1713 function Object_Dir_Default_Prefix return String is
1714 Object_Dir : String_Access :=
1715 String_Access (Update_Path (Object_Dir_Default_Name));
1718 if Object_Dir = null then
1723 Result : constant String := Object_Dir.all;
1729 end Object_Dir_Default_Prefix;
1731 ----------------------
1732 -- Object_File_Name --
1733 ----------------------
1735 function Object_File_Name (N : File_Name_Type) return File_Name_Type is
1741 Get_Name_String (N);
1742 Name_Len := Name_Len - ALI_Suffix'Length - 1;
1744 for J in Object_Suffix'Range loop
1745 Name_Len := Name_Len + 1;
1746 Name_Buffer (Name_Len) := Object_Suffix (J);
1750 end Object_File_Name;
1752 --------------------------
1753 -- OS_Time_To_GNAT_Time --
1754 --------------------------
1756 function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type is
1757 GNAT_Time : Time_Stamp_Type;
1767 GM_Split (T, Y, Mo, D, H, Mn, S);
1773 Minutes => Nat (Mn),
1778 end OS_Time_To_GNAT_Time;
1784 function Program_Name (Nam : String) return String_Access is
1785 Res : String_Access;
1788 -- Get the name of the current program being executed
1792 -- Find the target prefix if any, for the cross compilation case
1793 -- for instance in "alpha-dec-vxworks-gcc" the target prefix is
1794 -- "alpha-dec-vxworks-"
1796 while Name_Len > 0 loop
1798 -- All done if we find the last hyphen
1800 if Name_Buffer (Name_Len) = '-' then
1803 -- If directory separator found, we don't want to look further
1804 -- since in this case, no prefix has been found.
1806 elsif Is_Directory_Separator (Name_Buffer (Name_Len)) then
1811 Name_Len := Name_Len - 1;
1814 -- Create the new program name
1816 Res := new String (1 .. Name_Len + Nam'Length);
1817 Res.all (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
1818 Res.all (Name_Len + 1 .. Name_Len + Nam'Length) := Nam;
1822 ------------------------------
1823 -- Read_Default_Search_Dirs --
1824 ------------------------------
1826 function Read_Default_Search_Dirs
1827 (Search_Dir_Prefix : String_Access;
1828 Search_File : String_Access;
1829 Search_Dir_Default_Name : String_Access) return String_Access
1831 Prefix_Len : constant Integer := Search_Dir_Prefix.all'Length;
1832 Buffer : String (1 .. Prefix_Len + Search_File.all'Length + 1);
1833 File_FD : File_Descriptor;
1834 S, S1 : String_Access;
1837 Actual_Len : Integer;
1840 Prev_Was_Separator : Boolean;
1841 Nb_Relative_Dir : Integer;
1843 function Is_Relative (S : String; K : Positive) return Boolean;
1844 pragma Inline (Is_Relative);
1845 -- Returns True if a relative directory specification is found
1846 -- in S at position K, False otherwise.
1852 function Is_Relative (S : String; K : Positive) return Boolean is
1854 return not Is_Absolute_Path (S (K .. S'Last));
1857 -- Start of processing for Read_Default_Search_Dirs
1860 -- Construct a C compatible character string buffer
1862 Buffer (1 .. Search_Dir_Prefix.all'Length)
1863 := Search_Dir_Prefix.all;
1864 Buffer (Search_Dir_Prefix.all'Length + 1 .. Buffer'Last - 1)
1866 Buffer (Buffer'Last) := ASCII.NUL;
1868 File_FD := Open_Read (Buffer'Address, Binary);
1869 if File_FD = Invalid_FD then
1870 return Search_Dir_Default_Name;
1873 Len := Integer (File_Length (File_FD));
1875 -- An extra character for a trailing Path_Separator is allocated
1877 S := new String (1 .. Len + 1);
1878 S (Len + 1) := Path_Separator;
1880 -- Read the file. Note that the loop is not necessary since the
1881 -- whole file is read at once except on VMS.
1885 while Actual_Len /= 0 loop
1886 Actual_Len := Read (File_FD, S (Curr)'Address, Len);
1887 Curr := Curr + Actual_Len;
1890 -- Process the file, translating line and file ending
1891 -- control characters to a path separator character.
1893 Prev_Was_Separator := True;
1894 Nb_Relative_Dir := 0;
1895 for J in 1 .. Len loop
1896 if S (J) in ASCII.NUL .. ASCII.US
1899 S (J) := Path_Separator;
1902 if S (J) = Path_Separator then
1903 Prev_Was_Separator := True;
1905 if Prev_Was_Separator and then Is_Relative (S.all, J) then
1906 Nb_Relative_Dir := Nb_Relative_Dir + 1;
1909 Prev_Was_Separator := False;
1913 if Nb_Relative_Dir = 0 then
1917 -- Add the Search_Dir_Prefix to all relative paths
1919 S1 := new String (1 .. S'Length + Nb_Relative_Dir * Prefix_Len);
1921 Prev_Was_Separator := True;
1922 for J in 1 .. Len + 1 loop
1923 if S (J) = Path_Separator then
1924 Prev_Was_Separator := True;
1927 if Prev_Was_Separator and then Is_Relative (S.all, J) then
1928 S1 (J1 .. J1 + Prefix_Len - 1) := Search_Dir_Prefix.all;
1929 J1 := J1 + Prefix_Len;
1932 Prev_Was_Separator := False;
1940 end Read_Default_Search_Dirs;
1942 -----------------------
1943 -- Read_Library_Info --
1944 -----------------------
1946 function Read_Library_Info
1947 (Lib_File : File_Name_Type;
1948 Fatal_Err : Boolean := False) return Text_Buffer_Ptr
1950 Lib_FD : File_Descriptor;
1951 -- The file descriptor for the current library file. A negative value
1952 -- indicates failure to open the specified source file.
1954 Text : Text_Buffer_Ptr;
1955 -- Allocated text buffer
1958 -- For the calls to Close
1961 Current_Full_Lib_Name := Find_File (Lib_File, Library);
1962 Current_Full_Obj_Name := Object_File_Name (Current_Full_Lib_Name);
1964 if Current_Full_Lib_Name = No_File then
1966 Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
1968 Current_Full_Obj_Stamp := Empty_Time_Stamp;
1973 Get_Name_String (Current_Full_Lib_Name);
1974 Name_Buffer (Name_Len + 1) := ASCII.NUL;
1976 -- Open the library FD, note that we open in binary mode, because as
1977 -- documented in the spec, the caller is expected to handle either
1978 -- DOS or Unix mode files, and there is no point in wasting time on
1979 -- text translation when it is not required.
1981 Lib_FD := Open_Read (Name_Buffer'Address, Binary);
1983 if Lib_FD = Invalid_FD then
1985 Fail ("Cannot open: ", Name_Buffer (1 .. Name_Len));
1987 Current_Full_Obj_Stamp := Empty_Time_Stamp;
1992 -- Check for object file consistency if requested
1994 if Opt.Check_Object_Consistency then
1995 Current_Full_Lib_Stamp := File_Stamp (Current_Full_Lib_Name);
1996 Current_Full_Obj_Stamp := File_Stamp (Current_Full_Obj_Name);
1998 if Current_Full_Obj_Stamp (1) = ' ' then
2000 -- When the library is readonly, always assume that
2001 -- the object is consistent.
2003 if Is_Readonly_Library (Current_Full_Lib_Name) then
2004 Current_Full_Obj_Stamp := Current_Full_Lib_Stamp;
2006 elsif Fatal_Err then
2007 Get_Name_String (Current_Full_Obj_Name);
2008 Close (Lib_FD, Status);
2009 -- No need to check the status, we fail anyway
2011 Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
2014 Current_Full_Obj_Stamp := Empty_Time_Stamp;
2015 Close (Lib_FD, Status);
2017 -- No need to check the status, we return null anyway
2024 -- Read data from the file
2027 Len : constant Integer := Integer (File_Length (Lib_FD));
2028 -- Length of source file text. If it doesn't fit in an integer
2029 -- we're probably stuck anyway (>2 gigs of source seems a lot!)
2031 Actual_Len : Integer := 0;
2033 Lo : constant Text_Ptr := 0;
2034 -- Low bound for allocated text buffer
2036 Hi : Text_Ptr := Text_Ptr (Len);
2037 -- High bound for allocated text buffer. Note length is Len + 1
2038 -- which allows for extra EOF character at the end of the buffer.
2041 -- Allocate text buffer. Note extra character at end for EOF
2043 Text := new Text_Buffer (Lo .. Hi);
2045 -- Some systems (e.g. VMS) have file types that require one
2046 -- read per line, so read until we get the Len bytes or until
2047 -- there are no more characters.
2051 Actual_Len := Read (Lib_FD, Text (Hi)'Address, Len);
2052 Hi := Hi + Text_Ptr (Actual_Len);
2053 exit when Actual_Len = Len or Actual_Len <= 0;
2059 -- Read is complete, close file and we are done
2061 Close (Lib_FD, Status);
2062 -- The status should never be False. But, if it is, what can we do?
2063 -- So, we don't test it.
2067 end Read_Library_Info;
2069 ----------------------
2070 -- Read_Source_File --
2071 ----------------------
2073 procedure Read_Source_File
2074 (N : File_Name_Type;
2076 Hi : out Source_Ptr;
2077 Src : out Source_Buffer_Ptr;
2078 T : File_Type := Source)
2080 Source_File_FD : File_Descriptor;
2081 -- The file descriptor for the current source file. A negative value
2082 -- indicates failure to open the specified source file.
2085 -- Length of file. Assume no more than 2 gigabytes of source!
2087 Actual_Len : Integer;
2090 -- For the call to Close
2093 Current_Full_Source_Name := Find_File (N, T);
2094 Current_Full_Source_Stamp := File_Stamp (Current_Full_Source_Name);
2096 if Current_Full_Source_Name = No_File then
2098 -- If we were trying to access the main file and we could not
2099 -- find it we have an error.
2101 if N = Current_Main then
2102 Get_Name_String (N);
2103 Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
2111 Get_Name_String (Current_Full_Source_Name);
2112 Name_Buffer (Name_Len + 1) := ASCII.NUL;
2114 -- Open the source FD, note that we open in binary mode, because as
2115 -- documented in the spec, the caller is expected to handle either
2116 -- DOS or Unix mode files, and there is no point in wasting time on
2117 -- text translation when it is not required.
2119 Source_File_FD := Open_Read (Name_Buffer'Address, Binary);
2121 if Source_File_FD = Invalid_FD then
2127 -- Prepare to read data from the file
2129 Len := Integer (File_Length (Source_File_FD));
2131 -- Set Hi so that length is one more than the physical length,
2132 -- allowing for the extra EOF character at the end of the buffer
2134 Hi := Lo + Source_Ptr (Len);
2136 -- Do the actual read operation
2139 subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
2140 -- Physical buffer allocated
2142 type Actual_Source_Ptr is access Actual_Source_Buffer;
2143 -- This is the pointer type for the physical buffer allocated
2145 Actual_Ptr : constant Actual_Source_Ptr := new Actual_Source_Buffer;
2146 -- And this is the actual physical buffer
2149 -- Allocate source buffer, allowing extra character at end for EOF
2151 -- Some systems (e.g. VMS) have file types that require one
2152 -- read per line, so read until we get the Len bytes or until
2153 -- there are no more characters.
2157 Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len);
2158 Hi := Hi + Source_Ptr (Actual_Len);
2159 exit when Actual_Len = Len or Actual_Len <= 0;
2162 Actual_Ptr (Hi) := EOF;
2164 -- Now we need to work out the proper virtual origin pointer to
2165 -- return. This is exactly Actual_Ptr (0)'Address, but we have
2166 -- to be careful to suppress checks to compute this address.
2169 pragma Suppress (All_Checks);
2171 pragma Warnings (Off);
2172 -- This use of unchecked conversion is aliasing safe
2174 function To_Source_Buffer_Ptr is new
2175 Unchecked_Conversion (Address, Source_Buffer_Ptr);
2177 pragma Warnings (On);
2180 Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
2184 -- Read is complete, get time stamp and close file and we are done
2186 Close (Source_File_FD, Status);
2188 -- The status should never be False. But, if it is, what can we do?
2189 -- So, we don't test it.
2191 end Read_Source_File;
2197 function Relocate_Path
2199 Path : String) return String_Ptr
2203 procedure set_std_prefix (S : String; Len : Integer);
2204 pragma Import (C, set_std_prefix);
2207 if Std_Prefix = null then
2208 Std_Prefix := Executable_Prefix;
2210 if Std_Prefix.all /= "" then
2212 -- Remove trailing directory separator when calling set_std_prefix
2214 set_std_prefix (Std_Prefix.all, Std_Prefix'Length - 1);
2218 if Path (Prefix'Range) = Prefix then
2219 if Std_Prefix.all /= "" then
2221 (1 .. Std_Prefix'Length + Path'Last - Prefix'Last);
2222 S (1 .. Std_Prefix'Length) := Std_Prefix.all;
2223 S (Std_Prefix'Length + 1 .. S'Last) :=
2224 Path (Prefix'Last + 1 .. Path'Last);
2229 return new String'(Path);
2236 procedure Set_Program (P : Program_Type) is
2239 Fail ("Set_Program called twice");
2242 Program_Set := True;
2243 Running_Program := P;
2250 function Shared_Lib (Name : String) return String is
2251 Library : String (1 .. Name'Length + Library_Version'Length + 3);
2252 -- 3 = 2 for "-l" + 1 for "-" before lib version
2255 Library (1 .. 2) := "-l";
2256 Library (3 .. 2 + Name'Length) := Name;
2257 Library (3 + Name'Length) := '-';
2258 Library (4 + Name'Length .. Library'Last) := Library_Version;
2260 if Hostparm.OpenVMS then
2261 for K in Library'First + 2 .. Library'Last loop
2262 if Library (K) = '.' or else Library (K) = '-' then
2271 ----------------------
2272 -- Smart_File_Stamp --
2273 ----------------------
2275 function Smart_File_Stamp
2276 (N : File_Name_Type;
2277 T : File_Type) return Time_Stamp_Type
2279 Time_Stamp : Time_Stamp_Type;
2282 if not File_Cache_Enabled then
2283 return File_Stamp (Find_File (N, T));
2286 Time_Stamp := File_Stamp_Hash_Table.Get (N);
2288 if Time_Stamp (1) = ' ' then
2289 Time_Stamp := File_Stamp (Smart_Find_File (N, T));
2290 File_Stamp_Hash_Table.Set (N, Time_Stamp);
2294 end Smart_File_Stamp;
2296 ---------------------
2297 -- Smart_Find_File --
2298 ---------------------
2300 function Smart_Find_File
2301 (N : File_Name_Type;
2302 T : File_Type) return File_Name_Type
2304 Full_File_Name : File_Name_Type;
2307 if not File_Cache_Enabled then
2308 return Find_File (N, T);
2311 Full_File_Name := File_Name_Hash_Table.Get (N);
2313 if Full_File_Name = No_File then
2314 Full_File_Name := Find_File (N, T);
2315 File_Name_Hash_Table.Set (N, Full_File_Name);
2318 return Full_File_Name;
2319 end Smart_Find_File;
2321 ----------------------
2322 -- Source_File_Data --
2323 ----------------------
2325 procedure Source_File_Data (Cache : Boolean) is
2327 File_Cache_Enabled := Cache;
2328 end Source_File_Data;
2330 -----------------------
2331 -- Source_File_Stamp --
2332 -----------------------
2334 function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is
2336 return Smart_File_Stamp (N, Source);
2337 end Source_File_Stamp;
2339 ---------------------
2340 -- Strip_Directory --
2341 ---------------------
2343 function Strip_Directory (Name : File_Name_Type) return File_Name_Type is
2345 Get_Name_String (Name);
2347 for J in reverse 1 .. Name_Len - 1 loop
2349 -- If we find the last directory separator
2351 if Is_Directory_Separator (Name_Buffer (J)) then
2353 -- Return the part of Name that follows this last directory
2356 Name_Buffer (1 .. Name_Len - J) := Name_Buffer (J + 1 .. Name_Len);
2357 Name_Len := Name_Len - J;
2362 -- There were no directory separator, just return Name
2365 end Strip_Directory;
2371 function Strip_Suffix (Name : File_Name_Type) return File_Name_Type is
2373 Get_Name_String (Name);
2375 for J in reverse 2 .. Name_Len loop
2377 -- If we found the last '.', return part of Name that precedes it
2379 if Name_Buffer (J) = '.' then
2388 ---------------------------
2389 -- To_Canonical_Dir_Spec --
2390 ---------------------------
2392 function To_Canonical_Dir_Spec
2394 Prefix_Style : Boolean) return String_Access
2396 function To_Canonical_Dir_Spec
2397 (Host_Dir : Address;
2398 Prefix_Flag : Integer) return Address;
2399 pragma Import (C, To_Canonical_Dir_Spec, "__gnat_to_canonical_dir_spec");
2401 C_Host_Dir : String (1 .. Host_Dir'Length + 1);
2402 Canonical_Dir_Addr : Address;
2403 Canonical_Dir_Len : Integer;
2406 C_Host_Dir (1 .. Host_Dir'Length) := Host_Dir;
2407 C_Host_Dir (C_Host_Dir'Last) := ASCII.NUL;
2409 if Prefix_Style then
2410 Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 1);
2412 Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 0);
2414 Canonical_Dir_Len := C_String_Length (Canonical_Dir_Addr);
2416 if Canonical_Dir_Len = 0 then
2419 return To_Path_String_Access (Canonical_Dir_Addr, Canonical_Dir_Len);
2424 Fail ("erroneous directory spec: ", Host_Dir);
2426 end To_Canonical_Dir_Spec;
2428 ---------------------------
2429 -- To_Canonical_File_List --
2430 ---------------------------
2432 function To_Canonical_File_List
2433 (Wildcard_Host_File : String;
2434 Only_Dirs : Boolean) return String_Access_List_Access
2436 function To_Canonical_File_List_Init
2437 (Host_File : Address;
2438 Only_Dirs : Integer) return Integer;
2439 pragma Import (C, To_Canonical_File_List_Init,
2440 "__gnat_to_canonical_file_list_init");
2442 function To_Canonical_File_List_Next return Address;
2443 pragma Import (C, To_Canonical_File_List_Next,
2444 "__gnat_to_canonical_file_list_next");
2446 procedure To_Canonical_File_List_Free;
2447 pragma Import (C, To_Canonical_File_List_Free,
2448 "__gnat_to_canonical_file_list_free");
2450 Num_Files : Integer;
2451 C_Wildcard_Host_File : String (1 .. Wildcard_Host_File'Length + 1);
2454 C_Wildcard_Host_File (1 .. Wildcard_Host_File'Length) :=
2456 C_Wildcard_Host_File (C_Wildcard_Host_File'Last) := ASCII.NUL;
2458 -- Do the expansion and say how many there are
2460 Num_Files := To_Canonical_File_List_Init
2461 (C_Wildcard_Host_File'Address, Boolean'Pos (Only_Dirs));
2464 Canonical_File_List : String_Access_List (1 .. Num_Files);
2465 Canonical_File_Addr : Address;
2466 Canonical_File_Len : Integer;
2469 -- Retrieve the expanded directoy names and build the list
2471 for J in 1 .. Num_Files loop
2472 Canonical_File_Addr := To_Canonical_File_List_Next;
2473 Canonical_File_Len := C_String_Length (Canonical_File_Addr);
2474 Canonical_File_List (J) := To_Path_String_Access
2475 (Canonical_File_Addr, Canonical_File_Len);
2478 -- Free up the storage
2480 To_Canonical_File_List_Free;
2482 return new String_Access_List'(Canonical_File_List);
2484 end To_Canonical_File_List;
2486 ----------------------------
2487 -- To_Canonical_File_Spec --
2488 ----------------------------
2490 function To_Canonical_File_Spec
2491 (Host_File : String) return String_Access
2493 function To_Canonical_File_Spec (Host_File : Address) return Address;
2495 (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
2497 C_Host_File : String (1 .. Host_File'Length + 1);
2498 Canonical_File_Addr : Address;
2499 Canonical_File_Len : Integer;
2502 C_Host_File (1 .. Host_File'Length) := Host_File;
2503 C_Host_File (C_Host_File'Last) := ASCII.NUL;
2505 Canonical_File_Addr := To_Canonical_File_Spec (C_Host_File'Address);
2506 Canonical_File_Len := C_String_Length (Canonical_File_Addr);
2508 if Canonical_File_Len = 0 then
2511 return To_Path_String_Access
2512 (Canonical_File_Addr, Canonical_File_Len);
2517 Fail ("erroneous file spec: ", Host_File);
2519 end To_Canonical_File_Spec;
2521 ----------------------------
2522 -- To_Canonical_Path_Spec --
2523 ----------------------------
2525 function To_Canonical_Path_Spec
2526 (Host_Path : String) return String_Access
2528 function To_Canonical_Path_Spec (Host_Path : Address) return Address;
2530 (C, To_Canonical_Path_Spec, "__gnat_to_canonical_path_spec");
2532 C_Host_Path : String (1 .. Host_Path'Length + 1);
2533 Canonical_Path_Addr : Address;
2534 Canonical_Path_Len : Integer;
2537 C_Host_Path (1 .. Host_Path'Length) := Host_Path;
2538 C_Host_Path (C_Host_Path'Last) := ASCII.NUL;
2540 Canonical_Path_Addr := To_Canonical_Path_Spec (C_Host_Path'Address);
2541 Canonical_Path_Len := C_String_Length (Canonical_Path_Addr);
2543 -- Return a null string (vice a null) for zero length paths, for
2544 -- compatibility with getenv().
2546 return To_Path_String_Access (Canonical_Path_Addr, Canonical_Path_Len);
2550 Fail ("erroneous path spec: ", Host_Path);
2552 end To_Canonical_Path_Spec;
2554 ---------------------------
2555 -- To_Host_Dir_Spec --
2556 ---------------------------
2558 function To_Host_Dir_Spec
2559 (Canonical_Dir : String;
2560 Prefix_Style : Boolean) return String_Access
2562 function To_Host_Dir_Spec
2563 (Canonical_Dir : Address;
2564 Prefix_Flag : Integer) return Address;
2565 pragma Import (C, To_Host_Dir_Spec, "__gnat_to_host_dir_spec");
2567 C_Canonical_Dir : String (1 .. Canonical_Dir'Length + 1);
2568 Host_Dir_Addr : Address;
2569 Host_Dir_Len : Integer;
2572 C_Canonical_Dir (1 .. Canonical_Dir'Length) := Canonical_Dir;
2573 C_Canonical_Dir (C_Canonical_Dir'Last) := ASCII.NUL;
2575 if Prefix_Style then
2576 Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 1);
2578 Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 0);
2580 Host_Dir_Len := C_String_Length (Host_Dir_Addr);
2582 if Host_Dir_Len = 0 then
2585 return To_Path_String_Access (Host_Dir_Addr, Host_Dir_Len);
2587 end To_Host_Dir_Spec;
2589 ----------------------------
2590 -- To_Host_File_Spec --
2591 ----------------------------
2593 function To_Host_File_Spec
2594 (Canonical_File : String) return String_Access
2596 function To_Host_File_Spec (Canonical_File : Address) return Address;
2597 pragma Import (C, To_Host_File_Spec, "__gnat_to_host_file_spec");
2599 C_Canonical_File : String (1 .. Canonical_File'Length + 1);
2600 Host_File_Addr : Address;
2601 Host_File_Len : Integer;
2604 C_Canonical_File (1 .. Canonical_File'Length) := Canonical_File;
2605 C_Canonical_File (C_Canonical_File'Last) := ASCII.NUL;
2607 Host_File_Addr := To_Host_File_Spec (C_Canonical_File'Address);
2608 Host_File_Len := C_String_Length (Host_File_Addr);
2610 if Host_File_Len = 0 then
2613 return To_Path_String_Access
2614 (Host_File_Addr, Host_File_Len);
2616 end To_Host_File_Spec;
2618 ---------------------------
2619 -- To_Path_String_Access --
2620 ---------------------------
2622 function To_Path_String_Access
2623 (Path_Addr : Address;
2624 Path_Len : Integer) return String_Access
2626 subtype Path_String is String (1 .. Path_Len);
2627 type Path_String_Access is access Path_String;
2629 function Address_To_Access is new
2630 Unchecked_Conversion (Source => Address,
2631 Target => Path_String_Access);
2633 Path_Access : constant Path_String_Access :=
2634 Address_To_Access (Path_Addr);
2636 Return_Val : String_Access;
2639 Return_Val := new String (1 .. Path_Len);
2641 for J in 1 .. Path_Len loop
2642 Return_Val (J) := Path_Access (J);
2646 end To_Path_String_Access;
2652 function Update_Path (Path : String_Ptr) return String_Ptr is
2654 function C_Update_Path (Path, Component : Address) return Address;
2655 pragma Import (C, C_Update_Path, "update_path");
2657 function Strlen (Str : Address) return Integer;
2658 pragma Import (C, Strlen, "strlen");
2660 procedure Strncpy (X : Address; Y : Address; Length : Integer);
2661 pragma Import (C, Strncpy, "strncpy");
2663 In_Length : constant Integer := Path'Length;
2664 In_String : String (1 .. In_Length + 1);
2665 Component_Name : aliased String := "GCC" & ASCII.NUL;
2666 Result_Ptr : Address;
2667 Result_Length : Integer;
2668 Out_String : String_Ptr;
2671 In_String (1 .. In_Length) := Path.all;
2672 In_String (In_Length + 1) := ASCII.NUL;
2673 Result_Ptr := C_Update_Path (In_String'Address,
2674 Component_Name'Address);
2675 Result_Length := Strlen (Result_Ptr);
2677 Out_String := new String (1 .. Result_Length);
2678 Strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
2686 procedure Write_Info (Info : String) is
2688 Write_With_Check (Info'Address, Info'Length);
2689 Write_With_Check (EOL'Address, 1);
2692 ------------------------
2693 -- Write_Program_Name --
2694 ------------------------
2696 procedure Write_Program_Name is
2697 Save_Buffer : constant String (1 .. Name_Len) :=
2698 Name_Buffer (1 .. Name_Len);
2703 -- Convert the name to lower case so error messages are the same on
2706 for J in 1 .. Name_Len loop
2707 if Name_Buffer (J) in 'A' .. 'Z' then
2709 Character'Val (Character'Pos (Name_Buffer (J)) + 32);
2713 Write_Str (Name_Buffer (1 .. Name_Len));
2715 -- Restore Name_Buffer which was clobbered by the call to
2716 -- Find_Program_Name
2718 Name_Len := Save_Buffer'Last;
2719 Name_Buffer (1 .. Name_Len) := Save_Buffer;
2720 end Write_Program_Name;
2722 ----------------------
2723 -- Write_With_Check --
2724 ----------------------
2726 procedure Write_With_Check (A : Address; N : Integer) is
2730 if N = Write (Output_FD, A, N) then
2734 Write_Str ("error: disk full writing ");
2735 Write_Name_Decoded (Output_File_Name);
2737 Name_Len := Name_Len + 1;
2738 Name_Buffer (Name_Len) := ASCII.NUL;
2739 Delete_File (Name_Buffer'Address, Ignore);
2740 Exit_Program (E_Fatal);
2742 end Write_With_Check;
2744 ----------------------------
2745 -- Package Initialization --
2746 ----------------------------
2749 Initialization : declare
2751 function Get_Default_Identifier_Character_Set return Character;
2752 pragma Import (C, Get_Default_Identifier_Character_Set,
2753 "__gnat_get_default_identifier_character_set");
2754 -- Function to determine the default identifier character set,
2755 -- which is system dependent. See Opt package spec for a list of
2756 -- the possible character codes and their interpretations.
2758 function Get_Maximum_File_Name_Length return Int;
2759 pragma Import (C, Get_Maximum_File_Name_Length,
2760 "__gnat_get_maximum_file_name_length");
2761 -- Function to get maximum file name length for system
2764 Identifier_Character_Set := Get_Default_Identifier_Character_Set;
2765 Maximum_File_Name_Length := Get_Maximum_File_Name_Length;
2767 -- On VMS, '~' is not allowed in file names. Change the multi unit
2768 -- index character to '$'.
2770 if Hostparm.OpenVMS then
2771 Multi_Unit_Index_Character := '$';
2774 -- Following should be removed by having above function return
2775 -- Integer'Last as indication of no maximum instead of -1 ???
2777 if Maximum_File_Name_Length = -1 then
2778 Maximum_File_Name_Length := Int'Last;
2781 Src_Search_Directories.Set_Last (Primary_Directory);
2782 Src_Search_Directories.Table (Primary_Directory) := new String'("");
2784 Lib_Search_Directories.Set_Last (Primary_Directory);
2785 Lib_Search_Directories.Table (Primary_Directory) := new String'("");