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.
91 -- Round to even seconds on Windows before conversion.
92 -- Windows ALI files had timestamps rounded to even seconds historically.
93 -- The rounding was originally done in GM_Split. Now that GM_Split no
94 -- longer does it, we are rounding it here only for ALI files.
96 function Executable_Prefix
return String_Ptr
;
97 -- Returns the name of the root directory where the executable is stored.
98 -- The executable must be located in a directory called "bin", or under
99 -- root/lib/gcc-lib/..., or under root/libexec/gcc/... For example, if
100 -- executable is stored in directory "/foo/bar/bin", this routine returns
101 -- "/foo/bar/". Return "" if location is not recognized as described above.
103 function Update_Path
(Path
: String_Ptr
) return String_Ptr
;
104 -- Update the specified path to replace the prefix with the location where
105 -- GNAT is installed. See the file prefix.c in GCC for details.
107 procedure Locate_File
112 Found
: out File_Name_Type
;
113 Attr
: access File_Attributes
);
114 -- See if the file N whose name is Name exists in directory Dir. Dir is an
115 -- index into the Lib_Search_Directories table if T = Library. Otherwise
116 -- if T = Source, Dir is an index into the Src_Search_Directories table.
117 -- Returns the File_Name_Type of the full file name if file found, or
118 -- No_File if not found.
120 -- On exit, Found is set to the file that was found, and Attr to a cache of
121 -- its attributes (at least those that have been computed so far). Reusing
122 -- the cache will save some system calls.
124 -- Attr is always reset in this call to Unknown_Attributes, even in case of
130 Found
: out File_Name_Type
;
131 Attr
: access File_Attributes
;
132 Full_Name
: Boolean := False);
133 -- A version of Find_File that also returns a cache of the file attributes
136 procedure Smart_Find_File
139 Found
: out File_Name_Type
;
140 Attr
: out File_Attributes
);
141 -- A version of Smart_Find_File that also returns a cache of the file
142 -- attributes for later reuse
144 function C_String_Length
(S
: Address
) return CRTL
.size_t
;
145 -- Returns length of a C string (zero for a null address)
147 function To_Path_String_Access
148 (Path_Addr
: Address
;
149 Path_Len
: CRTL
.size_t
) return String_Access
;
150 -- Converts a C String to an Ada String. Are we doing this to avoid withing
151 -- Interfaces.C.Strings ???
152 -- Caller must free result.
154 function Include_Dir_Default_Prefix
return String_Access
;
155 -- Same as exported version, except returns a String_Access
157 ------------------------------
158 -- Other Local Declarations --
159 ------------------------------
161 EOL
: constant Character := ASCII
.LF
;
162 -- End of line character
164 Number_File_Names
: Nat
:= 0;
165 -- Number of file names found on command line and placed in File_Names
167 Look_In_Primary_Directory_For_Current_Main
: Boolean := False;
168 -- When this variable is True, Find_File only looks in Primary_Directory
169 -- for the Current_Main file. This variable is always set to True for the
170 -- compiler. It is also True for gnatmake, when the source name given on
171 -- the command line has directory information.
173 Current_Full_Source_Name
: File_Name_Type
:= No_File
;
174 Current_Full_Source_Stamp
: Time_Stamp_Type
:= Empty_Time_Stamp
;
175 Current_Full_Lib_Name
: File_Name_Type
:= No_File
;
176 Current_Full_Lib_Stamp
: Time_Stamp_Type
:= Empty_Time_Stamp
;
177 Current_Full_Obj_Name
: File_Name_Type
:= No_File
;
178 Current_Full_Obj_Stamp
: Time_Stamp_Type
:= Empty_Time_Stamp
;
179 -- Respectively full name (with directory info) and time stamp of the
180 -- latest source, library and object files opened by Read_Source_File and
181 -- Read_Library_Info.
183 package File_Name_Chars
is new Table
.Table
(
184 Table_Component_Type
=> Character,
185 Table_Index_Type
=> Int
,
186 Table_Low_Bound
=> 1,
187 Table_Initial
=> Alloc
.File_Name_Chars_Initial
,
188 Table_Increment
=> Alloc
.File_Name_Chars_Increment
,
189 Table_Name
=> "File_Name_Chars");
190 -- Table to store text to be printed by Dump_Source_File_Names
192 The_Include_Dir_Default_Prefix
: String_Access
:= null;
193 -- Value returned by Include_Dir_Default_Prefix. We don't initialize it
194 -- here, because that causes an elaboration cycle with Sdefault; we
195 -- initialize it lazily instead.
201 Primary_Directory
: constant := 0;
202 -- This is index in the tables created below for the first directory to
203 -- search in for source or library information files. This is the directory
204 -- containing the latest main input file (a source file for the compiler or
205 -- a library file for the binder).
207 package Src_Search_Directories
is new Table
.Table
(
208 Table_Component_Type
=> String_Ptr
,
209 Table_Index_Type
=> Integer,
210 Table_Low_Bound
=> Primary_Directory
,
212 Table_Increment
=> 100,
213 Table_Name
=> "Osint.Src_Search_Directories");
214 -- Table of names of directories in which to search for source (Compiler)
215 -- files. This table is filled in the order in which the directories are
216 -- to be searched, and then used in that order.
218 package Lib_Search_Directories
is new Table
.Table
(
219 Table_Component_Type
=> String_Ptr
,
220 Table_Index_Type
=> Integer,
221 Table_Low_Bound
=> Primary_Directory
,
223 Table_Increment
=> 100,
224 Table_Name
=> "Osint.Lib_Search_Directories");
225 -- Table of names of directories in which to search for library (Binder)
226 -- files. This table is filled in the order in which the directories are
227 -- to be searched and then used in that order. The reason for having two
228 -- distinct tables is that we need them both in gnatmake.
230 ---------------------
231 -- File Hash Table --
232 ---------------------
234 -- The file hash table is provided to free the programmer from any
235 -- efficiency concern when retrieving full file names or time stamps of
236 -- source files. If the programmer calls Source_File_Data (Cache => True)
237 -- he is guaranteed that the price to retrieve the full name (i.e. with
238 -- directory info) or time stamp of the file will be payed only once, the
239 -- first time the full name is actually searched (or the first time the
240 -- time stamp is actually retrieved). This is achieved by employing a hash
241 -- table that stores as a key the File_Name_Type of the file and associates
242 -- to that File_Name_Type the full file name and time stamp of the file.
244 File_Cache_Enabled
: Boolean := False;
245 -- Set to true if you want the enable the file data caching mechanism
247 type File_Hash_Num
is range 0 .. 1020;
249 function File_Hash
(F
: File_Name_Type
) return File_Hash_Num
;
250 -- Compute hash index for use by Simple_HTable
252 type File_Info_Cache
is record
253 File
: File_Name_Type
;
254 Attr
: aliased File_Attributes
;
257 No_File_Info_Cache
: constant File_Info_Cache
:= (No_File
, (others => 0));
259 package File_Name_Hash_Table
is new GNAT
.HTable
.Simple_HTable
(
260 Header_Num
=> File_Hash_Num
,
261 Element
=> File_Info_Cache
,
262 No_Element
=> No_File_Info_Cache
,
263 Key
=> File_Name_Type
,
267 function Smart_Find_File
269 T
: File_Type
) return File_Name_Type
;
270 -- Exactly like Find_File except that if File_Cache_Enabled is True this
271 -- routine looks first in the hash table to see if the full name of the
272 -- file is already available.
274 function Smart_File_Stamp
276 T
: File_Type
) return Time_Stamp_Type
;
277 -- Takes the same parameter as the routine above (N is a file name without
278 -- any prefix directory information) and behaves like File_Stamp except
279 -- that if File_Cache_Enabled is True this routine looks first in the hash
280 -- table to see if the file stamp of the file is already available.
282 -----------------------------
283 -- Add_Default_Search_Dirs --
284 -----------------------------
286 procedure Add_Default_Search_Dirs
is
287 Search_Dir
: String_Access
;
288 Search_Path
: String_Access
;
289 Path_File_Name
: String_Access
;
291 procedure Add_Search_Dir
292 (Search_Dir
: String;
293 Additional_Source_Dir
: Boolean);
294 procedure Add_Search_Dir
295 (Search_Dir
: String_Access
;
296 Additional_Source_Dir
: Boolean);
297 -- Add a source search dir or a library search dir, depending on the
298 -- value of Additional_Source_Dir.
300 procedure Get_Dirs_From_File
(Additional_Source_Dir
: Boolean);
301 -- Open a path file and read the directory to search, one per line
303 function Get_Libraries_From_Registry
return String_Ptr
;
304 -- On Windows systems, get the list of installed standard libraries
305 -- from the registry key:
307 -- HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\
308 -- GNAT\Standard Libraries
309 -- Return an empty string on other systems.
311 -- Note that this is an undocumented legacy feature, and that it
312 -- works only when using the default runtime library (i.e. no --RTS=
313 -- command line switch).
319 procedure Add_Search_Dir
320 (Search_Dir
: String;
321 Additional_Source_Dir
: Boolean)
324 if Additional_Source_Dir
then
325 Add_Src_Search_Dir
(Search_Dir
);
327 Add_Lib_Search_Dir
(Search_Dir
);
331 procedure Add_Search_Dir
332 (Search_Dir
: String_Access
;
333 Additional_Source_Dir
: Boolean)
336 if Additional_Source_Dir
then
337 Add_Src_Search_Dir
(Search_Dir
.all);
339 Add_Lib_Search_Dir
(Search_Dir
.all);
343 ------------------------
344 -- Get_Dirs_From_File --
345 ------------------------
347 procedure Get_Dirs_From_File
(Additional_Source_Dir
: Boolean) is
348 File_FD
: File_Descriptor
;
349 Buffer
: constant String := Path_File_Name
.all & ASCII
.NUL
;
351 Actual_Len
: Natural;
358 pragma Warnings
(Off
, Status
);
359 -- For the call to Close where status is ignored
362 File_FD
:= Open_Read
(Buffer
'Address, Binary
);
364 -- If we cannot open the file, we ignore it, we don't fail
366 if File_FD
= Invalid_FD
then
370 Len
:= Integer (File_Length
(File_FD
));
372 S
:= new String (1 .. Len
);
374 -- Read the file. Note that the loop is probably not necessary any
375 -- more since the whole file is read in at once on all targets. But
376 -- it is harmless and might be needed in future.
380 while Curr
<= Len
and then Actual_Len
/= 0 loop
381 Actual_Len
:= Read
(File_FD
, S
(Curr
)'Address, Len
);
382 Curr
:= Curr
+ Actual_Len
;
385 -- We are done with the file, so we close it (ignore any error on
386 -- the close, since we have successfully read the file).
388 Close
(File_FD
, Status
);
390 -- Now, we read line by line
394 while Curr
< Len
loop
397 if Ch
= ASCII
.CR
or else Ch
= ASCII
.LF
398 or else Ch
= ASCII
.FF
or else Ch
= ASCII
.VT
400 if First
<= Curr
then
401 Add_Search_Dir
(S
(First
.. Curr
), Additional_Source_Dir
);
410 -- Last line is a special case, if the file does not end with
411 -- an end of line mark.
413 if First
<= S
'Last then
414 Add_Search_Dir
(S
(First
.. S
'Last), Additional_Source_Dir
);
416 end Get_Dirs_From_File
;
418 ---------------------------------
419 -- Get_Libraries_From_Registry --
420 ---------------------------------
422 function Get_Libraries_From_Registry
return String_Ptr
is
423 function C_Get_Libraries_From_Registry
return Address
;
424 pragma Import
(C
, C_Get_Libraries_From_Registry
,
425 "__gnat_get_libraries_from_registry");
427 Result_Ptr
: Address
;
428 Result_Length
: CRTL
.size_t
;
429 Out_String
: String_Ptr
;
432 Result_Ptr
:= C_Get_Libraries_From_Registry
;
433 Result_Length
:= CRTL
.strlen
(Result_Ptr
);
435 Out_String
:= new String (1 .. Integer (Result_Length
));
436 CRTL
.strncpy
(Out_String
.all'Address, Result_Ptr
, Result_Length
);
438 CRTL
.free
(Result_Ptr
);
441 end Get_Libraries_From_Registry
;
443 -- Start of processing for Add_Default_Search_Dirs
446 -- If there was a -gnateO switch, add all object directories from the
447 -- file given in argument to the library search list.
449 if Object_Path_File_Name
/= null then
450 Path_File_Name
:= String_Access
(Object_Path_File_Name
);
451 pragma Assert
(Path_File_Name
'Length > 0);
452 Get_Dirs_From_File
(Additional_Source_Dir
=> False);
455 -- After the locations specified on the command line, the next places
456 -- to look for files are the directories specified by the appropriate
457 -- environment variable. Get this value, extract the directory names
458 -- and store in the tables.
460 -- Check for eventual project path file env vars
462 Path_File_Name
:= Getenv
(Project_Include_Path_File
);
464 if Path_File_Name
'Length > 0 then
465 Get_Dirs_From_File
(Additional_Source_Dir
=> True);
468 Path_File_Name
:= Getenv
(Project_Objects_Path_File
);
470 if Path_File_Name
'Length > 0 then
471 Get_Dirs_From_File
(Additional_Source_Dir
=> False);
474 -- Put path name in canonical form
476 for Additional_Source_Dir
in False .. True loop
477 if Additional_Source_Dir
then
478 Search_Path
:= Getenv
(Ada_Include_Path
);
481 Search_Path
:= Getenv
(Ada_Objects_Path
);
485 Get_Next_Dir_In_Path_Init
(Search_Path
);
487 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
488 exit when Search_Dir
= null;
489 Add_Search_Dir
(Search_Dir
, Additional_Source_Dir
);
493 -- For the compiler, if --RTS= was specified, add the runtime
496 if RTS_Src_Path_Name
/= null and then RTS_Lib_Path_Name
/= null then
497 Add_Search_Dirs
(RTS_Src_Path_Name
, Include
);
498 Add_Search_Dirs
(RTS_Lib_Path_Name
, Objects
);
501 if not Opt
.No_Stdinc
then
503 -- For WIN32 systems, look for any system libraries defined in
504 -- the registry. These are added to both source and object
507 Search_Path
:= String_Access
(Get_Libraries_From_Registry
);
509 Get_Next_Dir_In_Path_Init
(Search_Path
);
511 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
512 exit when Search_Dir
= null;
513 Add_Search_Dir
(Search_Dir
, False);
514 Add_Search_Dir
(Search_Dir
, True);
517 -- The last place to look are the defaults
520 Read_Default_Search_Dirs
521 (String_Access
(Update_Path
(Search_Dir_Prefix
)),
523 String_Access
(Update_Path
(Include_Dir_Default_Name
)));
525 Get_Next_Dir_In_Path_Init
(Search_Path
);
527 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
528 exit when Search_Dir
= null;
529 Add_Search_Dir
(Search_Dir
, True);
533 -- Even when -nostdlib is used, we still want to have visibility on
534 -- the run-time object directory, as it is used by gnatbind to find
535 -- the run-time ALI files in "real" ZFP set up.
537 if not Opt
.RTS_Switch
then
539 Read_Default_Search_Dirs
540 (String_Access
(Update_Path
(Search_Dir_Prefix
)),
542 String_Access
(Update_Path
(Object_Dir_Default_Name
)));
544 Get_Next_Dir_In_Path_Init
(Search_Path
);
546 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
547 exit when Search_Dir
= null;
548 Add_Search_Dir
(Search_Dir
, False);
552 end Add_Default_Search_Dirs
;
558 procedure Add_File
(File_Name
: String; Index
: Int
:= No_Index
) is
560 Number_File_Names
:= Number_File_Names
+ 1;
562 -- As Add_File may be called for mains specified inside a project file,
563 -- File_Names may be too short and needs to be extended.
565 if Number_File_Names
> File_Names
'Last then
566 File_Names
:= new File_Name_Array
'(File_Names.all & File_Names.all);
568 new File_Index_Array'(File_Indexes
.all & File_Indexes
.all);
571 File_Names
(Number_File_Names
) := new String'(File_Name);
572 File_Indexes (Number_File_Names) := Index;
575 ------------------------
576 -- Add_Lib_Search_Dir --
577 ------------------------
579 procedure Add_Lib_Search_Dir (Dir : String) is
581 if Dir'Length = 0 then
582 Fail ("missing library directory name");
586 Norm : String_Ptr := Normalize_Directory_Name (Dir);
589 -- Do nothing if the directory is already in the list. This saves
590 -- system calls and avoid unneeded work
592 for D in Lib_Search_Directories.First ..
593 Lib_Search_Directories.Last
595 if Lib_Search_Directories.Table (D).all = Norm.all then
601 Lib_Search_Directories.Increment_Last;
602 Lib_Search_Directories.Table (Lib_Search_Directories.Last) := Norm;
604 end Add_Lib_Search_Dir;
606 ---------------------
607 -- Add_Search_Dirs --
608 ---------------------
610 procedure Add_Search_Dirs
611 (Search_Path : String_Ptr;
612 Path_Type : Search_File_Type)
614 Current_Search_Path : String_Access;
617 Get_Next_Dir_In_Path_Init (String_Access (Search_Path));
619 Current_Search_Path :=
620 Get_Next_Dir_In_Path (String_Access (Search_Path));
621 exit when Current_Search_Path = null;
623 if Path_Type = Include then
624 Add_Src_Search_Dir (Current_Search_Path.all);
626 Add_Lib_Search_Dir (Current_Search_Path.all);
631 ------------------------
632 -- Add_Src_Search_Dir --
633 ------------------------
635 procedure Add_Src_Search_Dir (Dir : String) is
637 if Dir'Length = 0 then
638 Fail ("missing source directory name");
641 Src_Search_Directories.Increment_Last;
642 Src_Search_Directories.Table (Src_Search_Directories.Last) :=
643 Normalize_Directory_Name (Dir);
644 end Add_Src_Search_Dir;
646 --------------------------------
647 -- Append_Suffix_To_File_Name --
648 --------------------------------
650 function Append_Suffix_To_File_Name
651 (Name : File_Name_Type;
652 Suffix : String) return File_Name_Type
655 Get_Name_String (Name);
656 Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
657 Name_Len := Name_Len + Suffix'Length;
659 end Append_Suffix_To_File_Name;
661 ---------------------
662 -- C_String_Length --
663 ---------------------
665 function C_String_Length (S : Address) return CRTL.size_t is
667 if S = Null_Address then
670 return CRTL.strlen (S);
674 ------------------------------
675 -- Canonical_Case_File_Name --
676 ------------------------------
678 procedure Canonical_Case_File_Name (S : in out String) is
680 if not File_Names_Case_Sensitive then
683 end Canonical_Case_File_Name;
685 ---------------------------------
686 -- Canonical_Case_Env_Var_Name --
687 ---------------------------------
689 procedure Canonical_Case_Env_Var_Name (S : in out String) is
691 if not Env_Vars_Case_Sensitive then
694 end Canonical_Case_Env_Var_Name;
696 ---------------------------
697 -- Create_File_And_Check --
698 ---------------------------
700 procedure Create_File_And_Check
701 (Fdesc : out File_Descriptor;
705 Output_File_Name := Name_Enter;
706 Fdesc := Create_File (Name_Buffer'Address, Fmode);
708 if Fdesc = Invalid_FD then
709 Fail ("Cannot create: " & Name_Buffer (1 .. Name_Len));
711 end Create_File_And_Check;
713 -----------------------------------
714 -- Open_File_To_Append_And_Check --
715 -----------------------------------
717 procedure Open_File_To_Append_And_Check
718 (Fdesc : out File_Descriptor;
722 Output_File_Name := Name_Enter;
723 Fdesc := Open_Append (Name_Buffer'Address, Fmode);
725 if Fdesc = Invalid_FD then
726 Fail ("Cannot create: " & Name_Buffer (1 .. Name_Len));
728 end Open_File_To_Append_And_Check;
730 ------------------------
731 -- Current_File_Index --
732 ------------------------
734 function Current_File_Index return Int is
736 return File_Indexes (Current_File_Name_Index);
737 end Current_File_Index;
739 --------------------------------
740 -- Current_Library_File_Stamp --
741 --------------------------------
743 function Current_Library_File_Stamp return Time_Stamp_Type is
745 return Current_Full_Lib_Stamp;
746 end Current_Library_File_Stamp;
748 -------------------------------
749 -- Current_Object_File_Stamp --
750 -------------------------------
752 function Current_Object_File_Stamp return Time_Stamp_Type is
754 return Current_Full_Obj_Stamp;
755 end Current_Object_File_Stamp;
757 -------------------------------
758 -- Current_Source_File_Stamp --
759 -------------------------------
761 function Current_Source_File_Stamp return Time_Stamp_Type is
763 return Current_Full_Source_Stamp;
764 end Current_Source_File_Stamp;
766 ----------------------------
767 -- Dir_In_Obj_Search_Path --
768 ----------------------------
770 function Dir_In_Obj_Search_Path (Position : Natural) return String_Ptr is
772 if Opt.Look_In_Primary_Dir then
774 Lib_Search_Directories.Table (Primary_Directory + Position - 1);
776 return Lib_Search_Directories.Table (Primary_Directory + Position);
778 end Dir_In_Obj_Search_Path;
780 ----------------------------
781 -- Dir_In_Src_Search_Path --
782 ----------------------------
784 function Dir_In_Src_Search_Path (Position : Natural) return String_Ptr is
786 if Opt.Look_In_Primary_Dir then
788 Src_Search_Directories.Table (Primary_Directory + Position - 1);
790 return Src_Search_Directories.Table (Primary_Directory + Position);
792 end Dir_In_Src_Search_Path;
794 -----------------------------------------
795 -- Dump_Command_Line_Source_File_Names --
796 -----------------------------------------
798 procedure Dump_Command_Line_Source_File_Names is
800 for J in 1 .. Number_Of_Files loop
801 Write_Str (File_Names (J).all & " ");
803 end Dump_Command_Line_Source_File_Names;
805 ----------------------------
806 -- Dump_Source_File_Names --
807 ----------------------------
809 procedure Dump_Source_File_Names is
810 subtype Rng is Int range File_Name_Chars.First .. File_Name_Chars.Last;
812 Write_Str (String (File_Name_Chars.Table (Rng)));
813 end Dump_Source_File_Names;
815 ---------------------
816 -- Executable_Name --
817 ---------------------
819 function Executable_Name
820 (Name : File_Name_Type;
821 Only_If_No_Suffix : Boolean := False) return File_Name_Type
823 Exec_Suffix : String_Access;
824 Add_Suffix : Boolean;
827 if Name = No_File then
831 if Executable_Extension_On_Target = No_Name then
832 Exec_Suffix := Get_Target_Executable_Suffix;
834 Get_Name_String (Executable_Extension_On_Target);
835 Exec_Suffix := new String'(Name_Buffer
(1 .. Name_Len
));
838 if Exec_Suffix
'Length /= 0 then
839 Get_Name_String
(Name
);
842 if Only_If_No_Suffix
then
843 for J
in reverse 1 .. Name_Len
loop
844 if Name_Buffer
(J
) = '.' then
848 elsif Is_Directory_Separator
(Name_Buffer
(J
)) then
856 Buffer
: String := Name_Buffer
(1 .. Name_Len
);
859 -- Get the file name in canonical case to accept as is. Names
860 -- end with ".EXE" on Windows.
862 Canonical_Case_File_Name
(Buffer
);
864 -- If Executable doesn't end with the executable suffix, add it
866 if Buffer
'Length <= Exec_Suffix
'Length
868 Buffer
(Buffer
'Last - Exec_Suffix
'Length + 1 .. Buffer
'Last)
872 (Name_Len
+ 1 .. Name_Len
+ Exec_Suffix
'Length) :=
874 Name_Len
:= Name_Len
+ Exec_Suffix
'Length;
886 function Executable_Name
888 Only_If_No_Suffix
: Boolean := False) return String
890 Exec_Suffix
: String_Access
;
891 Add_Suffix
: Boolean;
892 Canonical_Name
: String := Name
;
895 if Executable_Extension_On_Target
= No_Name
then
896 Exec_Suffix
:= Get_Target_Executable_Suffix
;
898 Get_Name_String
(Executable_Extension_On_Target
);
899 Exec_Suffix
:= new String'(Name_Buffer (1 .. Name_Len));
902 if Exec_Suffix'Length = 0 then
908 Suffix : constant String := Exec_Suffix.all;
912 Canonical_Case_File_Name (Canonical_Name);
915 if Only_If_No_Suffix then
916 for J in reverse Canonical_Name'Range loop
917 if Canonical_Name (J) = '.' then
921 elsif Is_Directory_Separator (Canonical_Name (J)) then
927 if Add_Suffix and then
928 (Canonical_Name'Length <= Suffix'Length
929 or else Canonical_Name (Canonical_Name'Last - Suffix'Length + 1
930 .. Canonical_Name'Last) /= Suffix)
933 Result : String (1 .. Name'Length + Suffix'Length);
935 Result (1 .. Name'Length) := Name;
936 Result (Name'Length + 1 .. Result'Last) := Suffix;
946 -----------------------
947 -- Executable_Prefix --
948 -----------------------
950 function Executable_Prefix return String_Ptr is
952 function Get_Install_Dir (Exec : String) return String_Ptr;
953 -- S is the executable name preceded by the absolute or relative
954 -- path, e.g. "c:\usr\bin\gcc.exe" or "..\bin\gcc".
956 ---------------------
957 -- Get_Install_Dir --
958 ---------------------
960 function Get_Install_Dir (Exec : String) return String_Ptr is
961 Full_Path : constant String := Normalize_Pathname (Exec);
962 -- Use the full path, so that we find "lib" or "bin", even when
963 -- the tool has been invoked with a relative path, as in
964 -- "./gnatls -v" invoked in the GNAT bin directory.
967 for J in reverse Full_Path'Range loop
968 if Is_Directory_Separator (Full_Path (J)) then
969 if J < Full_Path'Last - 5 then
970 if (To_Lower (Full_Path (J + 1)) = 'l
'
971 and then To_Lower (Full_Path (J + 2)) = 'i
'
972 and then To_Lower (Full_Path (J + 3)) = 'b
')
974 (To_Lower (Full_Path (J + 1)) = 'b
'
975 and then To_Lower (Full_Path (J + 2)) = 'i
'
976 and then To_Lower (Full_Path (J + 3)) = 'n
')
978 return new String'(Full_Path
(Full_Path
'First .. J
));
984 return new String'("");
987 -- Start of processing for Executable_Prefix
990 if Exec_Name = null then
991 Exec_Name := new String (1 .. Len_Arg (0));
992 Osint.Fill_Arg (Exec_Name (1)'Address, 0);
995 -- First determine if a path prefix was placed in front of the
998 for J in reverse Exec_Name'Range loop
999 if Is_Directory_Separator (Exec_Name (J)) then
1000 return Get_Install_Dir (Exec_Name.all);
1004 -- If we come here, the user has typed the executable name with no
1005 -- directory prefix.
1007 return Get_Install_Dir (Locate_Exec_On_Path (Exec_Name.all).all);
1008 end Executable_Prefix;
1014 procedure Exit_Program (Exit_Code : Exit_Code_Type) is
1016 -- The program will exit with the following status:
1018 -- 0 if the object file has been generated (with or without warnings)
1019 -- 1 if recompilation was not needed (smart recompilation)
1020 -- 2 if gnat1 has been killed by a signal (detected by GCC)
1021 -- 4 for a fatal error
1022 -- 5 if there were errors
1023 -- 6 if no code has been generated (spec)
1025 -- Note that exit code 3 is not used and must not be used as this is
1026 -- the code returned by a program aborted via C abort() routine on
1027 -- Windows. GCC checks for that case and thinks that the child process
1028 -- has been aborted. This code (exit code 3) used to be the code used
1029 -- for E_No_Code, but E_No_Code was changed to 6 for this reason.
1032 when E_Success => OS_Exit (0);
1033 when E_Warnings => OS_Exit (0);
1034 when E_No_Compile => OS_Exit (1);
1035 when E_Fatal => OS_Exit (4);
1036 when E_Errors => OS_Exit (5);
1037 when E_No_Code => OS_Exit (6);
1038 when E_Abort => OS_Abort;
1046 procedure Fail (S : String) is
1048 -- We use Output in case there is a special output set up. In this case
1049 -- Set_Standard_Error will have no immediate effect.
1052 Osint.Write_Program_Name;
1057 Exit_Program (E_Fatal);
1064 function File_Hash (F : File_Name_Type) return File_Hash_Num is
1066 return File_Hash_Num (Int (F) rem File_Hash_Num'Range_Length);
1073 function File_Length
1074 (Name : C_File_Name;
1075 Attr : access File_Attributes) return Long_Integer
1080 A : System.Address) return CRTL.int64;
1081 pragma Import (C, Internal, "__gnat_file_length_attr");
1084 -- The conversion from int64 to Long_Integer is ok here as this
1085 -- routine is only to be used by the compiler and we do not expect
1086 -- a unit to be larger than a 32bit integer.
1088 return Long_Integer (Internal (-1, Name, Attr.all'Address));
1091 ---------------------
1092 -- File_Time_Stamp --
1093 ---------------------
1095 function File_Time_Stamp
1096 (Name : C_File_Name;
1097 Attr : access File_Attributes) return OS_Time
1099 function Internal (N : C_File_Name; A : System.Address) return OS_Time;
1100 pragma Import (C, Internal, "__gnat_file_time_name_attr");
1102 return Internal (Name, Attr.all'Address);
1103 end File_Time_Stamp;
1105 function File_Time_Stamp
1106 (Name : Path_Name_Type;
1107 Attr : access File_Attributes) return Time_Stamp_Type
1110 if Name = No_Path then
1111 return Empty_Time_Stamp;
1114 Get_Name_String (Name);
1115 Name_Buffer (Name_Len + 1) := ASCII.NUL;
1116 return OS_Time_To_GNAT_Time
1117 (File_Time_Stamp (Name_Buffer'Address, Attr));
1118 end File_Time_Stamp;
1124 function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type is
1126 if Name = No_File then
1127 return Empty_Time_Stamp;
1130 Get_Name_String (Name);
1132 -- File_Time_Stamp will always return Invalid_Time if the file does
1133 -- not exist, and OS_Time_To_GNAT_Time will convert this value to
1134 -- Empty_Time_Stamp. Therefore we do not need to first test whether
1135 -- the file actually exists, which saves a system call.
1137 return OS_Time_To_GNAT_Time
1138 (File_Time_Stamp (Name_Buffer (1 .. Name_Len)));
1141 function File_Stamp (Name : Path_Name_Type) return Time_Stamp_Type is
1143 return File_Stamp (File_Name_Type (Name));
1151 (N : File_Name_Type;
1153 Full_Name : Boolean := False) return File_Name_Type
1155 Attr : aliased File_Attributes;
1156 Found : File_Name_Type;
1158 Find_File (N, T, Found, Attr'Access, Full_Name);
1167 (N : File_Name_Type;
1169 Found : out File_Name_Type;
1170 Attr : access File_Attributes;
1171 Full_Name : Boolean := False)
1174 Get_Name_String (N);
1177 File_Name : String renames Name_Buffer (1 .. Name_Len);
1178 File : File_Name_Type := No_File;
1182 -- If we are looking for a config file, look only in the current
1183 -- directory, i.e. return input argument unchanged. Also look only in
1184 -- the current directory if we are looking for a .dg file (happens in
1188 or else (Debug_Generated_Code
1189 and then Name_Len > 3
1190 and then Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg")
1193 Attr.all := Unknown_Attributes;
1198 Full_Path : constant String :=
1199 Normalize_Pathname (Get_Name_String (N));
1200 Full_Size : constant Natural := Full_Path'Length;
1203 Name_Buffer (1 .. Full_Size) := Full_Path;
1204 Name_Len := Full_Size;
1209 -- Check that it is a file, not a directory
1211 if not Is_Regular_File (Get_Name_String (Found)) then
1218 -- If we are trying to find the current main file just look in the
1219 -- directory where the user said it was.
1221 elsif Look_In_Primary_Directory_For_Current_Main
1222 and then Current_Main = N
1224 Locate_File (N, T, Primary_Directory, File_Name, Found, Attr);
1227 -- Otherwise do standard search for source file
1230 -- Check the mapping of this file name
1232 File := Mapped_Path_Name (N);
1234 -- If the file name is mapped to a path name, return the
1235 -- corresponding path name
1237 if File /= No_File then
1239 -- For locally removed file, Error_Name is returned; then
1240 -- return No_File, indicating the file is not a source.
1242 if File = Error_File_Name then
1248 Attr.all := Unknown_Attributes;
1252 -- First place to look is in the primary directory (i.e. the same
1253 -- directory as the source) unless this has been disabled with -I-
1255 if Opt.Look_In_Primary_Dir then
1256 Locate_File (N, T, Primary_Directory, File_Name, Found, Attr);
1258 if Found /= No_File then
1263 -- Finally look in directories specified with switches -I/-aI/-aO
1266 Last_Dir := Lib_Search_Directories.Last;
1268 Last_Dir := Src_Search_Directories.Last;
1271 for D in Primary_Directory + 1 .. Last_Dir loop
1272 Locate_File (N, T, D, File_Name, Found, Attr);
1274 if Found /= No_File then
1279 Attr.all := Unknown_Attributes;
1285 -----------------------
1286 -- Find_Program_Name --
1287 -----------------------
1289 procedure Find_Program_Name is
1290 Command_Name : String (1 .. Len_Arg (0));
1291 Cindex1 : Integer := Command_Name'First;
1292 Cindex2 : Integer := Command_Name'Last;
1295 Fill_Arg (Command_Name'Address, 0);
1297 if Command_Name = "" then
1302 -- The program name might be specified by a full path name. However,
1303 -- we don't want to print that all out in an error message, so the
1304 -- path might need to be stripped away.
1306 for J in reverse Cindex1 .. Cindex2 loop
1307 if Is_Directory_Separator (Command_Name (J)) then
1313 -- Command_Name(Cindex1 .. Cindex2) is now the equivalent of the
1314 -- POSIX command "basename argv[0]"
1316 -- Strip off any executable extension (usually nothing or .exe)
1317 -- but formally reported by autoconf in the variable EXEEXT
1319 if Cindex2 - Cindex1 >= 4 then
1320 if To_Lower (Command_Name (Cindex2 - 3)) = '.'
1321 and then To_Lower (Command_Name (Cindex2 - 2)) = 'e
'
1322 and then To_Lower (Command_Name (Cindex2 - 1)) = 'x
'
1323 and then To_Lower (Command_Name (Cindex2)) = 'e
'
1325 Cindex2 := Cindex2 - 4;
1329 Name_Len := Cindex2 - Cindex1 + 1;
1330 Name_Buffer (1 .. Name_Len) := Command_Name (Cindex1 .. Cindex2);
1331 end Find_Program_Name;
1333 ------------------------
1334 -- Full_Lib_File_Name --
1335 ------------------------
1337 procedure Full_Lib_File_Name
1338 (N : File_Name_Type;
1339 Lib_File : out File_Name_Type;
1340 Attr : out File_Attributes)
1342 A : aliased File_Attributes;
1344 -- ??? seems we could use Smart_Find_File here
1345 Find_File (N, Library, Lib_File, A'Access);
1347 end Full_Lib_File_Name;
1349 ------------------------
1350 -- Full_Lib_File_Name --
1351 ------------------------
1353 function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type is
1354 Attr : File_Attributes;
1355 File : File_Name_Type;
1357 Full_Lib_File_Name (N, File, Attr);
1359 end Full_Lib_File_Name;
1361 ----------------------------
1362 -- Full_Library_Info_Name --
1363 ----------------------------
1365 function Full_Library_Info_Name return File_Name_Type is
1367 return Current_Full_Lib_Name;
1368 end Full_Library_Info_Name;
1370 ---------------------------
1371 -- Full_Object_File_Name --
1372 ---------------------------
1374 function Full_Object_File_Name return File_Name_Type is
1376 return Current_Full_Obj_Name;
1377 end Full_Object_File_Name;
1379 ----------------------
1380 -- Full_Source_Name --
1381 ----------------------
1383 function Full_Source_Name return File_Name_Type is
1385 return Current_Full_Source_Name;
1386 end Full_Source_Name;
1388 ----------------------
1389 -- Full_Source_Name --
1390 ----------------------
1392 function Full_Source_Name (N : File_Name_Type) return File_Name_Type is
1394 return Smart_Find_File (N, Source);
1395 end Full_Source_Name;
1397 ----------------------
1398 -- Full_Source_Name --
1399 ----------------------
1401 procedure Full_Source_Name
1402 (N : File_Name_Type;
1403 Full_File : out File_Name_Type;
1404 Attr : access File_Attributes) is
1406 Smart_Find_File (N, Source, Full_File, Attr.all);
1407 end Full_Source_Name;
1413 function Get_Directory (Name : File_Name_Type) return File_Name_Type is
1415 Get_Name_String (Name);
1417 for J in reverse 1 .. Name_Len loop
1418 if Is_Directory_Separator (Name_Buffer (J)) then
1424 Name_Len := Hostparm.Normalized_CWD'Length;
1425 Name_Buffer (1 .. Name_Len) := Hostparm.Normalized_CWD;
1429 ------------------------------
1430 -- Get_First_Main_File_Name --
1431 ------------------------------
1433 function Get_First_Main_File_Name return String is
1435 return File_Names (1).all;
1436 end Get_First_Main_File_Name;
1438 --------------------------
1439 -- Get_Next_Dir_In_Path --
1440 --------------------------
1442 Search_Path_Pos : Integer;
1443 -- Keeps track of current position in search path. Initialized by the
1444 -- call to Get_Next_Dir_In_Path_Init, updated by Get_Next_Dir_In_Path.
1446 function Get_Next_Dir_In_Path
1447 (Search_Path : String_Access) return String_Access
1449 Lower_Bound : Positive := Search_Path_Pos;
1450 Upper_Bound : Positive;
1454 while Lower_Bound <= Search_Path'Last
1455 and then Search_Path.all (Lower_Bound) = Path_Separator
1457 Lower_Bound := Lower_Bound + 1;
1460 exit when Lower_Bound > Search_Path'Last;
1462 Upper_Bound := Lower_Bound;
1463 while Upper_Bound <= Search_Path'Last
1464 and then Search_Path.all (Upper_Bound) /= Path_Separator
1466 Upper_Bound := Upper_Bound + 1;
1469 Search_Path_Pos := Upper_Bound;
1470 return new String'(Search_Path
.all (Lower_Bound
.. Upper_Bound
- 1));
1474 end Get_Next_Dir_In_Path
;
1476 -------------------------------
1477 -- Get_Next_Dir_In_Path_Init --
1478 -------------------------------
1480 procedure Get_Next_Dir_In_Path_Init
(Search_Path
: String_Access
) is
1482 Search_Path_Pos
:= Search_Path
'First;
1483 end Get_Next_Dir_In_Path_Init
;
1485 --------------------------------------
1486 -- Get_Primary_Src_Search_Directory --
1487 --------------------------------------
1489 function Get_Primary_Src_Search_Directory
return String_Ptr
is
1491 return Src_Search_Directories
.Table
(Primary_Directory
);
1492 end Get_Primary_Src_Search_Directory
;
1494 ------------------------
1495 -- Get_RTS_Search_Dir --
1496 ------------------------
1498 function Get_RTS_Search_Dir
1499 (Search_Dir
: String;
1500 File_Type
: Search_File_Type
) return String_Ptr
1502 procedure Get_Current_Dir
1503 (Dir
: System
.Address
;
1504 Length
: System
.Address
);
1505 pragma Import
(C
, Get_Current_Dir
, "__gnat_get_current_dir");
1508 pragma Import
(C
, Max_Path
, "__gnat_max_path_len");
1509 -- Maximum length of a path name
1511 Current_Dir
: String_Ptr
;
1512 Default_Search_Dir
: String_Access
;
1513 Default_Suffix_Dir
: String_Access
;
1514 Local_Search_Dir
: String_Access
;
1515 Norm_Search_Dir
: String_Access
;
1516 Result_Search_Dir
: String_Access
;
1517 Search_File
: String_Access
;
1518 Temp_String
: String_Ptr
;
1521 -- Add a directory separator at the end of the directory if necessary
1522 -- so that we can directly append a file to the directory
1524 if not Is_Directory_Separator
(Search_Dir
(Search_Dir
'Last)) then
1526 new String'(Search_Dir & String'(1 => Directory_Separator
));
1528 Local_Search_Dir
:= new String'(Search_Dir);
1531 if File_Type = Include then
1532 Search_File := Include_Search_File;
1533 Default_Suffix_Dir := new String'("adainclude");
1535 Search_File
:= Objects_Search_File
;
1536 Default_Suffix_Dir
:= new String'("adalib");
1539 Norm_Search_Dir := Local_Search_Dir;
1541 if Is_Absolute_Path (Norm_Search_Dir.all) then
1543 -- We first verify if there is a directory Include_Search_Dir
1544 -- containing default search directories
1546 Result_Search_Dir :=
1547 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1548 Default_Search_Dir :=
1549 new String'(Norm_Search_Dir
.all & Default_Suffix_Dir
.all);
1550 Free
(Norm_Search_Dir
);
1552 if Result_Search_Dir
/= null then
1553 return String_Ptr
(Result_Search_Dir
);
1554 elsif Is_Directory
(Default_Search_Dir
.all) then
1555 return String_Ptr
(Default_Search_Dir
);
1560 -- Search in the current directory
1563 -- Get the current directory
1566 Buffer
: String (1 .. Max_Path
+ 2);
1567 Path_Len
: Natural := Max_Path
;
1570 Get_Current_Dir
(Buffer
'Address, Path_Len
'Address);
1572 if Path_Len
= 0 then
1573 raise Program_Error
;
1576 if not Is_Directory_Separator
(Buffer
(Path_Len
)) then
1577 Path_Len
:= Path_Len
+ 1;
1578 Buffer
(Path_Len
) := Directory_Separator
;
1581 Current_Dir
:= new String'(Buffer (1 .. Path_Len));
1585 new String'(Current_Dir
.all & Local_Search_Dir
.all);
1587 Result_Search_Dir
:=
1588 Read_Default_Search_Dirs
(Norm_Search_Dir
, Search_File
, null);
1590 Default_Search_Dir
:=
1591 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1593 Free (Norm_Search_Dir);
1595 if Result_Search_Dir /= null then
1596 return String_Ptr (Result_Search_Dir);
1598 elsif Is_Directory (Default_Search_Dir.all) then
1599 return String_Ptr (Default_Search_Dir);
1602 -- Search in Search_Dir_Prefix/Search_Dir
1606 (Update_Path
(Search_Dir_Prefix
).all & Local_Search_Dir
.all);
1608 Result_Search_Dir
:=
1609 Read_Default_Search_Dirs
(Norm_Search_Dir
, Search_File
, null);
1611 Default_Search_Dir
:=
1612 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1614 Free (Norm_Search_Dir);
1616 if Result_Search_Dir /= null then
1617 return String_Ptr (Result_Search_Dir);
1619 elsif Is_Directory (Default_Search_Dir.all) then
1620 return String_Ptr (Default_Search_Dir);
1623 -- We finally search in Search_Dir_Prefix/rts-Search_Dir
1626 new String'(Update_Path
(Search_Dir_Prefix
).all & "rts-");
1629 new String'(Temp_String.all & Local_Search_Dir.all);
1631 Result_Search_Dir :=
1632 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1634 Default_Search_Dir :=
1635 new String'(Norm_Search_Dir
.all & Default_Suffix_Dir
.all);
1636 Free
(Norm_Search_Dir
);
1638 if Result_Search_Dir
/= null then
1639 return String_Ptr
(Result_Search_Dir
);
1641 elsif Is_Directory
(Default_Search_Dir
.all) then
1642 return String_Ptr
(Default_Search_Dir
);
1650 end Get_RTS_Search_Dir
;
1652 --------------------------------
1653 -- Include_Dir_Default_Prefix --
1654 --------------------------------
1656 function Include_Dir_Default_Prefix
return String_Access
is
1658 if The_Include_Dir_Default_Prefix
= null then
1659 The_Include_Dir_Default_Prefix
:=
1660 String_Access
(Update_Path
(Include_Dir_Default_Name
));
1663 return The_Include_Dir_Default_Prefix
;
1664 end Include_Dir_Default_Prefix
;
1666 function Include_Dir_Default_Prefix
return String is
1668 return Include_Dir_Default_Prefix
.all;
1669 end Include_Dir_Default_Prefix
;
1675 procedure Initialize
is
1677 Number_File_Names
:= 0;
1678 Current_File_Name_Index
:= 0;
1680 Src_Search_Directories
.Init
;
1681 Lib_Search_Directories
.Init
;
1683 -- Start off by setting all suppress options, to False. The special
1684 -- overflow fields are set to Not_Set (they will be set by -gnatp, or
1685 -- by -gnato, or, if neither of these appear, in Adjust_Global_Switches
1688 Suppress_Options
:= ((others => False), Not_Set
, Not_Set
);
1690 -- Reserve the first slot in the search paths table. This is the
1691 -- directory of the main source file or main library file and is filled
1692 -- in by each call to Next_Main_Source/Next_Main_Lib_File with the
1693 -- directory specified for this main source or library file. This is the
1694 -- directory which is searched first by default. This default search is
1695 -- inhibited by the option -I- for both source and library files.
1697 Src_Search_Directories
.Set_Last
(Primary_Directory
);
1698 Src_Search_Directories
.Table
(Primary_Directory
) := new String'("");
1700 Lib_Search_Directories.Set_Last (Primary_Directory);
1701 Lib_Search_Directories.Table (Primary_Directory) := new String'("");
1708 function Is_Directory
1709 (Name
: C_File_Name
; Attr
: access File_Attributes
) return Boolean
1711 function Internal
(N
: C_File_Name
; A
: System
.Address
) return Integer;
1712 pragma Import
(C
, Internal
, "__gnat_is_directory_attr");
1714 return Internal
(Name
, Attr
.all'Address) /= 0;
1717 ----------------------------
1718 -- Is_Directory_Separator --
1719 ----------------------------
1721 function Is_Directory_Separator
(C
: Character) return Boolean is
1723 -- In addition to the default directory_separator allow the '/' to
1724 -- act as separator since this is allowed in MS-DOS and Windows.
1726 return C
= Directory_Separator
or else C
= '/';
1727 end Is_Directory_Separator
;
1729 -------------------------
1730 -- Is_Readonly_Library --
1731 -------------------------
1733 function Is_Readonly_Library
(File
: File_Name_Type
) return Boolean is
1735 Get_Name_String
(File
);
1737 pragma Assert
(Name_Buffer
(Name_Len
- 3 .. Name_Len
) = ".ali");
1739 return not Is_Writable_File
(Name_Buffer
(1 .. Name_Len
));
1740 end Is_Readonly_Library
;
1742 ------------------------
1743 -- Is_Executable_File --
1744 ------------------------
1746 function Is_Executable_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_executable_file_attr");
1752 return Internal
(Name
, Attr
.all'Address) /= 0;
1753 end Is_Executable_File
;
1755 ----------------------
1756 -- Is_Readable_File --
1757 ----------------------
1759 function Is_Readable_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_readable_file_attr");
1765 return Internal
(Name
, Attr
.all'Address) /= 0;
1766 end Is_Readable_File
;
1768 ---------------------
1769 -- Is_Regular_File --
1770 ---------------------
1772 function Is_Regular_File
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_regular_file_attr");
1778 return Internal
(Name
, Attr
.all'Address) /= 0;
1779 end Is_Regular_File
;
1781 ----------------------
1782 -- Is_Symbolic_Link --
1783 ----------------------
1785 function Is_Symbolic_Link
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_symbolic_link_attr");
1791 return Internal
(Name
, Attr
.all'Address) /= 0;
1792 end Is_Symbolic_Link
;
1794 ----------------------
1795 -- Is_Writable_File --
1796 ----------------------
1798 function Is_Writable_File
1799 (Name
: C_File_Name
; Attr
: access File_Attributes
) return Boolean
1801 function Internal
(N
: C_File_Name
; A
: System
.Address
) return Integer;
1802 pragma Import
(C
, Internal
, "__gnat_is_writable_file_attr");
1804 return Internal
(Name
, Attr
.all'Address) /= 0;
1805 end Is_Writable_File
;
1811 function Lib_File_Name
1812 (Source_File
: File_Name_Type
;
1813 Munit_Index
: Nat
:= 0) return File_Name_Type
1816 Get_Name_String
(Source_File
);
1818 for J
in reverse 2 .. Name_Len
loop
1819 if Name_Buffer
(J
) = '.' then
1825 if Munit_Index
/= 0 then
1826 Add_Char_To_Name_Buffer
(Multi_Unit_Index_Character
);
1827 Add_Nat_To_Name_Buffer
(Munit_Index
);
1830 Add_Char_To_Name_Buffer
('.');
1831 Add_Str_To_Name_Buffer
(ALI_Suffix
.all);
1839 procedure Locate_File
1840 (N
: File_Name_Type
;
1844 Found
: out File_Name_Type
;
1845 Attr
: access File_Attributes
)
1847 Dir_Name
: String_Ptr
;
1850 -- If Name is already an absolute path, do not look for a directory
1852 if Is_Absolute_Path
(Name
) then
1855 elsif T
= Library
then
1856 Dir_Name
:= Lib_Search_Directories
.Table
(Dir
);
1859 pragma Assert
(T
/= Config
);
1860 Dir_Name
:= Src_Search_Directories
.Table
(Dir
);
1864 Full_Name
: String (1 .. Dir_Name
'Length + Name
'Length + 1);
1867 Full_Name
(1 .. Dir_Name
'Length) := Dir_Name
.all;
1868 Full_Name
(Dir_Name
'Length + 1 .. Full_Name
'Last - 1) := Name
;
1869 Full_Name
(Full_Name
'Last) := ASCII
.NUL
;
1871 Attr
.all := Unknown_Attributes
;
1873 if not Is_Regular_File
(Full_Name
'Address, Attr
) then
1877 -- If the file is in the current directory then return N itself
1879 if Dir_Name
'Length = 0 then
1882 Name_Len
:= Full_Name
'Length - 1;
1883 Name_Buffer
(1 .. Name_Len
) :=
1884 Full_Name
(1 .. Full_Name
'Last - 1);
1885 Found
:= Name_Find
; -- ??? Was Name_Enter, no obvious reason
1891 -------------------------------
1892 -- Matching_Full_Source_Name --
1893 -------------------------------
1895 function Matching_Full_Source_Name
1896 (N
: File_Name_Type
;
1897 T
: Time_Stamp_Type
) return File_Name_Type
1900 Get_Name_String
(N
);
1903 File_Name
: constant String := Name_Buffer
(1 .. Name_Len
);
1904 File
: File_Name_Type
:= No_File
;
1905 Attr
: aliased File_Attributes
;
1909 if Opt
.Look_In_Primary_Dir
then
1911 (N
, Source
, Primary_Directory
, File_Name
, File
, Attr
'Access);
1913 if File
/= No_File
and then T
= File_Stamp
(N
) then
1918 Last_Dir
:= Src_Search_Directories
.Last
;
1920 for D
in Primary_Directory
+ 1 .. Last_Dir
loop
1921 Locate_File
(N
, Source
, D
, File_Name
, File
, Attr
'Access);
1923 if File
/= No_File
and then T
= File_Stamp
(File
) then
1930 end Matching_Full_Source_Name
;
1936 function More_Files
return Boolean is
1938 return (Current_File_Name_Index
< Number_File_Names
);
1941 -------------------------------
1942 -- Nb_Dir_In_Obj_Search_Path --
1943 -------------------------------
1945 function Nb_Dir_In_Obj_Search_Path
return Natural is
1947 if Opt
.Look_In_Primary_Dir
then
1948 return Lib_Search_Directories
.Last
- Primary_Directory
+ 1;
1950 return Lib_Search_Directories
.Last
- Primary_Directory
;
1952 end Nb_Dir_In_Obj_Search_Path
;
1954 -------------------------------
1955 -- Nb_Dir_In_Src_Search_Path --
1956 -------------------------------
1958 function Nb_Dir_In_Src_Search_Path
return Natural is
1960 if Opt
.Look_In_Primary_Dir
then
1961 return Src_Search_Directories
.Last
- Primary_Directory
+ 1;
1963 return Src_Search_Directories
.Last
- Primary_Directory
;
1965 end Nb_Dir_In_Src_Search_Path
;
1967 --------------------
1968 -- Next_Main_File --
1969 --------------------
1971 function Next_Main_File
return File_Name_Type
is
1972 File_Name
: String_Ptr
;
1973 Dir_Name
: String_Ptr
;
1977 pragma Assert
(More_Files
);
1979 Current_File_Name_Index
:= Current_File_Name_Index
+ 1;
1981 -- Get the file and directory name
1983 File_Name
:= File_Names
(Current_File_Name_Index
);
1984 Fptr
:= File_Name
'First;
1986 for J
in reverse File_Name
'Range loop
1987 if Is_Directory_Separator
(File_Name
(J
)) then
1988 if J
= File_Name
'Last then
1989 Fail
("File name missing");
1997 -- Save name of directory in which main unit resides for use in
1998 -- locating other units
2000 Dir_Name
:= new String'(File_Name (File_Name'First .. Fptr - 1));
2002 case Running_Program is
2004 Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
2005 Look_In_Primary_Directory_For_Current_Main := True;
2008 Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
2010 if Fptr > File_Name'First then
2011 Look_In_Primary_Directory_For_Current_Main := True;
2017 Dir_Name := Normalize_Directory_Name (Dir_Name.all);
2018 Lib_Search_Directories.Table (Primary_Directory) := Dir_Name;
2024 Name_Len := File_Name'Last - Fptr + 1;
2025 Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last);
2026 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
2027 Current_Main := Name_Find;
2029 -- In the gnatmake case, the main file may have not have the
2030 -- extension. Try ".adb" first then ".ads"
2032 if Running_Program = Make then
2034 Orig_Main : constant File_Name_Type := Current_Main;
2037 if Strip_Suffix (Orig_Main) = Orig_Main then
2039 Append_Suffix_To_File_Name (Orig_Main, ".adb");
2041 if Full_Source_Name (Current_Main) = No_File then
2043 Append_Suffix_To_File_Name (Orig_Main, ".ads");
2045 if Full_Source_Name (Current_Main) = No_File then
2046 Current_Main := Orig_Main;
2053 return Current_Main;
2056 ------------------------------
2057 -- Normalize_Directory_Name --
2058 ------------------------------
2060 function Normalize_Directory_Name (Directory : String) return String_Ptr is
2062 function Is_Quoted (Path : String) return Boolean;
2063 pragma Inline (Is_Quoted);
2064 -- Returns true if Path is quoted (either double or single quotes)
2070 function Is_Quoted (Path : String) return Boolean is
2071 First : constant Character := Path (Path'First);
2072 Last : constant Character := Path (Path'Last);
2075 if (First = ''' and then Last = ''')
2077 (First = '"' and then Last = '"')
2085 Result : String_Ptr;
2087 -- Start of processing for Normalize_Directory_Name
2090 if Directory'Length = 0 then
2091 Result := new String'(Hostparm
.Normalized_CWD
);
2093 elsif Is_Directory_Separator
(Directory
(Directory
'Last)) then
2094 Result
:= new String'(Directory);
2096 elsif Is_Quoted (Directory) then
2098 -- This is a quoted string, it certainly means that the directory
2099 -- contains some spaces for example. We can safely remove the quotes
2100 -- here as the OS_Lib.Normalize_Arguments will be called before any
2101 -- spawn routines. This ensure that quotes will be added when needed.
2103 Result := new String (1 .. Directory'Length - 1);
2104 Result (1 .. Directory'Length - 2) :=
2105 Directory (Directory'First + 1 .. Directory'Last - 1);
2106 Result (Result'Last) := Directory_Separator;
2109 Result := new String (1 .. Directory'Length + 1);
2110 Result (1 .. Directory'Length) := Directory;
2111 Result (Directory'Length + 1) := Directory_Separator;
2115 end Normalize_Directory_Name;
2117 ---------------------
2118 -- Number_Of_Files --
2119 ---------------------
2121 function Number_Of_Files return Nat is
2123 return Number_File_Names;
2124 end Number_Of_Files;
2126 -------------------------------
2127 -- Object_Dir_Default_Prefix --
2128 -------------------------------
2130 function Object_Dir_Default_Prefix return String is
2131 Object_Dir : String_Access :=
2132 String_Access (Update_Path (Object_Dir_Default_Name));
2135 if Object_Dir = null then
2140 Result : constant String := Object_Dir.all;
2146 end Object_Dir_Default_Prefix;
2148 ----------------------
2149 -- Object_File_Name --
2150 ----------------------
2152 function Object_File_Name (N : File_Name_Type) return File_Name_Type is
2158 Get_Name_String (N);
2159 Name_Len := Name_Len - ALI_Suffix'Length - 1;
2161 for J in Target_Object_Suffix'Range loop
2162 Name_Len := Name_Len + 1;
2163 Name_Buffer (Name_Len) := Target_Object_Suffix (J);
2167 end Object_File_Name;
2169 -------------------------------
2170 -- OS_Exit_Through_Exception --
2171 -------------------------------
2173 procedure OS_Exit_Through_Exception (Status : Integer) is
2175 Current_Exit_Status := Status;
2176 raise Types.Terminate_Program;
2177 end OS_Exit_Through_Exception;
2179 --------------------------
2180 -- OS_Time_To_GNAT_Time --
2181 --------------------------
2183 function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type is
2184 GNAT_Time : Time_Stamp_Type;
2186 type Underlying_OS_Time is
2187 range -(2 ** (Standard'Address_Size - Integer'(1))) ..
2188 +(2 ** (Standard
'Address_Size - Integer'(1)) - 1);
2189 -- Underlying_OS_Time is a redeclaration of OS_Time to allow integer
2190 -- manipulation. Remove this in favor of To_Ada/To_C once newer
2191 -- GNAT releases are available with these functions.
2194 new Unchecked_Conversion (OS_Time, Underlying_OS_Time);
2195 function From_Int is
2196 new Unchecked_Conversion (Underlying_OS_Time, OS_Time);
2198 TI : Underlying_OS_Time := To_Int (T);
2207 if T = Invalid_Time then
2208 return Empty_Time_Stamp;
2211 if On_Windows and then TI mod 2 > 0 then
2212 -- Windows ALI files had timestamps rounded to even seconds
2213 -- historically. The rounding was originally done in GM_Split.
2214 -- Now that GM_Split no longer does it, we are rounding it here
2215 -- only for ALI files.
2220 GM_Split (From_Int (TI), Y, Mo, D, H, Mn, S);
2227 Minutes => Nat (Mn),
2232 end OS_Time_To_GNAT_Time;
2238 function Prep_Suffix return String is
2247 function Program_Name (Nam : String; Prog : String) return String_Access is
2248 End_Of_Prefix : Natural := 0;
2249 Start_Of_Prefix : Positive := 1;
2250 Start_Of_Suffix : Positive;
2253 -- Get the name of the current program being executed
2257 Start_Of_Suffix := Name_Len + 1;
2259 -- Find the target prefix if any, for the cross compilation case.
2260 -- For instance in "powerpc-elf-gcc" the target prefix is
2262 -- Ditto for suffix, e.g. in "gcc-4.1", the suffix is "-4.1"
2264 for J in reverse 1 .. Name_Len loop
2265 if Is_Directory_Separator (Name_Buffer (J))
2266 or else Name_Buffer (J) = ':'
2268 Start_Of_Prefix := J + 1;
2273 -- Find End_Of_Prefix
2275 for J in Start_Of_Prefix .. Name_Len - Prog'Length + 1 loop
2276 if Name_Buffer (J .. J + Prog'Length - 1) = Prog then
2277 End_Of_Prefix := J - 1;
2282 if End_Of_Prefix > 1 then
2283 Start_Of_Suffix := End_Of_Prefix + Prog'Length + 1;
2286 -- Create the new program name
2289 (Name_Buffer
(Start_Of_Prefix
.. End_Of_Prefix
)
2291 & Name_Buffer
(Start_Of_Suffix
.. Name_Len
));
2294 ------------------------------
2295 -- Read_Default_Search_Dirs --
2296 ------------------------------
2298 function Read_Default_Search_Dirs
2299 (Search_Dir_Prefix
: String_Access
;
2300 Search_File
: String_Access
;
2301 Search_Dir_Default_Name
: String_Access
) return String_Access
2303 Prefix_Len
: constant Integer := Search_Dir_Prefix
.all'Length;
2304 Buffer
: String (1 .. Prefix_Len
+ Search_File
.all'Length + 1);
2305 File_FD
: File_Descriptor
;
2306 S
, S1
: String_Access
;
2309 Actual_Len
: Integer;
2312 Prev_Was_Separator
: Boolean;
2313 Nb_Relative_Dir
: Integer;
2315 function Is_Relative
(S
: String; K
: Positive) return Boolean;
2316 pragma Inline
(Is_Relative
);
2317 -- Returns True if a relative directory specification is found
2318 -- in S at position K, False otherwise.
2324 function Is_Relative
(S
: String; K
: Positive) return Boolean is
2326 return not Is_Absolute_Path
(S
(K
.. S
'Last));
2329 -- Start of processing for Read_Default_Search_Dirs
2332 -- Construct a C compatible character string buffer
2334 Buffer
(1 .. Search_Dir_Prefix
.all'Length)
2335 := Search_Dir_Prefix
.all;
2336 Buffer
(Search_Dir_Prefix
.all'Length + 1 .. Buffer
'Last - 1)
2338 Buffer
(Buffer
'Last) := ASCII
.NUL
;
2340 File_FD
:= Open_Read
(Buffer
'Address, Binary
);
2341 if File_FD
= Invalid_FD
then
2342 return Search_Dir_Default_Name
;
2345 Len
:= Integer (File_Length
(File_FD
));
2347 -- An extra character for a trailing Path_Separator is allocated
2349 S
:= new String (1 .. Len
+ 1);
2350 S
(Len
+ 1) := Path_Separator
;
2352 -- Read the file. Note that the loop is probably not necessary since the
2353 -- whole file is read at once but the loop is harmless and that way we
2354 -- are sure to accommodate systems where this is not the case.
2358 while Actual_Len
/= 0 loop
2359 Actual_Len
:= Read
(File_FD
, S
(Curr
)'Address, Len
);
2360 Curr
:= Curr
+ Actual_Len
;
2363 -- Process the file, dealing with path separators
2365 Prev_Was_Separator
:= True;
2366 Nb_Relative_Dir
:= 0;
2367 for J
in 1 .. Len
loop
2369 -- Treat any control character as a path separator. Note that we do
2370 -- not treat space as a path separator (we used to treat space as a
2371 -- path separator in an earlier version). That way space can appear
2372 -- as a legitimate character in a path name.
2374 -- Why do we treat all control characters as path separators???
2376 if S
(J
) in ASCII
.NUL
.. ASCII
.US
then
2377 S
(J
) := Path_Separator
;
2380 -- Test for explicit path separator (or control char as above)
2382 if S
(J
) = Path_Separator
then
2383 Prev_Was_Separator
:= True;
2385 -- If not path separator, register use of relative directory
2388 if Prev_Was_Separator
and then Is_Relative
(S
.all, J
) then
2389 Nb_Relative_Dir
:= Nb_Relative_Dir
+ 1;
2392 Prev_Was_Separator
:= False;
2396 if Nb_Relative_Dir
= 0 then
2400 -- Add the Search_Dir_Prefix to all relative paths
2402 S1
:= new String (1 .. S
'Length + Nb_Relative_Dir
* Prefix_Len
);
2404 Prev_Was_Separator
:= True;
2405 for J
in 1 .. Len
+ 1 loop
2406 if S
(J
) = Path_Separator
then
2407 Prev_Was_Separator
:= True;
2410 if Prev_Was_Separator
and then Is_Relative
(S
.all, J
) then
2411 S1
(J1
.. J1
+ Prefix_Len
- 1) := Search_Dir_Prefix
.all;
2412 J1
:= J1
+ Prefix_Len
;
2415 Prev_Was_Separator
:= False;
2423 end Read_Default_Search_Dirs
;
2425 -----------------------
2426 -- Read_Library_Info --
2427 -----------------------
2429 function Read_Library_Info
2430 (Lib_File
: File_Name_Type
;
2431 Fatal_Err
: Boolean := False) return Text_Buffer_Ptr
2433 File
: File_Name_Type
;
2434 Attr
: aliased File_Attributes
;
2436 Find_File
(Lib_File
, Library
, File
, Attr
'Access);
2437 return Read_Library_Info_From_Full
2438 (Full_Lib_File
=> File
,
2439 Lib_File_Attr
=> Attr
'Access,
2440 Fatal_Err
=> Fatal_Err
);
2441 end Read_Library_Info
;
2443 ---------------------------------
2444 -- Read_Library_Info_From_Full --
2445 ---------------------------------
2447 function Read_Library_Info_From_Full
2448 (Full_Lib_File
: File_Name_Type
;
2449 Lib_File_Attr
: access File_Attributes
;
2450 Fatal_Err
: Boolean := False) return Text_Buffer_Ptr
2452 Lib_FD
: File_Descriptor
;
2453 -- The file descriptor for the current library file. A negative value
2454 -- indicates failure to open the specified source file.
2457 -- Length of source file text (ALI). If it doesn't fit in an integer
2458 -- we're probably stuck anyway (>2 gigs of source seems a lot, and
2459 -- there are other places in the compiler that make this assumption).
2461 Text
: Text_Buffer_Ptr
;
2462 -- Allocated text buffer
2465 pragma Warnings
(Off
, Status
);
2466 -- For the calls to Close
2469 Current_Full_Lib_Name
:= Full_Lib_File
;
2470 Current_Full_Obj_Name
:= Object_File_Name
(Current_Full_Lib_Name
);
2472 if Current_Full_Lib_Name
= No_File
then
2474 Fail
("Cannot find: " & Name_Buffer
(1 .. Name_Len
));
2476 Current_Full_Obj_Stamp
:= Empty_Time_Stamp
;
2481 Get_Name_String
(Current_Full_Lib_Name
);
2482 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
2484 -- Open the library FD, note that we open in binary mode, because as
2485 -- documented in the spec, the caller is expected to handle either
2486 -- DOS or Unix mode files, and there is no point in wasting time on
2487 -- text translation when it is not required.
2489 Lib_FD
:= Open_Read
(Name_Buffer
'Address, Binary
);
2491 if Lib_FD
= Invalid_FD
then
2493 Fail
("Cannot open: " & Name_Buffer
(1 .. Name_Len
));
2495 Current_Full_Obj_Stamp
:= Empty_Time_Stamp
;
2500 -- Compute the length of the file (potentially also preparing other data
2501 -- like the timestamp and whether the file is read-only, for future use)
2503 Len
:= Integer (File_Length
(Name_Buffer
'Address, Lib_File_Attr
));
2505 -- Check for object file consistency if requested
2507 if Opt
.Check_Object_Consistency
then
2508 -- On most systems, this does not result in an extra system call
2510 Current_Full_Lib_Stamp
:=
2511 OS_Time_To_GNAT_Time
2512 (File_Time_Stamp
(Name_Buffer
'Address, Lib_File_Attr
));
2514 -- ??? One system call here
2516 Current_Full_Obj_Stamp
:= File_Stamp
(Current_Full_Obj_Name
);
2518 if Current_Full_Obj_Stamp
(1) = ' ' then
2520 -- When the library is readonly always assume object is consistent
2521 -- The call to Is_Writable_File only results in a system call on
2522 -- some systems, but in most cases it has already been computed as
2523 -- part of the call to File_Length above.
2525 Get_Name_String
(Current_Full_Lib_Name
);
2526 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
2528 if not Is_Writable_File
(Name_Buffer
'Address, Lib_File_Attr
) then
2529 Current_Full_Obj_Stamp
:= Current_Full_Lib_Stamp
;
2531 elsif Fatal_Err
then
2532 Get_Name_String
(Current_Full_Obj_Name
);
2533 Close
(Lib_FD
, Status
);
2535 -- No need to check the status, we fail anyway
2537 Fail
("Cannot find: " & Name_Buffer
(1 .. Name_Len
));
2540 Current_Full_Obj_Stamp
:= Empty_Time_Stamp
;
2541 Close
(Lib_FD
, Status
);
2543 -- No need to check the status, we return null anyway
2548 elsif Current_Full_Obj_Stamp
< Current_Full_Lib_Stamp
then
2549 Close
(Lib_FD
, Status
);
2551 -- No need to check the status, we return null anyway
2557 -- Read data from the file
2560 Actual_Len
: Integer := 0;
2562 Lo
: constant Text_Ptr
:= 0;
2563 -- Low bound for allocated text buffer
2565 Hi
: Text_Ptr
:= Text_Ptr
(Len
);
2566 -- High bound for allocated text buffer. Note length is Len + 1
2567 -- which allows for extra EOF character at the end of the buffer.
2570 -- Allocate text buffer. Note extra character at end for EOF
2572 Text
:= new Text_Buffer
(Lo
.. Hi
);
2574 -- Some systems have file types that require one read per line,
2575 -- so read until we get the Len bytes or until there are no more
2580 Actual_Len
:= Read
(Lib_FD
, Text
(Hi
)'Address, Len
);
2581 Hi
:= Hi
+ Text_Ptr
(Actual_Len
);
2582 exit when Actual_Len
= Len
or else Actual_Len
<= 0;
2588 -- Read is complete, close file and we are done
2590 Close
(Lib_FD
, Status
);
2591 -- The status should never be False. But, if it is, what can we do?
2592 -- So, we don't test it.
2596 end Read_Library_Info_From_Full
;
2598 ----------------------
2599 -- Read_Source_File --
2600 ----------------------
2602 procedure Read_Source_File
2603 (N
: File_Name_Type
;
2605 Hi
: out Source_Ptr
;
2606 Src
: out Source_Buffer_Ptr
;
2607 FD
: out File_Descriptor
;
2608 T
: File_Type
:= Source
)
2611 -- Length of file, assume no more than 2 gigabytes of source
2613 Actual_Len
: Integer;
2616 pragma Warnings
(Off
, Status
);
2617 -- For the call to Close
2620 Current_Full_Source_Name
:= Find_File
(N
, T
, Full_Name
=> True);
2621 Current_Full_Source_Stamp
:= File_Stamp
(Current_Full_Source_Name
);
2623 if Current_Full_Source_Name
= No_File
then
2625 -- If we were trying to access the main file and we could not find
2626 -- it, we have an error.
2628 if N
= Current_Main
then
2629 Get_Name_String
(N
);
2630 Fail
("Cannot find: " & Name_Buffer
(1 .. Name_Len
));
2639 Get_Name_String
(Current_Full_Source_Name
);
2640 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
2642 -- Open the source FD, note that we open in binary mode, because as
2643 -- documented in the spec, the caller is expected to handle either
2644 -- DOS or Unix mode files, and there is no point in wasting time on
2645 -- text translation when it is not required.
2647 FD
:= Open_Read
(Name_Buffer
'Address, Binary
);
2649 if FD
= Invalid_FD
then
2655 -- If it's a Source file, print out the file name, if requested, and if
2656 -- it's not part of the runtimes, store it in File_Name_Chars. We don't
2657 -- want to print non-Source files, like GNAT-TEMP-000001.TMP used to
2658 -- pass information from gprbuild to gcc. We don't want to save runtime
2659 -- file names, because we don't want users to send them in bug reports.
2663 Name
: String renames Name_Buffer
(1 .. Name_Len
);
2664 Inc
: String renames Include_Dir_Default_Prefix
.all;
2666 Part_Of_Runtimes
: constant Boolean :=
2668 and then Inc
'Length < Name_Len
2669 and then Name_Buffer
(1 .. Inc
'Length) = Inc
;
2672 if Debug
.Debug_Flag_Dot_N
then
2676 if not Part_Of_Runtimes
then
2677 File_Name_Chars
.Append_All
(File_Name_Chars
.Table_Type
(Name
));
2678 File_Name_Chars
.Append
(ASCII
.LF
);
2683 -- Prepare to read data from the file
2685 Len
:= Integer (File_Length
(FD
));
2687 -- Set Hi so that length is one more than the physical length,
2688 -- allowing for the extra EOF character at the end of the buffer
2690 Hi
:= Lo
+ Source_Ptr
(Len
);
2692 -- Do the actual read operation
2695 Var_Ptr
: constant Source_Buffer_Ptr_Var
:=
2696 new Source_Buffer
(Lo
.. Hi
);
2697 -- Allocate source buffer, allowing extra character at end for EOF
2699 -- Some systems have file types that require one read per line,
2700 -- so read until we get the Len bytes or until there are no more
2705 Actual_Len
:= Read
(FD
, Var_Ptr
(Hi
)'Address, Len
);
2706 Hi
:= Hi
+ Source_Ptr
(Actual_Len
);
2707 exit when Actual_Len
= Len
or else Actual_Len
<= 0;
2710 Var_Ptr
(Hi
) := EOF
;
2711 Src
:= Var_Ptr
.all'Access;
2714 -- Read is complete, get time stamp and close file and we are done
2718 -- The status should never be False. But, if it is, what can we do?
2719 -- So, we don't test it.
2721 -- ???We don't really need to return Hi anymore; We could get rid of
2722 -- it. We could also make this into a function.
2724 pragma Assert
(Hi
= Src
'Last);
2725 end Read_Source_File
;
2731 function Relocate_Path
2733 Path
: String) return String_Ptr
2737 procedure set_std_prefix
(S
: String; Len
: Integer);
2738 pragma Import
(C
, set_std_prefix
);
2741 if Std_Prefix
= null then
2742 Std_Prefix
:= Executable_Prefix
;
2744 if Std_Prefix
.all /= "" then
2746 -- Remove trailing directory separator when calling set_std_prefix
2748 set_std_prefix
(Std_Prefix
.all, Std_Prefix
'Length - 1);
2752 if Path
'Last >= Prefix
'Last and then Path
(Prefix
'Range) = Prefix
then
2753 if Std_Prefix
.all /= "" then
2755 (1 .. Std_Prefix
'Length + Path
'Last - Prefix
'Last);
2756 S
(1 .. Std_Prefix
'Length) := Std_Prefix
.all;
2757 S
(Std_Prefix
'Length + 1 .. S
'Last) :=
2758 Path
(Prefix
'Last + 1 .. Path
'Last);
2763 return new String'(Path);
2770 procedure Set_Program (P : Program_Type) is
2773 Fail ("Set_Program called twice");
2776 Program_Set := True;
2777 Running_Program := P;
2784 function Shared_Lib (Name : String) return String is
2785 Library : String (1 .. Name'Length + Library_Version'Length + 3);
2786 -- 3 = 2 for "-l" + 1 for "-" before lib version
2789 Library (1 .. 2) := "-l";
2790 Library (3 .. 2 + Name'Length) := Name;
2791 Library (3 + Name'Length) := '-';
2792 Library (4 + Name'Length .. Library'Last) := Library_Version;
2796 ----------------------
2797 -- Smart_File_Stamp --
2798 ----------------------
2800 function Smart_File_Stamp
2801 (N : File_Name_Type;
2802 T : File_Type) return Time_Stamp_Type
2804 File : File_Name_Type;
2805 Attr : aliased File_Attributes;
2808 if not File_Cache_Enabled then
2809 Find_File (N, T, File, Attr'Access);
2811 Smart_Find_File (N, T, File, Attr);
2814 if File = No_File then
2815 return Empty_Time_Stamp;
2817 Get_Name_String (File);
2818 Name_Buffer (Name_Len + 1) := ASCII.NUL;
2820 OS_Time_To_GNAT_Time
2821 (File_Time_Stamp (Name_Buffer'Address, Attr'Access));
2823 end Smart_File_Stamp;
2825 ---------------------
2826 -- Smart_Find_File --
2827 ---------------------
2829 function Smart_Find_File
2830 (N : File_Name_Type;
2831 T : File_Type) return File_Name_Type
2833 File : File_Name_Type;
2834 Attr : File_Attributes;
2836 Smart_Find_File (N, T, File, Attr);
2838 end Smart_Find_File;
2840 ---------------------
2841 -- Smart_Find_File --
2842 ---------------------
2844 procedure Smart_Find_File
2845 (N : File_Name_Type;
2847 Found : out File_Name_Type;
2848 Attr : out File_Attributes)
2850 Info : File_Info_Cache;
2853 if not File_Cache_Enabled then
2854 Find_File (N, T, Info.File, Info.Attr'Access);
2857 Info := File_Name_Hash_Table.Get (N);
2859 if Info.File = No_File then
2860 Find_File (N, T, Info.File, Info.Attr'Access);
2861 File_Name_Hash_Table.Set (N, Info);
2867 end Smart_Find_File;
2869 ----------------------
2870 -- Source_File_Data --
2871 ----------------------
2873 procedure Source_File_Data (Cache : Boolean) is
2875 File_Cache_Enabled := Cache;
2876 end Source_File_Data;
2878 -----------------------
2879 -- Source_File_Stamp --
2880 -----------------------
2882 function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is
2884 return Smart_File_Stamp (N, Source);
2885 end Source_File_Stamp;
2887 ---------------------
2888 -- Strip_Directory --
2889 ---------------------
2891 function Strip_Directory (Name : File_Name_Type) return File_Name_Type is
2893 Get_Name_String (Name);
2895 for J in reverse 1 .. Name_Len - 1 loop
2897 -- If we find the last directory separator
2899 if Is_Directory_Separator (Name_Buffer (J)) then
2901 -- Return part of Name that follows this last directory separator
2903 Name_Buffer (1 .. Name_Len - J) := Name_Buffer (J + 1 .. Name_Len);
2904 Name_Len := Name_Len - J;
2909 -- There were no directory separator, just return Name
2912 end Strip_Directory;
2918 function Strip_Suffix (Name : File_Name_Type) return File_Name_Type is
2920 Get_Name_String (Name);
2922 for J in reverse 2 .. Name_Len loop
2924 -- If we found the last '.', return part of Name that precedes it
2926 if Name_Buffer (J) = '.' then
2935 ---------------------------
2936 -- To_Canonical_File_List --
2937 ---------------------------
2939 function To_Canonical_File_List
2940 (Wildcard_Host_File : String;
2941 Only_Dirs : Boolean) return String_Access_List_Access
2943 function To_Canonical_File_List_Init
2944 (Host_File : Address;
2945 Only_Dirs : Integer) return Integer;
2946 pragma Import (C, To_Canonical_File_List_Init,
2947 "__gnat_to_canonical_file_list_init");
2949 function To_Canonical_File_List_Next return Address;
2950 pragma Import (C, To_Canonical_File_List_Next,
2951 "__gnat_to_canonical_file_list_next");
2953 procedure To_Canonical_File_List_Free;
2954 pragma Import (C, To_Canonical_File_List_Free,
2955 "__gnat_to_canonical_file_list_free");
2957 Num_Files : Integer;
2958 C_Wildcard_Host_File : String (1 .. Wildcard_Host_File'Length + 1);
2961 C_Wildcard_Host_File (1 .. Wildcard_Host_File'Length) :=
2963 C_Wildcard_Host_File (C_Wildcard_Host_File'Last) := ASCII.NUL;
2965 -- Do the expansion and say how many there are
2967 Num_Files := To_Canonical_File_List_Init
2968 (C_Wildcard_Host_File'Address, Boolean'Pos (Only_Dirs));
2971 Canonical_File_List : String_Access_List (1 .. Num_Files);
2972 Canonical_File_Addr : Address;
2973 Canonical_File_Len : CRTL.size_t;
2976 -- Retrieve the expanded directory names and build the list
2978 for J in 1 .. Num_Files loop
2979 Canonical_File_Addr := To_Canonical_File_List_Next;
2980 Canonical_File_Len := C_String_Length (Canonical_File_Addr);
2981 Canonical_File_List (J) := To_Path_String_Access
2982 (Canonical_File_Addr, Canonical_File_Len);
2985 -- Free up the storage
2987 To_Canonical_File_List_Free;
2989 return new String_Access_List'(Canonical_File_List
);
2991 end To_Canonical_File_List
;
2993 ----------------------
2994 -- To_Host_Dir_Spec --
2995 ----------------------
2997 function To_Host_Dir_Spec
2998 (Canonical_Dir
: String;
2999 Prefix_Style
: Boolean) return String_Access
3001 function To_Host_Dir_Spec
3002 (Canonical_Dir
: Address
;
3003 Prefix_Flag
: Integer) return Address
;
3004 pragma Import
(C
, To_Host_Dir_Spec
, "__gnat_to_host_dir_spec");
3006 C_Canonical_Dir
: String (1 .. Canonical_Dir
'Length + 1);
3007 Host_Dir_Addr
: Address
;
3008 Host_Dir_Len
: CRTL
.size_t
;
3011 C_Canonical_Dir
(1 .. Canonical_Dir
'Length) := Canonical_Dir
;
3012 C_Canonical_Dir
(C_Canonical_Dir
'Last) := ASCII
.NUL
;
3014 if Prefix_Style
then
3015 Host_Dir_Addr
:= To_Host_Dir_Spec
(C_Canonical_Dir
'Address, 1);
3017 Host_Dir_Addr
:= To_Host_Dir_Spec
(C_Canonical_Dir
'Address, 0);
3019 Host_Dir_Len
:= C_String_Length
(Host_Dir_Addr
);
3021 if Host_Dir_Len
= 0 then
3024 return To_Path_String_Access
(Host_Dir_Addr
, Host_Dir_Len
);
3026 end To_Host_Dir_Spec
;
3028 -----------------------
3029 -- To_Host_File_Spec --
3030 -----------------------
3032 function To_Host_File_Spec
3033 (Canonical_File
: String) return String_Access
3035 function To_Host_File_Spec
(Canonical_File
: Address
) return Address
;
3036 pragma Import
(C
, To_Host_File_Spec
, "__gnat_to_host_file_spec");
3038 C_Canonical_File
: String (1 .. Canonical_File
'Length + 1);
3039 Host_File_Addr
: Address
;
3040 Host_File_Len
: CRTL
.size_t
;
3043 C_Canonical_File
(1 .. Canonical_File
'Length) := Canonical_File
;
3044 C_Canonical_File
(C_Canonical_File
'Last) := ASCII
.NUL
;
3046 Host_File_Addr
:= To_Host_File_Spec
(C_Canonical_File
'Address);
3047 Host_File_Len
:= C_String_Length
(Host_File_Addr
);
3049 if Host_File_Len
= 0 then
3052 return To_Path_String_Access
3053 (Host_File_Addr
, Host_File_Len
);
3055 end To_Host_File_Spec
;
3057 ---------------------------
3058 -- To_Path_String_Access --
3059 ---------------------------
3061 function To_Path_String_Access
3062 (Path_Addr
: Address
;
3063 Path_Len
: CRTL
.size_t
) return String_Access
3065 subtype Path_String
is String (1 .. Integer (Path_Len
));
3066 type Path_String_Access
is access Path_String
;
3068 function Address_To_Access
is new
3069 Unchecked_Conversion
(Source
=> Address
,
3070 Target
=> Path_String_Access
);
3072 Path_Access
: constant Path_String_Access
:=
3073 Address_To_Access
(Path_Addr
);
3075 Return_Val
: String_Access
;
3078 Return_Val
:= new String (1 .. Integer (Path_Len
));
3080 for J
in 1 .. Integer (Path_Len
) loop
3081 Return_Val
(J
) := Path_Access
(J
);
3085 end To_Path_String_Access
;
3091 function Update_Path
(Path
: String_Ptr
) return String_Ptr
is
3093 function C_Update_Path
(Path
, Component
: Address
) return Address
;
3094 pragma Import
(C
, C_Update_Path
, "update_path");
3096 In_Length
: constant Integer := Path
'Length;
3097 In_String
: String (1 .. In_Length
+ 1);
3098 Component_Name
: aliased String := "GCC" & ASCII
.NUL
;
3099 Result_Ptr
: Address
;
3100 Result_Length
: CRTL
.size_t
;
3101 Out_String
: String_Ptr
;
3104 In_String
(1 .. In_Length
) := Path
.all;
3105 In_String
(In_Length
+ 1) := ASCII
.NUL
;
3106 Result_Ptr
:= C_Update_Path
(In_String
'Address, Component_Name
'Address);
3107 Result_Length
:= CRTL
.strlen
(Result_Ptr
);
3109 Out_String
:= new String (1 .. Integer (Result_Length
));
3110 CRTL
.strncpy
(Out_String
.all'Address, Result_Ptr
, Result_Length
);
3118 procedure Write_Info
(Info
: String) is
3120 Write_With_Check
(Info
'Address, Info
'Length);
3121 Write_With_Check
(EOL
'Address, 1);
3124 ------------------------
3125 -- Write_Program_Name --
3126 ------------------------
3128 procedure Write_Program_Name
is
3129 Save_Buffer
: constant String (1 .. Name_Len
) :=
3130 Name_Buffer
(1 .. Name_Len
);
3135 -- Convert the name to lower case so error messages are the same on
3138 for J
in 1 .. Name_Len
loop
3139 if Name_Buffer
(J
) in 'A' .. 'Z' then
3141 Character'Val (Character'Pos (Name_Buffer
(J
)) + 32);
3145 Write_Str
(Name_Buffer
(1 .. Name_Len
));
3147 -- Restore Name_Buffer which was clobbered by the call to
3148 -- Find_Program_Name
3150 Name_Len
:= Save_Buffer
'Last;
3151 Name_Buffer
(1 .. Name_Len
) := Save_Buffer
;
3152 end Write_Program_Name
;
3154 ----------------------
3155 -- Write_With_Check --
3156 ----------------------
3158 procedure Write_With_Check
(A
: Address
; N
: Integer) is
3161 if N
= Write
(Output_FD
, A
, N
) then
3164 Write_Str
("error: disk full writing ");
3165 Write_Name_Decoded
(Output_File_Name
);
3167 Name_Len
:= Name_Len
+ 1;
3168 Name_Buffer
(Name_Len
) := ASCII
.NUL
;
3169 Delete_File
(Name_Buffer
'Address, Ignore
);
3170 Exit_Program
(E_Fatal
);
3172 end Write_With_Check
;
3174 ----------------------------
3175 -- Package Initialization --
3176 ----------------------------
3178 procedure Reset_File_Attributes
(Attr
: System
.Address
);
3179 pragma Import
(C
, Reset_File_Attributes
, "__gnat_reset_attributes");
3182 Initialization
: declare
3184 function Get_Default_Identifier_Character_Set
return Character;
3185 pragma Import
(C
, Get_Default_Identifier_Character_Set
,
3186 "__gnat_get_default_identifier_character_set");
3187 -- Function to determine the default identifier character set,
3188 -- which is system dependent. See Opt package spec for a list of
3189 -- the possible character codes and their interpretations.
3191 function Get_Maximum_File_Name_Length
return Int
;
3192 pragma Import
(C
, Get_Maximum_File_Name_Length
,
3193 "__gnat_get_maximum_file_name_length");
3194 -- Function to get maximum file name length for system
3196 Sizeof_File_Attributes
: Integer;
3197 pragma Import
(C
, Sizeof_File_Attributes
,
3198 "__gnat_size_of_file_attributes");
3201 pragma Assert
(Sizeof_File_Attributes
<= File_Attributes_Size
);
3203 Reset_File_Attributes
(Unknown_Attributes
'Address);
3205 Identifier_Character_Set
:= Get_Default_Identifier_Character_Set
;
3206 Maximum_File_Name_Length
:= Get_Maximum_File_Name_Length
;
3208 -- Following should be removed by having above function return
3209 -- Integer'Last as indication of no maximum instead of -1 ???
3211 if Maximum_File_Name_Length
= -1 then
3212 Maximum_File_Name_Length
:= Int
'Last;
3215 Src_Search_Directories
.Set_Last
(Primary_Directory
);
3216 Src_Search_Directories
.Table
(Primary_Directory
) := new String'("");
3218 Lib_Search_Directories.Set_Last (Primary_Directory);
3219 Lib_Search_Directories.Table (Primary_Directory) := new String'("");