1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2019, 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 -- comment required here ???
54 Program_Set
: Boolean := False;
55 -- comment required here ???
57 Std_Prefix
: String_Ptr
;
58 -- Standard prefix, computed dynamically the first time Relocate_Path
59 -- is called, and cached for subsequent calls.
61 Empty
: aliased String := "";
62 No_Dir
: constant String_Ptr
:= Empty
'Access;
63 -- Used in Locate_File as a fake directory when Name is already an
66 -------------------------------------
67 -- Use of Name_Find and Name_Enter --
68 -------------------------------------
70 -- This package creates a number of source, ALI and object file names
71 -- that are used to locate the actual file and for the purpose of message
72 -- construction. These names need not be accessible by Name_Find, and can
73 -- be therefore created by using routine Name_Enter. The files in question
74 -- are file names with a prefix directory (i.e., the files not in the
75 -- current directory). File names without a prefix directory are entered
76 -- with Name_Find because special values might be attached to the various
77 -- Info fields of the corresponding name table entry.
79 -----------------------
80 -- Local Subprograms --
81 -----------------------
83 function Append_Suffix_To_File_Name
84 (Name
: File_Name_Type
;
85 Suffix
: String) return File_Name_Type
;
86 -- Appends Suffix to Name and returns the new name
88 function OS_Time_To_GNAT_Time
(T
: OS_Time
) return Time_Stamp_Type
;
89 -- Convert OS format time to GNAT format time stamp. If T is Invalid_Time,
90 -- then returns Empty_Time_Stamp.
92 function Executable_Prefix
return String_Ptr
;
93 -- Returns the name of the root directory where the executable is stored.
94 -- The executable must be located in a directory called "bin", or under
95 -- root/lib/gcc-lib/..., or under root/libexec/gcc/... For example, if
96 -- executable is stored in directory "/foo/bar/bin", this routine returns
97 -- "/foo/bar/". Return "" if location is not recognized as described above.
99 function Update_Path
(Path
: String_Ptr
) return String_Ptr
;
100 -- Update the specified path to replace the prefix with the location where
101 -- GNAT is installed. See the file prefix.c in GCC for details.
103 procedure Locate_File
108 Found
: out File_Name_Type
;
109 Attr
: access File_Attributes
);
110 -- See if the file N whose name is Name exists in directory Dir. Dir is an
111 -- index into the Lib_Search_Directories table if T = Library. Otherwise
112 -- if T = Source, Dir is an index into the Src_Search_Directories table.
113 -- Returns the File_Name_Type of the full file name if file found, or
114 -- No_File if not found.
116 -- On exit, Found is set to the file that was found, and Attr to a cache of
117 -- its attributes (at least those that have been computed so far). Reusing
118 -- the cache will save some system calls.
120 -- Attr is always reset in this call to Unknown_Attributes, even in case of
126 Found
: out File_Name_Type
;
127 Attr
: access File_Attributes
;
128 Full_Name
: Boolean := False);
129 -- A version of Find_File that also returns a cache of the file attributes
132 procedure Smart_Find_File
135 Found
: out File_Name_Type
;
136 Attr
: out File_Attributes
);
137 -- A version of Smart_Find_File that also returns a cache of the file
138 -- attributes for later reuse
140 function C_String_Length
(S
: Address
) return CRTL
.size_t
;
141 -- Returns length of a C string (zero for a null address)
143 function To_Path_String_Access
144 (Path_Addr
: Address
;
145 Path_Len
: CRTL
.size_t
) return String_Access
;
146 -- Converts a C String to an Ada String. Are we doing this to avoid withing
147 -- Interfaces.C.Strings ???
148 -- Caller must free result.
150 function Include_Dir_Default_Prefix
return String_Access
;
151 -- Same as exported version, except returns a String_Access
153 ------------------------------
154 -- Other Local Declarations --
155 ------------------------------
157 EOL
: constant Character := ASCII
.LF
;
158 -- End of line character
160 Number_File_Names
: Nat
:= 0;
161 -- Number of file names found on command line and placed in File_Names
163 Look_In_Primary_Directory_For_Current_Main
: Boolean := False;
164 -- When this variable is True, Find_File only looks in Primary_Directory
165 -- for the Current_Main file. This variable is always set to True for the
166 -- compiler. It is also True for gnatmake, when the source name given on
167 -- the command line has directory information.
169 Current_Full_Source_Name
: File_Name_Type
:= No_File
;
170 Current_Full_Source_Stamp
: Time_Stamp_Type
:= Empty_Time_Stamp
;
171 Current_Full_Lib_Name
: File_Name_Type
:= No_File
;
172 Current_Full_Lib_Stamp
: Time_Stamp_Type
:= Empty_Time_Stamp
;
173 Current_Full_Obj_Name
: File_Name_Type
:= No_File
;
174 Current_Full_Obj_Stamp
: Time_Stamp_Type
:= Empty_Time_Stamp
;
175 -- Respectively full name (with directory info) and time stamp of the
176 -- latest source, library and object files opened by Read_Source_File and
177 -- Read_Library_Info.
179 package File_Name_Chars
is new Table
.Table
(
180 Table_Component_Type
=> Character,
181 Table_Index_Type
=> Int
,
182 Table_Low_Bound
=> 1,
183 Table_Initial
=> Alloc
.File_Name_Chars_Initial
,
184 Table_Increment
=> Alloc
.File_Name_Chars_Increment
,
185 Table_Name
=> "File_Name_Chars");
186 -- Table to store text to be printed by Dump_Source_File_Names
188 The_Include_Dir_Default_Prefix
: String_Access
:= null;
189 -- Value returned by Include_Dir_Default_Prefix. We don't initialize it
190 -- here, because that causes an elaboration cycle with Sdefault; we
191 -- initialize it lazily instead.
197 Primary_Directory
: constant := 0;
198 -- This is index in the tables created below for the first directory to
199 -- search in for source or library information files. This is the directory
200 -- containing the latest main input file (a source file for the compiler or
201 -- a library file for the binder).
203 package Src_Search_Directories
is new Table
.Table
(
204 Table_Component_Type
=> String_Ptr
,
205 Table_Index_Type
=> Integer,
206 Table_Low_Bound
=> Primary_Directory
,
208 Table_Increment
=> 100,
209 Table_Name
=> "Osint.Src_Search_Directories");
210 -- Table of names of directories in which to search for source (Compiler)
211 -- files. This table is filled in the order in which the directories are
212 -- to be searched, and then used in that order.
214 package Lib_Search_Directories
is new Table
.Table
(
215 Table_Component_Type
=> String_Ptr
,
216 Table_Index_Type
=> Integer,
217 Table_Low_Bound
=> Primary_Directory
,
219 Table_Increment
=> 100,
220 Table_Name
=> "Osint.Lib_Search_Directories");
221 -- Table of names of directories in which to search for library (Binder)
222 -- files. This table is filled in the order in which the directories are
223 -- to be searched and then used in that order. The reason for having two
224 -- distinct tables is that we need them both in gnatmake.
226 ---------------------
227 -- File Hash Table --
228 ---------------------
230 -- The file hash table is provided to free the programmer from any
231 -- efficiency concern when retrieving full file names or time stamps of
232 -- source files. If the programmer calls Source_File_Data (Cache => True)
233 -- he is guaranteed that the price to retrieve the full name (i.e. with
234 -- directory info) or time stamp of the file will be payed only once, the
235 -- first time the full name is actually searched (or the first time the
236 -- time stamp is actually retrieved). This is achieved by employing a hash
237 -- table that stores as a key the File_Name_Type of the file and associates
238 -- to that File_Name_Type the full file name and time stamp of the file.
240 File_Cache_Enabled
: Boolean := False;
241 -- Set to true if you want the enable the file data caching mechanism
243 type File_Hash_Num
is range 0 .. 1020;
245 function File_Hash
(F
: File_Name_Type
) return File_Hash_Num
;
246 -- Compute hash index for use by Simple_HTable
248 type File_Info_Cache
is record
249 File
: File_Name_Type
;
250 Attr
: aliased File_Attributes
;
253 No_File_Info_Cache
: constant File_Info_Cache
:= (No_File
, (others => 0));
255 package File_Name_Hash_Table
is new GNAT
.HTable
.Simple_HTable
(
256 Header_Num
=> File_Hash_Num
,
257 Element
=> File_Info_Cache
,
258 No_Element
=> No_File_Info_Cache
,
259 Key
=> File_Name_Type
,
263 function Smart_Find_File
265 T
: File_Type
) return File_Name_Type
;
266 -- Exactly like Find_File except that if File_Cache_Enabled is True this
267 -- routine looks first in the hash table to see if the full name of the
268 -- file is already available.
270 function Smart_File_Stamp
272 T
: File_Type
) return Time_Stamp_Type
;
273 -- Takes the same parameter as the routine above (N is a file name without
274 -- any prefix directory information) and behaves like File_Stamp except
275 -- that if File_Cache_Enabled is True this routine looks first in the hash
276 -- table to see if the file stamp of the file is already available.
278 -----------------------------
279 -- Add_Default_Search_Dirs --
280 -----------------------------
282 procedure Add_Default_Search_Dirs
is
283 Search_Dir
: String_Access
;
284 Search_Path
: String_Access
;
285 Path_File_Name
: String_Access
;
287 procedure Add_Search_Dir
288 (Search_Dir
: String;
289 Additional_Source_Dir
: Boolean);
290 procedure Add_Search_Dir
291 (Search_Dir
: String_Access
;
292 Additional_Source_Dir
: Boolean);
293 -- Add a source search dir or a library search dir, depending on the
294 -- value of Additional_Source_Dir.
296 procedure Get_Dirs_From_File
(Additional_Source_Dir
: Boolean);
297 -- Open a path file and read the directory to search, one per line
299 function Get_Libraries_From_Registry
return String_Ptr
;
300 -- On Windows systems, get the list of installed standard libraries
301 -- from the registry key:
303 -- HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\
304 -- GNAT\Standard Libraries
305 -- Return an empty string on other systems.
307 -- Note that this is an undocumented legacy feature, and that it
308 -- works only when using the default runtime library (i.e. no --RTS=
309 -- command line switch).
315 procedure Add_Search_Dir
316 (Search_Dir
: String;
317 Additional_Source_Dir
: Boolean)
320 if Additional_Source_Dir
then
321 Add_Src_Search_Dir
(Search_Dir
);
323 Add_Lib_Search_Dir
(Search_Dir
);
327 procedure Add_Search_Dir
328 (Search_Dir
: String_Access
;
329 Additional_Source_Dir
: Boolean)
332 if Additional_Source_Dir
then
333 Add_Src_Search_Dir
(Search_Dir
.all);
335 Add_Lib_Search_Dir
(Search_Dir
.all);
339 ------------------------
340 -- Get_Dirs_From_File --
341 ------------------------
343 procedure Get_Dirs_From_File
(Additional_Source_Dir
: Boolean) is
344 File_FD
: File_Descriptor
;
345 Buffer
: constant String := Path_File_Name
.all & ASCII
.NUL
;
347 Actual_Len
: Natural;
354 pragma Warnings
(Off
, Status
);
355 -- For the call to Close where status is ignored
358 File_FD
:= Open_Read
(Buffer
'Address, Binary
);
360 -- If we cannot open the file, we ignore it, we don't fail
362 if File_FD
= Invalid_FD
then
366 Len
:= Integer (File_Length
(File_FD
));
368 S
:= new String (1 .. Len
);
370 -- Read the file. Note that the loop is probably not necessary any
371 -- more since the whole file is read in at once on all targets. But
372 -- it is harmless and might be needed in future.
376 while Curr
<= Len
and then Actual_Len
/= 0 loop
377 Actual_Len
:= Read
(File_FD
, S
(Curr
)'Address, Len
);
378 Curr
:= Curr
+ Actual_Len
;
381 -- We are done with the file, so we close it (ignore any error on
382 -- the close, since we have successfully read the file).
384 Close
(File_FD
, Status
);
386 -- Now, we read line by line
390 while Curr
< Len
loop
393 if Ch
= ASCII
.CR
or else Ch
= ASCII
.LF
394 or else Ch
= ASCII
.FF
or else Ch
= ASCII
.VT
396 if First
<= Curr
then
397 Add_Search_Dir
(S
(First
.. Curr
), Additional_Source_Dir
);
406 -- Last line is a special case, if the file does not end with
407 -- an end of line mark.
409 if First
<= S
'Last then
410 Add_Search_Dir
(S
(First
.. S
'Last), Additional_Source_Dir
);
412 end Get_Dirs_From_File
;
414 ---------------------------------
415 -- Get_Libraries_From_Registry --
416 ---------------------------------
418 function Get_Libraries_From_Registry
return String_Ptr
is
419 function C_Get_Libraries_From_Registry
return Address
;
420 pragma Import
(C
, C_Get_Libraries_From_Registry
,
421 "__gnat_get_libraries_from_registry");
423 Result_Ptr
: Address
;
424 Result_Length
: CRTL
.size_t
;
425 Out_String
: String_Ptr
;
428 Result_Ptr
:= C_Get_Libraries_From_Registry
;
429 Result_Length
:= CRTL
.strlen
(Result_Ptr
);
431 Out_String
:= new String (1 .. Integer (Result_Length
));
432 CRTL
.strncpy
(Out_String
.all'Address, Result_Ptr
, Result_Length
);
434 CRTL
.free
(Result_Ptr
);
437 end Get_Libraries_From_Registry
;
439 -- Start of processing for Add_Default_Search_Dirs
442 -- If there was a -gnateO switch, add all object directories from the
443 -- file given in argument to the library search list.
445 if Object_Path_File_Name
/= null then
446 Path_File_Name
:= String_Access
(Object_Path_File_Name
);
447 pragma Assert
(Path_File_Name
'Length > 0);
448 Get_Dirs_From_File
(Additional_Source_Dir
=> False);
451 -- After the locations specified on the command line, the next places
452 -- to look for files are the directories specified by the appropriate
453 -- environment variable. Get this value, extract the directory names
454 -- and store in the tables.
456 -- Check for eventual project path file env vars
458 Path_File_Name
:= Getenv
(Project_Include_Path_File
);
460 if Path_File_Name
'Length > 0 then
461 Get_Dirs_From_File
(Additional_Source_Dir
=> True);
464 Path_File_Name
:= Getenv
(Project_Objects_Path_File
);
466 if Path_File_Name
'Length > 0 then
467 Get_Dirs_From_File
(Additional_Source_Dir
=> False);
470 -- Put path name in canonical form
472 for Additional_Source_Dir
in False .. True loop
473 if Additional_Source_Dir
then
474 Search_Path
:= Getenv
(Ada_Include_Path
);
477 Search_Path
:= Getenv
(Ada_Objects_Path
);
481 Get_Next_Dir_In_Path_Init
(Search_Path
);
483 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
484 exit when Search_Dir
= null;
485 Add_Search_Dir
(Search_Dir
, Additional_Source_Dir
);
489 -- For the compiler, if --RTS= was specified, add the runtime
492 if RTS_Src_Path_Name
/= null and then RTS_Lib_Path_Name
/= null then
493 Add_Search_Dirs
(RTS_Src_Path_Name
, Include
);
494 Add_Search_Dirs
(RTS_Lib_Path_Name
, Objects
);
497 if not Opt
.No_Stdinc
then
499 -- For WIN32 systems, look for any system libraries defined in
500 -- the registry. These are added to both source and object
503 Search_Path
:= String_Access
(Get_Libraries_From_Registry
);
505 Get_Next_Dir_In_Path_Init
(Search_Path
);
507 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
508 exit when Search_Dir
= null;
509 Add_Search_Dir
(Search_Dir
, False);
510 Add_Search_Dir
(Search_Dir
, True);
513 -- The last place to look are the defaults
516 Read_Default_Search_Dirs
517 (String_Access
(Update_Path
(Search_Dir_Prefix
)),
519 String_Access
(Update_Path
(Include_Dir_Default_Name
)));
521 Get_Next_Dir_In_Path_Init
(Search_Path
);
523 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
524 exit when Search_Dir
= null;
525 Add_Search_Dir
(Search_Dir
, True);
529 -- Even when -nostdlib is used, we still want to have visibility on
530 -- the run-time object directory, as it is used by gnatbind to find
531 -- the run-time ALI files in "real" ZFP set up.
533 if not Opt
.RTS_Switch
then
535 Read_Default_Search_Dirs
536 (String_Access
(Update_Path
(Search_Dir_Prefix
)),
538 String_Access
(Update_Path
(Object_Dir_Default_Name
)));
540 Get_Next_Dir_In_Path_Init
(Search_Path
);
542 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
543 exit when Search_Dir
= null;
544 Add_Search_Dir
(Search_Dir
, False);
548 end Add_Default_Search_Dirs
;
554 procedure Add_File
(File_Name
: String; Index
: Int
:= No_Index
) is
556 Number_File_Names
:= Number_File_Names
+ 1;
558 -- As Add_File may be called for mains specified inside a project file,
559 -- File_Names may be too short and needs to be extended.
561 if Number_File_Names
> File_Names
'Last then
562 File_Names
:= new File_Name_Array
'(File_Names.all & File_Names.all);
564 new File_Index_Array'(File_Indexes
.all & File_Indexes
.all);
567 File_Names
(Number_File_Names
) := new String'(File_Name);
568 File_Indexes (Number_File_Names) := Index;
571 ------------------------
572 -- Add_Lib_Search_Dir --
573 ------------------------
575 procedure Add_Lib_Search_Dir (Dir : String) is
577 if Dir'Length = 0 then
578 Fail ("missing library directory name");
582 Norm : String_Ptr := Normalize_Directory_Name (Dir);
585 -- Do nothing if the directory is already in the list. This saves
586 -- system calls and avoid unneeded work
588 for D in Lib_Search_Directories.First ..
589 Lib_Search_Directories.Last
591 if Lib_Search_Directories.Table (D).all = Norm.all then
597 Lib_Search_Directories.Increment_Last;
598 Lib_Search_Directories.Table (Lib_Search_Directories.Last) := Norm;
600 end Add_Lib_Search_Dir;
602 ---------------------
603 -- Add_Search_Dirs --
604 ---------------------
606 procedure Add_Search_Dirs
607 (Search_Path : String_Ptr;
608 Path_Type : Search_File_Type)
610 Current_Search_Path : String_Access;
613 Get_Next_Dir_In_Path_Init (String_Access (Search_Path));
615 Current_Search_Path :=
616 Get_Next_Dir_In_Path (String_Access (Search_Path));
617 exit when Current_Search_Path = null;
619 if Path_Type = Include then
620 Add_Src_Search_Dir (Current_Search_Path.all);
622 Add_Lib_Search_Dir (Current_Search_Path.all);
627 ------------------------
628 -- Add_Src_Search_Dir --
629 ------------------------
631 procedure Add_Src_Search_Dir (Dir : String) is
633 if Dir'Length = 0 then
634 Fail ("missing source directory name");
637 Src_Search_Directories.Increment_Last;
638 Src_Search_Directories.Table (Src_Search_Directories.Last) :=
639 Normalize_Directory_Name (Dir);
640 end Add_Src_Search_Dir;
642 --------------------------------
643 -- Append_Suffix_To_File_Name --
644 --------------------------------
646 function Append_Suffix_To_File_Name
647 (Name : File_Name_Type;
648 Suffix : String) return File_Name_Type
651 Get_Name_String (Name);
652 Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
653 Name_Len := Name_Len + Suffix'Length;
655 end Append_Suffix_To_File_Name;
657 ---------------------
658 -- C_String_Length --
659 ---------------------
661 function C_String_Length (S : Address) return CRTL.size_t is
663 if S = Null_Address then
666 return CRTL.strlen (S);
670 ------------------------------
671 -- Canonical_Case_File_Name --
672 ------------------------------
674 procedure Canonical_Case_File_Name (S : in out String) is
676 if not File_Names_Case_Sensitive then
679 end Canonical_Case_File_Name;
681 ---------------------------------
682 -- Canonical_Case_Env_Var_Name --
683 ---------------------------------
685 procedure Canonical_Case_Env_Var_Name (S : in out String) is
687 if not Env_Vars_Case_Sensitive then
690 end Canonical_Case_Env_Var_Name;
692 ---------------------------
693 -- Create_File_And_Check --
694 ---------------------------
696 procedure Create_File_And_Check
697 (Fdesc : out File_Descriptor;
701 Output_File_Name := Name_Enter;
702 Fdesc := Create_File (Name_Buffer'Address, Fmode);
704 if Fdesc = Invalid_FD then
705 Fail ("Cannot create: " & Name_Buffer (1 .. Name_Len));
707 end Create_File_And_Check;
709 -----------------------------------
710 -- Open_File_To_Append_And_Check --
711 -----------------------------------
713 procedure Open_File_To_Append_And_Check
714 (Fdesc : out File_Descriptor;
718 Output_File_Name := Name_Enter;
719 Fdesc := Open_Append (Name_Buffer'Address, Fmode);
721 if Fdesc = Invalid_FD then
722 Fail ("Cannot create: " & Name_Buffer (1 .. Name_Len));
724 end Open_File_To_Append_And_Check;
726 ------------------------
727 -- Current_File_Index --
728 ------------------------
730 function Current_File_Index return Int is
732 return File_Indexes (Current_File_Name_Index);
733 end Current_File_Index;
735 --------------------------------
736 -- Current_Library_File_Stamp --
737 --------------------------------
739 function Current_Library_File_Stamp return Time_Stamp_Type is
741 return Current_Full_Lib_Stamp;
742 end Current_Library_File_Stamp;
744 -------------------------------
745 -- Current_Object_File_Stamp --
746 -------------------------------
748 function Current_Object_File_Stamp return Time_Stamp_Type is
750 return Current_Full_Obj_Stamp;
751 end Current_Object_File_Stamp;
753 -------------------------------
754 -- Current_Source_File_Stamp --
755 -------------------------------
757 function Current_Source_File_Stamp return Time_Stamp_Type is
759 return Current_Full_Source_Stamp;
760 end Current_Source_File_Stamp;
762 ----------------------------
763 -- Dir_In_Obj_Search_Path --
764 ----------------------------
766 function Dir_In_Obj_Search_Path (Position : Natural) return String_Ptr is
768 if Opt.Look_In_Primary_Dir then
770 Lib_Search_Directories.Table (Primary_Directory + Position - 1);
772 return Lib_Search_Directories.Table (Primary_Directory + Position);
774 end Dir_In_Obj_Search_Path;
776 ----------------------------
777 -- Dir_In_Src_Search_Path --
778 ----------------------------
780 function Dir_In_Src_Search_Path (Position : Natural) return String_Ptr is
782 if Opt.Look_In_Primary_Dir then
784 Src_Search_Directories.Table (Primary_Directory + Position - 1);
786 return Src_Search_Directories.Table (Primary_Directory + Position);
788 end Dir_In_Src_Search_Path;
790 -----------------------------------------
791 -- Dump_Command_Line_Source_File_Names --
792 -----------------------------------------
794 procedure Dump_Command_Line_Source_File_Names is
796 for J in 1 .. Number_Of_Files loop
797 Write_Str (File_Names (J).all & " ");
799 end Dump_Command_Line_Source_File_Names;
801 ----------------------------
802 -- Dump_Source_File_Names --
803 ----------------------------
805 procedure Dump_Source_File_Names is
806 subtype Rng is Int range File_Name_Chars.First .. File_Name_Chars.Last;
808 Write_Str (String (File_Name_Chars.Table (Rng)));
809 end Dump_Source_File_Names;
811 ---------------------
812 -- Executable_Name --
813 ---------------------
815 function Executable_Name
816 (Name : File_Name_Type;
817 Only_If_No_Suffix : Boolean := False) return File_Name_Type
819 Exec_Suffix : String_Access;
820 Add_Suffix : Boolean;
823 if Name = No_File then
827 if Executable_Extension_On_Target = No_Name then
828 Exec_Suffix := Get_Target_Executable_Suffix;
830 Get_Name_String (Executable_Extension_On_Target);
831 Exec_Suffix := new String'(Name_Buffer
(1 .. Name_Len
));
834 if Exec_Suffix
'Length /= 0 then
835 Get_Name_String
(Name
);
838 if Only_If_No_Suffix
then
839 for J
in reverse 1 .. Name_Len
loop
840 if Name_Buffer
(J
) = '.' then
844 elsif Is_Directory_Separator
(Name_Buffer
(J
)) then
852 Buffer
: String := Name_Buffer
(1 .. Name_Len
);
855 -- Get the file name in canonical case to accept as is. Names
856 -- end with ".EXE" on Windows.
858 Canonical_Case_File_Name
(Buffer
);
860 -- If Executable doesn't end with the executable suffix, add it
862 if Buffer
'Length <= Exec_Suffix
'Length
864 Buffer
(Buffer
'Last - Exec_Suffix
'Length + 1 .. Buffer
'Last)
868 (Name_Len
+ 1 .. Name_Len
+ Exec_Suffix
'Length) :=
870 Name_Len
:= Name_Len
+ Exec_Suffix
'Length;
882 function Executable_Name
884 Only_If_No_Suffix
: Boolean := False) return String
886 Exec_Suffix
: String_Access
;
887 Add_Suffix
: Boolean;
888 Canonical_Name
: String := Name
;
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;
908 Canonical_Case_File_Name (Canonical_Name);
911 if Only_If_No_Suffix then
912 for J in reverse Canonical_Name'Range loop
913 if Canonical_Name (J) = '.' then
917 elsif Is_Directory_Separator (Canonical_Name (J)) then
923 if Add_Suffix and then
924 (Canonical_Name'Length <= Suffix'Length
925 or else Canonical_Name (Canonical_Name'Last - Suffix'Length + 1
926 .. Canonical_Name'Last) /= Suffix)
929 Result : String (1 .. Name'Length + Suffix'Length);
931 Result (1 .. Name'Length) := Name;
932 Result (Name'Length + 1 .. Result'Last) := Suffix;
942 -----------------------
943 -- Executable_Prefix --
944 -----------------------
946 function Executable_Prefix return String_Ptr is
948 function Get_Install_Dir (Exec : String) return String_Ptr;
949 -- S is the executable name preceded by the absolute or relative
950 -- path, e.g. "c:\usr\bin\gcc.exe" or "..\bin\gcc".
952 ---------------------
953 -- Get_Install_Dir --
954 ---------------------
956 function Get_Install_Dir (Exec : String) return String_Ptr is
957 Full_Path : constant String := Normalize_Pathname (Exec);
958 -- Use the full path, so that we find "lib" or "bin", even when
959 -- the tool has been invoked with a relative path, as in
960 -- "./gnatls -v" invoked in the GNAT bin directory.
963 for J in reverse Full_Path'Range loop
964 if Is_Directory_Separator (Full_Path (J)) then
965 if J < Full_Path'Last - 5 then
966 if (To_Lower (Full_Path (J + 1)) = 'l
'
967 and then To_Lower (Full_Path (J + 2)) = 'i
'
968 and then To_Lower (Full_Path (J + 3)) = 'b
')
970 (To_Lower (Full_Path (J + 1)) = 'b
'
971 and then To_Lower (Full_Path (J + 2)) = 'i
'
972 and then To_Lower (Full_Path (J + 3)) = 'n
')
974 return new String'(Full_Path
(Full_Path
'First .. J
));
980 return new String'("");
983 -- Start of processing for Executable_Prefix
986 if Exec_Name = null then
987 Exec_Name := new String (1 .. Len_Arg (0));
988 Osint.Fill_Arg (Exec_Name (1)'Address, 0);
991 -- First determine if a path prefix was placed in front of the
994 for J in reverse Exec_Name'Range loop
995 if Is_Directory_Separator (Exec_Name (J)) then
996 return Get_Install_Dir (Exec_Name.all);
1000 -- If we come here, the user has typed the executable name with no
1001 -- directory prefix.
1003 return Get_Install_Dir (Locate_Exec_On_Path (Exec_Name.all).all);
1004 end Executable_Prefix;
1010 procedure Exit_Program (Exit_Code : Exit_Code_Type) is
1012 -- The program will exit with the following status:
1014 -- 0 if the object file has been generated (with or without warnings)
1015 -- 1 if recompilation was not needed (smart recompilation)
1016 -- 2 if gnat1 has been killed by a signal (detected by GCC)
1017 -- 4 for a fatal error
1018 -- 5 if there were errors
1019 -- 6 if no code has been generated (spec)
1021 -- Note that exit code 3 is not used and must not be used as this is
1022 -- the code returned by a program aborted via C abort() routine on
1023 -- Windows. GCC checks for that case and thinks that the child process
1024 -- has been aborted. This code (exit code 3) used to be the code used
1025 -- for E_No_Code, but E_No_Code was changed to 6 for this reason.
1028 when E_Success => OS_Exit (0);
1029 when E_Warnings => OS_Exit (0);
1030 when E_No_Compile => OS_Exit (1);
1031 when E_Fatal => OS_Exit (4);
1032 when E_Errors => OS_Exit (5);
1033 when E_No_Code => OS_Exit (6);
1034 when E_Abort => OS_Abort;
1042 procedure Fail (S : String) is
1044 -- We use Output in case there is a special output set up. In this case
1045 -- Set_Standard_Error will have no immediate effect.
1048 Osint.Write_Program_Name;
1053 Exit_Program (E_Fatal);
1060 function File_Hash (F : File_Name_Type) return File_Hash_Num is
1062 return File_Hash_Num (Int (F) rem File_Hash_Num'Range_Length);
1069 function File_Length
1070 (Name : C_File_Name;
1071 Attr : access File_Attributes) return Long_Integer
1076 A : System.Address) return CRTL.int64;
1077 pragma Import (C, Internal, "__gnat_file_length_attr");
1080 -- The conversion from int64 to Long_Integer is ok here as this
1081 -- routine is only to be used by the compiler and we do not expect
1082 -- a unit to be larger than a 32bit integer.
1084 return Long_Integer (Internal (-1, Name, Attr.all'Address));
1087 ---------------------
1088 -- File_Time_Stamp --
1089 ---------------------
1091 function File_Time_Stamp
1092 (Name : C_File_Name;
1093 Attr : access File_Attributes) return OS_Time
1095 function Internal (N : C_File_Name; A : System.Address) return OS_Time;
1096 pragma Import (C, Internal, "__gnat_file_time_name_attr");
1098 return Internal (Name, Attr.all'Address);
1099 end File_Time_Stamp;
1101 function File_Time_Stamp
1102 (Name : Path_Name_Type;
1103 Attr : access File_Attributes) return Time_Stamp_Type
1106 if Name = No_Path then
1107 return Empty_Time_Stamp;
1110 Get_Name_String (Name);
1111 Name_Buffer (Name_Len + 1) := ASCII.NUL;
1112 return OS_Time_To_GNAT_Time
1113 (File_Time_Stamp (Name_Buffer'Address, Attr));
1114 end File_Time_Stamp;
1120 function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type is
1122 if Name = No_File then
1123 return Empty_Time_Stamp;
1126 Get_Name_String (Name);
1128 -- File_Time_Stamp will always return Invalid_Time if the file does
1129 -- not exist, and OS_Time_To_GNAT_Time will convert this value to
1130 -- Empty_Time_Stamp. Therefore we do not need to first test whether
1131 -- the file actually exists, which saves a system call.
1133 return OS_Time_To_GNAT_Time
1134 (File_Time_Stamp (Name_Buffer (1 .. Name_Len)));
1137 function File_Stamp (Name : Path_Name_Type) return Time_Stamp_Type is
1139 return File_Stamp (File_Name_Type (Name));
1147 (N : File_Name_Type;
1149 Full_Name : Boolean := False) return File_Name_Type
1151 Attr : aliased File_Attributes;
1152 Found : File_Name_Type;
1154 Find_File (N, T, Found, Attr'Access, Full_Name);
1163 (N : File_Name_Type;
1165 Found : out File_Name_Type;
1166 Attr : access File_Attributes;
1167 Full_Name : Boolean := False)
1170 Get_Name_String (N);
1173 File_Name : String renames Name_Buffer (1 .. Name_Len);
1174 File : File_Name_Type := No_File;
1178 -- If we are looking for a config file, look only in the current
1179 -- directory, i.e. return input argument unchanged. Also look only in
1180 -- the current directory if we are looking for a .dg file (happens in
1184 or else (Debug_Generated_Code
1185 and then Name_Len > 3
1186 and then Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg")
1189 Attr.all := Unknown_Attributes;
1194 Full_Path : constant String :=
1195 Normalize_Pathname (Get_Name_String (N));
1196 Full_Size : constant Natural := Full_Path'Length;
1199 Name_Buffer (1 .. Full_Size) := Full_Path;
1200 Name_Len := Full_Size;
1205 -- Check that it is a file, not a directory
1207 if not Is_Regular_File (Get_Name_String (Found)) then
1214 -- If we are trying to find the current main file just look in the
1215 -- directory where the user said it was.
1217 elsif Look_In_Primary_Directory_For_Current_Main
1218 and then Current_Main = N
1220 Locate_File (N, T, Primary_Directory, File_Name, Found, Attr);
1223 -- Otherwise do standard search for source file
1226 -- Check the mapping of this file name
1228 File := Mapped_Path_Name (N);
1230 -- If the file name is mapped to a path name, return the
1231 -- corresponding path name
1233 if File /= No_File then
1235 -- For locally removed file, Error_Name is returned; then
1236 -- return No_File, indicating the file is not a source.
1238 if File = Error_File_Name then
1244 Attr.all := Unknown_Attributes;
1248 -- First place to look is in the primary directory (i.e. the same
1249 -- directory as the source) unless this has been disabled with -I-
1251 if Opt.Look_In_Primary_Dir then
1252 Locate_File (N, T, Primary_Directory, File_Name, Found, Attr);
1254 if Found /= No_File then
1259 -- Finally look in directories specified with switches -I/-aI/-aO
1262 Last_Dir := Lib_Search_Directories.Last;
1264 Last_Dir := Src_Search_Directories.Last;
1267 for D in Primary_Directory + 1 .. Last_Dir loop
1268 Locate_File (N, T, D, File_Name, Found, Attr);
1270 if Found /= No_File then
1275 Attr.all := Unknown_Attributes;
1281 -----------------------
1282 -- Find_Program_Name --
1283 -----------------------
1285 procedure Find_Program_Name is
1286 Command_Name : String (1 .. Len_Arg (0));
1287 Cindex1 : Integer := Command_Name'First;
1288 Cindex2 : Integer := Command_Name'Last;
1291 Fill_Arg (Command_Name'Address, 0);
1293 if Command_Name = "" then
1298 -- The program name might be specified by a full path name. However,
1299 -- we don't want to print that all out in an error message, so the
1300 -- path might need to be stripped away.
1302 for J in reverse Cindex1 .. Cindex2 loop
1303 if Is_Directory_Separator (Command_Name (J)) then
1309 -- Command_Name(Cindex1 .. Cindex2) is now the equivalent of the
1310 -- POSIX command "basename argv[0]"
1312 -- Strip off any executable extension (usually nothing or .exe)
1313 -- but formally reported by autoconf in the variable EXEEXT
1315 if Cindex2 - Cindex1 >= 4 then
1316 if To_Lower (Command_Name (Cindex2 - 3)) = '.'
1317 and then To_Lower (Command_Name (Cindex2 - 2)) = 'e
'
1318 and then To_Lower (Command_Name (Cindex2 - 1)) = 'x
'
1319 and then To_Lower (Command_Name (Cindex2)) = 'e
'
1321 Cindex2 := Cindex2 - 4;
1325 Name_Len := Cindex2 - Cindex1 + 1;
1326 Name_Buffer (1 .. Name_Len) := Command_Name (Cindex1 .. Cindex2);
1327 end Find_Program_Name;
1329 ------------------------
1330 -- Full_Lib_File_Name --
1331 ------------------------
1333 procedure Full_Lib_File_Name
1334 (N : File_Name_Type;
1335 Lib_File : out File_Name_Type;
1336 Attr : out File_Attributes)
1338 A : aliased File_Attributes;
1340 -- ??? seems we could use Smart_Find_File here
1341 Find_File (N, Library, Lib_File, A'Access);
1343 end Full_Lib_File_Name;
1345 ------------------------
1346 -- Full_Lib_File_Name --
1347 ------------------------
1349 function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type is
1350 Attr : File_Attributes;
1351 File : File_Name_Type;
1353 Full_Lib_File_Name (N, File, Attr);
1355 end Full_Lib_File_Name;
1357 ----------------------------
1358 -- Full_Library_Info_Name --
1359 ----------------------------
1361 function Full_Library_Info_Name return File_Name_Type is
1363 return Current_Full_Lib_Name;
1364 end Full_Library_Info_Name;
1366 ---------------------------
1367 -- Full_Object_File_Name --
1368 ---------------------------
1370 function Full_Object_File_Name return File_Name_Type is
1372 return Current_Full_Obj_Name;
1373 end Full_Object_File_Name;
1375 ----------------------
1376 -- Full_Source_Name --
1377 ----------------------
1379 function Full_Source_Name return File_Name_Type is
1381 return Current_Full_Source_Name;
1382 end Full_Source_Name;
1384 ----------------------
1385 -- Full_Source_Name --
1386 ----------------------
1388 function Full_Source_Name (N : File_Name_Type) return File_Name_Type is
1390 return Smart_Find_File (N, Source);
1391 end Full_Source_Name;
1393 ----------------------
1394 -- Full_Source_Name --
1395 ----------------------
1397 procedure Full_Source_Name
1398 (N : File_Name_Type;
1399 Full_File : out File_Name_Type;
1400 Attr : access File_Attributes) is
1402 Smart_Find_File (N, Source, Full_File, Attr.all);
1403 end Full_Source_Name;
1409 function Get_Directory (Name : File_Name_Type) return File_Name_Type is
1411 Get_Name_String (Name);
1413 for J in reverse 1 .. Name_Len loop
1414 if Is_Directory_Separator (Name_Buffer (J)) then
1420 Name_Len := Hostparm.Normalized_CWD'Length;
1421 Name_Buffer (1 .. Name_Len) := Hostparm.Normalized_CWD;
1425 --------------------------
1426 -- Get_Next_Dir_In_Path --
1427 --------------------------
1429 Search_Path_Pos : Integer;
1430 -- Keeps track of current position in search path. Initialized by the
1431 -- call to Get_Next_Dir_In_Path_Init, updated by Get_Next_Dir_In_Path.
1433 function Get_Next_Dir_In_Path
1434 (Search_Path : String_Access) return String_Access
1436 Lower_Bound : Positive := Search_Path_Pos;
1437 Upper_Bound : Positive;
1441 while Lower_Bound <= Search_Path'Last
1442 and then Search_Path.all (Lower_Bound) = Path_Separator
1444 Lower_Bound := Lower_Bound + 1;
1447 exit when Lower_Bound > Search_Path'Last;
1449 Upper_Bound := Lower_Bound;
1450 while Upper_Bound <= Search_Path'Last
1451 and then Search_Path.all (Upper_Bound) /= Path_Separator
1453 Upper_Bound := Upper_Bound + 1;
1456 Search_Path_Pos := Upper_Bound;
1457 return new String'(Search_Path
.all (Lower_Bound
.. Upper_Bound
- 1));
1461 end Get_Next_Dir_In_Path
;
1463 -------------------------------
1464 -- Get_Next_Dir_In_Path_Init --
1465 -------------------------------
1467 procedure Get_Next_Dir_In_Path_Init
(Search_Path
: String_Access
) is
1469 Search_Path_Pos
:= Search_Path
'First;
1470 end Get_Next_Dir_In_Path_Init
;
1472 --------------------------------------
1473 -- Get_Primary_Src_Search_Directory --
1474 --------------------------------------
1476 function Get_Primary_Src_Search_Directory
return String_Ptr
is
1478 return Src_Search_Directories
.Table
(Primary_Directory
);
1479 end Get_Primary_Src_Search_Directory
;
1481 ------------------------
1482 -- Get_RTS_Search_Dir --
1483 ------------------------
1485 function Get_RTS_Search_Dir
1486 (Search_Dir
: String;
1487 File_Type
: Search_File_Type
) return String_Ptr
1489 procedure Get_Current_Dir
1490 (Dir
: System
.Address
;
1491 Length
: System
.Address
);
1492 pragma Import
(C
, Get_Current_Dir
, "__gnat_get_current_dir");
1495 pragma Import
(C
, Max_Path
, "__gnat_max_path_len");
1496 -- Maximum length of a path name
1498 Current_Dir
: String_Ptr
;
1499 Default_Search_Dir
: String_Access
;
1500 Default_Suffix_Dir
: String_Access
;
1501 Local_Search_Dir
: String_Access
;
1502 Norm_Search_Dir
: String_Access
;
1503 Result_Search_Dir
: String_Access
;
1504 Search_File
: String_Access
;
1505 Temp_String
: String_Ptr
;
1508 -- Add a directory separator at the end of the directory if necessary
1509 -- so that we can directly append a file to the directory
1511 if not Is_Directory_Separator
(Search_Dir
(Search_Dir
'Last)) then
1513 new String'(Search_Dir & String'(1 => Directory_Separator
));
1515 Local_Search_Dir
:= new String'(Search_Dir);
1518 if File_Type = Include then
1519 Search_File := Include_Search_File;
1520 Default_Suffix_Dir := new String'("adainclude");
1522 Search_File
:= Objects_Search_File
;
1523 Default_Suffix_Dir
:= new String'("adalib");
1526 Norm_Search_Dir := Local_Search_Dir;
1528 if Is_Absolute_Path (Norm_Search_Dir.all) then
1530 -- We first verify if there is a directory Include_Search_Dir
1531 -- containing default search directories
1533 Result_Search_Dir :=
1534 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1535 Default_Search_Dir :=
1536 new String'(Norm_Search_Dir
.all & Default_Suffix_Dir
.all);
1537 Free
(Norm_Search_Dir
);
1539 if Result_Search_Dir
/= null then
1540 return String_Ptr
(Result_Search_Dir
);
1541 elsif Is_Directory
(Default_Search_Dir
.all) then
1542 return String_Ptr
(Default_Search_Dir
);
1547 -- Search in the current directory
1550 -- Get the current directory
1553 Buffer
: String (1 .. Max_Path
+ 2);
1554 Path_Len
: Natural := Max_Path
;
1557 Get_Current_Dir
(Buffer
'Address, Path_Len
'Address);
1559 if Path_Len
= 0 then
1560 raise Program_Error
;
1563 if not Is_Directory_Separator
(Buffer
(Path_Len
)) then
1564 Path_Len
:= Path_Len
+ 1;
1565 Buffer
(Path_Len
) := Directory_Separator
;
1568 Current_Dir
:= new String'(Buffer (1 .. Path_Len));
1572 new String'(Current_Dir
.all & Local_Search_Dir
.all);
1574 Result_Search_Dir
:=
1575 Read_Default_Search_Dirs
(Norm_Search_Dir
, Search_File
, null);
1577 Default_Search_Dir
:=
1578 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1580 Free (Norm_Search_Dir);
1582 if Result_Search_Dir /= null then
1583 return String_Ptr (Result_Search_Dir);
1585 elsif Is_Directory (Default_Search_Dir.all) then
1586 return String_Ptr (Default_Search_Dir);
1589 -- Search in Search_Dir_Prefix/Search_Dir
1593 (Update_Path
(Search_Dir_Prefix
).all & Local_Search_Dir
.all);
1595 Result_Search_Dir
:=
1596 Read_Default_Search_Dirs
(Norm_Search_Dir
, Search_File
, null);
1598 Default_Search_Dir
:=
1599 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);
1610 -- We finally search in Search_Dir_Prefix/rts-Search_Dir
1613 new String'(Update_Path
(Search_Dir_Prefix
).all & "rts-");
1616 new String'(Temp_String.all & Local_Search_Dir.all);
1618 Result_Search_Dir :=
1619 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1621 Default_Search_Dir :=
1622 new String'(Norm_Search_Dir
.all & Default_Suffix_Dir
.all);
1623 Free
(Norm_Search_Dir
);
1625 if Result_Search_Dir
/= null then
1626 return String_Ptr
(Result_Search_Dir
);
1628 elsif Is_Directory
(Default_Search_Dir
.all) then
1629 return String_Ptr
(Default_Search_Dir
);
1637 end Get_RTS_Search_Dir
;
1639 --------------------------------
1640 -- Include_Dir_Default_Prefix --
1641 --------------------------------
1643 function Include_Dir_Default_Prefix
return String_Access
is
1645 if The_Include_Dir_Default_Prefix
= null then
1646 The_Include_Dir_Default_Prefix
:=
1647 String_Access
(Update_Path
(Include_Dir_Default_Name
));
1650 return The_Include_Dir_Default_Prefix
;
1651 end Include_Dir_Default_Prefix
;
1653 function Include_Dir_Default_Prefix
return String is
1655 return Include_Dir_Default_Prefix
.all;
1656 end Include_Dir_Default_Prefix
;
1662 procedure Initialize
is
1664 Number_File_Names
:= 0;
1665 Current_File_Name_Index
:= 0;
1667 Src_Search_Directories
.Init
;
1668 Lib_Search_Directories
.Init
;
1670 -- Start off by setting all suppress options, to False. The special
1671 -- overflow fields are set to Not_Set (they will be set by -gnatp, or
1672 -- by -gnato, or, if neither of these appear, in Adjust_Global_Switches
1675 Suppress_Options
:= ((others => False), Not_Set
, Not_Set
);
1677 -- Reserve the first slot in the search paths table. This is the
1678 -- directory of the main source file or main library file and is filled
1679 -- in by each call to Next_Main_Source/Next_Main_Lib_File with the
1680 -- directory specified for this main source or library file. This is the
1681 -- directory which is searched first by default. This default search is
1682 -- inhibited by the option -I- for both source and library files.
1684 Src_Search_Directories
.Set_Last
(Primary_Directory
);
1685 Src_Search_Directories
.Table
(Primary_Directory
) := new String'("");
1687 Lib_Search_Directories.Set_Last (Primary_Directory);
1688 Lib_Search_Directories.Table (Primary_Directory) := new String'("");
1695 function Is_Directory
1696 (Name
: C_File_Name
; Attr
: access File_Attributes
) return Boolean
1698 function Internal
(N
: C_File_Name
; A
: System
.Address
) return Integer;
1699 pragma Import
(C
, Internal
, "__gnat_is_directory_attr");
1701 return Internal
(Name
, Attr
.all'Address) /= 0;
1704 ----------------------------
1705 -- Is_Directory_Separator --
1706 ----------------------------
1708 function Is_Directory_Separator
(C
: Character) return Boolean is
1710 -- In addition to the default directory_separator allow the '/' to
1711 -- act as separator since this is allowed in MS-DOS and Windows.
1713 return C
= Directory_Separator
or else C
= '/';
1714 end Is_Directory_Separator
;
1716 -------------------------
1717 -- Is_Readonly_Library --
1718 -------------------------
1720 function Is_Readonly_Library
(File
: File_Name_Type
) return Boolean is
1722 Get_Name_String
(File
);
1724 pragma Assert
(Name_Buffer
(Name_Len
- 3 .. Name_Len
) = ".ali");
1726 return not Is_Writable_File
(Name_Buffer
(1 .. Name_Len
));
1727 end Is_Readonly_Library
;
1729 ------------------------
1730 -- Is_Executable_File --
1731 ------------------------
1733 function Is_Executable_File
1734 (Name
: C_File_Name
; Attr
: access File_Attributes
) return Boolean
1736 function Internal
(N
: C_File_Name
; A
: System
.Address
) return Integer;
1737 pragma Import
(C
, Internal
, "__gnat_is_executable_file_attr");
1739 return Internal
(Name
, Attr
.all'Address) /= 0;
1740 end Is_Executable_File
;
1742 ----------------------
1743 -- Is_Readable_File --
1744 ----------------------
1746 function Is_Readable_File
1747 (Name
: C_File_Name
; Attr
: access File_Attributes
) return Boolean
1749 function Internal
(N
: C_File_Name
; A
: System
.Address
) return Integer;
1750 pragma Import
(C
, Internal
, "__gnat_is_readable_file_attr");
1752 return Internal
(Name
, Attr
.all'Address) /= 0;
1753 end Is_Readable_File
;
1755 ---------------------
1756 -- Is_Regular_File --
1757 ---------------------
1759 function Is_Regular_File
1760 (Name
: C_File_Name
; Attr
: access File_Attributes
) return Boolean
1762 function Internal
(N
: C_File_Name
; A
: System
.Address
) return Integer;
1763 pragma Import
(C
, Internal
, "__gnat_is_regular_file_attr");
1765 return Internal
(Name
, Attr
.all'Address) /= 0;
1766 end Is_Regular_File
;
1768 ----------------------
1769 -- Is_Symbolic_Link --
1770 ----------------------
1772 function Is_Symbolic_Link
1773 (Name
: C_File_Name
; Attr
: access File_Attributes
) return Boolean
1775 function Internal
(N
: C_File_Name
; A
: System
.Address
) return Integer;
1776 pragma Import
(C
, Internal
, "__gnat_is_symbolic_link_attr");
1778 return Internal
(Name
, Attr
.all'Address) /= 0;
1779 end Is_Symbolic_Link
;
1781 ----------------------
1782 -- Is_Writable_File --
1783 ----------------------
1785 function Is_Writable_File
1786 (Name
: C_File_Name
; Attr
: access File_Attributes
) return Boolean
1788 function Internal
(N
: C_File_Name
; A
: System
.Address
) return Integer;
1789 pragma Import
(C
, Internal
, "__gnat_is_writable_file_attr");
1791 return Internal
(Name
, Attr
.all'Address) /= 0;
1792 end Is_Writable_File
;
1798 function Lib_File_Name
1799 (Source_File
: File_Name_Type
;
1800 Munit_Index
: Nat
:= 0) return File_Name_Type
1803 Get_Name_String
(Source_File
);
1805 for J
in reverse 2 .. Name_Len
loop
1806 if Name_Buffer
(J
) = '.' then
1812 if Munit_Index
/= 0 then
1813 Add_Char_To_Name_Buffer
(Multi_Unit_Index_Character
);
1814 Add_Nat_To_Name_Buffer
(Munit_Index
);
1817 Add_Char_To_Name_Buffer
('.');
1818 Add_Str_To_Name_Buffer
(ALI_Suffix
.all);
1826 procedure Locate_File
1827 (N
: File_Name_Type
;
1831 Found
: out File_Name_Type
;
1832 Attr
: access File_Attributes
)
1834 Dir_Name
: String_Ptr
;
1837 -- If Name is already an absolute path, do not look for a directory
1839 if Is_Absolute_Path
(Name
) then
1842 elsif T
= Library
then
1843 Dir_Name
:= Lib_Search_Directories
.Table
(Dir
);
1846 pragma Assert
(T
/= Config
);
1847 Dir_Name
:= Src_Search_Directories
.Table
(Dir
);
1851 Full_Name
: String (1 .. Dir_Name
'Length + Name
'Length + 1);
1854 Full_Name
(1 .. Dir_Name
'Length) := Dir_Name
.all;
1855 Full_Name
(Dir_Name
'Length + 1 .. Full_Name
'Last - 1) := Name
;
1856 Full_Name
(Full_Name
'Last) := ASCII
.NUL
;
1858 Attr
.all := Unknown_Attributes
;
1860 if not Is_Regular_File
(Full_Name
'Address, Attr
) then
1864 -- If the file is in the current directory then return N itself
1866 if Dir_Name
'Length = 0 then
1869 Name_Len
:= Full_Name
'Length - 1;
1870 Name_Buffer
(1 .. Name_Len
) :=
1871 Full_Name
(1 .. Full_Name
'Last - 1);
1872 Found
:= Name_Find
; -- ??? Was Name_Enter, no obvious reason
1878 -------------------------------
1879 -- Matching_Full_Source_Name --
1880 -------------------------------
1882 function Matching_Full_Source_Name
1883 (N
: File_Name_Type
;
1884 T
: Time_Stamp_Type
) return File_Name_Type
1887 Get_Name_String
(N
);
1890 File_Name
: constant String := Name_Buffer
(1 .. Name_Len
);
1891 File
: File_Name_Type
:= No_File
;
1892 Attr
: aliased File_Attributes
;
1896 if Opt
.Look_In_Primary_Dir
then
1898 (N
, Source
, Primary_Directory
, File_Name
, File
, Attr
'Access);
1900 if File
/= No_File
and then T
= File_Stamp
(N
) then
1905 Last_Dir
:= Src_Search_Directories
.Last
;
1907 for D
in Primary_Directory
+ 1 .. Last_Dir
loop
1908 Locate_File
(N
, Source
, D
, File_Name
, File
, Attr
'Access);
1910 if File
/= No_File
and then T
= File_Stamp
(File
) then
1917 end Matching_Full_Source_Name
;
1923 function More_Files
return Boolean is
1925 return (Current_File_Name_Index
< Number_File_Names
);
1928 -------------------------------
1929 -- Nb_Dir_In_Obj_Search_Path --
1930 -------------------------------
1932 function Nb_Dir_In_Obj_Search_Path
return Natural is
1934 if Opt
.Look_In_Primary_Dir
then
1935 return Lib_Search_Directories
.Last
- Primary_Directory
+ 1;
1937 return Lib_Search_Directories
.Last
- Primary_Directory
;
1939 end Nb_Dir_In_Obj_Search_Path
;
1941 -------------------------------
1942 -- Nb_Dir_In_Src_Search_Path --
1943 -------------------------------
1945 function Nb_Dir_In_Src_Search_Path
return Natural is
1947 if Opt
.Look_In_Primary_Dir
then
1948 return Src_Search_Directories
.Last
- Primary_Directory
+ 1;
1950 return Src_Search_Directories
.Last
- Primary_Directory
;
1952 end Nb_Dir_In_Src_Search_Path
;
1954 --------------------
1955 -- Next_Main_File --
1956 --------------------
1958 function Next_Main_File
return File_Name_Type
is
1959 File_Name
: String_Ptr
;
1960 Dir_Name
: String_Ptr
;
1964 pragma Assert
(More_Files
);
1966 Current_File_Name_Index
:= Current_File_Name_Index
+ 1;
1968 -- Get the file and directory name
1970 File_Name
:= File_Names
(Current_File_Name_Index
);
1971 Fptr
:= File_Name
'First;
1973 for J
in reverse File_Name
'Range loop
1974 if Is_Directory_Separator
(File_Name
(J
)) then
1975 if J
= File_Name
'Last then
1976 Fail
("File name missing");
1984 -- Save name of directory in which main unit resides for use in
1985 -- locating other units
1987 Dir_Name
:= new String'(File_Name (File_Name'First .. Fptr - 1));
1989 case Running_Program is
1991 Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
1992 Look_In_Primary_Directory_For_Current_Main := True;
1995 Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
1997 if Fptr > File_Name'First then
1998 Look_In_Primary_Directory_For_Current_Main := True;
2004 Dir_Name := Normalize_Directory_Name (Dir_Name.all);
2005 Lib_Search_Directories.Table (Primary_Directory) := Dir_Name;
2011 Name_Len := File_Name'Last - Fptr + 1;
2012 Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last);
2013 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
2014 Current_Main := Name_Find;
2016 -- In the gnatmake case, the main file may have not have the
2017 -- extension. Try ".adb" first then ".ads"
2019 if Running_Program = Make then
2021 Orig_Main : constant File_Name_Type := Current_Main;
2024 if Strip_Suffix (Orig_Main) = Orig_Main then
2026 Append_Suffix_To_File_Name (Orig_Main, ".adb");
2028 if Full_Source_Name (Current_Main) = No_File then
2030 Append_Suffix_To_File_Name (Orig_Main, ".ads");
2032 if Full_Source_Name (Current_Main) = No_File then
2033 Current_Main := Orig_Main;
2040 return Current_Main;
2043 ------------------------------
2044 -- Normalize_Directory_Name --
2045 ------------------------------
2047 function Normalize_Directory_Name (Directory : String) return String_Ptr is
2049 function Is_Quoted (Path : String) return Boolean;
2050 pragma Inline (Is_Quoted);
2051 -- Returns true if Path is quoted (either double or single quotes)
2057 function Is_Quoted (Path : String) return Boolean is
2058 First : constant Character := Path (Path'First);
2059 Last : constant Character := Path (Path'Last);
2062 if (First = ''' and then Last = ''')
2064 (First = '"' and then Last = '"')
2072 Result : String_Ptr;
2074 -- Start of processing for Normalize_Directory_Name
2077 if Directory'Length = 0 then
2078 Result := new String'(Hostparm
.Normalized_CWD
);
2080 elsif Is_Directory_Separator
(Directory
(Directory
'Last)) then
2081 Result
:= new String'(Directory);
2083 elsif Is_Quoted (Directory) then
2085 -- This is a quoted string, it certainly means that the directory
2086 -- contains some spaces for example. We can safely remove the quotes
2087 -- here as the OS_Lib.Normalize_Arguments will be called before any
2088 -- spawn routines. This ensure that quotes will be added when needed.
2090 Result := new String (1 .. Directory'Length - 1);
2091 Result (1 .. Directory'Length - 2) :=
2092 Directory (Directory'First + 1 .. Directory'Last - 1);
2093 Result (Result'Last) := Directory_Separator;
2096 Result := new String (1 .. Directory'Length + 1);
2097 Result (1 .. Directory'Length) := Directory;
2098 Result (Directory'Length + 1) := Directory_Separator;
2102 end Normalize_Directory_Name;
2104 ---------------------
2105 -- Number_Of_Files --
2106 ---------------------
2108 function Number_Of_Files return Nat is
2110 return Number_File_Names;
2111 end Number_Of_Files;
2113 -------------------------------
2114 -- Object_Dir_Default_Prefix --
2115 -------------------------------
2117 function Object_Dir_Default_Prefix return String is
2118 Object_Dir : String_Access :=
2119 String_Access (Update_Path (Object_Dir_Default_Name));
2122 if Object_Dir = null then
2127 Result : constant String := Object_Dir.all;
2133 end Object_Dir_Default_Prefix;
2135 ----------------------
2136 -- Object_File_Name --
2137 ----------------------
2139 function Object_File_Name (N : File_Name_Type) return File_Name_Type is
2145 Get_Name_String (N);
2146 Name_Len := Name_Len - ALI_Suffix'Length - 1;
2148 for J in Target_Object_Suffix'Range loop
2149 Name_Len := Name_Len + 1;
2150 Name_Buffer (Name_Len) := Target_Object_Suffix (J);
2154 end Object_File_Name;
2156 -------------------------------
2157 -- OS_Exit_Through_Exception --
2158 -------------------------------
2160 procedure OS_Exit_Through_Exception (Status : Integer) is
2162 Current_Exit_Status := Status;
2163 raise Types.Terminate_Program;
2164 end OS_Exit_Through_Exception;
2166 --------------------------
2167 -- OS_Time_To_GNAT_Time --
2168 --------------------------
2170 function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type is
2171 GNAT_Time : Time_Stamp_Type;
2181 if T = Invalid_Time then
2182 return Empty_Time_Stamp;
2185 GM_Split (T, Y, Mo, D, H, Mn, S);
2191 Minutes => Nat (Mn),
2196 end OS_Time_To_GNAT_Time;
2202 function Prep_Suffix return String is
2211 function Program_Name (Nam : String; Prog : String) return String_Access is
2212 End_Of_Prefix : Natural := 0;
2213 Start_Of_Prefix : Positive := 1;
2214 Start_Of_Suffix : Positive;
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 Is_Directory_Separator (Name_Buffer (J))
2230 or else Name_Buffer (J) = ':'
2232 Start_Of_Prefix := J + 1;
2237 -- Find End_Of_Prefix
2239 for J in Start_Of_Prefix .. Name_Len - Prog'Length + 1 loop
2240 if Name_Buffer (J .. J + Prog'Length - 1) = Prog then
2241 End_Of_Prefix := J - 1;
2246 if End_Of_Prefix > 1 then
2247 Start_Of_Suffix := End_Of_Prefix + Prog'Length + 1;
2250 -- Create the new program name
2253 (Name_Buffer
(Start_Of_Prefix
.. End_Of_Prefix
)
2255 & Name_Buffer
(Start_Of_Suffix
.. Name_Len
));
2258 ------------------------------
2259 -- Read_Default_Search_Dirs --
2260 ------------------------------
2262 function Read_Default_Search_Dirs
2263 (Search_Dir_Prefix
: String_Access
;
2264 Search_File
: String_Access
;
2265 Search_Dir_Default_Name
: String_Access
) return String_Access
2267 Prefix_Len
: constant Integer := Search_Dir_Prefix
.all'Length;
2268 Buffer
: String (1 .. Prefix_Len
+ Search_File
.all'Length + 1);
2269 File_FD
: File_Descriptor
;
2270 S
, S1
: String_Access
;
2273 Actual_Len
: Integer;
2276 Prev_Was_Separator
: Boolean;
2277 Nb_Relative_Dir
: Integer;
2279 function Is_Relative
(S
: String; K
: Positive) return Boolean;
2280 pragma Inline
(Is_Relative
);
2281 -- Returns True if a relative directory specification is found
2282 -- in S at position K, False otherwise.
2288 function Is_Relative
(S
: String; K
: Positive) return Boolean is
2290 return not Is_Absolute_Path
(S
(K
.. S
'Last));
2293 -- Start of processing for Read_Default_Search_Dirs
2296 -- Construct a C compatible character string buffer
2298 Buffer
(1 .. Search_Dir_Prefix
.all'Length)
2299 := Search_Dir_Prefix
.all;
2300 Buffer
(Search_Dir_Prefix
.all'Length + 1 .. Buffer
'Last - 1)
2302 Buffer
(Buffer
'Last) := ASCII
.NUL
;
2304 File_FD
:= Open_Read
(Buffer
'Address, Binary
);
2305 if File_FD
= Invalid_FD
then
2306 return Search_Dir_Default_Name
;
2309 Len
:= Integer (File_Length
(File_FD
));
2311 -- An extra character for a trailing Path_Separator is allocated
2313 S
:= new String (1 .. Len
+ 1);
2314 S
(Len
+ 1) := Path_Separator
;
2316 -- Read the file. Note that the loop is probably not necessary since the
2317 -- whole file is read at once but the loop is harmless and that way we
2318 -- are sure to accommodate systems where this is not the case.
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, and
2423 -- there are other places in the compiler that make this assumption).
2425 Text
: Text_Buffer_Ptr
;
2426 -- Allocated text buffer
2429 pragma Warnings
(Off
, Status
);
2430 -- For the calls to Close
2433 Current_Full_Lib_Name
:= Full_Lib_File
;
2434 Current_Full_Obj_Name
:= Object_File_Name
(Current_Full_Lib_Name
);
2436 if Current_Full_Lib_Name
= No_File
then
2438 Fail
("Cannot find: " & Name_Buffer
(1 .. Name_Len
));
2440 Current_Full_Obj_Stamp
:= Empty_Time_Stamp
;
2445 Get_Name_String
(Current_Full_Lib_Name
);
2446 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
2448 -- Open the library FD, note that we open in binary mode, because as
2449 -- documented in the spec, the caller is expected to handle either
2450 -- DOS or Unix mode files, and there is no point in wasting time on
2451 -- text translation when it is not required.
2453 Lib_FD
:= Open_Read
(Name_Buffer
'Address, Binary
);
2455 if Lib_FD
= Invalid_FD
then
2457 Fail
("Cannot open: " & Name_Buffer
(1 .. Name_Len
));
2459 Current_Full_Obj_Stamp
:= Empty_Time_Stamp
;
2464 -- Compute the length of the file (potentially also preparing other data
2465 -- like the timestamp and whether the file is read-only, for future use)
2467 Len
:= Integer (File_Length
(Name_Buffer
'Address, Lib_File_Attr
));
2469 -- Check for object file consistency if requested
2471 if Opt
.Check_Object_Consistency
then
2472 -- On most systems, this does not result in an extra system call
2474 Current_Full_Lib_Stamp
:=
2475 OS_Time_To_GNAT_Time
2476 (File_Time_Stamp
(Name_Buffer
'Address, Lib_File_Attr
));
2478 -- ??? One system call here
2480 Current_Full_Obj_Stamp
:= File_Stamp
(Current_Full_Obj_Name
);
2482 if Current_Full_Obj_Stamp
(1) = ' ' then
2484 -- When the library is readonly always assume object is consistent
2485 -- The call to Is_Writable_File only results in a system call on
2486 -- some systems, but in most cases it has already been computed as
2487 -- part of the call to File_Length above.
2489 Get_Name_String
(Current_Full_Lib_Name
);
2490 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
2492 if not Is_Writable_File
(Name_Buffer
'Address, Lib_File_Attr
) then
2493 Current_Full_Obj_Stamp
:= Current_Full_Lib_Stamp
;
2495 elsif Fatal_Err
then
2496 Get_Name_String
(Current_Full_Obj_Name
);
2497 Close
(Lib_FD
, Status
);
2499 -- No need to check the status, we fail anyway
2501 Fail
("Cannot find: " & Name_Buffer
(1 .. Name_Len
));
2504 Current_Full_Obj_Stamp
:= Empty_Time_Stamp
;
2505 Close
(Lib_FD
, Status
);
2507 -- No need to check the status, we return null anyway
2512 elsif Current_Full_Obj_Stamp
< Current_Full_Lib_Stamp
then
2513 Close
(Lib_FD
, Status
);
2515 -- No need to check the status, we return null anyway
2521 -- Read data from the file
2524 Actual_Len
: Integer := 0;
2526 Lo
: constant Text_Ptr
:= 0;
2527 -- Low bound for allocated text buffer
2529 Hi
: Text_Ptr
:= Text_Ptr
(Len
);
2530 -- High bound for allocated text buffer. Note length is Len + 1
2531 -- which allows for extra EOF character at the end of the buffer.
2534 -- Allocate text buffer. Note extra character at end for EOF
2536 Text
:= new Text_Buffer
(Lo
.. Hi
);
2538 -- Some systems have file types that require one read per line,
2539 -- so read until we get the Len bytes or until there are no more
2544 Actual_Len
:= Read
(Lib_FD
, Text
(Hi
)'Address, Len
);
2545 Hi
:= Hi
+ Text_Ptr
(Actual_Len
);
2546 exit when Actual_Len
= Len
or else Actual_Len
<= 0;
2552 -- Read is complete, close file and we are done
2554 Close
(Lib_FD
, Status
);
2555 -- The status should never be False. But, if it is, what can we do?
2556 -- So, we don't test it.
2560 end Read_Library_Info_From_Full
;
2562 ----------------------
2563 -- Read_Source_File --
2564 ----------------------
2566 procedure Read_Source_File
2567 (N
: File_Name_Type
;
2569 Hi
: out Source_Ptr
;
2570 Src
: out Source_Buffer_Ptr
;
2571 FD
: out File_Descriptor
;
2572 T
: File_Type
:= Source
)
2575 -- Length of file, assume no more than 2 gigabytes of source
2577 Actual_Len
: Integer;
2580 pragma Warnings
(Off
, Status
);
2581 -- For the call to Close
2584 Current_Full_Source_Name
:= Find_File
(N
, T
, Full_Name
=> True);
2585 Current_Full_Source_Stamp
:= File_Stamp
(Current_Full_Source_Name
);
2587 if Current_Full_Source_Name
= No_File
then
2589 -- If we were trying to access the main file and we could not find
2590 -- it, we have an error.
2592 if N
= Current_Main
then
2593 Get_Name_String
(N
);
2594 Fail
("Cannot find: " & Name_Buffer
(1 .. Name_Len
));
2603 Get_Name_String
(Current_Full_Source_Name
);
2604 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
2606 -- Open the source FD, note that we open in binary mode, because as
2607 -- documented in the spec, the caller is expected to handle either
2608 -- DOS or Unix mode files, and there is no point in wasting time on
2609 -- text translation when it is not required.
2611 FD
:= Open_Read
(Name_Buffer
'Address, Binary
);
2613 if FD
= Invalid_FD
then
2619 -- If it's a Source file, print out the file name, if requested, and if
2620 -- it's not part of the runtimes, store it in File_Name_Chars. We don't
2621 -- want to print non-Source files, like GNAT-TEMP-000001.TMP used to
2622 -- pass information from gprbuild to gcc. We don't want to save runtime
2623 -- file names, because we don't want users to send them in bug reports.
2627 Name
: String renames Name_Buffer
(1 .. Name_Len
);
2628 Inc
: String renames Include_Dir_Default_Prefix
.all;
2630 Part_Of_Runtimes
: constant Boolean :=
2632 and then Inc
'Length < Name_Len
2633 and then Name_Buffer
(1 .. Inc
'Length) = Inc
;
2636 if Debug
.Debug_Flag_Dot_N
then
2640 if not Part_Of_Runtimes
then
2641 File_Name_Chars
.Append_All
(File_Name_Chars
.Table_Type
(Name
));
2642 File_Name_Chars
.Append
(ASCII
.LF
);
2647 -- Prepare to read data from the file
2649 Len
:= Integer (File_Length
(FD
));
2651 -- Set Hi so that length is one more than the physical length,
2652 -- allowing for the extra EOF character at the end of the buffer
2654 Hi
:= Lo
+ Source_Ptr
(Len
);
2656 -- Do the actual read operation
2659 Var_Ptr
: constant Source_Buffer_Ptr_Var
:=
2660 new Source_Buffer
(Lo
.. Hi
);
2661 -- Allocate source buffer, allowing extra character at end for EOF
2663 -- Some systems have file types that require one read per line,
2664 -- so read until we get the Len bytes or until there are no more
2669 Actual_Len
:= Read
(FD
, Var_Ptr
(Hi
)'Address, Len
);
2670 Hi
:= Hi
+ Source_Ptr
(Actual_Len
);
2671 exit when Actual_Len
= Len
or else Actual_Len
<= 0;
2674 Var_Ptr
(Hi
) := EOF
;
2675 Src
:= Var_Ptr
.all'Access;
2678 -- Read is complete, get time stamp and close file and we are done
2682 -- The status should never be False. But, if it is, what can we do?
2683 -- So, we don't test it.
2685 -- ???We don't really need to return Hi anymore; We could get rid of
2686 -- it. We could also make this into a function.
2688 pragma Assert
(Hi
= Src
'Last);
2689 end Read_Source_File
;
2695 function Relocate_Path
2697 Path
: String) return String_Ptr
2701 procedure set_std_prefix
(S
: String; Len
: Integer);
2702 pragma Import
(C
, set_std_prefix
);
2705 if Std_Prefix
= null then
2706 Std_Prefix
:= Executable_Prefix
;
2708 if Std_Prefix
.all /= "" then
2710 -- Remove trailing directory separator when calling set_std_prefix
2712 set_std_prefix
(Std_Prefix
.all, Std_Prefix
'Length - 1);
2716 if Path
'Last >= Prefix
'Last and then Path
(Prefix
'Range) = Prefix
then
2717 if Std_Prefix
.all /= "" then
2719 (1 .. Std_Prefix
'Length + Path
'Last - Prefix
'Last);
2720 S
(1 .. Std_Prefix
'Length) := Std_Prefix
.all;
2721 S
(Std_Prefix
'Length + 1 .. S
'Last) :=
2722 Path
(Prefix
'Last + 1 .. Path
'Last);
2727 return new String'(Path);
2734 procedure Set_Program (P : Program_Type) is
2737 Fail ("Set_Program called twice");
2740 Program_Set := True;
2741 Running_Program := P;
2748 function Shared_Lib (Name : String) return String is
2749 Library : String (1 .. Name'Length + Library_Version'Length + 3);
2750 -- 3 = 2 for "-l" + 1 for "-" before lib version
2753 Library (1 .. 2) := "-l";
2754 Library (3 .. 2 + Name'Length) := Name;
2755 Library (3 + Name'Length) := '-';
2756 Library (4 + Name'Length .. Library'Last) := Library_Version;
2760 ----------------------
2761 -- Smart_File_Stamp --
2762 ----------------------
2764 function Smart_File_Stamp
2765 (N : File_Name_Type;
2766 T : File_Type) return Time_Stamp_Type
2768 File : File_Name_Type;
2769 Attr : aliased File_Attributes;
2772 if not File_Cache_Enabled then
2773 Find_File (N, T, File, Attr'Access);
2775 Smart_Find_File (N, T, File, Attr);
2778 if File = No_File then
2779 return Empty_Time_Stamp;
2781 Get_Name_String (File);
2782 Name_Buffer (Name_Len + 1) := ASCII.NUL;
2784 OS_Time_To_GNAT_Time
2785 (File_Time_Stamp (Name_Buffer'Address, Attr'Access));
2787 end Smart_File_Stamp;
2789 ---------------------
2790 -- Smart_Find_File --
2791 ---------------------
2793 function Smart_Find_File
2794 (N : File_Name_Type;
2795 T : File_Type) return File_Name_Type
2797 File : File_Name_Type;
2798 Attr : File_Attributes;
2800 Smart_Find_File (N, T, File, Attr);
2802 end Smart_Find_File;
2804 ---------------------
2805 -- Smart_Find_File --
2806 ---------------------
2808 procedure Smart_Find_File
2809 (N : File_Name_Type;
2811 Found : out File_Name_Type;
2812 Attr : out File_Attributes)
2814 Info : File_Info_Cache;
2817 if not File_Cache_Enabled then
2818 Find_File (N, T, Info.File, Info.Attr'Access);
2821 Info := File_Name_Hash_Table.Get (N);
2823 if Info.File = No_File then
2824 Find_File (N, T, Info.File, Info.Attr'Access);
2825 File_Name_Hash_Table.Set (N, Info);
2831 end Smart_Find_File;
2833 ----------------------
2834 -- Source_File_Data --
2835 ----------------------
2837 procedure Source_File_Data (Cache : Boolean) is
2839 File_Cache_Enabled := Cache;
2840 end Source_File_Data;
2842 -----------------------
2843 -- Source_File_Stamp --
2844 -----------------------
2846 function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is
2848 return Smart_File_Stamp (N, Source);
2849 end Source_File_Stamp;
2851 ---------------------
2852 -- Strip_Directory --
2853 ---------------------
2855 function Strip_Directory (Name : File_Name_Type) return File_Name_Type is
2857 Get_Name_String (Name);
2859 for J in reverse 1 .. Name_Len - 1 loop
2861 -- If we find the last directory separator
2863 if Is_Directory_Separator (Name_Buffer (J)) then
2865 -- Return part of Name that follows this last directory separator
2867 Name_Buffer (1 .. Name_Len - J) := Name_Buffer (J + 1 .. Name_Len);
2868 Name_Len := Name_Len - J;
2873 -- There were no directory separator, just return Name
2876 end Strip_Directory;
2882 function Strip_Suffix (Name : File_Name_Type) return File_Name_Type is
2884 Get_Name_String (Name);
2886 for J in reverse 2 .. Name_Len loop
2888 -- If we found the last '.', return part of Name that precedes it
2890 if Name_Buffer (J) = '.' then
2899 ---------------------------
2900 -- To_Canonical_File_List --
2901 ---------------------------
2903 function To_Canonical_File_List
2904 (Wildcard_Host_File : String;
2905 Only_Dirs : Boolean) return String_Access_List_Access
2907 function To_Canonical_File_List_Init
2908 (Host_File : Address;
2909 Only_Dirs : Integer) return Integer;
2910 pragma Import (C, To_Canonical_File_List_Init,
2911 "__gnat_to_canonical_file_list_init");
2913 function To_Canonical_File_List_Next return Address;
2914 pragma Import (C, To_Canonical_File_List_Next,
2915 "__gnat_to_canonical_file_list_next");
2917 procedure To_Canonical_File_List_Free;
2918 pragma Import (C, To_Canonical_File_List_Free,
2919 "__gnat_to_canonical_file_list_free");
2921 Num_Files : Integer;
2922 C_Wildcard_Host_File : String (1 .. Wildcard_Host_File'Length + 1);
2925 C_Wildcard_Host_File (1 .. Wildcard_Host_File'Length) :=
2927 C_Wildcard_Host_File (C_Wildcard_Host_File'Last) := ASCII.NUL;
2929 -- Do the expansion and say how many there are
2931 Num_Files := To_Canonical_File_List_Init
2932 (C_Wildcard_Host_File'Address, Boolean'Pos (Only_Dirs));
2935 Canonical_File_List : String_Access_List (1 .. Num_Files);
2936 Canonical_File_Addr : Address;
2937 Canonical_File_Len : CRTL.size_t;
2940 -- Retrieve the expanded directory names and build the list
2942 for J in 1 .. Num_Files loop
2943 Canonical_File_Addr := To_Canonical_File_List_Next;
2944 Canonical_File_Len := C_String_Length (Canonical_File_Addr);
2945 Canonical_File_List (J) := To_Path_String_Access
2946 (Canonical_File_Addr, Canonical_File_Len);
2949 -- Free up the storage
2951 To_Canonical_File_List_Free;
2953 return new String_Access_List'(Canonical_File_List
);
2955 end To_Canonical_File_List
;
2957 ----------------------
2958 -- To_Host_Dir_Spec --
2959 ----------------------
2961 function To_Host_Dir_Spec
2962 (Canonical_Dir
: String;
2963 Prefix_Style
: Boolean) return String_Access
2965 function To_Host_Dir_Spec
2966 (Canonical_Dir
: Address
;
2967 Prefix_Flag
: Integer) return Address
;
2968 pragma Import
(C
, To_Host_Dir_Spec
, "__gnat_to_host_dir_spec");
2970 C_Canonical_Dir
: String (1 .. Canonical_Dir
'Length + 1);
2971 Host_Dir_Addr
: Address
;
2972 Host_Dir_Len
: CRTL
.size_t
;
2975 C_Canonical_Dir
(1 .. Canonical_Dir
'Length) := Canonical_Dir
;
2976 C_Canonical_Dir
(C_Canonical_Dir
'Last) := ASCII
.NUL
;
2978 if Prefix_Style
then
2979 Host_Dir_Addr
:= To_Host_Dir_Spec
(C_Canonical_Dir
'Address, 1);
2981 Host_Dir_Addr
:= To_Host_Dir_Spec
(C_Canonical_Dir
'Address, 0);
2983 Host_Dir_Len
:= C_String_Length
(Host_Dir_Addr
);
2985 if Host_Dir_Len
= 0 then
2988 return To_Path_String_Access
(Host_Dir_Addr
, Host_Dir_Len
);
2990 end To_Host_Dir_Spec
;
2992 -----------------------
2993 -- To_Host_File_Spec --
2994 -----------------------
2996 function To_Host_File_Spec
2997 (Canonical_File
: String) return String_Access
2999 function To_Host_File_Spec
(Canonical_File
: Address
) return Address
;
3000 pragma Import
(C
, To_Host_File_Spec
, "__gnat_to_host_file_spec");
3002 C_Canonical_File
: String (1 .. Canonical_File
'Length + 1);
3003 Host_File_Addr
: Address
;
3004 Host_File_Len
: CRTL
.size_t
;
3007 C_Canonical_File
(1 .. Canonical_File
'Length) := Canonical_File
;
3008 C_Canonical_File
(C_Canonical_File
'Last) := ASCII
.NUL
;
3010 Host_File_Addr
:= To_Host_File_Spec
(C_Canonical_File
'Address);
3011 Host_File_Len
:= C_String_Length
(Host_File_Addr
);
3013 if Host_File_Len
= 0 then
3016 return To_Path_String_Access
3017 (Host_File_Addr
, Host_File_Len
);
3019 end To_Host_File_Spec
;
3021 ---------------------------
3022 -- To_Path_String_Access --
3023 ---------------------------
3025 function To_Path_String_Access
3026 (Path_Addr
: Address
;
3027 Path_Len
: CRTL
.size_t
) return String_Access
3029 subtype Path_String
is String (1 .. Integer (Path_Len
));
3030 type Path_String_Access
is access Path_String
;
3032 function Address_To_Access
is new
3033 Unchecked_Conversion
(Source
=> Address
,
3034 Target
=> Path_String_Access
);
3036 Path_Access
: constant Path_String_Access
:=
3037 Address_To_Access
(Path_Addr
);
3039 Return_Val
: String_Access
;
3042 Return_Val
:= new String (1 .. Integer (Path_Len
));
3044 for J
in 1 .. Integer (Path_Len
) loop
3045 Return_Val
(J
) := Path_Access
(J
);
3049 end To_Path_String_Access
;
3055 function Update_Path
(Path
: String_Ptr
) return String_Ptr
is
3057 function C_Update_Path
(Path
, Component
: Address
) return Address
;
3058 pragma Import
(C
, C_Update_Path
, "update_path");
3060 In_Length
: constant Integer := Path
'Length;
3061 In_String
: String (1 .. In_Length
+ 1);
3062 Component_Name
: aliased String := "GCC" & ASCII
.NUL
;
3063 Result_Ptr
: Address
;
3064 Result_Length
: CRTL
.size_t
;
3065 Out_String
: String_Ptr
;
3068 In_String
(1 .. In_Length
) := Path
.all;
3069 In_String
(In_Length
+ 1) := ASCII
.NUL
;
3070 Result_Ptr
:= C_Update_Path
(In_String
'Address, Component_Name
'Address);
3071 Result_Length
:= CRTL
.strlen
(Result_Ptr
);
3073 Out_String
:= new String (1 .. Integer (Result_Length
));
3074 CRTL
.strncpy
(Out_String
.all'Address, Result_Ptr
, Result_Length
);
3082 procedure Write_Info
(Info
: String) is
3084 Write_With_Check
(Info
'Address, Info
'Length);
3085 Write_With_Check
(EOL
'Address, 1);
3088 ------------------------
3089 -- Write_Program_Name --
3090 ------------------------
3092 procedure Write_Program_Name
is
3093 Save_Buffer
: constant String (1 .. Name_Len
) :=
3094 Name_Buffer
(1 .. Name_Len
);
3099 -- Convert the name to lower case so error messages are the same on
3102 for J
in 1 .. Name_Len
loop
3103 if Name_Buffer
(J
) in 'A' .. 'Z' then
3105 Character'Val (Character'Pos (Name_Buffer
(J
)) + 32);
3109 Write_Str
(Name_Buffer
(1 .. Name_Len
));
3111 -- Restore Name_Buffer which was clobbered by the call to
3112 -- Find_Program_Name
3114 Name_Len
:= Save_Buffer
'Last;
3115 Name_Buffer
(1 .. Name_Len
) := Save_Buffer
;
3116 end Write_Program_Name
;
3118 ----------------------
3119 -- Write_With_Check --
3120 ----------------------
3122 procedure Write_With_Check
(A
: Address
; N
: Integer) is
3125 if N
= Write
(Output_FD
, A
, N
) then
3128 Write_Str
("error: disk full writing ");
3129 Write_Name_Decoded
(Output_File_Name
);
3131 Name_Len
:= Name_Len
+ 1;
3132 Name_Buffer
(Name_Len
) := ASCII
.NUL
;
3133 Delete_File
(Name_Buffer
'Address, Ignore
);
3134 Exit_Program
(E_Fatal
);
3136 end Write_With_Check
;
3138 ----------------------------
3139 -- Package Initialization --
3140 ----------------------------
3142 procedure Reset_File_Attributes
(Attr
: System
.Address
);
3143 pragma Import
(C
, Reset_File_Attributes
, "__gnat_reset_attributes");
3146 Initialization
: declare
3148 function Get_Default_Identifier_Character_Set
return Character;
3149 pragma Import
(C
, Get_Default_Identifier_Character_Set
,
3150 "__gnat_get_default_identifier_character_set");
3151 -- Function to determine the default identifier character set,
3152 -- which is system dependent. See Opt package spec for a list of
3153 -- the possible character codes and their interpretations.
3155 function Get_Maximum_File_Name_Length
return Int
;
3156 pragma Import
(C
, Get_Maximum_File_Name_Length
,
3157 "__gnat_get_maximum_file_name_length");
3158 -- Function to get maximum file name length for system
3160 Sizeof_File_Attributes
: Integer;
3161 pragma Import
(C
, Sizeof_File_Attributes
,
3162 "__gnat_size_of_file_attributes");
3165 pragma Assert
(Sizeof_File_Attributes
<= File_Attributes_Size
);
3167 Reset_File_Attributes
(Unknown_Attributes
'Address);
3169 Identifier_Character_Set
:= Get_Default_Identifier_Character_Set
;
3170 Maximum_File_Name_Length
:= Get_Maximum_File_Name_Length
;
3172 -- Following should be removed by having above function return
3173 -- Integer'Last as indication of no maximum instead of -1 ???
3175 if Maximum_File_Name_Length
= -1 then
3176 Maximum_File_Name_Length
:= Int
'Last;
3179 Src_Search_Directories
.Set_Last
(Primary_Directory
);
3180 Src_Search_Directories
.Table
(Primary_Directory
) := new String'("");
3182 Lib_Search_Directories.Set_Last (Primary_Directory);
3183 Lib_Search_Directories.Table (Primary_Directory) := new String'("");