1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005 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 ------------------------------------------------------------------------------
28 with Gnatvsn
; use Gnatvsn
;
30 with Namet
; use Namet
;
32 with Output
; use Output
;
33 with Sdefault
; use Sdefault
;
35 with Targparm
; use Targparm
;
37 with System
.Case_Util
; use System
.Case_Util
;
39 with Unchecked_Conversion
;
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 -- Check for eventual project path file env vars
414 Path_File_Name
:= Getenv
(Project_Include_Path_File
);
416 if Path_File_Name
'Length > 0 then
417 Get_Dirs_From_File
(Additional_Source_Dir
=> True);
420 Path_File_Name
:= Getenv
(Project_Objects_Path_File
);
422 if Path_File_Name
'Length > 0 then
423 Get_Dirs_From_File
(Additional_Source_Dir
=> False);
426 -- On VMS, don't expand the logical name (e.g. environment variable),
427 -- just put it into Unix (e.g. canonical) format. System services
428 -- will handle the expansion as part of the file processing.
430 for Additional_Source_Dir
in False .. True loop
432 if Additional_Source_Dir
then
433 Search_Path
:= Getenv
(Ada_Include_Path
);
434 if Search_Path
'Length > 0 then
435 if Hostparm
.OpenVMS
then
436 Search_Path
:= To_Canonical_Path_Spec
("ADA_INCLUDE_PATH:");
438 Search_Path
:= To_Canonical_Path_Spec
(Search_Path
.all);
442 Search_Path
:= Getenv
(Ada_Objects_Path
);
443 if Search_Path
'Length > 0 then
444 if Hostparm
.OpenVMS
then
445 Search_Path
:= To_Canonical_Path_Spec
("ADA_OBJECTS_PATH:");
447 Search_Path
:= To_Canonical_Path_Spec
(Search_Path
.all);
452 Get_Next_Dir_In_Path_Init
(Search_Path
);
454 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
455 exit when Search_Dir
= null;
456 Add_Search_Dir
(Search_Dir
, Additional_Source_Dir
);
460 -- For the compiler, if --RTS= was specified, 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; Index
: Int
:= No_Index
) 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);
534 new File_Index_Array'(File_Indexes
.all & File_Indexes
.all);
537 File_Names
(Number_File_Names
) := new String'(File_Name);
538 File_Indexes (Number_File_Names) := Index;
541 ------------------------
542 -- Add_Lib_Search_Dir --
543 ------------------------
545 procedure Add_Lib_Search_Dir (Dir : String) is
547 if Dir'Length = 0 then
548 Fail ("missing library directory name");
551 Lib_Search_Directories.Increment_Last;
552 Lib_Search_Directories.Table (Lib_Search_Directories.Last) :=
553 Normalize_Directory_Name (Dir);
554 end Add_Lib_Search_Dir;
556 ---------------------
557 -- Add_Search_Dirs --
558 ---------------------
560 procedure Add_Search_Dirs
561 (Search_Path : String_Ptr;
562 Path_Type : Search_File_Type)
564 Current_Search_Path : String_Access;
567 Get_Next_Dir_In_Path_Init (String_Access (Search_Path));
569 Current_Search_Path :=
570 Get_Next_Dir_In_Path (String_Access (Search_Path));
571 exit when Current_Search_Path = null;
573 if Path_Type = Include then
574 Add_Src_Search_Dir (Current_Search_Path.all);
576 Add_Lib_Search_Dir (Current_Search_Path.all);
581 ------------------------
582 -- Add_Src_Search_Dir --
583 ------------------------
585 procedure Add_Src_Search_Dir (Dir : String) is
587 if Dir'Length = 0 then
588 Fail ("missing source directory name");
591 Src_Search_Directories.Increment_Last;
592 Src_Search_Directories.Table (Src_Search_Directories.Last) :=
593 Normalize_Directory_Name (Dir);
594 end Add_Src_Search_Dir;
596 --------------------------------
597 -- Append_Suffix_To_File_Name --
598 --------------------------------
600 function Append_Suffix_To_File_Name
602 Suffix : String) return Name_Id
605 Get_Name_String (Name);
606 Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
607 Name_Len := Name_Len + Suffix'Length;
609 end Append_Suffix_To_File_Name;
611 ---------------------
612 -- C_String_Length --
613 ---------------------
615 function C_String_Length (S : Address) return Integer is
616 function Strlen (S : Address) return Integer;
617 pragma Import (C, Strlen, "strlen");
619 if S = Null_Address then
626 ------------------------------
627 -- Canonical_Case_File_Name --
628 ------------------------------
630 -- For now, we only deal with the case of a-z. Eventually we should
631 -- worry about other Latin-1 letters on systems that support this ???
633 procedure Canonical_Case_File_Name (S : in out String) is
635 if not File_Names_Case_Sensitive then
636 for J in S'Range loop
637 if S (J) in 'A
' .. 'Z
' then
638 S (J) := Character'Val (
639 Character'Pos (S (J)) +
640 Character'Pos ('a
') -
641 Character'Pos ('A
'));
645 end Canonical_Case_File_Name;
651 function Concat (String_One : String; String_Two : String) return String is
652 Buffer : String (1 .. String_One'Length + String_Two'Length);
654 Buffer (1 .. String_One'Length) := String_One;
655 Buffer (String_One'Length + 1 .. Buffer'Last) := String_Two;
659 ---------------------------
660 -- Create_File_And_Check --
661 ---------------------------
663 procedure Create_File_And_Check
664 (Fdesc : out File_Descriptor;
668 Output_File_Name := Name_Enter;
669 Fdesc := Create_File (Name_Buffer'Address, Fmode);
671 if Fdesc = Invalid_FD then
672 Fail ("Cannot create: ", Name_Buffer (1 .. Name_Len));
674 end Create_File_And_Check;
676 ------------------------
677 -- Current_File_Index --
678 ------------------------
680 function Current_File_Index return Int is
682 return File_Indexes (Current_File_Name_Index);
683 end Current_File_Index;
685 --------------------------------
686 -- Current_Library_File_Stamp --
687 --------------------------------
689 function Current_Library_File_Stamp return Time_Stamp_Type is
691 return Current_Full_Lib_Stamp;
692 end Current_Library_File_Stamp;
694 -------------------------------
695 -- Current_Object_File_Stamp --
696 -------------------------------
698 function Current_Object_File_Stamp return Time_Stamp_Type is
700 return Current_Full_Obj_Stamp;
701 end Current_Object_File_Stamp;
703 -------------------------------
704 -- Current_Source_File_Stamp --
705 -------------------------------
707 function Current_Source_File_Stamp return Time_Stamp_Type is
709 return Current_Full_Source_Stamp;
710 end Current_Source_File_Stamp;
712 ----------------------------
713 -- Dir_In_Obj_Search_Path --
714 ----------------------------
716 function Dir_In_Obj_Search_Path (Position : Natural) return String_Ptr is
718 if Opt.Look_In_Primary_Dir then
720 Lib_Search_Directories.Table (Primary_Directory + Position - 1);
722 return Lib_Search_Directories.Table (Primary_Directory + Position);
724 end Dir_In_Obj_Search_Path;
726 ----------------------------
727 -- Dir_In_Src_Search_Path --
728 ----------------------------
730 function Dir_In_Src_Search_Path (Position : Natural) return String_Ptr is
732 if Opt.Look_In_Primary_Dir then
734 Src_Search_Directories.Table (Primary_Directory + Position - 1);
736 return Src_Search_Directories.Table (Primary_Directory + Position);
738 end Dir_In_Src_Search_Path;
740 ---------------------
741 -- Executable_Name --
742 ---------------------
744 function Executable_Name (Name : File_Name_Type) return File_Name_Type is
745 Exec_Suffix : String_Access;
748 if Name = No_File then
752 Get_Name_String (Name);
753 Exec_Suffix := Get_Executable_Suffix;
755 for J in Exec_Suffix'Range loop
756 Name_Len := Name_Len + 1;
757 Name_Buffer (Name_Len) := Exec_Suffix (J);
765 -----------------------
766 -- Executable_Prefix --
767 -----------------------
769 function Executable_Prefix return String_Ptr is
770 function Get_Install_Dir (Exec : String) return String_Ptr;
771 -- S is the executable name preceeded by the absolute or relative
772 -- path, e.g. "c:\usr\bin\gcc.exe" or "..\bin\gcc".
774 ---------------------
775 -- Get_Install_Dir --
776 ---------------------
778 function Get_Install_Dir (Exec : String) return String_Ptr is
780 for J in reverse Exec'Range loop
781 if Is_Directory_Separator (Exec (J)) then
782 if J < Exec'Last - 5 then
783 if (To_Lower (Exec (J + 1)) = 'l
'
784 and then To_Lower (Exec (J + 2)) = 'i
'
785 and then To_Lower (Exec (J + 3)) = 'b
')
787 (To_Lower (Exec (J + 1)) = 'b
'
788 and then To_Lower (Exec (J + 2)) = 'i
'
789 and then To_Lower (Exec (J + 3)) = 'n
')
791 return new String'(Exec
(Exec
'First .. J
));
797 return new String'("");
800 -- Start of processing for Executable_Prefix
803 if Exec_Name = null then
804 Exec_Name := new String (1 .. Len_Arg (0));
805 Osint.Fill_Arg (Exec_Name (1)'Address, 0);
808 -- First determine if a path prefix was placed in front of the
811 for J in reverse Exec_Name'Range loop
812 if Is_Directory_Separator (Exec_Name (J)) then
813 return Get_Install_Dir (Exec_Name.all);
817 -- If we come here, the user has typed the executable name with no
820 return Get_Install_Dir
821 (GNAT.OS_Lib.Locate_Exec_On_Path (Exec_Name.all).all);
822 end Executable_Prefix;
828 procedure Exit_Program (Exit_Code : Exit_Code_Type) is
830 -- The program will exit with the following status:
832 -- 0 if the object file has been generated (with or without warnings)
833 -- 1 if recompilation was not needed (smart recompilation)
834 -- 2 if gnat1 has been killed by a signal (detected by GCC)
835 -- 4 for a fatal error
836 -- 5 if there were errors
837 -- 6 if no code has been generated (spec)
839 -- Note that exit code 3 is not used and must not be used as this is
840 -- the code returned by a program aborted via C abort() routine on
841 -- Windows. GCC checks for that case and thinks that the child process
842 -- has been aborted. This code (exit code 3) used to be the code used
843 -- for E_No_Code, but E_No_Code was changed to 6 for this reason.
846 when E_Success => OS_Exit (0);
847 when E_Warnings => OS_Exit (0);
848 when E_No_Compile => OS_Exit (1);
849 when E_Fatal => OS_Exit (4);
850 when E_Errors => OS_Exit (5);
851 when E_No_Code => OS_Exit (6);
852 when E_Abort => OS_Abort;
860 procedure Fail (S1 : String; S2 : String := ""; S3 : String := "") is
862 -- We use Output in case there is a special output set up.
863 -- In this case Set_Standard_Error will have no immediate effect.
866 Osint.Write_Program_Name;
873 Exit_Program (E_Fatal);
880 function File_Hash (F : File_Name_Type) return File_Hash_Num is
882 return File_Hash_Num (Int (F) rem File_Hash_Num'Range_Length);
889 function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type is
891 if Name = No_File then
892 return Empty_Time_Stamp;
895 Get_Name_String (Name);
897 if not Is_Regular_File (Name_Buffer (1 .. Name_Len)) then
898 return Empty_Time_Stamp;
900 Name_Buffer (Name_Len + 1) := ASCII.NUL;
901 return OS_Time_To_GNAT_Time (File_Time_Stamp (Name_Buffer));
911 T : File_Type) return File_Name_Type
917 File_Name : String renames Name_Buffer (1 .. Name_Len);
918 File : File_Name_Type := No_File;
922 -- If we are looking for a config file, look only in the current
923 -- directory, i.e. return input argument unchanged. Also look
924 -- only in the current directory if we are looking for a .dg
925 -- file (happens in -gnatD mode)
928 or else (Debug_Generated_Code
929 and then Name_Len > 3
931 (Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg"
933 (Hostparm.OpenVMS and then
934 Name_Buffer (Name_Len - 2 .. Name_Len) = "_dg")))
938 -- If we are trying to find the current main file just look in the
939 -- directory where the user said it was.
941 elsif Look_In_Primary_Directory_For_Current_Main
942 and then Current_Main = N
944 return Locate_File (N, T, Primary_Directory, File_Name);
946 -- Otherwise do standard search for source file
949 -- Check the mapping of this file name
951 File := Mapped_Path_Name (N);
953 -- If the file name is mapped to a path name, return the
954 -- corresponding path name
956 if File /= No_File then
957 -- For locally removed file, Error_Name is returned; then
958 -- return No_File, indicating the file is not a source.
960 if File = Error_Name then
968 -- First place to look is in the primary directory (i.e. the same
969 -- directory as the source) unless this has been disabled with -I-
971 if Opt.Look_In_Primary_Dir then
972 File := Locate_File (N, T, Primary_Directory, File_Name);
974 if File /= No_File then
979 -- Finally look in directories specified with switches -I/-aI/-aO
982 Last_Dir := Lib_Search_Directories.Last;
984 Last_Dir := Src_Search_Directories.Last;
987 for D in Primary_Directory + 1 .. Last_Dir loop
988 File := Locate_File (N, T, D, File_Name);
990 if File /= No_File then
1000 -----------------------
1001 -- Find_Program_Name --
1002 -----------------------
1004 procedure Find_Program_Name is
1005 Command_Name : String (1 .. Len_Arg (0));
1006 Cindex1 : Integer := Command_Name'First;
1007 Cindex2 : Integer := Command_Name'Last;
1010 Fill_Arg (Command_Name'Address, 0);
1012 -- The program name might be specified by a full path name. However,
1013 -- we don't want to print that all out in an error message, so the
1014 -- path might need to be stripped away.
1016 for J in reverse Cindex1 .. Cindex2 loop
1017 if Is_Directory_Separator (Command_Name (J)) then
1023 -- Command_Name(Cindex1 .. Cindex2) is now the equivalent of the
1024 -- POSIX command "basename argv[0]"
1026 -- Strip off any versioning information such as found on VMS.
1027 -- This would take the form of TOOL.exe followed by a ";" or "."
1028 -- and a sequence of one or more numbers.
1030 if Command_Name (Cindex2) in '0' .. '9' then
1031 for J in reverse Cindex1 .. Cindex2 loop
1032 if Command_Name (J) = '.' or Command_Name (J) = ';' then
1037 exit when Command_Name (J) not in '0' .. '9';
1041 -- Strip off any executable extension (usually nothing or .exe)
1042 -- but formally reported by autoconf in the variable EXEEXT
1044 if Cindex2 - Cindex1 >= 4 then
1045 if To_Lower (Command_Name (Cindex2 - 3)) = '.'
1046 and then To_Lower (Command_Name (Cindex2 - 2)) = 'e
'
1047 and then To_Lower (Command_Name (Cindex2 - 1)) = 'x
'
1048 and then To_Lower (Command_Name (Cindex2)) = 'e
'
1050 Cindex2 := Cindex2 - 4;
1054 Name_Len := Cindex2 - Cindex1 + 1;
1055 Name_Buffer (1 .. Name_Len) := Command_Name (Cindex1 .. Cindex2);
1056 end Find_Program_Name;
1058 ------------------------
1059 -- Full_Lib_File_Name --
1060 ------------------------
1062 function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type is
1064 return Find_File (N, Library);
1065 end Full_Lib_File_Name;
1067 ----------------------------
1068 -- Full_Library_Info_Name --
1069 ----------------------------
1071 function Full_Library_Info_Name return File_Name_Type is
1073 return Current_Full_Lib_Name;
1074 end Full_Library_Info_Name;
1076 ---------------------------
1077 -- Full_Object_File_Name --
1078 ---------------------------
1080 function Full_Object_File_Name return File_Name_Type is
1082 return Current_Full_Obj_Name;
1083 end Full_Object_File_Name;
1085 ----------------------
1086 -- Full_Source_Name --
1087 ----------------------
1089 function Full_Source_Name return File_Name_Type is
1091 return Current_Full_Source_Name;
1092 end Full_Source_Name;
1094 ----------------------
1095 -- Full_Source_Name --
1096 ----------------------
1098 function Full_Source_Name (N : File_Name_Type) return File_Name_Type is
1100 return Smart_Find_File (N, Source);
1101 end Full_Source_Name;
1107 function Get_Directory (Name : File_Name_Type) return File_Name_Type is
1109 Get_Name_String (Name);
1111 for J in reverse 1 .. Name_Len loop
1112 if Is_Directory_Separator (Name_Buffer (J)) then
1118 Name_Len := Hostparm.Normalized_CWD'Length;
1119 Name_Buffer (1 .. Name_Len) := Hostparm.Normalized_CWD;
1123 --------------------------
1124 -- Get_Next_Dir_In_Path --
1125 --------------------------
1127 Search_Path_Pos : Integer;
1128 -- Keeps track of current position in search path. Initialized by the
1129 -- call to Get_Next_Dir_In_Path_Init, updated by Get_Next_Dir_In_Path.
1131 function Get_Next_Dir_In_Path
1132 (Search_Path : String_Access) return String_Access
1134 Lower_Bound : Positive := Search_Path_Pos;
1135 Upper_Bound : Positive;
1139 while Lower_Bound <= Search_Path'Last
1140 and then Search_Path.all (Lower_Bound) = Path_Separator
1142 Lower_Bound := Lower_Bound + 1;
1145 exit when Lower_Bound > Search_Path'Last;
1147 Upper_Bound := Lower_Bound;
1148 while Upper_Bound <= Search_Path'Last
1149 and then Search_Path.all (Upper_Bound) /= Path_Separator
1151 Upper_Bound := Upper_Bound + 1;
1154 Search_Path_Pos := Upper_Bound;
1155 return new String'(Search_Path
.all (Lower_Bound
.. Upper_Bound
- 1));
1159 end Get_Next_Dir_In_Path
;
1161 -------------------------------
1162 -- Get_Next_Dir_In_Path_Init --
1163 -------------------------------
1165 procedure Get_Next_Dir_In_Path_Init
(Search_Path
: String_Access
) is
1167 Search_Path_Pos
:= Search_Path
'First;
1168 end Get_Next_Dir_In_Path_Init
;
1170 --------------------------------------
1171 -- Get_Primary_Src_Search_Directory --
1172 --------------------------------------
1174 function Get_Primary_Src_Search_Directory
return String_Ptr
is
1176 return Src_Search_Directories
.Table
(Primary_Directory
);
1177 end Get_Primary_Src_Search_Directory
;
1179 ------------------------
1180 -- Get_RTS_Search_Dir --
1181 ------------------------
1183 function Get_RTS_Search_Dir
1184 (Search_Dir
: String;
1185 File_Type
: Search_File_Type
) return String_Ptr
1187 procedure Get_Current_Dir
1188 (Dir
: System
.Address
;
1189 Length
: System
.Address
);
1190 pragma Import
(C
, Get_Current_Dir
, "__gnat_get_current_dir");
1193 pragma Import
(C
, Max_Path
, "__gnat_max_path_len");
1194 -- Maximum length of a path name
1196 Current_Dir
: String_Ptr
;
1197 Default_Search_Dir
: String_Access
;
1198 Default_Suffix_Dir
: String_Access
;
1199 Local_Search_Dir
: String_Access
;
1200 Norm_Search_Dir
: String_Access
;
1201 Result_Search_Dir
: String_Access
;
1202 Search_File
: String_Access
;
1203 Temp_String
: String_Ptr
;
1206 -- Add a directory separator at the end of the directory if necessary
1207 -- so that we can directly append a file to the directory
1209 if Search_Dir
(Search_Dir
'Last) /= Directory_Separator
then
1210 Local_Search_Dir
:= new String'
1211 (Concat (Search_Dir, String'(1 => Directory_Separator
)));
1213 Local_Search_Dir
:= new String'(Search_Dir);
1216 if File_Type = Include then
1217 Search_File := Include_Search_File;
1218 Default_Suffix_Dir := new String'("adainclude");
1220 Search_File
:= Objects_Search_File
;
1221 Default_Suffix_Dir
:= new String'("adalib");
1224 Norm_Search_Dir := To_Canonical_Path_Spec (Local_Search_Dir.all);
1226 if Is_Absolute_Path (Norm_Search_Dir.all) then
1228 -- We first verify if there is a directory Include_Search_Dir
1229 -- containing default search directories
1232 := Read_Default_Search_Dirs (Norm_Search_Dir,
1235 Default_Search_Dir := new String'
1236 (Concat
(Norm_Search_Dir
.all, Default_Suffix_Dir
.all));
1237 Free
(Norm_Search_Dir
);
1239 if Result_Search_Dir
/= null then
1240 return String_Ptr
(Result_Search_Dir
);
1241 elsif Is_Directory
(Default_Search_Dir
.all) then
1242 return String_Ptr
(Default_Search_Dir
);
1247 -- Search in the current directory
1250 -- Get the current directory
1253 Buffer
: String (1 .. Max_Path
+ 2);
1254 Path_Len
: Natural := Max_Path
;
1257 Get_Current_Dir
(Buffer
'Address, Path_Len
'Address);
1259 if Buffer
(Path_Len
) /= Directory_Separator
then
1260 Path_Len
:= Path_Len
+ 1;
1261 Buffer
(Path_Len
) := Directory_Separator
;
1264 Current_Dir
:= new String'(Buffer (1 .. Path_Len));
1268 new String'(Concat
(Current_Dir
.all, Local_Search_Dir
.all));
1270 Result_Search_Dir
:=
1271 Read_Default_Search_Dirs
(Norm_Search_Dir
, Search_File
, null);
1273 Default_Search_Dir
:=
1275 (Concat (Norm_Search_Dir.all, Default_Suffix_Dir.all));
1277 Free (Norm_Search_Dir);
1279 if Result_Search_Dir /= null then
1280 return String_Ptr (Result_Search_Dir);
1282 elsif Is_Directory (Default_Search_Dir.all) then
1283 return String_Ptr (Default_Search_Dir);
1286 -- Search in Search_Dir_Prefix/Search_Dir
1290 (Concat
(Update_Path
(Search_Dir_Prefix
).all,
1291 Local_Search_Dir
.all));
1293 Result_Search_Dir
:=
1294 Read_Default_Search_Dirs
(Norm_Search_Dir
, Search_File
, null);
1296 Default_Search_Dir
:=
1298 (Concat (Norm_Search_Dir.all, Default_Suffix_Dir.all));
1300 Free (Norm_Search_Dir);
1302 if Result_Search_Dir /= null then
1303 return String_Ptr (Result_Search_Dir);
1305 elsif Is_Directory (Default_Search_Dir.all) then
1306 return String_Ptr (Default_Search_Dir);
1309 -- We finally search in Search_Dir_Prefix/rts-Search_Dir
1313 (Concat
(Update_Path
(Search_Dir_Prefix
).all, "rts-"));
1316 new String'(Concat (Temp_String.all, Local_Search_Dir.all));
1318 Result_Search_Dir :=
1319 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1321 Default_Search_Dir :=
1323 (Concat
(Norm_Search_Dir
.all, Default_Suffix_Dir
.all));
1324 Free
(Norm_Search_Dir
);
1326 if Result_Search_Dir
/= null then
1327 return String_Ptr
(Result_Search_Dir
);
1329 elsif Is_Directory
(Default_Search_Dir
.all) then
1330 return String_Ptr
(Default_Search_Dir
);
1338 end Get_RTS_Search_Dir
;
1340 --------------------------------
1341 -- Include_Dir_Default_Prefix --
1342 --------------------------------
1344 function Include_Dir_Default_Prefix
return String is
1345 Include_Dir
: String_Access
:=
1346 String_Access
(Update_Path
(Include_Dir_Default_Name
));
1349 if Include_Dir
= null then
1354 Result
: constant String := Include_Dir
.all;
1360 end Include_Dir_Default_Prefix
;
1366 procedure Initialize
is
1368 Number_File_Names
:= 0;
1369 Current_File_Name_Index
:= 0;
1371 Src_Search_Directories
.Init
;
1372 Lib_Search_Directories
.Init
;
1374 -- Start off by setting all suppress options to False, these will
1375 -- be reset later (turning some on if -gnato is not specified, and
1376 -- turning all of them on if -gnatp is specified).
1378 Suppress_Options
:= (others => False);
1380 -- Reserve the first slot in the search paths table. This is the
1381 -- directory of the main source file or main library file and is
1382 -- filled in by each call to Next_Main_Source/Next_Main_Lib_File with
1383 -- the directory specified for this main source or library file. This
1384 -- is the directory which is searched first by default. This default
1385 -- search is inhibited by the option -I- for both source and library
1388 Src_Search_Directories
.Set_Last
(Primary_Directory
);
1389 Src_Search_Directories
.Table
(Primary_Directory
) := new String'("");
1391 Lib_Search_Directories.Set_Last (Primary_Directory);
1392 Lib_Search_Directories.Table (Primary_Directory) := new String'("");
1395 ----------------------------
1396 -- Is_Directory_Separator --
1397 ----------------------------
1399 function Is_Directory_Separator
(C
: Character) return Boolean is
1401 -- In addition to the default directory_separator allow the '/' to
1402 -- act as separator since this is allowed in MS-DOS, Windows 95/NT,
1403 -- and OS2 ports. On VMS, the situation is more complicated because
1404 -- there are two characters to check for.
1407 C
= Directory_Separator
1409 or else (Hostparm
.OpenVMS
1410 and then (C
= ']' or else C
= ':'));
1411 end Is_Directory_Separator
;
1413 -------------------------
1414 -- Is_Readonly_Library --
1415 -------------------------
1417 function Is_Readonly_Library
(File
: in File_Name_Type
) return Boolean is
1419 Get_Name_String
(File
);
1421 pragma Assert
(Name_Buffer
(Name_Len
- 3 .. Name_Len
) = ".ali");
1423 return not Is_Writable_File
(Name_Buffer
(1 .. Name_Len
));
1424 end Is_Readonly_Library
;
1430 function Lib_File_Name
1431 (Source_File
: File_Name_Type
;
1432 Munit_Index
: Nat
:= 0) return File_Name_Type
1435 Get_Name_String
(Source_File
);
1437 for J
in reverse 2 .. Name_Len
loop
1438 if Name_Buffer
(J
) = '.' then
1444 if Munit_Index
/= 0 then
1445 Add_Char_To_Name_Buffer
(Multi_Unit_Index_Character
);
1446 Add_Nat_To_Name_Buffer
(Munit_Index
);
1449 Add_Char_To_Name_Buffer
('.');
1450 Add_Str_To_Name_Buffer
(ALI_Suffix
.all);
1454 ------------------------
1455 -- Library_File_Stamp --
1456 ------------------------
1458 function Library_File_Stamp
(N
: File_Name_Type
) return Time_Stamp_Type
is
1460 return File_Stamp
(Find_File
(N
, Library
));
1461 end Library_File_Stamp
;
1467 function Locate_File
1468 (N
: File_Name_Type
;
1471 Name
: String) return File_Name_Type
1473 Dir_Name
: String_Ptr
;
1476 -- If Name is already an absolute path, do not look for a directory
1478 if Is_Absolute_Path
(Name
) then
1481 elsif T
= Library
then
1482 Dir_Name
:= Lib_Search_Directories
.Table
(Dir
);
1484 else pragma Assert
(T
/= Config
);
1485 Dir_Name
:= Src_Search_Directories
.Table
(Dir
);
1489 Full_Name
: String (1 .. Dir_Name
'Length + Name
'Length);
1492 Full_Name
(1 .. Dir_Name
'Length) := Dir_Name
.all;
1493 Full_Name
(Dir_Name
'Length + 1 .. Full_Name
'Length) := Name
;
1495 if not Is_Regular_File
(Full_Name
) then
1499 -- If the file is in the current directory then return N itself
1501 if Dir_Name
'Length = 0 then
1504 Name_Len
:= Full_Name
'Length;
1505 Name_Buffer
(1 .. Name_Len
) := Full_Name
;
1512 -------------------------------
1513 -- Matching_Full_Source_Name --
1514 -------------------------------
1516 function Matching_Full_Source_Name
1517 (N
: File_Name_Type
;
1518 T
: Time_Stamp_Type
) return File_Name_Type
1521 Get_Name_String
(N
);
1524 File_Name
: constant String := Name_Buffer
(1 .. Name_Len
);
1525 File
: File_Name_Type
:= No_File
;
1529 if Opt
.Look_In_Primary_Dir
then
1530 File
:= Locate_File
(N
, Source
, Primary_Directory
, File_Name
);
1532 if File
/= No_File
and then T
= File_Stamp
(N
) then
1537 Last_Dir
:= Src_Search_Directories
.Last
;
1539 for D
in Primary_Directory
+ 1 .. Last_Dir
loop
1540 File
:= Locate_File
(N
, Source
, D
, File_Name
);
1542 if File
/= No_File
and then T
= File_Stamp
(File
) then
1549 end Matching_Full_Source_Name
;
1555 function More_Files
return Boolean is
1557 return (Current_File_Name_Index
< Number_File_Names
);
1560 -------------------------------
1561 -- Nb_Dir_In_Obj_Search_Path --
1562 -------------------------------
1564 function Nb_Dir_In_Obj_Search_Path
return Natural is
1566 if Opt
.Look_In_Primary_Dir
then
1567 return Lib_Search_Directories
.Last
- Primary_Directory
+ 1;
1569 return Lib_Search_Directories
.Last
- Primary_Directory
;
1571 end Nb_Dir_In_Obj_Search_Path
;
1573 -------------------------------
1574 -- Nb_Dir_In_Src_Search_Path --
1575 -------------------------------
1577 function Nb_Dir_In_Src_Search_Path
return Natural is
1579 if Opt
.Look_In_Primary_Dir
then
1580 return Src_Search_Directories
.Last
- Primary_Directory
+ 1;
1582 return Src_Search_Directories
.Last
- Primary_Directory
;
1584 end Nb_Dir_In_Src_Search_Path
;
1586 --------------------
1587 -- Next_Main_File --
1588 --------------------
1590 function Next_Main_File
return File_Name_Type
is
1591 File_Name
: String_Ptr
;
1592 Dir_Name
: String_Ptr
;
1596 pragma Assert
(More_Files
);
1598 Current_File_Name_Index
:= Current_File_Name_Index
+ 1;
1600 -- Get the file and directory name
1602 File_Name
:= File_Names
(Current_File_Name_Index
);
1603 Fptr
:= File_Name
'First;
1605 for J
in reverse File_Name
'Range loop
1606 if File_Name
(J
) = Directory_Separator
1607 or else File_Name
(J
) = '/'
1609 if J
= File_Name
'Last then
1610 Fail
("File name missing");
1618 -- Save name of directory in which main unit resides for use in
1619 -- locating other units
1621 Dir_Name
:= new String'(File_Name (File_Name'First .. Fptr - 1));
1623 case Running_Program is
1626 Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
1627 Look_In_Primary_Directory_For_Current_Main := True;
1630 Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
1632 if Fptr > File_Name'First then
1633 Look_In_Primary_Directory_For_Current_Main := True;
1636 when Binder | Gnatls =>
1637 Dir_Name := Normalize_Directory_Name (Dir_Name.all);
1638 Lib_Search_Directories.Table (Primary_Directory) := Dir_Name;
1644 Name_Len := File_Name'Last - Fptr + 1;
1645 Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last);
1646 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
1647 Current_Main := File_Name_Type (Name_Find);
1649 -- In the gnatmake case, the main file may have not have the
1650 -- extension. Try ".adb" first then ".ads"
1652 if Running_Program = Make then
1654 Orig_Main : constant File_Name_Type := Current_Main;
1657 if Strip_Suffix (Orig_Main) = Orig_Main then
1658 Current_Main := Append_Suffix_To_File_Name (Orig_Main, ".adb");
1660 if Full_Source_Name (Current_Main) = No_File then
1662 Append_Suffix_To_File_Name (Orig_Main, ".ads");
1664 if Full_Source_Name (Current_Main) = No_File then
1665 Current_Main := Orig_Main;
1672 return Current_Main;
1675 ------------------------------
1676 -- Normalize_Directory_Name --
1677 ------------------------------
1679 function Normalize_Directory_Name (Directory : String) return String_Ptr is
1681 function Is_Quoted (Path : String) return Boolean;
1682 pragma Inline (Is_Quoted);
1683 -- Returns true if Path is quoted (either double or single quotes)
1689 function Is_Quoted (Path : String) return Boolean is
1690 First : constant Character := Path (Path'First);
1691 Last : constant Character := Path (Path'Last);
1694 if (First = ''' and then Last = ''')
1696 (First = '"' and then Last = '"')
1704 Result : String_Ptr;
1706 -- Start of processing for Normalize_Directory_Name
1709 if Directory'Length = 0 then
1710 Result := new String'(Hostparm
.Normalized_CWD
);
1712 elsif Is_Directory_Separator
(Directory
(Directory
'Last)) then
1713 Result
:= new String'(Directory);
1715 elsif Is_Quoted (Directory) then
1717 -- This is a quoted string, it certainly means that the directory
1718 -- contains some spaces for example. We can safely remove the quotes
1719 -- here as the OS_Lib.Normalize_Arguments will be called before any
1720 -- spawn routines. This ensure that quotes will be added when needed.
1722 Result := new String (1 .. Directory'Length - 1);
1723 Result (1 .. Directory'Length - 1) :=
1724 Directory (Directory'First + 1 .. Directory'Last - 1);
1725 Result (Result'Last) := Directory_Separator;
1728 Result := new String (1 .. Directory'Length + 1);
1729 Result (1 .. Directory'Length) := Directory;
1730 Result (Directory'Length + 1) := Directory_Separator;
1734 end Normalize_Directory_Name;
1736 ---------------------
1737 -- Number_Of_Files --
1738 ---------------------
1740 function Number_Of_Files return Int is
1742 return Number_File_Names;
1743 end Number_Of_Files;
1745 -------------------------------
1746 -- Object_Dir_Default_Prefix --
1747 -------------------------------
1749 function Object_Dir_Default_Prefix return String is
1750 Object_Dir : String_Access :=
1751 String_Access (Update_Path (Object_Dir_Default_Name));
1754 if Object_Dir = null then
1759 Result : constant String := Object_Dir.all;
1765 end Object_Dir_Default_Prefix;
1767 ----------------------
1768 -- Object_File_Name --
1769 ----------------------
1771 function Object_File_Name (N : File_Name_Type) return File_Name_Type is
1777 Get_Name_String (N);
1778 Name_Len := Name_Len - ALI_Suffix'Length - 1;
1780 for J in Target_Object_Suffix'Range loop
1781 Name_Len := Name_Len + 1;
1782 Name_Buffer (Name_Len) := Target_Object_Suffix (J);
1786 end Object_File_Name;
1788 --------------------------
1789 -- OS_Time_To_GNAT_Time --
1790 --------------------------
1792 function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type is
1793 GNAT_Time : Time_Stamp_Type;
1803 GM_Split (T, Y, Mo, D, H, Mn, S);
1809 Minutes => Nat (Mn),
1814 end OS_Time_To_GNAT_Time;
1820 function Program_Name (Nam : String) return String_Access is
1821 Res : String_Access;
1824 -- Get the name of the current program being executed
1828 -- Find the target prefix if any, for the cross compilation case
1829 -- for instance in "alpha-dec-vxworks-gcc" the target prefix is
1830 -- "alpha-dec-vxworks-"
1832 while Name_Len > 0 loop
1834 -- All done if we find the last hyphen
1836 if Name_Buffer (Name_Len) = '-' then
1839 -- If directory separator found, we don't want to look further
1840 -- since in this case, no prefix has been found.
1842 elsif Is_Directory_Separator (Name_Buffer (Name_Len)) then
1847 Name_Len := Name_Len - 1;
1850 -- Create the new program name
1852 Res := new String (1 .. Name_Len + Nam'Length);
1853 Res.all (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
1854 Res.all (Name_Len + 1 .. Name_Len + Nam'Length) := Nam;
1858 ------------------------------
1859 -- Read_Default_Search_Dirs --
1860 ------------------------------
1862 function Read_Default_Search_Dirs
1863 (Search_Dir_Prefix : String_Access;
1864 Search_File : String_Access;
1865 Search_Dir_Default_Name : String_Access) return String_Access
1867 Prefix_Len : constant Integer := Search_Dir_Prefix.all'Length;
1868 Buffer : String (1 .. Prefix_Len + Search_File.all'Length + 1);
1869 File_FD : File_Descriptor;
1870 S, S1 : String_Access;
1873 Actual_Len : Integer;
1876 Prev_Was_Separator : Boolean;
1877 Nb_Relative_Dir : Integer;
1879 function Is_Relative (S : String; K : Positive) return Boolean;
1880 pragma Inline (Is_Relative);
1881 -- Returns True if a relative directory specification is found
1882 -- in S at position K, False otherwise.
1888 function Is_Relative (S : String; K : Positive) return Boolean is
1890 return not Is_Absolute_Path (S (K .. S'Last));
1893 -- Start of processing for Read_Default_Search_Dirs
1896 -- Construct a C compatible character string buffer
1898 Buffer (1 .. Search_Dir_Prefix.all'Length)
1899 := Search_Dir_Prefix.all;
1900 Buffer (Search_Dir_Prefix.all'Length + 1 .. Buffer'Last - 1)
1902 Buffer (Buffer'Last) := ASCII.NUL;
1904 File_FD := Open_Read (Buffer'Address, Binary);
1905 if File_FD = Invalid_FD then
1906 return Search_Dir_Default_Name;
1909 Len := Integer (File_Length (File_FD));
1911 -- An extra character for a trailing Path_Separator is allocated
1913 S := new String (1 .. Len + 1);
1914 S (Len + 1) := Path_Separator;
1916 -- Read the file. Note that the loop is not necessary since the
1917 -- whole file is read at once except on VMS.
1921 while Actual_Len /= 0 loop
1922 Actual_Len := Read (File_FD, S (Curr)'Address, Len);
1923 Curr := Curr + Actual_Len;
1926 -- Process the file, translating line and file ending
1927 -- control characters to a path separator character.
1929 Prev_Was_Separator := True;
1930 Nb_Relative_Dir := 0;
1931 for J in 1 .. Len loop
1932 if S (J) in ASCII.NUL .. ASCII.US
1935 S (J) := Path_Separator;
1938 if S (J) = Path_Separator then
1939 Prev_Was_Separator := True;
1941 if Prev_Was_Separator and then Is_Relative (S.all, J) then
1942 Nb_Relative_Dir := Nb_Relative_Dir + 1;
1945 Prev_Was_Separator := False;
1949 if Nb_Relative_Dir = 0 then
1953 -- Add the Search_Dir_Prefix to all relative paths
1955 S1 := new String (1 .. S'Length + Nb_Relative_Dir * Prefix_Len);
1957 Prev_Was_Separator := True;
1958 for J in 1 .. Len + 1 loop
1959 if S (J) = Path_Separator then
1960 Prev_Was_Separator := True;
1963 if Prev_Was_Separator and then Is_Relative (S.all, J) then
1964 S1 (J1 .. J1 + Prefix_Len - 1) := Search_Dir_Prefix.all;
1965 J1 := J1 + Prefix_Len;
1968 Prev_Was_Separator := False;
1976 end Read_Default_Search_Dirs;
1978 -----------------------
1979 -- Read_Library_Info --
1980 -----------------------
1982 function Read_Library_Info
1983 (Lib_File : File_Name_Type;
1984 Fatal_Err : Boolean := False) return Text_Buffer_Ptr
1986 Lib_FD : File_Descriptor;
1987 -- The file descriptor for the current library file. A negative value
1988 -- indicates failure to open the specified source file.
1990 Text : Text_Buffer_Ptr;
1991 -- Allocated text buffer
1994 -- For the calls to Close
1997 Current_Full_Lib_Name := Find_File (Lib_File, Library);
1998 Current_Full_Obj_Name := Object_File_Name (Current_Full_Lib_Name);
2000 if Current_Full_Lib_Name = No_File then
2002 Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
2004 Current_Full_Obj_Stamp := Empty_Time_Stamp;
2009 Get_Name_String (Current_Full_Lib_Name);
2010 Name_Buffer (Name_Len + 1) := ASCII.NUL;
2012 -- Open the library FD, note that we open in binary mode, because as
2013 -- documented in the spec, the caller is expected to handle either
2014 -- DOS or Unix mode files, and there is no point in wasting time on
2015 -- text translation when it is not required.
2017 Lib_FD := Open_Read (Name_Buffer'Address, Binary);
2019 if Lib_FD = Invalid_FD then
2021 Fail ("Cannot open: ", Name_Buffer (1 .. Name_Len));
2023 Current_Full_Obj_Stamp := Empty_Time_Stamp;
2028 -- Check for object file consistency if requested
2030 if Opt.Check_Object_Consistency then
2031 Current_Full_Lib_Stamp := File_Stamp (Current_Full_Lib_Name);
2032 Current_Full_Obj_Stamp := File_Stamp (Current_Full_Obj_Name);
2034 if Current_Full_Obj_Stamp (1) = ' ' then
2036 -- When the library is readonly, always assume that
2037 -- the object is consistent.
2039 if Is_Readonly_Library (Current_Full_Lib_Name) then
2040 Current_Full_Obj_Stamp := Current_Full_Lib_Stamp;
2042 elsif Fatal_Err then
2043 Get_Name_String (Current_Full_Obj_Name);
2044 Close (Lib_FD, Status);
2045 -- No need to check the status, we fail anyway
2047 Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
2050 Current_Full_Obj_Stamp := Empty_Time_Stamp;
2051 Close (Lib_FD, Status);
2053 -- No need to check the status, we return null anyway
2060 -- Read data from the file
2063 Len : constant Integer := Integer (File_Length (Lib_FD));
2064 -- Length of source file text. If it doesn't fit in an integer
2065 -- we're probably stuck anyway (>2 gigs of source seems a lot!)
2067 Actual_Len : Integer := 0;
2069 Lo : constant Text_Ptr := 0;
2070 -- Low bound for allocated text buffer
2072 Hi : Text_Ptr := Text_Ptr (Len);
2073 -- High bound for allocated text buffer. Note length is Len + 1
2074 -- which allows for extra EOF character at the end of the buffer.
2077 -- Allocate text buffer. Note extra character at end for EOF
2079 Text := new Text_Buffer (Lo .. Hi);
2081 -- Some systems (e.g. VMS) have file types that require one
2082 -- read per line, so read until we get the Len bytes or until
2083 -- there are no more characters.
2087 Actual_Len := Read (Lib_FD, Text (Hi)'Address, Len);
2088 Hi := Hi + Text_Ptr (Actual_Len);
2089 exit when Actual_Len = Len or Actual_Len <= 0;
2095 -- Read is complete, close file and we are done
2097 Close (Lib_FD, Status);
2098 -- The status should never be False. But, if it is, what can we do?
2099 -- So, we don't test it.
2103 end Read_Library_Info;
2105 ----------------------
2106 -- Read_Source_File --
2107 ----------------------
2109 procedure Read_Source_File
2110 (N : File_Name_Type;
2112 Hi : out Source_Ptr;
2113 Src : out Source_Buffer_Ptr;
2114 T : File_Type := Source)
2116 Source_File_FD : File_Descriptor;
2117 -- The file descriptor for the current source file. A negative value
2118 -- indicates failure to open the specified source file.
2121 -- Length of file. Assume no more than 2 gigabytes of source!
2123 Actual_Len : Integer;
2126 -- For the call to Close
2129 Current_Full_Source_Name := Find_File (N, T);
2130 Current_Full_Source_Stamp := File_Stamp (Current_Full_Source_Name);
2132 if Current_Full_Source_Name = No_File then
2134 -- If we were trying to access the main file and we could not
2135 -- find it we have an error.
2137 if N = Current_Main then
2138 Get_Name_String (N);
2139 Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
2147 Get_Name_String (Current_Full_Source_Name);
2148 Name_Buffer (Name_Len + 1) := ASCII.NUL;
2150 -- Open the source FD, note that we open in binary mode, because as
2151 -- documented in the spec, the caller is expected to handle either
2152 -- DOS or Unix mode files, and there is no point in wasting time on
2153 -- text translation when it is not required.
2155 Source_File_FD := Open_Read (Name_Buffer'Address, Binary);
2157 if Source_File_FD = Invalid_FD then
2163 -- Prepare to read data from the file
2165 Len := Integer (File_Length (Source_File_FD));
2167 -- Set Hi so that length is one more than the physical length,
2168 -- allowing for the extra EOF character at the end of the buffer
2170 Hi := Lo + Source_Ptr (Len);
2172 -- Do the actual read operation
2175 subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
2176 -- Physical buffer allocated
2178 type Actual_Source_Ptr is access Actual_Source_Buffer;
2179 -- This is the pointer type for the physical buffer allocated
2181 Actual_Ptr : constant Actual_Source_Ptr := new Actual_Source_Buffer;
2182 -- And this is the actual physical buffer
2185 -- Allocate source buffer, allowing extra character at end for EOF
2187 -- Some systems (e.g. VMS) have file types that require one
2188 -- read per line, so read until we get the Len bytes or until
2189 -- there are no more characters.
2193 Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len);
2194 Hi := Hi + Source_Ptr (Actual_Len);
2195 exit when Actual_Len = Len or Actual_Len <= 0;
2198 Actual_Ptr (Hi) := EOF;
2200 -- Now we need to work out the proper virtual origin pointer to
2201 -- return. This is exactly Actual_Ptr (0)'Address, but we have
2202 -- to be careful to suppress checks to compute this address.
2205 pragma Suppress (All_Checks);
2207 pragma Warnings (Off);
2208 -- This use of unchecked conversion is aliasing safe
2210 function To_Source_Buffer_Ptr is new
2211 Unchecked_Conversion (Address, Source_Buffer_Ptr);
2213 pragma Warnings (On);
2216 Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
2220 -- Read is complete, get time stamp and close file and we are done
2222 Close (Source_File_FD, Status);
2224 -- The status should never be False. But, if it is, what can we do?
2225 -- So, we don't test it.
2227 end Read_Source_File;
2233 function Relocate_Path
2235 Path : String) return String_Ptr
2239 procedure set_std_prefix (S : String; Len : Integer);
2240 pragma Import (C, set_std_prefix);
2243 if Std_Prefix = null then
2244 Std_Prefix := Executable_Prefix;
2246 if Std_Prefix.all /= "" then
2248 -- Remove trailing directory separator when calling set_std_prefix
2250 set_std_prefix (Std_Prefix.all, Std_Prefix'Length - 1);
2254 if Path (Prefix'Range) = Prefix then
2255 if Std_Prefix.all /= "" then
2257 (1 .. Std_Prefix'Length + Path'Last - Prefix'Last);
2258 S (1 .. Std_Prefix'Length) := Std_Prefix.all;
2259 S (Std_Prefix'Length + 1 .. S'Last) :=
2260 Path (Prefix'Last + 1 .. Path'Last);
2265 return new String'(Path
);
2272 procedure Set_Program
(P
: Program_Type
) is
2275 Fail
("Set_Program called twice");
2278 Program_Set
:= True;
2279 Running_Program
:= P
;
2286 function Shared_Lib
(Name
: String) return String is
2287 Library
: String (1 .. Name
'Length + Library_Version
'Length + 3);
2288 -- 3 = 2 for "-l" + 1 for "-" before lib version
2291 Library
(1 .. 2) := "-l";
2292 Library
(3 .. 2 + Name
'Length) := Name
;
2293 Library
(3 + Name
'Length) := '-';
2294 Library
(4 + Name
'Length .. Library
'Last) := Library_Version
;
2296 if OpenVMS_On_Target
then
2297 for K
in Library
'First + 2 .. Library
'Last loop
2298 if Library
(K
) = '.' or else Library
(K
) = '-' then
2307 ----------------------
2308 -- Smart_File_Stamp --
2309 ----------------------
2311 function Smart_File_Stamp
2312 (N
: File_Name_Type
;
2313 T
: File_Type
) return Time_Stamp_Type
2315 Time_Stamp
: Time_Stamp_Type
;
2318 if not File_Cache_Enabled
then
2319 return File_Stamp
(Find_File
(N
, T
));
2322 Time_Stamp
:= File_Stamp_Hash_Table
.Get
(N
);
2324 if Time_Stamp
(1) = ' ' then
2325 Time_Stamp
:= File_Stamp
(Smart_Find_File
(N
, T
));
2326 File_Stamp_Hash_Table
.Set
(N
, Time_Stamp
);
2330 end Smart_File_Stamp
;
2332 ---------------------
2333 -- Smart_Find_File --
2334 ---------------------
2336 function Smart_Find_File
2337 (N
: File_Name_Type
;
2338 T
: File_Type
) return File_Name_Type
2340 Full_File_Name
: File_Name_Type
;
2343 if not File_Cache_Enabled
then
2344 return Find_File
(N
, T
);
2347 Full_File_Name
:= File_Name_Hash_Table
.Get
(N
);
2349 if Full_File_Name
= No_File
then
2350 Full_File_Name
:= Find_File
(N
, T
);
2351 File_Name_Hash_Table
.Set
(N
, Full_File_Name
);
2354 return Full_File_Name
;
2355 end Smart_Find_File
;
2357 ----------------------
2358 -- Source_File_Data --
2359 ----------------------
2361 procedure Source_File_Data
(Cache
: Boolean) is
2363 File_Cache_Enabled
:= Cache
;
2364 end Source_File_Data
;
2366 -----------------------
2367 -- Source_File_Stamp --
2368 -----------------------
2370 function Source_File_Stamp
(N
: File_Name_Type
) return Time_Stamp_Type
is
2372 return Smart_File_Stamp
(N
, Source
);
2373 end Source_File_Stamp
;
2375 ---------------------
2376 -- Strip_Directory --
2377 ---------------------
2379 function Strip_Directory
(Name
: File_Name_Type
) return File_Name_Type
is
2381 Get_Name_String
(Name
);
2383 for J
in reverse 1 .. Name_Len
- 1 loop
2385 -- If we find the last directory separator
2387 if Is_Directory_Separator
(Name_Buffer
(J
)) then
2389 -- Return the part of Name that follows this last directory
2392 Name_Buffer
(1 .. Name_Len
- J
) := Name_Buffer
(J
+ 1 .. Name_Len
);
2393 Name_Len
:= Name_Len
- J
;
2398 -- There were no directory separator, just return Name
2401 end Strip_Directory
;
2407 function Strip_Suffix
(Name
: File_Name_Type
) return File_Name_Type
is
2409 Get_Name_String
(Name
);
2411 for J
in reverse 2 .. Name_Len
loop
2413 -- If we found the last '.', return part of Name that precedes it
2415 if Name_Buffer
(J
) = '.' then
2424 ---------------------------
2425 -- To_Canonical_Dir_Spec --
2426 ---------------------------
2428 function To_Canonical_Dir_Spec
2430 Prefix_Style
: Boolean) return String_Access
2432 function To_Canonical_Dir_Spec
2433 (Host_Dir
: Address
;
2434 Prefix_Flag
: Integer) return Address
;
2435 pragma Import
(C
, To_Canonical_Dir_Spec
, "__gnat_to_canonical_dir_spec");
2437 C_Host_Dir
: String (1 .. Host_Dir
'Length + 1);
2438 Canonical_Dir_Addr
: Address
;
2439 Canonical_Dir_Len
: Integer;
2442 C_Host_Dir
(1 .. Host_Dir
'Length) := Host_Dir
;
2443 C_Host_Dir
(C_Host_Dir
'Last) := ASCII
.NUL
;
2445 if Prefix_Style
then
2446 Canonical_Dir_Addr
:= To_Canonical_Dir_Spec
(C_Host_Dir
'Address, 1);
2448 Canonical_Dir_Addr
:= To_Canonical_Dir_Spec
(C_Host_Dir
'Address, 0);
2450 Canonical_Dir_Len
:= C_String_Length
(Canonical_Dir_Addr
);
2452 if Canonical_Dir_Len
= 0 then
2455 return To_Path_String_Access
(Canonical_Dir_Addr
, Canonical_Dir_Len
);
2460 Fail
("erroneous directory spec: ", Host_Dir
);
2462 end To_Canonical_Dir_Spec
;
2464 ---------------------------
2465 -- To_Canonical_File_List --
2466 ---------------------------
2468 function To_Canonical_File_List
2469 (Wildcard_Host_File
: String;
2470 Only_Dirs
: Boolean) return String_Access_List_Access
2472 function To_Canonical_File_List_Init
2473 (Host_File
: Address
;
2474 Only_Dirs
: Integer) return Integer;
2475 pragma Import
(C
, To_Canonical_File_List_Init
,
2476 "__gnat_to_canonical_file_list_init");
2478 function To_Canonical_File_List_Next
return Address
;
2479 pragma Import
(C
, To_Canonical_File_List_Next
,
2480 "__gnat_to_canonical_file_list_next");
2482 procedure To_Canonical_File_List_Free
;
2483 pragma Import
(C
, To_Canonical_File_List_Free
,
2484 "__gnat_to_canonical_file_list_free");
2486 Num_Files
: Integer;
2487 C_Wildcard_Host_File
: String (1 .. Wildcard_Host_File
'Length + 1);
2490 C_Wildcard_Host_File
(1 .. Wildcard_Host_File
'Length) :=
2492 C_Wildcard_Host_File
(C_Wildcard_Host_File
'Last) := ASCII
.NUL
;
2494 -- Do the expansion and say how many there are
2496 Num_Files
:= To_Canonical_File_List_Init
2497 (C_Wildcard_Host_File
'Address, Boolean'Pos (Only_Dirs
));
2500 Canonical_File_List
: String_Access_List
(1 .. Num_Files
);
2501 Canonical_File_Addr
: Address
;
2502 Canonical_File_Len
: Integer;
2505 -- Retrieve the expanded directoy names and build the list
2507 for J
in 1 .. Num_Files
loop
2508 Canonical_File_Addr
:= To_Canonical_File_List_Next
;
2509 Canonical_File_Len
:= C_String_Length
(Canonical_File_Addr
);
2510 Canonical_File_List
(J
) := To_Path_String_Access
2511 (Canonical_File_Addr
, Canonical_File_Len
);
2514 -- Free up the storage
2516 To_Canonical_File_List_Free
;
2518 return new String_Access_List
'(Canonical_File_List);
2520 end To_Canonical_File_List;
2522 ----------------------------
2523 -- To_Canonical_File_Spec --
2524 ----------------------------
2526 function To_Canonical_File_Spec
2527 (Host_File : String) return String_Access
2529 function To_Canonical_File_Spec (Host_File : Address) return Address;
2531 (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
2533 C_Host_File : String (1 .. Host_File'Length + 1);
2534 Canonical_File_Addr : Address;
2535 Canonical_File_Len : Integer;
2538 C_Host_File (1 .. Host_File'Length) := Host_File;
2539 C_Host_File (C_Host_File'Last) := ASCII.NUL;
2541 Canonical_File_Addr := To_Canonical_File_Spec (C_Host_File'Address);
2542 Canonical_File_Len := C_String_Length (Canonical_File_Addr);
2544 if Canonical_File_Len = 0 then
2547 return To_Path_String_Access
2548 (Canonical_File_Addr, Canonical_File_Len);
2553 Fail ("erroneous file spec: ", Host_File);
2555 end To_Canonical_File_Spec;
2557 ----------------------------
2558 -- To_Canonical_Path_Spec --
2559 ----------------------------
2561 function To_Canonical_Path_Spec
2562 (Host_Path : String) return String_Access
2564 function To_Canonical_Path_Spec (Host_Path : Address) return Address;
2566 (C, To_Canonical_Path_Spec, "__gnat_to_canonical_path_spec");
2568 C_Host_Path : String (1 .. Host_Path'Length + 1);
2569 Canonical_Path_Addr : Address;
2570 Canonical_Path_Len : Integer;
2573 C_Host_Path (1 .. Host_Path'Length) := Host_Path;
2574 C_Host_Path (C_Host_Path'Last) := ASCII.NUL;
2576 Canonical_Path_Addr := To_Canonical_Path_Spec (C_Host_Path'Address);
2577 Canonical_Path_Len := C_String_Length (Canonical_Path_Addr);
2579 -- Return a null string (vice a null) for zero length paths, for
2580 -- compatibility with getenv().
2582 return To_Path_String_Access (Canonical_Path_Addr, Canonical_Path_Len);
2586 Fail ("erroneous path spec: ", Host_Path);
2588 end To_Canonical_Path_Spec;
2590 ---------------------------
2591 -- To_Host_Dir_Spec --
2592 ---------------------------
2594 function To_Host_Dir_Spec
2595 (Canonical_Dir : String;
2596 Prefix_Style : Boolean) return String_Access
2598 function To_Host_Dir_Spec
2599 (Canonical_Dir : Address;
2600 Prefix_Flag : Integer) return Address;
2601 pragma Import (C, To_Host_Dir_Spec, "__gnat_to_host_dir_spec");
2603 C_Canonical_Dir : String (1 .. Canonical_Dir'Length + 1);
2604 Host_Dir_Addr : Address;
2605 Host_Dir_Len : Integer;
2608 C_Canonical_Dir (1 .. Canonical_Dir'Length) := Canonical_Dir;
2609 C_Canonical_Dir (C_Canonical_Dir'Last) := ASCII.NUL;
2611 if Prefix_Style then
2612 Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 1);
2614 Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 0);
2616 Host_Dir_Len := C_String_Length (Host_Dir_Addr);
2618 if Host_Dir_Len = 0 then
2621 return To_Path_String_Access (Host_Dir_Addr, Host_Dir_Len);
2623 end To_Host_Dir_Spec;
2625 ----------------------------
2626 -- To_Host_File_Spec --
2627 ----------------------------
2629 function To_Host_File_Spec
2630 (Canonical_File : String) return String_Access
2632 function To_Host_File_Spec (Canonical_File : Address) return Address;
2633 pragma Import (C, To_Host_File_Spec, "__gnat_to_host_file_spec");
2635 C_Canonical_File : String (1 .. Canonical_File'Length + 1);
2636 Host_File_Addr : Address;
2637 Host_File_Len : Integer;
2640 C_Canonical_File (1 .. Canonical_File'Length) := Canonical_File;
2641 C_Canonical_File (C_Canonical_File'Last) := ASCII.NUL;
2643 Host_File_Addr := To_Host_File_Spec (C_Canonical_File'Address);
2644 Host_File_Len := C_String_Length (Host_File_Addr);
2646 if Host_File_Len = 0 then
2649 return To_Path_String_Access
2650 (Host_File_Addr, Host_File_Len);
2652 end To_Host_File_Spec;
2654 ---------------------------
2655 -- To_Path_String_Access --
2656 ---------------------------
2658 function To_Path_String_Access
2659 (Path_Addr : Address;
2660 Path_Len : Integer) return String_Access
2662 subtype Path_String is String (1 .. Path_Len);
2663 type Path_String_Access is access Path_String;
2665 function Address_To_Access is new
2666 Unchecked_Conversion (Source => Address,
2667 Target => Path_String_Access);
2669 Path_Access : constant Path_String_Access :=
2670 Address_To_Access (Path_Addr);
2672 Return_Val : String_Access;
2675 Return_Val := new String (1 .. Path_Len);
2677 for J in 1 .. Path_Len loop
2678 Return_Val (J) := Path_Access (J);
2682 end To_Path_String_Access;
2688 function Update_Path (Path : String_Ptr) return String_Ptr is
2690 function C_Update_Path (Path, Component : Address) return Address;
2691 pragma Import (C, C_Update_Path, "update_path");
2693 function Strlen (Str : Address) return Integer;
2694 pragma Import (C, Strlen, "strlen");
2696 procedure Strncpy (X : Address; Y : Address; Length : Integer);
2697 pragma Import (C, Strncpy, "strncpy");
2699 In_Length : constant Integer := Path'Length;
2700 In_String : String (1 .. In_Length + 1);
2701 Component_Name : aliased String := "GCC" & ASCII.NUL;
2702 Result_Ptr : Address;
2703 Result_Length : Integer;
2704 Out_String : String_Ptr;
2707 In_String (1 .. In_Length) := Path.all;
2708 In_String (In_Length + 1) := ASCII.NUL;
2709 Result_Ptr := C_Update_Path (In_String'Address,
2710 Component_Name'Address);
2711 Result_Length := Strlen (Result_Ptr);
2713 Out_String := new String (1 .. Result_Length);
2714 Strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
2722 procedure Write_Info (Info : String) is
2724 Write_With_Check (Info'Address, Info'Length);
2725 Write_With_Check (EOL'Address, 1);
2728 ------------------------
2729 -- Write_Program_Name --
2730 ------------------------
2732 procedure Write_Program_Name is
2733 Save_Buffer : constant String (1 .. Name_Len) :=
2734 Name_Buffer (1 .. Name_Len);
2739 -- Convert the name to lower case so error messages are the same on
2742 for J in 1 .. Name_Len loop
2743 if Name_Buffer (J) in 'A
' .. 'Z
' then
2745 Character'Val (Character'Pos (Name_Buffer (J)) + 32);
2749 Write_Str (Name_Buffer (1 .. Name_Len));
2751 -- Restore Name_Buffer which was clobbered by the call to
2752 -- Find_Program_Name
2754 Name_Len := Save_Buffer'Last;
2755 Name_Buffer (1 .. Name_Len) := Save_Buffer;
2756 end Write_Program_Name;
2758 ----------------------
2759 -- Write_With_Check --
2760 ----------------------
2762 procedure Write_With_Check (A : Address; N : Integer) is
2766 if N = Write (Output_FD, A, N) then
2770 Write_Str ("error: disk full writing ");
2771 Write_Name_Decoded (Output_File_Name);
2773 Name_Len := Name_Len + 1;
2774 Name_Buffer (Name_Len) := ASCII.NUL;
2775 Delete_File (Name_Buffer'Address, Ignore);
2776 Exit_Program (E_Fatal);
2778 end Write_With_Check;
2780 ----------------------------
2781 -- Package Initialization --
2782 ----------------------------
2785 Initialization : declare
2787 function Get_Default_Identifier_Character_Set return Character;
2788 pragma Import (C, Get_Default_Identifier_Character_Set,
2789 "__gnat_get_default_identifier_character_set");
2790 -- Function to determine the default identifier character set,
2791 -- which is system dependent. See Opt package spec for a list of
2792 -- the possible character codes and their interpretations.
2794 function Get_Maximum_File_Name_Length return Int;
2795 pragma Import (C, Get_Maximum_File_Name_Length,
2796 "__gnat_get_maximum_file_name_length");
2797 -- Function to get maximum file name length for system
2800 Identifier_Character_Set := Get_Default_Identifier_Character_Set;
2801 Maximum_File_Name_Length := Get_Maximum_File_Name_Length;
2803 -- Following should be removed by having above function return
2804 -- Integer'Last as indication of no maximum instead of -1 ???
2806 if Maximum_File_Name_Length = -1 then
2807 Maximum_File_Name_Length := Int'Last;
2810 Src_Search_Directories.Set_Last (Primary_Directory);
2811 Src_Search_Directories.Table (Primary_Directory) := new String'("");
2813 Lib_Search_Directories
.Set_Last
(Primary_Directory
);
2814 Lib_Search_Directories
.Table
(Primary_Directory
) := new String'("");