1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2021, 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
;
51 Running_Program
: Program_Type
:= Unspecified
;
52 -- Set by Set_Program to indicate which of Compiler, Binder, etc is
55 Program_Set
: Boolean := False;
56 -- True if Set_Program has been called; used to detect duplicate calls.
58 Std_Prefix
: String_Ptr
;
59 -- Standard prefix, computed dynamically the first time Relocate_Path
60 -- is called, and cached for subsequent calls.
62 Empty
: aliased String := "";
63 No_Dir
: constant String_Ptr
:= Empty
'Access;
64 -- Used in Locate_File as a fake directory when Name is already an
67 -------------------------------------
68 -- Use of Name_Find and Name_Enter --
69 -------------------------------------
71 -- This package creates a number of source, ALI and object file names
72 -- that are used to locate the actual file and for the purpose of message
73 -- construction. These names need not be accessible by Name_Find, and can
74 -- be therefore created by using routine Name_Enter. The files in question
75 -- are file names with a prefix directory (i.e., the files not in the
76 -- current directory). File names without a prefix directory are entered
77 -- with Name_Find because special values might be attached to the various
78 -- Info fields of the corresponding name table entry.
80 -----------------------
81 -- Local Subprograms --
82 -----------------------
84 function Append_Suffix_To_File_Name
85 (Name
: File_Name_Type
;
86 Suffix
: String) return File_Name_Type
;
87 -- Appends Suffix to Name and returns the new name
89 function OS_Time_To_GNAT_Time
(T
: OS_Time
) return Time_Stamp_Type
;
90 -- Convert OS format time to GNAT format time stamp. If T is Invalid_Time,
91 -- then returns Empty_Time_Stamp.
92 -- Round to even seconds on Windows before conversion.
93 -- Windows ALI files had timestamps rounded to even seconds historically.
94 -- The rounding was originally done in GM_Split. Now that GM_Split no
95 -- longer does it, we are rounding it here only for ALI files.
97 function Executable_Prefix
return String_Ptr
;
98 -- Returns the name of the root directory where the executable is stored.
99 -- The executable must be located in a directory called "bin", or under
100 -- root/lib/gcc-lib/..., or under root/libexec/gcc/... For example, if
101 -- executable is stored in directory "/foo/bar/bin", this routine returns
102 -- "/foo/bar/". Return "" if location is not recognized as described above.
104 function File_Names_Equal
(File1
, File2
: String) return Boolean;
105 -- Compare File1 and File2 taking into account the case insensitivity
108 function Update_Path
(Path
: String_Ptr
) return String_Ptr
;
109 -- Update the specified path to replace the prefix with the location where
110 -- GNAT is installed. See the file prefix.c in GCC for details.
112 procedure Locate_File
117 Found
: out File_Name_Type
;
118 Attr
: access File_Attributes
);
119 -- See if the file N whose name is Name exists in directory Dir. Dir is an
120 -- index into the Lib_Search_Directories table if T = Library. Otherwise
121 -- if T = Source, Dir is an index into the Src_Search_Directories table.
122 -- Returns the File_Name_Type of the full file name if file found, or
123 -- No_File if not found.
125 -- On exit, Found is set to the file that was found, and Attr to a cache of
126 -- its attributes (at least those that have been computed so far). Reusing
127 -- the cache will save some system calls.
129 -- Attr is always reset in this call to Unknown_Attributes, even in case of
135 Found
: out File_Name_Type
;
136 Attr
: access File_Attributes
;
137 Full_Name
: Boolean := False);
138 -- A version of Find_File that also returns a cache of the file attributes
141 procedure Smart_Find_File
144 Found
: out File_Name_Type
;
145 Attr
: out File_Attributes
);
146 -- A version of Smart_Find_File that also returns a cache of the file
147 -- attributes for later reuse
149 function C_String_Length
(S
: Address
) return CRTL
.size_t
;
150 -- Returns length of a C string (zero for a null address)
152 function To_Path_String_Access
153 (Path_Addr
: Address
;
154 Path_Len
: CRTL
.size_t
) return String_Access
;
155 -- Converts a C String to an Ada String. We don't use a more general
156 -- purpose facility, because we are dealing with low-level types like
157 -- Address. Caller must free result.
159 function Include_Dir_Default_Prefix
return String_Access
;
160 -- Same as exported version, except returns a String_Access
162 ------------------------------
163 -- Other Local Declarations --
164 ------------------------------
166 EOL
: constant Character := ASCII
.LF
;
167 -- End of line character
169 Number_File_Names
: Nat
:= 0;
170 -- Number of file names found on command line and placed in File_Names
172 Look_In_Primary_Directory_For_Current_Main
: Boolean := False;
173 -- When this variable is True, Find_File only looks in Primary_Directory
174 -- for the Current_Main file. This variable is always set to True for the
175 -- compiler. It is also True for gnatmake, when the source name given on
176 -- the command line has directory information.
178 Current_Full_Source_Name
: File_Name_Type
:= No_File
;
179 Current_Full_Source_Stamp
: Time_Stamp_Type
:= Empty_Time_Stamp
;
180 Current_Full_Lib_Name
: File_Name_Type
:= No_File
;
181 Current_Full_Lib_Stamp
: Time_Stamp_Type
:= Empty_Time_Stamp
;
182 Current_Full_Obj_Name
: File_Name_Type
:= No_File
;
183 Current_Full_Obj_Stamp
: Time_Stamp_Type
:= Empty_Time_Stamp
;
184 -- Respectively full name (with directory info) and time stamp of the
185 -- latest source, library and object files opened by Read_Source_File and
186 -- Read_Library_Info.
188 package File_Name_Chars
is new Table
.Table
(
189 Table_Component_Type
=> Character,
190 Table_Index_Type
=> Int
,
191 Table_Low_Bound
=> 1,
192 Table_Initial
=> Alloc
.File_Name_Chars_Initial
,
193 Table_Increment
=> Alloc
.File_Name_Chars_Increment
,
194 Table_Name
=> "File_Name_Chars");
195 -- Table to store text to be printed by Dump_Source_File_Names
197 The_Include_Dir_Default_Prefix
: String_Access
:= null;
198 -- Value returned by Include_Dir_Default_Prefix. We don't initialize it
199 -- here, because that causes an elaboration cycle with Sdefault; we
200 -- initialize it lazily instead.
206 Primary_Directory
: constant := 0;
207 -- This is index in the tables created below for the first directory to
208 -- search in for source or library information files. This is the directory
209 -- containing the latest main input file (a source file for the compiler or
210 -- a library file for the binder).
212 package Src_Search_Directories
is new Table
.Table
(
213 Table_Component_Type
=> String_Ptr
,
214 Table_Index_Type
=> Integer,
215 Table_Low_Bound
=> Primary_Directory
,
217 Table_Increment
=> 100,
218 Table_Name
=> "Osint.Src_Search_Directories");
219 -- Table of names of directories in which to search for source (Compiler)
220 -- files. This table is filled in the order in which the directories are
221 -- to be searched, and then used in that order.
223 package Lib_Search_Directories
is new Table
.Table
(
224 Table_Component_Type
=> String_Ptr
,
225 Table_Index_Type
=> Integer,
226 Table_Low_Bound
=> Primary_Directory
,
228 Table_Increment
=> 100,
229 Table_Name
=> "Osint.Lib_Search_Directories");
230 -- Table of names of directories in which to search for library (Binder)
231 -- files. This table is filled in the order in which the directories are
232 -- to be searched and then used in that order. The reason for having two
233 -- distinct tables is that we need them both in gnatmake.
235 ---------------------
236 -- File Hash Table --
237 ---------------------
239 -- The file hash table is provided to free the programmer from any
240 -- efficiency concern when retrieving full file names or time stamps of
241 -- source files. If the programmer calls Source_File_Data (Cache => True)
242 -- he is guaranteed that the price to retrieve the full name (i.e. with
243 -- directory info) or time stamp of the file will be payed only once, the
244 -- first time the full name is actually searched (or the first time the
245 -- time stamp is actually retrieved). This is achieved by employing a hash
246 -- table that stores as a key the File_Name_Type of the file and associates
247 -- to that File_Name_Type the full file name and time stamp of the file.
249 File_Cache_Enabled
: Boolean := False;
250 -- Set to true if you want the enable the file data caching mechanism
252 type File_Hash_Num
is range 0 .. 1020;
254 function File_Hash
(F
: File_Name_Type
) return File_Hash_Num
;
255 -- Compute hash index for use by Simple_HTable
257 type File_Info_Cache
is record
258 File
: File_Name_Type
;
259 Attr
: aliased File_Attributes
;
262 No_File_Info_Cache
: constant File_Info_Cache
:= (No_File
, (others => 0));
264 package File_Name_Hash_Table
is new GNAT
.HTable
.Simple_HTable
(
265 Header_Num
=> File_Hash_Num
,
266 Element
=> File_Info_Cache
,
267 No_Element
=> No_File_Info_Cache
,
268 Key
=> File_Name_Type
,
272 function Smart_Find_File
274 T
: File_Type
) return File_Name_Type
;
275 -- Exactly like Find_File except that if File_Cache_Enabled is True this
276 -- routine looks first in the hash table to see if the full name of the
277 -- file is already available.
279 function Smart_File_Stamp
281 T
: File_Type
) return Time_Stamp_Type
;
282 -- Takes the same parameter as the routine above (N is a file name without
283 -- any prefix directory information) and behaves like File_Stamp except
284 -- that if File_Cache_Enabled is True this routine looks first in the hash
285 -- table to see if the file stamp of the file is already available.
287 -----------------------------
288 -- Add_Default_Search_Dirs --
289 -----------------------------
291 procedure Add_Default_Search_Dirs
is
292 Search_Dir
: String_Access
;
293 Search_Path
: String_Access
;
294 Path_File_Name
: String_Access
;
296 procedure Add_Search_Dir
297 (Search_Dir
: String;
298 Additional_Source_Dir
: Boolean);
299 procedure Add_Search_Dir
300 (Search_Dir
: String_Access
;
301 Additional_Source_Dir
: Boolean);
302 -- Add a source search dir or a library search dir, depending on the
303 -- value of Additional_Source_Dir.
305 procedure Get_Dirs_From_File
(Additional_Source_Dir
: Boolean);
306 -- Open a path file and read the directory to search, one per line
308 function Get_Libraries_From_Registry
return String_Ptr
;
309 -- On Windows systems, get the list of installed standard libraries
310 -- from the registry key:
312 -- HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\
313 -- GNAT\Standard Libraries
314 -- Return an empty string on other systems.
316 -- Note that this is an undocumented legacy feature, and that it
317 -- works only when using the default runtime library (i.e. no --RTS=
318 -- command line switch).
324 procedure Add_Search_Dir
325 (Search_Dir
: String;
326 Additional_Source_Dir
: Boolean)
329 if Additional_Source_Dir
then
330 Add_Src_Search_Dir
(Search_Dir
);
332 Add_Lib_Search_Dir
(Search_Dir
);
336 procedure Add_Search_Dir
337 (Search_Dir
: String_Access
;
338 Additional_Source_Dir
: Boolean)
341 if Additional_Source_Dir
then
342 Add_Src_Search_Dir
(Search_Dir
.all);
344 Add_Lib_Search_Dir
(Search_Dir
.all);
348 ------------------------
349 -- Get_Dirs_From_File --
350 ------------------------
352 procedure Get_Dirs_From_File
(Additional_Source_Dir
: Boolean) is
353 File_FD
: File_Descriptor
;
354 Buffer
: constant String := Path_File_Name
.all & ASCII
.NUL
;
356 Actual_Len
: Natural;
363 pragma Warnings
(Off
, Status
);
364 -- For the call to Close where status is ignored
367 File_FD
:= Open_Read
(Buffer
'Address, Binary
);
369 -- If we cannot open the file, we ignore it, we don't fail
371 if File_FD
= Invalid_FD
then
375 Len
:= Integer (File_Length
(File_FD
));
377 S
:= new String (1 .. Len
);
379 -- Read the file. Note that the loop is probably not necessary any
380 -- more since the whole file is read in at once on all targets. But
381 -- it is harmless and might be needed in future.
385 while Curr
<= Len
and then Actual_Len
/= 0 loop
386 Actual_Len
:= Read
(File_FD
, S
(Curr
)'Address, Len
);
387 Curr
:= Curr
+ Actual_Len
;
390 -- We are done with the file, so we close it (ignore any error on
391 -- the close, since we have successfully read the file).
393 Close
(File_FD
, Status
);
395 -- Now, we read line by line
399 while Curr
< Len
loop
402 if Ch
= ASCII
.CR
or else Ch
= ASCII
.LF
403 or else Ch
= ASCII
.FF
or else Ch
= ASCII
.VT
405 if First
<= Curr
then
406 Add_Search_Dir
(S
(First
.. Curr
), Additional_Source_Dir
);
415 -- Last line is a special case, if the file does not end with
416 -- an end of line mark.
418 if First
<= S
'Last then
419 Add_Search_Dir
(S
(First
.. S
'Last), Additional_Source_Dir
);
421 end Get_Dirs_From_File
;
423 ---------------------------------
424 -- Get_Libraries_From_Registry --
425 ---------------------------------
427 function Get_Libraries_From_Registry
return String_Ptr
is
428 function C_Get_Libraries_From_Registry
return Address
;
429 pragma Import
(C
, C_Get_Libraries_From_Registry
,
430 "__gnat_get_libraries_from_registry");
432 Result_Ptr
: Address
;
433 Result_Length
: CRTL
.size_t
;
434 Out_String
: String_Ptr
;
437 Result_Ptr
:= C_Get_Libraries_From_Registry
;
438 Result_Length
:= CRTL
.strlen
(Result_Ptr
);
440 Out_String
:= new String (1 .. Integer (Result_Length
));
441 CRTL
.strncpy
(Out_String
.all'Address, Result_Ptr
, Result_Length
);
443 CRTL
.free
(Result_Ptr
);
446 end Get_Libraries_From_Registry
;
448 -- Start of processing for Add_Default_Search_Dirs
451 -- If there was a -gnateO switch, add all object directories from the
452 -- file given in argument to the library search list.
454 if Object_Path_File_Name
/= null then
455 Path_File_Name
:= String_Access
(Object_Path_File_Name
);
456 pragma Assert
(Path_File_Name
'Length > 0);
457 Get_Dirs_From_File
(Additional_Source_Dir
=> False);
460 -- After the locations specified on the command line, the next places
461 -- to look for files are the directories specified by the appropriate
462 -- environment variable. Get this value, extract the directory names
463 -- and store in the tables.
465 -- Check for eventual project path file env vars
467 Path_File_Name
:= Getenv
(Project_Include_Path_File
);
469 if Path_File_Name
'Length > 0 then
470 Get_Dirs_From_File
(Additional_Source_Dir
=> True);
473 Path_File_Name
:= Getenv
(Project_Objects_Path_File
);
475 if Path_File_Name
'Length > 0 then
476 Get_Dirs_From_File
(Additional_Source_Dir
=> False);
479 -- Put path name in canonical form
481 for Additional_Source_Dir
in False .. True loop
482 if Additional_Source_Dir
then
483 Search_Path
:= Getenv
(Ada_Include_Path
);
486 Search_Path
:= Getenv
(Ada_Objects_Path
);
490 Get_Next_Dir_In_Path_Init
(Search_Path
);
492 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
493 exit when Search_Dir
= null;
494 Add_Search_Dir
(Search_Dir
, Additional_Source_Dir
);
498 -- For the compiler, if --RTS= was specified, add the runtime
501 if RTS_Src_Path_Name
/= null and then RTS_Lib_Path_Name
/= null then
502 Add_Search_Dirs
(RTS_Src_Path_Name
, Include
);
503 Add_Search_Dirs
(RTS_Lib_Path_Name
, Objects
);
506 if not Opt
.No_Stdinc
then
508 -- For WIN32 systems, look for any system libraries defined in
509 -- the registry. These are added to both source and object
512 Search_Path
:= String_Access
(Get_Libraries_From_Registry
);
514 Get_Next_Dir_In_Path_Init
(Search_Path
);
516 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
517 exit when Search_Dir
= null;
518 Add_Search_Dir
(Search_Dir
, False);
519 Add_Search_Dir
(Search_Dir
, True);
522 -- The last place to look are the defaults
525 Read_Default_Search_Dirs
526 (String_Access
(Update_Path
(Search_Dir_Prefix
)),
528 String_Access
(Update_Path
(Include_Dir_Default_Name
)));
530 Get_Next_Dir_In_Path_Init
(Search_Path
);
532 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
533 exit when Search_Dir
= null;
534 Add_Search_Dir
(Search_Dir
, True);
538 -- Even when -nostdlib is used, we still want to have visibility on
539 -- the run-time object directory, as it is used by gnatbind to find
540 -- the run-time ALI files in "real" ZFP set up.
542 if not Opt
.RTS_Switch
then
544 Read_Default_Search_Dirs
545 (String_Access
(Update_Path
(Search_Dir_Prefix
)),
547 String_Access
(Update_Path
(Object_Dir_Default_Name
)));
549 Get_Next_Dir_In_Path_Init
(Search_Path
);
551 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
552 exit when Search_Dir
= null;
553 Add_Search_Dir
(Search_Dir
, False);
557 end Add_Default_Search_Dirs
;
563 procedure Add_File
(File_Name
: String; Index
: Int
:= No_Index
) is
565 Number_File_Names
:= Number_File_Names
+ 1;
567 -- As Add_File may be called for mains specified inside a project file,
568 -- File_Names may be too short and needs to be extended.
570 if Number_File_Names
> File_Names
'Last then
571 File_Names
:= new File_Name_Array
'(File_Names.all & File_Names.all);
573 new File_Index_Array'(File_Indexes
.all & File_Indexes
.all);
576 File_Names
(Number_File_Names
) := new String'(File_Name);
577 File_Indexes (Number_File_Names) := Index;
580 ------------------------
581 -- Add_Lib_Search_Dir --
582 ------------------------
584 procedure Add_Lib_Search_Dir (Dir : String) is
586 if Dir'Length = 0 then
587 Fail ("missing library directory name");
591 Norm : String_Ptr := Normalize_Directory_Name (Dir);
594 -- Do nothing if the directory is already in the list. This saves
595 -- system calls and avoid unneeded work
597 for D in Lib_Search_Directories.First ..
598 Lib_Search_Directories.Last
600 if Lib_Search_Directories.Table (D).all = Norm.all then
606 Lib_Search_Directories.Increment_Last;
607 Lib_Search_Directories.Table (Lib_Search_Directories.Last) := Norm;
609 end Add_Lib_Search_Dir;
611 ---------------------
612 -- Add_Search_Dirs --
613 ---------------------
615 procedure Add_Search_Dirs
616 (Search_Path : String_Ptr;
617 Path_Type : Search_File_Type)
619 Current_Search_Path : String_Access;
622 Get_Next_Dir_In_Path_Init (String_Access (Search_Path));
624 Current_Search_Path :=
625 Get_Next_Dir_In_Path (String_Access (Search_Path));
626 exit when Current_Search_Path = null;
628 if Path_Type = Include then
629 Add_Src_Search_Dir (Current_Search_Path.all);
631 Add_Lib_Search_Dir (Current_Search_Path.all);
636 ------------------------
637 -- Add_Src_Search_Dir --
638 ------------------------
640 procedure Add_Src_Search_Dir (Dir : String) is
642 if Dir'Length = 0 then
643 Fail ("missing source directory name");
646 Src_Search_Directories.Increment_Last;
647 Src_Search_Directories.Table (Src_Search_Directories.Last) :=
648 Normalize_Directory_Name (Dir);
649 end Add_Src_Search_Dir;
651 --------------------------------
652 -- Append_Suffix_To_File_Name --
653 --------------------------------
655 function Append_Suffix_To_File_Name
656 (Name : File_Name_Type;
657 Suffix : String) return File_Name_Type
660 Get_Name_String (Name);
661 Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
662 Name_Len := Name_Len + Suffix'Length;
664 end Append_Suffix_To_File_Name;
666 ---------------------
667 -- C_String_Length --
668 ---------------------
670 function C_String_Length (S : Address) return CRTL.size_t is
672 if S = Null_Address then
675 return CRTL.strlen (S);
679 ------------------------------
680 -- Canonical_Case_File_Name --
681 ------------------------------
683 procedure Canonical_Case_File_Name (S : in out String) is
685 if not File_Names_Case_Sensitive then
688 end Canonical_Case_File_Name;
690 ---------------------------------
691 -- Canonical_Case_Env_Var_Name --
692 ---------------------------------
694 procedure Canonical_Case_Env_Var_Name (S : in out String) is
696 if not Env_Vars_Case_Sensitive then
699 end Canonical_Case_Env_Var_Name;
701 ---------------------------
702 -- Create_File_And_Check --
703 ---------------------------
705 procedure Create_File_And_Check
706 (Fdesc : out File_Descriptor;
710 Output_File_Name := Name_Enter;
711 Fdesc := Create_File (Name_Buffer'Address, Fmode);
713 if Fdesc = Invalid_FD then
714 Fail ("Cannot create: " & Name_Buffer (1 .. Name_Len));
716 end Create_File_And_Check;
718 -----------------------------------
719 -- Open_File_To_Append_And_Check --
720 -----------------------------------
722 procedure Open_File_To_Append_And_Check
723 (Fdesc : out File_Descriptor;
727 Output_File_Name := Name_Enter;
728 Fdesc := Open_Append (Name_Buffer'Address, Fmode);
730 if Fdesc = Invalid_FD then
731 Fail ("Cannot create: " & Name_Buffer (1 .. Name_Len));
733 end Open_File_To_Append_And_Check;
735 ------------------------
736 -- Current_File_Index --
737 ------------------------
739 function Current_File_Index return Int is
741 return File_Indexes (Current_File_Name_Index);
742 end Current_File_Index;
744 --------------------------------
745 -- Current_Library_File_Stamp --
746 --------------------------------
748 function Current_Library_File_Stamp return Time_Stamp_Type is
750 return Current_Full_Lib_Stamp;
751 end Current_Library_File_Stamp;
753 -------------------------------
754 -- Current_Object_File_Stamp --
755 -------------------------------
757 function Current_Object_File_Stamp return Time_Stamp_Type is
759 return Current_Full_Obj_Stamp;
760 end Current_Object_File_Stamp;
762 -------------------------------
763 -- Current_Source_File_Stamp --
764 -------------------------------
766 function Current_Source_File_Stamp return Time_Stamp_Type is
768 return Current_Full_Source_Stamp;
769 end Current_Source_File_Stamp;
771 ----------------------------
772 -- Dir_In_Obj_Search_Path --
773 ----------------------------
775 function Dir_In_Obj_Search_Path (Position : Natural) return String_Ptr is
777 if Opt.Look_In_Primary_Dir then
779 Lib_Search_Directories.Table (Primary_Directory + Position - 1);
781 return Lib_Search_Directories.Table (Primary_Directory + Position);
783 end Dir_In_Obj_Search_Path;
785 ----------------------------
786 -- Dir_In_Src_Search_Path --
787 ----------------------------
789 function Dir_In_Src_Search_Path (Position : Natural) return String_Ptr is
791 if Opt.Look_In_Primary_Dir then
793 Src_Search_Directories.Table (Primary_Directory + Position - 1);
795 return Src_Search_Directories.Table (Primary_Directory + Position);
797 end Dir_In_Src_Search_Path;
799 -----------------------------------------
800 -- Dump_Command_Line_Source_File_Names --
801 -----------------------------------------
803 procedure Dump_Command_Line_Source_File_Names is
805 for J in 1 .. Number_Of_Files loop
806 Write_Str (File_Names (J).all & " ");
808 end Dump_Command_Line_Source_File_Names;
810 ----------------------------
811 -- Dump_Source_File_Names --
812 ----------------------------
814 procedure Dump_Source_File_Names is
815 subtype Rng is Int range File_Name_Chars.First .. File_Name_Chars.Last;
817 Write_Str (String (File_Name_Chars.Table (Rng)));
818 end Dump_Source_File_Names;
820 ---------------------
821 -- Executable_Name --
822 ---------------------
824 function Executable_Name
825 (Name : File_Name_Type;
826 Only_If_No_Suffix : Boolean := False) return File_Name_Type
828 Exec_Suffix : String_Access;
829 Add_Suffix : Boolean;
832 if Name = No_File then
836 if Executable_Extension_On_Target = No_Name then
837 Exec_Suffix := Get_Target_Executable_Suffix;
839 Get_Name_String (Executable_Extension_On_Target);
840 Exec_Suffix := new String'(Name_Buffer
(1 .. Name_Len
));
843 if Exec_Suffix
'Length /= 0 then
844 Get_Name_String
(Name
);
847 if Only_If_No_Suffix
then
848 for J
in reverse 1 .. Name_Len
loop
849 if Name_Buffer
(J
) = '.' then
853 elsif Is_Directory_Separator
(Name_Buffer
(J
)) then
860 -- If Executable doesn't end with the executable suffix, add it
862 if Name_Len
<= Exec_Suffix
'Length
866 (Name_Len
- Exec_Suffix
'Length + 1 .. Name_Len
),
870 (Name_Len
+ 1 .. Name_Len
+ Exec_Suffix
'Length) :=
872 Name_Len
:= Name_Len
+ Exec_Suffix
'Length;
883 function Executable_Name
885 Only_If_No_Suffix
: Boolean := False) return String
887 Exec_Suffix
: String_Access
;
888 Add_Suffix
: Boolean;
891 if Executable_Extension_On_Target
= No_Name
then
892 Exec_Suffix
:= Get_Target_Executable_Suffix
;
894 Get_Name_String
(Executable_Extension_On_Target
);
895 Exec_Suffix
:= new String'(Name_Buffer (1 .. Name_Len));
898 if Exec_Suffix'Length = 0 then
904 Suffix : constant String := Exec_Suffix.all;
910 if Only_If_No_Suffix then
911 for J in reverse Name'Range loop
912 if Name (J) = '.' then
916 elsif Is_Directory_Separator (Name (J)) then
922 if Add_Suffix and then
923 (Name'Length <= Suffix'Length
926 (Name (Name'Last - Suffix'Length + 1 .. Name'Last),
930 Result : String (1 .. Name'Length + Suffix'Length);
932 Result (1 .. Name'Length) := Name;
933 Result (Name'Length + 1 .. Result'Last) := Suffix;
943 -----------------------
944 -- Executable_Prefix --
945 -----------------------
947 function Executable_Prefix return String_Ptr is
949 function Get_Install_Dir (Exec : String) return String_Ptr;
950 -- S is the executable name preceded by the absolute or relative
951 -- path, e.g. "c:\usr\bin\gcc.exe" or "..\bin\gcc".
953 ---------------------
954 -- Get_Install_Dir --
955 ---------------------
957 function Get_Install_Dir (Exec : String) return String_Ptr is
958 Full_Path : constant String := Normalize_Pathname (Exec);
959 -- Use the full path, so that we find "lib" or "bin", even when
960 -- the tool has been invoked with a relative path, as in
961 -- "./gnatls -v" invoked in the GNAT bin directory.
964 for J in reverse Full_Path'Range loop
965 if Is_Directory_Separator (Full_Path (J)) then
966 if J < Full_Path'Last - 5 then
967 if (To_Lower (Full_Path (J + 1)) = 'l
'
968 and then To_Lower (Full_Path (J + 2)) = 'i
'
969 and then To_Lower (Full_Path (J + 3)) = 'b
')
971 (To_Lower (Full_Path (J + 1)) = 'b
'
972 and then To_Lower (Full_Path (J + 2)) = 'i
'
973 and then To_Lower (Full_Path (J + 3)) = 'n
')
975 return new String'(Full_Path
(Full_Path
'First .. J
));
981 return new String'("");
984 -- Start of processing for Executable_Prefix
987 if Exec_Name = null then
988 Exec_Name := new String (1 .. Len_Arg (0));
989 Osint.Fill_Arg (Exec_Name (1)'Address, 0);
992 -- First determine if a path prefix was placed in front of the
995 for J in reverse Exec_Name'Range loop
996 if Is_Directory_Separator (Exec_Name (J)) then
997 return Get_Install_Dir (Exec_Name.all);
1001 -- If we come here, the user has typed the executable name with no
1002 -- directory prefix.
1004 return Get_Install_Dir (Locate_Exec_On_Path (Exec_Name.all).all);
1005 end Executable_Prefix;
1011 procedure Exit_Program (Exit_Code : Exit_Code_Type) is
1013 -- The program will exit with the following status:
1015 -- 0 if the object file has been generated (with or without warnings)
1016 -- 1 if recompilation was not needed (smart recompilation)
1017 -- 2 if gnat1 has been killed by a signal (detected by GCC)
1018 -- 4 for a fatal error
1019 -- 5 if there were errors
1020 -- 6 if no code has been generated (spec)
1022 -- Note that exit code 3 is not used and must not be used as this is
1023 -- the code returned by a program aborted via C abort() routine on
1024 -- Windows. GCC checks for that case and thinks that the child process
1025 -- has been aborted. This code (exit code 3) used to be the code used
1026 -- for E_No_Code, but E_No_Code was changed to 6 for this reason.
1029 when E_Success => OS_Exit (0);
1030 when E_Warnings => OS_Exit (0);
1031 when E_No_Compile => OS_Exit (1);
1032 when E_Fatal => OS_Exit (4);
1033 when E_Errors => OS_Exit (5);
1034 when E_No_Code => OS_Exit (6);
1035 when E_Abort => OS_Abort;
1043 procedure Fail (S : String) is
1045 -- We use Output in case there is a special output set up. In this case
1046 -- Set_Standard_Error will have no immediate effect.
1049 Osint.Write_Program_Name;
1054 Exit_Program (E_Fatal);
1057 ----------------------
1058 -- File_Names_Equal --
1059 ----------------------
1061 function File_Names_Equal (File1, File2 : String) return Boolean is
1063 if File_Names_Case_Sensitive then
1064 return File1 = File2;
1066 return To_Lower (File1) = To_Lower (File2);
1068 end File_Names_Equal;
1074 function File_Hash (F : File_Name_Type) return File_Hash_Num is
1076 return File_Hash_Num (Int (F) mod File_Hash_Num'Range_Length);
1083 function File_Length
1084 (Name : C_File_Name;
1085 Attr : access File_Attributes) return Long_Integer
1090 A : System.Address) return CRTL.int64;
1091 pragma Import (C, Internal, "__gnat_file_length_attr");
1094 -- The conversion from int64 to Long_Integer is ok here as this
1095 -- routine is only to be used by the compiler and we do not expect
1096 -- a unit to be larger than a 32bit integer.
1098 return Long_Integer (Internal (-1, Name, Attr.all'Address));
1101 ---------------------
1102 -- File_Time_Stamp --
1103 ---------------------
1105 function File_Time_Stamp
1106 (Name : C_File_Name;
1107 Attr : access File_Attributes) return OS_Time
1109 function Internal (N : C_File_Name; A : System.Address) return OS_Time;
1110 pragma Import (C, Internal, "__gnat_file_time_name_attr");
1112 return Internal (Name, Attr.all'Address);
1113 end File_Time_Stamp;
1115 function File_Time_Stamp
1116 (Name : Path_Name_Type;
1117 Attr : access File_Attributes) return Time_Stamp_Type
1120 if Name = No_Path then
1121 return Empty_Time_Stamp;
1124 Get_Name_String (Name);
1125 Name_Buffer (Name_Len + 1) := ASCII.NUL;
1126 return OS_Time_To_GNAT_Time
1127 (File_Time_Stamp (Name_Buffer'Address, Attr));
1128 end File_Time_Stamp;
1134 function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type is
1136 if Name = No_File then
1137 return Empty_Time_Stamp;
1140 Get_Name_String (Name);
1142 -- File_Time_Stamp will always return Invalid_Time if the file does
1143 -- not exist, and OS_Time_To_GNAT_Time will convert this value to
1144 -- Empty_Time_Stamp. Therefore we do not need to first test whether
1145 -- the file actually exists, which saves a system call.
1147 return OS_Time_To_GNAT_Time
1148 (File_Time_Stamp (Name_Buffer (1 .. Name_Len)));
1151 function File_Stamp (Name : Path_Name_Type) return Time_Stamp_Type is
1153 return File_Stamp (File_Name_Type (Name));
1161 (N : File_Name_Type;
1163 Full_Name : Boolean := False) return File_Name_Type
1165 Attr : aliased File_Attributes;
1166 Found : File_Name_Type;
1168 Find_File (N, T, Found, Attr'Access, Full_Name);
1177 (N : File_Name_Type;
1179 Found : out File_Name_Type;
1180 Attr : access File_Attributes;
1181 Full_Name : Boolean := False)
1184 Get_Name_String (N);
1187 File_Name : String renames Name_Buffer (1 .. Name_Len);
1188 File : File_Name_Type := No_File;
1192 -- If we are looking for a config file, look only in the current
1193 -- directory, i.e. return input argument unchanged. Also look only in
1194 -- the current directory if we are looking for a .dg file (happens in
1198 or else (Debug_Generated_Code
1199 and then Name_Len > 3
1200 and then Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg")
1203 Attr.all := Unknown_Attributes;
1208 Full_Path : constant String :=
1209 Normalize_Pathname (Get_Name_String (N));
1210 Full_Size : constant Natural := Full_Path'Length;
1213 Name_Buffer (1 .. Full_Size) := Full_Path;
1214 Name_Len := Full_Size;
1219 -- Check that it is a file, not a directory
1221 if not Is_Regular_File (Get_Name_String (Found)) then
1228 -- If we are trying to find the current main file just look in the
1229 -- directory where the user said it was.
1231 elsif Look_In_Primary_Directory_For_Current_Main
1232 and then Current_Main = N
1234 Locate_File (N, T, Primary_Directory, File_Name, Found, Attr);
1237 -- Otherwise do standard search for source file
1240 -- Check the mapping of this file name
1242 File := Mapped_Path_Name (N);
1244 -- If the file name is mapped to a path name, return the
1245 -- corresponding path name
1247 if File /= No_File then
1249 -- For locally removed file, Error_Name is returned; then
1250 -- return No_File, indicating the file is not a source.
1252 if File = Error_File_Name then
1258 Attr.all := Unknown_Attributes;
1262 -- First place to look is in the primary directory (i.e. the same
1263 -- directory as the source) unless this has been disabled with -I-
1265 if Opt.Look_In_Primary_Dir then
1266 Locate_File (N, T, Primary_Directory, File_Name, Found, Attr);
1268 if Found /= No_File then
1273 -- Finally look in directories specified with switches -I/-aI/-aO
1276 Last_Dir := Lib_Search_Directories.Last;
1278 Last_Dir := Src_Search_Directories.Last;
1281 for D in Primary_Directory + 1 .. Last_Dir loop
1282 Locate_File (N, T, D, File_Name, Found, Attr);
1284 if Found /= No_File then
1289 Attr.all := Unknown_Attributes;
1295 -----------------------
1296 -- Find_Program_Name --
1297 -----------------------
1299 procedure Find_Program_Name is
1300 Command_Name : String (1 .. Len_Arg (0));
1301 Cindex1 : Integer := Command_Name'First;
1302 Cindex2 : Integer := Command_Name'Last;
1305 Fill_Arg (Command_Name'Address, 0);
1307 if Command_Name = "" then
1312 -- The program name might be specified by a full path name. However,
1313 -- we don't want to print that all out in an error message, so the
1314 -- path might need to be stripped away.
1316 for J in reverse Cindex1 .. Cindex2 loop
1317 if Is_Directory_Separator (Command_Name (J)) then
1323 -- Command_Name(Cindex1 .. Cindex2) is now the equivalent of the
1324 -- POSIX command "basename argv[0]"
1326 -- Strip off any executable extension (usually nothing or .exe)
1327 -- but formally reported by autoconf in the variable EXEEXT
1329 if Cindex2 - Cindex1 >= 4 then
1330 if To_Lower (Command_Name (Cindex2 - 3)) = '.'
1331 and then To_Lower (Command_Name (Cindex2 - 2)) = 'e
'
1332 and then To_Lower (Command_Name (Cindex2 - 1)) = 'x
'
1333 and then To_Lower (Command_Name (Cindex2)) = 'e
'
1335 Cindex2 := Cindex2 - 4;
1339 Name_Len := Cindex2 - Cindex1 + 1;
1340 Name_Buffer (1 .. Name_Len) := Command_Name (Cindex1 .. Cindex2);
1341 end Find_Program_Name;
1343 ------------------------
1344 -- Full_Lib_File_Name --
1345 ------------------------
1347 procedure Full_Lib_File_Name
1348 (N : File_Name_Type;
1349 Lib_File : out File_Name_Type;
1350 Attr : out File_Attributes)
1353 Smart_Find_File (N, Library, Lib_File, Attr);
1354 end Full_Lib_File_Name;
1356 ------------------------
1357 -- Full_Lib_File_Name --
1358 ------------------------
1360 function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type is
1361 Attr : File_Attributes;
1362 File : File_Name_Type;
1364 Full_Lib_File_Name (N, File, Attr);
1366 end Full_Lib_File_Name;
1368 ----------------------------
1369 -- Full_Library_Info_Name --
1370 ----------------------------
1372 function Full_Library_Info_Name return File_Name_Type is
1374 return Current_Full_Lib_Name;
1375 end Full_Library_Info_Name;
1377 ---------------------------
1378 -- Full_Object_File_Name --
1379 ---------------------------
1381 function Full_Object_File_Name return File_Name_Type is
1383 return Current_Full_Obj_Name;
1384 end Full_Object_File_Name;
1386 ----------------------
1387 -- Full_Source_Name --
1388 ----------------------
1390 function Full_Source_Name return File_Name_Type is
1392 return Current_Full_Source_Name;
1393 end Full_Source_Name;
1395 ----------------------
1396 -- Full_Source_Name --
1397 ----------------------
1399 function Full_Source_Name (N : File_Name_Type) return File_Name_Type is
1401 return Smart_Find_File (N, Source);
1402 end Full_Source_Name;
1404 ----------------------
1405 -- Full_Source_Name --
1406 ----------------------
1408 procedure Full_Source_Name
1409 (N : File_Name_Type;
1410 Full_File : out File_Name_Type;
1411 Attr : access File_Attributes) is
1413 Smart_Find_File (N, Source, Full_File, Attr.all);
1414 end Full_Source_Name;
1420 function Get_Directory (Name : File_Name_Type) return File_Name_Type is
1422 Get_Name_String (Name);
1424 for J in reverse 1 .. Name_Len loop
1425 if Is_Directory_Separator (Name_Buffer (J)) then
1431 Name_Len := Hostparm.Normalized_CWD'Length;
1432 Name_Buffer (1 .. Name_Len) := Hostparm.Normalized_CWD;
1436 ------------------------------
1437 -- Get_First_Main_File_Name --
1438 ------------------------------
1440 function Get_First_Main_File_Name return String is
1442 return File_Names (1).all;
1443 end Get_First_Main_File_Name;
1445 --------------------------
1446 -- Get_Next_Dir_In_Path --
1447 --------------------------
1449 Search_Path_Pos : Integer;
1450 -- Keeps track of current position in search path. Initialized by the
1451 -- call to Get_Next_Dir_In_Path_Init, updated by Get_Next_Dir_In_Path.
1453 function Get_Next_Dir_In_Path
1454 (Search_Path : String_Access) return String_Access
1456 Lower_Bound : Positive := Search_Path_Pos;
1457 Upper_Bound : Positive;
1461 while Lower_Bound <= Search_Path'Last
1462 and then Search_Path.all (Lower_Bound) = Path_Separator
1464 Lower_Bound := Lower_Bound + 1;
1467 exit when Lower_Bound > Search_Path'Last;
1469 Upper_Bound := Lower_Bound;
1470 while Upper_Bound <= Search_Path'Last
1471 and then Search_Path.all (Upper_Bound) /= Path_Separator
1473 Upper_Bound := Upper_Bound + 1;
1476 Search_Path_Pos := Upper_Bound;
1477 return new String'(Search_Path
.all (Lower_Bound
.. Upper_Bound
- 1));
1481 end Get_Next_Dir_In_Path
;
1483 -------------------------------
1484 -- Get_Next_Dir_In_Path_Init --
1485 -------------------------------
1487 procedure Get_Next_Dir_In_Path_Init
(Search_Path
: String_Access
) is
1489 Search_Path_Pos
:= Search_Path
'First;
1490 end Get_Next_Dir_In_Path_Init
;
1492 --------------------------------------
1493 -- Get_Primary_Src_Search_Directory --
1494 --------------------------------------
1496 function Get_Primary_Src_Search_Directory
return String_Ptr
is
1498 return Src_Search_Directories
.Table
(Primary_Directory
);
1499 end Get_Primary_Src_Search_Directory
;
1501 ------------------------
1502 -- Get_RTS_Search_Dir --
1503 ------------------------
1505 function Get_RTS_Search_Dir
1506 (Search_Dir
: String;
1507 File_Type
: Search_File_Type
) return String_Ptr
1509 procedure Get_Current_Dir
1510 (Dir
: System
.Address
;
1511 Length
: System
.Address
);
1512 pragma Import
(C
, Get_Current_Dir
, "__gnat_get_current_dir");
1515 pragma Import
(C
, Max_Path
, "__gnat_max_path_len");
1516 -- Maximum length of a path name
1518 Current_Dir
: String_Ptr
;
1519 Default_Search_Dir
: String_Access
;
1520 Default_Suffix_Dir
: String_Access
;
1521 Local_Search_Dir
: String_Access
;
1522 Norm_Search_Dir
: String_Access
;
1523 Result_Search_Dir
: String_Access
;
1524 Search_File
: String_Access
;
1525 Temp_String
: String_Ptr
;
1528 -- Add a directory separator at the end of the directory if necessary
1529 -- so that we can directly append a file to the directory
1531 if not Is_Directory_Separator
(Search_Dir
(Search_Dir
'Last)) then
1533 new String'(Search_Dir & String'(1 => Directory_Separator
));
1535 Local_Search_Dir
:= new String'(Search_Dir);
1538 if File_Type = Include then
1539 Search_File := Include_Search_File;
1540 Default_Suffix_Dir := new String'("adainclude");
1542 Search_File
:= Objects_Search_File
;
1543 Default_Suffix_Dir
:= new String'("adalib");
1546 Norm_Search_Dir := Local_Search_Dir;
1548 if Is_Absolute_Path (Norm_Search_Dir.all) then
1550 -- We first verify if there is a directory Include_Search_Dir
1551 -- containing default search directories
1553 Result_Search_Dir :=
1554 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);
1557 Free
(Norm_Search_Dir
);
1559 if Result_Search_Dir
/= null then
1560 return String_Ptr
(Result_Search_Dir
);
1561 elsif Is_Directory
(Default_Search_Dir
.all) then
1562 return String_Ptr
(Default_Search_Dir
);
1567 -- Search in the current directory
1570 -- Get the current directory
1573 Buffer
: String (1 .. Max_Path
+ 2);
1574 Path_Len
: Natural := Max_Path
;
1577 Get_Current_Dir
(Buffer
'Address, Path_Len
'Address);
1579 if Path_Len
= 0 then
1580 raise Program_Error
;
1583 if not Is_Directory_Separator
(Buffer
(Path_Len
)) then
1584 Path_Len
:= Path_Len
+ 1;
1585 Buffer
(Path_Len
) := Directory_Separator
;
1588 Current_Dir
:= new String'(Buffer (1 .. Path_Len));
1592 new String'(Current_Dir
.all & Local_Search_Dir
.all);
1594 Result_Search_Dir
:=
1595 Read_Default_Search_Dirs
(Norm_Search_Dir
, Search_File
, null);
1597 Default_Search_Dir
:=
1598 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1600 Free (Norm_Search_Dir);
1602 if Result_Search_Dir /= null then
1603 return String_Ptr (Result_Search_Dir);
1605 elsif Is_Directory (Default_Search_Dir.all) then
1606 return String_Ptr (Default_Search_Dir);
1609 -- Search in Search_Dir_Prefix/Search_Dir
1613 (Update_Path
(Search_Dir_Prefix
).all & Local_Search_Dir
.all);
1615 Result_Search_Dir
:=
1616 Read_Default_Search_Dirs
(Norm_Search_Dir
, Search_File
, null);
1618 Default_Search_Dir
:=
1619 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1621 Free (Norm_Search_Dir);
1623 if Result_Search_Dir /= null then
1624 return String_Ptr (Result_Search_Dir);
1626 elsif Is_Directory (Default_Search_Dir.all) then
1627 return String_Ptr (Default_Search_Dir);
1630 -- We finally search in Search_Dir_Prefix/rts-Search_Dir
1633 new String'(Update_Path
(Search_Dir_Prefix
).all & "rts-");
1636 new String'(Temp_String.all & Local_Search_Dir.all);
1638 Result_Search_Dir :=
1639 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1641 Default_Search_Dir :=
1642 new String'(Norm_Search_Dir
.all & Default_Suffix_Dir
.all);
1643 Free
(Norm_Search_Dir
);
1645 if Result_Search_Dir
/= null then
1646 return String_Ptr
(Result_Search_Dir
);
1648 elsif Is_Directory
(Default_Search_Dir
.all) then
1649 return String_Ptr
(Default_Search_Dir
);
1657 end Get_RTS_Search_Dir
;
1659 --------------------------------
1660 -- Include_Dir_Default_Prefix --
1661 --------------------------------
1663 function Include_Dir_Default_Prefix
return String_Access
is
1665 if The_Include_Dir_Default_Prefix
= null then
1666 The_Include_Dir_Default_Prefix
:=
1667 String_Access
(Update_Path
(Include_Dir_Default_Name
));
1670 return The_Include_Dir_Default_Prefix
;
1671 end Include_Dir_Default_Prefix
;
1673 function Include_Dir_Default_Prefix
return String is
1675 return Include_Dir_Default_Prefix
.all;
1676 end Include_Dir_Default_Prefix
;
1682 procedure Initialize
is
1684 Number_File_Names
:= 0;
1685 Current_File_Name_Index
:= 0;
1687 Src_Search_Directories
.Init
;
1688 Lib_Search_Directories
.Init
;
1690 -- Start off by setting all suppress options, to False. The special
1691 -- overflow fields are set to Not_Set (they will be set by -gnatp, or
1692 -- by -gnato, or, if neither of these appear, in Adjust_Global_Switches
1695 Suppress_Options
:= ((others => False), Not_Set
, Not_Set
);
1697 -- Reserve the first slot in the search paths table. This is the
1698 -- directory of the main source file or main library file and is filled
1699 -- in by each call to Next_Main_Source/Next_Main_Lib_File with the
1700 -- directory specified for this main source or library file. This is the
1701 -- directory which is searched first by default. This default search is
1702 -- inhibited by the option -I- for both source and library files.
1704 Src_Search_Directories
.Set_Last
(Primary_Directory
);
1705 Src_Search_Directories
.Table
(Primary_Directory
) := new String'("");
1707 Lib_Search_Directories.Set_Last (Primary_Directory);
1708 Lib_Search_Directories.Table (Primary_Directory) := new String'("");
1715 function Is_Directory
1716 (Name
: C_File_Name
; Attr
: access File_Attributes
) return Boolean
1718 function Internal
(N
: C_File_Name
; A
: System
.Address
) return Integer;
1719 pragma Import
(C
, Internal
, "__gnat_is_directory_attr");
1721 return Internal
(Name
, Attr
.all'Address) /= 0;
1724 ----------------------------
1725 -- Is_Directory_Separator --
1726 ----------------------------
1728 function Is_Directory_Separator
(C
: Character) return Boolean is
1730 -- In addition to the default directory_separator allow the '/' to
1731 -- act as separator since this is allowed in MS-DOS and Windows.
1733 return C
= Directory_Separator
or else C
= '/';
1734 end Is_Directory_Separator
;
1736 -------------------------
1737 -- Is_Readonly_Library --
1738 -------------------------
1740 function Is_Readonly_Library
(File
: File_Name_Type
) return Boolean is
1742 Get_Name_String
(File
);
1744 pragma Assert
(Name_Buffer
(Name_Len
- 3 .. Name_Len
) = ".ali");
1746 return not Is_Writable_File
(Name_Buffer
(1 .. Name_Len
));
1747 end Is_Readonly_Library
;
1749 ------------------------
1750 -- Is_Executable_File --
1751 ------------------------
1753 function Is_Executable_File
1754 (Name
: C_File_Name
; Attr
: access File_Attributes
) return Boolean
1756 function Internal
(N
: C_File_Name
; A
: System
.Address
) return Integer;
1757 pragma Import
(C
, Internal
, "__gnat_is_executable_file_attr");
1759 return Internal
(Name
, Attr
.all'Address) /= 0;
1760 end Is_Executable_File
;
1762 ----------------------
1763 -- Is_Readable_File --
1764 ----------------------
1766 function Is_Readable_File
1767 (Name
: C_File_Name
; Attr
: access File_Attributes
) return Boolean
1769 function Internal
(N
: C_File_Name
; A
: System
.Address
) return Integer;
1770 pragma Import
(C
, Internal
, "__gnat_is_readable_file_attr");
1772 return Internal
(Name
, Attr
.all'Address) /= 0;
1773 end Is_Readable_File
;
1775 ---------------------
1776 -- Is_Regular_File --
1777 ---------------------
1779 function Is_Regular_File
1780 (Name
: C_File_Name
; Attr
: access File_Attributes
) return Boolean
1782 function Internal
(N
: C_File_Name
; A
: System
.Address
) return Integer;
1783 pragma Import
(C
, Internal
, "__gnat_is_regular_file_attr");
1785 return Internal
(Name
, Attr
.all'Address) /= 0;
1786 end Is_Regular_File
;
1788 ----------------------
1789 -- Is_Symbolic_Link --
1790 ----------------------
1792 function Is_Symbolic_Link
1793 (Name
: C_File_Name
; Attr
: access File_Attributes
) return Boolean
1795 function Internal
(N
: C_File_Name
; A
: System
.Address
) return Integer;
1796 pragma Import
(C
, Internal
, "__gnat_is_symbolic_link_attr");
1798 return Internal
(Name
, Attr
.all'Address) /= 0;
1799 end Is_Symbolic_Link
;
1801 ----------------------
1802 -- Is_Writable_File --
1803 ----------------------
1805 function Is_Writable_File
1806 (Name
: C_File_Name
; Attr
: access File_Attributes
) return Boolean
1808 function Internal
(N
: C_File_Name
; A
: System
.Address
) return Integer;
1809 pragma Import
(C
, Internal
, "__gnat_is_writable_file_attr");
1811 return Internal
(Name
, Attr
.all'Address) /= 0;
1812 end Is_Writable_File
;
1818 function Lib_File_Name
1819 (Source_File
: File_Name_Type
;
1820 Munit_Index
: Nat
:= 0) return File_Name_Type
1823 Get_Name_String
(Source_File
);
1825 for J
in reverse 2 .. Name_Len
loop
1826 if Name_Buffer
(J
) = '.' then
1832 if Munit_Index
/= 0 then
1833 Add_Char_To_Name_Buffer
(Multi_Unit_Index_Character
);
1834 Add_Nat_To_Name_Buffer
(Munit_Index
);
1837 Add_Char_To_Name_Buffer
('.');
1838 Add_Str_To_Name_Buffer
(ALI_Suffix
.all);
1846 procedure Locate_File
1847 (N
: File_Name_Type
;
1851 Found
: out File_Name_Type
;
1852 Attr
: access File_Attributes
)
1854 Dir_Name
: String_Ptr
;
1857 -- If Name is already an absolute path, do not look for a directory
1859 if Is_Absolute_Path
(Name
) then
1862 elsif T
= Library
then
1863 Dir_Name
:= Lib_Search_Directories
.Table
(Dir
);
1866 pragma Assert
(T
/= Config
);
1867 Dir_Name
:= Src_Search_Directories
.Table
(Dir
);
1871 Full_Name
: String (1 .. Dir_Name
'Length + Name
'Length + 1);
1874 Full_Name
(1 .. Dir_Name
'Length) := Dir_Name
.all;
1875 Full_Name
(Dir_Name
'Length + 1 .. Full_Name
'Last - 1) := Name
;
1876 Full_Name
(Full_Name
'Last) := ASCII
.NUL
;
1878 Attr
.all := Unknown_Attributes
;
1880 if not Is_Regular_File
(Full_Name
'Address, Attr
) then
1884 -- If the file is in the current directory then return N itself
1886 if Dir_Name
'Length = 0 then
1889 Name_Len
:= Full_Name
'Length - 1;
1890 Name_Buffer
(1 .. Name_Len
) :=
1891 Full_Name
(1 .. Full_Name
'Last - 1);
1898 -------------------------------
1899 -- Matching_Full_Source_Name --
1900 -------------------------------
1902 function Matching_Full_Source_Name
1903 (N
: File_Name_Type
;
1904 T
: Time_Stamp_Type
) return File_Name_Type
1907 Get_Name_String
(N
);
1910 File_Name
: constant String := Name_Buffer
(1 .. Name_Len
);
1911 File
: File_Name_Type
:= No_File
;
1912 Attr
: aliased File_Attributes
;
1916 if Opt
.Look_In_Primary_Dir
then
1918 (N
, Source
, Primary_Directory
, File_Name
, File
,
1919 Attr
'Unchecked_Access);
1921 if File
/= No_File
and then T
= File_Stamp
(N
) then
1926 Last_Dir
:= Src_Search_Directories
.Last
;
1928 for D
in Primary_Directory
+ 1 .. Last_Dir
loop
1929 Locate_File
(N
, Source
, D
, File_Name
, File
, Attr
'Unchecked_Access);
1931 if File
/= No_File
and then T
= File_Stamp
(File
) then
1938 end Matching_Full_Source_Name
;
1944 function More_Files
return Boolean is
1946 return (Current_File_Name_Index
< Number_File_Names
);
1949 -------------------------------
1950 -- Nb_Dir_In_Obj_Search_Path --
1951 -------------------------------
1953 function Nb_Dir_In_Obj_Search_Path
return Natural is
1955 if Opt
.Look_In_Primary_Dir
then
1956 return Lib_Search_Directories
.Last
- Primary_Directory
+ 1;
1958 return Lib_Search_Directories
.Last
- Primary_Directory
;
1960 end Nb_Dir_In_Obj_Search_Path
;
1962 -------------------------------
1963 -- Nb_Dir_In_Src_Search_Path --
1964 -------------------------------
1966 function Nb_Dir_In_Src_Search_Path
return Natural is
1968 if Opt
.Look_In_Primary_Dir
then
1969 return Src_Search_Directories
.Last
- Primary_Directory
+ 1;
1971 return Src_Search_Directories
.Last
- Primary_Directory
;
1973 end Nb_Dir_In_Src_Search_Path
;
1975 --------------------
1976 -- Next_Main_File --
1977 --------------------
1979 function Next_Main_File
return File_Name_Type
is
1980 File_Name
: String_Ptr
;
1981 Dir_Name
: String_Ptr
;
1985 pragma Assert
(More_Files
);
1987 Current_File_Name_Index
:= Current_File_Name_Index
+ 1;
1989 -- Get the file and directory name
1991 File_Name
:= File_Names
(Current_File_Name_Index
);
1992 Fptr
:= File_Name
'First;
1994 for J
in reverse File_Name
'Range loop
1995 if Is_Directory_Separator
(File_Name
(J
)) then
1996 if J
= File_Name
'Last then
1997 Fail
("File name missing");
2005 -- Save name of directory in which main unit resides for use in
2006 -- locating other units
2008 Dir_Name
:= new String'(File_Name (File_Name'First .. Fptr - 1));
2010 case Running_Program is
2012 Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
2013 Look_In_Primary_Directory_For_Current_Main := True;
2016 Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
2018 if Fptr > File_Name'First then
2019 Look_In_Primary_Directory_For_Current_Main := True;
2025 Dir_Name := Normalize_Directory_Name (Dir_Name.all);
2026 Lib_Search_Directories.Table (Primary_Directory) := Dir_Name;
2032 Name_Len := File_Name'Last - Fptr + 1;
2033 Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last);
2034 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
2035 Current_Main := Name_Find;
2037 -- In the gnatmake case, the main file may have not have the
2038 -- extension. Try ".adb" first then ".ads"
2040 if Running_Program = Make then
2042 Orig_Main : constant File_Name_Type := Current_Main;
2045 if Strip_Suffix (Orig_Main) = Orig_Main then
2047 Append_Suffix_To_File_Name (Orig_Main, ".adb");
2049 if Full_Source_Name (Current_Main) = No_File then
2051 Append_Suffix_To_File_Name (Orig_Main, ".ads");
2053 if Full_Source_Name (Current_Main) = No_File then
2054 Current_Main := Orig_Main;
2061 return Current_Main;
2064 ------------------------------
2065 -- Normalize_Directory_Name --
2066 ------------------------------
2068 function Normalize_Directory_Name (Directory : String) return String_Ptr is
2070 function Is_Quoted (Path : String) return Boolean;
2071 pragma Inline (Is_Quoted);
2072 -- Returns true if Path is quoted (either double or single quotes)
2078 function Is_Quoted (Path : String) return Boolean is
2079 First : constant Character := Path (Path'First);
2080 Last : constant Character := Path (Path'Last);
2083 if (First = ''' and then Last = ''')
2085 (First = '"' and then Last = '"')
2093 Result : String_Ptr;
2095 -- Start of processing for Normalize_Directory_Name
2098 if Directory'Length = 0 then
2099 Result := new String'(Hostparm
.Normalized_CWD
);
2101 elsif Is_Directory_Separator
(Directory
(Directory
'Last)) then
2102 Result
:= new String'(Directory);
2104 elsif Is_Quoted (Directory) then
2106 -- This is a quoted string, it certainly means that the directory
2107 -- contains some spaces for example. We can safely remove the quotes
2108 -- here as the OS_Lib.Normalize_Arguments will be called before any
2109 -- spawn routines. This ensure that quotes will be added when needed.
2111 Result := new String (1 .. Directory'Length - 1);
2112 Result (1 .. Directory'Length - 2) :=
2113 Directory (Directory'First + 1 .. Directory'Last - 1);
2114 Result (Result'Last) := Directory_Separator;
2117 Result := new String (1 .. Directory'Length + 1);
2118 Result (1 .. Directory'Length) := Directory;
2119 Result (Directory'Length + 1) := Directory_Separator;
2123 end Normalize_Directory_Name;
2125 ---------------------
2126 -- Number_Of_Files --
2127 ---------------------
2129 function Number_Of_Files return Nat is
2131 return Number_File_Names;
2132 end Number_Of_Files;
2134 -------------------------------
2135 -- Object_Dir_Default_Prefix --
2136 -------------------------------
2138 function Object_Dir_Default_Prefix return String is
2139 Object_Dir : String_Access :=
2140 String_Access (Update_Path (Object_Dir_Default_Name));
2143 if Object_Dir = null then
2148 Result : constant String := Object_Dir.all;
2154 end Object_Dir_Default_Prefix;
2156 ----------------------
2157 -- Object_File_Name --
2158 ----------------------
2160 function Object_File_Name (N : File_Name_Type) return File_Name_Type is
2166 Get_Name_String (N);
2167 Name_Len := Name_Len - ALI_Suffix'Length - 1;
2169 for J in Target_Object_Suffix'Range loop
2170 Name_Len := Name_Len + 1;
2171 Name_Buffer (Name_Len) := Target_Object_Suffix (J);
2175 end Object_File_Name;
2177 -------------------------------
2178 -- OS_Exit_Through_Exception --
2179 -------------------------------
2181 procedure OS_Exit_Through_Exception (Status : Integer) is
2183 Current_Exit_Status := Status;
2184 raise Types.Terminate_Program;
2185 end OS_Exit_Through_Exception;
2187 --------------------------
2188 -- OS_Time_To_GNAT_Time --
2189 --------------------------
2191 function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type is
2192 GNAT_Time : Time_Stamp_Type;
2194 type Underlying_OS_Time is
2195 range -(2 ** 63) .. +(2 ** 63 - 1);
2196 -- Underlying_OS_Time is a redeclaration of OS_Time to allow integer
2197 -- manipulation. Remove this in favor of To_Ada/To_C once newer
2198 -- GNAT releases are available with these functions.
2201 new Unchecked_Conversion (OS_Time, Underlying_OS_Time);
2202 function From_Int is
2203 new Unchecked_Conversion (Underlying_OS_Time, OS_Time);
2205 TI : Underlying_OS_Time := To_Int (T);
2214 if T = Invalid_Time then
2215 return Empty_Time_Stamp;
2218 if On_Windows and then TI mod 2 > 0 then
2219 -- Windows ALI files had timestamps rounded to even seconds
2220 -- historically. The rounding was originally done in GM_Split.
2221 -- Now that GM_Split no longer does it, we are rounding it here
2222 -- only for ALI files.
2227 GM_Split (From_Int (TI), Y, Mo, D, H, Mn, S);
2234 Minutes => Nat (Mn),
2239 end OS_Time_To_GNAT_Time;
2245 function Prep_Suffix return String is
2254 function Program_Name (Nam : String; Prog : String) return String_Access is
2255 End_Of_Prefix : Natural := 0;
2256 Start_Of_Prefix : Positive := 1;
2257 Start_Of_Suffix : Positive;
2260 -- Get the name of the current program being executed
2264 Start_Of_Suffix := Name_Len + 1;
2266 -- Find the target prefix if any, for the cross compilation case.
2267 -- For instance in "powerpc-elf-gcc" the target prefix is
2269 -- Ditto for suffix, e.g. in "gcc-4.1", the suffix is "-4.1"
2271 for J in reverse 1 .. Name_Len loop
2272 if Is_Directory_Separator (Name_Buffer (J))
2273 or else Name_Buffer (J) = ':'
2275 Start_Of_Prefix := J + 1;
2280 -- Find End_Of_Prefix
2282 for J in Start_Of_Prefix .. Name_Len - Prog'Length + 1 loop
2283 if Name_Buffer (J .. J + Prog'Length - 1) = Prog then
2284 End_Of_Prefix := J - 1;
2289 if End_Of_Prefix > 1 then
2290 Start_Of_Suffix := End_Of_Prefix + Prog'Length + 1;
2293 -- Create the new program name
2296 (Name_Buffer
(Start_Of_Prefix
.. End_Of_Prefix
)
2298 & Name_Buffer
(Start_Of_Suffix
.. Name_Len
));
2301 ------------------------------
2302 -- Read_Default_Search_Dirs --
2303 ------------------------------
2305 function Read_Default_Search_Dirs
2306 (Search_Dir_Prefix
: String_Access
;
2307 Search_File
: String_Access
;
2308 Search_Dir_Default_Name
: String_Access
) return String_Access
2310 Prefix_Len
: constant Integer := Search_Dir_Prefix
.all'Length;
2311 Buffer
: String (1 .. Prefix_Len
+ Search_File
.all'Length + 1);
2312 File_FD
: File_Descriptor
;
2313 S
, S1
: String_Access
;
2316 Actual_Len
: Integer;
2319 Prev_Was_Separator
: Boolean;
2320 Nb_Relative_Dir
: Integer;
2322 function Is_Relative
(S
: String; K
: Positive) return Boolean;
2323 pragma Inline
(Is_Relative
);
2324 -- Returns True if a relative directory specification is found
2325 -- in S at position K, False otherwise.
2331 function Is_Relative
(S
: String; K
: Positive) return Boolean is
2333 return not Is_Absolute_Path
(S
(K
.. S
'Last));
2336 -- Start of processing for Read_Default_Search_Dirs
2339 -- Construct a C compatible character string buffer
2341 Buffer
(1 .. Search_Dir_Prefix
.all'Length)
2342 := Search_Dir_Prefix
.all;
2343 Buffer
(Search_Dir_Prefix
.all'Length + 1 .. Buffer
'Last - 1)
2345 Buffer
(Buffer
'Last) := ASCII
.NUL
;
2347 File_FD
:= Open_Read
(Buffer
'Address, Binary
);
2348 if File_FD
= Invalid_FD
then
2349 return Search_Dir_Default_Name
;
2352 Len
:= Integer (File_Length
(File_FD
));
2354 -- An extra character for a trailing Path_Separator is allocated
2356 S
:= new String (1 .. Len
+ 1);
2357 S
(Len
+ 1) := Path_Separator
;
2359 -- Read the file. Note that the loop is probably not necessary since the
2360 -- whole file is read at once but the loop is harmless and that way we
2361 -- are sure to accommodate systems where this is not the case.
2365 while Actual_Len
/= 0 loop
2366 Actual_Len
:= Read
(File_FD
, S
(Curr
)'Address, Len
);
2367 Curr
:= Curr
+ Actual_Len
;
2370 -- Process the file, dealing with path separators
2372 Prev_Was_Separator
:= True;
2373 Nb_Relative_Dir
:= 0;
2374 for J
in 1 .. Len
loop
2376 -- Treat any EOL character as a path separator. Note that we do
2377 -- not treat space as a path separator (we used to treat space as a
2378 -- path separator in an earlier version). That way space can appear
2379 -- as a legitimate character in a path name.
2381 if S
(J
) = ASCII
.LF
or else S
(J
) = ASCII
.CR
then
2382 S
(J
) := Path_Separator
;
2385 -- Test for explicit path separator (or control char as above)
2387 if S
(J
) = Path_Separator
then
2388 Prev_Was_Separator
:= True;
2390 -- If not path separator, register use of relative directory
2393 if Prev_Was_Separator
and then Is_Relative
(S
.all, J
) then
2394 Nb_Relative_Dir
:= Nb_Relative_Dir
+ 1;
2397 Prev_Was_Separator
:= False;
2401 if Nb_Relative_Dir
= 0 then
2405 -- Add the Search_Dir_Prefix to all relative paths
2407 S1
:= new String (1 .. S
'Length + Nb_Relative_Dir
* Prefix_Len
);
2409 Prev_Was_Separator
:= True;
2410 for J
in 1 .. Len
+ 1 loop
2411 if S
(J
) = Path_Separator
then
2412 Prev_Was_Separator
:= True;
2415 if Prev_Was_Separator
and then Is_Relative
(S
.all, J
) then
2416 S1
(J1
.. J1
+ Prefix_Len
- 1) := Search_Dir_Prefix
.all;
2417 J1
:= J1
+ Prefix_Len
;
2420 Prev_Was_Separator
:= False;
2428 end Read_Default_Search_Dirs
;
2430 -----------------------
2431 -- Read_Library_Info --
2432 -----------------------
2434 function Read_Library_Info
2435 (Lib_File
: File_Name_Type
;
2436 Fatal_Err
: Boolean := False) return Text_Buffer_Ptr
2438 File
: File_Name_Type
;
2439 Attr
: aliased File_Attributes
;
2441 Find_File
(Lib_File
, Library
, File
, Attr
'Access);
2442 return Read_Library_Info_From_Full
2443 (Full_Lib_File
=> File
,
2444 Lib_File_Attr
=> Attr
'Access,
2445 Fatal_Err
=> Fatal_Err
);
2446 end Read_Library_Info
;
2448 ---------------------------------
2449 -- Read_Library_Info_From_Full --
2450 ---------------------------------
2452 function Read_Library_Info_From_Full
2453 (Full_Lib_File
: File_Name_Type
;
2454 Lib_File_Attr
: access File_Attributes
;
2455 Fatal_Err
: Boolean := False) return Text_Buffer_Ptr
2457 Lib_FD
: File_Descriptor
;
2458 -- The file descriptor for the current library file. A negative value
2459 -- indicates failure to open the specified source file.
2462 -- Length of source file text (ALI). If it doesn't fit in an integer
2463 -- we're probably stuck anyway (>2 gigs of source seems a lot, and
2464 -- there are other places in the compiler that make this assumption).
2466 Text
: Text_Buffer_Ptr
;
2467 -- Allocated text buffer
2470 pragma Warnings
(Off
, Status
);
2471 -- For the calls to Close
2474 Current_Full_Lib_Name
:= Full_Lib_File
;
2475 Current_Full_Obj_Name
:= Object_File_Name
(Current_Full_Lib_Name
);
2477 if Current_Full_Lib_Name
= No_File
then
2479 Fail
("Cannot find: " & Name_Buffer
(1 .. Name_Len
));
2481 Current_Full_Obj_Stamp
:= Empty_Time_Stamp
;
2486 Get_Name_String
(Current_Full_Lib_Name
);
2487 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
2489 -- Open the library FD, note that we open in binary mode, because as
2490 -- documented in the spec, the caller is expected to handle either
2491 -- DOS or Unix mode files, and there is no point in wasting time on
2492 -- text translation when it is not required.
2494 Lib_FD
:= Open_Read
(Name_Buffer
'Address, Binary
);
2496 if Lib_FD
= Invalid_FD
then
2498 Fail
("Cannot open: " & Name_Buffer
(1 .. Name_Len
));
2500 Current_Full_Obj_Stamp
:= Empty_Time_Stamp
;
2505 -- Compute the length of the file (potentially also preparing other data
2506 -- like the timestamp and whether the file is read-only, for future use)
2508 Len
:= Integer (File_Length
(Name_Buffer
'Address, Lib_File_Attr
));
2510 -- Check for object file consistency if requested
2512 if Opt
.Check_Object_Consistency
then
2513 -- On most systems, this does not result in an extra system call
2515 Current_Full_Lib_Stamp
:=
2516 OS_Time_To_GNAT_Time
2517 (File_Time_Stamp
(Name_Buffer
'Address, Lib_File_Attr
));
2519 -- ??? One system call here
2521 Current_Full_Obj_Stamp
:= File_Stamp
(Current_Full_Obj_Name
);
2523 if Current_Full_Obj_Stamp
(1) = ' ' then
2525 -- When the library is readonly always assume object is consistent
2526 -- The call to Is_Writable_File only results in a system call on
2527 -- some systems, but in most cases it has already been computed as
2528 -- part of the call to File_Length above.
2530 Get_Name_String
(Current_Full_Lib_Name
);
2531 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
2533 if not Is_Writable_File
(Name_Buffer
'Address, Lib_File_Attr
) then
2534 Current_Full_Obj_Stamp
:= Current_Full_Lib_Stamp
;
2536 elsif Fatal_Err
then
2537 Get_Name_String
(Current_Full_Obj_Name
);
2538 Close
(Lib_FD
, Status
);
2540 -- No need to check the status, we fail anyway
2542 Fail
("Cannot find: " & Name_Buffer
(1 .. Name_Len
));
2545 Current_Full_Obj_Stamp
:= Empty_Time_Stamp
;
2546 Close
(Lib_FD
, Status
);
2548 -- No need to check the status, we return null anyway
2553 elsif Current_Full_Obj_Stamp
< Current_Full_Lib_Stamp
then
2554 Close
(Lib_FD
, Status
);
2556 -- No need to check the status, we return null anyway
2562 -- Read data from the file
2565 Actual_Len
: Integer;
2567 Lo
: constant Text_Ptr
:= 0;
2568 -- Low bound for allocated text buffer
2570 Hi
: Text_Ptr
:= Text_Ptr
(Len
);
2571 -- High bound for allocated text buffer. Note length is Len + 1
2572 -- which allows for extra EOF character at the end of the buffer.
2575 -- Allocate text buffer. Note extra character at end for EOF
2577 Text
:= new Text_Buffer
(Lo
.. Hi
);
2579 -- Some systems have file types that require one read per line,
2580 -- so read until we get the Len bytes or until there are no more
2585 Actual_Len
:= Read
(Lib_FD
, Text
(Hi
)'Address, Len
);
2586 Hi
:= Hi
+ Text_Ptr
(Actual_Len
);
2587 exit when Actual_Len
= Len
or else Actual_Len
<= 0;
2593 -- Read is complete, close file and we are done
2595 Close
(Lib_FD
, Status
);
2596 -- The status should never be False. But, if it is, what can we do?
2597 -- So, we don't test it.
2601 end Read_Library_Info_From_Full
;
2603 ----------------------
2604 -- Read_Source_File --
2605 ----------------------
2607 procedure Read_Source_File
2608 (N
: File_Name_Type
;
2610 Hi
: out Source_Ptr
;
2611 Src
: out Source_Buffer_Ptr
;
2612 FD
: out File_Descriptor
;
2613 T
: File_Type
:= Source
)
2616 -- Length of file, assume no more than 2 gigabytes of source
2618 Actual_Len
: Integer;
2621 pragma Warnings
(Off
, Status
);
2622 -- For the call to Close
2625 Current_Full_Source_Name
:= Find_File
(N
, T
, Full_Name
=> True);
2626 Current_Full_Source_Stamp
:= File_Stamp
(Current_Full_Source_Name
);
2628 if Current_Full_Source_Name
= No_File
then
2630 -- If we were trying to access the main file and we could not find
2631 -- it, we have an error.
2633 if N
= Current_Main
then
2634 Get_Name_String
(N
);
2635 Fail
("Cannot find: " & Name_Buffer
(1 .. Name_Len
));
2644 Get_Name_String
(Current_Full_Source_Name
);
2645 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
2647 -- Open the source FD, note that we open in binary mode, because as
2648 -- documented in the spec, the caller is expected to handle either
2649 -- DOS or Unix mode files, and there is no point in wasting time on
2650 -- text translation when it is not required.
2652 FD
:= Open_Read
(Name_Buffer
'Address, Binary
);
2654 if FD
= Invalid_FD
then
2660 -- If it's a Source file, print out the file name, if requested, and if
2661 -- it's not part of the runtimes, store it in File_Name_Chars. We don't
2662 -- want to print non-Source files, like GNAT-TEMP-000001.TMP used to
2663 -- pass information from gprbuild to gcc. We don't want to save runtime
2664 -- file names, because we don't want users to send them in bug reports.
2668 Name
: String renames Name_Buffer
(1 .. Name_Len
);
2669 Inc
: String renames Include_Dir_Default_Prefix
.all;
2671 Part_Of_Runtimes
: constant Boolean :=
2673 and then Inc
'Length < Name_Len
2674 and then Name_Buffer
(1 .. Inc
'Length) = Inc
;
2677 if Debug
.Debug_Flag_Dot_N
then
2681 if not Part_Of_Runtimes
then
2682 File_Name_Chars
.Append_All
(File_Name_Chars
.Table_Type
(Name
));
2683 File_Name_Chars
.Append
(ASCII
.LF
);
2688 -- Prepare to read data from the file
2690 Len
:= Integer (File_Length
(FD
));
2692 -- Set Hi so that length is one more than the physical length,
2693 -- allowing for the extra EOF character at the end of the buffer
2695 Hi
:= Lo
+ Source_Ptr
(Len
);
2697 -- Do the actual read operation
2700 Var_Ptr
: constant Source_Buffer_Ptr_Var
:=
2701 new Source_Buffer
(Lo
.. Hi
);
2702 -- Allocate source buffer, allowing extra character at end for EOF
2704 -- Some systems have file types that require one read per line,
2705 -- so read until we get the Len bytes or until there are no more
2710 Actual_Len
:= Read
(FD
, Var_Ptr
(Hi
)'Address, Len
);
2711 Hi
:= Hi
+ Source_Ptr
(Actual_Len
);
2712 exit when Actual_Len
= Len
or else Actual_Len
<= 0;
2715 Var_Ptr
(Hi
) := EOF
;
2716 Src
:= Var_Ptr
.all'Access;
2719 -- Read is complete, get time stamp and close file and we are done
2723 -- The status should never be False. But, if it is, what can we do?
2724 -- So, we don't test it.
2726 -- ???We don't really need to return Hi anymore; We could get rid of
2727 -- it. We could also make this into a function.
2729 pragma Assert
(Hi
= Src
'Last);
2730 end Read_Source_File
;
2736 function Relocate_Path
2738 Path
: String) return String_Ptr
2742 procedure set_std_prefix
(S
: String; Len
: Integer);
2743 pragma Import
(C
, set_std_prefix
);
2746 if Std_Prefix
= null then
2747 Std_Prefix
:= Executable_Prefix
;
2749 if Std_Prefix
.all /= "" then
2751 -- Remove trailing directory separator when calling set_std_prefix
2753 set_std_prefix
(Std_Prefix
.all, Std_Prefix
'Length - 1);
2757 if Path
'Last >= Prefix
'Last and then Path
(Prefix
'Range) = Prefix
then
2758 if Std_Prefix
.all /= "" then
2760 (1 .. Std_Prefix
'Length + Path
'Last - Prefix
'Last);
2761 S
(1 .. Std_Prefix
'Length) := Std_Prefix
.all;
2762 S
(Std_Prefix
'Length + 1 .. S
'Last) :=
2763 Path
(Prefix
'Last + 1 .. Path
'Last);
2768 return new String'(Path);
2775 procedure Set_Program (P : Program_Type) is
2778 Fail ("Set_Program called twice");
2781 Program_Set := True;
2782 Running_Program := P;
2789 function Shared_Lib (Name : String) return String is
2790 Library : String (1 .. Name'Length + Library_Version'Length + 3);
2791 -- 3 = 2 for "-l" + 1 for "-" before lib version
2794 Library (1 .. 2) := "-l";
2795 Library (3 .. 2 + Name'Length) := Name;
2796 Library (3 + Name'Length) := '-';
2797 Library (4 + Name'Length .. Library'Last) := Library_Version;
2801 ----------------------
2802 -- Smart_File_Stamp --
2803 ----------------------
2805 function Smart_File_Stamp
2806 (N : File_Name_Type;
2807 T : File_Type) return Time_Stamp_Type
2809 File : File_Name_Type;
2810 Attr : aliased File_Attributes;
2813 if not File_Cache_Enabled then
2814 Find_File (N, T, File, Attr'Access);
2816 Smart_Find_File (N, T, File, Attr);
2819 if File = No_File then
2820 return Empty_Time_Stamp;
2822 Get_Name_String (File);
2823 Name_Buffer (Name_Len + 1) := ASCII.NUL;
2825 OS_Time_To_GNAT_Time
2826 (File_Time_Stamp (Name_Buffer'Address, Attr'Access));
2828 end Smart_File_Stamp;
2830 ---------------------
2831 -- Smart_Find_File --
2832 ---------------------
2834 function Smart_Find_File
2835 (N : File_Name_Type;
2836 T : File_Type) return File_Name_Type
2838 File : File_Name_Type;
2839 Attr : File_Attributes;
2841 Smart_Find_File (N, T, File, Attr);
2843 end Smart_Find_File;
2845 ---------------------
2846 -- Smart_Find_File --
2847 ---------------------
2849 procedure Smart_Find_File
2850 (N : File_Name_Type;
2852 Found : out File_Name_Type;
2853 Attr : out File_Attributes)
2855 Info : File_Info_Cache;
2858 if not File_Cache_Enabled then
2859 Find_File (N, T, Info.File, Info.Attr'Access);
2862 Info := File_Name_Hash_Table.Get (N);
2864 if Info.File = No_File then
2865 Find_File (N, T, Info.File, Info.Attr'Access);
2866 File_Name_Hash_Table.Set (N, Info);
2872 end Smart_Find_File;
2874 ----------------------
2875 -- Source_File_Data --
2876 ----------------------
2878 procedure Source_File_Data (Cache : Boolean) is
2880 File_Cache_Enabled := Cache;
2881 end Source_File_Data;
2883 -----------------------
2884 -- Source_File_Stamp --
2885 -----------------------
2887 function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is
2889 return Smart_File_Stamp (N, Source);
2890 end Source_File_Stamp;
2892 ---------------------
2893 -- Strip_Directory --
2894 ---------------------
2896 function Strip_Directory (Name : File_Name_Type) return File_Name_Type is
2898 Get_Name_String (Name);
2900 for J in reverse 1 .. Name_Len - 1 loop
2902 -- If we find the last directory separator
2904 if Is_Directory_Separator (Name_Buffer (J)) then
2906 -- Return part of Name that follows this last directory separator
2908 Name_Buffer (1 .. Name_Len - J) := Name_Buffer (J + 1 .. Name_Len);
2909 Name_Len := Name_Len - J;
2914 -- There were no directory separator, just return Name
2917 end Strip_Directory;
2923 function Strip_Suffix (Name : File_Name_Type) return File_Name_Type is
2925 Get_Name_String (Name);
2927 for J in reverse 2 .. Name_Len loop
2929 -- If we found the last '.', return part of Name that precedes it
2931 if Name_Buffer (J) = '.' then
2940 ---------------------------
2941 -- To_Canonical_File_List --
2942 ---------------------------
2944 function To_Canonical_File_List
2945 (Wildcard_Host_File : String;
2946 Only_Dirs : Boolean) return String_Access_List_Access
2948 function To_Canonical_File_List_Init
2949 (Host_File : Address;
2950 Only_Dirs : Integer) return Integer;
2951 pragma Import (C, To_Canonical_File_List_Init,
2952 "__gnat_to_canonical_file_list_init");
2954 function To_Canonical_File_List_Next return Address;
2955 pragma Import (C, To_Canonical_File_List_Next,
2956 "__gnat_to_canonical_file_list_next");
2958 procedure To_Canonical_File_List_Free;
2959 pragma Import (C, To_Canonical_File_List_Free,
2960 "__gnat_to_canonical_file_list_free");
2962 Num_Files : Integer;
2963 C_Wildcard_Host_File : String (1 .. Wildcard_Host_File'Length + 1);
2966 C_Wildcard_Host_File (1 .. Wildcard_Host_File'Length) :=
2968 C_Wildcard_Host_File (C_Wildcard_Host_File'Last) := ASCII.NUL;
2970 -- Do the expansion and say how many there are
2972 Num_Files := To_Canonical_File_List_Init
2973 (C_Wildcard_Host_File'Address, Boolean'Pos (Only_Dirs));
2976 Canonical_File_List : String_Access_List (1 .. Num_Files);
2977 Canonical_File_Addr : Address;
2978 Canonical_File_Len : CRTL.size_t;
2981 -- Retrieve the expanded directory names and build the list
2983 for J in 1 .. Num_Files loop
2984 Canonical_File_Addr := To_Canonical_File_List_Next;
2985 Canonical_File_Len := C_String_Length (Canonical_File_Addr);
2986 Canonical_File_List (J) := To_Path_String_Access
2987 (Canonical_File_Addr, Canonical_File_Len);
2990 -- Free up the storage
2992 To_Canonical_File_List_Free;
2994 return new String_Access_List'(Canonical_File_List
);
2996 end To_Canonical_File_List
;
2998 ----------------------
2999 -- To_Host_Dir_Spec --
3000 ----------------------
3002 function To_Host_Dir_Spec
3003 (Canonical_Dir
: String;
3004 Prefix_Style
: Boolean) return String_Access
3006 function To_Host_Dir_Spec
3007 (Canonical_Dir
: Address
;
3008 Prefix_Flag
: Integer) return Address
;
3009 pragma Import
(C
, To_Host_Dir_Spec
, "__gnat_to_host_dir_spec");
3011 C_Canonical_Dir
: String (1 .. Canonical_Dir
'Length + 1);
3012 Host_Dir_Addr
: Address
;
3013 Host_Dir_Len
: CRTL
.size_t
;
3016 C_Canonical_Dir
(1 .. Canonical_Dir
'Length) := Canonical_Dir
;
3017 C_Canonical_Dir
(C_Canonical_Dir
'Last) := ASCII
.NUL
;
3019 if Prefix_Style
then
3020 Host_Dir_Addr
:= To_Host_Dir_Spec
(C_Canonical_Dir
'Address, 1);
3022 Host_Dir_Addr
:= To_Host_Dir_Spec
(C_Canonical_Dir
'Address, 0);
3024 Host_Dir_Len
:= C_String_Length
(Host_Dir_Addr
);
3026 if Host_Dir_Len
= 0 then
3029 return To_Path_String_Access
(Host_Dir_Addr
, Host_Dir_Len
);
3031 end To_Host_Dir_Spec
;
3033 -----------------------
3034 -- To_Host_File_Spec --
3035 -----------------------
3037 function To_Host_File_Spec
3038 (Canonical_File
: String) return String_Access
3040 function To_Host_File_Spec
(Canonical_File
: Address
) return Address
;
3041 pragma Import
(C
, To_Host_File_Spec
, "__gnat_to_host_file_spec");
3043 C_Canonical_File
: String (1 .. Canonical_File
'Length + 1);
3044 Host_File_Addr
: Address
;
3045 Host_File_Len
: CRTL
.size_t
;
3048 C_Canonical_File
(1 .. Canonical_File
'Length) := Canonical_File
;
3049 C_Canonical_File
(C_Canonical_File
'Last) := ASCII
.NUL
;
3051 Host_File_Addr
:= To_Host_File_Spec
(C_Canonical_File
'Address);
3052 Host_File_Len
:= C_String_Length
(Host_File_Addr
);
3054 if Host_File_Len
= 0 then
3057 return To_Path_String_Access
3058 (Host_File_Addr
, Host_File_Len
);
3060 end To_Host_File_Spec
;
3062 ---------------------------
3063 -- To_Path_String_Access --
3064 ---------------------------
3066 function To_Path_String_Access
3067 (Path_Addr
: Address
;
3068 Path_Len
: CRTL
.size_t
) return String_Access
3070 subtype Path_String
is String (1 .. Integer (Path_Len
));
3071 type Path_String_Access
is access Path_String
;
3073 function Address_To_Access
is new
3074 Unchecked_Conversion
(Source
=> Address
,
3075 Target
=> Path_String_Access
);
3077 Path_Access
: constant Path_String_Access
:=
3078 Address_To_Access
(Path_Addr
);
3080 Return_Val
: String_Access
;
3083 Return_Val
:= new String (1 .. Integer (Path_Len
));
3085 for J
in 1 .. Integer (Path_Len
) loop
3086 Return_Val
(J
) := Path_Access
(J
);
3090 end To_Path_String_Access
;
3096 function Update_Path
(Path
: String_Ptr
) return String_Ptr
is
3098 function C_Update_Path
(Path
, Component
: Address
) return Address
;
3099 pragma Import
(C
, C_Update_Path
, "update_path");
3101 In_Length
: constant Integer := Path
'Length;
3102 In_String
: String (1 .. In_Length
+ 1);
3103 Component_Name
: aliased String := "GCC" & ASCII
.NUL
;
3104 Result_Ptr
: Address
;
3105 Result_Length
: CRTL
.size_t
;
3106 Out_String
: String_Ptr
;
3109 In_String
(1 .. In_Length
) := Path
.all;
3110 In_String
(In_Length
+ 1) := ASCII
.NUL
;
3111 Result_Ptr
:= C_Update_Path
(In_String
'Address, Component_Name
'Address);
3112 Result_Length
:= CRTL
.strlen
(Result_Ptr
);
3114 Out_String
:= new String (1 .. Integer (Result_Length
));
3115 CRTL
.strncpy
(Out_String
.all'Address, Result_Ptr
, Result_Length
);
3123 procedure Write_Info
(Info
: String) is
3125 Write_With_Check
(Info
'Address, Info
'Length);
3126 Write_With_Check
(EOL
'Address, 1);
3129 ------------------------
3130 -- Write_Program_Name --
3131 ------------------------
3133 procedure Write_Program_Name
is
3134 Save_Buffer
: constant String (1 .. Name_Len
) :=
3135 Name_Buffer
(1 .. Name_Len
);
3140 -- Convert the name to lower case so error messages are the same on
3143 for J
in 1 .. Name_Len
loop
3144 if Name_Buffer
(J
) in 'A' .. 'Z' then
3146 Character'Val (Character'Pos (Name_Buffer
(J
)) + 32);
3150 Write_Str
(Name_Buffer
(1 .. Name_Len
));
3152 -- Restore Name_Buffer which was clobbered by the call to
3153 -- Find_Program_Name
3155 Name_Len
:= Save_Buffer
'Last;
3156 Name_Buffer
(1 .. Name_Len
) := Save_Buffer
;
3157 end Write_Program_Name
;
3159 ----------------------
3160 -- Write_With_Check --
3161 ----------------------
3163 procedure Write_With_Check
(A
: Address
; N
: Integer) is
3166 if N
= Write
(Output_FD
, A
, N
) then
3169 Write_Str
("error: disk full writing ");
3170 Write_Name_Decoded
(Output_File_Name
);
3172 Name_Len
:= Name_Len
+ 1;
3173 Name_Buffer
(Name_Len
) := ASCII
.NUL
;
3174 Delete_File
(Name_Buffer
'Address, Ignore
);
3175 Exit_Program
(E_Fatal
);
3177 end Write_With_Check
;
3179 ----------------------------
3180 -- Package Initialization --
3181 ----------------------------
3183 procedure Reset_File_Attributes
(Attr
: System
.Address
);
3184 pragma Import
(C
, Reset_File_Attributes
, "__gnat_reset_attributes");
3187 Initialization
: declare
3189 function Get_Default_Identifier_Character_Set
return Character;
3190 pragma Import
(C
, Get_Default_Identifier_Character_Set
,
3191 "__gnat_get_default_identifier_character_set");
3192 -- Function to determine the default identifier character set,
3193 -- which is system dependent. See Opt package spec for a list of
3194 -- the possible character codes and their interpretations.
3196 function Get_Maximum_File_Name_Length
return Int
;
3197 pragma Import
(C
, Get_Maximum_File_Name_Length
,
3198 "__gnat_get_maximum_file_name_length");
3199 -- Function to get maximum file name length for system
3201 Sizeof_File_Attributes
: Integer;
3202 pragma Import
(C
, Sizeof_File_Attributes
,
3203 "__gnat_size_of_file_attributes");
3206 pragma Assert
(Sizeof_File_Attributes
<= File_Attributes_Size
);
3208 Reset_File_Attributes
(Unknown_Attributes
'Address);
3210 Identifier_Character_Set
:= Get_Default_Identifier_Character_Set
;
3211 Maximum_File_Name_Length
:= Get_Maximum_File_Name_Length
;
3213 -- Following should be removed by having above function return
3214 -- Integer'Last as indication of no maximum instead of -1 ???
3216 if Maximum_File_Name_Length
= -1 then
3217 Maximum_File_Name_Length
:= Int
'Last;
3220 Src_Search_Directories
.Set_Last
(Primary_Directory
);
3221 Src_Search_Directories
.Table
(Primary_Directory
) := new String'("");
3223 Lib_Search_Directories.Set_Last (Primary_Directory);
3224 Lib_Search_Directories.Table (Primary_Directory) := new String'("");