1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2006, 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
28 with Gnatvsn
; use Gnatvsn
;
30 with Namet
; use Namet
;
32 with Output
; use Output
;
33 with Sdefault
; use Sdefault
;
35 with Targparm
; use Targparm
;
37 with System
.Case_Util
; use System
.Case_Util
;
39 with Unchecked_Conversion
;
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
66 -- message construction. These names need not be accessible by Name_Find,
67 -- and can be therefore created by using routine Name_Enter. The files in
68 -- question are file names with a prefix directory (ie the files not
69 -- in the current directory). File names without a prefix directory are
70 -- entered with Name_Find because special values might be attached to
71 -- the various Info fields of the corresponding name table entry.
73 -----------------------
74 -- Local Subprograms --
75 -----------------------
77 function Append_Suffix_To_File_Name
79 Suffix
: String) return Name_Id
;
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
88 -- under root/lib/gcc-lib/..., or under root/libexec/gcc/... Thus, if
89 -- the executable is stored in directory "/foo/bar/bin", this routine
90 -- returns "/foo/bar/". Return "" if the location is not recognized
91 -- as described above.
93 function Update_Path
(Path
: String_Ptr
) return String_Ptr
;
94 -- Update the specified path to replace the prefix with the location
95 -- where GNAT is installed. See the file prefix.c in GCC for details.
101 Name
: String) return File_Name_Type
;
102 -- See if the file N whose name is Name exists in directory Dir. Dir is
103 -- an index into the Lib_Search_Directories table if T = Library.
104 -- Otherwise if T = Source, Dir is an index into the
105 -- Src_Search_Directories table. Returns the File_Name_Type of the
106 -- full file name if file found, or No_File if not found.
108 function C_String_Length
(S
: Address
) return Integer;
109 -- Returns length of a C string. Returns zero for a null address
111 function To_Path_String_Access
112 (Path_Addr
: Address
;
113 Path_Len
: Integer) return String_Access
;
114 -- Converts a C String to an Ada String. Are we doing this to avoid
115 -- withing Interfaces.C.Strings ???
117 ------------------------------
118 -- Other Local Declarations --
119 ------------------------------
121 EOL
: constant Character := ASCII
.LF
;
122 -- End of line character
124 Number_File_Names
: Int
:= 0;
125 -- The total number of file names found on command line and placed in
128 Look_In_Primary_Directory_For_Current_Main
: Boolean := False;
129 -- When this variable is True, Find_File will only look in
130 -- the Primary_Directory for the Current_Main file.
131 -- This variable is always True for the compiler.
132 -- It is also True for gnatmake, when the soucr name given
133 -- on 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
142 -- the latest source, library and object files opened by Read_Source_File
143 -- and Read_Library_Info.
149 Primary_Directory
: constant := 0;
150 -- This is index in the tables created below for the first directory to
151 -- search in for source or library information files. This is the
152 -- directory containing the latest main input file (a source file for
153 -- the compiler or a library file for the binder).
155 package Src_Search_Directories
is new Table
.Table
(
156 Table_Component_Type
=> String_Ptr
,
157 Table_Index_Type
=> Natural,
158 Table_Low_Bound
=> Primary_Directory
,
160 Table_Increment
=> 100,
161 Table_Name
=> "Osint.Src_Search_Directories");
162 -- Table of names of directories in which to search for source (Compiler)
163 -- files. This table is filled in the order in which the directories are
164 -- to be searched, and then used in that order.
166 package Lib_Search_Directories
is new Table
.Table
(
167 Table_Component_Type
=> String_Ptr
,
168 Table_Index_Type
=> Natural,
169 Table_Low_Bound
=> Primary_Directory
,
171 Table_Increment
=> 100,
172 Table_Name
=> "Osint.Lib_Search_Directories");
173 -- Table of names of directories in which to search for library (Binder)
174 -- files. This table is filled in the order in which the directories are
175 -- to be searched and then used in that order. The reason for having two
176 -- distinct tables is that we need them both in gnatmake.
178 ---------------------
179 -- File Hash Table --
180 ---------------------
182 -- The file hash table is provided to free the programmer from any
183 -- efficiency concern when retrieving full file names or time stamps of
184 -- source files. If the programmer calls Source_File_Data (Cache => True)
185 -- he is guaranteed that the price to retrieve the full name (ie with
186 -- directory info) or time stamp of the file will be payed only once,
187 -- the first time the full name is actually searched (or the first time
188 -- the time stamp is actually retrieved). This is achieved by employing
189 -- a hash table that stores as a key the File_Name_Type of the file and
190 -- associates to that File_Name_Type the full file name of the file and its
193 File_Cache_Enabled
: Boolean := False;
194 -- Set to true if you want the enable the file data caching mechanism
196 type File_Hash_Num
is range 0 .. 1020;
198 function File_Hash
(F
: File_Name_Type
) return File_Hash_Num
;
199 -- Compute hash index for use by Simple_HTable
201 package File_Name_Hash_Table
is new GNAT
.HTable
.Simple_HTable
(
202 Header_Num
=> File_Hash_Num
,
203 Element
=> File_Name_Type
,
204 No_Element
=> No_File
,
205 Key
=> File_Name_Type
,
209 package File_Stamp_Hash_Table
is new GNAT
.HTable
.Simple_HTable
(
210 Header_Num
=> File_Hash_Num
,
211 Element
=> Time_Stamp_Type
,
212 No_Element
=> Empty_Time_Stamp
,
213 Key
=> File_Name_Type
,
217 function Smart_Find_File
219 T
: File_Type
) return File_Name_Type
;
220 -- Exactly like Find_File except that if File_Cache_Enabled is True this
221 -- routine looks first in the hash table to see if the full name of the
222 -- file is already available.
224 function Smart_File_Stamp
226 T
: File_Type
) return Time_Stamp_Type
;
227 -- Takes the same parameter as the routine above (N is a file name
228 -- without any prefix directory information) and behaves like File_Stamp
229 -- except that if File_Cache_Enabled is True this routine looks first in
230 -- the hash table to see if the file stamp of the file is already
233 -----------------------------
234 -- Add_Default_Search_Dirs --
235 -----------------------------
237 procedure Add_Default_Search_Dirs
is
238 Search_Dir
: String_Access
;
239 Search_Path
: String_Access
;
240 Path_File_Name
: String_Access
;
242 procedure Add_Search_Dir
243 (Search_Dir
: String;
244 Additional_Source_Dir
: Boolean);
245 procedure Add_Search_Dir
246 (Search_Dir
: String_Access
;
247 Additional_Source_Dir
: Boolean);
248 -- Add a source search dir or a library search dir, depending on the
249 -- value of Additional_Source_Dir.
251 procedure Get_Dirs_From_File
(Additional_Source_Dir
: Boolean);
252 -- Open a path file and read the directory to search, one per line
254 function Get_Libraries_From_Registry
return String_Ptr
;
255 -- On Windows systems, get the list of installed standard libraries
256 -- from the registry key:
258 -- HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\
259 -- GNAT\Standard Libraries
260 -- Return an empty string on other systems
266 procedure Add_Search_Dir
267 (Search_Dir
: String;
268 Additional_Source_Dir
: Boolean)
271 if Additional_Source_Dir
then
272 Add_Src_Search_Dir
(Search_Dir
);
274 Add_Lib_Search_Dir
(Search_Dir
);
278 procedure Add_Search_Dir
279 (Search_Dir
: String_Access
;
280 Additional_Source_Dir
: Boolean)
283 if Additional_Source_Dir
then
284 Add_Src_Search_Dir
(Search_Dir
.all);
286 Add_Lib_Search_Dir
(Search_Dir
.all);
290 ------------------------
291 -- Get_Dirs_From_File --
292 ------------------------
294 procedure Get_Dirs_From_File
(Additional_Source_Dir
: Boolean) is
295 File_FD
: File_Descriptor
;
296 Buffer
: constant String := Path_File_Name
.all & ASCII
.NUL
;
298 Actual_Len
: Natural;
305 -- For the call to Close
308 File_FD
:= Open_Read
(Buffer
'Address, Binary
);
310 -- If we cannot open the file, we ignore it, we don't fail
312 if File_FD
= Invalid_FD
then
316 Len
:= Integer (File_Length
(File_FD
));
318 S
:= new String (1 .. Len
);
320 -- Read the file. Note that the loop is not necessary since the
321 -- whole file is read at once except on VMS.
325 while Curr
<= Len
and then Actual_Len
/= 0 loop
326 Actual_Len
:= Read
(File_FD
, S
(Curr
)'Address, Len
);
327 Curr
:= Curr
+ Actual_Len
;
330 -- We are done with the file, so we close it
332 Close
(File_FD
, Status
);
333 -- We ignore any error here, because we have successfully read the
336 -- Now, we read line by line
341 while Curr
< Len
loop
344 if Ch
= ASCII
.CR
or else Ch
= ASCII
.LF
345 or else Ch
= ASCII
.FF
or else Ch
= ASCII
.VT
347 if First
<= Curr
then
348 Add_Search_Dir
(S
(First
.. Curr
), Additional_Source_Dir
);
357 -- Last line is a special case, if the file does not end with
358 -- an end of line mark.
360 if First
<= S
'Last then
361 Add_Search_Dir
(S
(First
.. S
'Last), Additional_Source_Dir
);
363 end Get_Dirs_From_File
;
365 ---------------------------------
366 -- Get_Libraries_From_Registry --
367 ---------------------------------
369 function Get_Libraries_From_Registry
return String_Ptr
is
370 function C_Get_Libraries_From_Registry
return Address
;
371 pragma Import
(C
, C_Get_Libraries_From_Registry
,
372 "__gnat_get_libraries_from_registry");
374 function Strlen
(Str
: Address
) return Integer;
375 pragma Import
(C
, Strlen
, "strlen");
377 procedure Strncpy
(X
: Address
; Y
: Address
; Length
: Integer);
378 pragma Import
(C
, Strncpy
, "strncpy");
380 Result_Ptr
: Address
;
381 Result_Length
: Integer;
382 Out_String
: String_Ptr
;
385 Result_Ptr
:= C_Get_Libraries_From_Registry
;
386 Result_Length
:= Strlen
(Result_Ptr
);
388 Out_String
:= new String (1 .. Result_Length
);
389 Strncpy
(Out_String
.all'Address, Result_Ptr
, Result_Length
);
391 end Get_Libraries_From_Registry
;
393 -- Start of processing for Add_Default_Search_Dirs
396 -- After the locations specified on the command line, the next places
397 -- to look for files are the directories specified by the appropriate
398 -- environment variable. Get this value, extract the directory names
399 -- and store in the tables.
401 -- Check for eventual project path file env vars
403 Path_File_Name
:= Getenv
(Project_Include_Path_File
);
405 if Path_File_Name
'Length > 0 then
406 Get_Dirs_From_File
(Additional_Source_Dir
=> True);
409 Path_File_Name
:= Getenv
(Project_Objects_Path_File
);
411 if Path_File_Name
'Length > 0 then
412 Get_Dirs_From_File
(Additional_Source_Dir
=> False);
415 -- On VMS, don't expand the logical name (e.g. environment variable),
416 -- just put it into Unix (e.g. canonical) format. System services
417 -- will handle the expansion as part of the file processing.
419 for Additional_Source_Dir
in False .. True loop
420 if Additional_Source_Dir
then
421 Search_Path
:= Getenv
(Ada_Include_Path
);
423 if Search_Path
'Length > 0 then
424 if Hostparm
.OpenVMS
then
425 Search_Path
:= To_Canonical_Path_Spec
("ADA_INCLUDE_PATH:");
427 Search_Path
:= To_Canonical_Path_Spec
(Search_Path
.all);
432 Search_Path
:= Getenv
(Ada_Objects_Path
);
434 if Search_Path
'Length > 0 then
435 if Hostparm
.OpenVMS
then
436 Search_Path
:= To_Canonical_Path_Spec
("ADA_OBJECTS_PATH:");
438 Search_Path
:= To_Canonical_Path_Spec
(Search_Path
.all);
443 Get_Next_Dir_In_Path_Init
(Search_Path
);
445 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
446 exit when Search_Dir
= null;
447 Add_Search_Dir
(Search_Dir
, Additional_Source_Dir
);
451 -- For the compiler, if --RTS= was specified, add the runtime
454 if RTS_Src_Path_Name
/= null and then
455 RTS_Lib_Path_Name
/= null
457 Add_Search_Dirs
(RTS_Src_Path_Name
, Include
);
458 Add_Search_Dirs
(RTS_Lib_Path_Name
, Objects
);
461 if not Opt
.No_Stdinc
then
463 -- For WIN32 systems, look for any system libraries defined in
464 -- the registry. These are added to both source and object
467 Search_Path
:= String_Access
(Get_Libraries_From_Registry
);
469 Get_Next_Dir_In_Path_Init
(Search_Path
);
471 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
472 exit when Search_Dir
= null;
473 Add_Search_Dir
(Search_Dir
, False);
474 Add_Search_Dir
(Search_Dir
, True);
477 -- The last place to look are the defaults
480 Read_Default_Search_Dirs
481 (String_Access
(Update_Path
(Search_Dir_Prefix
)),
483 String_Access
(Update_Path
(Include_Dir_Default_Name
)));
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
, True);
493 if not Opt
.No_Stdlib
and not Opt
.RTS_Switch
then
495 Read_Default_Search_Dirs
496 (String_Access
(Update_Path
(Search_Dir_Prefix
)),
498 String_Access
(Update_Path
(Object_Dir_Default_Name
)));
500 Get_Next_Dir_In_Path_Init
(Search_Path
);
502 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
503 exit when Search_Dir
= null;
504 Add_Search_Dir
(Search_Dir
, False);
508 end Add_Default_Search_Dirs
;
514 procedure Add_File
(File_Name
: String; Index
: Int
:= No_Index
) is
516 Number_File_Names
:= Number_File_Names
+ 1;
518 -- As Add_File may be called for mains specified inside
519 -- a project file, File_Names may be too short and needs
522 if Number_File_Names
> File_Names
'Last then
523 File_Names
:= new File_Name_Array
'(File_Names.all & File_Names.all);
525 new File_Index_Array'(File_Indexes
.all & File_Indexes
.all);
528 File_Names
(Number_File_Names
) := new String'(File_Name);
529 File_Indexes (Number_File_Names) := Index;
532 ------------------------
533 -- Add_Lib_Search_Dir --
534 ------------------------
536 procedure Add_Lib_Search_Dir (Dir : String) is
538 if Dir'Length = 0 then
539 Fail ("missing library directory name");
542 Lib_Search_Directories.Increment_Last;
543 Lib_Search_Directories.Table (Lib_Search_Directories.Last) :=
544 Normalize_Directory_Name (Dir);
545 end Add_Lib_Search_Dir;
547 ---------------------
548 -- Add_Search_Dirs --
549 ---------------------
551 procedure Add_Search_Dirs
552 (Search_Path : String_Ptr;
553 Path_Type : Search_File_Type)
555 Current_Search_Path : String_Access;
558 Get_Next_Dir_In_Path_Init (String_Access (Search_Path));
560 Current_Search_Path :=
561 Get_Next_Dir_In_Path (String_Access (Search_Path));
562 exit when Current_Search_Path = null;
564 if Path_Type = Include then
565 Add_Src_Search_Dir (Current_Search_Path.all);
567 Add_Lib_Search_Dir (Current_Search_Path.all);
572 ------------------------
573 -- Add_Src_Search_Dir --
574 ------------------------
576 procedure Add_Src_Search_Dir (Dir : String) is
578 if Dir'Length = 0 then
579 Fail ("missing source directory name");
582 Src_Search_Directories.Increment_Last;
583 Src_Search_Directories.Table (Src_Search_Directories.Last) :=
584 Normalize_Directory_Name (Dir);
585 end Add_Src_Search_Dir;
587 --------------------------------
588 -- Append_Suffix_To_File_Name --
589 --------------------------------
591 function Append_Suffix_To_File_Name
593 Suffix : String) return Name_Id
596 Get_Name_String (Name);
597 Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
598 Name_Len := Name_Len + Suffix'Length;
600 end Append_Suffix_To_File_Name;
602 ---------------------
603 -- C_String_Length --
604 ---------------------
606 function C_String_Length (S : Address) return Integer is
607 function Strlen (S : Address) return Integer;
608 pragma Import (C, Strlen, "strlen");
610 if S = Null_Address then
617 ------------------------------
618 -- Canonical_Case_File_Name --
619 ------------------------------
621 -- For now, we only deal with the case of a-z. Eventually we should
622 -- worry about other Latin-1 letters on systems that support this ???
624 procedure Canonical_Case_File_Name (S : in out String) is
626 if not File_Names_Case_Sensitive then
627 for J in S'Range loop
628 if S (J) in 'A
' .. 'Z
' then
629 S (J) := Character'Val (
630 Character'Pos (S (J)) +
631 Character'Pos ('a
') -
632 Character'Pos ('A
'));
636 end Canonical_Case_File_Name;
638 ---------------------------
639 -- Create_File_And_Check --
640 ---------------------------
642 procedure Create_File_And_Check
643 (Fdesc : out File_Descriptor;
647 Output_File_Name := Name_Enter;
648 Fdesc := Create_File (Name_Buffer'Address, Fmode);
650 if Fdesc = Invalid_FD then
651 Fail ("Cannot create: ", Name_Buffer (1 .. Name_Len));
653 end Create_File_And_Check;
655 ------------------------
656 -- Current_File_Index --
657 ------------------------
659 function Current_File_Index return Int is
661 return File_Indexes (Current_File_Name_Index);
662 end Current_File_Index;
664 --------------------------------
665 -- Current_Library_File_Stamp --
666 --------------------------------
668 function Current_Library_File_Stamp return Time_Stamp_Type is
670 return Current_Full_Lib_Stamp;
671 end Current_Library_File_Stamp;
673 -------------------------------
674 -- Current_Object_File_Stamp --
675 -------------------------------
677 function Current_Object_File_Stamp return Time_Stamp_Type is
679 return Current_Full_Obj_Stamp;
680 end Current_Object_File_Stamp;
682 -------------------------------
683 -- Current_Source_File_Stamp --
684 -------------------------------
686 function Current_Source_File_Stamp return Time_Stamp_Type is
688 return Current_Full_Source_Stamp;
689 end Current_Source_File_Stamp;
691 ----------------------------
692 -- Dir_In_Obj_Search_Path --
693 ----------------------------
695 function Dir_In_Obj_Search_Path (Position : Natural) return String_Ptr is
697 if Opt.Look_In_Primary_Dir then
699 Lib_Search_Directories.Table (Primary_Directory + Position - 1);
701 return Lib_Search_Directories.Table (Primary_Directory + Position);
703 end Dir_In_Obj_Search_Path;
705 ----------------------------
706 -- Dir_In_Src_Search_Path --
707 ----------------------------
709 function Dir_In_Src_Search_Path (Position : Natural) return String_Ptr is
711 if Opt.Look_In_Primary_Dir then
713 Src_Search_Directories.Table (Primary_Directory + Position - 1);
715 return Src_Search_Directories.Table (Primary_Directory + Position);
717 end Dir_In_Src_Search_Path;
719 ---------------------
720 -- Executable_Name --
721 ---------------------
723 function Executable_Name (Name : File_Name_Type) return File_Name_Type is
724 Exec_Suffix : String_Access;
726 if Name = No_File then
730 if Executable_Extension_On_Target = No_Name then
731 Exec_Suffix := Get_Target_Executable_Suffix;
733 Get_Name_String (Executable_Extension_On_Target);
734 Exec_Suffix := new String'(Name_Buffer
(1 .. Name_Len
));
737 Get_Name_String
(Name
);
739 if Exec_Suffix
'Length /= 0 then
741 Buffer
: String := Name_Buffer
(1 .. Name_Len
);
744 -- Get the file name in canonical case to accept as is
745 -- names ending with ".EXE" on VMS and Windows.
747 Canonical_Case_File_Name
(Buffer
);
749 -- If the Executable does not end with the executable
752 if Buffer
'Length <= Exec_Suffix
'Length
754 Buffer
(Buffer
'Last - Exec_Suffix
'Length + 1 .. Buffer
'Last)
757 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ Exec_Suffix
'Length) :=
759 Name_Len
:= Name_Len
+ Exec_Suffix
'Length;
770 function Executable_Name
(Name
: String) return String is
771 Exec_Suffix
: String_Access
;
772 Canonical_Name
: String := Name
;
775 if Executable_Extension_On_Target
= No_Name
then
776 Exec_Suffix
:= Get_Target_Executable_Suffix
;
778 Get_Name_String
(Executable_Extension_On_Target
);
779 Exec_Suffix
:= new String'(Name_Buffer (1 .. Name_Len));
783 Suffix : constant String := Exec_Suffix.all;
787 Canonical_Case_File_Name (Canonical_Name);
789 if Suffix'Length /= 0
791 (Canonical_Name'Length <= Suffix'Length
792 or else Canonical_Name (Canonical_Name'Last - Suffix'Length + 1
793 .. Canonical_Name'Last) /= Suffix)
796 Result : String (1 .. Name'Length + Suffix'Length);
798 Result (1 .. Name'Length) := Name;
799 Result (Name'Length + 1 .. Result'Last) := Suffix;
808 -----------------------
809 -- Executable_Prefix --
810 -----------------------
812 function Executable_Prefix return String_Ptr is
813 function Get_Install_Dir (Exec : String) return String_Ptr;
814 -- S is the executable name preceeded by the absolute or relative
815 -- path, e.g. "c:\usr\bin\gcc.exe" or "..\bin\gcc".
817 ---------------------
818 -- Get_Install_Dir --
819 ---------------------
821 function Get_Install_Dir (Exec : String) return String_Ptr is
822 Full_Path : constant String := Normalize_Pathname (Exec);
823 -- Use the full path, so that we find "lib" or "bin", even when
824 -- the tool has been invoked with a relative path, as in
825 -- "./gnatls -v" invoked in the GNAT bin directory.
828 for J in reverse Full_Path'Range loop
829 if Is_Directory_Separator (Full_Path (J)) then
830 if J < Full_Path'Last - 5 then
831 if (To_Lower (Full_Path (J + 1)) = 'l
'
832 and then To_Lower (Full_Path (J + 2)) = 'i
'
833 and then To_Lower (Full_Path (J + 3)) = 'b
')
835 (To_Lower (Full_Path (J + 1)) = 'b
'
836 and then To_Lower (Full_Path (J + 2)) = 'i
'
837 and then To_Lower (Full_Path (J + 3)) = 'n
')
839 return new String'(Full_Path
(Full_Path
'First .. J
));
845 return new String'("");
848 -- Start of processing for Executable_Prefix
851 if Exec_Name = null then
852 Exec_Name := new String (1 .. Len_Arg (0));
853 Osint.Fill_Arg (Exec_Name (1)'Address, 0);
856 -- First determine if a path prefix was placed in front of the
859 for J in reverse Exec_Name'Range loop
860 if Is_Directory_Separator (Exec_Name (J)) then
861 return Get_Install_Dir (Exec_Name.all);
865 -- If we come here, the user has typed the executable name with no
868 return Get_Install_Dir
869 (GNAT.OS_Lib.Locate_Exec_On_Path (Exec_Name.all).all);
870 end Executable_Prefix;
876 procedure Exit_Program (Exit_Code : Exit_Code_Type) is
878 -- The program will exit with the following status:
880 -- 0 if the object file has been generated (with or without warnings)
881 -- 1 if recompilation was not needed (smart recompilation)
882 -- 2 if gnat1 has been killed by a signal (detected by GCC)
883 -- 4 for a fatal error
884 -- 5 if there were errors
885 -- 6 if no code has been generated (spec)
887 -- Note that exit code 3 is not used and must not be used as this is
888 -- the code returned by a program aborted via C abort() routine on
889 -- Windows. GCC checks for that case and thinks that the child process
890 -- has been aborted. This code (exit code 3) used to be the code used
891 -- for E_No_Code, but E_No_Code was changed to 6 for this reason.
894 when E_Success => OS_Exit (0);
895 when E_Warnings => OS_Exit (0);
896 when E_No_Compile => OS_Exit (1);
897 when E_Fatal => OS_Exit (4);
898 when E_Errors => OS_Exit (5);
899 when E_No_Code => OS_Exit (6);
900 when E_Abort => OS_Abort;
908 procedure Fail (S1 : String; S2 : String := ""; S3 : String := "") is
910 -- We use Output in case there is a special output set up.
911 -- In this case Set_Standard_Error will have no immediate effect.
914 Osint.Write_Program_Name;
921 Exit_Program (E_Fatal);
928 function File_Hash (F : File_Name_Type) return File_Hash_Num is
930 return File_Hash_Num (Int (F) rem File_Hash_Num'Range_Length);
937 function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type is
939 if Name = No_File then
940 return Empty_Time_Stamp;
943 Get_Name_String (Name);
945 if not Is_Regular_File (Name_Buffer (1 .. Name_Len)) then
946 return Empty_Time_Stamp;
948 Name_Buffer (Name_Len + 1) := ASCII.NUL;
949 return OS_Time_To_GNAT_Time (File_Time_Stamp (Name_Buffer));
959 T : File_Type) return File_Name_Type
965 File_Name : String renames Name_Buffer (1 .. Name_Len);
966 File : File_Name_Type := No_File;
970 -- If we are looking for a config file, look only in the current
971 -- directory, i.e. return input argument unchanged. Also look
972 -- only in the current directory if we are looking for a .dg
973 -- file (happens in -gnatD mode)
976 or else (Debug_Generated_Code
977 and then Name_Len > 3
979 (Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg"
981 (Hostparm.OpenVMS and then
982 Name_Buffer (Name_Len - 2 .. Name_Len) = "_dg")))
986 -- If we are trying to find the current main file just look in the
987 -- directory where the user said it was.
989 elsif Look_In_Primary_Directory_For_Current_Main
990 and then Current_Main = N
992 return Locate_File (N, T, Primary_Directory, File_Name);
994 -- Otherwise do standard search for source file
997 -- Check the mapping of this file name
999 File := Mapped_Path_Name (N);
1001 -- If the file name is mapped to a path name, return the
1002 -- corresponding path name
1004 if File /= No_File then
1005 -- For locally removed file, Error_Name is returned; then
1006 -- return No_File, indicating the file is not a source.
1008 if File = Error_Name then
1016 -- First place to look is in the primary directory (i.e. the same
1017 -- directory as the source) unless this has been disabled with -I-
1019 if Opt.Look_In_Primary_Dir then
1020 File := Locate_File (N, T, Primary_Directory, File_Name);
1022 if File /= No_File then
1027 -- Finally look in directories specified with switches -I/-aI/-aO
1030 Last_Dir := Lib_Search_Directories.Last;
1032 Last_Dir := Src_Search_Directories.Last;
1035 for D in Primary_Directory + 1 .. Last_Dir loop
1036 File := Locate_File (N, T, D, File_Name);
1038 if File /= No_File then
1048 -----------------------
1049 -- Find_Program_Name --
1050 -----------------------
1052 procedure Find_Program_Name is
1053 Command_Name : String (1 .. Len_Arg (0));
1054 Cindex1 : Integer := Command_Name'First;
1055 Cindex2 : Integer := Command_Name'Last;
1058 Fill_Arg (Command_Name'Address, 0);
1060 -- The program name might be specified by a full path name. However,
1061 -- we don't want to print that all out in an error message, so the
1062 -- path might need to be stripped away.
1064 for J in reverse Cindex1 .. Cindex2 loop
1065 if Is_Directory_Separator (Command_Name (J)) then
1071 -- Command_Name(Cindex1 .. Cindex2) is now the equivalent of the
1072 -- POSIX command "basename argv[0]"
1074 -- Strip off any versioning information such as found on VMS.
1075 -- This would take the form of TOOL.exe followed by a ";" or "."
1076 -- and a sequence of one or more numbers.
1078 if Command_Name (Cindex2) in '0' .. '9' then
1079 for J in reverse Cindex1 .. Cindex2 loop
1080 if Command_Name (J) = '.' or Command_Name (J) = ';' then
1085 exit when Command_Name (J) not in '0' .. '9';
1089 -- Strip off any executable extension (usually nothing or .exe)
1090 -- but formally reported by autoconf in the variable EXEEXT
1092 if Cindex2 - Cindex1 >= 4 then
1093 if To_Lower (Command_Name (Cindex2 - 3)) = '.'
1094 and then To_Lower (Command_Name (Cindex2 - 2)) = 'e
'
1095 and then To_Lower (Command_Name (Cindex2 - 1)) = 'x
'
1096 and then To_Lower (Command_Name (Cindex2)) = 'e
'
1098 Cindex2 := Cindex2 - 4;
1102 Name_Len := Cindex2 - Cindex1 + 1;
1103 Name_Buffer (1 .. Name_Len) := Command_Name (Cindex1 .. Cindex2);
1104 end Find_Program_Name;
1106 ------------------------
1107 -- Full_Lib_File_Name --
1108 ------------------------
1110 function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type is
1112 return Find_File (N, Library);
1113 end Full_Lib_File_Name;
1115 ----------------------------
1116 -- Full_Library_Info_Name --
1117 ----------------------------
1119 function Full_Library_Info_Name return File_Name_Type is
1121 return Current_Full_Lib_Name;
1122 end Full_Library_Info_Name;
1124 ---------------------------
1125 -- Full_Object_File_Name --
1126 ---------------------------
1128 function Full_Object_File_Name return File_Name_Type is
1130 return Current_Full_Obj_Name;
1131 end Full_Object_File_Name;
1133 ----------------------
1134 -- Full_Source_Name --
1135 ----------------------
1137 function Full_Source_Name return File_Name_Type is
1139 return Current_Full_Source_Name;
1140 end Full_Source_Name;
1142 ----------------------
1143 -- Full_Source_Name --
1144 ----------------------
1146 function Full_Source_Name (N : File_Name_Type) return File_Name_Type is
1148 return Smart_Find_File (N, Source);
1149 end Full_Source_Name;
1155 function Get_Directory (Name : File_Name_Type) return File_Name_Type is
1157 Get_Name_String (Name);
1159 for J in reverse 1 .. Name_Len loop
1160 if Is_Directory_Separator (Name_Buffer (J)) then
1166 Name_Len := Hostparm.Normalized_CWD'Length;
1167 Name_Buffer (1 .. Name_Len) := Hostparm.Normalized_CWD;
1171 --------------------------
1172 -- Get_Next_Dir_In_Path --
1173 --------------------------
1175 Search_Path_Pos : Integer;
1176 -- Keeps track of current position in search path. Initialized by the
1177 -- call to Get_Next_Dir_In_Path_Init, updated by Get_Next_Dir_In_Path.
1179 function Get_Next_Dir_In_Path
1180 (Search_Path : String_Access) return String_Access
1182 Lower_Bound : Positive := Search_Path_Pos;
1183 Upper_Bound : Positive;
1187 while Lower_Bound <= Search_Path'Last
1188 and then Search_Path.all (Lower_Bound) = Path_Separator
1190 Lower_Bound := Lower_Bound + 1;
1193 exit when Lower_Bound > Search_Path'Last;
1195 Upper_Bound := Lower_Bound;
1196 while Upper_Bound <= Search_Path'Last
1197 and then Search_Path.all (Upper_Bound) /= Path_Separator
1199 Upper_Bound := Upper_Bound + 1;
1202 Search_Path_Pos := Upper_Bound;
1203 return new String'(Search_Path
.all (Lower_Bound
.. Upper_Bound
- 1));
1207 end Get_Next_Dir_In_Path
;
1209 -------------------------------
1210 -- Get_Next_Dir_In_Path_Init --
1211 -------------------------------
1213 procedure Get_Next_Dir_In_Path_Init
(Search_Path
: String_Access
) is
1215 Search_Path_Pos
:= Search_Path
'First;
1216 end Get_Next_Dir_In_Path_Init
;
1218 --------------------------------------
1219 -- Get_Primary_Src_Search_Directory --
1220 --------------------------------------
1222 function Get_Primary_Src_Search_Directory
return String_Ptr
is
1224 return Src_Search_Directories
.Table
(Primary_Directory
);
1225 end Get_Primary_Src_Search_Directory
;
1227 ------------------------
1228 -- Get_RTS_Search_Dir --
1229 ------------------------
1231 function Get_RTS_Search_Dir
1232 (Search_Dir
: String;
1233 File_Type
: Search_File_Type
) return String_Ptr
1235 procedure Get_Current_Dir
1236 (Dir
: System
.Address
;
1237 Length
: System
.Address
);
1238 pragma Import
(C
, Get_Current_Dir
, "__gnat_get_current_dir");
1241 pragma Import
(C
, Max_Path
, "__gnat_max_path_len");
1242 -- Maximum length of a path name
1244 Current_Dir
: String_Ptr
;
1245 Default_Search_Dir
: String_Access
;
1246 Default_Suffix_Dir
: String_Access
;
1247 Local_Search_Dir
: String_Access
;
1248 Norm_Search_Dir
: String_Access
;
1249 Result_Search_Dir
: String_Access
;
1250 Search_File
: String_Access
;
1251 Temp_String
: String_Ptr
;
1254 -- Add a directory separator at the end of the directory if necessary
1255 -- so that we can directly append a file to the directory
1257 if Search_Dir
(Search_Dir
'Last) /= Directory_Separator
then
1259 new String'(Search_Dir & String'(1 => Directory_Separator
));
1261 Local_Search_Dir
:= new String'(Search_Dir);
1264 if File_Type = Include then
1265 Search_File := Include_Search_File;
1266 Default_Suffix_Dir := new String'("adainclude");
1268 Search_File
:= Objects_Search_File
;
1269 Default_Suffix_Dir
:= new String'("adalib");
1272 Norm_Search_Dir := To_Canonical_Path_Spec (Local_Search_Dir.all);
1274 if Is_Absolute_Path (Norm_Search_Dir.all) then
1276 -- We first verify if there is a directory Include_Search_Dir
1277 -- containing default search directories
1280 := Read_Default_Search_Dirs (Norm_Search_Dir,
1283 Default_Search_Dir :=
1284 new String'(Norm_Search_Dir
.all & Default_Suffix_Dir
.all);
1285 Free
(Norm_Search_Dir
);
1287 if Result_Search_Dir
/= null then
1288 return String_Ptr
(Result_Search_Dir
);
1289 elsif Is_Directory
(Default_Search_Dir
.all) then
1290 return String_Ptr
(Default_Search_Dir
);
1295 -- Search in the current directory
1298 -- Get the current directory
1301 Buffer
: String (1 .. Max_Path
+ 2);
1302 Path_Len
: Natural := Max_Path
;
1305 Get_Current_Dir
(Buffer
'Address, Path_Len
'Address);
1307 if Buffer
(Path_Len
) /= Directory_Separator
then
1308 Path_Len
:= Path_Len
+ 1;
1309 Buffer
(Path_Len
) := Directory_Separator
;
1312 Current_Dir
:= new String'(Buffer (1 .. Path_Len));
1316 new String'(Current_Dir
.all & Local_Search_Dir
.all);
1318 Result_Search_Dir
:=
1319 Read_Default_Search_Dirs
(Norm_Search_Dir
, Search_File
, null);
1321 Default_Search_Dir
:=
1322 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1324 Free (Norm_Search_Dir);
1326 if Result_Search_Dir /= null then
1327 return String_Ptr (Result_Search_Dir);
1329 elsif Is_Directory (Default_Search_Dir.all) then
1330 return String_Ptr (Default_Search_Dir);
1333 -- Search in Search_Dir_Prefix/Search_Dir
1337 (Update_Path
(Search_Dir_Prefix
).all & Local_Search_Dir
.all);
1339 Result_Search_Dir
:=
1340 Read_Default_Search_Dirs
(Norm_Search_Dir
, Search_File
, null);
1342 Default_Search_Dir
:=
1343 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
1345 Free (Norm_Search_Dir);
1347 if Result_Search_Dir /= null then
1348 return String_Ptr (Result_Search_Dir);
1350 elsif Is_Directory (Default_Search_Dir.all) then
1351 return String_Ptr (Default_Search_Dir);
1354 -- We finally search in Search_Dir_Prefix/rts-Search_Dir
1357 new String'(Update_Path
(Search_Dir_Prefix
).all & "rts-");
1360 new String'(Temp_String.all & Local_Search_Dir.all);
1362 Result_Search_Dir :=
1363 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
1365 Default_Search_Dir :=
1366 new String'(Norm_Search_Dir
.all & Default_Suffix_Dir
.all);
1367 Free
(Norm_Search_Dir
);
1369 if Result_Search_Dir
/= null then
1370 return String_Ptr
(Result_Search_Dir
);
1372 elsif Is_Directory
(Default_Search_Dir
.all) then
1373 return String_Ptr
(Default_Search_Dir
);
1381 end Get_RTS_Search_Dir
;
1383 --------------------------------
1384 -- Include_Dir_Default_Prefix --
1385 --------------------------------
1387 function Include_Dir_Default_Prefix
return String is
1388 Include_Dir
: String_Access
:=
1389 String_Access
(Update_Path
(Include_Dir_Default_Name
));
1392 if Include_Dir
= null then
1397 Result
: constant String := Include_Dir
.all;
1403 end Include_Dir_Default_Prefix
;
1409 procedure Initialize
is
1411 Number_File_Names
:= 0;
1412 Current_File_Name_Index
:= 0;
1414 Src_Search_Directories
.Init
;
1415 Lib_Search_Directories
.Init
;
1417 -- Start off by setting all suppress options to False, these will
1418 -- be reset later (turning some on if -gnato is not specified, and
1419 -- turning all of them on if -gnatp is specified).
1421 Suppress_Options
:= (others => False);
1423 -- Reserve the first slot in the search paths table. This is the
1424 -- directory of the main source file or main library file and is
1425 -- filled in by each call to Next_Main_Source/Next_Main_Lib_File with
1426 -- the directory specified for this main source or library file. This
1427 -- is the directory which is searched first by default. This default
1428 -- search is inhibited by the option -I- for both source and library
1431 Src_Search_Directories
.Set_Last
(Primary_Directory
);
1432 Src_Search_Directories
.Table
(Primary_Directory
) := new String'("");
1434 Lib_Search_Directories.Set_Last (Primary_Directory);
1435 Lib_Search_Directories.Table (Primary_Directory) := new String'("");
1438 ----------------------------
1439 -- Is_Directory_Separator --
1440 ----------------------------
1442 function Is_Directory_Separator
(C
: Character) return Boolean is
1444 -- In addition to the default directory_separator allow the '/' to
1445 -- act as separator since this is allowed in MS-DOS, Windows 95/NT,
1446 -- and OS2 ports. On VMS, the situation is more complicated because
1447 -- there are two characters to check for.
1450 C
= Directory_Separator
1452 or else (Hostparm
.OpenVMS
1453 and then (C
= ']' or else C
= ':'));
1454 end Is_Directory_Separator
;
1456 -------------------------
1457 -- Is_Readonly_Library --
1458 -------------------------
1460 function Is_Readonly_Library
(File
: File_Name_Type
) return Boolean is
1462 Get_Name_String
(File
);
1464 pragma Assert
(Name_Buffer
(Name_Len
- 3 .. Name_Len
) = ".ali");
1466 return not Is_Writable_File
(Name_Buffer
(1 .. Name_Len
));
1467 end Is_Readonly_Library
;
1473 function Lib_File_Name
1474 (Source_File
: File_Name_Type
;
1475 Munit_Index
: Nat
:= 0) return File_Name_Type
1478 Get_Name_String
(Source_File
);
1480 for J
in reverse 2 .. Name_Len
loop
1481 if Name_Buffer
(J
) = '.' then
1487 if Munit_Index
/= 0 then
1488 Add_Char_To_Name_Buffer
(Multi_Unit_Index_Character
);
1489 Add_Nat_To_Name_Buffer
(Munit_Index
);
1492 Add_Char_To_Name_Buffer
('.');
1493 Add_Str_To_Name_Buffer
(ALI_Suffix
.all);
1497 ------------------------
1498 -- Library_File_Stamp --
1499 ------------------------
1501 function Library_File_Stamp
(N
: File_Name_Type
) return Time_Stamp_Type
is
1503 return File_Stamp
(Find_File
(N
, Library
));
1504 end Library_File_Stamp
;
1510 function Locate_File
1511 (N
: File_Name_Type
;
1514 Name
: String) return File_Name_Type
1516 Dir_Name
: String_Ptr
;
1519 -- If Name is already an absolute path, do not look for a directory
1521 if Is_Absolute_Path
(Name
) then
1524 elsif T
= Library
then
1525 Dir_Name
:= Lib_Search_Directories
.Table
(Dir
);
1527 else pragma Assert
(T
/= Config
);
1528 Dir_Name
:= Src_Search_Directories
.Table
(Dir
);
1532 Full_Name
: String (1 .. Dir_Name
'Length + Name
'Length);
1535 Full_Name
(1 .. Dir_Name
'Length) := Dir_Name
.all;
1536 Full_Name
(Dir_Name
'Length + 1 .. Full_Name
'Length) := Name
;
1538 if not Is_Regular_File
(Full_Name
) then
1542 -- If the file is in the current directory then return N itself
1544 if Dir_Name
'Length = 0 then
1547 Name_Len
:= Full_Name
'Length;
1548 Name_Buffer
(1 .. Name_Len
) := Full_Name
;
1555 -------------------------------
1556 -- Matching_Full_Source_Name --
1557 -------------------------------
1559 function Matching_Full_Source_Name
1560 (N
: File_Name_Type
;
1561 T
: Time_Stamp_Type
) return File_Name_Type
1564 Get_Name_String
(N
);
1567 File_Name
: constant String := Name_Buffer
(1 .. Name_Len
);
1568 File
: File_Name_Type
:= No_File
;
1572 if Opt
.Look_In_Primary_Dir
then
1573 File
:= Locate_File
(N
, Source
, Primary_Directory
, File_Name
);
1575 if File
/= No_File
and then T
= File_Stamp
(N
) then
1580 Last_Dir
:= Src_Search_Directories
.Last
;
1582 for D
in Primary_Directory
+ 1 .. Last_Dir
loop
1583 File
:= Locate_File
(N
, Source
, D
, File_Name
);
1585 if File
/= No_File
and then T
= File_Stamp
(File
) then
1592 end Matching_Full_Source_Name
;
1598 function More_Files
return Boolean is
1600 return (Current_File_Name_Index
< Number_File_Names
);
1603 -------------------------------
1604 -- Nb_Dir_In_Obj_Search_Path --
1605 -------------------------------
1607 function Nb_Dir_In_Obj_Search_Path
return Natural is
1609 if Opt
.Look_In_Primary_Dir
then
1610 return Lib_Search_Directories
.Last
- Primary_Directory
+ 1;
1612 return Lib_Search_Directories
.Last
- Primary_Directory
;
1614 end Nb_Dir_In_Obj_Search_Path
;
1616 -------------------------------
1617 -- Nb_Dir_In_Src_Search_Path --
1618 -------------------------------
1620 function Nb_Dir_In_Src_Search_Path
return Natural is
1622 if Opt
.Look_In_Primary_Dir
then
1623 return Src_Search_Directories
.Last
- Primary_Directory
+ 1;
1625 return Src_Search_Directories
.Last
- Primary_Directory
;
1627 end Nb_Dir_In_Src_Search_Path
;
1629 --------------------
1630 -- Next_Main_File --
1631 --------------------
1633 function Next_Main_File
return File_Name_Type
is
1634 File_Name
: String_Ptr
;
1635 Dir_Name
: String_Ptr
;
1639 pragma Assert
(More_Files
);
1641 Current_File_Name_Index
:= Current_File_Name_Index
+ 1;
1643 -- Get the file and directory name
1645 File_Name
:= File_Names
(Current_File_Name_Index
);
1646 Fptr
:= File_Name
'First;
1648 for J
in reverse File_Name
'Range loop
1649 if File_Name
(J
) = Directory_Separator
1650 or else File_Name
(J
) = '/'
1652 if J
= File_Name
'Last then
1653 Fail
("File name missing");
1661 -- Save name of directory in which main unit resides for use in
1662 -- locating other units
1664 Dir_Name
:= new String'(File_Name (File_Name'First .. Fptr - 1));
1666 case Running_Program is
1669 Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
1670 Look_In_Primary_Directory_For_Current_Main := True;
1673 Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
1675 if Fptr > File_Name'First then
1676 Look_In_Primary_Directory_For_Current_Main := True;
1679 when Binder | Gnatls =>
1680 Dir_Name := Normalize_Directory_Name (Dir_Name.all);
1681 Lib_Search_Directories.Table (Primary_Directory) := Dir_Name;
1687 Name_Len := File_Name'Last - Fptr + 1;
1688 Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last);
1689 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
1690 Current_Main := File_Name_Type (Name_Find);
1692 -- In the gnatmake case, the main file may have not have the
1693 -- extension. Try ".adb" first then ".ads"
1695 if Running_Program = Make then
1697 Orig_Main : constant File_Name_Type := Current_Main;
1700 if Strip_Suffix (Orig_Main) = Orig_Main then
1701 Current_Main := Append_Suffix_To_File_Name (Orig_Main, ".adb");
1703 if Full_Source_Name (Current_Main) = No_File then
1705 Append_Suffix_To_File_Name (Orig_Main, ".ads");
1707 if Full_Source_Name (Current_Main) = No_File then
1708 Current_Main := Orig_Main;
1715 return Current_Main;
1718 ------------------------------
1719 -- Normalize_Directory_Name --
1720 ------------------------------
1722 function Normalize_Directory_Name (Directory : String) return String_Ptr is
1724 function Is_Quoted (Path : String) return Boolean;
1725 pragma Inline (Is_Quoted);
1726 -- Returns true if Path is quoted (either double or single quotes)
1732 function Is_Quoted (Path : String) return Boolean is
1733 First : constant Character := Path (Path'First);
1734 Last : constant Character := Path (Path'Last);
1737 if (First = ''' and then Last = ''')
1739 (First = '"' and then Last = '"')
1747 Result : String_Ptr;
1749 -- Start of processing for Normalize_Directory_Name
1752 if Directory'Length = 0 then
1753 Result := new String'(Hostparm
.Normalized_CWD
);
1755 elsif Is_Directory_Separator
(Directory
(Directory
'Last)) then
1756 Result
:= new String'(Directory);
1758 elsif Is_Quoted (Directory) then
1760 -- This is a quoted string, it certainly means that the directory
1761 -- contains some spaces for example. We can safely remove the quotes
1762 -- here as the OS_Lib.Normalize_Arguments will be called before any
1763 -- spawn routines. This ensure that quotes will be added when needed.
1765 Result := new String (1 .. Directory'Length - 1);
1766 Result (1 .. Directory'Length - 2) :=
1767 Directory (Directory'First + 1 .. Directory'Last - 1);
1768 Result (Result'Last) := Directory_Separator;
1771 Result := new String (1 .. Directory'Length + 1);
1772 Result (1 .. Directory'Length) := Directory;
1773 Result (Directory'Length + 1) := Directory_Separator;
1777 end Normalize_Directory_Name;
1779 ---------------------
1780 -- Number_Of_Files --
1781 ---------------------
1783 function Number_Of_Files return Int is
1785 return Number_File_Names;
1786 end Number_Of_Files;
1788 -------------------------------
1789 -- Object_Dir_Default_Prefix --
1790 -------------------------------
1792 function Object_Dir_Default_Prefix return String is
1793 Object_Dir : String_Access :=
1794 String_Access (Update_Path (Object_Dir_Default_Name));
1797 if Object_Dir = null then
1802 Result : constant String := Object_Dir.all;
1808 end Object_Dir_Default_Prefix;
1810 ----------------------
1811 -- Object_File_Name --
1812 ----------------------
1814 function Object_File_Name (N : File_Name_Type) return File_Name_Type is
1820 Get_Name_String (N);
1821 Name_Len := Name_Len - ALI_Suffix'Length - 1;
1823 for J in Target_Object_Suffix'Range loop
1824 Name_Len := Name_Len + 1;
1825 Name_Buffer (Name_Len) := Target_Object_Suffix (J);
1829 end Object_File_Name;
1831 --------------------------
1832 -- OS_Time_To_GNAT_Time --
1833 --------------------------
1835 function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type is
1836 GNAT_Time : Time_Stamp_Type;
1846 GM_Split (T, Y, Mo, D, H, Mn, S);
1852 Minutes => Nat (Mn),
1857 end OS_Time_To_GNAT_Time;
1863 function Program_Name (Nam : String) return String_Access is
1864 Res : String_Access;
1867 -- Get the name of the current program being executed
1871 -- Find the target prefix if any, for the cross compilation case
1872 -- for instance in "alpha-dec-vxworks-gcc" the target prefix is
1873 -- "alpha-dec-vxworks-"
1875 while Name_Len > 0 loop
1877 -- All done if we find the last hyphen
1879 if Name_Buffer (Name_Len) = '-' then
1882 -- If directory separator found, we don't want to look further
1883 -- since in this case, no prefix has been found.
1885 elsif Is_Directory_Separator (Name_Buffer (Name_Len)) then
1890 Name_Len := Name_Len - 1;
1893 -- Create the new program name
1895 Res := new String (1 .. Name_Len + Nam'Length);
1896 Res.all (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
1897 Res.all (Name_Len + 1 .. Name_Len + Nam'Length) := Nam;
1901 ------------------------------
1902 -- Read_Default_Search_Dirs --
1903 ------------------------------
1905 function Read_Default_Search_Dirs
1906 (Search_Dir_Prefix : String_Access;
1907 Search_File : String_Access;
1908 Search_Dir_Default_Name : String_Access) return String_Access
1910 Prefix_Len : constant Integer := Search_Dir_Prefix.all'Length;
1911 Buffer : String (1 .. Prefix_Len + Search_File.all'Length + 1);
1912 File_FD : File_Descriptor;
1913 S, S1 : String_Access;
1916 Actual_Len : Integer;
1919 Prev_Was_Separator : Boolean;
1920 Nb_Relative_Dir : Integer;
1922 function Is_Relative (S : String; K : Positive) return Boolean;
1923 pragma Inline (Is_Relative);
1924 -- Returns True if a relative directory specification is found
1925 -- in S at position K, False otherwise.
1931 function Is_Relative (S : String; K : Positive) return Boolean is
1933 return not Is_Absolute_Path (S (K .. S'Last));
1936 -- Start of processing for Read_Default_Search_Dirs
1939 -- Construct a C compatible character string buffer
1941 Buffer (1 .. Search_Dir_Prefix.all'Length)
1942 := Search_Dir_Prefix.all;
1943 Buffer (Search_Dir_Prefix.all'Length + 1 .. Buffer'Last - 1)
1945 Buffer (Buffer'Last) := ASCII.NUL;
1947 File_FD := Open_Read (Buffer'Address, Binary);
1948 if File_FD = Invalid_FD then
1949 return Search_Dir_Default_Name;
1952 Len := Integer (File_Length (File_FD));
1954 -- An extra character for a trailing Path_Separator is allocated
1956 S := new String (1 .. Len + 1);
1957 S (Len + 1) := Path_Separator;
1959 -- Read the file. Note that the loop is not necessary since the
1960 -- whole file is read at once except on VMS.
1964 while Actual_Len /= 0 loop
1965 Actual_Len := Read (File_FD, S (Curr)'Address, Len);
1966 Curr := Curr + Actual_Len;
1969 -- Process the file, translating line and file ending
1970 -- control characters to a path separator character.
1972 Prev_Was_Separator := True;
1973 Nb_Relative_Dir := 0;
1974 for J in 1 .. Len loop
1975 if S (J) in ASCII.NUL .. ASCII.US
1978 S (J) := Path_Separator;
1981 if S (J) = Path_Separator then
1982 Prev_Was_Separator := True;
1984 if Prev_Was_Separator and then Is_Relative (S.all, J) then
1985 Nb_Relative_Dir := Nb_Relative_Dir + 1;
1988 Prev_Was_Separator := False;
1992 if Nb_Relative_Dir = 0 then
1996 -- Add the Search_Dir_Prefix to all relative paths
1998 S1 := new String (1 .. S'Length + Nb_Relative_Dir * Prefix_Len);
2000 Prev_Was_Separator := True;
2001 for J in 1 .. Len + 1 loop
2002 if S (J) = Path_Separator then
2003 Prev_Was_Separator := True;
2006 if Prev_Was_Separator and then Is_Relative (S.all, J) then
2007 S1 (J1 .. J1 + Prefix_Len - 1) := Search_Dir_Prefix.all;
2008 J1 := J1 + Prefix_Len;
2011 Prev_Was_Separator := False;
2019 end Read_Default_Search_Dirs;
2021 -----------------------
2022 -- Read_Library_Info --
2023 -----------------------
2025 function Read_Library_Info
2026 (Lib_File : File_Name_Type;
2027 Fatal_Err : Boolean := False) return Text_Buffer_Ptr
2029 Lib_FD : File_Descriptor;
2030 -- The file descriptor for the current library file. A negative value
2031 -- indicates failure to open the specified source file.
2033 Text : Text_Buffer_Ptr;
2034 -- Allocated text buffer
2037 -- For the calls to Close
2040 Current_Full_Lib_Name := Find_File (Lib_File, Library);
2041 Current_Full_Obj_Name := Object_File_Name (Current_Full_Lib_Name);
2043 if Current_Full_Lib_Name = No_File then
2045 Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
2047 Current_Full_Obj_Stamp := Empty_Time_Stamp;
2052 Get_Name_String (Current_Full_Lib_Name);
2053 Name_Buffer (Name_Len + 1) := ASCII.NUL;
2055 -- Open the library FD, note that we open in binary mode, because as
2056 -- documented in the spec, the caller is expected to handle either
2057 -- DOS or Unix mode files, and there is no point in wasting time on
2058 -- text translation when it is not required.
2060 Lib_FD := Open_Read (Name_Buffer'Address, Binary);
2062 if Lib_FD = Invalid_FD then
2064 Fail ("Cannot open: ", Name_Buffer (1 .. Name_Len));
2066 Current_Full_Obj_Stamp := Empty_Time_Stamp;
2071 -- Check for object file consistency if requested
2073 if Opt.Check_Object_Consistency then
2074 Current_Full_Lib_Stamp := File_Stamp (Current_Full_Lib_Name);
2075 Current_Full_Obj_Stamp := File_Stamp (Current_Full_Obj_Name);
2077 if Current_Full_Obj_Stamp (1) = ' ' then
2079 -- When the library is readonly, always assume that
2080 -- the object is consistent.
2082 if Is_Readonly_Library (Current_Full_Lib_Name) then
2083 Current_Full_Obj_Stamp := Current_Full_Lib_Stamp;
2085 elsif Fatal_Err then
2086 Get_Name_String (Current_Full_Obj_Name);
2087 Close (Lib_FD, Status);
2088 -- No need to check the status, we fail anyway
2090 Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
2093 Current_Full_Obj_Stamp := Empty_Time_Stamp;
2094 Close (Lib_FD, Status);
2096 -- No need to check the status, we return null anyway
2103 -- Read data from the file
2106 Len : constant Integer := Integer (File_Length (Lib_FD));
2107 -- Length of source file text. If it doesn't fit in an integer
2108 -- we're probably stuck anyway (>2 gigs of source seems a lot!)
2110 Actual_Len : Integer := 0;
2112 Lo : constant Text_Ptr := 0;
2113 -- Low bound for allocated text buffer
2115 Hi : Text_Ptr := Text_Ptr (Len);
2116 -- High bound for allocated text buffer. Note length is Len + 1
2117 -- which allows for extra EOF character at the end of the buffer.
2120 -- Allocate text buffer. Note extra character at end for EOF
2122 Text := new Text_Buffer (Lo .. Hi);
2124 -- Some systems (e.g. VMS) have file types that require one
2125 -- read per line, so read until we get the Len bytes or until
2126 -- there are no more characters.
2130 Actual_Len := Read (Lib_FD, Text (Hi)'Address, Len);
2131 Hi := Hi + Text_Ptr (Actual_Len);
2132 exit when Actual_Len = Len or Actual_Len <= 0;
2138 -- Read is complete, close file and we are done
2140 Close (Lib_FD, Status);
2141 -- The status should never be False. But, if it is, what can we do?
2142 -- So, we don't test it.
2146 end Read_Library_Info;
2148 ----------------------
2149 -- Read_Source_File --
2150 ----------------------
2152 procedure Read_Source_File
2153 (N : File_Name_Type;
2155 Hi : out Source_Ptr;
2156 Src : out Source_Buffer_Ptr;
2157 T : File_Type := Source)
2159 Source_File_FD : File_Descriptor;
2160 -- The file descriptor for the current source file. A negative value
2161 -- indicates failure to open the specified source file.
2164 -- Length of file. Assume no more than 2 gigabytes of source!
2166 Actual_Len : Integer;
2169 -- For the call to Close
2172 Current_Full_Source_Name := Find_File (N, T);
2173 Current_Full_Source_Stamp := File_Stamp (Current_Full_Source_Name);
2175 if Current_Full_Source_Name = No_File then
2177 -- If we were trying to access the main file and we could not
2178 -- find it we have an error.
2180 if N = Current_Main then
2181 Get_Name_String (N);
2182 Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
2190 Get_Name_String (Current_Full_Source_Name);
2191 Name_Buffer (Name_Len + 1) := ASCII.NUL;
2193 -- Open the source FD, note that we open in binary mode, because as
2194 -- documented in the spec, the caller is expected to handle either
2195 -- DOS or Unix mode files, and there is no point in wasting time on
2196 -- text translation when it is not required.
2198 Source_File_FD := Open_Read (Name_Buffer'Address, Binary);
2200 if Source_File_FD = Invalid_FD then
2206 -- Prepare to read data from the file
2208 Len := Integer (File_Length (Source_File_FD));
2210 -- Set Hi so that length is one more than the physical length,
2211 -- allowing for the extra EOF character at the end of the buffer
2213 Hi := Lo + Source_Ptr (Len);
2215 -- Do the actual read operation
2218 subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
2219 -- Physical buffer allocated
2221 type Actual_Source_Ptr is access Actual_Source_Buffer;
2222 -- This is the pointer type for the physical buffer allocated
2224 Actual_Ptr : constant Actual_Source_Ptr := new Actual_Source_Buffer;
2225 -- And this is the actual physical buffer
2228 -- Allocate source buffer, allowing extra character at end for EOF
2230 -- Some systems (e.g. VMS) have file types that require one
2231 -- read per line, so read until we get the Len bytes or until
2232 -- there are no more characters.
2236 Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len);
2237 Hi := Hi + Source_Ptr (Actual_Len);
2238 exit when Actual_Len = Len or Actual_Len <= 0;
2241 Actual_Ptr (Hi) := EOF;
2243 -- Now we need to work out the proper virtual origin pointer to
2244 -- return. This is exactly Actual_Ptr (0)'Address, but we have
2245 -- to be careful to suppress checks to compute this address.
2248 pragma Suppress (All_Checks);
2250 pragma Warnings (Off);
2251 -- This use of unchecked conversion is aliasing safe
2253 function To_Source_Buffer_Ptr is new
2254 Unchecked_Conversion (Address, Source_Buffer_Ptr);
2256 pragma Warnings (On);
2259 Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
2263 -- Read is complete, get time stamp and close file and we are done
2265 Close (Source_File_FD, Status);
2267 -- The status should never be False. But, if it is, what can we do?
2268 -- So, we don't test it.
2270 end Read_Source_File;
2276 function Relocate_Path
2278 Path : String) return String_Ptr
2282 procedure set_std_prefix (S : String; Len : Integer);
2283 pragma Import (C, set_std_prefix);
2286 if Std_Prefix = null then
2287 Std_Prefix := Executable_Prefix;
2289 if Std_Prefix.all /= "" then
2291 -- Remove trailing directory separator when calling set_std_prefix
2293 set_std_prefix (Std_Prefix.all, Std_Prefix'Length - 1);
2297 if Path (Prefix'Range) = Prefix then
2298 if Std_Prefix.all /= "" then
2300 (1 .. Std_Prefix'Length + Path'Last - Prefix'Last);
2301 S (1 .. Std_Prefix'Length) := Std_Prefix.all;
2302 S (Std_Prefix'Length + 1 .. S'Last) :=
2303 Path (Prefix'Last + 1 .. Path'Last);
2308 return new String'(Path
);
2315 procedure Set_Program
(P
: Program_Type
) is
2318 Fail
("Set_Program called twice");
2321 Program_Set
:= True;
2322 Running_Program
:= P
;
2329 function Shared_Lib
(Name
: String) return String is
2330 Library
: String (1 .. Name
'Length + Library_Version
'Length + 3);
2331 -- 3 = 2 for "-l" + 1 for "-" before lib version
2334 Library
(1 .. 2) := "-l";
2335 Library
(3 .. 2 + Name
'Length) := Name
;
2336 Library
(3 + Name
'Length) := '-';
2337 Library
(4 + Name
'Length .. Library
'Last) := Library_Version
;
2339 if OpenVMS_On_Target
then
2340 for K
in Library
'First + 2 .. Library
'Last loop
2341 if Library
(K
) = '.' or else Library
(K
) = '-' then
2350 ----------------------
2351 -- Smart_File_Stamp --
2352 ----------------------
2354 function Smart_File_Stamp
2355 (N
: File_Name_Type
;
2356 T
: File_Type
) return Time_Stamp_Type
2358 Time_Stamp
: Time_Stamp_Type
;
2361 if not File_Cache_Enabled
then
2362 return File_Stamp
(Find_File
(N
, T
));
2365 Time_Stamp
:= File_Stamp_Hash_Table
.Get
(N
);
2367 if Time_Stamp
(1) = ' ' then
2368 Time_Stamp
:= File_Stamp
(Smart_Find_File
(N
, T
));
2369 File_Stamp_Hash_Table
.Set
(N
, Time_Stamp
);
2373 end Smart_File_Stamp
;
2375 ---------------------
2376 -- Smart_Find_File --
2377 ---------------------
2379 function Smart_Find_File
2380 (N
: File_Name_Type
;
2381 T
: File_Type
) return File_Name_Type
2383 Full_File_Name
: File_Name_Type
;
2386 if not File_Cache_Enabled
then
2387 return Find_File
(N
, T
);
2390 Full_File_Name
:= File_Name_Hash_Table
.Get
(N
);
2392 if Full_File_Name
= No_File
then
2393 Full_File_Name
:= Find_File
(N
, T
);
2394 File_Name_Hash_Table
.Set
(N
, Full_File_Name
);
2397 return Full_File_Name
;
2398 end Smart_Find_File
;
2400 ----------------------
2401 -- Source_File_Data --
2402 ----------------------
2404 procedure Source_File_Data
(Cache
: Boolean) is
2406 File_Cache_Enabled
:= Cache
;
2407 end Source_File_Data
;
2409 -----------------------
2410 -- Source_File_Stamp --
2411 -----------------------
2413 function Source_File_Stamp
(N
: File_Name_Type
) return Time_Stamp_Type
is
2415 return Smart_File_Stamp
(N
, Source
);
2416 end Source_File_Stamp
;
2418 ---------------------
2419 -- Strip_Directory --
2420 ---------------------
2422 function Strip_Directory
(Name
: File_Name_Type
) return File_Name_Type
is
2424 Get_Name_String
(Name
);
2426 for J
in reverse 1 .. Name_Len
- 1 loop
2428 -- If we find the last directory separator
2430 if Is_Directory_Separator
(Name_Buffer
(J
)) then
2432 -- Return the part of Name that follows this last directory
2435 Name_Buffer
(1 .. Name_Len
- J
) := Name_Buffer
(J
+ 1 .. Name_Len
);
2436 Name_Len
:= Name_Len
- J
;
2441 -- There were no directory separator, just return Name
2444 end Strip_Directory
;
2450 function Strip_Suffix
(Name
: File_Name_Type
) return File_Name_Type
is
2452 Get_Name_String
(Name
);
2454 for J
in reverse 2 .. Name_Len
loop
2456 -- If we found the last '.', return part of Name that precedes it
2458 if Name_Buffer
(J
) = '.' then
2467 ---------------------------
2468 -- To_Canonical_Dir_Spec --
2469 ---------------------------
2471 function To_Canonical_Dir_Spec
2473 Prefix_Style
: Boolean) return String_Access
2475 function To_Canonical_Dir_Spec
2476 (Host_Dir
: Address
;
2477 Prefix_Flag
: Integer) return Address
;
2478 pragma Import
(C
, To_Canonical_Dir_Spec
, "__gnat_to_canonical_dir_spec");
2480 C_Host_Dir
: String (1 .. Host_Dir
'Length + 1);
2481 Canonical_Dir_Addr
: Address
;
2482 Canonical_Dir_Len
: Integer;
2485 C_Host_Dir
(1 .. Host_Dir
'Length) := Host_Dir
;
2486 C_Host_Dir
(C_Host_Dir
'Last) := ASCII
.NUL
;
2488 if Prefix_Style
then
2489 Canonical_Dir_Addr
:= To_Canonical_Dir_Spec
(C_Host_Dir
'Address, 1);
2491 Canonical_Dir_Addr
:= To_Canonical_Dir_Spec
(C_Host_Dir
'Address, 0);
2493 Canonical_Dir_Len
:= C_String_Length
(Canonical_Dir_Addr
);
2495 if Canonical_Dir_Len
= 0 then
2498 return To_Path_String_Access
(Canonical_Dir_Addr
, Canonical_Dir_Len
);
2503 Fail
("erroneous directory spec: ", Host_Dir
);
2505 end To_Canonical_Dir_Spec
;
2507 ---------------------------
2508 -- To_Canonical_File_List --
2509 ---------------------------
2511 function To_Canonical_File_List
2512 (Wildcard_Host_File
: String;
2513 Only_Dirs
: Boolean) return String_Access_List_Access
2515 function To_Canonical_File_List_Init
2516 (Host_File
: Address
;
2517 Only_Dirs
: Integer) return Integer;
2518 pragma Import
(C
, To_Canonical_File_List_Init
,
2519 "__gnat_to_canonical_file_list_init");
2521 function To_Canonical_File_List_Next
return Address
;
2522 pragma Import
(C
, To_Canonical_File_List_Next
,
2523 "__gnat_to_canonical_file_list_next");
2525 procedure To_Canonical_File_List_Free
;
2526 pragma Import
(C
, To_Canonical_File_List_Free
,
2527 "__gnat_to_canonical_file_list_free");
2529 Num_Files
: Integer;
2530 C_Wildcard_Host_File
: String (1 .. Wildcard_Host_File
'Length + 1);
2533 C_Wildcard_Host_File
(1 .. Wildcard_Host_File
'Length) :=
2535 C_Wildcard_Host_File
(C_Wildcard_Host_File
'Last) := ASCII
.NUL
;
2537 -- Do the expansion and say how many there are
2539 Num_Files
:= To_Canonical_File_List_Init
2540 (C_Wildcard_Host_File
'Address, Boolean'Pos (Only_Dirs
));
2543 Canonical_File_List
: String_Access_List
(1 .. Num_Files
);
2544 Canonical_File_Addr
: Address
;
2545 Canonical_File_Len
: Integer;
2548 -- Retrieve the expanded directoy names and build the list
2550 for J
in 1 .. Num_Files
loop
2551 Canonical_File_Addr
:= To_Canonical_File_List_Next
;
2552 Canonical_File_Len
:= C_String_Length
(Canonical_File_Addr
);
2553 Canonical_File_List
(J
) := To_Path_String_Access
2554 (Canonical_File_Addr
, Canonical_File_Len
);
2557 -- Free up the storage
2559 To_Canonical_File_List_Free
;
2561 return new String_Access_List
'(Canonical_File_List);
2563 end To_Canonical_File_List;
2565 ----------------------------
2566 -- To_Canonical_File_Spec --
2567 ----------------------------
2569 function To_Canonical_File_Spec
2570 (Host_File : String) return String_Access
2572 function To_Canonical_File_Spec (Host_File : Address) return Address;
2574 (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
2576 C_Host_File : String (1 .. Host_File'Length + 1);
2577 Canonical_File_Addr : Address;
2578 Canonical_File_Len : Integer;
2581 C_Host_File (1 .. Host_File'Length) := Host_File;
2582 C_Host_File (C_Host_File'Last) := ASCII.NUL;
2584 Canonical_File_Addr := To_Canonical_File_Spec (C_Host_File'Address);
2585 Canonical_File_Len := C_String_Length (Canonical_File_Addr);
2587 if Canonical_File_Len = 0 then
2590 return To_Path_String_Access
2591 (Canonical_File_Addr, Canonical_File_Len);
2596 Fail ("erroneous file spec: ", Host_File);
2598 end To_Canonical_File_Spec;
2600 ----------------------------
2601 -- To_Canonical_Path_Spec --
2602 ----------------------------
2604 function To_Canonical_Path_Spec
2605 (Host_Path : String) return String_Access
2607 function To_Canonical_Path_Spec (Host_Path : Address) return Address;
2609 (C, To_Canonical_Path_Spec, "__gnat_to_canonical_path_spec");
2611 C_Host_Path : String (1 .. Host_Path'Length + 1);
2612 Canonical_Path_Addr : Address;
2613 Canonical_Path_Len : Integer;
2616 C_Host_Path (1 .. Host_Path'Length) := Host_Path;
2617 C_Host_Path (C_Host_Path'Last) := ASCII.NUL;
2619 Canonical_Path_Addr := To_Canonical_Path_Spec (C_Host_Path'Address);
2620 Canonical_Path_Len := C_String_Length (Canonical_Path_Addr);
2622 -- Return a null string (vice a null) for zero length paths, for
2623 -- compatibility with getenv().
2625 return To_Path_String_Access (Canonical_Path_Addr, Canonical_Path_Len);
2629 Fail ("erroneous path spec: ", Host_Path);
2631 end To_Canonical_Path_Spec;
2633 ---------------------------
2634 -- To_Host_Dir_Spec --
2635 ---------------------------
2637 function To_Host_Dir_Spec
2638 (Canonical_Dir : String;
2639 Prefix_Style : Boolean) return String_Access
2641 function To_Host_Dir_Spec
2642 (Canonical_Dir : Address;
2643 Prefix_Flag : Integer) return Address;
2644 pragma Import (C, To_Host_Dir_Spec, "__gnat_to_host_dir_spec");
2646 C_Canonical_Dir : String (1 .. Canonical_Dir'Length + 1);
2647 Host_Dir_Addr : Address;
2648 Host_Dir_Len : Integer;
2651 C_Canonical_Dir (1 .. Canonical_Dir'Length) := Canonical_Dir;
2652 C_Canonical_Dir (C_Canonical_Dir'Last) := ASCII.NUL;
2654 if Prefix_Style then
2655 Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 1);
2657 Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 0);
2659 Host_Dir_Len := C_String_Length (Host_Dir_Addr);
2661 if Host_Dir_Len = 0 then
2664 return To_Path_String_Access (Host_Dir_Addr, Host_Dir_Len);
2666 end To_Host_Dir_Spec;
2668 ----------------------------
2669 -- To_Host_File_Spec --
2670 ----------------------------
2672 function To_Host_File_Spec
2673 (Canonical_File : String) return String_Access
2675 function To_Host_File_Spec (Canonical_File : Address) return Address;
2676 pragma Import (C, To_Host_File_Spec, "__gnat_to_host_file_spec");
2678 C_Canonical_File : String (1 .. Canonical_File'Length + 1);
2679 Host_File_Addr : Address;
2680 Host_File_Len : Integer;
2683 C_Canonical_File (1 .. Canonical_File'Length) := Canonical_File;
2684 C_Canonical_File (C_Canonical_File'Last) := ASCII.NUL;
2686 Host_File_Addr := To_Host_File_Spec (C_Canonical_File'Address);
2687 Host_File_Len := C_String_Length (Host_File_Addr);
2689 if Host_File_Len = 0 then
2692 return To_Path_String_Access
2693 (Host_File_Addr, Host_File_Len);
2695 end To_Host_File_Spec;
2697 ---------------------------
2698 -- To_Path_String_Access --
2699 ---------------------------
2701 function To_Path_String_Access
2702 (Path_Addr : Address;
2703 Path_Len : Integer) return String_Access
2705 subtype Path_String is String (1 .. Path_Len);
2706 type Path_String_Access is access Path_String;
2708 function Address_To_Access is new
2709 Unchecked_Conversion (Source => Address,
2710 Target => Path_String_Access);
2712 Path_Access : constant Path_String_Access :=
2713 Address_To_Access (Path_Addr);
2715 Return_Val : String_Access;
2718 Return_Val := new String (1 .. Path_Len);
2720 for J in 1 .. Path_Len loop
2721 Return_Val (J) := Path_Access (J);
2725 end To_Path_String_Access;
2731 function Update_Path (Path : String_Ptr) return String_Ptr is
2733 function C_Update_Path (Path, Component : Address) return Address;
2734 pragma Import (C, C_Update_Path, "update_path");
2736 function Strlen (Str : Address) return Integer;
2737 pragma Import (C, Strlen, "strlen");
2739 procedure Strncpy (X : Address; Y : Address; Length : Integer);
2740 pragma Import (C, Strncpy, "strncpy");
2742 In_Length : constant Integer := Path'Length;
2743 In_String : String (1 .. In_Length + 1);
2744 Component_Name : aliased String := "GCC" & ASCII.NUL;
2745 Result_Ptr : Address;
2746 Result_Length : Integer;
2747 Out_String : String_Ptr;
2750 In_String (1 .. In_Length) := Path.all;
2751 In_String (In_Length + 1) := ASCII.NUL;
2752 Result_Ptr := C_Update_Path (In_String'Address,
2753 Component_Name'Address);
2754 Result_Length := Strlen (Result_Ptr);
2756 Out_String := new String (1 .. Result_Length);
2757 Strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
2765 procedure Write_Info (Info : String) is
2767 Write_With_Check (Info'Address, Info'Length);
2768 Write_With_Check (EOL'Address, 1);
2771 ------------------------
2772 -- Write_Program_Name --
2773 ------------------------
2775 procedure Write_Program_Name is
2776 Save_Buffer : constant String (1 .. Name_Len) :=
2777 Name_Buffer (1 .. Name_Len);
2782 -- Convert the name to lower case so error messages are the same on
2785 for J in 1 .. Name_Len loop
2786 if Name_Buffer (J) in 'A
' .. 'Z
' then
2788 Character'Val (Character'Pos (Name_Buffer (J)) + 32);
2792 Write_Str (Name_Buffer (1 .. Name_Len));
2794 -- Restore Name_Buffer which was clobbered by the call to
2795 -- Find_Program_Name
2797 Name_Len := Save_Buffer'Last;
2798 Name_Buffer (1 .. Name_Len) := Save_Buffer;
2799 end Write_Program_Name;
2801 ----------------------
2802 -- Write_With_Check --
2803 ----------------------
2805 procedure Write_With_Check (A : Address; N : Integer) is
2809 if N = Write (Output_FD, A, N) then
2813 Write_Str ("error: disk full writing ");
2814 Write_Name_Decoded (Output_File_Name);
2816 Name_Len := Name_Len + 1;
2817 Name_Buffer (Name_Len) := ASCII.NUL;
2818 Delete_File (Name_Buffer'Address, Ignore);
2819 Exit_Program (E_Fatal);
2821 end Write_With_Check;
2823 ----------------------------
2824 -- Package Initialization --
2825 ----------------------------
2828 Initialization : declare
2830 function Get_Default_Identifier_Character_Set return Character;
2831 pragma Import (C, Get_Default_Identifier_Character_Set,
2832 "__gnat_get_default_identifier_character_set");
2833 -- Function to determine the default identifier character set,
2834 -- which is system dependent. See Opt package spec for a list of
2835 -- the possible character codes and their interpretations.
2837 function Get_Maximum_File_Name_Length return Int;
2838 pragma Import (C, Get_Maximum_File_Name_Length,
2839 "__gnat_get_maximum_file_name_length");
2840 -- Function to get maximum file name length for system
2843 Identifier_Character_Set := Get_Default_Identifier_Character_Set;
2844 Maximum_File_Name_Length := Get_Maximum_File_Name_Length;
2846 -- Following should be removed by having above function return
2847 -- Integer'Last as indication of no maximum instead of -1 ???
2849 if Maximum_File_Name_Length = -1 then
2850 Maximum_File_Name_Length := Int'Last;
2853 Src_Search_Directories.Set_Last (Primary_Directory);
2854 Src_Search_Directories.Table (Primary_Directory) := new String'("");
2856 Lib_Search_Directories
.Set_Last
(Primary_Directory
);
2857 Lib_Search_Directories
.Table
(Primary_Directory
) := new String'("");