1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Unchecked_Conversion
;
28 with System
.Case_Util
; use System
.Case_Util
;
35 with Gnatvsn
; use Gnatvsn
;
38 with Output
; use Output
;
39 with Sdefault
; use Sdefault
;
41 with Targparm
; use Targparm
;
45 Running_Program
: Program_Type
:= Unspecified
;
46 -- comment required here ???
48 Program_Set
: Boolean := False;
49 -- comment required here ???
51 Std_Prefix
: String_Ptr
;
52 -- Standard prefix, computed dynamically the first time Relocate_Path
53 -- is called, and cached for subsequent calls.
55 Empty
: aliased String := "";
56 No_Dir
: constant String_Ptr
:= Empty
'Access;
57 -- Used in Locate_File as a fake directory when Name is already an
60 -------------------------------------
61 -- Use of Name_Find and Name_Enter --
62 -------------------------------------
64 -- This package creates a number of source, ALI and object file names
65 -- that are used to locate the actual file and for the purpose of message
66 -- construction. These names need not be accessible by Name_Find, and can
67 -- be therefore created by using routine Name_Enter. The files in question
68 -- are file names with a prefix directory (i.e., the files not in the
69 -- current directory). File names without a prefix directory are entered
70 -- with Name_Find because special values might be attached to the various
71 -- Info fields of the corresponding name table entry.
73 -----------------------
74 -- Local Subprograms --
75 -----------------------
77 function Append_Suffix_To_File_Name
78 (Name
: File_Name_Type
;
79 Suffix
: String) return File_Name_Type
;
80 -- Appends Suffix to Name and returns the new name
82 function OS_Time_To_GNAT_Time
(T
: OS_Time
) return Time_Stamp_Type
;
83 -- Convert OS format time to GNAT format time stamp
85 function Executable_Prefix
return String_Ptr
;
86 -- Returns the name of the root directory where the executable is stored.
87 -- The executable must be located in a directory called "bin", or under
88 -- root/lib/gcc-lib/..., or under root/libexec/gcc/... For example, if
89 -- executable is stored in directory "/foo/bar/bin", this routine returns
90 -- "/foo/bar/". Return "" if location is not recognized as described above.
92 function Update_Path
(Path
: String_Ptr
) return String_Ptr
;
93 -- Update the specified path to replace the prefix with the location
94 -- where GNAT is installed. See the file prefix.c in GCC for details.
100 Name
: String) return File_Name_Type
;
101 -- See if the file N whose name is Name exists in directory Dir. Dir is an
102 -- index into the Lib_Search_Directories table if T = Library. Otherwise
103 -- if T = Source, Dir is an index into the Src_Search_Directories table.
104 -- Returns the File_Name_Type of the full file name if file found, or
105 -- No_File if not found.
107 function C_String_Length
(S
: Address
) return Integer;
108 -- Returns length of a C string (zero for a null address)
110 function To_Path_String_Access
111 (Path_Addr
: Address
;
112 Path_Len
: Integer) return String_Access
;
113 -- Converts a C String to an Ada String. Are we doing this to avoid withing
114 -- Interfaces.C.Strings ???
116 function Include_Dir_Default_Prefix
return String_Access
;
117 -- Same as exported version, except returns a String_Access
119 ------------------------------
120 -- Other Local Declarations --
121 ------------------------------
123 EOL
: constant Character := ASCII
.LF
;
124 -- End of line character
126 Number_File_Names
: Int
:= 0;
127 -- Number of file names found on command line and placed in File_Names
129 Look_In_Primary_Directory_For_Current_Main
: Boolean := False;
130 -- When this variable is True, Find_File only looks in Primary_Directory
131 -- for the Current_Main file. This variable is always set to True for the
132 -- compiler. It is also True for gnatmake, when the source name given on
133 -- the command line has directory information.
135 Current_Full_Source_Name
: File_Name_Type
:= No_File
;
136 Current_Full_Source_Stamp
: Time_Stamp_Type
:= Empty_Time_Stamp
;
137 Current_Full_Lib_Name
: File_Name_Type
:= No_File
;
138 Current_Full_Lib_Stamp
: Time_Stamp_Type
:= Empty_Time_Stamp
;
139 Current_Full_Obj_Name
: File_Name_Type
:= No_File
;
140 Current_Full_Obj_Stamp
: Time_Stamp_Type
:= Empty_Time_Stamp
;
141 -- Respectively full name (with directory info) and time stamp of the
142 -- latest source, library and object files opened by Read_Source_File and
143 -- Read_Library_Info.
145 package File_Name_Chars
is new Table
.Table
(
146 Table_Component_Type
=> Character,
147 Table_Index_Type
=> Int
,
148 Table_Low_Bound
=> 1,
149 Table_Initial
=> Alloc
.File_Name_Chars_Initial
,
150 Table_Increment
=> Alloc
.File_Name_Chars_Increment
,
151 Table_Name
=> "File_Name_Chars");
152 -- Table to store text to be printed by Dump_Source_File_Names
154 The_Include_Dir_Default_Prefix
: String_Access
:= null;
155 -- Value returned by Include_Dir_Default_Prefix. We don't initialize it
156 -- here, because that causes an elaboration cycle with Sdefault; we
157 -- initialize it lazily instead.
163 Primary_Directory
: constant := 0;
164 -- This is index in the tables created below for the first directory to
165 -- search in for source or library information files. This is the directory
166 -- containing the latest main input file (a source file for the compiler or
167 -- a library file for the binder).
169 package Src_Search_Directories
is new Table
.Table
(
170 Table_Component_Type
=> String_Ptr
,
171 Table_Index_Type
=> Integer,
172 Table_Low_Bound
=> Primary_Directory
,
174 Table_Increment
=> 100,
175 Table_Name
=> "Osint.Src_Search_Directories");
176 -- Table of names of directories in which to search for source (Compiler)
177 -- files. This table is filled in the order in which the directories are
178 -- to be searched, and then used in that order.
180 package Lib_Search_Directories
is new Table
.Table
(
181 Table_Component_Type
=> String_Ptr
,
182 Table_Index_Type
=> Integer,
183 Table_Low_Bound
=> Primary_Directory
,
185 Table_Increment
=> 100,
186 Table_Name
=> "Osint.Lib_Search_Directories");
187 -- Table of names of directories in which to search for library (Binder)
188 -- files. This table is filled in the order in which the directories are
189 -- to be searched and then used in that order. The reason for having two
190 -- distinct tables is that we need them both in gnatmake.
192 ---------------------
193 -- File Hash Table --
194 ---------------------
196 -- The file hash table is provided to free the programmer from any
197 -- efficiency concern when retrieving full file names or time stamps of
198 -- source files. If the programmer calls Source_File_Data (Cache => True)
199 -- he is guaranteed that the price to retrieve the full name (i.e. with
200 -- directory info) or time stamp of the file will be payed only once, the
201 -- first time the full name is actually searched (or the first time the
202 -- time stamp is actually retrieved). This is achieved by employing a hash
203 -- table that stores as a key the File_Name_Type of the file and associates
204 -- to that File_Name_Type the full file name and time stamp of the file.
206 File_Cache_Enabled
: Boolean := False;
207 -- Set to true if you want the enable the file data caching mechanism
209 type File_Hash_Num
is range 0 .. 1020;
211 function File_Hash
(F
: File_Name_Type
) return File_Hash_Num
;
212 -- Compute hash index for use by Simple_HTable
214 package File_Name_Hash_Table
is new GNAT
.HTable
.Simple_HTable
(
215 Header_Num
=> File_Hash_Num
,
216 Element
=> File_Name_Type
,
217 No_Element
=> No_File
,
218 Key
=> File_Name_Type
,
222 package File_Stamp_Hash_Table
is new GNAT
.HTable
.Simple_HTable
(
223 Header_Num
=> File_Hash_Num
,
224 Element
=> Time_Stamp_Type
,
225 No_Element
=> Empty_Time_Stamp
,
226 Key
=> File_Name_Type
,
230 function Smart_Find_File
232 T
: File_Type
) return File_Name_Type
;
233 -- Exactly like Find_File except that if File_Cache_Enabled is True this
234 -- routine looks first in the hash table to see if the full name of the
235 -- file is already available.
237 function Smart_File_Stamp
239 T
: File_Type
) return Time_Stamp_Type
;
240 -- Takes the same parameter as the routine above (N is a file name without
241 -- any prefix directory information) and behaves like File_Stamp except
242 -- that if File_Cache_Enabled is True this routine looks first in the hash
243 -- table to see if the file stamp of the file is already available.
245 -----------------------------
246 -- Add_Default_Search_Dirs --
247 -----------------------------
249 procedure Add_Default_Search_Dirs
is
250 Search_Dir
: String_Access
;
251 Search_Path
: String_Access
;
252 Path_File_Name
: String_Access
;
254 procedure Add_Search_Dir
255 (Search_Dir
: String;
256 Additional_Source_Dir
: Boolean);
257 procedure Add_Search_Dir
258 (Search_Dir
: String_Access
;
259 Additional_Source_Dir
: Boolean);
260 -- Add a source search dir or a library search dir, depending on the
261 -- value of Additional_Source_Dir.
263 procedure Get_Dirs_From_File
(Additional_Source_Dir
: Boolean);
264 -- Open a path file and read the directory to search, one per line
266 function Get_Libraries_From_Registry
return String_Ptr
;
267 -- On Windows systems, get the list of installed standard libraries
268 -- from the registry key:
270 -- HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\
271 -- GNAT\Standard Libraries
272 -- Return an empty string on other systems.
274 -- Note that this is an undocumented legacy feature, and that it
275 -- works only when using the default runtime library (i.e. no --RTS=
276 -- command line switch).
282 procedure Add_Search_Dir
283 (Search_Dir
: String;
284 Additional_Source_Dir
: Boolean)
287 if Additional_Source_Dir
then
288 Add_Src_Search_Dir
(Search_Dir
);
290 Add_Lib_Search_Dir
(Search_Dir
);
294 procedure Add_Search_Dir
295 (Search_Dir
: String_Access
;
296 Additional_Source_Dir
: Boolean)
299 if Additional_Source_Dir
then
300 Add_Src_Search_Dir
(Search_Dir
.all);
302 Add_Lib_Search_Dir
(Search_Dir
.all);
306 ------------------------
307 -- Get_Dirs_From_File --
308 ------------------------
310 procedure Get_Dirs_From_File
(Additional_Source_Dir
: Boolean) is
311 File_FD
: File_Descriptor
;
312 Buffer
: constant String := Path_File_Name
.all & ASCII
.NUL
;
314 Actual_Len
: Natural;
321 pragma Warnings
(Off
, Status
);
322 -- For the call to Close where status is ignored
325 File_FD
:= Open_Read
(Buffer
'Address, Binary
);
327 -- If we cannot open the file, we ignore it, we don't fail
329 if File_FD
= Invalid_FD
then
333 Len
:= Integer (File_Length
(File_FD
));
335 S
:= new String (1 .. Len
);
337 -- Read the file. Note that the loop is not necessary since the
338 -- whole file is read at once except on VMS.
342 while Curr
<= Len
and then Actual_Len
/= 0 loop
343 Actual_Len
:= Read
(File_FD
, S
(Curr
)'Address, Len
);
344 Curr
:= Curr
+ Actual_Len
;
347 -- We are done with the file, so we close it (ignore any error on
348 -- the close, since we have successfully read the file).
350 Close
(File_FD
, Status
);
352 -- Now, we read line by line
356 while Curr
< Len
loop
359 if Ch
= ASCII
.CR
or else Ch
= ASCII
.LF
360 or else Ch
= ASCII
.FF
or else Ch
= ASCII
.VT
362 if First
<= Curr
then
363 Add_Search_Dir
(S
(First
.. Curr
), Additional_Source_Dir
);
372 -- Last line is a special case, if the file does not end with
373 -- an end of line mark.
375 if First
<= S
'Last then
376 Add_Search_Dir
(S
(First
.. S
'Last), Additional_Source_Dir
);
378 end Get_Dirs_From_File
;
380 ---------------------------------
381 -- Get_Libraries_From_Registry --
382 ---------------------------------
384 function Get_Libraries_From_Registry
return String_Ptr
is
385 function C_Get_Libraries_From_Registry
return Address
;
386 pragma Import
(C
, C_Get_Libraries_From_Registry
,
387 "__gnat_get_libraries_from_registry");
389 function Strlen
(Str
: Address
) return Integer;
390 pragma Import
(C
, Strlen
, "strlen");
392 procedure Strncpy
(X
: Address
; Y
: Address
; Length
: Integer);
393 pragma Import
(C
, Strncpy
, "strncpy");
395 procedure C_Free
(Str
: Address
);
396 pragma Import
(C
, C_Free
, "free");
398 Result_Ptr
: Address
;
399 Result_Length
: Integer;
400 Out_String
: String_Ptr
;
403 Result_Ptr
:= C_Get_Libraries_From_Registry
;
404 Result_Length
:= Strlen
(Result_Ptr
);
406 Out_String
:= new String (1 .. Result_Length
);
407 Strncpy
(Out_String
.all'Address, Result_Ptr
, Result_Length
);
412 end Get_Libraries_From_Registry
;
414 -- Start of processing for Add_Default_Search_Dirs
417 -- After the locations specified on the command line, the next places
418 -- to look for files are the directories specified by the appropriate
419 -- environment variable. Get this value, extract the directory names
420 -- and store in the tables.
422 -- Check for eventual project path file env vars
424 Path_File_Name
:= Getenv
(Project_Include_Path_File
);
426 if Path_File_Name
'Length > 0 then
427 Get_Dirs_From_File
(Additional_Source_Dir
=> True);
430 Path_File_Name
:= Getenv
(Project_Objects_Path_File
);
432 if Path_File_Name
'Length > 0 then
433 Get_Dirs_From_File
(Additional_Source_Dir
=> False);
436 -- On VMS, don't expand the logical name (e.g. environment variable),
437 -- just put it into Unix (e.g. canonical) format. System services
438 -- will handle the expansion as part of the file processing.
440 for Additional_Source_Dir
in False .. True loop
441 if Additional_Source_Dir
then
442 Search_Path
:= Getenv
(Ada_Include_Path
);
444 if Search_Path
'Length > 0 then
445 if Hostparm
.OpenVMS
then
446 Search_Path
:= To_Canonical_Path_Spec
("ADA_INCLUDE_PATH:");
448 Search_Path
:= To_Canonical_Path_Spec
(Search_Path
.all);
453 Search_Path
:= Getenv
(Ada_Objects_Path
);
455 if Search_Path
'Length > 0 then
456 if Hostparm
.OpenVMS
then
457 Search_Path
:= To_Canonical_Path_Spec
("ADA_OBJECTS_PATH:");
459 Search_Path
:= To_Canonical_Path_Spec
(Search_Path
.all);
464 Get_Next_Dir_In_Path_Init
(Search_Path
);
466 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
467 exit when Search_Dir
= null;
468 Add_Search_Dir
(Search_Dir
, Additional_Source_Dir
);
472 -- For the compiler, if --RTS= was specified, add the runtime
475 if RTS_Src_Path_Name
/= null
476 and then RTS_Lib_Path_Name
/= null
478 Add_Search_Dirs
(RTS_Src_Path_Name
, Include
);
479 Add_Search_Dirs
(RTS_Lib_Path_Name
, Objects
);
482 if not Opt
.No_Stdinc
then
484 -- For WIN32 systems, look for any system libraries defined in
485 -- the registry. These are added to both source and object
488 Search_Path
:= String_Access
(Get_Libraries_From_Registry
);
490 Get_Next_Dir_In_Path_Init
(Search_Path
);
492 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
493 exit when Search_Dir
= null;
494 Add_Search_Dir
(Search_Dir
, False);
495 Add_Search_Dir
(Search_Dir
, True);
498 -- The last place to look are the defaults
501 Read_Default_Search_Dirs
502 (String_Access
(Update_Path
(Search_Dir_Prefix
)),
504 String_Access
(Update_Path
(Include_Dir_Default_Name
)));
506 Get_Next_Dir_In_Path_Init
(Search_Path
);
508 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
509 exit when Search_Dir
= null;
510 Add_Search_Dir
(Search_Dir
, True);
514 if not Opt
.No_Stdlib
and not Opt
.RTS_Switch
then
516 Read_Default_Search_Dirs
517 (String_Access
(Update_Path
(Search_Dir_Prefix
)),
519 String_Access
(Update_Path
(Object_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
, False);
529 end Add_Default_Search_Dirs
;
535 procedure Add_File
(File_Name
: String; Index
: Int
:= No_Index
) is
537 Number_File_Names
:= Number_File_Names
+ 1;
539 -- As Add_File may be called for mains specified inside a project file,
540 -- File_Names may be too short and needs to be extended.
542 if Number_File_Names
> File_Names
'Last then
543 File_Names
:= new File_Name_Array
'(File_Names.all & File_Names.all);
545 new File_Index_Array'(File_Indexes
.all & File_Indexes
.all);
548 File_Names
(Number_File_Names
) := new String'(File_Name);
549 File_Indexes (Number_File_Names) := Index;
552 ------------------------
553 -- Add_Lib_Search_Dir --
554 ------------------------
556 procedure Add_Lib_Search_Dir (Dir : String) is
558 if Dir'Length = 0 then
559 Fail ("missing library directory name");
562 Lib_Search_Directories.Increment_Last;
563 Lib_Search_Directories.Table (Lib_Search_Directories.Last) :=
564 Normalize_Directory_Name (Dir);
565 end Add_Lib_Search_Dir;
567 ---------------------
568 -- Add_Search_Dirs --
569 ---------------------
571 procedure Add_Search_Dirs
572 (Search_Path : String_Ptr;
573 Path_Type : Search_File_Type)
575 Current_Search_Path : String_Access;
578 Get_Next_Dir_In_Path_Init (String_Access (Search_Path));
580 Current_Search_Path :=
581 Get_Next_Dir_In_Path (String_Access (Search_Path));
582 exit when Current_Search_Path = null;
584 if Path_Type = Include then
585 Add_Src_Search_Dir (Current_Search_Path.all);
587 Add_Lib_Search_Dir (Current_Search_Path.all);
592 ------------------------
593 -- Add_Src_Search_Dir --
594 ------------------------
596 procedure Add_Src_Search_Dir (Dir : String) is
598 if Dir'Length = 0 then
599 Fail ("missing source directory name");
602 Src_Search_Directories.Increment_Last;
603 Src_Search_Directories.Table (Src_Search_Directories.Last) :=
604 Normalize_Directory_Name (Dir);
605 end Add_Src_Search_Dir;
607 --------------------------------
608 -- Append_Suffix_To_File_Name --
609 --------------------------------
611 function Append_Suffix_To_File_Name
612 (Name : File_Name_Type;
613 Suffix : String) return File_Name_Type
616 Get_Name_String (Name);
617 Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
618 Name_Len := Name_Len + Suffix'Length;
620 end Append_Suffix_To_File_Name;
622 ---------------------
623 -- C_String_Length --
624 ---------------------
626 function C_String_Length (S : Address) return Integer is
627 function Strlen (S : Address) return Integer;
628 pragma Import (C, Strlen, "strlen");
630 if S = Null_Address then
637 ------------------------------
638 -- Canonical_Case_File_Name --
639 ------------------------------
641 -- For now, we only deal with the case of a-z. Eventually we should
642 -- worry about other Latin-1 letters on systems that support this ???
644 procedure Canonical_Case_File_Name (S : in out String) is
646 if not File_Names_Case_Sensitive then
647 for J in S'Range loop
648 if S (J) in 'A
' .. 'Z
' then
649 S (J) := Character'Val (
650 Character'Pos (S (J)) +
651 Character'Pos ('a
') -
652 Character'Pos ('A
'));
656 end Canonical_Case_File_Name;
658 ---------------------------
659 -- Create_File_And_Check --
660 ---------------------------
662 procedure Create_File_And_Check
663 (Fdesc : out File_Descriptor;
667 Output_File_Name := Name_Enter;
668 Fdesc := Create_File (Name_Buffer'Address, Fmode);
670 if Fdesc = Invalid_FD then
671 Fail ("Cannot create: " & Name_Buffer (1 .. Name_Len));
673 end Create_File_And_Check;
675 ------------------------
676 -- Current_File_Index --
677 ------------------------
679 function Current_File_Index return Int is
681 return File_Indexes (Current_File_Name_Index);
682 end Current_File_Index;
684 --------------------------------
685 -- Current_Library_File_Stamp --
686 --------------------------------
688 function Current_Library_File_Stamp return Time_Stamp_Type is
690 return Current_Full_Lib_Stamp;
691 end Current_Library_File_Stamp;
693 -------------------------------
694 -- Current_Object_File_Stamp --
695 -------------------------------
697 function Current_Object_File_Stamp return Time_Stamp_Type is
699 return Current_Full_Obj_Stamp;
700 end Current_Object_File_Stamp;
702 -------------------------------
703 -- Current_Source_File_Stamp --
704 -------------------------------
706 function Current_Source_File_Stamp return Time_Stamp_Type is
708 return Current_Full_Source_Stamp;
709 end Current_Source_File_Stamp;
711 ----------------------------
712 -- Dir_In_Obj_Search_Path --
713 ----------------------------
715 function Dir_In_Obj_Search_Path (Position : Natural) return String_Ptr is
717 if Opt.Look_In_Primary_Dir then
719 Lib_Search_Directories.Table (Primary_Directory + Position - 1);
721 return Lib_Search_Directories.Table (Primary_Directory + Position);
723 end Dir_In_Obj_Search_Path;
725 ----------------------------
726 -- Dir_In_Src_Search_Path --
727 ----------------------------
729 function Dir_In_Src_Search_Path (Position : Natural) return String_Ptr is
731 if Opt.Look_In_Primary_Dir then
733 Src_Search_Directories.Table (Primary_Directory + Position - 1);
735 return Src_Search_Directories.Table (Primary_Directory + Position);
737 end Dir_In_Src_Search_Path;
739 ----------------------------
740 -- Dump_Source_File_Names --
741 ----------------------------
743 procedure Dump_Source_File_Names is
744 subtype Rng is Int range File_Name_Chars.First .. File_Name_Chars.Last;
746 Write_Str (String (File_Name_Chars.Table (Rng)));
747 end Dump_Source_File_Names;
749 ---------------------
750 -- Executable_Name --
751 ---------------------
753 function Executable_Name (Name : File_Name_Type) return File_Name_Type is
754 Exec_Suffix : String_Access;
757 if Name = No_File then
761 if Executable_Extension_On_Target = No_Name then
762 Exec_Suffix := Get_Target_Executable_Suffix;
764 Get_Name_String (Executable_Extension_On_Target);
765 Exec_Suffix := new String'(Name_Buffer
(1 .. Name_Len
));
768 Get_Name_String
(Name
);
770 if Exec_Suffix
'Length /= 0 then
772 Buffer
: String := Name_Buffer
(1 .. Name_Len
);
775 -- Get the file name in canonical case to accept as is names
776 -- ending with ".EXE" on VMS and Windows.
778 Canonical_Case_File_Name
(Buffer
);
780 -- If Executable does not end with the executable suffix, add it
782 if Buffer
'Length <= Exec_Suffix
'Length
784 Buffer
(Buffer
'Last - Exec_Suffix
'Length + 1 .. Buffer
'Last)
787 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ Exec_Suffix
'Length) :=
789 Name_Len
:= Name_Len
+ Exec_Suffix
'Length;
800 function Executable_Name
(Name
: String) return String is
801 Exec_Suffix
: String_Access
;
802 Canonical_Name
: String := Name
;
805 if Executable_Extension_On_Target
= No_Name
then
806 Exec_Suffix
:= Get_Target_Executable_Suffix
;
808 Get_Name_String
(Executable_Extension_On_Target
);
809 Exec_Suffix
:= new String'(Name_Buffer (1 .. Name_Len));
813 Suffix : constant String := Exec_Suffix.all;
817 Canonical_Case_File_Name (Canonical_Name);
819 if Suffix'Length /= 0
821 (Canonical_Name'Length <= Suffix'Length
822 or else Canonical_Name (Canonical_Name'Last - Suffix'Length + 1
823 .. Canonical_Name'Last) /= Suffix)
826 Result : String (1 .. Name'Length + Suffix'Length);
828 Result (1 .. Name'Length) := Name;
829 Result (Name'Length + 1 .. Result'Last) := Suffix;
838 -----------------------
839 -- Executable_Prefix --
840 -----------------------
842 function Executable_Prefix return String_Ptr is
844 function Get_Install_Dir (Exec : String) return String_Ptr;
845 -- S is the executable name preceded by the absolute or relative
846 -- path, e.g. "c:\usr\bin\gcc.exe" or "..\bin\gcc".
848 ---------------------
849 -- Get_Install_Dir --
850 ---------------------
852 function Get_Install_Dir (Exec : String) return String_Ptr is
853 Full_Path : constant String := Normalize_Pathname (Exec);
854 -- Use the full path, so that we find "lib" or "bin", even when
855 -- the tool has been invoked with a relative path, as in
856 -- "./gnatls -v" invoked in the GNAT bin directory.
859 for J in reverse Full_Path'Range loop
860 if Is_Directory_Separator (Full_Path (J)) then
861 if J < Full_Path'Last - 5 then
862 if (To_Lower (Full_Path (J + 1)) = 'l
'
863 and then To_Lower (Full_Path (J + 2)) = 'i
'
864 and then To_Lower (Full_Path (J + 3)) = 'b
')
866 (To_Lower (Full_Path (J + 1)) = 'b
'
867 and then To_Lower (Full_Path (J + 2)) = 'i
'
868 and then To_Lower (Full_Path (J + 3)) = 'n
')
870 return new String'(Full_Path
(Full_Path
'First .. J
));
876 return new String'("");
879 -- Start of processing for Executable_Prefix
882 if Exec_Name = null then
883 Exec_Name := new String (1 .. Len_Arg (0));
884 Osint.Fill_Arg (Exec_Name (1)'Address, 0);
887 -- First determine if a path prefix was placed in front of the
890 for J in reverse Exec_Name'Range loop
891 if Is_Directory_Separator (Exec_Name (J)) then
892 return Get_Install_Dir (Exec_Name.all);
896 -- If we come here, the user has typed the executable name with no
899 return Get_Install_Dir (Locate_Exec_On_Path (Exec_Name.all).all);
900 end Executable_Prefix;
906 procedure Exit_Program (Exit_Code : Exit_Code_Type) is
908 -- The program will exit with the following status:
910 -- 0 if the object file has been generated (with or without warnings)
911 -- 1 if recompilation was not needed (smart recompilation)
912 -- 2 if gnat1 has been killed by a signal (detected by GCC)
913 -- 4 for a fatal error
914 -- 5 if there were errors
915 -- 6 if no code has been generated (spec)
917 -- Note that exit code 3 is not used and must not be used as this is
918 -- the code returned by a program aborted via C abort() routine on
919 -- Windows. GCC checks for that case and thinks that the child process
920 -- has been aborted. This code (exit code 3) used to be the code used
921 -- for E_No_Code, but E_No_Code was changed to 6 for this reason.
924 when E_Success => OS_Exit (0);
925 when E_Warnings => OS_Exit (0);
926 when E_No_Compile => OS_Exit (1);
927 when E_Fatal => OS_Exit (4);
928 when E_Errors => OS_Exit (5);
929 when E_No_Code => OS_Exit (6);
930 when E_Abort => OS_Abort;
938 procedure Fail (S : String) is
940 -- We use Output in case there is a special output set up.
941 -- In this case Set_Standard_Error will have no immediate effect.
944 Osint.Write_Program_Name;
949 Exit_Program (E_Fatal);
956 function File_Hash (F : File_Name_Type) return File_Hash_Num is
958 return File_Hash_Num (Int (F) rem File_Hash_Num'Range_Length);
965 function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type is
967 if Name = No_File then
968 return Empty_Time_Stamp;
971 Get_Name_String (Name);
973 if not Is_Regular_File (Name_Buffer (1 .. Name_Len)) then
974 return Empty_Time_Stamp;
976 Name_Buffer (Name_Len + 1) := ASCII.NUL;
977 return OS_Time_To_GNAT_Time (File_Time_Stamp (Name_Buffer));
981 function File_Stamp (Name : Path_Name_Type) return Time_Stamp_Type is
983 return File_Stamp (File_Name_Type (Name));
992 T : File_Type) return File_Name_Type
998 File_Name : String renames Name_Buffer (1 .. Name_Len);
999 File : File_Name_Type := No_File;
1003 -- If we are looking for a config file, look only in the current
1004 -- directory, i.e. return input argument unchanged. Also look
1005 -- only in the current directory if we are looking for a .dg
1006 -- file (happens in -gnatD mode).
1009 or else (Debug_Generated_Code
1010 and then Name_Len > 3
1012 (Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg"
1014 (Hostparm.OpenVMS and then
1015 Name_Buffer (Name_Len - 2 .. Name_Len) = "_dg")))
1019 -- If we are trying to find the current main file just look in the
1020 -- directory where the user said it was.
1022 elsif Look_In_Primary_Directory_For_Current_Main
1023 and then Current_Main = N
1025 return Locate_File (N, T, Primary_Directory, File_Name);
1027 -- Otherwise do standard search for source file
1030 -- Check the mapping of this file name
1032 File := Mapped_Path_Name (N);
1034 -- If the file name is mapped to a path name, return the
1035 -- corresponding path name
1037 if File /= No_File then
1039 -- For locally removed file, Error_Name is returned; then
1040 -- return No_File, indicating the file is not a source.
1042 if File = Error_File_Name then
1050 -- First place to look is in the primary directory (i.e. the same
1051 -- directory as the source) unless this has been disabled with -I-
1053 if Opt.Look_In_Primary_Dir then
1054 File := Locate_File (N, T, Primary_Directory, File_Name);
1056 if File /= No_File then
1061 -- Finally look in directories specified with switches -I/-aI/-aO
1064 Last_Dir := Lib_Search_Directories.Last;
1066 Last_Dir := Src_Search_Directories.Last;
1069 for D in Primary_Directory + 1 .. Last_Dir loop
1070 File := Locate_File (N, T, D, File_Name);
1072 if File /= No_File then
1082 -----------------------
1083 -- Find_Program_Name --
1084 -----------------------
1086 procedure Find_Program_Name is
1087 Command_Name : String (1 .. Len_Arg (0));
1088 Cindex1 : Integer := Command_Name'First;
1089 Cindex2 : Integer := Command_Name'Last;
1092 Fill_Arg (Command_Name'Address, 0);
1094 if Command_Name = "" then
1099 -- The program name might be specified by a full path name. However,
1100 -- we don't want to print that all out in an error message, so the
1101 -- path might need to be stripped away.
1103 for J in reverse Cindex1 .. Cindex2 loop
1104 if Is_Directory_Separator (Command_Name (J)) then
1110 -- Command_Name(Cindex1 .. Cindex2) is now the equivalent of the
1111 -- POSIX command "basename argv[0]"
1113 -- Strip off any versioning information such as found on VMS.
1114 -- This would take the form of TOOL.exe followed by a ";" or "."
1115 -- and a sequence of one or more numbers.
1117 if Command_Name (Cindex2) in '0' .. '9' then
1118 for J in reverse Cindex1 .. Cindex2 loop
1119 if Command_Name (J) = '.' or else Command_Name (J) = ';' then
1124 exit when Command_Name (J) not in '0' .. '9';
1128 -- Strip off any executable extension (usually nothing or .exe)
1129 -- but formally reported by autoconf in the variable EXEEXT
1131 if Cindex2 - Cindex1 >= 4 then
1132 if To_Lower (Command_Name (Cindex2 - 3)) = '.'
1133 and then To_Lower (Command_Name (Cindex2 - 2)) = 'e
'
1134 and then To_Lower (Command_Name (Cindex2 - 1)) = 'x
'
1135 and then To_Lower (Command_Name (Cindex2)) = 'e
'
1137 Cindex2 := Cindex2 - 4;
1141 Name_Len := Cindex2 - Cindex1 + 1;
1142 Name_Buffer (1 .. Name_Len) := Command_Name (Cindex1 .. Cindex2);
1143 end Find_Program_Name;
1145 ------------------------
1146 -- Full_Lib_File_Name --
1147 ------------------------
1149 function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type is
1151 return Find_File (N, Library);
1152 end Full_Lib_File_Name;
1154 ----------------------------
1155 -- Full_Library_Info_Name --
1156 ----------------------------
1158 function Full_Library_Info_Name return File_Name_Type is
1160 return Current_Full_Lib_Name;
1161 end Full_Library_Info_Name;
1163 ---------------------------
1164 -- Full_Object_File_Name --
1165 ---------------------------
1167 function Full_Object_File_Name return File_Name_Type is
1169 return Current_Full_Obj_Name;
1170 end Full_Object_File_Name;
1172 ----------------------
1173 -- Full_Source_Name --
1174 ----------------------
1176 function Full_Source_Name return File_Name_Type is
1178 return Current_Full_Source_Name;
1179 end Full_Source_Name;
1181 ----------------------
1182 -- Full_Source_Name --
1183 ----------------------
1185 function Full_Source_Name (N : File_Name_Type) return File_Name_Type is
1187 return Smart_Find_File (N, Source);
1188 end Full_Source_Name;
1194 function Get_Directory (Name : File_Name_Type) return File_Name_Type is
1196 Get_Name_String (Name);
1198 for J in reverse 1 .. Name_Len loop
1199 if Is_Directory_Separator (Name_Buffer (J)) then
1205 Name_Len := Hostparm.Normalized_CWD'Length;
1206 Name_Buffer (1 .. Name_Len) := Hostparm.Normalized_CWD;
1210 --------------------------
1211 -- Get_Next_Dir_In_Path --
1212 --------------------------
1214 Search_Path_Pos : Integer;
1215 -- Keeps track of current position in search path. Initialized by the
1216 -- call to Get_Next_Dir_In_Path_Init, updated by Get_Next_Dir_In_Path.
1218 function Get_Next_Dir_In_Path
1219 (Search_Path : String_Access) return String_Access
1221 Lower_Bound : Positive := Search_Path_Pos;
1222 Upper_Bound : Positive;
1226 while Lower_Bound <= Search_Path'Last
1227 and then Search_Path.all (Lower_Bound) = Path_Separator
1229 Lower_Bound := Lower_Bound + 1;
1232 exit when Lower_Bound > Search_Path'Last;
1234 Upper_Bound := Lower_Bound;
1235 while Upper_Bound <= Search_Path'Last
1236 and then Search_Path.all (Upper_Bound) /= Path_Separator
1238 Upper_Bound := Upper_Bound + 1;
1241 Search_Path_Pos := Upper_Bound;
1242 return new String'(Search_Path
.all (Lower_Bound
.. Upper_Bound
- 1));
1246 end Get_Next_Dir_In_Path
;
1248 -------------------------------
1249 -- Get_Next_Dir_In_Path_Init --
1250 -------------------------------
1252 procedure Get_Next_Dir_In_Path_Init
(Search_Path
: String_Access
) is
1254 Search_Path_Pos
:= Search_Path
'First;
1255 end Get_Next_Dir_In_Path_Init
;
1257 --------------------------------------
1258 -- Get_Primary_Src_Search_Directory --
1259 --------------------------------------
1261 function Get_Primary_Src_Search_Directory
return String_Ptr
is
1263 return Src_Search_Directories
.Table
(Primary_Directory
);
1264 end Get_Primary_Src_Search_Directory
;
1266 ------------------------
1267 -- Get_RTS_Search_Dir --
1268 ------------------------
1270 function Get_RTS_Search_Dir
1271 (Search_Dir
: String;
1272 File_Type
: Search_File_Type
) return String_Ptr
1274 procedure Get_Current_Dir
1275 (Dir
: System
.Address
;
1276 Length
: System
.Address
);
1277 pragma Import
(C
, Get_Current_Dir
, "__gnat_get_current_dir");
1280 pragma Import
(C
, Max_Path
, "__gnat_max_path_len");
1281 -- Maximum length of a path name
1283 Current_Dir
: String_Ptr
;
1284 Default_Search_Dir
: String_Access
;
1285 Default_Suffix_Dir
: String_Access
;
1286 Local_Search_Dir
: String_Access
;
1287 Norm_Search_Dir
: String_Access
;
1288 Result_Search_Dir
: String_Access
;
1289 Search_File
: String_Access
;
1290 Temp_String
: String_Ptr
;
1293 -- Add a directory separator at the end of the directory if necessary
1294 -- so that we can directly append a file to the directory
1296 if Search_Dir
(Search_Dir
'Last) /= Directory_Separator
then
1298 new String'(Search_Dir & String'(1 => Directory_Separator
));
1300 Local_Search_Dir
:= new String'(Search_Dir);
1303 if File_Type = Include then
1304 Search_File := Include_Search_File;
1305 Default_Suffix_Dir := new String'("adainclude");
1307 Search_File
:= Objects_Search_File
;
1308 Default_Suffix_Dir
:= new String'("adalib");
1311 Norm_Search_Dir := To_Canonical_Path_Spec (Local_Search_Dir.all);
1313 if Is_Absolute_Path (Norm_Search_Dir.all) then
1315 -- We first verify if there is a directory Include_Search_Dir
1316 -- containing default search directories
1318 Result_Search_Dir :=
1319 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1320 Default_Search_Dir :=
1321 new String'(Norm_Search_Dir
.all & Default_Suffix_Dir
.all);
1322 Free
(Norm_Search_Dir
);
1324 if Result_Search_Dir
/= null then
1325 return String_Ptr
(Result_Search_Dir
);
1326 elsif Is_Directory
(Default_Search_Dir
.all) then
1327 return String_Ptr
(Default_Search_Dir
);
1332 -- Search in the current directory
1335 -- Get the current directory
1338 Buffer
: String (1 .. Max_Path
+ 2);
1339 Path_Len
: Natural := Max_Path
;
1342 Get_Current_Dir
(Buffer
'Address, Path_Len
'Address);
1344 if Buffer
(Path_Len
) /= Directory_Separator
then
1345 Path_Len
:= Path_Len
+ 1;
1346 Buffer
(Path_Len
) := Directory_Separator
;
1349 Current_Dir
:= new String'(Buffer (1 .. Path_Len));
1353 new String'(Current_Dir
.all & Local_Search_Dir
.all);
1355 Result_Search_Dir
:=
1356 Read_Default_Search_Dirs
(Norm_Search_Dir
, Search_File
, null);
1358 Default_Search_Dir
:=
1359 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1361 Free (Norm_Search_Dir);
1363 if Result_Search_Dir /= null then
1364 return String_Ptr (Result_Search_Dir);
1366 elsif Is_Directory (Default_Search_Dir.all) then
1367 return String_Ptr (Default_Search_Dir);
1370 -- Search in Search_Dir_Prefix/Search_Dir
1374 (Update_Path
(Search_Dir_Prefix
).all & Local_Search_Dir
.all);
1376 Result_Search_Dir
:=
1377 Read_Default_Search_Dirs
(Norm_Search_Dir
, Search_File
, null);
1379 Default_Search_Dir
:=
1380 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1382 Free (Norm_Search_Dir);
1384 if Result_Search_Dir /= null then
1385 return String_Ptr (Result_Search_Dir);
1387 elsif Is_Directory (Default_Search_Dir.all) then
1388 return String_Ptr (Default_Search_Dir);
1391 -- We finally search in Search_Dir_Prefix/rts-Search_Dir
1394 new String'(Update_Path
(Search_Dir_Prefix
).all & "rts-");
1397 new String'(Temp_String.all & Local_Search_Dir.all);
1399 Result_Search_Dir :=
1400 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1402 Default_Search_Dir :=
1403 new String'(Norm_Search_Dir
.all & Default_Suffix_Dir
.all);
1404 Free
(Norm_Search_Dir
);
1406 if Result_Search_Dir
/= null then
1407 return String_Ptr
(Result_Search_Dir
);
1409 elsif Is_Directory
(Default_Search_Dir
.all) then
1410 return String_Ptr
(Default_Search_Dir
);
1418 end Get_RTS_Search_Dir
;
1420 --------------------------------
1421 -- Include_Dir_Default_Prefix --
1422 --------------------------------
1424 function Include_Dir_Default_Prefix
return String_Access
is
1426 if The_Include_Dir_Default_Prefix
= null then
1427 The_Include_Dir_Default_Prefix
:=
1428 String_Access
(Update_Path
(Include_Dir_Default_Name
));
1431 return The_Include_Dir_Default_Prefix
;
1432 end Include_Dir_Default_Prefix
;
1434 function Include_Dir_Default_Prefix
return String is
1436 return Include_Dir_Default_Prefix
.all;
1437 end Include_Dir_Default_Prefix
;
1443 procedure Initialize
is
1445 Number_File_Names
:= 0;
1446 Current_File_Name_Index
:= 0;
1448 Src_Search_Directories
.Init
;
1449 Lib_Search_Directories
.Init
;
1451 -- Start off by setting all suppress options to False, these will
1452 -- be reset later (turning some on if -gnato is not specified, and
1453 -- turning all of them on if -gnatp is specified).
1455 Suppress_Options
:= (others => False);
1457 -- Reserve the first slot in the search paths table. This is the
1458 -- directory of the main source file or main library file and is filled
1459 -- in by each call to Next_Main_Source/Next_Main_Lib_File with the
1460 -- directory specified for this main source or library file. This is the
1461 -- directory which is searched first by default. This default search is
1462 -- inhibited by the option -I- for both source and library files.
1464 Src_Search_Directories
.Set_Last
(Primary_Directory
);
1465 Src_Search_Directories
.Table
(Primary_Directory
) := new String'("");
1467 Lib_Search_Directories.Set_Last (Primary_Directory);
1468 Lib_Search_Directories.Table (Primary_Directory) := new String'("");
1471 ----------------------------
1472 -- Is_Directory_Separator --
1473 ----------------------------
1475 function Is_Directory_Separator
(C
: Character) return Boolean is
1477 -- In addition to the default directory_separator allow the '/' to
1478 -- act as separator since this is allowed in MS-DOS, Windows 95/NT,
1479 -- and OS2 ports. On VMS, the situation is more complicated because
1480 -- there are two characters to check for.
1483 C
= Directory_Separator
1485 or else (Hostparm
.OpenVMS
1486 and then (C
= ']' or else C
= ':'));
1487 end Is_Directory_Separator
;
1489 -------------------------
1490 -- Is_Readonly_Library --
1491 -------------------------
1493 function Is_Readonly_Library
(File
: File_Name_Type
) return Boolean is
1495 Get_Name_String
(File
);
1497 pragma Assert
(Name_Buffer
(Name_Len
- 3 .. Name_Len
) = ".ali");
1499 return not Is_Writable_File
(Name_Buffer
(1 .. Name_Len
));
1500 end Is_Readonly_Library
;
1506 function Lib_File_Name
1507 (Source_File
: File_Name_Type
;
1508 Munit_Index
: Nat
:= 0) return File_Name_Type
1511 Get_Name_String
(Source_File
);
1513 for J
in reverse 2 .. Name_Len
loop
1514 if Name_Buffer
(J
) = '.' then
1520 if Munit_Index
/= 0 then
1521 Add_Char_To_Name_Buffer
(Multi_Unit_Index_Character
);
1522 Add_Nat_To_Name_Buffer
(Munit_Index
);
1525 Add_Char_To_Name_Buffer
('.');
1526 Add_Str_To_Name_Buffer
(ALI_Suffix
.all);
1530 ------------------------
1531 -- Library_File_Stamp --
1532 ------------------------
1534 function Library_File_Stamp
(N
: File_Name_Type
) return Time_Stamp_Type
is
1536 return File_Stamp
(Find_File
(N
, Library
));
1537 end Library_File_Stamp
;
1543 function Locate_File
1544 (N
: File_Name_Type
;
1547 Name
: String) return File_Name_Type
1549 Dir_Name
: String_Ptr
;
1552 -- If Name is already an absolute path, do not look for a directory
1554 if Is_Absolute_Path
(Name
) then
1557 elsif T
= Library
then
1558 Dir_Name
:= Lib_Search_Directories
.Table
(Dir
);
1560 else pragma Assert
(T
/= Config
);
1561 Dir_Name
:= Src_Search_Directories
.Table
(Dir
);
1565 Full_Name
: String (1 .. Dir_Name
'Length + Name
'Length);
1568 Full_Name
(1 .. Dir_Name
'Length) := Dir_Name
.all;
1569 Full_Name
(Dir_Name
'Length + 1 .. Full_Name
'Length) := Name
;
1571 if not Is_Regular_File
(Full_Name
) then
1575 -- If the file is in the current directory then return N itself
1577 if Dir_Name
'Length = 0 then
1580 Name_Len
:= Full_Name
'Length;
1581 Name_Buffer
(1 .. Name_Len
) := Full_Name
;
1588 -------------------------------
1589 -- Matching_Full_Source_Name --
1590 -------------------------------
1592 function Matching_Full_Source_Name
1593 (N
: File_Name_Type
;
1594 T
: Time_Stamp_Type
) return File_Name_Type
1597 Get_Name_String
(N
);
1600 File_Name
: constant String := Name_Buffer
(1 .. Name_Len
);
1601 File
: File_Name_Type
:= No_File
;
1605 if Opt
.Look_In_Primary_Dir
then
1606 File
:= Locate_File
(N
, Source
, Primary_Directory
, File_Name
);
1608 if File
/= No_File
and then T
= File_Stamp
(N
) then
1613 Last_Dir
:= Src_Search_Directories
.Last
;
1615 for D
in Primary_Directory
+ 1 .. Last_Dir
loop
1616 File
:= Locate_File
(N
, Source
, D
, File_Name
);
1618 if File
/= No_File
and then T
= File_Stamp
(File
) then
1625 end Matching_Full_Source_Name
;
1631 function More_Files
return Boolean is
1633 return (Current_File_Name_Index
< Number_File_Names
);
1636 -------------------------------
1637 -- Nb_Dir_In_Obj_Search_Path --
1638 -------------------------------
1640 function Nb_Dir_In_Obj_Search_Path
return Natural is
1642 if Opt
.Look_In_Primary_Dir
then
1643 return Lib_Search_Directories
.Last
- Primary_Directory
+ 1;
1645 return Lib_Search_Directories
.Last
- Primary_Directory
;
1647 end Nb_Dir_In_Obj_Search_Path
;
1649 -------------------------------
1650 -- Nb_Dir_In_Src_Search_Path --
1651 -------------------------------
1653 function Nb_Dir_In_Src_Search_Path
return Natural is
1655 if Opt
.Look_In_Primary_Dir
then
1656 return Src_Search_Directories
.Last
- Primary_Directory
+ 1;
1658 return Src_Search_Directories
.Last
- Primary_Directory
;
1660 end Nb_Dir_In_Src_Search_Path
;
1662 --------------------
1663 -- Next_Main_File --
1664 --------------------
1666 function Next_Main_File
return File_Name_Type
is
1667 File_Name
: String_Ptr
;
1668 Dir_Name
: String_Ptr
;
1672 pragma Assert
(More_Files
);
1674 Current_File_Name_Index
:= Current_File_Name_Index
+ 1;
1676 -- Get the file and directory name
1678 File_Name
:= File_Names
(Current_File_Name_Index
);
1679 Fptr
:= File_Name
'First;
1681 for J
in reverse File_Name
'Range loop
1682 if File_Name
(J
) = Directory_Separator
1683 or else File_Name
(J
) = '/'
1685 if J
= File_Name
'Last then
1686 Fail
("File name missing");
1694 -- Save name of directory in which main unit resides for use in
1695 -- locating other units
1697 Dir_Name
:= new String'(File_Name (File_Name'First .. Fptr - 1));
1699 case Running_Program is
1702 Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
1703 Look_In_Primary_Directory_For_Current_Main := True;
1706 Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
1708 if Fptr > File_Name'First then
1709 Look_In_Primary_Directory_For_Current_Main := True;
1712 when Binder | Gnatls =>
1713 Dir_Name := Normalize_Directory_Name (Dir_Name.all);
1714 Lib_Search_Directories.Table (Primary_Directory) := Dir_Name;
1720 Name_Len := File_Name'Last - Fptr + 1;
1721 Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last);
1722 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
1723 Current_Main := Name_Find;
1725 -- In the gnatmake case, the main file may have not have the
1726 -- extension. Try ".adb" first then ".ads"
1728 if Running_Program = Make then
1730 Orig_Main : constant File_Name_Type := Current_Main;
1733 if Strip_Suffix (Orig_Main) = Orig_Main then
1735 Append_Suffix_To_File_Name (Orig_Main, ".adb");
1737 if Full_Source_Name (Current_Main) = No_File then
1739 Append_Suffix_To_File_Name (Orig_Main, ".ads");
1741 if Full_Source_Name (Current_Main) = No_File then
1742 Current_Main := Orig_Main;
1749 return Current_Main;
1752 ------------------------------
1753 -- Normalize_Directory_Name --
1754 ------------------------------
1756 function Normalize_Directory_Name (Directory : String) return String_Ptr is
1758 function Is_Quoted (Path : String) return Boolean;
1759 pragma Inline (Is_Quoted);
1760 -- Returns true if Path is quoted (either double or single quotes)
1766 function Is_Quoted (Path : String) return Boolean is
1767 First : constant Character := Path (Path'First);
1768 Last : constant Character := Path (Path'Last);
1771 if (First = ''' and then Last = ''')
1773 (First = '"' and then Last = '"')
1781 Result : String_Ptr;
1783 -- Start of processing for Normalize_Directory_Name
1786 if Directory'Length = 0 then
1787 Result := new String'(Hostparm
.Normalized_CWD
);
1789 elsif Is_Directory_Separator
(Directory
(Directory
'Last)) then
1790 Result
:= new String'(Directory);
1792 elsif Is_Quoted (Directory) then
1794 -- This is a quoted string, it certainly means that the directory
1795 -- contains some spaces for example. We can safely remove the quotes
1796 -- here as the OS_Lib.Normalize_Arguments will be called before any
1797 -- spawn routines. This ensure that quotes will be added when needed.
1799 Result := new String (1 .. Directory'Length - 1);
1800 Result (1 .. Directory'Length - 2) :=
1801 Directory (Directory'First + 1 .. Directory'Last - 1);
1802 Result (Result'Last) := Directory_Separator;
1805 Result := new String (1 .. Directory'Length + 1);
1806 Result (1 .. Directory'Length) := Directory;
1807 Result (Directory'Length + 1) := Directory_Separator;
1811 end Normalize_Directory_Name;
1813 ---------------------
1814 -- Number_Of_Files --
1815 ---------------------
1817 function Number_Of_Files return Int is
1819 return Number_File_Names;
1820 end Number_Of_Files;
1822 -------------------------------
1823 -- Object_Dir_Default_Prefix --
1824 -------------------------------
1826 function Object_Dir_Default_Prefix return String is
1827 Object_Dir : String_Access :=
1828 String_Access (Update_Path (Object_Dir_Default_Name));
1831 if Object_Dir = null then
1836 Result : constant String := Object_Dir.all;
1842 end Object_Dir_Default_Prefix;
1844 ----------------------
1845 -- Object_File_Name --
1846 ----------------------
1848 function Object_File_Name (N : File_Name_Type) return File_Name_Type is
1854 Get_Name_String (N);
1855 Name_Len := Name_Len - ALI_Suffix'Length - 1;
1857 for J in Target_Object_Suffix'Range loop
1858 Name_Len := Name_Len + 1;
1859 Name_Buffer (Name_Len) := Target_Object_Suffix (J);
1863 end Object_File_Name;
1865 -------------------------------
1866 -- OS_Exit_Through_Exception --
1867 -------------------------------
1869 procedure OS_Exit_Through_Exception (Status : Integer) is
1871 Current_Exit_Status := Status;
1872 raise Types.Terminate_Program;
1873 end OS_Exit_Through_Exception;
1875 --------------------------
1876 -- OS_Time_To_GNAT_Time --
1877 --------------------------
1879 function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type is
1880 GNAT_Time : Time_Stamp_Type;
1890 GM_Split (T, Y, Mo, D, H, Mn, S);
1896 Minutes => Nat (Mn),
1901 end OS_Time_To_GNAT_Time;
1907 function Program_Name (Nam : String; Prog : String) return String_Access is
1908 End_Of_Prefix : Natural := 0;
1909 Start_Of_Prefix : Positive := 1;
1910 Start_Of_Suffix : Positive;
1913 -- GNAAMP tool names require special treatment
1915 if AAMP_On_Target then
1917 -- The name "gcc" is mapped to "gnaamp" (the compiler driver)
1920 return new String'("gnaamp");
1922 -- Tool names starting with "gnat" are mapped by substituting the
1923 -- string "gnaamp" for "gnat" (for example, "gnatpp" => "gnaamppp").
1925 elsif Nam
'Length >= 4
1926 and then Nam
(Nam
'First .. Nam
'First + 3) = "gnat"
1928 return new String'("gnaamp" & Nam (Nam'First + 4 .. Nam'Last));
1930 -- No other mapping rules, so we continue and handle any other forms
1931 -- of tool names the same as on other targets.
1938 -- Get the name of the current program being executed
1942 Start_Of_Suffix := Name_Len + 1;
1944 -- Find the target prefix if any, for the cross compilation case.
1945 -- For instance in "powerpc-elf-gcc" the target prefix is
1947 -- Ditto for suffix, e.g. in "gcc-4.1", the suffix is "-4.1"
1949 for J in reverse 1 .. Name_Len loop
1950 if Name_Buffer (J) = '/'
1951 or else Name_Buffer (J) = Directory_Separator
1952 or else Name_Buffer (J) = ':'
1954 Start_Of_Prefix := J + 1;
1959 -- Find End_Of_Prefix
1961 for J in Start_Of_Prefix .. Name_Len - Prog'Length + 1 loop
1962 if Name_Buffer (J .. J + Prog'Length - 1) = Prog then
1963 End_Of_Prefix := J - 1;
1968 if End_Of_Prefix > 1 then
1969 Start_Of_Suffix := End_Of_Prefix + Prog'Length + 1;
1972 -- Create the new program name
1975 (Name_Buffer
(Start_Of_Prefix
.. End_Of_Prefix
)
1977 & Name_Buffer
(Start_Of_Suffix
.. Name_Len
));
1980 ------------------------------
1981 -- Read_Default_Search_Dirs --
1982 ------------------------------
1984 function Read_Default_Search_Dirs
1985 (Search_Dir_Prefix
: String_Access
;
1986 Search_File
: String_Access
;
1987 Search_Dir_Default_Name
: String_Access
) return String_Access
1989 Prefix_Len
: constant Integer := Search_Dir_Prefix
.all'Length;
1990 Buffer
: String (1 .. Prefix_Len
+ Search_File
.all'Length + 1);
1991 File_FD
: File_Descriptor
;
1992 S
, S1
: String_Access
;
1995 Actual_Len
: Integer;
1998 Prev_Was_Separator
: Boolean;
1999 Nb_Relative_Dir
: Integer;
2001 function Is_Relative
(S
: String; K
: Positive) return Boolean;
2002 pragma Inline
(Is_Relative
);
2003 -- Returns True if a relative directory specification is found
2004 -- in S at position K, False otherwise.
2010 function Is_Relative
(S
: String; K
: Positive) return Boolean is
2012 return not Is_Absolute_Path
(S
(K
.. S
'Last));
2015 -- Start of processing for Read_Default_Search_Dirs
2018 -- Construct a C compatible character string buffer
2020 Buffer
(1 .. Search_Dir_Prefix
.all'Length)
2021 := Search_Dir_Prefix
.all;
2022 Buffer
(Search_Dir_Prefix
.all'Length + 1 .. Buffer
'Last - 1)
2024 Buffer
(Buffer
'Last) := ASCII
.NUL
;
2026 File_FD
:= Open_Read
(Buffer
'Address, Binary
);
2027 if File_FD
= Invalid_FD
then
2028 return Search_Dir_Default_Name
;
2031 Len
:= Integer (File_Length
(File_FD
));
2033 -- An extra character for a trailing Path_Separator is allocated
2035 S
:= new String (1 .. Len
+ 1);
2036 S
(Len
+ 1) := Path_Separator
;
2038 -- Read the file. Note that the loop is not necessary since the
2039 -- whole file is read at once except on VMS.
2043 while Actual_Len
/= 0 loop
2044 Actual_Len
:= Read
(File_FD
, S
(Curr
)'Address, Len
);
2045 Curr
:= Curr
+ Actual_Len
;
2048 -- Process the file, dealing with path separators
2050 Prev_Was_Separator
:= True;
2051 Nb_Relative_Dir
:= 0;
2052 for J
in 1 .. Len
loop
2054 -- Treat any control character as a path separator. Note that we do
2055 -- not treat space as a path separator (we used to treat space as a
2056 -- path separator in an earlier version). That way space can appear
2057 -- as a legitimate character in a path name.
2059 -- Why do we treat all control characters as path separators???
2061 if S
(J
) in ASCII
.NUL
.. ASCII
.US
then
2062 S
(J
) := Path_Separator
;
2065 -- Test for explicit path separator (or control char as above)
2067 if S
(J
) = Path_Separator
then
2068 Prev_Was_Separator
:= True;
2070 -- If not path separator, register use of relative directory
2073 if Prev_Was_Separator
and then Is_Relative
(S
.all, J
) then
2074 Nb_Relative_Dir
:= Nb_Relative_Dir
+ 1;
2077 Prev_Was_Separator
:= False;
2081 if Nb_Relative_Dir
= 0 then
2085 -- Add the Search_Dir_Prefix to all relative paths
2087 S1
:= new String (1 .. S
'Length + Nb_Relative_Dir
* Prefix_Len
);
2089 Prev_Was_Separator
:= True;
2090 for J
in 1 .. Len
+ 1 loop
2091 if S
(J
) = Path_Separator
then
2092 Prev_Was_Separator
:= True;
2095 if Prev_Was_Separator
and then Is_Relative
(S
.all, J
) then
2096 S1
(J1
.. J1
+ Prefix_Len
- 1) := Search_Dir_Prefix
.all;
2097 J1
:= J1
+ Prefix_Len
;
2100 Prev_Was_Separator
:= False;
2108 end Read_Default_Search_Dirs
;
2110 -----------------------
2111 -- Read_Library_Info --
2112 -----------------------
2114 function Read_Library_Info
2115 (Lib_File
: File_Name_Type
;
2116 Fatal_Err
: Boolean := False) return Text_Buffer_Ptr
2118 Lib_FD
: File_Descriptor
;
2119 -- The file descriptor for the current library file. A negative value
2120 -- indicates failure to open the specified source file.
2122 Text
: Text_Buffer_Ptr
;
2123 -- Allocated text buffer
2126 pragma Warnings
(Off
, Status
);
2127 -- For the calls to Close
2130 Current_Full_Lib_Name
:= Find_File
(Lib_File
, Library
);
2131 Current_Full_Obj_Name
:= Object_File_Name
(Current_Full_Lib_Name
);
2133 if Current_Full_Lib_Name
= No_File
then
2135 Fail
("Cannot find: " & Name_Buffer
(1 .. Name_Len
));
2137 Current_Full_Obj_Stamp
:= Empty_Time_Stamp
;
2142 Get_Name_String
(Current_Full_Lib_Name
);
2143 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
2145 -- Open the library FD, note that we open in binary mode, because as
2146 -- documented in the spec, the caller is expected to handle either
2147 -- DOS or Unix mode files, and there is no point in wasting time on
2148 -- text translation when it is not required.
2150 Lib_FD
:= Open_Read
(Name_Buffer
'Address, Binary
);
2152 if Lib_FD
= Invalid_FD
then
2154 Fail
("Cannot open: " & Name_Buffer
(1 .. Name_Len
));
2156 Current_Full_Obj_Stamp
:= Empty_Time_Stamp
;
2161 -- Check for object file consistency if requested
2163 if Opt
.Check_Object_Consistency
then
2164 Current_Full_Lib_Stamp
:= File_Stamp
(Current_Full_Lib_Name
);
2165 Current_Full_Obj_Stamp
:= File_Stamp
(Current_Full_Obj_Name
);
2167 if Current_Full_Obj_Stamp
(1) = ' ' then
2169 -- When the library is readonly always assume object is consistent
2171 if Is_Readonly_Library
(Current_Full_Lib_Name
) then
2172 Current_Full_Obj_Stamp
:= Current_Full_Lib_Stamp
;
2174 elsif Fatal_Err
then
2175 Get_Name_String
(Current_Full_Obj_Name
);
2176 Close
(Lib_FD
, Status
);
2178 -- No need to check the status, we fail anyway
2180 Fail
("Cannot find: " & Name_Buffer
(1 .. Name_Len
));
2183 Current_Full_Obj_Stamp
:= Empty_Time_Stamp
;
2184 Close
(Lib_FD
, Status
);
2186 -- No need to check the status, we return null anyway
2193 -- Read data from the file
2196 Len
: constant Integer := Integer (File_Length
(Lib_FD
));
2197 -- Length of source file text. If it doesn't fit in an integer
2198 -- we're probably stuck anyway (>2 gigs of source seems a lot!)
2200 Actual_Len
: Integer := 0;
2202 Lo
: constant Text_Ptr
:= 0;
2203 -- Low bound for allocated text buffer
2205 Hi
: Text_Ptr
:= Text_Ptr
(Len
);
2206 -- High bound for allocated text buffer. Note length is Len + 1
2207 -- which allows for extra EOF character at the end of the buffer.
2210 -- Allocate text buffer. Note extra character at end for EOF
2212 Text
:= new Text_Buffer
(Lo
.. Hi
);
2214 -- Some systems (e.g. VMS) have file types that require one
2215 -- read per line, so read until we get the Len bytes or until
2216 -- there are no more characters.
2220 Actual_Len
:= Read
(Lib_FD
, Text
(Hi
)'Address, Len
);
2221 Hi
:= Hi
+ Text_Ptr
(Actual_Len
);
2222 exit when Actual_Len
= Len
or else Actual_Len
<= 0;
2228 -- Read is complete, close file and we are done
2230 Close
(Lib_FD
, Status
);
2231 -- The status should never be False. But, if it is, what can we do?
2232 -- So, we don't test it.
2236 end Read_Library_Info
;
2238 ----------------------
2239 -- Read_Source_File --
2240 ----------------------
2242 procedure Read_Source_File
2243 (N
: File_Name_Type
;
2245 Hi
: out Source_Ptr
;
2246 Src
: out Source_Buffer_Ptr
;
2247 T
: File_Type
:= Source
)
2249 Source_File_FD
: File_Descriptor
;
2250 -- The file descriptor for the current source file. A negative value
2251 -- indicates failure to open the specified source file.
2254 -- Length of file. Assume no more than 2 gigabytes of source!
2256 Actual_Len
: Integer;
2259 pragma Warnings
(Off
, Status
);
2260 -- For the call to Close
2263 Current_Full_Source_Name
:= Find_File
(N
, T
);
2264 Current_Full_Source_Stamp
:= File_Stamp
(Current_Full_Source_Name
);
2266 if Current_Full_Source_Name
= No_File
then
2268 -- If we were trying to access the main file and we could not find
2269 -- it, we have an error.
2271 if N
= Current_Main
then
2272 Get_Name_String
(N
);
2273 Fail
("Cannot find: " & Name_Buffer
(1 .. Name_Len
));
2281 Get_Name_String
(Current_Full_Source_Name
);
2282 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
2284 -- Open the source FD, note that we open in binary mode, because as
2285 -- documented in the spec, the caller is expected to handle either
2286 -- DOS or Unix mode files, and there is no point in wasting time on
2287 -- text translation when it is not required.
2289 Source_File_FD
:= Open_Read
(Name_Buffer
'Address, Binary
);
2291 if Source_File_FD
= Invalid_FD
then
2297 -- Print out the file name, if requested, and if it's not part of the
2298 -- runtimes, store it in File_Name_Chars.
2301 Name
: String renames Name_Buffer
(1 .. Name_Len
);
2302 Inc
: String renames Include_Dir_Default_Prefix
.all;
2305 if Debug
.Debug_Flag_Dot_N
then
2310 and then Inc
'Length < Name_Len
2311 and then Name_Buffer
(1 .. Inc
'Length) = Inc
2313 -- Part of runtimes, so ignore it
2318 File_Name_Chars
.Append_All
(File_Name_Chars
.Table_Type
(Name
));
2319 File_Name_Chars
.Append
(ASCII
.LF
);
2323 -- Prepare to read data from the file
2325 Len
:= Integer (File_Length
(Source_File_FD
));
2327 -- Set Hi so that length is one more than the physical length,
2328 -- allowing for the extra EOF character at the end of the buffer
2330 Hi
:= Lo
+ Source_Ptr
(Len
);
2332 -- Do the actual read operation
2335 subtype Actual_Source_Buffer
is Source_Buffer
(Lo
.. Hi
);
2336 -- Physical buffer allocated
2338 type Actual_Source_Ptr
is access Actual_Source_Buffer
;
2339 -- This is the pointer type for the physical buffer allocated
2341 Actual_Ptr
: constant Actual_Source_Ptr
:= new Actual_Source_Buffer
;
2342 -- And this is the actual physical buffer
2345 -- Allocate source buffer, allowing extra character at end for EOF
2347 -- Some systems (e.g. VMS) have file types that require one read per
2348 -- line, so read until we get the Len bytes or until there are no
2353 Actual_Len
:= Read
(Source_File_FD
, Actual_Ptr
(Hi
)'Address, Len
);
2354 Hi
:= Hi
+ Source_Ptr
(Actual_Len
);
2355 exit when Actual_Len
= Len
or else Actual_Len
<= 0;
2358 Actual_Ptr
(Hi
) := EOF
;
2360 -- Now we need to work out the proper virtual origin pointer to
2361 -- return. This is exactly Actual_Ptr (0)'Address, but we have to
2362 -- be careful to suppress checks to compute this address.
2365 pragma Suppress
(All_Checks
);
2367 pragma Warnings
(Off
);
2368 -- This use of unchecked conversion is aliasing safe
2370 function To_Source_Buffer_Ptr
is new
2371 Unchecked_Conversion
(Address
, Source_Buffer_Ptr
);
2373 pragma Warnings
(On
);
2376 Src
:= To_Source_Buffer_Ptr
(Actual_Ptr
(0)'Address);
2380 -- Read is complete, get time stamp and close file and we are done
2382 Close
(Source_File_FD
, Status
);
2384 -- The status should never be False. But, if it is, what can we do?
2385 -- So, we don't test it.
2387 end Read_Source_File
;
2393 function Relocate_Path
2395 Path
: String) return String_Ptr
2399 procedure set_std_prefix
(S
: String; Len
: Integer);
2400 pragma Import
(C
, set_std_prefix
);
2403 if Std_Prefix
= null then
2404 Std_Prefix
:= Executable_Prefix
;
2406 if Std_Prefix
.all /= "" then
2408 -- Remove trailing directory separator when calling set_std_prefix
2410 set_std_prefix
(Std_Prefix
.all, Std_Prefix
'Length - 1);
2414 if Path
(Prefix
'Range) = Prefix
then
2415 if Std_Prefix
.all /= "" then
2417 (1 .. Std_Prefix
'Length + Path
'Last - Prefix
'Last);
2418 S
(1 .. Std_Prefix
'Length) := Std_Prefix
.all;
2419 S
(Std_Prefix
'Length + 1 .. S
'Last) :=
2420 Path
(Prefix
'Last + 1 .. Path
'Last);
2425 return new String'(Path);
2432 procedure Set_Program (P : Program_Type) is
2435 Fail ("Set_Program called twice");
2438 Program_Set := True;
2439 Running_Program := P;
2446 function Shared_Lib (Name : String) return String is
2447 Library : String (1 .. Name'Length + Library_Version'Length + 3);
2448 -- 3 = 2 for "-l" + 1 for "-" before lib version
2451 Library (1 .. 2) := "-l";
2452 Library (3 .. 2 + Name'Length) := Name;
2453 Library (3 + Name'Length) := '-';
2454 Library (4 + Name'Length .. Library'Last) := Library_Version;
2456 if OpenVMS_On_Target then
2457 for K in Library'First + 2 .. Library'Last loop
2458 if Library (K) = '.' or else Library (K) = '-' then
2467 ----------------------
2468 -- Smart_File_Stamp --
2469 ----------------------
2471 function Smart_File_Stamp
2472 (N : File_Name_Type;
2473 T : File_Type) return Time_Stamp_Type
2475 Time_Stamp : Time_Stamp_Type;
2478 if not File_Cache_Enabled then
2479 return File_Stamp (Find_File (N, T));
2482 Time_Stamp := File_Stamp_Hash_Table.Get (N);
2484 if Time_Stamp (1) = ' ' then
2485 Time_Stamp := File_Stamp (Smart_Find_File (N, T));
2486 File_Stamp_Hash_Table.Set (N, Time_Stamp);
2490 end Smart_File_Stamp;
2492 ---------------------
2493 -- Smart_Find_File --
2494 ---------------------
2496 function Smart_Find_File
2497 (N : File_Name_Type;
2498 T : File_Type) return File_Name_Type
2500 Full_File_Name : File_Name_Type;
2503 if not File_Cache_Enabled then
2504 return Find_File (N, T);
2507 Full_File_Name := File_Name_Hash_Table.Get (N);
2509 if Full_File_Name = No_File then
2510 Full_File_Name := Find_File (N, T);
2511 File_Name_Hash_Table.Set (N, Full_File_Name);
2514 return Full_File_Name;
2515 end Smart_Find_File;
2517 ----------------------
2518 -- Source_File_Data --
2519 ----------------------
2521 procedure Source_File_Data (Cache : Boolean) is
2523 File_Cache_Enabled := Cache;
2524 end Source_File_Data;
2526 -----------------------
2527 -- Source_File_Stamp --
2528 -----------------------
2530 function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is
2532 return Smart_File_Stamp (N, Source);
2533 end Source_File_Stamp;
2535 ---------------------
2536 -- Strip_Directory --
2537 ---------------------
2539 function Strip_Directory (Name : File_Name_Type) return File_Name_Type is
2541 Get_Name_String (Name);
2543 for J in reverse 1 .. Name_Len - 1 loop
2545 -- If we find the last directory separator
2547 if Is_Directory_Separator (Name_Buffer (J)) then
2549 -- Return the part of Name that follows this last directory
2552 Name_Buffer (1 .. Name_Len - J) := Name_Buffer (J + 1 .. Name_Len);
2553 Name_Len := Name_Len - J;
2558 -- There were no directory separator, just return Name
2561 end Strip_Directory;
2567 function Strip_Suffix (Name : File_Name_Type) return File_Name_Type is
2569 Get_Name_String (Name);
2571 for J in reverse 2 .. Name_Len loop
2573 -- If we found the last '.', return part of Name that precedes it
2575 if Name_Buffer (J) = '.' then
2584 ---------------------------
2585 -- To_Canonical_Dir_Spec --
2586 ---------------------------
2588 function To_Canonical_Dir_Spec
2590 Prefix_Style : Boolean) return String_Access
2592 function To_Canonical_Dir_Spec
2593 (Host_Dir : Address;
2594 Prefix_Flag : Integer) return Address;
2595 pragma Import (C, To_Canonical_Dir_Spec, "__gnat_to_canonical_dir_spec");
2597 C_Host_Dir : String (1 .. Host_Dir'Length + 1);
2598 Canonical_Dir_Addr : Address;
2599 Canonical_Dir_Len : Integer;
2602 C_Host_Dir (1 .. Host_Dir'Length) := Host_Dir;
2603 C_Host_Dir (C_Host_Dir'Last) := ASCII.NUL;
2605 if Prefix_Style then
2606 Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 1);
2608 Canonical_Dir_Addr := To_Canonical_Dir_Spec (C_Host_Dir'Address, 0);
2610 Canonical_Dir_Len := C_String_Length (Canonical_Dir_Addr);
2612 if Canonical_Dir_Len = 0 then
2615 return To_Path_String_Access (Canonical_Dir_Addr, Canonical_Dir_Len);
2620 Fail ("erroneous directory spec: " & Host_Dir);
2622 end To_Canonical_Dir_Spec;
2624 ---------------------------
2625 -- To_Canonical_File_List --
2626 ---------------------------
2628 function To_Canonical_File_List
2629 (Wildcard_Host_File : String;
2630 Only_Dirs : Boolean) return String_Access_List_Access
2632 function To_Canonical_File_List_Init
2633 (Host_File : Address;
2634 Only_Dirs : Integer) return Integer;
2635 pragma Import (C, To_Canonical_File_List_Init,
2636 "__gnat_to_canonical_file_list_init");
2638 function To_Canonical_File_List_Next return Address;
2639 pragma Import (C, To_Canonical_File_List_Next,
2640 "__gnat_to_canonical_file_list_next");
2642 procedure To_Canonical_File_List_Free;
2643 pragma Import (C, To_Canonical_File_List_Free,
2644 "__gnat_to_canonical_file_list_free");
2646 Num_Files : Integer;
2647 C_Wildcard_Host_File : String (1 .. Wildcard_Host_File'Length + 1);
2650 C_Wildcard_Host_File (1 .. Wildcard_Host_File'Length) :=
2652 C_Wildcard_Host_File (C_Wildcard_Host_File'Last) := ASCII.NUL;
2654 -- Do the expansion and say how many there are
2656 Num_Files := To_Canonical_File_List_Init
2657 (C_Wildcard_Host_File'Address, Boolean'Pos (Only_Dirs));
2660 Canonical_File_List : String_Access_List (1 .. Num_Files);
2661 Canonical_File_Addr : Address;
2662 Canonical_File_Len : Integer;
2665 -- Retrieve the expanded directory names and build the list
2667 for J in 1 .. Num_Files loop
2668 Canonical_File_Addr := To_Canonical_File_List_Next;
2669 Canonical_File_Len := C_String_Length (Canonical_File_Addr);
2670 Canonical_File_List (J) := To_Path_String_Access
2671 (Canonical_File_Addr, Canonical_File_Len);
2674 -- Free up the storage
2676 To_Canonical_File_List_Free;
2678 return new String_Access_List'(Canonical_File_List
);
2680 end To_Canonical_File_List
;
2682 ----------------------------
2683 -- To_Canonical_File_Spec --
2684 ----------------------------
2686 function To_Canonical_File_Spec
2687 (Host_File
: String) return String_Access
2689 function To_Canonical_File_Spec
(Host_File
: Address
) return Address
;
2691 (C
, To_Canonical_File_Spec
, "__gnat_to_canonical_file_spec");
2693 C_Host_File
: String (1 .. Host_File
'Length + 1);
2694 Canonical_File_Addr
: Address
;
2695 Canonical_File_Len
: Integer;
2698 C_Host_File
(1 .. Host_File
'Length) := Host_File
;
2699 C_Host_File
(C_Host_File
'Last) := ASCII
.NUL
;
2701 Canonical_File_Addr
:= To_Canonical_File_Spec
(C_Host_File
'Address);
2702 Canonical_File_Len
:= C_String_Length
(Canonical_File_Addr
);
2704 if Canonical_File_Len
= 0 then
2707 return To_Path_String_Access
2708 (Canonical_File_Addr
, Canonical_File_Len
);
2713 Fail
("erroneous file spec: " & Host_File
);
2715 end To_Canonical_File_Spec
;
2717 ----------------------------
2718 -- To_Canonical_Path_Spec --
2719 ----------------------------
2721 function To_Canonical_Path_Spec
2722 (Host_Path
: String) return String_Access
2724 function To_Canonical_Path_Spec
(Host_Path
: Address
) return Address
;
2726 (C
, To_Canonical_Path_Spec
, "__gnat_to_canonical_path_spec");
2728 C_Host_Path
: String (1 .. Host_Path
'Length + 1);
2729 Canonical_Path_Addr
: Address
;
2730 Canonical_Path_Len
: Integer;
2733 C_Host_Path
(1 .. Host_Path
'Length) := Host_Path
;
2734 C_Host_Path
(C_Host_Path
'Last) := ASCII
.NUL
;
2736 Canonical_Path_Addr
:= To_Canonical_Path_Spec
(C_Host_Path
'Address);
2737 Canonical_Path_Len
:= C_String_Length
(Canonical_Path_Addr
);
2739 -- Return a null string (vice a null) for zero length paths, for
2740 -- compatibility with getenv().
2742 return To_Path_String_Access
(Canonical_Path_Addr
, Canonical_Path_Len
);
2746 Fail
("erroneous path spec: " & Host_Path
);
2748 end To_Canonical_Path_Spec
;
2750 ---------------------------
2751 -- To_Host_Dir_Spec --
2752 ---------------------------
2754 function To_Host_Dir_Spec
2755 (Canonical_Dir
: String;
2756 Prefix_Style
: Boolean) return String_Access
2758 function To_Host_Dir_Spec
2759 (Canonical_Dir
: Address
;
2760 Prefix_Flag
: Integer) return Address
;
2761 pragma Import
(C
, To_Host_Dir_Spec
, "__gnat_to_host_dir_spec");
2763 C_Canonical_Dir
: String (1 .. Canonical_Dir
'Length + 1);
2764 Host_Dir_Addr
: Address
;
2765 Host_Dir_Len
: Integer;
2768 C_Canonical_Dir
(1 .. Canonical_Dir
'Length) := Canonical_Dir
;
2769 C_Canonical_Dir
(C_Canonical_Dir
'Last) := ASCII
.NUL
;
2771 if Prefix_Style
then
2772 Host_Dir_Addr
:= To_Host_Dir_Spec
(C_Canonical_Dir
'Address, 1);
2774 Host_Dir_Addr
:= To_Host_Dir_Spec
(C_Canonical_Dir
'Address, 0);
2776 Host_Dir_Len
:= C_String_Length
(Host_Dir_Addr
);
2778 if Host_Dir_Len
= 0 then
2781 return To_Path_String_Access
(Host_Dir_Addr
, Host_Dir_Len
);
2783 end To_Host_Dir_Spec
;
2785 ----------------------------
2786 -- To_Host_File_Spec --
2787 ----------------------------
2789 function To_Host_File_Spec
2790 (Canonical_File
: String) return String_Access
2792 function To_Host_File_Spec
(Canonical_File
: Address
) return Address
;
2793 pragma Import
(C
, To_Host_File_Spec
, "__gnat_to_host_file_spec");
2795 C_Canonical_File
: String (1 .. Canonical_File
'Length + 1);
2796 Host_File_Addr
: Address
;
2797 Host_File_Len
: Integer;
2800 C_Canonical_File
(1 .. Canonical_File
'Length) := Canonical_File
;
2801 C_Canonical_File
(C_Canonical_File
'Last) := ASCII
.NUL
;
2803 Host_File_Addr
:= To_Host_File_Spec
(C_Canonical_File
'Address);
2804 Host_File_Len
:= C_String_Length
(Host_File_Addr
);
2806 if Host_File_Len
= 0 then
2809 return To_Path_String_Access
2810 (Host_File_Addr
, Host_File_Len
);
2812 end To_Host_File_Spec
;
2814 ---------------------------
2815 -- To_Path_String_Access --
2816 ---------------------------
2818 function To_Path_String_Access
2819 (Path_Addr
: Address
;
2820 Path_Len
: Integer) return String_Access
2822 subtype Path_String
is String (1 .. Path_Len
);
2823 type Path_String_Access
is access Path_String
;
2825 function Address_To_Access
is new
2826 Unchecked_Conversion
(Source
=> Address
,
2827 Target
=> Path_String_Access
);
2829 Path_Access
: constant Path_String_Access
:=
2830 Address_To_Access
(Path_Addr
);
2832 Return_Val
: String_Access
;
2835 Return_Val
:= new String (1 .. Path_Len
);
2837 for J
in 1 .. Path_Len
loop
2838 Return_Val
(J
) := Path_Access
(J
);
2842 end To_Path_String_Access
;
2848 function Update_Path
(Path
: String_Ptr
) return String_Ptr
is
2850 function C_Update_Path
(Path
, Component
: Address
) return Address
;
2851 pragma Import
(C
, C_Update_Path
, "update_path");
2853 function Strlen
(Str
: Address
) return Integer;
2854 pragma Import
(C
, Strlen
, "strlen");
2856 procedure Strncpy
(X
: Address
; Y
: Address
; Length
: Integer);
2857 pragma Import
(C
, Strncpy
, "strncpy");
2859 In_Length
: constant Integer := Path
'Length;
2860 In_String
: String (1 .. In_Length
+ 1);
2861 Component_Name
: aliased String := "GCC" & ASCII
.NUL
;
2862 Result_Ptr
: Address
;
2863 Result_Length
: Integer;
2864 Out_String
: String_Ptr
;
2867 In_String
(1 .. In_Length
) := Path
.all;
2868 In_String
(In_Length
+ 1) := ASCII
.NUL
;
2869 Result_Ptr
:= C_Update_Path
(In_String
'Address, Component_Name
'Address);
2870 Result_Length
:= Strlen
(Result_Ptr
);
2872 Out_String
:= new String (1 .. Result_Length
);
2873 Strncpy
(Out_String
.all'Address, Result_Ptr
, Result_Length
);
2881 procedure Write_Info
(Info
: String) is
2883 Write_With_Check
(Info
'Address, Info
'Length);
2884 Write_With_Check
(EOL
'Address, 1);
2887 ------------------------
2888 -- Write_Program_Name --
2889 ------------------------
2891 procedure Write_Program_Name
is
2892 Save_Buffer
: constant String (1 .. Name_Len
) :=
2893 Name_Buffer
(1 .. Name_Len
);
2898 -- Convert the name to lower case so error messages are the same on
2901 for J
in 1 .. Name_Len
loop
2902 if Name_Buffer
(J
) in 'A' .. 'Z' then
2904 Character'Val (Character'Pos (Name_Buffer
(J
)) + 32);
2908 Write_Str
(Name_Buffer
(1 .. Name_Len
));
2910 -- Restore Name_Buffer which was clobbered by the call to
2911 -- Find_Program_Name
2913 Name_Len
:= Save_Buffer
'Last;
2914 Name_Buffer
(1 .. Name_Len
) := Save_Buffer
;
2915 end Write_Program_Name
;
2917 ----------------------
2918 -- Write_With_Check --
2919 ----------------------
2921 procedure Write_With_Check
(A
: Address
; N
: Integer) is
2923 pragma Warnings
(Off
, Ignore
);
2926 if N
= Write
(Output_FD
, A
, N
) then
2930 Write_Str
("error: disk full writing ");
2931 Write_Name_Decoded
(Output_File_Name
);
2933 Name_Len
:= Name_Len
+ 1;
2934 Name_Buffer
(Name_Len
) := ASCII
.NUL
;
2935 Delete_File
(Name_Buffer
'Address, Ignore
);
2936 Exit_Program
(E_Fatal
);
2938 end Write_With_Check
;
2940 ----------------------------
2941 -- Package Initialization --
2942 ----------------------------
2945 Initialization
: declare
2947 function Get_Default_Identifier_Character_Set
return Character;
2948 pragma Import
(C
, Get_Default_Identifier_Character_Set
,
2949 "__gnat_get_default_identifier_character_set");
2950 -- Function to determine the default identifier character set,
2951 -- which is system dependent. See Opt package spec for a list of
2952 -- the possible character codes and their interpretations.
2954 function Get_Maximum_File_Name_Length
return Int
;
2955 pragma Import
(C
, Get_Maximum_File_Name_Length
,
2956 "__gnat_get_maximum_file_name_length");
2957 -- Function to get maximum file name length for system
2960 Identifier_Character_Set
:= Get_Default_Identifier_Character_Set
;
2961 Maximum_File_Name_Length
:= Get_Maximum_File_Name_Length
;
2963 -- Following should be removed by having above function return
2964 -- Integer'Last as indication of no maximum instead of -1 ???
2966 if Maximum_File_Name_Length
= -1 then
2967 Maximum_File_Name_Length
:= Int
'Last;
2970 Src_Search_Directories
.Set_Last
(Primary_Directory
);
2971 Src_Search_Directories
.Table
(Primary_Directory
) := new String'("");
2973 Lib_Search_Directories.Set_Last (Primary_Directory);
2974 Lib_Search_Directories.Table (Primary_Directory) := new String'("");