1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Unchecked_Conversion
;
28 with System
.Case_Util
; use System
.Case_Util
;
33 with Gnatvsn
; use Gnatvsn
;
36 with Output
; use Output
;
37 with Sdefault
; use Sdefault
;
39 with Targparm
; use Targparm
;
43 Running_Program
: Program_Type
:= Unspecified
;
44 -- comment required here ???
46 Program_Set
: Boolean := False;
47 -- comment required here ???
49 Std_Prefix
: String_Ptr
;
50 -- Standard prefix, computed dynamically the first time Relocate_Path
51 -- is called, and cached for subsequent calls.
53 Empty
: aliased String := "";
54 No_Dir
: constant String_Ptr
:= Empty
'Access;
55 -- Used in Locate_File as a fake directory when Name is already an
58 -------------------------------------
59 -- Use of Name_Find and Name_Enter --
60 -------------------------------------
62 -- This package creates a number of source, ALI and object file names
63 -- that are used to locate the actual file and for the purpose of message
64 -- construction. These names need not be accessible by Name_Find, and can
65 -- be therefore created by using routine Name_Enter. The files in question
66 -- are file names with a prefix directory (i.e., the files not in the
67 -- current directory). File names without a prefix directory are entered
68 -- with Name_Find because special values might be attached to the various
69 -- Info fields of the corresponding name table entry.
71 -----------------------
72 -- Local Subprograms --
73 -----------------------
75 function Append_Suffix_To_File_Name
76 (Name
: File_Name_Type
;
77 Suffix
: String) return File_Name_Type
;
78 -- Appends Suffix to Name and returns the new name
80 function OS_Time_To_GNAT_Time
(T
: OS_Time
) return Time_Stamp_Type
;
81 -- Convert OS format time to GNAT format time stamp
83 function Executable_Prefix
return String_Ptr
;
84 -- Returns the name of the root directory where the executable is stored.
85 -- The executable must be located in a directory called "bin", or under
86 -- root/lib/gcc-lib/..., or under root/libexec/gcc/... For example, if
87 -- executable is stored in directory "/foo/bar/bin", this routine returns
88 -- "/foo/bar/". Return "" if location is not recognized as described above.
90 function Update_Path
(Path
: String_Ptr
) return String_Ptr
;
91 -- Update the specified path to replace the prefix with the location
92 -- where GNAT is installed. See the file prefix.c in GCC for details.
98 Name
: String) return File_Name_Type
;
99 -- See if the file N whose name is Name exists in directory Dir. Dir is an
100 -- index into the Lib_Search_Directories table if T = Library. Otherwise
101 -- if T = Source, Dir is an index into the Src_Search_Directories table.
102 -- Returns the File_Name_Type of the full file name if file found, or
103 -- No_File if not found.
105 function C_String_Length
(S
: Address
) return Integer;
106 -- Returns length of a C string (zero for a null address)
108 function To_Path_String_Access
109 (Path_Addr
: Address
;
110 Path_Len
: Integer) return String_Access
;
111 -- Converts a C String to an Ada String. Are we doing this to avoid withing
112 -- Interfaces.C.Strings ???
114 ------------------------------
115 -- Other Local Declarations --
116 ------------------------------
118 EOL
: constant Character := ASCII
.LF
;
119 -- End of line character
121 Number_File_Names
: Int
:= 0;
122 -- Number of file names found on command line and placed in File_Names
124 Look_In_Primary_Directory_For_Current_Main
: Boolean := False;
125 -- When this variable is True, Find_File only looks in Primary_Directory
126 -- for the Current_Main file. This variable is always set to True for the
127 -- compiler. It is also True for gnatmake, when the source name given on
128 -- the command line has directory information.
130 Current_Full_Source_Name
: File_Name_Type
:= No_File
;
131 Current_Full_Source_Stamp
: Time_Stamp_Type
:= Empty_Time_Stamp
;
132 Current_Full_Lib_Name
: File_Name_Type
:= No_File
;
133 Current_Full_Lib_Stamp
: Time_Stamp_Type
:= Empty_Time_Stamp
;
134 Current_Full_Obj_Name
: File_Name_Type
:= No_File
;
135 Current_Full_Obj_Stamp
: Time_Stamp_Type
:= Empty_Time_Stamp
;
136 -- Respectively full name (with directory info) and time stamp of the
137 -- latest source, library and object files opened by Read_Source_File and
138 -- Read_Library_Info.
144 Primary_Directory
: constant := 0;
145 -- This is index in the tables created below for the first directory to
146 -- search in for source or library information files. This is the directory
147 -- containing the latest main input file (a source file for the compiler or
148 -- a library file for the binder).
150 package Src_Search_Directories
is new Table
.Table
(
151 Table_Component_Type
=> String_Ptr
,
152 Table_Index_Type
=> Integer,
153 Table_Low_Bound
=> Primary_Directory
,
155 Table_Increment
=> 100,
156 Table_Name
=> "Osint.Src_Search_Directories");
157 -- Table of names of directories in which to search for source (Compiler)
158 -- files. This table is filled in the order in which the directories are
159 -- to be searched, and then used in that order.
161 package Lib_Search_Directories
is new Table
.Table
(
162 Table_Component_Type
=> String_Ptr
,
163 Table_Index_Type
=> Integer,
164 Table_Low_Bound
=> Primary_Directory
,
166 Table_Increment
=> 100,
167 Table_Name
=> "Osint.Lib_Search_Directories");
168 -- Table of names of directories in which to search for library (Binder)
169 -- files. This table is filled in the order in which the directories are
170 -- to be searched and then used in that order. The reason for having two
171 -- distinct tables is that we need them both in gnatmake.
173 ---------------------
174 -- File Hash Table --
175 ---------------------
177 -- The file hash table is provided to free the programmer from any
178 -- efficiency concern when retrieving full file names or time stamps of
179 -- source files. If the programmer calls Source_File_Data (Cache => True)
180 -- he is guaranteed that the price to retrieve the full name (i.e. with
181 -- directory info) or time stamp of the file will be payed only once, the
182 -- first time the full name is actually searched (or the first time the
183 -- time stamp is actually retrieved). This is achieved by employing a hash
184 -- table that stores as a key the File_Name_Type of the file and associates
185 -- to that File_Name_Type the full file name and time stamp of the file.
187 File_Cache_Enabled
: Boolean := False;
188 -- Set to true if you want the enable the file data caching mechanism
190 type File_Hash_Num
is range 0 .. 1020;
192 function File_Hash
(F
: File_Name_Type
) return File_Hash_Num
;
193 -- Compute hash index for use by Simple_HTable
195 package File_Name_Hash_Table
is new GNAT
.HTable
.Simple_HTable
(
196 Header_Num
=> File_Hash_Num
,
197 Element
=> File_Name_Type
,
198 No_Element
=> No_File
,
199 Key
=> File_Name_Type
,
203 package File_Stamp_Hash_Table
is new GNAT
.HTable
.Simple_HTable
(
204 Header_Num
=> File_Hash_Num
,
205 Element
=> Time_Stamp_Type
,
206 No_Element
=> Empty_Time_Stamp
,
207 Key
=> File_Name_Type
,
211 function Smart_Find_File
213 T
: File_Type
) return File_Name_Type
;
214 -- Exactly like Find_File except that if File_Cache_Enabled is True this
215 -- routine looks first in the hash table to see if the full name of the
216 -- file is already available.
218 function Smart_File_Stamp
220 T
: File_Type
) return Time_Stamp_Type
;
221 -- Takes the same parameter as the routine above (N is a file name without
222 -- any prefix directory information) and behaves like File_Stamp except
223 -- that if File_Cache_Enabled is True this routine looks first in the hash
224 -- table to see if the file stamp of the file is already available.
226 -----------------------------
227 -- Add_Default_Search_Dirs --
228 -----------------------------
230 procedure Add_Default_Search_Dirs
is
231 Search_Dir
: String_Access
;
232 Search_Path
: String_Access
;
233 Path_File_Name
: String_Access
;
235 procedure Add_Search_Dir
236 (Search_Dir
: String;
237 Additional_Source_Dir
: Boolean);
238 procedure Add_Search_Dir
239 (Search_Dir
: String_Access
;
240 Additional_Source_Dir
: Boolean);
241 -- Add a source search dir or a library search dir, depending on the
242 -- value of Additional_Source_Dir.
244 procedure Get_Dirs_From_File
(Additional_Source_Dir
: Boolean);
245 -- Open a path file and read the directory to search, one per line
247 function Get_Libraries_From_Registry
return String_Ptr
;
248 -- On Windows systems, get the list of installed standard libraries
249 -- from the registry key:
251 -- HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\
252 -- GNAT\Standard Libraries
253 -- Return an empty string on other systems.
255 -- Note that this is an undocumented legacy feature, and that it
256 -- works only when using the default runtime library (i.e. no --RTS=
257 -- command line switch).
263 procedure Add_Search_Dir
264 (Search_Dir
: String;
265 Additional_Source_Dir
: Boolean)
268 if Additional_Source_Dir
then
269 Add_Src_Search_Dir
(Search_Dir
);
271 Add_Lib_Search_Dir
(Search_Dir
);
275 procedure Add_Search_Dir
276 (Search_Dir
: String_Access
;
277 Additional_Source_Dir
: Boolean)
280 if Additional_Source_Dir
then
281 Add_Src_Search_Dir
(Search_Dir
.all);
283 Add_Lib_Search_Dir
(Search_Dir
.all);
287 ------------------------
288 -- Get_Dirs_From_File --
289 ------------------------
291 procedure Get_Dirs_From_File
(Additional_Source_Dir
: Boolean) is
292 File_FD
: File_Descriptor
;
293 Buffer
: constant String := Path_File_Name
.all & ASCII
.NUL
;
295 Actual_Len
: Natural;
302 pragma Warnings
(Off
, Status
);
303 -- For the call to Close
306 File_FD
:= Open_Read
(Buffer
'Address, Binary
);
308 -- If we cannot open the file, we ignore it, we don't fail
310 if File_FD
= Invalid_FD
then
314 Len
:= Integer (File_Length
(File_FD
));
316 S
:= new String (1 .. Len
);
318 -- Read the file. Note that the loop is not necessary since the
319 -- whole file is read at once except on VMS.
323 while Curr
<= Len
and then Actual_Len
/= 0 loop
324 Actual_Len
:= Read
(File_FD
, S
(Curr
)'Address, Len
);
325 Curr
:= Curr
+ Actual_Len
;
328 -- We are done with the file, so we close it (ignore any error on
329 -- the close, since we have successfully read the file).
331 Close
(File_FD
, Status
);
333 -- Now, we read line by line
337 while Curr
< Len
loop
340 if Ch
= ASCII
.CR
or else Ch
= ASCII
.LF
341 or else Ch
= ASCII
.FF
or else Ch
= ASCII
.VT
343 if First
<= Curr
then
344 Add_Search_Dir
(S
(First
.. Curr
), Additional_Source_Dir
);
353 -- Last line is a special case, if the file does not end with
354 -- an end of line mark.
356 if First
<= S
'Last then
357 Add_Search_Dir
(S
(First
.. S
'Last), Additional_Source_Dir
);
359 end Get_Dirs_From_File
;
361 ---------------------------------
362 -- Get_Libraries_From_Registry --
363 ---------------------------------
365 function Get_Libraries_From_Registry
return String_Ptr
is
366 function C_Get_Libraries_From_Registry
return Address
;
367 pragma Import
(C
, C_Get_Libraries_From_Registry
,
368 "__gnat_get_libraries_from_registry");
370 function Strlen
(Str
: Address
) return Integer;
371 pragma Import
(C
, Strlen
, "strlen");
373 procedure Strncpy
(X
: Address
; Y
: Address
; Length
: Integer);
374 pragma Import
(C
, Strncpy
, "strncpy");
376 Result_Ptr
: Address
;
377 Result_Length
: Integer;
378 Out_String
: String_Ptr
;
381 Result_Ptr
:= C_Get_Libraries_From_Registry
;
382 Result_Length
:= Strlen
(Result_Ptr
);
384 Out_String
:= new String (1 .. Result_Length
);
385 Strncpy
(Out_String
.all'Address, Result_Ptr
, Result_Length
);
387 end Get_Libraries_From_Registry
;
389 -- Start of processing for Add_Default_Search_Dirs
392 -- After the locations specified on the command line, the next places
393 -- to look for files are the directories specified by the appropriate
394 -- environment variable. Get this value, extract the directory names
395 -- and store in the tables.
397 -- Check for eventual project path file env vars
399 Path_File_Name
:= Getenv
(Project_Include_Path_File
);
401 if Path_File_Name
'Length > 0 then
402 Get_Dirs_From_File
(Additional_Source_Dir
=> True);
405 Path_File_Name
:= Getenv
(Project_Objects_Path_File
);
407 if Path_File_Name
'Length > 0 then
408 Get_Dirs_From_File
(Additional_Source_Dir
=> False);
411 -- On VMS, don't expand the logical name (e.g. environment variable),
412 -- just put it into Unix (e.g. canonical) format. System services
413 -- will handle the expansion as part of the file processing.
415 for Additional_Source_Dir
in False .. True loop
416 if Additional_Source_Dir
then
417 Search_Path
:= Getenv
(Ada_Include_Path
);
419 if Search_Path
'Length > 0 then
420 if Hostparm
.OpenVMS
then
421 Search_Path
:= To_Canonical_Path_Spec
("ADA_INCLUDE_PATH:");
423 Search_Path
:= To_Canonical_Path_Spec
(Search_Path
.all);
428 Search_Path
:= Getenv
(Ada_Objects_Path
);
430 if Search_Path
'Length > 0 then
431 if Hostparm
.OpenVMS
then
432 Search_Path
:= To_Canonical_Path_Spec
("ADA_OBJECTS_PATH:");
434 Search_Path
:= To_Canonical_Path_Spec
(Search_Path
.all);
439 Get_Next_Dir_In_Path_Init
(Search_Path
);
441 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
442 exit when Search_Dir
= null;
443 Add_Search_Dir
(Search_Dir
, Additional_Source_Dir
);
447 -- For the compiler, if --RTS= was specified, add the runtime
450 if RTS_Src_Path_Name
/= null
451 and then RTS_Lib_Path_Name
/= null
453 Add_Search_Dirs
(RTS_Src_Path_Name
, Include
);
454 Add_Search_Dirs
(RTS_Lib_Path_Name
, Objects
);
457 if not Opt
.No_Stdinc
then
459 -- For WIN32 systems, look for any system libraries defined in
460 -- the registry. These are added to both source and object
463 Search_Path
:= String_Access
(Get_Libraries_From_Registry
);
465 Get_Next_Dir_In_Path_Init
(Search_Path
);
467 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
468 exit when Search_Dir
= null;
469 Add_Search_Dir
(Search_Dir
, False);
470 Add_Search_Dir
(Search_Dir
, True);
473 -- The last place to look are the defaults
476 Read_Default_Search_Dirs
477 (String_Access
(Update_Path
(Search_Dir_Prefix
)),
479 String_Access
(Update_Path
(Include_Dir_Default_Name
)));
481 Get_Next_Dir_In_Path_Init
(Search_Path
);
483 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
484 exit when Search_Dir
= null;
485 Add_Search_Dir
(Search_Dir
, True);
489 if not Opt
.No_Stdlib
and not Opt
.RTS_Switch
then
491 Read_Default_Search_Dirs
492 (String_Access
(Update_Path
(Search_Dir_Prefix
)),
494 String_Access
(Update_Path
(Object_Dir_Default_Name
)));
496 Get_Next_Dir_In_Path_Init
(Search_Path
);
498 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
499 exit when Search_Dir
= null;
500 Add_Search_Dir
(Search_Dir
, False);
504 end Add_Default_Search_Dirs
;
510 procedure Add_File
(File_Name
: String; Index
: Int
:= No_Index
) is
512 Number_File_Names
:= Number_File_Names
+ 1;
514 -- As Add_File may be called for mains specified inside a project file,
515 -- File_Names may be too short and needs to be extended.
517 if Number_File_Names
> File_Names
'Last then
518 File_Names
:= new File_Name_Array
'(File_Names.all & File_Names.all);
520 new File_Index_Array'(File_Indexes
.all & File_Indexes
.all);
523 File_Names
(Number_File_Names
) := new String'(File_Name);
524 File_Indexes (Number_File_Names) := Index;
527 ------------------------
528 -- Add_Lib_Search_Dir --
529 ------------------------
531 procedure Add_Lib_Search_Dir (Dir : String) is
533 if Dir'Length = 0 then
534 Fail ("missing library directory name");
537 Lib_Search_Directories.Increment_Last;
538 Lib_Search_Directories.Table (Lib_Search_Directories.Last) :=
539 Normalize_Directory_Name (Dir);
540 end Add_Lib_Search_Dir;
542 ---------------------
543 -- Add_Search_Dirs --
544 ---------------------
546 procedure Add_Search_Dirs
547 (Search_Path : String_Ptr;
548 Path_Type : Search_File_Type)
550 Current_Search_Path : String_Access;
553 Get_Next_Dir_In_Path_Init (String_Access (Search_Path));
555 Current_Search_Path :=
556 Get_Next_Dir_In_Path (String_Access (Search_Path));
557 exit when Current_Search_Path = null;
559 if Path_Type = Include then
560 Add_Src_Search_Dir (Current_Search_Path.all);
562 Add_Lib_Search_Dir (Current_Search_Path.all);
567 ------------------------
568 -- Add_Src_Search_Dir --
569 ------------------------
571 procedure Add_Src_Search_Dir (Dir : String) is
573 if Dir'Length = 0 then
574 Fail ("missing source directory name");
577 Src_Search_Directories.Increment_Last;
578 Src_Search_Directories.Table (Src_Search_Directories.Last) :=
579 Normalize_Directory_Name (Dir);
580 end Add_Src_Search_Dir;
582 --------------------------------
583 -- Append_Suffix_To_File_Name --
584 --------------------------------
586 function Append_Suffix_To_File_Name
587 (Name : File_Name_Type;
588 Suffix : String) return File_Name_Type
591 Get_Name_String (Name);
592 Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
593 Name_Len := Name_Len + Suffix'Length;
595 end Append_Suffix_To_File_Name;
597 ---------------------
598 -- C_String_Length --
599 ---------------------
601 function C_String_Length (S : Address) return Integer is
602 function Strlen (S : Address) return Integer;
603 pragma Import (C, Strlen, "strlen");
605 if S = Null_Address then
612 ------------------------------
613 -- Canonical_Case_File_Name --
614 ------------------------------
616 -- For now, we only deal with the case of a-z. Eventually we should
617 -- worry about other Latin-1 letters on systems that support this ???
619 procedure Canonical_Case_File_Name (S : in out String) is
621 if not File_Names_Case_Sensitive then
622 for J in S'Range loop
623 if S (J) in 'A
' .. 'Z
' then
624 S (J) := Character'Val (
625 Character'Pos (S (J)) +
626 Character'Pos ('a
') -
627 Character'Pos ('A
'));
631 end Canonical_Case_File_Name;
633 ---------------------------
634 -- Create_File_And_Check --
635 ---------------------------
637 procedure Create_File_And_Check
638 (Fdesc : out File_Descriptor;
642 Output_File_Name := Name_Enter;
643 Fdesc := Create_File (Name_Buffer'Address, Fmode);
645 if Fdesc = Invalid_FD then
646 Fail ("Cannot create: ", Name_Buffer (1 .. Name_Len));
648 end Create_File_And_Check;
650 ------------------------
651 -- Current_File_Index --
652 ------------------------
654 function Current_File_Index return Int is
656 return File_Indexes (Current_File_Name_Index);
657 end Current_File_Index;
659 --------------------------------
660 -- Current_Library_File_Stamp --
661 --------------------------------
663 function Current_Library_File_Stamp return Time_Stamp_Type is
665 return Current_Full_Lib_Stamp;
666 end Current_Library_File_Stamp;
668 -------------------------------
669 -- Current_Object_File_Stamp --
670 -------------------------------
672 function Current_Object_File_Stamp return Time_Stamp_Type is
674 return Current_Full_Obj_Stamp;
675 end Current_Object_File_Stamp;
677 -------------------------------
678 -- Current_Source_File_Stamp --
679 -------------------------------
681 function Current_Source_File_Stamp return Time_Stamp_Type is
683 return Current_Full_Source_Stamp;
684 end Current_Source_File_Stamp;
686 ----------------------------
687 -- Dir_In_Obj_Search_Path --
688 ----------------------------
690 function Dir_In_Obj_Search_Path (Position : Natural) return String_Ptr is
692 if Opt.Look_In_Primary_Dir then
694 Lib_Search_Directories.Table (Primary_Directory + Position - 1);
696 return Lib_Search_Directories.Table (Primary_Directory + Position);
698 end Dir_In_Obj_Search_Path;
700 ----------------------------
701 -- Dir_In_Src_Search_Path --
702 ----------------------------
704 function Dir_In_Src_Search_Path (Position : Natural) return String_Ptr is
706 if Opt.Look_In_Primary_Dir then
708 Src_Search_Directories.Table (Primary_Directory + Position - 1);
710 return Src_Search_Directories.Table (Primary_Directory + Position);
712 end Dir_In_Src_Search_Path;
714 ---------------------
715 -- Executable_Name --
716 ---------------------
718 function Executable_Name (Name : File_Name_Type) return File_Name_Type is
719 Exec_Suffix : String_Access;
722 if Name = No_File then
726 if Executable_Extension_On_Target = No_Name then
727 Exec_Suffix := Get_Target_Executable_Suffix;
729 Get_Name_String (Executable_Extension_On_Target);
730 Exec_Suffix := new String'(Name_Buffer
(1 .. Name_Len
));
733 Get_Name_String
(Name
);
735 if Exec_Suffix
'Length /= 0 then
737 Buffer
: String := Name_Buffer
(1 .. Name_Len
);
740 -- Get the file name in canonical case to accept as is names
741 -- ending with ".EXE" on VMS and Windows.
743 Canonical_Case_File_Name
(Buffer
);
745 -- If Executable does not end with the executable suffix, add it
747 if Buffer
'Length <= Exec_Suffix
'Length
749 Buffer
(Buffer
'Last - Exec_Suffix
'Length + 1 .. Buffer
'Last)
752 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ Exec_Suffix
'Length) :=
754 Name_Len
:= Name_Len
+ Exec_Suffix
'Length;
765 function Executable_Name
(Name
: String) return String is
766 Exec_Suffix
: String_Access
;
767 Canonical_Name
: String := Name
;
770 if Executable_Extension_On_Target
= No_Name
then
771 Exec_Suffix
:= Get_Target_Executable_Suffix
;
773 Get_Name_String
(Executable_Extension_On_Target
);
774 Exec_Suffix
:= new String'(Name_Buffer (1 .. Name_Len));
778 Suffix : constant String := Exec_Suffix.all;
782 Canonical_Case_File_Name (Canonical_Name);
784 if Suffix'Length /= 0
786 (Canonical_Name'Length <= Suffix'Length
787 or else Canonical_Name (Canonical_Name'Last - Suffix'Length + 1
788 .. Canonical_Name'Last) /= Suffix)
791 Result : String (1 .. Name'Length + Suffix'Length);
793 Result (1 .. Name'Length) := Name;
794 Result (Name'Length + 1 .. Result'Last) := Suffix;
803 -----------------------
804 -- Executable_Prefix --
805 -----------------------
807 function Executable_Prefix return String_Ptr is
809 function Get_Install_Dir (Exec : String) return String_Ptr;
810 -- S is the executable name preceded by the absolute or relative
811 -- path, e.g. "c:\usr\bin\gcc.exe" or "..\bin\gcc".
813 ---------------------
814 -- Get_Install_Dir --
815 ---------------------
817 function Get_Install_Dir (Exec : String) return String_Ptr is
818 Full_Path : constant String := Normalize_Pathname (Exec);
819 -- Use the full path, so that we find "lib" or "bin", even when
820 -- the tool has been invoked with a relative path, as in
821 -- "./gnatls -v" invoked in the GNAT bin directory.
824 for J in reverse Full_Path'Range loop
825 if Is_Directory_Separator (Full_Path (J)) then
826 if J < Full_Path'Last - 5 then
827 if (To_Lower (Full_Path (J + 1)) = 'l
'
828 and then To_Lower (Full_Path (J + 2)) = 'i
'
829 and then To_Lower (Full_Path (J + 3)) = 'b
')
831 (To_Lower (Full_Path (J + 1)) = 'b
'
832 and then To_Lower (Full_Path (J + 2)) = 'i
'
833 and then To_Lower (Full_Path (J + 3)) = 'n
')
835 return new String'(Full_Path
(Full_Path
'First .. J
));
841 return new String'("");
844 -- Start of processing for Executable_Prefix
847 if Exec_Name = null then
848 Exec_Name := new String (1 .. Len_Arg (0));
849 Osint.Fill_Arg (Exec_Name (1)'Address, 0);
852 -- First determine if a path prefix was placed in front of the
855 for J in reverse Exec_Name'Range loop
856 if Is_Directory_Separator (Exec_Name (J)) then
857 return Get_Install_Dir (Exec_Name.all);
861 -- If we come here, the user has typed the executable name with no
864 return Get_Install_Dir (Locate_Exec_On_Path (Exec_Name.all).all);
865 end Executable_Prefix;
871 procedure Exit_Program (Exit_Code : Exit_Code_Type) is
873 -- The program will exit with the following status:
875 -- 0 if the object file has been generated (with or without warnings)
876 -- 1 if recompilation was not needed (smart recompilation)
877 -- 2 if gnat1 has been killed by a signal (detected by GCC)
878 -- 4 for a fatal error
879 -- 5 if there were errors
880 -- 6 if no code has been generated (spec)
882 -- Note that exit code 3 is not used and must not be used as this is
883 -- the code returned by a program aborted via C abort() routine on
884 -- Windows. GCC checks for that case and thinks that the child process
885 -- has been aborted. This code (exit code 3) used to be the code used
886 -- for E_No_Code, but E_No_Code was changed to 6 for this reason.
889 when E_Success => OS_Exit (0);
890 when E_Warnings => OS_Exit (0);
891 when E_No_Compile => OS_Exit (1);
892 when E_Fatal => OS_Exit (4);
893 when E_Errors => OS_Exit (5);
894 when E_No_Code => OS_Exit (6);
895 when E_Abort => OS_Abort;
903 procedure Fail (S1 : String; S2 : String := ""; S3 : String := "") is
905 -- We use Output in case there is a special output set up.
906 -- In this case Set_Standard_Error will have no immediate effect.
909 Osint.Write_Program_Name;
916 Exit_Program (E_Fatal);
923 function File_Hash (F : File_Name_Type) return File_Hash_Num is
925 return File_Hash_Num (Int (F) rem File_Hash_Num'Range_Length);
932 function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type is
934 if Name = No_File then
935 return Empty_Time_Stamp;
938 Get_Name_String (Name);
940 if not Is_Regular_File (Name_Buffer (1 .. Name_Len)) then
941 return Empty_Time_Stamp;
943 Name_Buffer (Name_Len + 1) := ASCII.NUL;
944 return OS_Time_To_GNAT_Time (File_Time_Stamp (Name_Buffer));
948 function File_Stamp (Name : Path_Name_Type) return Time_Stamp_Type is
950 return File_Stamp (File_Name_Type (Name));
959 T : File_Type) return File_Name_Type
965 File_Name : String renames Name_Buffer (1 .. Name_Len);
966 File : File_Name_Type := No_File;
970 -- If we are looking for a config file, look only in the current
971 -- directory, i.e. return input argument unchanged. Also look
972 -- only in the current directory if we are looking for a .dg
973 -- file (happens in -gnatD mode).
976 or else (Debug_Generated_Code
977 and then Name_Len > 3
979 (Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg"
981 (Hostparm.OpenVMS and then
982 Name_Buffer (Name_Len - 2 .. Name_Len) = "_dg")))
986 -- If we are trying to find the current main file just look in the
987 -- directory where the user said it was.
989 elsif Look_In_Primary_Directory_For_Current_Main
990 and then Current_Main = N
992 return Locate_File (N, T, Primary_Directory, File_Name);
994 -- Otherwise do standard search for source file
997 -- Check the mapping of this file name
999 File := Mapped_Path_Name (N);
1001 -- If the file name is mapped to a path name, return the
1002 -- corresponding path name
1004 if File /= No_File then
1006 -- For locally removed file, Error_Name is returned; then
1007 -- return No_File, indicating the file is not a source.
1009 if File = Error_File_Name then
1017 -- First place to look is in the primary directory (i.e. the same
1018 -- directory as the source) unless this has been disabled with -I-
1020 if Opt.Look_In_Primary_Dir then
1021 File := Locate_File (N, T, Primary_Directory, File_Name);
1023 if File /= No_File then
1028 -- Finally look in directories specified with switches -I/-aI/-aO
1031 Last_Dir := Lib_Search_Directories.Last;
1033 Last_Dir := Src_Search_Directories.Last;
1036 for D in Primary_Directory + 1 .. Last_Dir loop
1037 File := Locate_File (N, T, D, File_Name);
1039 if File /= No_File then
1049 -----------------------
1050 -- Find_Program_Name --
1051 -----------------------
1053 procedure Find_Program_Name is
1054 Command_Name : String (1 .. Len_Arg (0));
1055 Cindex1 : Integer := Command_Name'First;
1056 Cindex2 : Integer := Command_Name'Last;
1059 Fill_Arg (Command_Name'Address, 0);
1061 if Command_Name = "" then
1066 -- The program name might be specified by a full path name. However,
1067 -- we don't want to print that all out in an error message, so the
1068 -- path might need to be stripped away.
1070 for J in reverse Cindex1 .. Cindex2 loop
1071 if Is_Directory_Separator (Command_Name (J)) then
1077 -- Command_Name(Cindex1 .. Cindex2) is now the equivalent of the
1078 -- POSIX command "basename argv[0]"
1080 -- Strip off any versioning information such as found on VMS.
1081 -- This would take the form of TOOL.exe followed by a ";" or "."
1082 -- and a sequence of one or more numbers.
1084 if Command_Name (Cindex2) in '0' .. '9' then
1085 for J in reverse Cindex1 .. Cindex2 loop
1086 if Command_Name (J) = '.' or Command_Name (J) = ';' then
1091 exit when Command_Name (J) not in '0' .. '9';
1095 -- Strip off any executable extension (usually nothing or .exe)
1096 -- but formally reported by autoconf in the variable EXEEXT
1098 if Cindex2 - Cindex1 >= 4 then
1099 if To_Lower (Command_Name (Cindex2 - 3)) = '.'
1100 and then To_Lower (Command_Name (Cindex2 - 2)) = 'e
'
1101 and then To_Lower (Command_Name (Cindex2 - 1)) = 'x
'
1102 and then To_Lower (Command_Name (Cindex2)) = 'e
'
1104 Cindex2 := Cindex2 - 4;
1108 Name_Len := Cindex2 - Cindex1 + 1;
1109 Name_Buffer (1 .. Name_Len) := Command_Name (Cindex1 .. Cindex2);
1110 end Find_Program_Name;
1112 ------------------------
1113 -- Full_Lib_File_Name --
1114 ------------------------
1116 function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type is
1118 return Find_File (N, Library);
1119 end Full_Lib_File_Name;
1121 ----------------------------
1122 -- Full_Library_Info_Name --
1123 ----------------------------
1125 function Full_Library_Info_Name return File_Name_Type is
1127 return Current_Full_Lib_Name;
1128 end Full_Library_Info_Name;
1130 ---------------------------
1131 -- Full_Object_File_Name --
1132 ---------------------------
1134 function Full_Object_File_Name return File_Name_Type is
1136 return Current_Full_Obj_Name;
1137 end Full_Object_File_Name;
1139 ----------------------
1140 -- Full_Source_Name --
1141 ----------------------
1143 function Full_Source_Name return File_Name_Type is
1145 return Current_Full_Source_Name;
1146 end Full_Source_Name;
1148 ----------------------
1149 -- Full_Source_Name --
1150 ----------------------
1152 function Full_Source_Name (N : File_Name_Type) return File_Name_Type is
1154 return Smart_Find_File (N, Source);
1155 end Full_Source_Name;
1161 function Get_Directory (Name : File_Name_Type) return File_Name_Type is
1163 Get_Name_String (Name);
1165 for J in reverse 1 .. Name_Len loop
1166 if Is_Directory_Separator (Name_Buffer (J)) then
1172 Name_Len := Hostparm.Normalized_CWD'Length;
1173 Name_Buffer (1 .. Name_Len) := Hostparm.Normalized_CWD;
1177 --------------------------
1178 -- Get_Next_Dir_In_Path --
1179 --------------------------
1181 Search_Path_Pos : Integer;
1182 -- Keeps track of current position in search path. Initialized by the
1183 -- call to Get_Next_Dir_In_Path_Init, updated by Get_Next_Dir_In_Path.
1185 function Get_Next_Dir_In_Path
1186 (Search_Path : String_Access) return String_Access
1188 Lower_Bound : Positive := Search_Path_Pos;
1189 Upper_Bound : Positive;
1193 while Lower_Bound <= Search_Path'Last
1194 and then Search_Path.all (Lower_Bound) = Path_Separator
1196 Lower_Bound := Lower_Bound + 1;
1199 exit when Lower_Bound > Search_Path'Last;
1201 Upper_Bound := Lower_Bound;
1202 while Upper_Bound <= Search_Path'Last
1203 and then Search_Path.all (Upper_Bound) /= Path_Separator
1205 Upper_Bound := Upper_Bound + 1;
1208 Search_Path_Pos := Upper_Bound;
1209 return new String'(Search_Path
.all (Lower_Bound
.. Upper_Bound
- 1));
1213 end Get_Next_Dir_In_Path
;
1215 -------------------------------
1216 -- Get_Next_Dir_In_Path_Init --
1217 -------------------------------
1219 procedure Get_Next_Dir_In_Path_Init
(Search_Path
: String_Access
) is
1221 Search_Path_Pos
:= Search_Path
'First;
1222 end Get_Next_Dir_In_Path_Init
;
1224 --------------------------------------
1225 -- Get_Primary_Src_Search_Directory --
1226 --------------------------------------
1228 function Get_Primary_Src_Search_Directory
return String_Ptr
is
1230 return Src_Search_Directories
.Table
(Primary_Directory
);
1231 end Get_Primary_Src_Search_Directory
;
1233 ------------------------
1234 -- Get_RTS_Search_Dir --
1235 ------------------------
1237 function Get_RTS_Search_Dir
1238 (Search_Dir
: String;
1239 File_Type
: Search_File_Type
) return String_Ptr
1241 procedure Get_Current_Dir
1242 (Dir
: System
.Address
;
1243 Length
: System
.Address
);
1244 pragma Import
(C
, Get_Current_Dir
, "__gnat_get_current_dir");
1247 pragma Import
(C
, Max_Path
, "__gnat_max_path_len");
1248 -- Maximum length of a path name
1250 Current_Dir
: String_Ptr
;
1251 Default_Search_Dir
: String_Access
;
1252 Default_Suffix_Dir
: String_Access
;
1253 Local_Search_Dir
: String_Access
;
1254 Norm_Search_Dir
: String_Access
;
1255 Result_Search_Dir
: String_Access
;
1256 Search_File
: String_Access
;
1257 Temp_String
: String_Ptr
;
1260 -- Add a directory separator at the end of the directory if necessary
1261 -- so that we can directly append a file to the directory
1263 if Search_Dir
(Search_Dir
'Last) /= Directory_Separator
then
1265 new String'(Search_Dir & String'(1 => Directory_Separator
));
1267 Local_Search_Dir
:= new String'(Search_Dir);
1270 if File_Type = Include then
1271 Search_File := Include_Search_File;
1272 Default_Suffix_Dir := new String'("adainclude");
1274 Search_File
:= Objects_Search_File
;
1275 Default_Suffix_Dir
:= new String'("adalib");
1278 Norm_Search_Dir := To_Canonical_Path_Spec (Local_Search_Dir.all);
1280 if Is_Absolute_Path (Norm_Search_Dir.all) then
1282 -- We first verify if there is a directory Include_Search_Dir
1283 -- containing default search directories
1285 Result_Search_Dir :=
1286 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1287 Default_Search_Dir :=
1288 new String'(Norm_Search_Dir
.all & Default_Suffix_Dir
.all);
1289 Free
(Norm_Search_Dir
);
1291 if Result_Search_Dir
/= null then
1292 return String_Ptr
(Result_Search_Dir
);
1293 elsif Is_Directory
(Default_Search_Dir
.all) then
1294 return String_Ptr
(Default_Search_Dir
);
1299 -- Search in the current directory
1302 -- Get the current directory
1305 Buffer
: String (1 .. Max_Path
+ 2);
1306 Path_Len
: Natural := Max_Path
;
1309 Get_Current_Dir
(Buffer
'Address, Path_Len
'Address);
1311 if Buffer
(Path_Len
) /= Directory_Separator
then
1312 Path_Len
:= Path_Len
+ 1;
1313 Buffer
(Path_Len
) := Directory_Separator
;
1316 Current_Dir
:= new String'(Buffer (1 .. Path_Len));
1320 new String'(Current_Dir
.all & Local_Search_Dir
.all);
1322 Result_Search_Dir
:=
1323 Read_Default_Search_Dirs
(Norm_Search_Dir
, Search_File
, null);
1325 Default_Search_Dir
:=
1326 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1328 Free (Norm_Search_Dir);
1330 if Result_Search_Dir /= null then
1331 return String_Ptr (Result_Search_Dir);
1333 elsif Is_Directory (Default_Search_Dir.all) then
1334 return String_Ptr (Default_Search_Dir);
1337 -- Search in Search_Dir_Prefix/Search_Dir
1341 (Update_Path
(Search_Dir_Prefix
).all & Local_Search_Dir
.all);
1343 Result_Search_Dir
:=
1344 Read_Default_Search_Dirs
(Norm_Search_Dir
, Search_File
, null);
1346 Default_Search_Dir
:=
1347 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1349 Free (Norm_Search_Dir);
1351 if Result_Search_Dir /= null then
1352 return String_Ptr (Result_Search_Dir);
1354 elsif Is_Directory (Default_Search_Dir.all) then
1355 return String_Ptr (Default_Search_Dir);
1358 -- We finally search in Search_Dir_Prefix/rts-Search_Dir
1361 new String'(Update_Path
(Search_Dir_Prefix
).all & "rts-");
1364 new String'(Temp_String.all & Local_Search_Dir.all);
1366 Result_Search_Dir :=
1367 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1369 Default_Search_Dir :=
1370 new String'(Norm_Search_Dir
.all & Default_Suffix_Dir
.all);
1371 Free
(Norm_Search_Dir
);
1373 if Result_Search_Dir
/= null then
1374 return String_Ptr
(Result_Search_Dir
);
1376 elsif Is_Directory
(Default_Search_Dir
.all) then
1377 return String_Ptr
(Default_Search_Dir
);
1385 end Get_RTS_Search_Dir
;
1387 --------------------------------
1388 -- Include_Dir_Default_Prefix --
1389 --------------------------------
1391 function Include_Dir_Default_Prefix
return String is
1392 Include_Dir
: String_Access
:=
1393 String_Access
(Update_Path
(Include_Dir_Default_Name
));
1396 if Include_Dir
= null then
1401 Result
: constant String := Include_Dir
.all;
1407 end Include_Dir_Default_Prefix
;
1413 procedure Initialize
is
1415 Number_File_Names
:= 0;
1416 Current_File_Name_Index
:= 0;
1418 Src_Search_Directories
.Init
;
1419 Lib_Search_Directories
.Init
;
1421 -- Start off by setting all suppress options to False, these will
1422 -- be reset later (turning some on if -gnato is not specified, and
1423 -- turning all of them on if -gnatp is specified).
1425 Suppress_Options
:= (others => False);
1427 -- Reserve the first slot in the search paths table. This is the
1428 -- directory of the main source file or main library file and is filled
1429 -- in by each call to Next_Main_Source/Next_Main_Lib_File with the
1430 -- directory specified for this main source or library file. This is the
1431 -- directory which is searched first by default. This default search is
1432 -- inhibited by the option -I- for both source and library files.
1434 Src_Search_Directories
.Set_Last
(Primary_Directory
);
1435 Src_Search_Directories
.Table
(Primary_Directory
) := new String'("");
1437 Lib_Search_Directories.Set_Last (Primary_Directory);
1438 Lib_Search_Directories.Table (Primary_Directory) := new String'("");
1441 ----------------------------
1442 -- Is_Directory_Separator --
1443 ----------------------------
1445 function Is_Directory_Separator
(C
: Character) return Boolean is
1447 -- In addition to the default directory_separator allow the '/' to
1448 -- act as separator since this is allowed in MS-DOS, Windows 95/NT,
1449 -- and OS2 ports. On VMS, the situation is more complicated because
1450 -- there are two characters to check for.
1453 C
= Directory_Separator
1455 or else (Hostparm
.OpenVMS
1456 and then (C
= ']' or else C
= ':'));
1457 end Is_Directory_Separator
;
1459 -------------------------
1460 -- Is_Readonly_Library --
1461 -------------------------
1463 function Is_Readonly_Library
(File
: File_Name_Type
) return Boolean is
1465 Get_Name_String
(File
);
1467 pragma Assert
(Name_Buffer
(Name_Len
- 3 .. Name_Len
) = ".ali");
1469 return not Is_Writable_File
(Name_Buffer
(1 .. Name_Len
));
1470 end Is_Readonly_Library
;
1476 function Lib_File_Name
1477 (Source_File
: File_Name_Type
;
1478 Munit_Index
: Nat
:= 0) return File_Name_Type
1481 Get_Name_String
(Source_File
);
1483 for J
in reverse 2 .. Name_Len
loop
1484 if Name_Buffer
(J
) = '.' then
1490 if Munit_Index
/= 0 then
1491 Add_Char_To_Name_Buffer
(Multi_Unit_Index_Character
);
1492 Add_Nat_To_Name_Buffer
(Munit_Index
);
1495 Add_Char_To_Name_Buffer
('.');
1496 Add_Str_To_Name_Buffer
(ALI_Suffix
.all);
1500 ------------------------
1501 -- Library_File_Stamp --
1502 ------------------------
1504 function Library_File_Stamp
(N
: File_Name_Type
) return Time_Stamp_Type
is
1506 return File_Stamp
(Find_File
(N
, Library
));
1507 end Library_File_Stamp
;
1513 function Locate_File
1514 (N
: File_Name_Type
;
1517 Name
: String) return File_Name_Type
1519 Dir_Name
: String_Ptr
;
1522 -- If Name is already an absolute path, do not look for a directory
1524 if Is_Absolute_Path
(Name
) then
1527 elsif T
= Library
then
1528 Dir_Name
:= Lib_Search_Directories
.Table
(Dir
);
1530 else pragma Assert
(T
/= Config
);
1531 Dir_Name
:= Src_Search_Directories
.Table
(Dir
);
1535 Full_Name
: String (1 .. Dir_Name
'Length + Name
'Length);
1538 Full_Name
(1 .. Dir_Name
'Length) := Dir_Name
.all;
1539 Full_Name
(Dir_Name
'Length + 1 .. Full_Name
'Length) := Name
;
1541 if not Is_Regular_File
(Full_Name
) then
1545 -- If the file is in the current directory then return N itself
1547 if Dir_Name
'Length = 0 then
1550 Name_Len
:= Full_Name
'Length;
1551 Name_Buffer
(1 .. Name_Len
) := Full_Name
;
1558 -------------------------------
1559 -- Matching_Full_Source_Name --
1560 -------------------------------
1562 function Matching_Full_Source_Name
1563 (N
: File_Name_Type
;
1564 T
: Time_Stamp_Type
) return File_Name_Type
1567 Get_Name_String
(N
);
1570 File_Name
: constant String := Name_Buffer
(1 .. Name_Len
);
1571 File
: File_Name_Type
:= No_File
;
1575 if Opt
.Look_In_Primary_Dir
then
1576 File
:= Locate_File
(N
, Source
, Primary_Directory
, File_Name
);
1578 if File
/= No_File
and then T
= File_Stamp
(N
) then
1583 Last_Dir
:= Src_Search_Directories
.Last
;
1585 for D
in Primary_Directory
+ 1 .. Last_Dir
loop
1586 File
:= Locate_File
(N
, Source
, D
, File_Name
);
1588 if File
/= No_File
and then T
= File_Stamp
(File
) then
1595 end Matching_Full_Source_Name
;
1601 function More_Files
return Boolean is
1603 return (Current_File_Name_Index
< Number_File_Names
);
1606 -------------------------------
1607 -- Nb_Dir_In_Obj_Search_Path --
1608 -------------------------------
1610 function Nb_Dir_In_Obj_Search_Path
return Natural is
1612 if Opt
.Look_In_Primary_Dir
then
1613 return Lib_Search_Directories
.Last
- Primary_Directory
+ 1;
1615 return Lib_Search_Directories
.Last
- Primary_Directory
;
1617 end Nb_Dir_In_Obj_Search_Path
;
1619 -------------------------------
1620 -- Nb_Dir_In_Src_Search_Path --
1621 -------------------------------
1623 function Nb_Dir_In_Src_Search_Path
return Natural is
1625 if Opt
.Look_In_Primary_Dir
then
1626 return Src_Search_Directories
.Last
- Primary_Directory
+ 1;
1628 return Src_Search_Directories
.Last
- Primary_Directory
;
1630 end Nb_Dir_In_Src_Search_Path
;
1632 --------------------
1633 -- Next_Main_File --
1634 --------------------
1636 function Next_Main_File
return File_Name_Type
is
1637 File_Name
: String_Ptr
;
1638 Dir_Name
: String_Ptr
;
1642 pragma Assert
(More_Files
);
1644 Current_File_Name_Index
:= Current_File_Name_Index
+ 1;
1646 -- Get the file and directory name
1648 File_Name
:= File_Names
(Current_File_Name_Index
);
1649 Fptr
:= File_Name
'First;
1651 for J
in reverse File_Name
'Range loop
1652 if File_Name
(J
) = Directory_Separator
1653 or else File_Name
(J
) = '/'
1655 if J
= File_Name
'Last then
1656 Fail
("File name missing");
1664 -- Save name of directory in which main unit resides for use in
1665 -- locating other units
1667 Dir_Name
:= new String'(File_Name (File_Name'First .. Fptr - 1));
1669 case Running_Program is
1672 Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
1673 Look_In_Primary_Directory_For_Current_Main := True;
1676 Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
1678 if Fptr > File_Name'First then
1679 Look_In_Primary_Directory_For_Current_Main := True;
1682 when Binder | Gnatls =>
1683 Dir_Name := Normalize_Directory_Name (Dir_Name.all);
1684 Lib_Search_Directories.Table (Primary_Directory) := Dir_Name;
1690 Name_Len := File_Name'Last - Fptr + 1;
1691 Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last);
1692 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
1693 Current_Main := Name_Find;
1695 -- In the gnatmake case, the main file may have not have the
1696 -- extension. Try ".adb" first then ".ads"
1698 if Running_Program = Make then
1700 Orig_Main : constant File_Name_Type := Current_Main;
1703 if Strip_Suffix (Orig_Main) = Orig_Main then
1705 Append_Suffix_To_File_Name (Orig_Main, ".adb");
1707 if Full_Source_Name (Current_Main) = No_File then
1709 Append_Suffix_To_File_Name (Orig_Main, ".ads");
1711 if Full_Source_Name (Current_Main) = No_File then
1712 Current_Main := Orig_Main;
1719 return Current_Main;
1722 ------------------------------
1723 -- Normalize_Directory_Name --
1724 ------------------------------
1726 function Normalize_Directory_Name (Directory : String) return String_Ptr is
1728 function Is_Quoted (Path : String) return Boolean;
1729 pragma Inline (Is_Quoted);
1730 -- Returns true if Path is quoted (either double or single quotes)
1736 function Is_Quoted (Path : String) return Boolean is
1737 First : constant Character := Path (Path'First);
1738 Last : constant Character := Path (Path'Last);
1741 if (First = ''' and then Last = ''')
1743 (First = '"' and then Last = '"')
1751 Result : String_Ptr;
1753 -- Start of processing for Normalize_Directory_Name
1756 if Directory'Length = 0 then
1757 Result := new String'(Hostparm
.Normalized_CWD
);
1759 elsif Is_Directory_Separator
(Directory
(Directory
'Last)) then
1760 Result
:= new String'(Directory);
1762 elsif Is_Quoted (Directory) then
1764 -- This is a quoted string, it certainly means that the directory
1765 -- contains some spaces for example. We can safely remove the quotes
1766 -- here as the OS_Lib.Normalize_Arguments will be called before any
1767 -- spawn routines. This ensure that quotes will be added when needed.
1769 Result := new String (1 .. Directory'Length - 1);
1770 Result (1 .. Directory'Length - 2) :=
1771 Directory (Directory'First + 1 .. Directory'Last - 1);
1772 Result (Result'Last) := Directory_Separator;
1775 Result := new String (1 .. Directory'Length + 1);
1776 Result (1 .. Directory'Length) := Directory;
1777 Result (Directory'Length + 1) := Directory_Separator;
1781 end Normalize_Directory_Name;
1783 ---------------------
1784 -- Number_Of_Files --
1785 ---------------------
1787 function Number_Of_Files return Int is
1789 return Number_File_Names;
1790 end Number_Of_Files;
1792 -------------------------------
1793 -- Object_Dir_Default_Prefix --
1794 -------------------------------
1796 function Object_Dir_Default_Prefix return String is
1797 Object_Dir : String_Access :=
1798 String_Access (Update_Path (Object_Dir_Default_Name));
1801 if Object_Dir = null then
1806 Result : constant String := Object_Dir.all;
1812 end Object_Dir_Default_Prefix;
1814 ----------------------
1815 -- Object_File_Name --
1816 ----------------------
1818 function Object_File_Name (N : File_Name_Type) return File_Name_Type is
1824 Get_Name_String (N);
1825 Name_Len := Name_Len - ALI_Suffix'Length - 1;
1827 for J in Target_Object_Suffix'Range loop
1828 Name_Len := Name_Len + 1;
1829 Name_Buffer (Name_Len) := Target_Object_Suffix (J);
1833 end Object_File_Name;
1835 -------------------------------
1836 -- OS_Exit_Through_Exception --
1837 -------------------------------
1839 procedure OS_Exit_Through_Exception (Status : Integer) is
1841 Current_Exit_Status := Status;
1842 raise Types.Terminate_Program;
1843 end OS_Exit_Through_Exception;
1845 --------------------------
1846 -- OS_Time_To_GNAT_Time --
1847 --------------------------
1849 function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type is
1850 GNAT_Time : Time_Stamp_Type;
1860 GM_Split (T, Y, Mo, D, H, Mn, S);
1866 Minutes => Nat (Mn),
1871 end OS_Time_To_GNAT_Time;
1877 function Program_Name (Nam : String; Prog : String) return String_Access is
1878 End_Of_Prefix : Natural := 0;
1879 Start_Of_Prefix : Positive := 1;
1880 Start_Of_Suffix : Positive;
1883 -- GNAAMP tool names require special treatment
1885 if AAMP_On_Target then
1887 -- The name "gcc" is mapped to "gnaamp" (the compiler driver)
1890 return new String'("gnaamp");
1892 -- Tool names starting with "gnat" are mapped by substituting the
1893 -- string "gnaamp" for "gnat" (for example, "gnatpp" => "gnaamppp").
1895 elsif Nam
'Length >= 4
1896 and then Nam
(Nam
'First .. Nam
'First + 3) = "gnat"
1898 return new String'("gnaamp" & Nam (Nam'First + 4 .. Nam'Last));
1900 -- No other mapping rules, so we continue and handle any other forms
1901 -- of tool names the same as on other targets.
1908 -- Get the name of the current program being executed
1912 Start_Of_Suffix := Name_Len + 1;
1914 -- Find the target prefix if any, for the cross compilation case.
1915 -- For instance in "powerpc-elf-gcc" the target prefix is
1917 -- Ditto for suffix, e.g. in "gcc-4.1", the suffix is "-4.1"
1919 for J in reverse 1 .. Name_Len loop
1920 if Name_Buffer (J) = '/'
1921 or else Name_Buffer (J) = Directory_Separator
1922 or else Name_Buffer (J) = ':'
1924 Start_Of_Prefix := J + 1;
1929 -- Find End_Of_Prefix
1931 for J in Start_Of_Prefix .. Name_Len - Prog'Length + 1 loop
1932 if Name_Buffer (J .. J + Prog'Length - 1) = Prog then
1933 End_Of_Prefix := J - 1;
1938 if End_Of_Prefix > 1 then
1939 Start_Of_Suffix := End_Of_Prefix + Prog'Length + 1;
1942 -- Create the new program name
1945 (Name_Buffer
(Start_Of_Prefix
.. End_Of_Prefix
)
1947 & Name_Buffer
(Start_Of_Suffix
.. Name_Len
));
1950 ------------------------------
1951 -- Read_Default_Search_Dirs --
1952 ------------------------------
1954 function Read_Default_Search_Dirs
1955 (Search_Dir_Prefix
: String_Access
;
1956 Search_File
: String_Access
;
1957 Search_Dir_Default_Name
: String_Access
) return String_Access
1959 Prefix_Len
: constant Integer := Search_Dir_Prefix
.all'Length;
1960 Buffer
: String (1 .. Prefix_Len
+ Search_File
.all'Length + 1);
1961 File_FD
: File_Descriptor
;
1962 S
, S1
: String_Access
;
1965 Actual_Len
: Integer;
1968 Prev_Was_Separator
: Boolean;
1969 Nb_Relative_Dir
: Integer;
1971 function Is_Relative
(S
: String; K
: Positive) return Boolean;
1972 pragma Inline
(Is_Relative
);
1973 -- Returns True if a relative directory specification is found
1974 -- in S at position K, False otherwise.
1980 function Is_Relative
(S
: String; K
: Positive) return Boolean is
1982 return not Is_Absolute_Path
(S
(K
.. S
'Last));
1985 -- Start of processing for Read_Default_Search_Dirs
1988 -- Construct a C compatible character string buffer
1990 Buffer
(1 .. Search_Dir_Prefix
.all'Length)
1991 := Search_Dir_Prefix
.all;
1992 Buffer
(Search_Dir_Prefix
.all'Length + 1 .. Buffer
'Last - 1)
1994 Buffer
(Buffer
'Last) := ASCII
.NUL
;
1996 File_FD
:= Open_Read
(Buffer
'Address, Binary
);
1997 if File_FD
= Invalid_FD
then
1998 return Search_Dir_Default_Name
;
2001 Len
:= Integer (File_Length
(File_FD
));
2003 -- An extra character for a trailing Path_Separator is allocated
2005 S
:= new String (1 .. Len
+ 1);
2006 S
(Len
+ 1) := Path_Separator
;
2008 -- Read the file. Note that the loop is not necessary since the
2009 -- whole file is read at once except on VMS.
2013 while Actual_Len
/= 0 loop
2014 Actual_Len
:= Read
(File_FD
, S
(Curr
)'Address, Len
);
2015 Curr
:= Curr
+ Actual_Len
;
2018 -- Process the file, dealing with path separators
2020 Prev_Was_Separator
:= True;
2021 Nb_Relative_Dir
:= 0;
2022 for J
in 1 .. Len
loop
2024 -- Treat any control character as a path separator. Note that we do
2025 -- not treat space as a path separator (we used to treat space as a
2026 -- path separator in an earlier version). That way space can appear
2027 -- as a legitimate character in a path name.
2029 -- Why do we treat all control characters as path separators???
2031 if S
(J
) in ASCII
.NUL
.. ASCII
.US
then
2032 S
(J
) := Path_Separator
;
2035 -- Test for explicit path separator (or control char as above)
2037 if S
(J
) = Path_Separator
then
2038 Prev_Was_Separator
:= True;
2040 -- If not path separator, register use of relative directory
2043 if Prev_Was_Separator
and then Is_Relative
(S
.all, J
) then
2044 Nb_Relative_Dir
:= Nb_Relative_Dir
+ 1;
2047 Prev_Was_Separator
:= False;
2051 if Nb_Relative_Dir
= 0 then
2055 -- Add the Search_Dir_Prefix to all relative paths
2057 S1
:= new String (1 .. S
'Length + Nb_Relative_Dir
* Prefix_Len
);
2059 Prev_Was_Separator
:= True;
2060 for J
in 1 .. Len
+ 1 loop
2061 if S
(J
) = Path_Separator
then
2062 Prev_Was_Separator
:= True;
2065 if Prev_Was_Separator
and then Is_Relative
(S
.all, J
) then
2066 S1
(J1
.. J1
+ Prefix_Len
- 1) := Search_Dir_Prefix
.all;
2067 J1
:= J1
+ Prefix_Len
;
2070 Prev_Was_Separator
:= False;
2078 end Read_Default_Search_Dirs
;
2080 -----------------------
2081 -- Read_Library_Info --
2082 -----------------------
2084 function Read_Library_Info
2085 (Lib_File
: File_Name_Type
;
2086 Fatal_Err
: Boolean := False) return Text_Buffer_Ptr
2088 Lib_FD
: File_Descriptor
;
2089 -- The file descriptor for the current library file. A negative value
2090 -- indicates failure to open the specified source file.
2092 Text
: Text_Buffer_Ptr
;
2093 -- Allocated text buffer
2096 pragma Warnings
(Off
, Status
);
2097 -- For the calls to Close
2100 Current_Full_Lib_Name
:= Find_File
(Lib_File
, Library
);
2101 Current_Full_Obj_Name
:= Object_File_Name
(Current_Full_Lib_Name
);
2103 if Current_Full_Lib_Name
= No_File
then
2105 Fail
("Cannot find: ", Name_Buffer
(1 .. Name_Len
));
2107 Current_Full_Obj_Stamp
:= Empty_Time_Stamp
;
2112 Get_Name_String
(Current_Full_Lib_Name
);
2113 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
2115 -- Open the library FD, note that we open in binary mode, because as
2116 -- documented in the spec, the caller is expected to handle either
2117 -- DOS or Unix mode files, and there is no point in wasting time on
2118 -- text translation when it is not required.
2120 Lib_FD
:= Open_Read
(Name_Buffer
'Address, Binary
);
2122 if Lib_FD
= Invalid_FD
then
2124 Fail
("Cannot open: ", Name_Buffer
(1 .. Name_Len
));
2126 Current_Full_Obj_Stamp
:= Empty_Time_Stamp
;
2131 -- Check for object file consistency if requested
2133 if Opt
.Check_Object_Consistency
then
2134 Current_Full_Lib_Stamp
:= File_Stamp
(Current_Full_Lib_Name
);
2135 Current_Full_Obj_Stamp
:= File_Stamp
(Current_Full_Obj_Name
);
2137 if Current_Full_Obj_Stamp
(1) = ' ' then
2139 -- When the library is readonly always assume object is consistent
2141 if Is_Readonly_Library
(Current_Full_Lib_Name
) then
2142 Current_Full_Obj_Stamp
:= Current_Full_Lib_Stamp
;
2144 elsif Fatal_Err
then
2145 Get_Name_String
(Current_Full_Obj_Name
);
2146 Close
(Lib_FD
, Status
);
2148 -- No need to check the status, we fail anyway
2150 Fail
("Cannot find: ", Name_Buffer
(1 .. Name_Len
));
2153 Current_Full_Obj_Stamp
:= Empty_Time_Stamp
;
2154 Close
(Lib_FD
, Status
);
2156 -- No need to check the status, we return null anyway
2163 -- Read data from the file
2166 Len
: constant Integer := Integer (File_Length
(Lib_FD
));
2167 -- Length of source file text. If it doesn't fit in an integer
2168 -- we're probably stuck anyway (>2 gigs of source seems a lot!)
2170 Actual_Len
: Integer := 0;
2172 Lo
: constant Text_Ptr
:= 0;
2173 -- Low bound for allocated text buffer
2175 Hi
: Text_Ptr
:= Text_Ptr
(Len
);
2176 -- High bound for allocated text buffer. Note length is Len + 1
2177 -- which allows for extra EOF character at the end of the buffer.
2180 -- Allocate text buffer. Note extra character at end for EOF
2182 Text
:= new Text_Buffer
(Lo
.. Hi
);
2184 -- Some systems (e.g. VMS) have file types that require one
2185 -- read per line, so read until we get the Len bytes or until
2186 -- there are no more characters.
2190 Actual_Len
:= Read
(Lib_FD
, Text
(Hi
)'Address, Len
);
2191 Hi
:= Hi
+ Text_Ptr
(Actual_Len
);
2192 exit when Actual_Len
= Len
or Actual_Len
<= 0;
2198 -- Read is complete, close file and we are done
2200 Close
(Lib_FD
, Status
);
2201 -- The status should never be False. But, if it is, what can we do?
2202 -- So, we don't test it.
2206 end Read_Library_Info
;
2208 ----------------------
2209 -- Read_Source_File --
2210 ----------------------
2212 procedure Read_Source_File
2213 (N
: File_Name_Type
;
2215 Hi
: out Source_Ptr
;
2216 Src
: out Source_Buffer_Ptr
;
2217 T
: File_Type
:= Source
)
2219 Source_File_FD
: File_Descriptor
;
2220 -- The file descriptor for the current source file. A negative value
2221 -- indicates failure to open the specified source file.
2224 -- Length of file. Assume no more than 2 gigabytes of source!
2226 Actual_Len
: Integer;
2229 pragma Warnings
(Off
, Status
);
2230 -- For the call to Close
2233 Current_Full_Source_Name
:= Find_File
(N
, T
);
2234 Current_Full_Source_Stamp
:= File_Stamp
(Current_Full_Source_Name
);
2236 if Current_Full_Source_Name
= No_File
then
2238 -- If we were trying to access the main file and we could not find
2239 -- it, we have an error.
2241 if N
= Current_Main
then
2242 Get_Name_String
(N
);
2243 Fail
("Cannot find: ", Name_Buffer
(1 .. Name_Len
));
2251 Get_Name_String
(Current_Full_Source_Name
);
2252 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
2254 -- Open the source FD, note that we open in binary mode, because as
2255 -- documented in the spec, the caller is expected to handle either
2256 -- DOS or Unix mode files, and there is no point in wasting time on
2257 -- text translation when it is not required.
2259 Source_File_FD
:= Open_Read
(Name_Buffer
'Address, Binary
);
2261 if Source_File_FD
= Invalid_FD
then
2267 -- Prepare to read data from the file
2269 Len
:= Integer (File_Length
(Source_File_FD
));
2271 -- Set Hi so that length is one more than the physical length,
2272 -- allowing for the extra EOF character at the end of the buffer
2274 Hi
:= Lo
+ Source_Ptr
(Len
);
2276 -- Do the actual read operation
2279 subtype Actual_Source_Buffer
is Source_Buffer
(Lo
.. Hi
);
2280 -- Physical buffer allocated
2282 type Actual_Source_Ptr
is access Actual_Source_Buffer
;
2283 -- This is the pointer type for the physical buffer allocated
2285 Actual_Ptr
: constant Actual_Source_Ptr
:= new Actual_Source_Buffer
;
2286 -- And this is the actual physical buffer
2289 -- Allocate source buffer, allowing extra character at end for EOF
2291 -- Some systems (e.g. VMS) have file types that require one
2292 -- read per line, so read until we get the Len bytes or until
2293 -- there are no more characters.
2297 Actual_Len
:= Read
(Source_File_FD
, Actual_Ptr
(Hi
)'Address, Len
);
2298 Hi
:= Hi
+ Source_Ptr
(Actual_Len
);
2299 exit when Actual_Len
= Len
or Actual_Len
<= 0;
2302 Actual_Ptr
(Hi
) := EOF
;
2304 -- Now we need to work out the proper virtual origin pointer to
2305 -- return. This is exactly Actual_Ptr (0)'Address, but we have
2306 -- to be careful to suppress checks to compute this address.
2309 pragma Suppress
(All_Checks
);
2311 pragma Warnings
(Off
);
2312 -- This use of unchecked conversion is aliasing safe
2314 function To_Source_Buffer_Ptr
is new
2315 Unchecked_Conversion
(Address
, Source_Buffer_Ptr
);
2317 pragma Warnings
(On
);
2320 Src
:= To_Source_Buffer_Ptr
(Actual_Ptr
(0)'Address);
2324 -- Read is complete, get time stamp and close file and we are done
2326 Close
(Source_File_FD
, Status
);
2328 -- The status should never be False. But, if it is, what can we do?
2329 -- So, we don't test it.
2331 end Read_Source_File
;
2337 function Relocate_Path
2339 Path
: String) return String_Ptr
2343 procedure set_std_prefix
(S
: String; Len
: Integer);
2344 pragma Import
(C
, set_std_prefix
);
2347 if Std_Prefix
= null then
2348 Std_Prefix
:= Executable_Prefix
;
2350 if Std_Prefix
.all /= "" then
2352 -- Remove trailing directory separator when calling set_std_prefix
2354 set_std_prefix
(Std_Prefix
.all, Std_Prefix
'Length - 1);
2358 if Path
(Prefix
'Range) = Prefix
then
2359 if Std_Prefix
.all /= "" then
2361 (1 .. Std_Prefix
'Length + Path
'Last - Prefix
'Last);
2362 S
(1 .. Std_Prefix
'Length) := Std_Prefix
.all;
2363 S
(Std_Prefix
'Length + 1 .. S
'Last) :=
2364 Path
(Prefix
'Last + 1 .. Path
'Last);
2369 return new String'(Path);
2376 procedure Set_Program (P : Program_Type) is
2379 Fail ("Set_Program called twice");
2382 Program_Set := True;
2383 Running_Program := P;
2390 function Shared_Lib (Name : String) return String is
2391 Library : String (1 .. Name'Length + Library_Version'Length + 3);
2392 -- 3 = 2 for "-l" + 1 for "-" before lib version
2395 Library (1 .. 2) := "-l";
2396 Library (3 .. 2 + Name'Length) := Name;
2397 Library (3 + Name'Length) := '-';
2398 Library (4 + Name'Length .. Library'Last) := Library_Version;
2400 if OpenVMS_On_Target then
2401 for K in Library'First + 2 .. Library'Last loop
2402 if Library (K) = '.' or else Library (K) = '-' then
2411 ----------------------
2412 -- Smart_File_Stamp --
2413 ----------------------
2415 function Smart_File_Stamp
2416 (N : File_Name_Type;
2417 T : File_Type) return Time_Stamp_Type
2419 Time_Stamp : Time_Stamp_Type;
2422 if not File_Cache_Enabled then
2423 return File_Stamp (Find_File (N, T));
2426 Time_Stamp := File_Stamp_Hash_Table.Get (N);
2428 if Time_Stamp (1) = ' ' then
2429 Time_Stamp := File_Stamp (Smart_Find_File (N, T));
2430 File_Stamp_Hash_Table.Set (N, Time_Stamp);
2434 end Smart_File_Stamp;
2436 ---------------------
2437 -- Smart_Find_File --
2438 ---------------------
2440 function Smart_Find_File
2441 (N : File_Name_Type;
2442 T : File_Type) return File_Name_Type
2444 Full_File_Name : File_Name_Type;
2447 if not File_Cache_Enabled then
2448 return Find_File (N, T);
2451 Full_File_Name := File_Name_Hash_Table.Get (N);
2453 if Full_File_Name = No_File then
2454 Full_File_Name := Find_File (N, T);
2455 File_Name_Hash_Table.Set (N, Full_File_Name);
2458 return Full_File_Name;
2459 end Smart_Find_File;
2461 ----------------------
2462 -- Source_File_Data --
2463 ----------------------
2465 procedure Source_File_Data (Cache : Boolean) is
2467 File_Cache_Enabled := Cache;
2468 end Source_File_Data;
2470 -----------------------
2471 -- Source_File_Stamp --
2472 -----------------------
2474 function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is
2476 return Smart_File_Stamp (N, Source);
2477 end Source_File_Stamp;
2479 ---------------------
2480 -- Strip_Directory --
2481 ---------------------
2483 function Strip_Directory (Name : File_Name_Type) return File_Name_Type is
2485 Get_Name_String (Name);
2487 for J in reverse 1 .. Name_Len - 1 loop
2489 -- If we find the last directory separator
2491 if Is_Directory_Separator (Name_Buffer (J)) then
2493 -- Return the part of Name that follows this last directory
2496 Name_Buffer (1 .. Name_Len - J) := Name_Buffer (J + 1 .. Name_Len);
2497 Name_Len := Name_Len - J;
2502 -- There were no directory separator, just return Name
2505 end Strip_Directory;
2511 function Strip_Suffix (Name : File_Name_Type) return File_Name_Type is
2513 Get_Name_String (Name);
2515 for J in reverse 2 .. Name_Len loop
2517 -- If we found the last '.', return part of Name that precedes it
2519 if Name_Buffer (J) = '.' then
2528 ---------------------------
2529 -- To_Canonical_Dir_Spec --
2530 ---------------------------
2532 function To_Canonical_Dir_Spec
2534 Prefix_Style : Boolean) return String_Access
2536 function To_Canonical_Dir_Spec
2537 (Host_Dir : Address;
2538 Prefix_Flag : Integer) return Address;
2539 pragma Import (C, To_Canonical_Dir_Spec, "__gnat_to_canonical_dir_spec");
2541 C_Host_Dir : String (1 .. Host_Dir'Length + 1);
2542 Canonical_Dir_Addr : Address;
2543 Canonical_Dir_Len : Integer;
2546 C_Host_Dir (1 .. Host_Dir'Length) := Host_Dir;
2547 C_Host_Dir (C_Host_Dir'Last) := ASCII.NUL;
2549 if Prefix_Style then
2550 Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 1);
2552 Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 0);
2554 Canonical_Dir_Len := C_String_Length (Canonical_Dir_Addr);
2556 if Canonical_Dir_Len = 0 then
2559 return To_Path_String_Access (Canonical_Dir_Addr, Canonical_Dir_Len);
2564 Fail ("erroneous directory spec: ", Host_Dir);
2566 end To_Canonical_Dir_Spec;
2568 ---------------------------
2569 -- To_Canonical_File_List --
2570 ---------------------------
2572 function To_Canonical_File_List
2573 (Wildcard_Host_File : String;
2574 Only_Dirs : Boolean) return String_Access_List_Access
2576 function To_Canonical_File_List_Init
2577 (Host_File : Address;
2578 Only_Dirs : Integer) return Integer;
2579 pragma Import (C, To_Canonical_File_List_Init,
2580 "__gnat_to_canonical_file_list_init");
2582 function To_Canonical_File_List_Next return Address;
2583 pragma Import (C, To_Canonical_File_List_Next,
2584 "__gnat_to_canonical_file_list_next");
2586 procedure To_Canonical_File_List_Free;
2587 pragma Import (C, To_Canonical_File_List_Free,
2588 "__gnat_to_canonical_file_list_free");
2590 Num_Files : Integer;
2591 C_Wildcard_Host_File : String (1 .. Wildcard_Host_File'Length + 1);
2594 C_Wildcard_Host_File (1 .. Wildcard_Host_File'Length) :=
2596 C_Wildcard_Host_File (C_Wildcard_Host_File'Last) := ASCII.NUL;
2598 -- Do the expansion and say how many there are
2600 Num_Files := To_Canonical_File_List_Init
2601 (C_Wildcard_Host_File'Address, Boolean'Pos (Only_Dirs));
2604 Canonical_File_List : String_Access_List (1 .. Num_Files);
2605 Canonical_File_Addr : Address;
2606 Canonical_File_Len : Integer;
2609 -- Retrieve the expanded directory names and build the list
2611 for J in 1 .. Num_Files loop
2612 Canonical_File_Addr := To_Canonical_File_List_Next;
2613 Canonical_File_Len := C_String_Length (Canonical_File_Addr);
2614 Canonical_File_List (J) := To_Path_String_Access
2615 (Canonical_File_Addr, Canonical_File_Len);
2618 -- Free up the storage
2620 To_Canonical_File_List_Free;
2622 return new String_Access_List'(Canonical_File_List
);
2624 end To_Canonical_File_List
;
2626 ----------------------------
2627 -- To_Canonical_File_Spec --
2628 ----------------------------
2630 function To_Canonical_File_Spec
2631 (Host_File
: String) return String_Access
2633 function To_Canonical_File_Spec
(Host_File
: Address
) return Address
;
2635 (C
, To_Canonical_File_Spec
, "__gnat_to_canonical_file_spec");
2637 C_Host_File
: String (1 .. Host_File
'Length + 1);
2638 Canonical_File_Addr
: Address
;
2639 Canonical_File_Len
: Integer;
2642 C_Host_File
(1 .. Host_File
'Length) := Host_File
;
2643 C_Host_File
(C_Host_File
'Last) := ASCII
.NUL
;
2645 Canonical_File_Addr
:= To_Canonical_File_Spec
(C_Host_File
'Address);
2646 Canonical_File_Len
:= C_String_Length
(Canonical_File_Addr
);
2648 if Canonical_File_Len
= 0 then
2651 return To_Path_String_Access
2652 (Canonical_File_Addr
, Canonical_File_Len
);
2657 Fail
("erroneous file spec: ", Host_File
);
2659 end To_Canonical_File_Spec
;
2661 ----------------------------
2662 -- To_Canonical_Path_Spec --
2663 ----------------------------
2665 function To_Canonical_Path_Spec
2666 (Host_Path
: String) return String_Access
2668 function To_Canonical_Path_Spec
(Host_Path
: Address
) return Address
;
2670 (C
, To_Canonical_Path_Spec
, "__gnat_to_canonical_path_spec");
2672 C_Host_Path
: String (1 .. Host_Path
'Length + 1);
2673 Canonical_Path_Addr
: Address
;
2674 Canonical_Path_Len
: Integer;
2677 C_Host_Path
(1 .. Host_Path
'Length) := Host_Path
;
2678 C_Host_Path
(C_Host_Path
'Last) := ASCII
.NUL
;
2680 Canonical_Path_Addr
:= To_Canonical_Path_Spec
(C_Host_Path
'Address);
2681 Canonical_Path_Len
:= C_String_Length
(Canonical_Path_Addr
);
2683 -- Return a null string (vice a null) for zero length paths, for
2684 -- compatibility with getenv().
2686 return To_Path_String_Access
(Canonical_Path_Addr
, Canonical_Path_Len
);
2690 Fail
("erroneous path spec: ", Host_Path
);
2692 end To_Canonical_Path_Spec
;
2694 ---------------------------
2695 -- To_Host_Dir_Spec --
2696 ---------------------------
2698 function To_Host_Dir_Spec
2699 (Canonical_Dir
: String;
2700 Prefix_Style
: Boolean) return String_Access
2702 function To_Host_Dir_Spec
2703 (Canonical_Dir
: Address
;
2704 Prefix_Flag
: Integer) return Address
;
2705 pragma Import
(C
, To_Host_Dir_Spec
, "__gnat_to_host_dir_spec");
2707 C_Canonical_Dir
: String (1 .. Canonical_Dir
'Length + 1);
2708 Host_Dir_Addr
: Address
;
2709 Host_Dir_Len
: Integer;
2712 C_Canonical_Dir
(1 .. Canonical_Dir
'Length) := Canonical_Dir
;
2713 C_Canonical_Dir
(C_Canonical_Dir
'Last) := ASCII
.NUL
;
2715 if Prefix_Style
then
2716 Host_Dir_Addr
:= To_Host_Dir_Spec
(C_Canonical_Dir
'Address, 1);
2718 Host_Dir_Addr
:= To_Host_Dir_Spec
(C_Canonical_Dir
'Address, 0);
2720 Host_Dir_Len
:= C_String_Length
(Host_Dir_Addr
);
2722 if Host_Dir_Len
= 0 then
2725 return To_Path_String_Access
(Host_Dir_Addr
, Host_Dir_Len
);
2727 end To_Host_Dir_Spec
;
2729 ----------------------------
2730 -- To_Host_File_Spec --
2731 ----------------------------
2733 function To_Host_File_Spec
2734 (Canonical_File
: String) return String_Access
2736 function To_Host_File_Spec
(Canonical_File
: Address
) return Address
;
2737 pragma Import
(C
, To_Host_File_Spec
, "__gnat_to_host_file_spec");
2739 C_Canonical_File
: String (1 .. Canonical_File
'Length + 1);
2740 Host_File_Addr
: Address
;
2741 Host_File_Len
: Integer;
2744 C_Canonical_File
(1 .. Canonical_File
'Length) := Canonical_File
;
2745 C_Canonical_File
(C_Canonical_File
'Last) := ASCII
.NUL
;
2747 Host_File_Addr
:= To_Host_File_Spec
(C_Canonical_File
'Address);
2748 Host_File_Len
:= C_String_Length
(Host_File_Addr
);
2750 if Host_File_Len
= 0 then
2753 return To_Path_String_Access
2754 (Host_File_Addr
, Host_File_Len
);
2756 end To_Host_File_Spec
;
2758 ---------------------------
2759 -- To_Path_String_Access --
2760 ---------------------------
2762 function To_Path_String_Access
2763 (Path_Addr
: Address
;
2764 Path_Len
: Integer) return String_Access
2766 subtype Path_String
is String (1 .. Path_Len
);
2767 type Path_String_Access
is access Path_String
;
2769 function Address_To_Access
is new
2770 Unchecked_Conversion
(Source
=> Address
,
2771 Target
=> Path_String_Access
);
2773 Path_Access
: constant Path_String_Access
:=
2774 Address_To_Access
(Path_Addr
);
2776 Return_Val
: String_Access
;
2779 Return_Val
:= new String (1 .. Path_Len
);
2781 for J
in 1 .. Path_Len
loop
2782 Return_Val
(J
) := Path_Access
(J
);
2786 end To_Path_String_Access
;
2792 function Update_Path
(Path
: String_Ptr
) return String_Ptr
is
2794 function C_Update_Path
(Path
, Component
: Address
) return Address
;
2795 pragma Import
(C
, C_Update_Path
, "update_path");
2797 function Strlen
(Str
: Address
) return Integer;
2798 pragma Import
(C
, Strlen
, "strlen");
2800 procedure Strncpy
(X
: Address
; Y
: Address
; Length
: Integer);
2801 pragma Import
(C
, Strncpy
, "strncpy");
2803 In_Length
: constant Integer := Path
'Length;
2804 In_String
: String (1 .. In_Length
+ 1);
2805 Component_Name
: aliased String := "GCC" & ASCII
.NUL
;
2806 Result_Ptr
: Address
;
2807 Result_Length
: Integer;
2808 Out_String
: String_Ptr
;
2811 In_String
(1 .. In_Length
) := Path
.all;
2812 In_String
(In_Length
+ 1) := ASCII
.NUL
;
2813 Result_Ptr
:= C_Update_Path
(In_String
'Address, Component_Name
'Address);
2814 Result_Length
:= Strlen
(Result_Ptr
);
2816 Out_String
:= new String (1 .. Result_Length
);
2817 Strncpy
(Out_String
.all'Address, Result_Ptr
, Result_Length
);
2825 procedure Write_Info
(Info
: String) is
2827 Write_With_Check
(Info
'Address, Info
'Length);
2828 Write_With_Check
(EOL
'Address, 1);
2831 ------------------------
2832 -- Write_Program_Name --
2833 ------------------------
2835 procedure Write_Program_Name
is
2836 Save_Buffer
: constant String (1 .. Name_Len
) :=
2837 Name_Buffer
(1 .. Name_Len
);
2842 -- Convert the name to lower case so error messages are the same on
2845 for J
in 1 .. Name_Len
loop
2846 if Name_Buffer
(J
) in 'A' .. 'Z' then
2848 Character'Val (Character'Pos (Name_Buffer
(J
)) + 32);
2852 Write_Str
(Name_Buffer
(1 .. Name_Len
));
2854 -- Restore Name_Buffer which was clobbered by the call to
2855 -- Find_Program_Name
2857 Name_Len
:= Save_Buffer
'Last;
2858 Name_Buffer
(1 .. Name_Len
) := Save_Buffer
;
2859 end Write_Program_Name
;
2861 ----------------------
2862 -- Write_With_Check --
2863 ----------------------
2865 procedure Write_With_Check
(A
: Address
; N
: Integer) is
2867 pragma Warnings
(Off
, Ignore
);
2870 if N
= Write
(Output_FD
, A
, N
) then
2874 Write_Str
("error: disk full writing ");
2875 Write_Name_Decoded
(Output_File_Name
);
2877 Name_Len
:= Name_Len
+ 1;
2878 Name_Buffer
(Name_Len
) := ASCII
.NUL
;
2879 Delete_File
(Name_Buffer
'Address, Ignore
);
2880 Exit_Program
(E_Fatal
);
2882 end Write_With_Check
;
2884 ----------------------------
2885 -- Package Initialization --
2886 ----------------------------
2889 Initialization
: declare
2891 function Get_Default_Identifier_Character_Set
return Character;
2892 pragma Import
(C
, Get_Default_Identifier_Character_Set
,
2893 "__gnat_get_default_identifier_character_set");
2894 -- Function to determine the default identifier character set,
2895 -- which is system dependent. See Opt package spec for a list of
2896 -- the possible character codes and their interpretations.
2898 function Get_Maximum_File_Name_Length
return Int
;
2899 pragma Import
(C
, Get_Maximum_File_Name_Length
,
2900 "__gnat_get_maximum_file_name_length");
2901 -- Function to get maximum file name length for system
2904 Identifier_Character_Set
:= Get_Default_Identifier_Character_Set
;
2905 Maximum_File_Name_Length
:= Get_Maximum_File_Name_Length
;
2907 -- Following should be removed by having above function return
2908 -- Integer'Last as indication of no maximum instead of -1 ???
2910 if Maximum_File_Name_Length
= -1 then
2911 Maximum_File_Name_Length
:= Int
'Last;
2914 Src_Search_Directories
.Set_Last
(Primary_Directory
);
2915 Src_Search_Directories
.Table
(Primary_Directory
) := new String'("");
2917 Lib_Search_Directories.Set_Last (Primary_Directory);
2918 Lib_Search_Directories.Table (Primary_Directory) := new String'("");