1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, 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 ------------------------------------------------------------------------------
29 with Gnatvsn
; use Gnatvsn
;
32 with Output
; use Output
;
33 with Sdefault
; use Sdefault
;
35 with Targparm
; use Targparm
;
37 with Unchecked_Conversion
;
39 pragma Warnings
(Off
);
40 -- This package is used also by gnatcoll
41 with System
.Case_Util
; use System
.Case_Util
;
48 Running_Program
: Program_Type
:= Unspecified
;
49 -- comment required here ???
51 Program_Set
: Boolean := False;
52 -- comment required here ???
54 Std_Prefix
: String_Ptr
;
55 -- Standard prefix, computed dynamically the first time Relocate_Path
56 -- is called, and cached for subsequent calls.
58 Empty
: aliased String := "";
59 No_Dir
: constant String_Ptr
:= Empty
'Access;
60 -- Used in Locate_File as a fake directory when Name is already an
63 -------------------------------------
64 -- Use of Name_Find and Name_Enter --
65 -------------------------------------
67 -- This package creates a number of source, ALI and object file names
68 -- that are used to locate the actual file and for the purpose of message
69 -- construction. These names need not be accessible by Name_Find, and can
70 -- be therefore created by using routine Name_Enter. The files in question
71 -- are file names with a prefix directory (i.e., the files not in the
72 -- current directory). File names without a prefix directory are entered
73 -- with Name_Find because special values might be attached to the various
74 -- Info fields of the corresponding name table entry.
76 -----------------------
77 -- Local Subprograms --
78 -----------------------
80 function Append_Suffix_To_File_Name
81 (Name
: File_Name_Type
;
82 Suffix
: String) return File_Name_Type
;
83 -- Appends Suffix to Name and returns the new name
85 function OS_Time_To_GNAT_Time
(T
: OS_Time
) return Time_Stamp_Type
;
86 -- Convert OS format time to GNAT format time stamp. If T is Invalid_Time,
87 -- then returns Empty_Time_Stamp.
89 function Executable_Prefix
return String_Ptr
;
90 -- Returns the name of the root directory where the executable is stored.
91 -- The executable must be located in a directory called "bin", or under
92 -- root/lib/gcc-lib/..., or under root/libexec/gcc/... For example, if
93 -- executable is stored in directory "/foo/bar/bin", this routine returns
94 -- "/foo/bar/". Return "" if location is not recognized 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 where
98 -- GNAT is installed. See the file prefix.c in GCC for details.
100 procedure Locate_File
105 Found
: out File_Name_Type
;
106 Attr
: access File_Attributes
);
107 -- See if the file N whose name is Name exists in directory Dir. Dir is an
108 -- index into the Lib_Search_Directories table if T = Library. Otherwise
109 -- if T = Source, Dir is an index into the Src_Search_Directories table.
110 -- Returns the File_Name_Type of the full file name if file found, or
111 -- No_File if not found.
113 -- On exit, Found is set to the file that was found, and Attr to a cache of
114 -- its attributes (at least those that have been computed so far). Reusing
115 -- the cache will save some system calls.
117 -- Attr is always reset in this call to Unknown_Attributes, even in case of
123 Found
: out File_Name_Type
;
124 Attr
: access File_Attributes
);
125 -- A version of Find_File that also returns a cache of the file attributes
128 procedure Smart_Find_File
131 Found
: out File_Name_Type
;
132 Attr
: out File_Attributes
);
133 -- A version of Smart_Find_File that also returns a cache of the file
134 -- attributes for later reuse
136 function C_String_Length
(S
: Address
) return Integer;
137 -- Returns length of a C string (zero for a null address)
139 function To_Path_String_Access
140 (Path_Addr
: Address
;
141 Path_Len
: Integer) return String_Access
;
142 -- Converts a C String to an Ada String. Are we doing this to avoid withing
143 -- Interfaces.C.Strings ???
144 -- Caller must free result.
146 function Include_Dir_Default_Prefix
return String_Access
;
147 -- Same as exported version, except returns a String_Access
149 ------------------------------
150 -- Other Local Declarations --
151 ------------------------------
153 EOL
: constant Character := ASCII
.LF
;
154 -- End of line character
156 Number_File_Names
: Int
:= 0;
157 -- Number of file names found on command line and placed in File_Names
159 Look_In_Primary_Directory_For_Current_Main
: Boolean := False;
160 -- When this variable is True, Find_File only looks in Primary_Directory
161 -- for the Current_Main file. This variable is always set to True for the
162 -- compiler. It is also True for gnatmake, when the source name given on
163 -- the command line has directory information.
165 Current_Full_Source_Name
: File_Name_Type
:= No_File
;
166 Current_Full_Source_Stamp
: Time_Stamp_Type
:= Empty_Time_Stamp
;
167 Current_Full_Lib_Name
: File_Name_Type
:= No_File
;
168 Current_Full_Lib_Stamp
: Time_Stamp_Type
:= Empty_Time_Stamp
;
169 Current_Full_Obj_Name
: File_Name_Type
:= No_File
;
170 Current_Full_Obj_Stamp
: Time_Stamp_Type
:= Empty_Time_Stamp
;
171 -- Respectively full name (with directory info) and time stamp of the
172 -- latest source, library and object files opened by Read_Source_File and
173 -- Read_Library_Info.
175 package File_Name_Chars
is new Table
.Table
(
176 Table_Component_Type
=> Character,
177 Table_Index_Type
=> Int
,
178 Table_Low_Bound
=> 1,
179 Table_Initial
=> Alloc
.File_Name_Chars_Initial
,
180 Table_Increment
=> Alloc
.File_Name_Chars_Increment
,
181 Table_Name
=> "File_Name_Chars");
182 -- Table to store text to be printed by Dump_Source_File_Names
184 The_Include_Dir_Default_Prefix
: String_Access
:= null;
185 -- Value returned by Include_Dir_Default_Prefix. We don't initialize it
186 -- here, because that causes an elaboration cycle with Sdefault; we
187 -- initialize it lazily instead.
193 Primary_Directory
: constant := 0;
194 -- This is index in the tables created below for the first directory to
195 -- search in for source or library information files. This is the directory
196 -- containing the latest main input file (a source file for the compiler or
197 -- a library file for the binder).
199 package Src_Search_Directories
is new Table
.Table
(
200 Table_Component_Type
=> String_Ptr
,
201 Table_Index_Type
=> Integer,
202 Table_Low_Bound
=> Primary_Directory
,
204 Table_Increment
=> 100,
205 Table_Name
=> "Osint.Src_Search_Directories");
206 -- Table of names of directories in which to search for source (Compiler)
207 -- files. This table is filled in the order in which the directories are
208 -- to be searched, and then used in that order.
210 package Lib_Search_Directories
is new Table
.Table
(
211 Table_Component_Type
=> String_Ptr
,
212 Table_Index_Type
=> Integer,
213 Table_Low_Bound
=> Primary_Directory
,
215 Table_Increment
=> 100,
216 Table_Name
=> "Osint.Lib_Search_Directories");
217 -- Table of names of directories in which to search for library (Binder)
218 -- files. This table is filled in the order in which the directories are
219 -- to be searched and then used in that order. The reason for having two
220 -- distinct tables is that we need them both in gnatmake.
222 ---------------------
223 -- File Hash Table --
224 ---------------------
226 -- The file hash table is provided to free the programmer from any
227 -- efficiency concern when retrieving full file names or time stamps of
228 -- source files. If the programmer calls Source_File_Data (Cache => True)
229 -- he is guaranteed that the price to retrieve the full name (i.e. with
230 -- directory info) or time stamp of the file will be payed only once, the
231 -- first time the full name is actually searched (or the first time the
232 -- time stamp is actually retrieved). This is achieved by employing a hash
233 -- table that stores as a key the File_Name_Type of the file and associates
234 -- to that File_Name_Type the full file name and time stamp of the file.
236 File_Cache_Enabled
: Boolean := False;
237 -- Set to true if you want the enable the file data caching mechanism
239 type File_Hash_Num
is range 0 .. 1020;
241 function File_Hash
(F
: File_Name_Type
) return File_Hash_Num
;
242 -- Compute hash index for use by Simple_HTable
244 type File_Info_Cache
is record
245 File
: File_Name_Type
;
246 Attr
: aliased File_Attributes
;
249 No_File_Info_Cache
: constant File_Info_Cache
:=
250 (No_File
, Unknown_Attributes
);
252 package File_Name_Hash_Table
is new GNAT
.HTable
.Simple_HTable
(
253 Header_Num
=> File_Hash_Num
,
254 Element
=> File_Info_Cache
,
255 No_Element
=> No_File_Info_Cache
,
256 Key
=> File_Name_Type
,
260 function Smart_Find_File
262 T
: File_Type
) return File_Name_Type
;
263 -- Exactly like Find_File except that if File_Cache_Enabled is True this
264 -- routine looks first in the hash table to see if the full name of the
265 -- file is already available.
267 function Smart_File_Stamp
269 T
: File_Type
) return Time_Stamp_Type
;
270 -- Takes the same parameter as the routine above (N is a file name without
271 -- any prefix directory information) and behaves like File_Stamp except
272 -- that if File_Cache_Enabled is True this routine looks first in the hash
273 -- table to see if the file stamp of the file is already available.
275 -----------------------------
276 -- Add_Default_Search_Dirs --
277 -----------------------------
279 procedure Add_Default_Search_Dirs
is
280 Search_Dir
: String_Access
;
281 Search_Path
: String_Access
;
282 Path_File_Name
: String_Access
;
284 procedure Add_Search_Dir
285 (Search_Dir
: String;
286 Additional_Source_Dir
: Boolean);
287 procedure Add_Search_Dir
288 (Search_Dir
: String_Access
;
289 Additional_Source_Dir
: Boolean);
290 -- Add a source search dir or a library search dir, depending on the
291 -- value of Additional_Source_Dir.
293 procedure Get_Dirs_From_File
(Additional_Source_Dir
: Boolean);
294 -- Open a path file and read the directory to search, one per line
296 function Get_Libraries_From_Registry
return String_Ptr
;
297 -- On Windows systems, get the list of installed standard libraries
298 -- from the registry key:
300 -- HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\
301 -- GNAT\Standard Libraries
302 -- Return an empty string on other systems.
304 -- Note that this is an undocumented legacy feature, and that it
305 -- works only when using the default runtime library (i.e. no --RTS=
306 -- command line switch).
312 procedure Add_Search_Dir
313 (Search_Dir
: String;
314 Additional_Source_Dir
: Boolean)
317 if Additional_Source_Dir
then
318 Add_Src_Search_Dir
(Search_Dir
);
320 Add_Lib_Search_Dir
(Search_Dir
);
324 procedure Add_Search_Dir
325 (Search_Dir
: String_Access
;
326 Additional_Source_Dir
: Boolean)
329 if Additional_Source_Dir
then
330 Add_Src_Search_Dir
(Search_Dir
.all);
332 Add_Lib_Search_Dir
(Search_Dir
.all);
336 ------------------------
337 -- Get_Dirs_From_File --
338 ------------------------
340 procedure Get_Dirs_From_File
(Additional_Source_Dir
: Boolean) is
341 File_FD
: File_Descriptor
;
342 Buffer
: constant String := Path_File_Name
.all & ASCII
.NUL
;
344 Actual_Len
: Natural;
351 pragma Warnings
(Off
, Status
);
352 -- For the call to Close where status is ignored
355 File_FD
:= Open_Read
(Buffer
'Address, Binary
);
357 -- If we cannot open the file, we ignore it, we don't fail
359 if File_FD
= Invalid_FD
then
363 Len
:= Integer (File_Length
(File_FD
));
365 S
:= new String (1 .. Len
);
367 -- Read the file. Note that the loop is not necessary since the
368 -- whole file is read at once except on VMS.
372 while Curr
<= Len
and then Actual_Len
/= 0 loop
373 Actual_Len
:= Read
(File_FD
, S
(Curr
)'Address, Len
);
374 Curr
:= Curr
+ Actual_Len
;
377 -- We are done with the file, so we close it (ignore any error on
378 -- the close, since we have successfully read the file).
380 Close
(File_FD
, Status
);
382 -- Now, we read line by line
386 while Curr
< Len
loop
389 if Ch
= ASCII
.CR
or else Ch
= ASCII
.LF
390 or else Ch
= ASCII
.FF
or else Ch
= ASCII
.VT
392 if First
<= Curr
then
393 Add_Search_Dir
(S
(First
.. Curr
), Additional_Source_Dir
);
402 -- Last line is a special case, if the file does not end with
403 -- an end of line mark.
405 if First
<= S
'Last then
406 Add_Search_Dir
(S
(First
.. S
'Last), Additional_Source_Dir
);
408 end Get_Dirs_From_File
;
410 ---------------------------------
411 -- Get_Libraries_From_Registry --
412 ---------------------------------
414 function Get_Libraries_From_Registry
return String_Ptr
is
415 function C_Get_Libraries_From_Registry
return Address
;
416 pragma Import
(C
, C_Get_Libraries_From_Registry
,
417 "__gnat_get_libraries_from_registry");
419 function Strlen
(Str
: Address
) return Integer;
420 pragma Import
(C
, Strlen
, "strlen");
422 procedure Strncpy
(X
: Address
; Y
: Address
; Length
: Integer);
423 pragma Import
(C
, Strncpy
, "strncpy");
425 procedure C_Free
(Str
: Address
);
426 pragma Import
(C
, C_Free
, "free");
428 Result_Ptr
: Address
;
429 Result_Length
: Integer;
430 Out_String
: String_Ptr
;
433 Result_Ptr
:= C_Get_Libraries_From_Registry
;
434 Result_Length
:= Strlen
(Result_Ptr
);
436 Out_String
:= new String (1 .. Result_Length
);
437 Strncpy
(Out_String
.all'Address, Result_Ptr
, Result_Length
);
442 end Get_Libraries_From_Registry
;
444 -- Start of processing for Add_Default_Search_Dirs
447 -- After the locations specified on the command line, the next places
448 -- to look for files are the directories specified by the appropriate
449 -- environment variable. Get this value, extract the directory names
450 -- and store in the tables.
452 -- Check for eventual project path file env vars
454 Path_File_Name
:= Getenv
(Project_Include_Path_File
);
456 if Path_File_Name
'Length > 0 then
457 Get_Dirs_From_File
(Additional_Source_Dir
=> True);
460 Path_File_Name
:= Getenv
(Project_Objects_Path_File
);
462 if Path_File_Name
'Length > 0 then
463 Get_Dirs_From_File
(Additional_Source_Dir
=> False);
466 -- On VMS, don't expand the logical name (e.g. environment variable),
467 -- just put it into Unix (e.g. canonical) format. System services
468 -- will handle the expansion as part of the file processing.
470 for Additional_Source_Dir
in False .. True loop
471 if Additional_Source_Dir
then
472 Search_Path
:= Getenv
(Ada_Include_Path
);
474 if Search_Path
'Length > 0 then
475 if Hostparm
.OpenVMS
then
476 Search_Path
:= To_Canonical_Path_Spec
("ADA_INCLUDE_PATH:");
478 Search_Path
:= To_Canonical_Path_Spec
(Search_Path
.all);
483 Search_Path
:= Getenv
(Ada_Objects_Path
);
485 if Search_Path
'Length > 0 then
486 if Hostparm
.OpenVMS
then
487 Search_Path
:= To_Canonical_Path_Spec
("ADA_OBJECTS_PATH:");
489 Search_Path
:= To_Canonical_Path_Spec
(Search_Path
.all);
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
, Additional_Source_Dir
);
502 -- For the compiler, if --RTS= was specified, add the runtime
505 if RTS_Src_Path_Name
/= null
506 and then RTS_Lib_Path_Name
/= null
508 Add_Search_Dirs
(RTS_Src_Path_Name
, Include
);
509 Add_Search_Dirs
(RTS_Lib_Path_Name
, Objects
);
512 if not Opt
.No_Stdinc
then
514 -- For WIN32 systems, look for any system libraries defined in
515 -- the registry. These are added to both source and object
518 Search_Path
:= String_Access
(Get_Libraries_From_Registry
);
520 Get_Next_Dir_In_Path_Init
(Search_Path
);
522 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
523 exit when Search_Dir
= null;
524 Add_Search_Dir
(Search_Dir
, False);
525 Add_Search_Dir
(Search_Dir
, True);
528 -- The last place to look are the defaults
531 Read_Default_Search_Dirs
532 (String_Access
(Update_Path
(Search_Dir_Prefix
)),
534 String_Access
(Update_Path
(Include_Dir_Default_Name
)));
536 Get_Next_Dir_In_Path_Init
(Search_Path
);
538 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
539 exit when Search_Dir
= null;
540 Add_Search_Dir
(Search_Dir
, True);
544 -- Even when -nostdlib is used, we still want to have visibility on
545 -- the run-time object directory, as it is used by gnatbind to find
546 -- the run-time ALI files in "real" ZFP set up.
548 if not Opt
.RTS_Switch
then
550 Read_Default_Search_Dirs
551 (String_Access
(Update_Path
(Search_Dir_Prefix
)),
553 String_Access
(Update_Path
(Object_Dir_Default_Name
)));
555 Get_Next_Dir_In_Path_Init
(Search_Path
);
557 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
558 exit when Search_Dir
= null;
559 Add_Search_Dir
(Search_Dir
, False);
563 end Add_Default_Search_Dirs
;
569 procedure Add_File
(File_Name
: String; Index
: Int
:= No_Index
) is
571 Number_File_Names
:= Number_File_Names
+ 1;
573 -- As Add_File may be called for mains specified inside a project file,
574 -- File_Names may be too short and needs to be extended.
576 if Number_File_Names
> File_Names
'Last then
577 File_Names
:= new File_Name_Array
'(File_Names.all & File_Names.all);
579 new File_Index_Array'(File_Indexes
.all & File_Indexes
.all);
582 File_Names
(Number_File_Names
) := new String'(File_Name);
583 File_Indexes (Number_File_Names) := Index;
586 ------------------------
587 -- Add_Lib_Search_Dir --
588 ------------------------
590 procedure Add_Lib_Search_Dir (Dir : String) is
592 if Dir'Length = 0 then
593 Fail ("missing library directory name");
597 Norm : String_Ptr := Normalize_Directory_Name (Dir);
600 -- Do nothing if the directory is already in the list. This saves
601 -- system calls and avoid unneeded work
603 for D in Lib_Search_Directories.First ..
604 Lib_Search_Directories.Last
606 if Lib_Search_Directories.Table (D).all = Norm.all then
612 Lib_Search_Directories.Increment_Last;
613 Lib_Search_Directories.Table (Lib_Search_Directories.Last) := Norm;
615 end Add_Lib_Search_Dir;
617 ---------------------
618 -- Add_Search_Dirs --
619 ---------------------
621 procedure Add_Search_Dirs
622 (Search_Path : String_Ptr;
623 Path_Type : Search_File_Type)
625 Current_Search_Path : String_Access;
628 Get_Next_Dir_In_Path_Init (String_Access (Search_Path));
630 Current_Search_Path :=
631 Get_Next_Dir_In_Path (String_Access (Search_Path));
632 exit when Current_Search_Path = null;
634 if Path_Type = Include then
635 Add_Src_Search_Dir (Current_Search_Path.all);
637 Add_Lib_Search_Dir (Current_Search_Path.all);
642 ------------------------
643 -- Add_Src_Search_Dir --
644 ------------------------
646 procedure Add_Src_Search_Dir (Dir : String) is
648 if Dir'Length = 0 then
649 Fail ("missing source directory name");
652 Src_Search_Directories.Increment_Last;
653 Src_Search_Directories.Table (Src_Search_Directories.Last) :=
654 Normalize_Directory_Name (Dir);
655 end Add_Src_Search_Dir;
657 --------------------------------
658 -- Append_Suffix_To_File_Name --
659 --------------------------------
661 function Append_Suffix_To_File_Name
662 (Name : File_Name_Type;
663 Suffix : String) return File_Name_Type
666 Get_Name_String (Name);
667 Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
668 Name_Len := Name_Len + Suffix'Length;
670 end Append_Suffix_To_File_Name;
672 ---------------------
673 -- C_String_Length --
674 ---------------------
676 function C_String_Length (S : Address) return Integer is
677 function Strlen (S : Address) return Integer;
678 pragma Import (C, Strlen, "strlen");
680 if S = Null_Address then
687 ------------------------------
688 -- Canonical_Case_File_Name --
689 ------------------------------
691 -- For now, we only deal with the case of a-z. Eventually we should
692 -- worry about other Latin-1 letters on systems that support this ???
694 procedure Canonical_Case_File_Name (S : in out String) is
696 if not File_Names_Case_Sensitive then
697 for J in S'Range loop
698 if S (J) in 'A
' .. 'Z
' then
699 S (J) := Character'Val (
700 Character'Pos (S (J)) +
701 Character'Pos ('a
') -
702 Character'Pos ('A
'));
706 end Canonical_Case_File_Name;
708 ---------------------------
709 -- Create_File_And_Check --
710 ---------------------------
712 procedure Create_File_And_Check
713 (Fdesc : out File_Descriptor;
717 Output_File_Name := Name_Enter;
718 Fdesc := Create_File (Name_Buffer'Address, Fmode);
720 if Fdesc = Invalid_FD then
721 Fail ("Cannot create: " & Name_Buffer (1 .. Name_Len));
723 end Create_File_And_Check;
725 ------------------------
726 -- Current_File_Index --
727 ------------------------
729 function Current_File_Index return Int is
731 return File_Indexes (Current_File_Name_Index);
732 end Current_File_Index;
734 --------------------------------
735 -- Current_Library_File_Stamp --
736 --------------------------------
738 function Current_Library_File_Stamp return Time_Stamp_Type is
740 return Current_Full_Lib_Stamp;
741 end Current_Library_File_Stamp;
743 -------------------------------
744 -- Current_Object_File_Stamp --
745 -------------------------------
747 function Current_Object_File_Stamp return Time_Stamp_Type is
749 return Current_Full_Obj_Stamp;
750 end Current_Object_File_Stamp;
752 -------------------------------
753 -- Current_Source_File_Stamp --
754 -------------------------------
756 function Current_Source_File_Stamp return Time_Stamp_Type is
758 return Current_Full_Source_Stamp;
759 end Current_Source_File_Stamp;
761 ----------------------------
762 -- Dir_In_Obj_Search_Path --
763 ----------------------------
765 function Dir_In_Obj_Search_Path (Position : Natural) return String_Ptr is
767 if Opt.Look_In_Primary_Dir then
769 Lib_Search_Directories.Table (Primary_Directory + Position - 1);
771 return Lib_Search_Directories.Table (Primary_Directory + Position);
773 end Dir_In_Obj_Search_Path;
775 ----------------------------
776 -- Dir_In_Src_Search_Path --
777 ----------------------------
779 function Dir_In_Src_Search_Path (Position : Natural) return String_Ptr is
781 if Opt.Look_In_Primary_Dir then
783 Src_Search_Directories.Table (Primary_Directory + Position - 1);
785 return Src_Search_Directories.Table (Primary_Directory + Position);
787 end Dir_In_Src_Search_Path;
789 ----------------------------
790 -- Dump_Source_File_Names --
791 ----------------------------
793 procedure Dump_Source_File_Names is
794 subtype Rng is Int range File_Name_Chars.First .. File_Name_Chars.Last;
796 Write_Str (String (File_Name_Chars.Table (Rng)));
797 end Dump_Source_File_Names;
799 ---------------------
800 -- Executable_Name --
801 ---------------------
803 function Executable_Name
804 (Name : File_Name_Type;
805 Only_If_No_Suffix : Boolean := False) return File_Name_Type
807 Exec_Suffix : String_Access;
808 Add_Suffix : Boolean;
811 if Name = No_File then
815 if Executable_Extension_On_Target = No_Name then
816 Exec_Suffix := Get_Target_Executable_Suffix;
818 Get_Name_String (Executable_Extension_On_Target);
819 Exec_Suffix := new String'(Name_Buffer
(1 .. Name_Len
));
822 if Exec_Suffix
'Length /= 0 then
823 Get_Name_String
(Name
);
826 if Only_If_No_Suffix
then
827 for J
in reverse 1 .. Name_Len
loop
828 if Name_Buffer
(J
) = '.' then
832 elsif Name_Buffer
(J
) = '/' or else
833 Name_Buffer
(J
) = Directory_Separator
842 Buffer
: String := Name_Buffer
(1 .. Name_Len
);
845 -- Get the file name in canonical case to accept as is names
846 -- ending with ".EXE" on VMS and Windows.
848 Canonical_Case_File_Name
(Buffer
);
850 -- If Executable does not end with the executable suffix, add
853 if Buffer
'Length <= Exec_Suffix
'Length
855 Buffer
(Buffer
'Last - Exec_Suffix
'Length + 1 .. Buffer
'Last)
859 (Name_Len
+ 1 .. Name_Len
+ Exec_Suffix
'Length) :=
861 Name_Len
:= Name_Len
+ Exec_Suffix
'Length;
873 function Executable_Name
875 Only_If_No_Suffix
: Boolean := False) return String
877 Exec_Suffix
: String_Access
;
878 Add_Suffix
: Boolean;
879 Canonical_Name
: String := Name
;
882 if Executable_Extension_On_Target
= No_Name
then
883 Exec_Suffix
:= Get_Target_Executable_Suffix
;
885 Get_Name_String
(Executable_Extension_On_Target
);
886 Exec_Suffix
:= new String'(Name_Buffer (1 .. Name_Len));
889 if Exec_Suffix'Length = 0 then
895 Suffix : constant String := Exec_Suffix.all;
899 Canonical_Case_File_Name (Canonical_Name);
902 if Only_If_No_Suffix then
903 for J in reverse Canonical_Name'Range loop
904 if Canonical_Name (J) = '.' then
908 elsif Canonical_Name (J) = '/' or else
909 Canonical_Name (J) = Directory_Separator
916 if Add_Suffix and then
917 (Canonical_Name'Length <= Suffix'Length
918 or else Canonical_Name (Canonical_Name'Last - Suffix'Length + 1
919 .. Canonical_Name'Last) /= Suffix)
922 Result : String (1 .. Name'Length + Suffix'Length);
924 Result (1 .. Name'Length) := Name;
925 Result (Name'Length + 1 .. Result'Last) := Suffix;
935 -----------------------
936 -- Executable_Prefix --
937 -----------------------
939 function Executable_Prefix return String_Ptr is
941 function Get_Install_Dir (Exec : String) return String_Ptr;
942 -- S is the executable name preceded by the absolute or relative
943 -- path, e.g. "c:\usr\bin\gcc.exe" or "..\bin\gcc".
945 ---------------------
946 -- Get_Install_Dir --
947 ---------------------
949 function Get_Install_Dir (Exec : String) return String_Ptr is
950 Full_Path : constant String := Normalize_Pathname (Exec);
951 -- Use the full path, so that we find "lib" or "bin", even when
952 -- the tool has been invoked with a relative path, as in
953 -- "./gnatls -v" invoked in the GNAT bin directory.
956 for J in reverse Full_Path'Range loop
957 if Is_Directory_Separator (Full_Path (J)) then
958 if J < Full_Path'Last - 5 then
959 if (To_Lower (Full_Path (J + 1)) = 'l
'
960 and then To_Lower (Full_Path (J + 2)) = 'i
'
961 and then To_Lower (Full_Path (J + 3)) = 'b
')
963 (To_Lower (Full_Path (J + 1)) = 'b
'
964 and then To_Lower (Full_Path (J + 2)) = 'i
'
965 and then To_Lower (Full_Path (J + 3)) = 'n
')
967 return new String'(Full_Path
(Full_Path
'First .. J
));
973 return new String'("");
976 -- Start of processing for Executable_Prefix
979 if Exec_Name = null then
980 Exec_Name := new String (1 .. Len_Arg (0));
981 Osint.Fill_Arg (Exec_Name (1)'Address, 0);
984 -- First determine if a path prefix was placed in front of the
987 for J in reverse Exec_Name'Range loop
988 if Is_Directory_Separator (Exec_Name (J)) then
989 return Get_Install_Dir (Exec_Name.all);
993 -- If we come here, the user has typed the executable name with no
996 return Get_Install_Dir (Locate_Exec_On_Path (Exec_Name.all).all);
997 end Executable_Prefix;
1003 procedure Exit_Program (Exit_Code : Exit_Code_Type) is
1005 -- The program will exit with the following status:
1007 -- 0 if the object file has been generated (with or without warnings)
1008 -- 1 if recompilation was not needed (smart recompilation)
1009 -- 2 if gnat1 has been killed by a signal (detected by GCC)
1010 -- 4 for a fatal error
1011 -- 5 if there were errors
1012 -- 6 if no code has been generated (spec)
1014 -- Note that exit code 3 is not used and must not be used as this is
1015 -- the code returned by a program aborted via C abort() routine on
1016 -- Windows. GCC checks for that case and thinks that the child process
1017 -- has been aborted. This code (exit code 3) used to be the code used
1018 -- for E_No_Code, but E_No_Code was changed to 6 for this reason.
1021 when E_Success => OS_Exit (0);
1022 when E_Warnings => OS_Exit (0);
1023 when E_No_Compile => OS_Exit (1);
1024 when E_Fatal => OS_Exit (4);
1025 when E_Errors => OS_Exit (5);
1026 when E_No_Code => OS_Exit (6);
1027 when E_Abort => OS_Abort;
1035 procedure Fail (S : String) is
1037 -- We use Output in case there is a special output set up.
1038 -- In this case Set_Standard_Error will have no immediate effect.
1041 Osint.Write_Program_Name;
1046 Exit_Program (E_Fatal);
1053 function File_Hash (F : File_Name_Type) return File_Hash_Num is
1055 return File_Hash_Num (Int (F) rem File_Hash_Num'Range_Length);
1062 function File_Length
1063 (Name : C_File_Name;
1064 Attr : access File_Attributes) return Long_Integer
1069 A : System.Address) return Long_Integer;
1070 pragma Import (C, Internal, "__gnat_file_length_attr");
1072 return Internal (-1, Name, Attr.all'Address);
1075 ---------------------
1076 -- File_Time_Stamp --
1077 ---------------------
1079 function File_Time_Stamp
1080 (Name : C_File_Name;
1081 Attr : access File_Attributes) return OS_Time
1083 function Internal (N : C_File_Name; A : System.Address) return OS_Time;
1084 pragma Import (C, Internal, "__gnat_file_time_name_attr");
1086 return Internal (Name, Attr.all'Address);
1087 end File_Time_Stamp;
1089 function File_Time_Stamp
1090 (Name : Path_Name_Type;
1091 Attr : access File_Attributes) return Time_Stamp_Type
1094 if Name = No_Path then
1095 return Empty_Time_Stamp;
1098 Get_Name_String (Name);
1099 Name_Buffer (Name_Len + 1) := ASCII.NUL;
1100 return OS_Time_To_GNAT_Time
1101 (File_Time_Stamp (Name_Buffer'Address, Attr));
1102 end File_Time_Stamp;
1108 function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type is
1110 if Name = No_File then
1111 return Empty_Time_Stamp;
1114 Get_Name_String (Name);
1116 -- File_Time_Stamp will always return Invalid_Time if the file does
1117 -- not exist, and OS_Time_To_GNAT_Time will convert this value to
1118 -- Empty_Time_Stamp. Therefore we do not need to first test whether
1119 -- the file actually exists, which saves a system call.
1121 return OS_Time_To_GNAT_Time
1122 (File_Time_Stamp (Name_Buffer (1 .. Name_Len)));
1125 function File_Stamp (Name : Path_Name_Type) return Time_Stamp_Type is
1127 return File_Stamp (File_Name_Type (Name));
1135 (N : File_Name_Type;
1136 T : File_Type) return File_Name_Type
1138 Attr : aliased File_Attributes;
1139 Found : File_Name_Type;
1141 Find_File (N, T, Found, Attr'Access);
1150 (N : File_Name_Type;
1152 Found : out File_Name_Type;
1153 Attr : access File_Attributes) is
1155 Get_Name_String (N);
1158 File_Name : String renames Name_Buffer (1 .. Name_Len);
1159 File : File_Name_Type := No_File;
1163 -- If we are looking for a config file, look only in the current
1164 -- directory, i.e. return input argument unchanged. Also look only in
1165 -- the curren directory if we are looking for a .dg file (happens in
1169 or else (Debug_Generated_Code
1170 and then Name_Len > 3
1172 (Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg"
1174 (Hostparm.OpenVMS and then
1175 Name_Buffer (Name_Len - 2 .. Name_Len) = "_dg")))
1178 Attr.all := Unknown_Attributes;
1181 -- If we are trying to find the current main file just look in the
1182 -- directory where the user said it was.
1184 elsif Look_In_Primary_Directory_For_Current_Main
1185 and then Current_Main = N
1187 Locate_File (N, T, Primary_Directory, File_Name, Found, Attr);
1190 -- Otherwise do standard search for source file
1193 -- Check the mapping of this file name
1195 File := Mapped_Path_Name (N);
1197 -- If the file name is mapped to a path name, return the
1198 -- corresponding path name
1200 if File /= No_File then
1202 -- For locally removed file, Error_Name is returned; then
1203 -- return No_File, indicating the file is not a source.
1205 if File = Error_File_Name then
1211 Attr.all := Unknown_Attributes;
1215 -- First place to look is in the primary directory (i.e. the same
1216 -- directory as the source) unless this has been disabled with -I-
1218 if Opt.Look_In_Primary_Dir then
1219 Locate_File (N, T, Primary_Directory, File_Name, Found, Attr);
1221 if Found /= No_File then
1226 -- Finally look in directories specified with switches -I/-aI/-aO
1229 Last_Dir := Lib_Search_Directories.Last;
1231 Last_Dir := Src_Search_Directories.Last;
1234 for D in Primary_Directory + 1 .. Last_Dir loop
1235 Locate_File (N, T, D, File_Name, Found, Attr);
1237 if Found /= No_File then
1242 Attr.all := Unknown_Attributes;
1248 -----------------------
1249 -- Find_Program_Name --
1250 -----------------------
1252 procedure Find_Program_Name is
1253 Command_Name : String (1 .. Len_Arg (0));
1254 Cindex1 : Integer := Command_Name'First;
1255 Cindex2 : Integer := Command_Name'Last;
1258 Fill_Arg (Command_Name'Address, 0);
1260 if Command_Name = "" then
1265 -- The program name might be specified by a full path name. However,
1266 -- we don't want to print that all out in an error message, so the
1267 -- path might need to be stripped away.
1269 for J in reverse Cindex1 .. Cindex2 loop
1270 if Is_Directory_Separator (Command_Name (J)) then
1276 -- Command_Name(Cindex1 .. Cindex2) is now the equivalent of the
1277 -- POSIX command "basename argv[0]"
1279 -- Strip off any versioning information such as found on VMS.
1280 -- This would take the form of TOOL.exe followed by a ";" or "."
1281 -- and a sequence of one or more numbers.
1283 if Command_Name (Cindex2) in '0' .. '9' then
1284 for J in reverse Cindex1 .. Cindex2 loop
1285 if Command_Name (J) = '.' or else Command_Name (J) = ';' then
1290 exit when Command_Name (J) not in '0' .. '9';
1294 -- Strip off any executable extension (usually nothing or .exe)
1295 -- but formally reported by autoconf in the variable EXEEXT
1297 if Cindex2 - Cindex1 >= 4 then
1298 if To_Lower (Command_Name (Cindex2 - 3)) = '.'
1299 and then To_Lower (Command_Name (Cindex2 - 2)) = 'e
'
1300 and then To_Lower (Command_Name (Cindex2 - 1)) = 'x
'
1301 and then To_Lower (Command_Name (Cindex2)) = 'e
'
1303 Cindex2 := Cindex2 - 4;
1307 Name_Len := Cindex2 - Cindex1 + 1;
1308 Name_Buffer (1 .. Name_Len) := Command_Name (Cindex1 .. Cindex2);
1309 end Find_Program_Name;
1311 ------------------------
1312 -- Full_Lib_File_Name --
1313 ------------------------
1315 procedure Full_Lib_File_Name
1316 (N : File_Name_Type;
1317 Lib_File : out File_Name_Type;
1318 Attr : out File_Attributes)
1320 A : aliased File_Attributes;
1322 -- ??? seems we could use Smart_Find_File here
1323 Find_File (N, Library, Lib_File, A'Access);
1325 end Full_Lib_File_Name;
1327 ------------------------
1328 -- Full_Lib_File_Name --
1329 ------------------------
1331 function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type is
1332 Attr : File_Attributes;
1333 File : File_Name_Type;
1335 Full_Lib_File_Name (N, File, Attr);
1337 end Full_Lib_File_Name;
1339 ----------------------------
1340 -- Full_Library_Info_Name --
1341 ----------------------------
1343 function Full_Library_Info_Name return File_Name_Type is
1345 return Current_Full_Lib_Name;
1346 end Full_Library_Info_Name;
1348 ---------------------------
1349 -- Full_Object_File_Name --
1350 ---------------------------
1352 function Full_Object_File_Name return File_Name_Type is
1354 return Current_Full_Obj_Name;
1355 end Full_Object_File_Name;
1357 ----------------------
1358 -- Full_Source_Name --
1359 ----------------------
1361 function Full_Source_Name return File_Name_Type is
1363 return Current_Full_Source_Name;
1364 end Full_Source_Name;
1366 ----------------------
1367 -- Full_Source_Name --
1368 ----------------------
1370 function Full_Source_Name (N : File_Name_Type) return File_Name_Type is
1372 return Smart_Find_File (N, Source);
1373 end Full_Source_Name;
1375 ----------------------
1376 -- Full_Source_Name --
1377 ----------------------
1379 procedure Full_Source_Name
1380 (N : File_Name_Type;
1381 Full_File : out File_Name_Type;
1382 Attr : access File_Attributes) is
1384 Smart_Find_File (N, Source, Full_File, Attr.all);
1385 end Full_Source_Name;
1391 function Get_Directory (Name : File_Name_Type) return File_Name_Type is
1393 Get_Name_String (Name);
1395 for J in reverse 1 .. Name_Len loop
1396 if Is_Directory_Separator (Name_Buffer (J)) then
1402 Name_Len := Hostparm.Normalized_CWD'Length;
1403 Name_Buffer (1 .. Name_Len) := Hostparm.Normalized_CWD;
1407 --------------------------
1408 -- Get_Next_Dir_In_Path --
1409 --------------------------
1411 Search_Path_Pos : Integer;
1412 -- Keeps track of current position in search path. Initialized by the
1413 -- call to Get_Next_Dir_In_Path_Init, updated by Get_Next_Dir_In_Path.
1415 function Get_Next_Dir_In_Path
1416 (Search_Path : String_Access) return String_Access
1418 Lower_Bound : Positive := Search_Path_Pos;
1419 Upper_Bound : Positive;
1423 while Lower_Bound <= Search_Path'Last
1424 and then Search_Path.all (Lower_Bound) = Path_Separator
1426 Lower_Bound := Lower_Bound + 1;
1429 exit when Lower_Bound > Search_Path'Last;
1431 Upper_Bound := Lower_Bound;
1432 while Upper_Bound <= Search_Path'Last
1433 and then Search_Path.all (Upper_Bound) /= Path_Separator
1435 Upper_Bound := Upper_Bound + 1;
1438 Search_Path_Pos := Upper_Bound;
1439 return new String'(Search_Path
.all (Lower_Bound
.. Upper_Bound
- 1));
1443 end Get_Next_Dir_In_Path
;
1445 -------------------------------
1446 -- Get_Next_Dir_In_Path_Init --
1447 -------------------------------
1449 procedure Get_Next_Dir_In_Path_Init
(Search_Path
: String_Access
) is
1451 Search_Path_Pos
:= Search_Path
'First;
1452 end Get_Next_Dir_In_Path_Init
;
1454 --------------------------------------
1455 -- Get_Primary_Src_Search_Directory --
1456 --------------------------------------
1458 function Get_Primary_Src_Search_Directory
return String_Ptr
is
1460 return Src_Search_Directories
.Table
(Primary_Directory
);
1461 end Get_Primary_Src_Search_Directory
;
1463 ------------------------
1464 -- Get_RTS_Search_Dir --
1465 ------------------------
1467 function Get_RTS_Search_Dir
1468 (Search_Dir
: String;
1469 File_Type
: Search_File_Type
) return String_Ptr
1471 procedure Get_Current_Dir
1472 (Dir
: System
.Address
;
1473 Length
: System
.Address
);
1474 pragma Import
(C
, Get_Current_Dir
, "__gnat_get_current_dir");
1477 pragma Import
(C
, Max_Path
, "__gnat_max_path_len");
1478 -- Maximum length of a path name
1480 Current_Dir
: String_Ptr
;
1481 Default_Search_Dir
: String_Access
;
1482 Default_Suffix_Dir
: String_Access
;
1483 Local_Search_Dir
: String_Access
;
1484 Norm_Search_Dir
: String_Access
;
1485 Result_Search_Dir
: String_Access
;
1486 Search_File
: String_Access
;
1487 Temp_String
: String_Ptr
;
1490 -- Add a directory separator at the end of the directory if necessary
1491 -- so that we can directly append a file to the directory
1493 if Search_Dir
(Search_Dir
'Last) /= Directory_Separator
then
1495 new String'(Search_Dir & String'(1 => Directory_Separator
));
1497 Local_Search_Dir
:= new String'(Search_Dir);
1500 if File_Type = Include then
1501 Search_File := Include_Search_File;
1502 Default_Suffix_Dir := new String'("adainclude");
1504 Search_File
:= Objects_Search_File
;
1505 Default_Suffix_Dir
:= new String'("adalib");
1508 Norm_Search_Dir := To_Canonical_Path_Spec (Local_Search_Dir.all);
1510 if Is_Absolute_Path (Norm_Search_Dir.all) then
1512 -- We first verify if there is a directory Include_Search_Dir
1513 -- containing default search directories
1515 Result_Search_Dir :=
1516 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1517 Default_Search_Dir :=
1518 new String'(Norm_Search_Dir
.all & Default_Suffix_Dir
.all);
1519 Free
(Norm_Search_Dir
);
1521 if Result_Search_Dir
/= null then
1522 return String_Ptr
(Result_Search_Dir
);
1523 elsif Is_Directory
(Default_Search_Dir
.all) then
1524 return String_Ptr
(Default_Search_Dir
);
1529 -- Search in the current directory
1532 -- Get the current directory
1535 Buffer
: String (1 .. Max_Path
+ 2);
1536 Path_Len
: Natural := Max_Path
;
1539 Get_Current_Dir
(Buffer
'Address, Path_Len
'Address);
1541 if Buffer
(Path_Len
) /= Directory_Separator
then
1542 Path_Len
:= Path_Len
+ 1;
1543 Buffer
(Path_Len
) := Directory_Separator
;
1546 Current_Dir
:= new String'(Buffer (1 .. Path_Len));
1550 new String'(Current_Dir
.all & Local_Search_Dir
.all);
1552 Result_Search_Dir
:=
1553 Read_Default_Search_Dirs
(Norm_Search_Dir
, Search_File
, null);
1555 Default_Search_Dir
:=
1556 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1558 Free (Norm_Search_Dir);
1560 if Result_Search_Dir /= null then
1561 return String_Ptr (Result_Search_Dir);
1563 elsif Is_Directory (Default_Search_Dir.all) then
1564 return String_Ptr (Default_Search_Dir);
1567 -- Search in Search_Dir_Prefix/Search_Dir
1571 (Update_Path
(Search_Dir_Prefix
).all & Local_Search_Dir
.all);
1573 Result_Search_Dir
:=
1574 Read_Default_Search_Dirs
(Norm_Search_Dir
, Search_File
, null);
1576 Default_Search_Dir
:=
1577 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1579 Free (Norm_Search_Dir);
1581 if Result_Search_Dir /= null then
1582 return String_Ptr (Result_Search_Dir);
1584 elsif Is_Directory (Default_Search_Dir.all) then
1585 return String_Ptr (Default_Search_Dir);
1588 -- We finally search in Search_Dir_Prefix/rts-Search_Dir
1591 new String'(Update_Path
(Search_Dir_Prefix
).all & "rts-");
1594 new String'(Temp_String.all & Local_Search_Dir.all);
1596 Result_Search_Dir :=
1597 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1599 Default_Search_Dir :=
1600 new String'(Norm_Search_Dir
.all & Default_Suffix_Dir
.all);
1601 Free
(Norm_Search_Dir
);
1603 if Result_Search_Dir
/= null then
1604 return String_Ptr
(Result_Search_Dir
);
1606 elsif Is_Directory
(Default_Search_Dir
.all) then
1607 return String_Ptr
(Default_Search_Dir
);
1615 end Get_RTS_Search_Dir
;
1617 --------------------------------
1618 -- Include_Dir_Default_Prefix --
1619 --------------------------------
1621 function Include_Dir_Default_Prefix
return String_Access
is
1623 if The_Include_Dir_Default_Prefix
= null then
1624 The_Include_Dir_Default_Prefix
:=
1625 String_Access
(Update_Path
(Include_Dir_Default_Name
));
1628 return The_Include_Dir_Default_Prefix
;
1629 end Include_Dir_Default_Prefix
;
1631 function Include_Dir_Default_Prefix
return String is
1633 return Include_Dir_Default_Prefix
.all;
1634 end Include_Dir_Default_Prefix
;
1640 procedure Initialize
is
1642 Number_File_Names
:= 0;
1643 Current_File_Name_Index
:= 0;
1645 Src_Search_Directories
.Init
;
1646 Lib_Search_Directories
.Init
;
1648 -- Start off by setting all suppress options to False, these will
1649 -- be reset later (turning some on if -gnato is not specified, and
1650 -- turning all of them on if -gnatp is specified).
1652 Suppress_Options
:= (others => False);
1654 -- Reserve the first slot in the search paths table. This is the
1655 -- directory of the main source file or main library file and is filled
1656 -- in by each call to Next_Main_Source/Next_Main_Lib_File with the
1657 -- directory specified for this main source or library file. This is the
1658 -- directory which is searched first by default. This default search is
1659 -- inhibited by the option -I- for both source and library files.
1661 Src_Search_Directories
.Set_Last
(Primary_Directory
);
1662 Src_Search_Directories
.Table
(Primary_Directory
) := new String'("");
1664 Lib_Search_Directories.Set_Last (Primary_Directory);
1665 Lib_Search_Directories.Table (Primary_Directory) := new String'("");
1672 function Is_Directory
1673 (Name
: C_File_Name
; Attr
: access File_Attributes
) return Boolean
1675 function Internal
(N
: C_File_Name
; A
: System
.Address
) return Integer;
1676 pragma Import
(C
, Internal
, "__gnat_is_directory_attr");
1678 return Internal
(Name
, Attr
.all'Address) /= 0;
1681 ----------------------------
1682 -- Is_Directory_Separator --
1683 ----------------------------
1685 function Is_Directory_Separator
(C
: Character) return Boolean is
1687 -- In addition to the default directory_separator allow the '/' to
1688 -- act as separator since this is allowed in MS-DOS, Windows 95/NT,
1689 -- and OS2 ports. On VMS, the situation is more complicated because
1690 -- there are two characters to check for.
1693 C
= Directory_Separator
1695 or else (Hostparm
.OpenVMS
1696 and then (C
= ']' or else C
= ':'));
1697 end Is_Directory_Separator
;
1699 -------------------------
1700 -- Is_Readonly_Library --
1701 -------------------------
1703 function Is_Readonly_Library
(File
: File_Name_Type
) return Boolean is
1705 Get_Name_String
(File
);
1707 pragma Assert
(Name_Buffer
(Name_Len
- 3 .. Name_Len
) = ".ali");
1709 return not Is_Writable_File
(Name_Buffer
(1 .. Name_Len
));
1710 end Is_Readonly_Library
;
1712 ------------------------
1713 -- Is_Executable_File --
1714 ------------------------
1716 function Is_Executable_File
1717 (Name
: C_File_Name
; Attr
: access File_Attributes
) return Boolean
1719 function Internal
(N
: C_File_Name
; A
: System
.Address
) return Integer;
1720 pragma Import
(C
, Internal
, "__gnat_is_executable_file_attr");
1722 return Internal
(Name
, Attr
.all'Address) /= 0;
1723 end Is_Executable_File
;
1725 ----------------------
1726 -- Is_Readable_File --
1727 ----------------------
1729 function Is_Readable_File
1730 (Name
: C_File_Name
; Attr
: access File_Attributes
) return Boolean
1732 function Internal
(N
: C_File_Name
; A
: System
.Address
) return Integer;
1733 pragma Import
(C
, Internal
, "__gnat_is_readable_file_attr");
1735 return Internal
(Name
, Attr
.all'Address) /= 0;
1736 end Is_Readable_File
;
1738 ---------------------
1739 -- Is_Regular_File --
1740 ---------------------
1742 function Is_Regular_File
1743 (Name
: C_File_Name
; Attr
: access File_Attributes
) return Boolean
1745 function Internal
(N
: C_File_Name
; A
: System
.Address
) return Integer;
1746 pragma Import
(C
, Internal
, "__gnat_is_regular_file_attr");
1748 return Internal
(Name
, Attr
.all'Address) /= 0;
1749 end Is_Regular_File
;
1751 ----------------------
1752 -- Is_Symbolic_Link --
1753 ----------------------
1755 function Is_Symbolic_Link
1756 (Name
: C_File_Name
; Attr
: access File_Attributes
) return Boolean
1758 function Internal
(N
: C_File_Name
; A
: System
.Address
) return Integer;
1759 pragma Import
(C
, Internal
, "__gnat_is_symbolic_link_attr");
1761 return Internal
(Name
, Attr
.all'Address) /= 0;
1762 end Is_Symbolic_Link
;
1764 ----------------------
1765 -- Is_Writable_File --
1766 ----------------------
1768 function Is_Writable_File
1769 (Name
: C_File_Name
; Attr
: access File_Attributes
) return Boolean
1771 function Internal
(N
: C_File_Name
; A
: System
.Address
) return Integer;
1772 pragma Import
(C
, Internal
, "__gnat_is_writable_file_attr");
1774 return Internal
(Name
, Attr
.all'Address) /= 0;
1775 end Is_Writable_File
;
1781 function Lib_File_Name
1782 (Source_File
: File_Name_Type
;
1783 Munit_Index
: Nat
:= 0) return File_Name_Type
1786 Get_Name_String
(Source_File
);
1788 for J
in reverse 2 .. Name_Len
loop
1789 if Name_Buffer
(J
) = '.' then
1795 if Munit_Index
/= 0 then
1796 Add_Char_To_Name_Buffer
(Multi_Unit_Index_Character
);
1797 Add_Nat_To_Name_Buffer
(Munit_Index
);
1800 Add_Char_To_Name_Buffer
('.');
1801 Add_Str_To_Name_Buffer
(ALI_Suffix
.all);
1809 procedure Locate_File
1810 (N
: File_Name_Type
;
1814 Found
: out File_Name_Type
;
1815 Attr
: access File_Attributes
)
1817 Dir_Name
: String_Ptr
;
1820 -- If Name is already an absolute path, do not look for a directory
1822 if Is_Absolute_Path
(Name
) then
1825 elsif T
= Library
then
1826 Dir_Name
:= Lib_Search_Directories
.Table
(Dir
);
1829 pragma Assert
(T
/= Config
);
1830 Dir_Name
:= Src_Search_Directories
.Table
(Dir
);
1834 Full_Name
: String (1 .. Dir_Name
'Length + Name
'Length + 1);
1837 Full_Name
(1 .. Dir_Name
'Length) := Dir_Name
.all;
1838 Full_Name
(Dir_Name
'Length + 1 .. Full_Name
'Last - 1) := Name
;
1839 Full_Name
(Full_Name
'Last) := ASCII
.NUL
;
1841 Attr
.all := Unknown_Attributes
;
1843 if not Is_Regular_File
(Full_Name
'Address, Attr
) then
1847 -- If the file is in the current directory then return N itself
1849 if Dir_Name
'Length = 0 then
1852 Name_Len
:= Full_Name
'Length - 1;
1853 Name_Buffer
(1 .. Name_Len
) :=
1854 Full_Name
(1 .. Full_Name
'Last - 1);
1855 Found
:= Name_Find
; -- ??? Was Name_Enter, no obvious reason
1861 -------------------------------
1862 -- Matching_Full_Source_Name --
1863 -------------------------------
1865 function Matching_Full_Source_Name
1866 (N
: File_Name_Type
;
1867 T
: Time_Stamp_Type
) return File_Name_Type
1870 Get_Name_String
(N
);
1873 File_Name
: constant String := Name_Buffer
(1 .. Name_Len
);
1874 File
: File_Name_Type
:= No_File
;
1875 Attr
: aliased File_Attributes
;
1879 if Opt
.Look_In_Primary_Dir
then
1881 (N
, Source
, Primary_Directory
, File_Name
, File
, Attr
'Access);
1883 if File
/= No_File
and then T
= File_Stamp
(N
) then
1888 Last_Dir
:= Src_Search_Directories
.Last
;
1890 for D
in Primary_Directory
+ 1 .. Last_Dir
loop
1891 Locate_File
(N
, Source
, D
, File_Name
, File
, Attr
'Access);
1893 if File
/= No_File
and then T
= File_Stamp
(File
) then
1900 end Matching_Full_Source_Name
;
1906 function More_Files
return Boolean is
1908 return (Current_File_Name_Index
< Number_File_Names
);
1911 -------------------------------
1912 -- Nb_Dir_In_Obj_Search_Path --
1913 -------------------------------
1915 function Nb_Dir_In_Obj_Search_Path
return Natural is
1917 if Opt
.Look_In_Primary_Dir
then
1918 return Lib_Search_Directories
.Last
- Primary_Directory
+ 1;
1920 return Lib_Search_Directories
.Last
- Primary_Directory
;
1922 end Nb_Dir_In_Obj_Search_Path
;
1924 -------------------------------
1925 -- Nb_Dir_In_Src_Search_Path --
1926 -------------------------------
1928 function Nb_Dir_In_Src_Search_Path
return Natural is
1930 if Opt
.Look_In_Primary_Dir
then
1931 return Src_Search_Directories
.Last
- Primary_Directory
+ 1;
1933 return Src_Search_Directories
.Last
- Primary_Directory
;
1935 end Nb_Dir_In_Src_Search_Path
;
1937 --------------------
1938 -- Next_Main_File --
1939 --------------------
1941 function Next_Main_File
return File_Name_Type
is
1942 File_Name
: String_Ptr
;
1943 Dir_Name
: String_Ptr
;
1947 pragma Assert
(More_Files
);
1949 Current_File_Name_Index
:= Current_File_Name_Index
+ 1;
1951 -- Get the file and directory name
1953 File_Name
:= File_Names
(Current_File_Name_Index
);
1954 Fptr
:= File_Name
'First;
1956 for J
in reverse File_Name
'Range loop
1957 if File_Name
(J
) = Directory_Separator
1958 or else File_Name
(J
) = '/'
1960 if J
= File_Name
'Last then
1961 Fail
("File name missing");
1969 -- Save name of directory in which main unit resides for use in
1970 -- locating other units
1972 Dir_Name
:= new String'(File_Name (File_Name'First .. Fptr - 1));
1974 case Running_Program is
1977 Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
1978 Look_In_Primary_Directory_For_Current_Main := True;
1981 Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
1983 if Fptr > File_Name'First then
1984 Look_In_Primary_Directory_For_Current_Main := True;
1987 when Binder | Gnatls =>
1988 Dir_Name := Normalize_Directory_Name (Dir_Name.all);
1989 Lib_Search_Directories.Table (Primary_Directory) := Dir_Name;
1995 Name_Len := File_Name'Last - Fptr + 1;
1996 Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last);
1997 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
1998 Current_Main := Name_Find;
2000 -- In the gnatmake case, the main file may have not have the
2001 -- extension. Try ".adb" first then ".ads"
2003 if Running_Program = Make then
2005 Orig_Main : constant File_Name_Type := Current_Main;
2008 if Strip_Suffix (Orig_Main) = Orig_Main then
2010 Append_Suffix_To_File_Name (Orig_Main, ".adb");
2012 if Full_Source_Name (Current_Main) = No_File then
2014 Append_Suffix_To_File_Name (Orig_Main, ".ads");
2016 if Full_Source_Name (Current_Main) = No_File then
2017 Current_Main := Orig_Main;
2024 return Current_Main;
2027 ------------------------------
2028 -- Normalize_Directory_Name --
2029 ------------------------------
2031 function Normalize_Directory_Name (Directory : String) return String_Ptr is
2033 function Is_Quoted (Path : String) return Boolean;
2034 pragma Inline (Is_Quoted);
2035 -- Returns true if Path is quoted (either double or single quotes)
2041 function Is_Quoted (Path : String) return Boolean is
2042 First : constant Character := Path (Path'First);
2043 Last : constant Character := Path (Path'Last);
2046 if (First = ''' and then Last = ''')
2048 (First = '"' and then Last = '"')
2056 Result : String_Ptr;
2058 -- Start of processing for Normalize_Directory_Name
2061 if Directory'Length = 0 then
2062 Result := new String'(Hostparm
.Normalized_CWD
);
2064 elsif Is_Directory_Separator
(Directory
(Directory
'Last)) then
2065 Result
:= new String'(Directory);
2067 elsif Is_Quoted (Directory) then
2069 -- This is a quoted string, it certainly means that the directory
2070 -- contains some spaces for example. We can safely remove the quotes
2071 -- here as the OS_Lib.Normalize_Arguments will be called before any
2072 -- spawn routines. This ensure that quotes will be added when needed.
2074 Result := new String (1 .. Directory'Length - 1);
2075 Result (1 .. Directory'Length - 2) :=
2076 Directory (Directory'First + 1 .. Directory'Last - 1);
2077 Result (Result'Last) := Directory_Separator;
2080 Result := new String (1 .. Directory'Length + 1);
2081 Result (1 .. Directory'Length) := Directory;
2082 Result (Directory'Length + 1) := Directory_Separator;
2086 end Normalize_Directory_Name;
2088 ---------------------
2089 -- Number_Of_Files --
2090 ---------------------
2092 function Number_Of_Files return Int is
2094 return Number_File_Names;
2095 end Number_Of_Files;
2097 -------------------------------
2098 -- Object_Dir_Default_Prefix --
2099 -------------------------------
2101 function Object_Dir_Default_Prefix return String is
2102 Object_Dir : String_Access :=
2103 String_Access (Update_Path (Object_Dir_Default_Name));
2106 if Object_Dir = null then
2111 Result : constant String := Object_Dir.all;
2117 end Object_Dir_Default_Prefix;
2119 ----------------------
2120 -- Object_File_Name --
2121 ----------------------
2123 function Object_File_Name (N : File_Name_Type) return File_Name_Type is
2129 Get_Name_String (N);
2130 Name_Len := Name_Len - ALI_Suffix'Length - 1;
2132 for J in Target_Object_Suffix'Range loop
2133 Name_Len := Name_Len + 1;
2134 Name_Buffer (Name_Len) := Target_Object_Suffix (J);
2138 end Object_File_Name;
2140 -------------------------------
2141 -- OS_Exit_Through_Exception --
2142 -------------------------------
2144 procedure OS_Exit_Through_Exception (Status : Integer) is
2146 Current_Exit_Status := Status;
2147 raise Types.Terminate_Program;
2148 end OS_Exit_Through_Exception;
2150 --------------------------
2151 -- OS_Time_To_GNAT_Time --
2152 --------------------------
2154 function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type is
2155 GNAT_Time : Time_Stamp_Type;
2165 if T = Invalid_Time then
2166 return Empty_Time_Stamp;
2169 GM_Split (T, Y, Mo, D, H, Mn, S);
2175 Minutes => Nat (Mn),
2180 end OS_Time_To_GNAT_Time;
2186 function Program_Name (Nam : String; Prog : String) return String_Access is
2187 End_Of_Prefix : Natural := 0;
2188 Start_Of_Prefix : Positive := 1;
2189 Start_Of_Suffix : Positive;
2192 -- GNAAMP tool names require special treatment
2194 if AAMP_On_Target then
2196 -- The name "gcc" is mapped to "gnaamp" (the compiler driver)
2199 return new String'("gnaamp");
2201 -- Tool names starting with "gnat" are mapped by substituting the
2202 -- string "gnaamp" for "gnat" (for example, "gnatpp" => "gnaamppp").
2204 elsif Nam
'Length >= 4
2205 and then Nam
(Nam
'First .. Nam
'First + 3) = "gnat"
2207 return new String'("gnaamp" & Nam (Nam'First + 4 .. Nam'Last));
2209 -- No other mapping rules, so we continue and handle any other forms
2210 -- of tool names the same as on other targets.
2217 -- Get the name of the current program being executed
2221 Start_Of_Suffix := Name_Len + 1;
2223 -- Find the target prefix if any, for the cross compilation case.
2224 -- For instance in "powerpc-elf-gcc" the target prefix is
2226 -- Ditto for suffix, e.g. in "gcc-4.1", the suffix is "-4.1"
2228 for J in reverse 1 .. Name_Len loop
2229 if Name_Buffer (J) = '/'
2230 or else Name_Buffer (J) = Directory_Separator
2231 or else Name_Buffer (J) = ':'
2233 Start_Of_Prefix := J + 1;
2238 -- Find End_Of_Prefix
2240 for J in Start_Of_Prefix .. Name_Len - Prog'Length + 1 loop
2241 if Name_Buffer (J .. J + Prog'Length - 1) = Prog then
2242 End_Of_Prefix := J - 1;
2247 if End_Of_Prefix > 1 then
2248 Start_Of_Suffix := End_Of_Prefix + Prog'Length + 1;
2251 -- Create the new program name
2254 (Name_Buffer
(Start_Of_Prefix
.. End_Of_Prefix
)
2256 & Name_Buffer
(Start_Of_Suffix
.. Name_Len
));
2259 ------------------------------
2260 -- Read_Default_Search_Dirs --
2261 ------------------------------
2263 function Read_Default_Search_Dirs
2264 (Search_Dir_Prefix
: String_Access
;
2265 Search_File
: String_Access
;
2266 Search_Dir_Default_Name
: String_Access
) return String_Access
2268 Prefix_Len
: constant Integer := Search_Dir_Prefix
.all'Length;
2269 Buffer
: String (1 .. Prefix_Len
+ Search_File
.all'Length + 1);
2270 File_FD
: File_Descriptor
;
2271 S
, S1
: String_Access
;
2274 Actual_Len
: Integer;
2277 Prev_Was_Separator
: Boolean;
2278 Nb_Relative_Dir
: Integer;
2280 function Is_Relative
(S
: String; K
: Positive) return Boolean;
2281 pragma Inline
(Is_Relative
);
2282 -- Returns True if a relative directory specification is found
2283 -- in S at position K, False otherwise.
2289 function Is_Relative
(S
: String; K
: Positive) return Boolean is
2291 return not Is_Absolute_Path
(S
(K
.. S
'Last));
2294 -- Start of processing for Read_Default_Search_Dirs
2297 -- Construct a C compatible character string buffer
2299 Buffer
(1 .. Search_Dir_Prefix
.all'Length)
2300 := Search_Dir_Prefix
.all;
2301 Buffer
(Search_Dir_Prefix
.all'Length + 1 .. Buffer
'Last - 1)
2303 Buffer
(Buffer
'Last) := ASCII
.NUL
;
2305 File_FD
:= Open_Read
(Buffer
'Address, Binary
);
2306 if File_FD
= Invalid_FD
then
2307 return Search_Dir_Default_Name
;
2310 Len
:= Integer (File_Length
(File_FD
));
2312 -- An extra character for a trailing Path_Separator is allocated
2314 S
:= new String (1 .. Len
+ 1);
2315 S
(Len
+ 1) := Path_Separator
;
2317 -- Read the file. Note that the loop is not necessary since the
2318 -- whole file is read at once except on VMS.
2322 while Actual_Len
/= 0 loop
2323 Actual_Len
:= Read
(File_FD
, S
(Curr
)'Address, Len
);
2324 Curr
:= Curr
+ Actual_Len
;
2327 -- Process the file, dealing with path separators
2329 Prev_Was_Separator
:= True;
2330 Nb_Relative_Dir
:= 0;
2331 for J
in 1 .. Len
loop
2333 -- Treat any control character as a path separator. Note that we do
2334 -- not treat space as a path separator (we used to treat space as a
2335 -- path separator in an earlier version). That way space can appear
2336 -- as a legitimate character in a path name.
2338 -- Why do we treat all control characters as path separators???
2340 if S
(J
) in ASCII
.NUL
.. ASCII
.US
then
2341 S
(J
) := Path_Separator
;
2344 -- Test for explicit path separator (or control char as above)
2346 if S
(J
) = Path_Separator
then
2347 Prev_Was_Separator
:= True;
2349 -- If not path separator, register use of relative directory
2352 if Prev_Was_Separator
and then Is_Relative
(S
.all, J
) then
2353 Nb_Relative_Dir
:= Nb_Relative_Dir
+ 1;
2356 Prev_Was_Separator
:= False;
2360 if Nb_Relative_Dir
= 0 then
2364 -- Add the Search_Dir_Prefix to all relative paths
2366 S1
:= new String (1 .. S
'Length + Nb_Relative_Dir
* Prefix_Len
);
2368 Prev_Was_Separator
:= True;
2369 for J
in 1 .. Len
+ 1 loop
2370 if S
(J
) = Path_Separator
then
2371 Prev_Was_Separator
:= True;
2374 if Prev_Was_Separator
and then Is_Relative
(S
.all, J
) then
2375 S1
(J1
.. J1
+ Prefix_Len
- 1) := Search_Dir_Prefix
.all;
2376 J1
:= J1
+ Prefix_Len
;
2379 Prev_Was_Separator
:= False;
2387 end Read_Default_Search_Dirs
;
2389 -----------------------
2390 -- Read_Library_Info --
2391 -----------------------
2393 function Read_Library_Info
2394 (Lib_File
: File_Name_Type
;
2395 Fatal_Err
: Boolean := False) return Text_Buffer_Ptr
2397 File
: File_Name_Type
;
2398 Attr
: aliased File_Attributes
;
2400 Find_File
(Lib_File
, Library
, File
, Attr
'Access);
2401 return Read_Library_Info_From_Full
2402 (Full_Lib_File
=> File
,
2403 Lib_File_Attr
=> Attr
'Access,
2404 Fatal_Err
=> Fatal_Err
);
2405 end Read_Library_Info
;
2407 ---------------------------------
2408 -- Read_Library_Info_From_Full --
2409 ---------------------------------
2411 function Read_Library_Info_From_Full
2412 (Full_Lib_File
: File_Name_Type
;
2413 Lib_File_Attr
: access File_Attributes
;
2414 Fatal_Err
: Boolean := False) return Text_Buffer_Ptr
2416 Lib_FD
: File_Descriptor
;
2417 -- The file descriptor for the current library file. A negative value
2418 -- indicates failure to open the specified source file.
2421 -- Length of source file text (ALI). If it doesn't fit in an integer
2422 -- we're probably stuck anyway (>2 gigs of source seems a lot!)
2424 Text
: Text_Buffer_Ptr
;
2425 -- Allocated text buffer
2428 pragma Warnings
(Off
, Status
);
2429 -- For the calls to Close
2432 Current_Full_Lib_Name
:= Full_Lib_File
;
2433 Current_Full_Obj_Name
:= Object_File_Name
(Current_Full_Lib_Name
);
2435 if Current_Full_Lib_Name
= No_File
then
2437 Fail
("Cannot find: " & Name_Buffer
(1 .. Name_Len
));
2439 Current_Full_Obj_Stamp
:= Empty_Time_Stamp
;
2444 Get_Name_String
(Current_Full_Lib_Name
);
2445 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
2447 -- Open the library FD, note that we open in binary mode, because as
2448 -- documented in the spec, the caller is expected to handle either
2449 -- DOS or Unix mode files, and there is no point in wasting time on
2450 -- text translation when it is not required.
2452 Lib_FD
:= Open_Read
(Name_Buffer
'Address, Binary
);
2454 if Lib_FD
= Invalid_FD
then
2456 Fail
("Cannot open: " & Name_Buffer
(1 .. Name_Len
));
2458 Current_Full_Obj_Stamp
:= Empty_Time_Stamp
;
2463 -- Compute the length of the file (potentially also preparing other data
2464 -- like the timestamp and whether the file is read-only, for future use)
2466 Len
:= Integer (File_Length
(Name_Buffer
'Address, Lib_File_Attr
));
2468 -- Check for object file consistency if requested
2470 if Opt
.Check_Object_Consistency
then
2471 -- On most systems, this does not result in an extra system call
2473 Current_Full_Lib_Stamp
:=
2474 OS_Time_To_GNAT_Time
2475 (File_Time_Stamp
(Name_Buffer
'Address, Lib_File_Attr
));
2477 -- ??? One system call here
2479 Current_Full_Obj_Stamp
:= File_Stamp
(Current_Full_Obj_Name
);
2481 if Current_Full_Obj_Stamp
(1) = ' ' then
2483 -- When the library is readonly always assume object is consistent
2484 -- The call to Is_Writable_File only results in a system call on
2485 -- some systems, but in most cases it has already been computed as
2486 -- part of the call to File_Length above.
2488 Get_Name_String
(Current_Full_Lib_Name
);
2489 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
2491 if not Is_Writable_File
(Name_Buffer
'Address, Lib_File_Attr
) then
2492 Current_Full_Obj_Stamp
:= Current_Full_Lib_Stamp
;
2494 elsif Fatal_Err
then
2495 Get_Name_String
(Current_Full_Obj_Name
);
2496 Close
(Lib_FD
, Status
);
2498 -- No need to check the status, we fail anyway
2500 Fail
("Cannot find: " & Name_Buffer
(1 .. Name_Len
));
2503 Current_Full_Obj_Stamp
:= Empty_Time_Stamp
;
2504 Close
(Lib_FD
, Status
);
2506 -- No need to check the status, we return null anyway
2513 -- Read data from the file
2516 Actual_Len
: Integer := 0;
2518 Lo
: constant Text_Ptr
:= 0;
2519 -- Low bound for allocated text buffer
2521 Hi
: Text_Ptr
:= Text_Ptr
(Len
);
2522 -- High bound for allocated text buffer. Note length is Len + 1
2523 -- which allows for extra EOF character at the end of the buffer.
2526 -- Allocate text buffer. Note extra character at end for EOF
2528 Text
:= new Text_Buffer
(Lo
.. Hi
);
2530 -- Some systems (e.g. VMS) have file types that require one
2531 -- read per line, so read until we get the Len bytes or until
2532 -- there are no more characters.
2536 Actual_Len
:= Read
(Lib_FD
, Text
(Hi
)'Address, Len
);
2537 Hi
:= Hi
+ Text_Ptr
(Actual_Len
);
2538 exit when Actual_Len
= Len
or else Actual_Len
<= 0;
2544 -- Read is complete, close file and we are done
2546 Close
(Lib_FD
, Status
);
2547 -- The status should never be False. But, if it is, what can we do?
2548 -- So, we don't test it.
2552 end Read_Library_Info_From_Full
;
2554 ----------------------
2555 -- Read_Source_File --
2556 ----------------------
2558 procedure Read_Source_File
2559 (N
: File_Name_Type
;
2561 Hi
: out Source_Ptr
;
2562 Src
: out Source_Buffer_Ptr
;
2563 T
: File_Type
:= Source
)
2565 Source_File_FD
: File_Descriptor
;
2566 -- The file descriptor for the current source file. A negative value
2567 -- indicates failure to open the specified source file.
2570 -- Length of file. Assume no more than 2 gigabytes of source!
2572 Actual_Len
: Integer;
2575 pragma Warnings
(Off
, Status
);
2576 -- For the call to Close
2579 Current_Full_Source_Name
:= Find_File
(N
, T
);
2580 Current_Full_Source_Stamp
:= File_Stamp
(Current_Full_Source_Name
);
2582 if Current_Full_Source_Name
= No_File
then
2584 -- If we were trying to access the main file and we could not find
2585 -- it, we have an error.
2587 if N
= Current_Main
then
2588 Get_Name_String
(N
);
2589 Fail
("Cannot find: " & Name_Buffer
(1 .. Name_Len
));
2597 Get_Name_String
(Current_Full_Source_Name
);
2598 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
2600 -- Open the source FD, note that we open in binary mode, because as
2601 -- documented in the spec, the caller is expected to handle either
2602 -- DOS or Unix mode files, and there is no point in wasting time on
2603 -- text translation when it is not required.
2605 Source_File_FD
:= Open_Read
(Name_Buffer
'Address, Binary
);
2607 if Source_File_FD
= Invalid_FD
then
2613 -- Print out the file name, if requested, and if it's not part of the
2614 -- runtimes, store it in File_Name_Chars.
2617 Name
: String renames Name_Buffer
(1 .. Name_Len
);
2618 Inc
: String renames Include_Dir_Default_Prefix
.all;
2621 if Debug
.Debug_Flag_Dot_N
then
2626 and then Inc
'Length < Name_Len
2627 and then Name_Buffer
(1 .. Inc
'Length) = Inc
2629 -- Part of runtimes, so ignore it
2634 File_Name_Chars
.Append_All
(File_Name_Chars
.Table_Type
(Name
));
2635 File_Name_Chars
.Append
(ASCII
.LF
);
2639 -- Prepare to read data from the file
2641 Len
:= Integer (File_Length
(Source_File_FD
));
2643 -- Set Hi so that length is one more than the physical length,
2644 -- allowing for the extra EOF character at the end of the buffer
2646 Hi
:= Lo
+ Source_Ptr
(Len
);
2648 -- Do the actual read operation
2651 subtype Actual_Source_Buffer
is Source_Buffer
(Lo
.. Hi
);
2652 -- Physical buffer allocated
2654 type Actual_Source_Ptr
is access Actual_Source_Buffer
;
2655 -- This is the pointer type for the physical buffer allocated
2657 Actual_Ptr
: constant Actual_Source_Ptr
:= new Actual_Source_Buffer
;
2658 -- And this is the actual physical buffer
2661 -- Allocate source buffer, allowing extra character at end for EOF
2663 -- Some systems (e.g. VMS) have file types that require one read per
2664 -- line, so read until we get the Len bytes or until there are no
2669 Actual_Len
:= Read
(Source_File_FD
, Actual_Ptr
(Hi
)'Address, Len
);
2670 Hi
:= Hi
+ Source_Ptr
(Actual_Len
);
2671 exit when Actual_Len
= Len
or else Actual_Len
<= 0;
2674 Actual_Ptr
(Hi
) := EOF
;
2676 -- Now we need to work out the proper virtual origin pointer to
2677 -- return. This is exactly Actual_Ptr (0)'Address, but we have to
2678 -- be careful to suppress checks to compute this address.
2681 pragma Suppress
(All_Checks
);
2683 pragma Warnings
(Off
);
2684 -- This use of unchecked conversion is aliasing safe
2686 function To_Source_Buffer_Ptr
is new
2687 Unchecked_Conversion
(Address
, Source_Buffer_Ptr
);
2689 pragma Warnings
(On
);
2692 Src
:= To_Source_Buffer_Ptr
(Actual_Ptr
(0)'Address);
2696 -- Read is complete, get time stamp and close file and we are done
2698 Close
(Source_File_FD
, Status
);
2700 -- The status should never be False. But, if it is, what can we do?
2701 -- So, we don't test it.
2703 end Read_Source_File
;
2709 function Relocate_Path
2711 Path
: String) return String_Ptr
2715 procedure set_std_prefix
(S
: String; Len
: Integer);
2716 pragma Import
(C
, set_std_prefix
);
2719 if Std_Prefix
= null then
2720 Std_Prefix
:= Executable_Prefix
;
2722 if Std_Prefix
.all /= "" then
2724 -- Remove trailing directory separator when calling set_std_prefix
2726 set_std_prefix
(Std_Prefix
.all, Std_Prefix
'Length - 1);
2730 if Path
(Prefix
'Range) = Prefix
then
2731 if Std_Prefix
.all /= "" then
2733 (1 .. Std_Prefix
'Length + Path
'Last - Prefix
'Last);
2734 S
(1 .. Std_Prefix
'Length) := Std_Prefix
.all;
2735 S
(Std_Prefix
'Length + 1 .. S
'Last) :=
2736 Path
(Prefix
'Last + 1 .. Path
'Last);
2741 return new String'(Path);
2748 procedure Set_Program (P : Program_Type) is
2751 Fail ("Set_Program called twice");
2754 Program_Set := True;
2755 Running_Program := P;
2762 function Shared_Lib (Name : String) return String is
2763 Library : String (1 .. Name'Length + Library_Version'Length + 3);
2764 -- 3 = 2 for "-l" + 1 for "-" before lib version
2767 Library (1 .. 2) := "-l";
2768 Library (3 .. 2 + Name'Length) := Name;
2769 Library (3 + Name'Length) := '-';
2770 Library (4 + Name'Length .. Library'Last) := Library_Version;
2772 if OpenVMS_On_Target then
2773 for K in Library'First + 2 .. Library'Last loop
2774 if Library (K) = '.' or else Library (K) = '-' then
2783 ----------------------
2784 -- Smart_File_Stamp --
2785 ----------------------
2787 function Smart_File_Stamp
2788 (N : File_Name_Type;
2789 T : File_Type) return Time_Stamp_Type
2791 File : File_Name_Type;
2792 Attr : aliased File_Attributes;
2795 if not File_Cache_Enabled then
2796 Find_File (N, T, File, Attr'Access);
2798 Smart_Find_File (N, T, File, Attr);
2801 if File = No_File then
2802 return Empty_Time_Stamp;
2804 Get_Name_String (File);
2805 Name_Buffer (Name_Len + 1) := ASCII.NUL;
2807 OS_Time_To_GNAT_Time
2808 (File_Time_Stamp (Name_Buffer'Address, Attr'Access));
2810 end Smart_File_Stamp;
2812 ---------------------
2813 -- Smart_Find_File --
2814 ---------------------
2816 function Smart_Find_File
2817 (N : File_Name_Type;
2818 T : File_Type) return File_Name_Type
2820 File : File_Name_Type;
2821 Attr : File_Attributes;
2823 Smart_Find_File (N, T, File, Attr);
2825 end Smart_Find_File;
2827 ---------------------
2828 -- Smart_Find_File --
2829 ---------------------
2831 procedure Smart_Find_File
2832 (N : File_Name_Type;
2834 Found : out File_Name_Type;
2835 Attr : out File_Attributes)
2837 Info : File_Info_Cache;
2840 if not File_Cache_Enabled then
2841 Find_File (N, T, Info.File, Info.Attr'Access);
2844 Info := File_Name_Hash_Table.Get (N);
2846 if Info.File = No_File then
2847 Find_File (N, T, Info.File, Info.Attr'Access);
2848 File_Name_Hash_Table.Set (N, Info);
2854 end Smart_Find_File;
2856 ----------------------
2857 -- Source_File_Data --
2858 ----------------------
2860 procedure Source_File_Data (Cache : Boolean) is
2862 File_Cache_Enabled := Cache;
2863 end Source_File_Data;
2865 -----------------------
2866 -- Source_File_Stamp --
2867 -----------------------
2869 function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is
2871 return Smart_File_Stamp (N, Source);
2872 end Source_File_Stamp;
2874 ---------------------
2875 -- Strip_Directory --
2876 ---------------------
2878 function Strip_Directory (Name : File_Name_Type) return File_Name_Type is
2880 Get_Name_String (Name);
2882 for J in reverse 1 .. Name_Len - 1 loop
2884 -- If we find the last directory separator
2886 if Is_Directory_Separator (Name_Buffer (J)) then
2888 -- Return part of Name that follows this last directory separator
2890 Name_Buffer (1 .. Name_Len - J) := Name_Buffer (J + 1 .. Name_Len);
2891 Name_Len := Name_Len - J;
2896 -- There were no directory separator, just return Name
2899 end Strip_Directory;
2905 function Strip_Suffix (Name : File_Name_Type) return File_Name_Type is
2907 Get_Name_String (Name);
2909 for J in reverse 2 .. Name_Len loop
2911 -- If we found the last '.', return part of Name that precedes it
2913 if Name_Buffer (J) = '.' then
2922 ---------------------------
2923 -- To_Canonical_Dir_Spec --
2924 ---------------------------
2926 function To_Canonical_Dir_Spec
2928 Prefix_Style : Boolean) return String_Access
2930 function To_Canonical_Dir_Spec
2931 (Host_Dir : Address;
2932 Prefix_Flag : Integer) return Address;
2933 pragma Import (C, To_Canonical_Dir_Spec, "__gnat_to_canonical_dir_spec");
2935 C_Host_Dir : String (1 .. Host_Dir'Length + 1);
2936 Canonical_Dir_Addr : Address;
2937 Canonical_Dir_Len : Integer;
2940 C_Host_Dir (1 .. Host_Dir'Length) := Host_Dir;
2941 C_Host_Dir (C_Host_Dir'Last) := ASCII.NUL;
2943 if Prefix_Style then
2944 Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 1);
2946 Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 0);
2949 Canonical_Dir_Len := C_String_Length (Canonical_Dir_Addr);
2951 if Canonical_Dir_Len = 0 then
2954 return To_Path_String_Access (Canonical_Dir_Addr, Canonical_Dir_Len);
2959 Fail ("erroneous directory spec: " & Host_Dir);
2961 end To_Canonical_Dir_Spec;
2963 ---------------------------
2964 -- To_Canonical_File_List --
2965 ---------------------------
2967 function To_Canonical_File_List
2968 (Wildcard_Host_File : String;
2969 Only_Dirs : Boolean) return String_Access_List_Access
2971 function To_Canonical_File_List_Init
2972 (Host_File : Address;
2973 Only_Dirs : Integer) return Integer;
2974 pragma Import (C, To_Canonical_File_List_Init,
2975 "__gnat_to_canonical_file_list_init");
2977 function To_Canonical_File_List_Next return Address;
2978 pragma Import (C, To_Canonical_File_List_Next,
2979 "__gnat_to_canonical_file_list_next");
2981 procedure To_Canonical_File_List_Free;
2982 pragma Import (C, To_Canonical_File_List_Free,
2983 "__gnat_to_canonical_file_list_free");
2985 Num_Files : Integer;
2986 C_Wildcard_Host_File : String (1 .. Wildcard_Host_File'Length + 1);
2989 C_Wildcard_Host_File (1 .. Wildcard_Host_File'Length) :=
2991 C_Wildcard_Host_File (C_Wildcard_Host_File'Last) := ASCII.NUL;
2993 -- Do the expansion and say how many there are
2995 Num_Files := To_Canonical_File_List_Init
2996 (C_Wildcard_Host_File'Address, Boolean'Pos (Only_Dirs));
2999 Canonical_File_List : String_Access_List (1 .. Num_Files);
3000 Canonical_File_Addr : Address;
3001 Canonical_File_Len : Integer;
3004 -- Retrieve the expanded directory names and build the list
3006 for J in 1 .. Num_Files loop
3007 Canonical_File_Addr := To_Canonical_File_List_Next;
3008 Canonical_File_Len := C_String_Length (Canonical_File_Addr);
3009 Canonical_File_List (J) := To_Path_String_Access
3010 (Canonical_File_Addr, Canonical_File_Len);
3013 -- Free up the storage
3015 To_Canonical_File_List_Free;
3017 return new String_Access_List'(Canonical_File_List
);
3019 end To_Canonical_File_List
;
3021 ----------------------------
3022 -- To_Canonical_File_Spec --
3023 ----------------------------
3025 function To_Canonical_File_Spec
3026 (Host_File
: String) return String_Access
3028 function To_Canonical_File_Spec
(Host_File
: Address
) return Address
;
3030 (C
, To_Canonical_File_Spec
, "__gnat_to_canonical_file_spec");
3032 C_Host_File
: String (1 .. Host_File
'Length + 1);
3033 Canonical_File_Addr
: Address
;
3034 Canonical_File_Len
: Integer;
3037 C_Host_File
(1 .. Host_File
'Length) := Host_File
;
3038 C_Host_File
(C_Host_File
'Last) := ASCII
.NUL
;
3040 Canonical_File_Addr
:= To_Canonical_File_Spec
(C_Host_File
'Address);
3041 Canonical_File_Len
:= C_String_Length
(Canonical_File_Addr
);
3043 if Canonical_File_Len
= 0 then
3046 return To_Path_String_Access
3047 (Canonical_File_Addr
, Canonical_File_Len
);
3052 Fail
("erroneous file spec: " & Host_File
);
3054 end To_Canonical_File_Spec
;
3056 ----------------------------
3057 -- To_Canonical_Path_Spec --
3058 ----------------------------
3060 function To_Canonical_Path_Spec
3061 (Host_Path
: String) return String_Access
3063 function To_Canonical_Path_Spec
(Host_Path
: Address
) return Address
;
3065 (C
, To_Canonical_Path_Spec
, "__gnat_to_canonical_path_spec");
3067 C_Host_Path
: String (1 .. Host_Path
'Length + 1);
3068 Canonical_Path_Addr
: Address
;
3069 Canonical_Path_Len
: Integer;
3072 C_Host_Path
(1 .. Host_Path
'Length) := Host_Path
;
3073 C_Host_Path
(C_Host_Path
'Last) := ASCII
.NUL
;
3075 Canonical_Path_Addr
:= To_Canonical_Path_Spec
(C_Host_Path
'Address);
3076 Canonical_Path_Len
:= C_String_Length
(Canonical_Path_Addr
);
3078 -- Return a null string (vice a null) for zero length paths, for
3079 -- compatibility with getenv().
3081 return To_Path_String_Access
(Canonical_Path_Addr
, Canonical_Path_Len
);
3085 Fail
("erroneous path spec: " & Host_Path
);
3087 end To_Canonical_Path_Spec
;
3089 ---------------------------
3090 -- To_Host_Dir_Spec --
3091 ---------------------------
3093 function To_Host_Dir_Spec
3094 (Canonical_Dir
: String;
3095 Prefix_Style
: Boolean) return String_Access
3097 function To_Host_Dir_Spec
3098 (Canonical_Dir
: Address
;
3099 Prefix_Flag
: Integer) return Address
;
3100 pragma Import
(C
, To_Host_Dir_Spec
, "__gnat_to_host_dir_spec");
3102 C_Canonical_Dir
: String (1 .. Canonical_Dir
'Length + 1);
3103 Host_Dir_Addr
: Address
;
3104 Host_Dir_Len
: Integer;
3107 C_Canonical_Dir
(1 .. Canonical_Dir
'Length) := Canonical_Dir
;
3108 C_Canonical_Dir
(C_Canonical_Dir
'Last) := ASCII
.NUL
;
3110 if Prefix_Style
then
3111 Host_Dir_Addr
:= To_Host_Dir_Spec
(C_Canonical_Dir
'Address, 1);
3113 Host_Dir_Addr
:= To_Host_Dir_Spec
(C_Canonical_Dir
'Address, 0);
3115 Host_Dir_Len
:= C_String_Length
(Host_Dir_Addr
);
3117 if Host_Dir_Len
= 0 then
3120 return To_Path_String_Access
(Host_Dir_Addr
, Host_Dir_Len
);
3122 end To_Host_Dir_Spec
;
3124 ----------------------------
3125 -- To_Host_File_Spec --
3126 ----------------------------
3128 function To_Host_File_Spec
3129 (Canonical_File
: String) return String_Access
3131 function To_Host_File_Spec
(Canonical_File
: Address
) return Address
;
3132 pragma Import
(C
, To_Host_File_Spec
, "__gnat_to_host_file_spec");
3134 C_Canonical_File
: String (1 .. Canonical_File
'Length + 1);
3135 Host_File_Addr
: Address
;
3136 Host_File_Len
: Integer;
3139 C_Canonical_File
(1 .. Canonical_File
'Length) := Canonical_File
;
3140 C_Canonical_File
(C_Canonical_File
'Last) := ASCII
.NUL
;
3142 Host_File_Addr
:= To_Host_File_Spec
(C_Canonical_File
'Address);
3143 Host_File_Len
:= C_String_Length
(Host_File_Addr
);
3145 if Host_File_Len
= 0 then
3148 return To_Path_String_Access
3149 (Host_File_Addr
, Host_File_Len
);
3151 end To_Host_File_Spec
;
3153 ---------------------------
3154 -- To_Path_String_Access --
3155 ---------------------------
3157 function To_Path_String_Access
3158 (Path_Addr
: Address
;
3159 Path_Len
: Integer) return String_Access
3161 subtype Path_String
is String (1 .. Path_Len
);
3162 type Path_String_Access
is access Path_String
;
3164 function Address_To_Access
is new
3165 Unchecked_Conversion
(Source
=> Address
,
3166 Target
=> Path_String_Access
);
3168 Path_Access
: constant Path_String_Access
:=
3169 Address_To_Access
(Path_Addr
);
3171 Return_Val
: String_Access
;
3174 Return_Val
:= new String (1 .. Path_Len
);
3176 for J
in 1 .. Path_Len
loop
3177 Return_Val
(J
) := Path_Access
(J
);
3181 end To_Path_String_Access
;
3187 function Update_Path
(Path
: String_Ptr
) return String_Ptr
is
3189 function C_Update_Path
(Path
, Component
: Address
) return Address
;
3190 pragma Import
(C
, C_Update_Path
, "update_path");
3192 function Strlen
(Str
: Address
) return Integer;
3193 pragma Import
(C
, Strlen
, "strlen");
3195 procedure Strncpy
(X
: Address
; Y
: Address
; Length
: Integer);
3196 pragma Import
(C
, Strncpy
, "strncpy");
3198 In_Length
: constant Integer := Path
'Length;
3199 In_String
: String (1 .. In_Length
+ 1);
3200 Component_Name
: aliased String := "GCC" & ASCII
.NUL
;
3201 Result_Ptr
: Address
;
3202 Result_Length
: Integer;
3203 Out_String
: String_Ptr
;
3206 In_String
(1 .. In_Length
) := Path
.all;
3207 In_String
(In_Length
+ 1) := ASCII
.NUL
;
3208 Result_Ptr
:= C_Update_Path
(In_String
'Address, Component_Name
'Address);
3209 Result_Length
:= Strlen
(Result_Ptr
);
3211 Out_String
:= new String (1 .. Result_Length
);
3212 Strncpy
(Out_String
.all'Address, Result_Ptr
, Result_Length
);
3220 procedure Write_Info
(Info
: String) is
3222 Write_With_Check
(Info
'Address, Info
'Length);
3223 Write_With_Check
(EOL
'Address, 1);
3226 ------------------------
3227 -- Write_Program_Name --
3228 ------------------------
3230 procedure Write_Program_Name
is
3231 Save_Buffer
: constant String (1 .. Name_Len
) :=
3232 Name_Buffer
(1 .. Name_Len
);
3237 -- Convert the name to lower case so error messages are the same on
3240 for J
in 1 .. Name_Len
loop
3241 if Name_Buffer
(J
) in 'A' .. 'Z' then
3243 Character'Val (Character'Pos (Name_Buffer
(J
)) + 32);
3247 Write_Str
(Name_Buffer
(1 .. Name_Len
));
3249 -- Restore Name_Buffer which was clobbered by the call to
3250 -- Find_Program_Name
3252 Name_Len
:= Save_Buffer
'Last;
3253 Name_Buffer
(1 .. Name_Len
) := Save_Buffer
;
3254 end Write_Program_Name
;
3256 ----------------------
3257 -- Write_With_Check --
3258 ----------------------
3260 procedure Write_With_Check
(A
: Address
; N
: Integer) is
3262 pragma Warnings
(Off
, Ignore
);
3265 if N
= Write
(Output_FD
, A
, N
) then
3269 Write_Str
("error: disk full writing ");
3270 Write_Name_Decoded
(Output_File_Name
);
3272 Name_Len
:= Name_Len
+ 1;
3273 Name_Buffer
(Name_Len
) := ASCII
.NUL
;
3274 Delete_File
(Name_Buffer
'Address, Ignore
);
3275 Exit_Program
(E_Fatal
);
3277 end Write_With_Check
;
3279 ----------------------------
3280 -- Package Initialization --
3281 ----------------------------
3283 procedure Reset_File_Attributes
(Attr
: System
.Address
);
3284 pragma Import
(C
, Reset_File_Attributes
, "__gnat_reset_attributes");
3287 Initialization
: declare
3289 function Get_Default_Identifier_Character_Set
return Character;
3290 pragma Import
(C
, Get_Default_Identifier_Character_Set
,
3291 "__gnat_get_default_identifier_character_set");
3292 -- Function to determine the default identifier character set,
3293 -- which is system dependent. See Opt package spec for a list of
3294 -- the possible character codes and their interpretations.
3296 function Get_Maximum_File_Name_Length
return Int
;
3297 pragma Import
(C
, Get_Maximum_File_Name_Length
,
3298 "__gnat_get_maximum_file_name_length");
3299 -- Function to get maximum file name length for system
3301 Sizeof_File_Attributes
: Integer;
3302 pragma Import
(C
, Sizeof_File_Attributes
,
3303 "__gnat_size_of_file_attributes");
3306 pragma Assert
(Sizeof_File_Attributes
<= File_Attributes_Size
);
3308 Reset_File_Attributes
(Unknown_Attributes
'Address);
3310 Identifier_Character_Set
:= Get_Default_Identifier_Character_Set
;
3311 Maximum_File_Name_Length
:= Get_Maximum_File_Name_Length
;
3313 -- Following should be removed by having above function return
3314 -- Integer'Last as indication of no maximum instead of -1 ???
3316 if Maximum_File_Name_Length
= -1 then
3317 Maximum_File_Name_Length
:= Int
'Last;
3320 Src_Search_Directories
.Set_Last
(Primary_Directory
);
3321 Src_Search_Directories
.Table
(Primary_Directory
) := new String'("");
3323 Lib_Search_Directories.Set_Last (Primary_Directory);
3324 Lib_Search_Directories.Table (Primary_Directory) := new String'("");