1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- Extensive contributions were provided by Ada Core Technologies Inc. --
26 ------------------------------------------------------------------------------
30 with Namet
; use Namet
;
32 with Output
; use Output
;
33 with Sdefault
; use Sdefault
;
36 with Unchecked_Conversion
;
38 with GNAT
.OS_Lib
; use GNAT
.OS_Lib
;
43 Running_Program
: Program_Type
:= Unspecified
;
44 Program_Set
: Boolean := False;
46 -------------------------------------
47 -- Use of Name_Find and Name_Enter --
48 -------------------------------------
50 -- This package creates a number of source, ALI and object file names
51 -- that are used to locate the actual file and for the purpose of
52 -- message construction. These names need not be accessible by Name_Find,
53 -- and can be therefore created by using routine Name_Enter. The files in
54 -- question are file names with a prefix directory (ie the files not
55 -- in the current directory). File names without a prefix directory are
56 -- entered with Name_Find because special values might be attached to
57 -- the various Info fields of the corresponding name table entry.
59 -----------------------
60 -- Local Subprograms --
61 -----------------------
63 function Append_Suffix_To_File_Name
67 -- Appends Suffix to Name and returns the new name.
69 function OS_Time_To_GNAT_Time
(T
: OS_Time
) return Time_Stamp_Type
;
70 -- Convert OS format time to GNAT format time stamp
72 function Concat
(String_One
: String; String_Two
: String) return String;
73 -- Concatenates 2 strings and returns the result of the concatenation
75 function Update_Path
(Path
: String_Ptr
) return String_Ptr
;
76 -- Update the specified path to replace the prefix with the location
77 -- where GNAT is installed. See the file prefix.c in GCC for details.
79 procedure Write_With_Check
(A
: Address
; N
: Integer);
80 -- Writes N bytes from buffer starting at address A to file whose FD is
81 -- stored in Output_FD, and whose file name is stored as a File_Name_Type
82 -- in Output_File_Name. A check is made for disk full, and if this is
83 -- detected, the file being written is deleted, and a fatal error is
91 return File_Name_Type
;
92 -- See if the file N whose name is Name exists in directory Dir. Dir is
93 -- an index into the Lib_Search_Directories table if T = Library.
94 -- Otherwise if T = Source, Dir is an index into the
95 -- Src_Search_Directories table. Returns the File_Name_Type of the
96 -- full file name if file found, or No_File if not found.
98 function C_String_Length
(S
: Address
) return Integer;
99 -- Returns length of a C string. Returns zero for a null address.
101 function To_Path_String_Access
102 (Path_Addr
: Address
;
104 return String_Access
;
105 -- Converts a C String to an Ada String. Are we doing this to avoid
106 -- withing Interfaces.C.Strings ???
108 ------------------------------
109 -- Other Local Declarations --
110 ------------------------------
112 EOL
: constant Character := ASCII
.LF
;
113 -- End of line character
115 Number_File_Names
: Int
:= 0;
116 -- The total number of file names found on command line and placed in
119 Look_In_Primary_Directory_For_Current_Main
: Boolean := False;
120 -- When this variable is True, Find_File will only look in
121 -- the Primary_Directory for the Current_Main file.
122 -- This variable is always True for the compiler.
123 -- It is also True for gnatmake, when the soucr name given
124 -- on the command line has directory information.
126 Current_Full_Source_Name
: File_Name_Type
:= No_File
;
127 Current_Full_Source_Stamp
: Time_Stamp_Type
:= Empty_Time_Stamp
;
128 Current_Full_Lib_Name
: File_Name_Type
:= No_File
;
129 Current_Full_Lib_Stamp
: Time_Stamp_Type
:= Empty_Time_Stamp
;
130 Current_Full_Obj_Name
: File_Name_Type
:= No_File
;
131 Current_Full_Obj_Stamp
: Time_Stamp_Type
:= Empty_Time_Stamp
;
132 -- Respectively full name (with directory info) and time stamp of
133 -- the latest source, library and object files opened by Read_Source_File
134 -- and Read_Library_Info.
140 Primary_Directory
: constant := 0;
141 -- This is index in the tables created below for the first directory to
142 -- search in for source or library information files. This is the
143 -- directory containing the latest main input file (a source file for
144 -- the compiler or a library file for the binder).
146 package Src_Search_Directories
is new Table
.Table
(
147 Table_Component_Type
=> String_Ptr
,
148 Table_Index_Type
=> Natural,
149 Table_Low_Bound
=> Primary_Directory
,
151 Table_Increment
=> 100,
152 Table_Name
=> "Osint.Src_Search_Directories");
153 -- Table of names of directories in which to search for source (Compiler)
154 -- files. This table is filled in the order in which the directories are
155 -- to be searched, and then used in that order.
157 package Lib_Search_Directories
is new Table
.Table
(
158 Table_Component_Type
=> String_Ptr
,
159 Table_Index_Type
=> Natural,
160 Table_Low_Bound
=> Primary_Directory
,
162 Table_Increment
=> 100,
163 Table_Name
=> "Osint.Lib_Search_Directories");
164 -- Table of names of directories in which to search for library (Binder)
165 -- files. This table is filled in the order in which the directories are
166 -- to be searched and then used in that order. The reason for having two
167 -- distinct tables is that we need them both in gnatmake.
169 ---------------------
170 -- File Hash Table --
171 ---------------------
173 -- The file hash table is provided to free the programmer from any
174 -- efficiency concern when retrieving full file names or time stamps of
175 -- source files. If the programmer calls Source_File_Data (Cache => True)
176 -- he is guaranteed that the price to retrieve the full name (ie with
177 -- directory info) or time stamp of the file will be payed only once,
178 -- the first time the full name is actually searched (or the first time
179 -- the time stamp is actually retrieved). This is achieved by employing
180 -- a hash table that stores as a key the File_Name_Type of the file and
181 -- associates to that File_Name_Type the full file name of the file and its
184 File_Cache_Enabled
: Boolean := False;
185 -- Set to true if you want the enable the file data caching mechanism.
187 type File_Hash_Num
is range 0 .. 1020;
189 function File_Hash
(F
: File_Name_Type
) return File_Hash_Num
;
190 -- Compute hash index for use by Simple_HTable
192 package File_Name_Hash_Table
is new GNAT
.HTable
.Simple_HTable
(
193 Header_Num
=> File_Hash_Num
,
194 Element
=> File_Name_Type
,
195 No_Element
=> No_File
,
196 Key
=> File_Name_Type
,
200 package File_Stamp_Hash_Table
is new GNAT
.HTable
.Simple_HTable
(
201 Header_Num
=> File_Hash_Num
,
202 Element
=> Time_Stamp_Type
,
203 No_Element
=> Empty_Time_Stamp
,
204 Key
=> File_Name_Type
,
208 function Smart_Find_File
211 return File_Name_Type
;
212 -- Exactly like Find_File except that if File_Cache_Enabled is True this
213 -- routine looks first in the hash table to see if the full name of the
214 -- file is already available.
216 function Smart_File_Stamp
219 return Time_Stamp_Type
;
220 -- Takes the same parameter as the routine above (N is a file name
221 -- without any prefix directory information) and behaves like File_Stamp
222 -- except that if File_Cache_Enabled is True this routine looks first in
223 -- the hash table to see if the file stamp of the file is already
226 -----------------------------
227 -- Add_Default_Search_Dirs --
228 -----------------------------
230 procedure Add_Default_Search_Dirs
is
231 Search_Dir
: String_Access
;
232 Search_Path
: String_Access
;
234 procedure Add_Search_Dir
235 (Search_Dir
: String_Access
;
236 Additional_Source_Dir
: Boolean);
237 -- Add a source search dir or a library search dir, depending on the
238 -- value of Additional_Source_Dir.
240 function Get_Libraries_From_Registry
return String_Ptr
;
241 -- On Windows systems, get the list of installed standard libraries
242 -- from the registry key:
243 -- HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\
244 -- GNAT\Standard Libraries
245 -- Return an empty string on other systems
251 procedure Add_Search_Dir
252 (Search_Dir
: String_Access
;
253 Additional_Source_Dir
: Boolean)
256 if Additional_Source_Dir
then
257 Add_Src_Search_Dir
(Search_Dir
.all);
259 Add_Lib_Search_Dir
(Search_Dir
.all);
263 ---------------------------------
264 -- Get_Libraries_From_Registry --
265 ---------------------------------
267 function Get_Libraries_From_Registry
return String_Ptr
is
268 function C_Get_Libraries_From_Registry
return Address
;
269 pragma Import
(C
, C_Get_Libraries_From_Registry
,
270 "__gnat_get_libraries_from_registry");
271 function Strlen
(Str
: Address
) return Integer;
272 pragma Import
(C
, Strlen
, "strlen");
273 procedure Strncpy
(X
: Address
; Y
: Address
; Length
: Integer);
274 pragma Import
(C
, Strncpy
, "strncpy");
275 Result_Ptr
: Address
;
276 Result_Length
: Integer;
277 Out_String
: String_Ptr
;
280 Result_Ptr
:= C_Get_Libraries_From_Registry
;
281 Result_Length
:= Strlen
(Result_Ptr
);
283 Out_String
:= new String (1 .. Result_Length
);
284 Strncpy
(Out_String
.all'Address, Result_Ptr
, Result_Length
);
286 end Get_Libraries_From_Registry
;
288 -- Start of processing for Add_Default_Search_Dirs
291 -- After the locations specified on the command line, the next places
292 -- to look for files are the directories specified by the appropriate
293 -- environment variable. Get this value, extract the directory names
294 -- and store in the tables.
296 -- On VMS, don't expand the logical name (e.g. environment variable),
297 -- just put it into Unix (e.g. canonical) format. System services
298 -- will handle the expansion as part of the file processing.
300 for Additional_Source_Dir
in False .. True loop
302 if Additional_Source_Dir
then
303 Search_Path
:= Getenv
("ADA_INCLUDE_PATH");
304 if Search_Path
'Length > 0 then
305 if Hostparm
.OpenVMS
then
306 Search_Path
:= To_Canonical_Path_Spec
("ADA_INCLUDE_PATH:");
308 Search_Path
:= To_Canonical_Path_Spec
(Search_Path
.all);
312 Search_Path
:= Getenv
("ADA_OBJECTS_PATH");
313 if Search_Path
'Length > 0 then
314 if Hostparm
.OpenVMS
then
315 Search_Path
:= To_Canonical_Path_Spec
("ADA_OBJECTS_PATH:");
317 Search_Path
:= To_Canonical_Path_Spec
(Search_Path
.all);
322 Get_Next_Dir_In_Path_Init
(Search_Path
);
324 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
325 exit when Search_Dir
= null;
326 Add_Search_Dir
(Search_Dir
, Additional_Source_Dir
);
330 if not Opt
.No_Stdinc
then
331 -- For WIN32 systems, look for any system libraries defined in
332 -- the registry. These are added to both source and object
335 Search_Path
:= String_Access
(Get_Libraries_From_Registry
);
336 Get_Next_Dir_In_Path_Init
(Search_Path
);
338 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
339 exit when Search_Dir
= null;
340 Add_Search_Dir
(Search_Dir
, False);
341 Add_Search_Dir
(Search_Dir
, True);
344 -- The last place to look are the defaults
346 Search_Path
:= Read_Default_Search_Dirs
347 (String_Access
(Update_Path
(Search_Dir_Prefix
)),
349 String_Access
(Update_Path
(Include_Dir_Default_Name
)));
351 Get_Next_Dir_In_Path_Init
(Search_Path
);
353 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
354 exit when Search_Dir
= null;
355 Add_Search_Dir
(Search_Dir
, True);
359 if not Opt
.No_Stdlib
and not Opt
.RTS_Switch
then
360 Search_Path
:= Read_Default_Search_Dirs
361 (String_Access
(Update_Path
(Search_Dir_Prefix
)),
363 String_Access
(Update_Path
(Object_Dir_Default_Name
)));
365 Get_Next_Dir_In_Path_Init
(Search_Path
);
367 Search_Dir
:= Get_Next_Dir_In_Path
(Search_Path
);
368 exit when Search_Dir
= null;
369 Add_Search_Dir
(Search_Dir
, False);
373 end Add_Default_Search_Dirs
;
379 procedure Add_File
(File_Name
: String) is
381 Number_File_Names
:= Number_File_Names
+ 1;
383 -- As Add_File may be called for mains specified inside
384 -- a project file, File_Names may be too short and needs
387 if Number_File_Names
> File_Names
'Last then
388 File_Names
:= new File_Name_Array
'(File_Names.all & File_Names.all);
391 File_Names (Number_File_Names) := new String'(File_Name
);
394 ------------------------
395 -- Add_Lib_Search_Dir --
396 ------------------------
398 procedure Add_Lib_Search_Dir
(Dir
: String) is
400 if Dir
'Length = 0 then
401 Fail
("missing library directory name");
404 Lib_Search_Directories
.Increment_Last
;
405 Lib_Search_Directories
.Table
(Lib_Search_Directories
.Last
) :=
406 Normalize_Directory_Name
(Dir
);
407 end Add_Lib_Search_Dir
;
409 ---------------------
410 -- Add_Search_Dirs --
411 ---------------------
413 procedure Add_Search_Dirs
414 (Search_Path
: String_Ptr
;
415 Path_Type
: Search_File_Type
)
417 Current_Search_Path
: String_Access
;
420 Get_Next_Dir_In_Path_Init
(String_Access
(Search_Path
));
422 Current_Search_Path
:=
423 Get_Next_Dir_In_Path
(String_Access
(Search_Path
));
424 exit when Current_Search_Path
= null;
426 if Path_Type
= Include
then
427 Add_Src_Search_Dir
(Current_Search_Path
.all);
429 Add_Lib_Search_Dir
(Current_Search_Path
.all);
434 ------------------------
435 -- Add_Src_Search_Dir --
436 ------------------------
438 procedure Add_Src_Search_Dir
(Dir
: String) is
440 if Dir
'Length = 0 then
441 Fail
("missing source directory name");
444 Src_Search_Directories
.Increment_Last
;
445 Src_Search_Directories
.Table
(Src_Search_Directories
.Last
) :=
446 Normalize_Directory_Name
(Dir
);
447 end Add_Src_Search_Dir
;
449 --------------------------------
450 -- Append_Suffix_To_File_Name --
451 --------------------------------
453 function Append_Suffix_To_File_Name
459 Get_Name_String
(Name
);
460 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ Suffix
'Length) := Suffix
;
461 Name_Len
:= Name_Len
+ Suffix
'Length;
463 end Append_Suffix_To_File_Name
;
465 ---------------------
466 -- C_String_Length --
467 ---------------------
469 function C_String_Length
(S
: Address
) return Integer is
470 function Strlen
(S
: Address
) return Integer;
471 pragma Import
(C
, Strlen
, "strlen");
474 if S
= Null_Address
then
481 ------------------------------
482 -- Canonical_Case_File_Name --
483 ------------------------------
485 -- For now, we only deal with the case of a-z. Eventually we should
486 -- worry about other Latin-1 letters on systems that support this ???
488 procedure Canonical_Case_File_Name
(S
: in out String) is
490 if not File_Names_Case_Sensitive
then
491 for J
in S
'Range loop
492 if S
(J
) in 'A' .. 'Z' then
493 S
(J
) := Character'Val (
494 Character'Pos (S
(J
)) +
495 Character'Pos ('a') -
496 Character'Pos ('A'));
500 end Canonical_Case_File_Name
;
506 function Concat
(String_One
: String; String_Two
: String) return String is
507 Buffer
: String (1 .. String_One
'Length + String_Two
'Length);
510 Buffer
(1 .. String_One
'Length) := String_One
;
511 Buffer
(String_One
'Length + 1 .. Buffer
'Last) := String_Two
;
515 ---------------------------
516 -- Create_File_And_Check --
517 ---------------------------
519 procedure Create_File_And_Check
520 (Fdesc
: out File_Descriptor
;
524 Output_File_Name
:= Name_Enter
;
525 Fdesc
:= Create_File
(Name_Buffer
'Address, Fmode
);
527 if Fdesc
= Invalid_FD
then
528 Fail
("Cannot create: ", Name_Buffer
(1 .. Name_Len
));
530 end Create_File_And_Check
;
532 --------------------------------
533 -- Current_Library_File_Stamp --
534 --------------------------------
536 function Current_Library_File_Stamp
return Time_Stamp_Type
is
538 return Current_Full_Lib_Stamp
;
539 end Current_Library_File_Stamp
;
541 -------------------------------
542 -- Current_Object_File_Stamp --
543 -------------------------------
545 function Current_Object_File_Stamp
return Time_Stamp_Type
is
547 return Current_Full_Obj_Stamp
;
548 end Current_Object_File_Stamp
;
550 -------------------------------
551 -- Current_Source_File_Stamp --
552 -------------------------------
554 function Current_Source_File_Stamp
return Time_Stamp_Type
is
556 return Current_Full_Source_Stamp
;
557 end Current_Source_File_Stamp
;
559 ----------------------------
560 -- Dir_In_Obj_Search_Path --
561 ----------------------------
563 function Dir_In_Obj_Search_Path
(Position
: Natural) return String_Ptr
is
565 if Opt
.Look_In_Primary_Dir
then
567 Lib_Search_Directories
.Table
(Primary_Directory
+ Position
- 1);
569 return Lib_Search_Directories
.Table
(Primary_Directory
+ Position
);
571 end Dir_In_Obj_Search_Path
;
573 ----------------------------
574 -- Dir_In_Src_Search_Path --
575 ----------------------------
577 function Dir_In_Src_Search_Path
(Position
: Natural) return String_Ptr
is
579 if Opt
.Look_In_Primary_Dir
then
581 Src_Search_Directories
.Table
(Primary_Directory
+ Position
- 1);
583 return Src_Search_Directories
.Table
(Primary_Directory
+ Position
);
585 end Dir_In_Src_Search_Path
;
587 ---------------------
588 -- Executable_Name --
589 ---------------------
591 function Executable_Name
(Name
: File_Name_Type
) return File_Name_Type
is
592 Exec_Suffix
: String_Access
;
595 if Name
= No_File
then
599 Get_Name_String
(Name
);
600 Exec_Suffix
:= Get_Executable_Suffix
;
602 for J
in Exec_Suffix
.all'Range loop
603 Name_Len
:= Name_Len
+ 1;
604 Name_Buffer
(Name_Len
) := Exec_Suffix
.all (J
);
614 procedure Exit_Program
(Exit_Code
: Exit_Code_Type
) is
616 -- The program will exit with the following status:
617 -- 0 if the object file has been generated (with or without warnings)
618 -- 1 if recompilation was not needed (smart recompilation)
619 -- 2 if gnat1 has been killed by a signal (detected by GCC)
620 -- 3 if no code has been generated (spec)
621 -- 4 for a fatal error
622 -- 5 if there were errors
625 when E_Success
=> OS_Exit
(0);
626 when E_Warnings
=> OS_Exit
(0);
627 when E_No_Compile
=> OS_Exit
(1);
628 when E_No_Code
=> OS_Exit
(3);
629 when E_Fatal
=> OS_Exit
(4);
630 when E_Errors
=> OS_Exit
(5);
631 when E_Abort
=> OS_Abort
;
639 procedure Fail
(S1
: String; S2
: String := ""; S3
: String := "") is
642 -- We use Output in case there is a special output set up.
643 -- In this case Set_Standard_Error will have no immediate effect.
646 Osint
.Write_Program_Name
;
653 Exit_Program
(E_Fatal
);
660 function File_Hash
(F
: File_Name_Type
) return File_Hash_Num
is
662 return File_Hash_Num
(Int
(F
) rem File_Hash_Num
'Range_Length);
669 function File_Stamp
(Name
: File_Name_Type
) return Time_Stamp_Type
is
671 if Name
= No_File
then
672 return Empty_Time_Stamp
;
675 Get_Name_String
(Name
);
677 if not Is_Regular_File
(Name_Buffer
(1 .. Name_Len
)) then
678 return Empty_Time_Stamp
;
680 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
681 return OS_Time_To_GNAT_Time
(File_Time_Stamp
(Name_Buffer
));
692 return File_Name_Type
698 File_Name
: String renames Name_Buffer
(1 .. Name_Len
);
699 File
: File_Name_Type
:= No_File
;
703 -- If we are looking for a config file, look only in the current
704 -- directory, i.e. return input argument unchanged. Also look
705 -- only in the current directory if we are looking for a .dg
706 -- file (happens in -gnatD mode)
709 or else (Debug_Generated_Code
710 and then Name_Len
> 3
712 (Name_Buffer
(Name_Len
- 2 .. Name_Len
) = ".dg"
714 (Hostparm
.OpenVMS
and then
715 Name_Buffer
(Name_Len
- 2 .. Name_Len
) = "_dg")))
719 -- If we are trying to find the current main file just look in the
720 -- directory where the user said it was.
722 elsif Look_In_Primary_Directory_For_Current_Main
723 and then Current_Main
= N
725 return Locate_File
(N
, T
, Primary_Directory
, File_Name
);
727 -- Otherwise do standard search for source file
730 -- Check the mapping of this file name
732 File
:= Mapped_Path_Name
(N
);
734 -- If the file name is mapped to a path name, return the
735 -- corresponding path name
737 if File
/= No_File
then
741 -- First place to look is in the primary directory (i.e. the same
742 -- directory as the source) unless this has been disabled with -I-
744 if Opt
.Look_In_Primary_Dir
then
745 File
:= Locate_File
(N
, T
, Primary_Directory
, File_Name
);
747 if File
/= No_File
then
752 -- Finally look in directories specified with switches -I/-aI/-aO
755 Last_Dir
:= Lib_Search_Directories
.Last
;
757 Last_Dir
:= Src_Search_Directories
.Last
;
760 for D
in Primary_Directory
+ 1 .. Last_Dir
loop
761 File
:= Locate_File
(N
, T
, D
, File_Name
);
763 if File
/= No_File
then
773 -----------------------
774 -- Find_Program_Name --
775 -----------------------
777 procedure Find_Program_Name
is
778 Command_Name
: String (1 .. Len_Arg
(0));
779 Cindex1
: Integer := Command_Name
'First;
780 Cindex2
: Integer := Command_Name
'Last;
783 Fill_Arg
(Command_Name
'Address, 0);
785 -- The program name might be specified by a full path name. However,
786 -- we don't want to print that all out in an error message, so the
787 -- path might need to be stripped away.
789 for J
in reverse Cindex1
.. Cindex2
loop
790 if Is_Directory_Separator
(Command_Name
(J
)) then
796 for J
in reverse Cindex1
.. Cindex2
loop
797 if Command_Name
(J
) = '.' then
803 Name_Len
:= Cindex2
- Cindex1
+ 1;
804 Name_Buffer
(1 .. Name_Len
) := Command_Name
(Cindex1
.. Cindex2
);
805 end Find_Program_Name
;
807 ------------------------
808 -- Full_Lib_File_Name --
809 ------------------------
811 function Full_Lib_File_Name
(N
: File_Name_Type
) return File_Name_Type
is
813 return Find_File
(N
, Library
);
814 end Full_Lib_File_Name
;
816 ----------------------------
817 -- Full_Library_Info_Name --
818 ----------------------------
820 function Full_Library_Info_Name
return File_Name_Type
is
822 return Current_Full_Lib_Name
;
823 end Full_Library_Info_Name
;
825 ---------------------------
826 -- Full_Object_File_Name --
827 ---------------------------
829 function Full_Object_File_Name
return File_Name_Type
is
831 return Current_Full_Obj_Name
;
832 end Full_Object_File_Name
;
834 ----------------------
835 -- Full_Source_Name --
836 ----------------------
838 function Full_Source_Name
return File_Name_Type
is
840 return Current_Full_Source_Name
;
841 end Full_Source_Name
;
843 ----------------------
844 -- Full_Source_Name --
845 ----------------------
847 function Full_Source_Name
(N
: File_Name_Type
) return File_Name_Type
is
849 return Smart_Find_File
(N
, Source
);
850 end Full_Source_Name
;
856 function Get_Directory
(Name
: File_Name_Type
) return File_Name_Type
is
858 Get_Name_String
(Name
);
860 for J
in reverse 1 .. Name_Len
loop
861 if Is_Directory_Separator
(Name_Buffer
(J
)) then
867 Name_Len
:= Hostparm
.Normalized_CWD
'Length;
868 Name_Buffer
(1 .. Name_Len
) := Hostparm
.Normalized_CWD
;
872 --------------------------
873 -- Get_Next_Dir_In_Path --
874 --------------------------
876 Search_Path_Pos
: Integer;
877 -- Keeps track of current position in search path. Initialized by the
878 -- call to Get_Next_Dir_In_Path_Init, updated by Get_Next_Dir_In_Path.
880 function Get_Next_Dir_In_Path
881 (Search_Path
: String_Access
)
884 Lower_Bound
: Positive := Search_Path_Pos
;
885 Upper_Bound
: Positive;
889 while Lower_Bound
<= Search_Path
'Last
890 and then Search_Path
.all (Lower_Bound
) = Path_Separator
892 Lower_Bound
:= Lower_Bound
+ 1;
895 exit when Lower_Bound
> Search_Path
'Last;
897 Upper_Bound
:= Lower_Bound
;
898 while Upper_Bound
<= Search_Path
'Last
899 and then Search_Path
.all (Upper_Bound
) /= Path_Separator
901 Upper_Bound
:= Upper_Bound
+ 1;
904 Search_Path_Pos
:= Upper_Bound
;
905 return new String'(Search_Path.all (Lower_Bound .. Upper_Bound - 1));
909 end Get_Next_Dir_In_Path;
911 -------------------------------
912 -- Get_Next_Dir_In_Path_Init --
913 -------------------------------
915 procedure Get_Next_Dir_In_Path_Init (Search_Path : String_Access) is
917 Search_Path_Pos := Search_Path'First;
918 end Get_Next_Dir_In_Path_Init;
920 --------------------------------------
921 -- Get_Primary_Src_Search_Directory --
922 --------------------------------------
924 function Get_Primary_Src_Search_Directory return String_Ptr is
926 return Src_Search_Directories.Table (Primary_Directory);
927 end Get_Primary_Src_Search_Directory;
929 -------------------------
930 -- Get_RTS_Search_Dir --
931 -------------------------
933 function Get_RTS_Search_Dir
934 (Search_Dir : String;
935 File_Type : Search_File_Type)
938 procedure Get_Current_Dir
939 (Dir : System.Address;
940 Length : System.Address);
941 pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir");
944 pragma Import (C, Max_Path, "__gnat_max_path_len");
945 -- Maximum length of a path name
947 Current_Dir : String_Ptr;
948 Default_Search_Dir : String_Access;
949 Default_Suffix_Dir : String_Access;
950 Local_Search_Dir : String_Access;
951 Norm_Search_Dir : String_Access;
952 Result_Search_Dir : String_Access;
953 Search_File : String_Access;
954 Temp_String : String_Ptr;
957 -- Add a directory separator at the end of the directory if necessary
958 -- so that we can directly append a file to the directory
960 if Search_Dir (Search_Dir'Last) /= Directory_Separator then
961 Local_Search_Dir := new String'
962 (Concat
(Search_Dir
, String' (1 => Directory_Separator)));
964 Local_Search_Dir := new String' (Search_Dir
);
967 if File_Type
= Include
then
968 Search_File
:= Include_Search_File
;
969 Default_Suffix_Dir
:= new String'("adainclude");
971 Search_File := Objects_Search_File;
972 Default_Suffix_Dir := new String' ("adalib");
975 Norm_Search_Dir
:= To_Canonical_Path_Spec
(Local_Search_Dir
.all);
977 if Is_Absolute_Path
(Norm_Search_Dir
.all) then
979 -- We first verify if there is a directory Include_Search_Dir
980 -- containing default search directories
983 := Read_Default_Search_Dirs
(Norm_Search_Dir
,
986 Default_Search_Dir
:= new String'
987 (Concat (Norm_Search_Dir.all, Default_Suffix_Dir.all));
988 Free (Norm_Search_Dir);
990 if Result_Search_Dir /= null then
991 return String_Ptr (Result_Search_Dir);
992 elsif Is_Directory (Default_Search_Dir.all) then
993 return String_Ptr (Default_Search_Dir);
999 -- Search in the current directory
1001 -- Get the current directory
1004 Buffer : String (1 .. Max_Path + 2);
1005 Path_Len : Natural := Max_Path;
1008 Get_Current_Dir (Buffer'Address, Path_Len'Address);
1010 if Buffer (Path_Len) /= Directory_Separator then
1011 Path_Len := Path_Len + 1;
1012 Buffer (Path_Len) := Directory_Separator;
1015 Current_Dir := new String'(Buffer
(1 .. Path_Len
));
1020 (Concat (Current_Dir.all, Local_Search_Dir.all));
1022 Result_Search_Dir :=
1023 Read_Default_Search_Dirs
1024 (String_Access (Update_Path (String_Ptr (Norm_Search_Dir))),
1028 Default_Search_Dir :=
1030 (Concat
(Norm_Search_Dir
.all, Default_Suffix_Dir
.all));
1032 Free
(Norm_Search_Dir
);
1034 if Result_Search_Dir
/= null then
1035 return String_Ptr
(Result_Search_Dir
);
1037 elsif Is_Directory
(Default_Search_Dir
.all) then
1038 return String_Ptr
(Default_Search_Dir
);
1041 -- Search in Search_Dir_Prefix/Search_Dir
1045 (Concat (Search_Dir_Prefix.all, Local_Search_Dir.all));
1047 Result_Search_Dir :=
1048 Read_Default_Search_Dirs
1049 (String_Access (Update_Path (String_Ptr (Norm_Search_Dir))),
1053 Default_Search_Dir :=
1055 (Concat
(Norm_Search_Dir
.all, Default_Suffix_Dir
.all));
1057 Free
(Norm_Search_Dir
);
1059 if Result_Search_Dir
/= null then
1060 return String_Ptr
(Result_Search_Dir
);
1062 elsif Is_Directory
(Default_Search_Dir
.all) then
1063 return String_Ptr
(Default_Search_Dir
);
1066 -- We finally search in Search_Dir_Prefix/rts-Search_Dir
1069 new String'(Concat (Search_Dir_Prefix.all, "rts-"));
1072 new String' (Concat
(Temp_String
.all, Local_Search_Dir
.all));
1074 Result_Search_Dir
:=
1075 Read_Default_Search_Dirs
1076 (String_Access
(Update_Path
(String_Ptr
(Norm_Search_Dir
))),
1080 Default_Search_Dir
:=
1082 (Concat (Norm_Search_Dir.all, Default_Suffix_Dir.all));
1083 Free (Norm_Search_Dir);
1085 if Result_Search_Dir /= null then
1086 return String_Ptr (Result_Search_Dir);
1088 elsif Is_Directory (Default_Search_Dir.all) then
1089 return String_Ptr (Default_Search_Dir);
1097 end Get_RTS_Search_Dir;
1099 ----------------------------
1100 -- Is_Directory_Separator --
1101 ----------------------------
1103 function Is_Directory_Separator (C : Character) return Boolean is
1105 -- In addition to the default directory_separator allow the '/' to
1106 -- act as separator since this is allowed in MS-DOS, Windows 95/NT,
1107 -- and OS2 ports. On VMS, the situation is more complicated because
1108 -- there are two characters to check for.
1111 C = Directory_Separator
1113 or else (Hostparm.OpenVMS
1114 and then (C = ']' or else C = ':'));
1115 end Is_Directory_Separator;
1117 -------------------------
1118 -- Is_Readonly_Library --
1119 -------------------------
1121 function Is_Readonly_Library (File : in File_Name_Type) return Boolean is
1123 Get_Name_String (File);
1125 pragma Assert (Name_Buffer (Name_Len - 3 .. Name_Len) = ".ali");
1127 return not Is_Writable_File (Name_Buffer (1 .. Name_Len));
1128 end Is_Readonly_Library;
1134 function Lib_File_Name
1135 (Source_File : File_Name_Type)
1136 return File_Name_Type
1139 -- Pointer to location to set extension in place
1142 Get_Name_String (Source_File);
1143 Fptr := Name_Len + 1;
1145 for J in reverse 2 .. Name_Len loop
1146 if Name_Buffer (J) = '.' then
1152 Name_Buffer (Fptr) := '.';
1153 Name_Buffer (Fptr + 1 .. Fptr + ALI_Suffix'Length) := ALI_Suffix.all;
1154 Name_Buffer (Fptr + ALI_Suffix'Length + 1) := ASCII.NUL;
1155 Name_Len := Fptr + ALI_Suffix'Length;
1159 ------------------------
1160 -- Library_File_Stamp --
1161 ------------------------
1163 function Library_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is
1165 return File_Stamp (Find_File (N, Library));
1166 end Library_File_Stamp;
1172 function Locate_File
1173 (N : File_Name_Type;
1177 return File_Name_Type
1179 Dir_Name : String_Ptr;
1183 Dir_Name := Lib_Search_Directories.Table (Dir);
1185 else pragma Assert (T = Source);
1186 Dir_Name := Src_Search_Directories.Table (Dir);
1190 Full_Name : String (1 .. Dir_Name'Length + Name'Length);
1193 Full_Name (1 .. Dir_Name'Length) := Dir_Name.all;
1194 Full_Name (Dir_Name'Length + 1 .. Full_Name'Length) := Name;
1196 if not Is_Regular_File (Full_Name) then
1200 -- If the file is in the current directory then return N itself
1202 if Dir_Name'Length = 0 then
1205 Name_Len := Full_Name'Length;
1206 Name_Buffer (1 .. Name_Len) := Full_Name;
1213 -------------------------------
1214 -- Matching_Full_Source_Name --
1215 -------------------------------
1217 function Matching_Full_Source_Name
1218 (N : File_Name_Type;
1219 T : Time_Stamp_Type)
1220 return File_Name_Type
1223 Get_Name_String (N);
1226 File_Name : constant String := Name_Buffer (1 .. Name_Len);
1227 File : File_Name_Type := No_File;
1231 if Opt.Look_In_Primary_Dir then
1232 File := Locate_File (N, Source, Primary_Directory, File_Name);
1234 if File /= No_File and then T = File_Stamp (N) then
1239 Last_Dir := Src_Search_Directories.Last;
1241 for D in Primary_Directory + 1 .. Last_Dir loop
1242 File := Locate_File (N, Source, D, File_Name);
1244 if File /= No_File and then T = File_Stamp (File) then
1251 end Matching_Full_Source_Name;
1257 function More_Files return Boolean is
1259 return (Current_File_Name_Index < Number_File_Names);
1262 -------------------------------
1263 -- Nb_Dir_In_Obj_Search_Path --
1264 -------------------------------
1266 function Nb_Dir_In_Obj_Search_Path return Natural is
1268 if Opt.Look_In_Primary_Dir then
1269 return Lib_Search_Directories.Last - Primary_Directory + 1;
1271 return Lib_Search_Directories.Last - Primary_Directory;
1273 end Nb_Dir_In_Obj_Search_Path;
1275 -------------------------------
1276 -- Nb_Dir_In_Src_Search_Path --
1277 -------------------------------
1279 function Nb_Dir_In_Src_Search_Path return Natural is
1281 if Opt.Look_In_Primary_Dir then
1282 return Src_Search_Directories.Last - Primary_Directory + 1;
1284 return Src_Search_Directories.Last - Primary_Directory;
1286 end Nb_Dir_In_Src_Search_Path;
1288 --------------------
1289 -- Next_Main_File --
1290 --------------------
1292 function Next_Main_File return File_Name_Type is
1293 File_Name : String_Ptr;
1294 Dir_Name : String_Ptr;
1298 pragma Assert (More_Files);
1300 Current_File_Name_Index := Current_File_Name_Index + 1;
1302 -- Get the file and directory name
1304 File_Name := File_Names (Current_File_Name_Index);
1305 Fptr := File_Name'First;
1307 for J in reverse File_Name'Range loop
1308 if File_Name (J) = Directory_Separator
1309 or else File_Name (J) = '/'
1311 if J = File_Name'Last then
1312 Fail ("File name missing");
1320 -- Save name of directory in which main unit resides for use in
1321 -- locating other units
1323 Dir_Name := new String'(File_Name
(File_Name
'First .. Fptr
- 1));
1325 case Running_Program
is
1328 Src_Search_Directories
.Table
(Primary_Directory
) := Dir_Name
;
1329 Look_In_Primary_Directory_For_Current_Main
:= True;
1332 Src_Search_Directories
.Table
(Primary_Directory
) := Dir_Name
;
1334 if Fptr
> File_Name
'First then
1335 Look_In_Primary_Directory_For_Current_Main
:= True;
1338 when Binder | Gnatls
=>
1339 Dir_Name
:= Normalize_Directory_Name
(Dir_Name
.all);
1340 Lib_Search_Directories
.Table
(Primary_Directory
) := Dir_Name
;
1346 Name_Len
:= File_Name
'Last - Fptr
+ 1;
1347 Name_Buffer
(1 .. Name_Len
) := File_Name
(Fptr
.. File_Name
'Last);
1348 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
1349 Current_Main
:= File_Name_Type
(Name_Find
);
1351 -- In the gnatmake case, the main file may have not have the
1352 -- extension. Try ".adb" first then ".ads"
1354 if Running_Program
= Make
then
1356 Orig_Main
: File_Name_Type
:= Current_Main
;
1359 if Strip_Suffix
(Orig_Main
) = Orig_Main
then
1360 Current_Main
:= Append_Suffix_To_File_Name
(Orig_Main
, ".adb");
1362 if Full_Source_Name
(Current_Main
) = No_File
then
1364 Append_Suffix_To_File_Name
(Orig_Main
, ".ads");
1366 if Full_Source_Name
(Current_Main
) = No_File
then
1367 Current_Main
:= Orig_Main
;
1374 return Current_Main
;
1377 ------------------------------
1378 -- Normalize_Directory_Name --
1379 ------------------------------
1381 function Normalize_Directory_Name
(Directory
: String) return String_Ptr
is
1382 Result
: String_Ptr
;
1385 if Directory
'Length = 0 then
1386 Result
:= new String'(Hostparm.Normalized_CWD);
1388 elsif Is_Directory_Separator (Directory (Directory'Last)) then
1389 Result := new String'(Directory
);
1391 Result
:= new String (1 .. Directory
'Length + 1);
1392 Result
(1 .. Directory
'Length) := Directory
;
1393 Result
(Directory
'Length + 1) := Directory_Separator
;
1397 end Normalize_Directory_Name
;
1399 ---------------------
1400 -- Number_Of_Files --
1401 ---------------------
1403 function Number_Of_Files
return Int
is
1405 return Number_File_Names
;
1406 end Number_Of_Files
;
1408 ----------------------
1409 -- Object_File_Name --
1410 ----------------------
1412 function Object_File_Name
(N
: File_Name_Type
) return File_Name_Type
is
1418 Get_Name_String
(N
);
1419 Name_Len
:= Name_Len
- ALI_Suffix
'Length - 1;
1421 for J
in Object_Suffix
'Range loop
1422 Name_Len
:= Name_Len
+ 1;
1423 Name_Buffer
(Name_Len
) := Object_Suffix
(J
);
1427 end Object_File_Name
;
1429 --------------------------
1430 -- OS_Time_To_GNAT_Time --
1431 --------------------------
1433 function OS_Time_To_GNAT_Time
(T
: OS_Time
) return Time_Stamp_Type
is
1434 GNAT_Time
: Time_Stamp_Type
;
1444 GM_Split
(T
, Y
, Mo
, D
, H
, Mn
, S
);
1450 Minutes
=> Nat
(Mn
),
1455 end OS_Time_To_GNAT_Time
;
1461 function Program_Name
(Nam
: String) return String_Access
is
1462 Res
: String_Access
;
1465 -- Get the name of the current program being executed
1469 -- Find the target prefix if any, for the cross compilation case
1470 -- for instance in "alpha-dec-vxworks-gcc" the target prefix is
1471 -- "alpha-dec-vxworks-"
1473 while Name_Len
> 0 loop
1474 if Name_Buffer
(Name_Len
) = '-' then
1478 Name_Len
:= Name_Len
- 1;
1481 -- Create the new program name
1483 Res
:= new String (1 .. Name_Len
+ Nam
'Length);
1484 Res
.all (1 .. Name_Len
) := Name_Buffer
(1 .. Name_Len
);
1485 Res
.all (Name_Len
+ 1 .. Name_Len
+ Nam
'Length) := Nam
;
1489 ------------------------------
1490 -- Read_Default_Search_Dirs --
1491 ------------------------------
1493 function Read_Default_Search_Dirs
1494 (Search_Dir_Prefix
: String_Access
;
1495 Search_File
: String_Access
;
1496 Search_Dir_Default_Name
: String_Access
)
1497 return String_Access
1499 Prefix_Len
: constant Integer := Search_Dir_Prefix
.all'Length;
1500 Buffer
: String (1 .. Prefix_Len
+ Search_File
.all'Length + 1);
1501 File_FD
: File_Descriptor
;
1502 S
, S1
: String_Access
;
1505 Actual_Len
: Integer;
1508 Prev_Was_Separator
: Boolean;
1509 Nb_Relative_Dir
: Integer;
1511 function Is_Relative
(S
: String; K
: Positive) return Boolean;
1512 pragma Inline
(Is_Relative
);
1513 -- Returns True if a relative directory specification is found
1514 -- in S at position K, False otherwise.
1520 function Is_Relative
(S
: String; K
: Positive) return Boolean is
1522 return not Is_Absolute_Path
(S
(K
.. S
'Last));
1525 -- Start of processing for Read_Default_Search_Dirs
1528 -- Construct a C compatible character string buffer.
1530 Buffer
(1 .. Search_Dir_Prefix
.all'Length)
1531 := Search_Dir_Prefix
.all;
1532 Buffer
(Search_Dir_Prefix
.all'Length + 1 .. Buffer
'Last - 1)
1534 Buffer
(Buffer
'Last) := ASCII
.NUL
;
1536 File_FD
:= Open_Read
(Buffer
'Address, Binary
);
1537 if File_FD
= Invalid_FD
then
1538 return Search_Dir_Default_Name
;
1541 Len
:= Integer (File_Length
(File_FD
));
1543 -- An extra character for a trailing Path_Separator is allocated
1545 S
:= new String (1 .. Len
+ 1);
1546 S
(Len
+ 1) := Path_Separator
;
1548 -- Read the file. Note that the loop is not necessary since the
1549 -- whole file is read at once except on VMS.
1553 while Actual_Len
/= 0 loop
1554 Actual_Len
:= Read
(File_FD
, S
(Curr
)'Address, Len
);
1555 Curr
:= Curr
+ Actual_Len
;
1558 -- Process the file, translating line and file ending
1559 -- control characters to a path separator character.
1561 Prev_Was_Separator
:= True;
1562 Nb_Relative_Dir
:= 0;
1563 for J
in 1 .. Len
loop
1564 if S
(J
) in ASCII
.NUL
.. ASCII
.US
1567 S
(J
) := Path_Separator
;
1570 if S
(J
) = Path_Separator
then
1571 Prev_Was_Separator
:= True;
1573 if Prev_Was_Separator
and then Is_Relative
(S
.all, J
) then
1574 Nb_Relative_Dir
:= Nb_Relative_Dir
+ 1;
1577 Prev_Was_Separator
:= False;
1581 if Nb_Relative_Dir
= 0 then
1585 -- Add the Search_Dir_Prefix to all relative paths
1587 S1
:= new String (1 .. S
'Length + Nb_Relative_Dir
* Prefix_Len
);
1589 Prev_Was_Separator
:= True;
1590 for J
in 1 .. Len
+ 1 loop
1591 if S
(J
) = Path_Separator
then
1592 Prev_Was_Separator
:= True;
1595 if Prev_Was_Separator
and then Is_Relative
(S
.all, J
) then
1596 S1
(J1
.. J1
+ Prefix_Len
) := Search_Dir_Prefix
.all;
1597 J1
:= J1
+ Prefix_Len
;
1600 Prev_Was_Separator
:= False;
1608 end Read_Default_Search_Dirs
;
1610 -----------------------
1611 -- Read_Library_Info --
1612 -----------------------
1614 function Read_Library_Info
1615 (Lib_File
: File_Name_Type
;
1616 Fatal_Err
: Boolean := False)
1617 return Text_Buffer_Ptr
1619 Lib_FD
: File_Descriptor
;
1620 -- The file descriptor for the current library file. A negative value
1621 -- indicates failure to open the specified source file.
1623 Text
: Text_Buffer_Ptr
;
1624 -- Allocated text buffer.
1627 Current_Full_Lib_Name
:= Find_File
(Lib_File
, Library
);
1628 Current_Full_Obj_Name
:= Object_File_Name
(Current_Full_Lib_Name
);
1630 if Current_Full_Lib_Name
= No_File
then
1632 Fail
("Cannot find: ", Name_Buffer
(1 .. Name_Len
));
1634 Current_Full_Obj_Stamp
:= Empty_Time_Stamp
;
1639 Get_Name_String
(Current_Full_Lib_Name
);
1640 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
1642 -- Open the library FD, note that we open in binary mode, because as
1643 -- documented in the spec, the caller is expected to handle either
1644 -- DOS or Unix mode files, and there is no point in wasting time on
1645 -- text translation when it is not required.
1647 Lib_FD
:= Open_Read
(Name_Buffer
'Address, Binary
);
1649 if Lib_FD
= Invalid_FD
then
1651 Fail
("Cannot open: ", Name_Buffer
(1 .. Name_Len
));
1653 Current_Full_Obj_Stamp
:= Empty_Time_Stamp
;
1658 -- Check for object file consistency if requested
1660 if Opt
.Check_Object_Consistency
then
1661 Current_Full_Lib_Stamp
:= File_Stamp
(Current_Full_Lib_Name
);
1662 Current_Full_Obj_Stamp
:= File_Stamp
(Current_Full_Obj_Name
);
1664 if Current_Full_Obj_Stamp
(1) = ' ' then
1666 -- When the library is readonly, always assume that
1667 -- the object is consistent.
1669 if Is_Readonly_Library
(Current_Full_Lib_Name
) then
1670 Current_Full_Obj_Stamp
:= Current_Full_Lib_Stamp
;
1672 elsif Fatal_Err
then
1673 Get_Name_String
(Current_Full_Obj_Name
);
1675 Fail
("Cannot find: ", Name_Buffer
(1 .. Name_Len
));
1678 Current_Full_Obj_Stamp
:= Empty_Time_Stamp
;
1684 -- Object file exists, compare object and ALI time stamps
1686 if Current_Full_Lib_Stamp
> Current_Full_Obj_Stamp
then
1688 Get_Name_String
(Current_Full_Obj_Name
);
1690 Fail
("Bad time stamp: ", Name_Buffer
(1 .. Name_Len
));
1692 Current_Full_Obj_Stamp
:= Empty_Time_Stamp
;
1699 -- Read data from the file
1702 Len
: Integer := Integer (File_Length
(Lib_FD
));
1703 -- Length of source file text. If it doesn't fit in an integer
1704 -- we're probably stuck anyway (>2 gigs of source seems a lot!)
1706 Actual_Len
: Integer := 0;
1709 -- Low bound for allocated text buffer
1711 Hi
: Text_Ptr
:= Text_Ptr
(Len
);
1712 -- High bound for allocated text buffer. Note length is Len + 1
1713 -- which allows for extra EOF character at the end of the buffer.
1716 -- Allocate text buffer. Note extra character at end for EOF
1718 Text
:= new Text_Buffer
(Lo
.. Hi
);
1720 -- Some systems (e.g. VMS) have file types that require one
1721 -- read per line, so read until we get the Len bytes or until
1722 -- there are no more characters.
1726 Actual_Len
:= Read
(Lib_FD
, Text
(Hi
)'Address, Len
);
1727 Hi
:= Hi
+ Text_Ptr
(Actual_Len
);
1728 exit when Actual_Len
= Len
or Actual_Len
<= 0;
1734 -- Read is complete, close file and we are done
1739 end Read_Library_Info
;
1741 ----------------------
1742 -- Read_Source_File --
1743 ----------------------
1745 procedure Read_Source_File
1746 (N
: File_Name_Type
;
1748 Hi
: out Source_Ptr
;
1749 Src
: out Source_Buffer_Ptr
;
1750 T
: File_Type
:= Source
)
1752 Source_File_FD
: File_Descriptor
;
1753 -- The file descriptor for the current source file. A negative value
1754 -- indicates failure to open the specified source file.
1757 -- Length of file. Assume no more than 2 gigabytes of source!
1759 Actual_Len
: Integer;
1762 Current_Full_Source_Name
:= Find_File
(N
, T
);
1763 Current_Full_Source_Stamp
:= File_Stamp
(Current_Full_Source_Name
);
1765 if Current_Full_Source_Name
= No_File
then
1767 -- If we were trying to access the main file and we could not
1768 -- find it we have an error.
1770 if N
= Current_Main
then
1771 Get_Name_String
(N
);
1772 Fail
("Cannot find: ", Name_Buffer
(1 .. Name_Len
));
1780 Get_Name_String
(Current_Full_Source_Name
);
1781 Name_Buffer
(Name_Len
+ 1) := ASCII
.NUL
;
1783 -- Open the source FD, note that we open in binary mode, because as
1784 -- documented in the spec, the caller is expected to handle either
1785 -- DOS or Unix mode files, and there is no point in wasting time on
1786 -- text translation when it is not required.
1788 Source_File_FD
:= Open_Read
(Name_Buffer
'Address, Binary
);
1790 if Source_File_FD
= Invalid_FD
then
1796 -- Prepare to read data from the file
1798 Len
:= Integer (File_Length
(Source_File_FD
));
1800 -- Set Hi so that length is one more than the physical length,
1801 -- allowing for the extra EOF character at the end of the buffer
1803 Hi
:= Lo
+ Source_Ptr
(Len
);
1805 -- Do the actual read operation
1808 subtype Actual_Source_Buffer
is Source_Buffer
(Lo
.. Hi
);
1809 -- Physical buffer allocated
1811 type Actual_Source_Ptr
is access Actual_Source_Buffer
;
1812 -- This is the pointer type for the physical buffer allocated
1814 Actual_Ptr
: Actual_Source_Ptr
:= new Actual_Source_Buffer
;
1815 -- And this is the actual physical buffer
1818 -- Allocate source buffer, allowing extra character at end for EOF
1820 -- Some systems (e.g. VMS) have file types that require one
1821 -- read per line, so read until we get the Len bytes or until
1822 -- there are no more characters.
1826 Actual_Len
:= Read
(Source_File_FD
, Actual_Ptr
(Hi
)'Address, Len
);
1827 Hi
:= Hi
+ Source_Ptr
(Actual_Len
);
1828 exit when Actual_Len
= Len
or Actual_Len
<= 0;
1831 Actual_Ptr
(Hi
) := EOF
;
1833 -- Now we need to work out the proper virtual origin pointer to
1834 -- return. This is exactly Actual_Ptr (0)'Address, but we have
1835 -- to be careful to suppress checks to compute this address.
1838 pragma Suppress
(All_Checks
);
1840 function To_Source_Buffer_Ptr
is new
1841 Unchecked_Conversion
(Address
, Source_Buffer_Ptr
);
1844 Src
:= To_Source_Buffer_Ptr
(Actual_Ptr
(0)'Address);
1848 -- Read is complete, get time stamp and close file and we are done
1850 Close
(Source_File_FD
);
1852 end Read_Source_File
;
1858 procedure Set_Program
(P
: Program_Type
) is
1861 Fail
("Set_Program called twice");
1864 Program_Set
:= True;
1865 Running_Program
:= P
;
1868 ----------------------
1869 -- Smart_File_Stamp --
1870 ----------------------
1872 function Smart_File_Stamp
1873 (N
: File_Name_Type
;
1875 return Time_Stamp_Type
1877 Time_Stamp
: Time_Stamp_Type
;
1880 if not File_Cache_Enabled
then
1881 return File_Stamp
(Find_File
(N
, T
));
1884 Time_Stamp
:= File_Stamp_Hash_Table
.Get
(N
);
1886 if Time_Stamp
(1) = ' ' then
1887 Time_Stamp
:= File_Stamp
(Smart_Find_File
(N
, T
));
1888 File_Stamp_Hash_Table
.Set
(N
, Time_Stamp
);
1892 end Smart_File_Stamp
;
1894 ---------------------
1895 -- Smart_Find_File --
1896 ---------------------
1898 function Smart_Find_File
1899 (N
: File_Name_Type
;
1901 return File_Name_Type
1903 Full_File_Name
: File_Name_Type
;
1906 if not File_Cache_Enabled
then
1907 return Find_File
(N
, T
);
1910 Full_File_Name
:= File_Name_Hash_Table
.Get
(N
);
1912 if Full_File_Name
= No_File
then
1913 Full_File_Name
:= Find_File
(N
, T
);
1914 File_Name_Hash_Table
.Set
(N
, Full_File_Name
);
1917 return Full_File_Name
;
1918 end Smart_Find_File
;
1920 ----------------------
1921 -- Source_File_Data --
1922 ----------------------
1924 procedure Source_File_Data
(Cache
: Boolean) is
1926 File_Cache_Enabled
:= Cache
;
1927 end Source_File_Data
;
1929 -----------------------
1930 -- Source_File_Stamp --
1931 -----------------------
1933 function Source_File_Stamp
(N
: File_Name_Type
) return Time_Stamp_Type
is
1935 return Smart_File_Stamp
(N
, Source
);
1936 end Source_File_Stamp
;
1938 ---------------------
1939 -- Strip_Directory --
1940 ---------------------
1942 function Strip_Directory
(Name
: File_Name_Type
) return File_Name_Type
is
1944 Get_Name_String
(Name
);
1946 for J
in reverse 1 .. Name_Len
- 1 loop
1947 -- If we find the last directory separator
1949 if Is_Directory_Separator
(Name_Buffer
(J
)) then
1950 -- Return the part of Name that follows this last directory
1953 Name_Buffer
(1 .. Name_Len
- J
) := Name_Buffer
(J
+ 1 .. Name_Len
);
1954 Name_Len
:= Name_Len
- J
;
1959 -- There were no directory separator, just return Name
1962 end Strip_Directory
;
1968 function Strip_Suffix
(Name
: File_Name_Type
) return File_Name_Type
is
1970 Get_Name_String
(Name
);
1972 for J
in reverse 2 .. Name_Len
loop
1974 -- If we found the last '.', return the part of Name that precedes
1977 if Name_Buffer
(J
) = '.' then
1986 ---------------------------
1987 -- To_Canonical_Dir_Spec --
1988 ---------------------------
1990 function To_Canonical_Dir_Spec
1992 Prefix_Style
: Boolean)
1993 return String_Access
1995 function To_Canonical_Dir_Spec
1996 (Host_Dir
: Address
;
1997 Prefix_Flag
: Integer)
1999 pragma Import
(C
, To_Canonical_Dir_Spec
, "__gnat_to_canonical_dir_spec");
2001 C_Host_Dir
: String (1 .. Host_Dir
'Length + 1);
2002 Canonical_Dir_Addr
: Address
;
2003 Canonical_Dir_Len
: Integer;
2006 C_Host_Dir
(1 .. Host_Dir
'Length) := Host_Dir
;
2007 C_Host_Dir
(C_Host_Dir
'Last) := ASCII
.NUL
;
2009 if Prefix_Style
then
2010 Canonical_Dir_Addr
:= To_Canonical_Dir_Spec
(C_Host_Dir
'Address, 1);
2012 Canonical_Dir_Addr
:= To_Canonical_Dir_Spec
(C_Host_Dir
'Address, 0);
2014 Canonical_Dir_Len
:= C_String_Length
(Canonical_Dir_Addr
);
2016 if Canonical_Dir_Len
= 0 then
2019 return To_Path_String_Access
(Canonical_Dir_Addr
, Canonical_Dir_Len
);
2024 Fail
("erroneous directory spec: ", Host_Dir
);
2026 end To_Canonical_Dir_Spec
;
2028 ---------------------------
2029 -- To_Canonical_File_List --
2030 ---------------------------
2032 function To_Canonical_File_List
2033 (Wildcard_Host_File
: String;
2034 Only_Dirs
: Boolean)
2035 return String_Access_List_Access
2037 function To_Canonical_File_List_Init
2038 (Host_File
: Address
;
2039 Only_Dirs
: Integer)
2041 pragma Import
(C
, To_Canonical_File_List_Init
,
2042 "__gnat_to_canonical_file_list_init");
2044 function To_Canonical_File_List_Next
return Address
;
2045 pragma Import
(C
, To_Canonical_File_List_Next
,
2046 "__gnat_to_canonical_file_list_next");
2048 procedure To_Canonical_File_List_Free
;
2049 pragma Import
(C
, To_Canonical_File_List_Free
,
2050 "__gnat_to_canonical_file_list_free");
2052 Num_Files
: Integer;
2053 C_Wildcard_Host_File
: String (1 .. Wildcard_Host_File
'Length + 1);
2056 C_Wildcard_Host_File
(1 .. Wildcard_Host_File
'Length) :=
2058 C_Wildcard_Host_File
(C_Wildcard_Host_File
'Last) := ASCII
.NUL
;
2060 -- Do the expansion and say how many there are
2062 Num_Files
:= To_Canonical_File_List_Init
2063 (C_Wildcard_Host_File
'Address, Boolean'Pos (Only_Dirs
));
2066 Canonical_File_List
: String_Access_List
(1 .. Num_Files
);
2067 Canonical_File_Addr
: Address
;
2068 Canonical_File_Len
: Integer;
2071 -- Retrieve the expanded directoy names and build the list
2073 for J
in 1 .. Num_Files
loop
2074 Canonical_File_Addr
:= To_Canonical_File_List_Next
;
2075 Canonical_File_Len
:= C_String_Length
(Canonical_File_Addr
);
2076 Canonical_File_List
(J
) := To_Path_String_Access
2077 (Canonical_File_Addr
, Canonical_File_Len
);
2080 -- Free up the storage
2082 To_Canonical_File_List_Free
;
2084 return new String_Access_List
'(Canonical_File_List);
2086 end To_Canonical_File_List;
2088 ----------------------------
2089 -- To_Canonical_File_Spec --
2090 ----------------------------
2092 function To_Canonical_File_Spec
2093 (Host_File : String)
2094 return String_Access
2096 function To_Canonical_File_Spec (Host_File : Address) return Address;
2098 (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
2100 C_Host_File : String (1 .. Host_File'Length + 1);
2101 Canonical_File_Addr : Address;
2102 Canonical_File_Len : Integer;
2105 C_Host_File (1 .. Host_File'Length) := Host_File;
2106 C_Host_File (C_Host_File'Last) := ASCII.NUL;
2108 Canonical_File_Addr := To_Canonical_File_Spec (C_Host_File'Address);
2109 Canonical_File_Len := C_String_Length (Canonical_File_Addr);
2111 if Canonical_File_Len = 0 then
2114 return To_Path_String_Access
2115 (Canonical_File_Addr, Canonical_File_Len);
2120 Fail ("erroneous file spec: ", Host_File);
2122 end To_Canonical_File_Spec;
2124 ----------------------------
2125 -- To_Canonical_Path_Spec --
2126 ----------------------------
2128 function To_Canonical_Path_Spec
2129 (Host_Path : String)
2130 return String_Access
2132 function To_Canonical_Path_Spec (Host_Path : Address) return Address;
2134 (C, To_Canonical_Path_Spec, "__gnat_to_canonical_path_spec");
2136 C_Host_Path : String (1 .. Host_Path'Length + 1);
2137 Canonical_Path_Addr : Address;
2138 Canonical_Path_Len : Integer;
2141 C_Host_Path (1 .. Host_Path'Length) := Host_Path;
2142 C_Host_Path (C_Host_Path'Last) := ASCII.NUL;
2144 Canonical_Path_Addr := To_Canonical_Path_Spec (C_Host_Path'Address);
2145 Canonical_Path_Len := C_String_Length (Canonical_Path_Addr);
2147 -- Return a null string (vice a null) for zero length paths, for
2148 -- compatibility with getenv().
2150 return To_Path_String_Access (Canonical_Path_Addr, Canonical_Path_Len);
2154 Fail ("erroneous path spec: ", Host_Path);
2156 end To_Canonical_Path_Spec;
2158 ---------------------------
2159 -- To_Host_Dir_Spec --
2160 ---------------------------
2162 function To_Host_Dir_Spec
2163 (Canonical_Dir : String;
2164 Prefix_Style : Boolean)
2165 return String_Access
2167 function To_Host_Dir_Spec
2168 (Canonical_Dir : Address;
2169 Prefix_Flag : Integer)
2171 pragma Import (C, To_Host_Dir_Spec, "__gnat_to_host_dir_spec");
2173 C_Canonical_Dir : String (1 .. Canonical_Dir'Length + 1);
2174 Host_Dir_Addr : Address;
2175 Host_Dir_Len : Integer;
2178 C_Canonical_Dir (1 .. Canonical_Dir'Length) := Canonical_Dir;
2179 C_Canonical_Dir (C_Canonical_Dir'Last) := ASCII.NUL;
2181 if Prefix_Style then
2182 Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 1);
2184 Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 0);
2186 Host_Dir_Len := C_String_Length (Host_Dir_Addr);
2188 if Host_Dir_Len = 0 then
2191 return To_Path_String_Access (Host_Dir_Addr, Host_Dir_Len);
2193 end To_Host_Dir_Spec;
2195 ----------------------------
2196 -- To_Host_File_Spec --
2197 ----------------------------
2199 function To_Host_File_Spec
2200 (Canonical_File : String)
2201 return String_Access
2203 function To_Host_File_Spec (Canonical_File : Address) return Address;
2204 pragma Import (C, To_Host_File_Spec, "__gnat_to_host_file_spec");
2206 C_Canonical_File : String (1 .. Canonical_File'Length + 1);
2207 Host_File_Addr : Address;
2208 Host_File_Len : Integer;
2211 C_Canonical_File (1 .. Canonical_File'Length) := Canonical_File;
2212 C_Canonical_File (C_Canonical_File'Last) := ASCII.NUL;
2214 Host_File_Addr := To_Host_File_Spec (C_Canonical_File'Address);
2215 Host_File_Len := C_String_Length (Host_File_Addr);
2217 if Host_File_Len = 0 then
2220 return To_Path_String_Access
2221 (Host_File_Addr, Host_File_Len);
2223 end To_Host_File_Spec;
2225 ---------------------------
2226 -- To_Path_String_Access --
2227 ---------------------------
2229 function To_Path_String_Access
2230 (Path_Addr : Address;
2232 return String_Access
2234 subtype Path_String is String (1 .. Path_Len);
2235 type Path_String_Access is access Path_String;
2237 function Address_To_Access is new
2238 Unchecked_Conversion (Source => Address,
2239 Target => Path_String_Access);
2241 Path_Access : Path_String_Access := Address_To_Access (Path_Addr);
2243 Return_Val : String_Access;
2246 Return_Val := new String (1 .. Path_Len);
2248 for J in 1 .. Path_Len loop
2249 Return_Val (J) := Path_Access (J);
2253 end To_Path_String_Access;
2259 function Update_Path (Path : String_Ptr) return String_Ptr is
2261 function C_Update_Path (Path, Component : Address) return Address;
2262 pragma Import (C, C_Update_Path, "update_path");
2264 function Strlen (Str : Address) return Integer;
2265 pragma Import (C, Strlen, "strlen");
2267 procedure Strncpy (X : Address; Y : Address; Length : Integer);
2268 pragma Import (C, Strncpy, "strncpy");
2270 In_Length : constant Integer := Path'Length;
2271 In_String : String (1 .. In_Length + 1);
2272 Component_Name : aliased String := "GNAT" & ASCII.NUL;
2273 Result_Ptr : Address;
2274 Result_Length : Integer;
2275 Out_String : String_Ptr;
2278 In_String (1 .. In_Length) := Path.all;
2279 In_String (In_Length + 1) := ASCII.NUL;
2280 Result_Ptr := C_Update_Path (In_String'Address,
2281 Component_Name'Address);
2282 Result_Length := Strlen (Result_Ptr);
2284 Out_String := new String (1 .. Result_Length);
2285 Strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
2293 procedure Write_Info (Info : String) is
2295 Write_With_Check (Info'Address, Info'Length);
2296 Write_With_Check (EOL'Address, 1);
2299 ------------------------
2300 -- Write_Program_Name --
2301 ------------------------
2303 procedure Write_Program_Name is
2304 Save_Buffer : String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
2310 -- Convert the name to lower case so error messages are the same on
2313 for J in 1 .. Name_Len loop
2314 if Name_Buffer (J) in 'A
' .. 'Z
' then
2316 Character'Val (Character'Pos (Name_Buffer (J)) + 32);
2320 Write_Str (Name_Buffer (1 .. Name_Len));
2322 -- Restore Name_Buffer which was clobbered by the call to
2323 -- Find_Program_Name
2325 Name_Len := Save_Buffer'Last;
2326 Name_Buffer (1 .. Name_Len) := Save_Buffer;
2327 end Write_Program_Name;
2329 ----------------------
2330 -- Write_With_Check --
2331 ----------------------
2333 procedure Write_With_Check (A : Address; N : Integer) is
2337 if N = Write (Output_FD, A, N) then
2341 Write_Str ("error: disk full writing ");
2342 Write_Name_Decoded (Output_File_Name);
2344 Name_Len := Name_Len + 1;
2345 Name_Buffer (Name_Len) := ASCII.NUL;
2346 Delete_File (Name_Buffer'Address, Ignore);
2347 Exit_Program (E_Fatal);
2349 end Write_With_Check;
2351 ----------------------------
2352 -- Package Initialization --
2353 ----------------------------
2356 Initialization : declare
2358 function Get_Default_Identifier_Character_Set return Character;
2359 pragma Import (C, Get_Default_Identifier_Character_Set,
2360 "__gnat_get_default_identifier_character_set");
2361 -- Function to determine the default identifier character set,
2362 -- which is system dependent. See Opt package spec for a list of
2363 -- the possible character codes and their interpretations.
2365 function Get_Maximum_File_Name_Length return Int;
2366 pragma Import (C, Get_Maximum_File_Name_Length,
2367 "__gnat_get_maximum_file_name_length");
2368 -- Function to get maximum file name length for system
2371 Src_Search_Directories.Init;
2372 Lib_Search_Directories.Init;
2374 Identifier_Character_Set := Get_Default_Identifier_Character_Set;
2375 Maximum_File_Name_Length := Get_Maximum_File_Name_Length;
2377 -- Following should be removed by having above function return
2378 -- Integer'Last as indication of no maximum instead of -1 ???
2380 if Maximum_File_Name_Length = -1 then
2381 Maximum_File_Name_Length := Int'Last;
2384 -- Start off by setting all suppress options to False, these will
2385 -- be reset later (turning some on if -gnato is not specified, and
2386 -- turning all of them on if -gnatp is specified).
2388 Suppress_Options := (others => False);
2390 -- Reserve the first slot in the search paths table. This is the
2391 -- directory of the main source file or main library file and is
2392 -- filled in by each call to Next_Main_Source/Next_Main_Lib_File with
2393 -- the directory specified for this main source or library file. This
2394 -- is the directory which is searched first by default. This default
2395 -- search is inhibited by the option -I- for both source and library
2398 Src_Search_Directories.Set_Last (Primary_Directory);
2399 Src_Search_Directories.Table (Primary_Directory) := new String'("");
2401 Lib_Search_Directories
.Set_Last
(Primary_Directory
);
2402 Lib_Search_Directories
.Table
(Primary_Directory
) := new String'("");