]>
Commit | Line | Data |
---|---|---|
38cbfe40 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- O S I N T -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
4b490c1e | 9 | -- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- |
38cbfe40 RK |
10 | -- -- |
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- -- | |
b5c84c3c | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
38cbfe40 RK |
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 -- | |
b5c84c3c RD |
18 | -- Public License distributed with GNAT; see file COPYING3. If not, go to -- |
19 | -- http://www.gnu.org/licenses for a complete copy of the license. -- | |
38cbfe40 RK |
20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
38cbfe40 RK |
23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
3743d5bd AC |
26 | with Alloc; |
27 | with Debug; | |
f6da8aff RD |
28 | with Fmap; use Fmap; |
29 | with Gnatvsn; use Gnatvsn; | |
39f4e199 | 30 | with Hostparm; |
f6da8aff RD |
31 | with Opt; use Opt; |
32 | with Output; use Output; | |
33 | with Sdefault; use Sdefault; | |
39f4e199 | 34 | with Table; |
f6da8aff | 35 | with Targparm; use Targparm; |
39f4e199 | 36 | |
fa5aa835 AC |
37 | with Unchecked_Conversion; |
38 | ||
9e9df9da AC |
39 | pragma Warnings (Off); |
40 | -- This package is used also by gnatcoll | |
fa5aa835 | 41 | with System.Case_Util; use System.Case_Util; |
0ef40c64 | 42 | with System.CRTL; |
9e9df9da | 43 | pragma Warnings (On); |
fa5aa835 AC |
44 | |
45 | with GNAT.HTable; | |
46 | ||
38cbfe40 RK |
47 | package body Osint is |
48 | ||
4f852a1a EB |
49 | use type CRTL.size_t; |
50 | ||
07fc65c4 | 51 | Running_Program : Program_Type := Unspecified; |
65356e64 | 52 | -- comment required here ??? |
07fc65c4 | 53 | |
65356e64 AC |
54 | Program_Set : Boolean := False; |
55 | -- comment required here ??? | |
56 | ||
57 | Std_Prefix : String_Ptr; | |
2cdc8909 AC |
58 | -- Standard prefix, computed dynamically the first time Relocate_Path |
59 | -- is called, and cached for subsequent calls. | |
60 | ||
d05ef0ab AC |
61 | Empty : aliased String := ""; |
62 | No_Dir : constant String_Ptr := Empty'Access; | |
63 | -- Used in Locate_File as a fake directory when Name is already an | |
64 | -- absolute path. | |
65 | ||
38cbfe40 RK |
66 | ------------------------------------- |
67 | -- Use of Name_Find and Name_Enter -- | |
68 | ------------------------------------- | |
69 | ||
70 | -- This package creates a number of source, ALI and object file names | |
39f4e199 VC |
71 | -- that are used to locate the actual file and for the purpose of message |
72 | -- construction. These names need not be accessible by Name_Find, and can | |
73 | -- be therefore created by using routine Name_Enter. The files in question | |
dec55d76 RW |
74 | -- are file names with a prefix directory (i.e., the files not in the |
75 | -- current directory). File names without a prefix directory are entered | |
76 | -- with Name_Find because special values might be attached to the various | |
77 | -- Info fields of the corresponding name table entry. | |
38cbfe40 RK |
78 | |
79 | ----------------------- | |
80 | -- Local Subprograms -- | |
81 | ----------------------- | |
82 | ||
83 | function Append_Suffix_To_File_Name | |
39f4e199 VC |
84 | (Name : File_Name_Type; |
85 | Suffix : String) return File_Name_Type; | |
9de61fcb | 86 | -- Appends Suffix to Name and returns the new name |
38cbfe40 RK |
87 | |
88 | function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type; | |
d56e7acd AC |
89 | -- Convert OS format time to GNAT format time stamp. If T is Invalid_Time, |
90 | -- then returns Empty_Time_Stamp. | |
64989f18 DA |
91 | -- Round to even seconds on Windows before conversion. |
92 | -- Windows ALI files had timestamps rounded to even seconds historically. | |
93 | -- The rounding was originally done in GM_Split. Now that GM_Split no | |
94 | -- longer does it, we are rounding it here only for ALI files. | |
38cbfe40 | 95 | |
2cdc8909 AC |
96 | function Executable_Prefix return String_Ptr; |
97 | -- Returns the name of the root directory where the executable is stored. | |
39f4e199 VC |
98 | -- The executable must be located in a directory called "bin", or under |
99 | -- root/lib/gcc-lib/..., or under root/libexec/gcc/... For example, if | |
100 | -- executable is stored in directory "/foo/bar/bin", this routine returns | |
101 | -- "/foo/bar/". Return "" if location is not recognized as described above. | |
2cdc8909 | 102 | |
07fc65c4 | 103 | function Update_Path (Path : String_Ptr) return String_Ptr; |
d56e7acd AC |
104 | -- Update the specified path to replace the prefix with the location where |
105 | -- GNAT is installed. See the file prefix.c in GCC for details. | |
38cbfe40 | 106 | |
48263c9a EB |
107 | procedure Locate_File |
108 | (N : File_Name_Type; | |
109 | T : File_Type; | |
110 | Dir : Natural; | |
111 | Name : String; | |
112 | Found : out File_Name_Type; | |
113 | Attr : access File_Attributes); | |
39f4e199 VC |
114 | -- See if the file N whose name is Name exists in directory Dir. Dir is an |
115 | -- index into the Lib_Search_Directories table if T = Library. Otherwise | |
116 | -- if T = Source, Dir is an index into the Src_Search_Directories table. | |
117 | -- Returns the File_Name_Type of the full file name if file found, or | |
118 | -- No_File if not found. | |
d56e7acd | 119 | -- |
48263c9a EB |
120 | -- On exit, Found is set to the file that was found, and Attr to a cache of |
121 | -- its attributes (at least those that have been computed so far). Reusing | |
122 | -- the cache will save some system calls. | |
d56e7acd | 123 | -- |
48263c9a EB |
124 | -- Attr is always reset in this call to Unknown_Attributes, even in case of |
125 | -- failure | |
126 | ||
127 | procedure Find_File | |
3ccedacc AC |
128 | (N : File_Name_Type; |
129 | T : File_Type; | |
130 | Found : out File_Name_Type; | |
131 | Attr : access File_Attributes; | |
132 | Full_Name : Boolean := False); | |
48263c9a EB |
133 | -- A version of Find_File that also returns a cache of the file attributes |
134 | -- for later reuse | |
135 | ||
136 | procedure Smart_Find_File | |
137 | (N : File_Name_Type; | |
138 | T : File_Type; | |
139 | Found : out File_Name_Type; | |
140 | Attr : out File_Attributes); | |
141 | -- A version of Smart_Find_File that also returns a cache of the file | |
142 | -- attributes for later reuse | |
38cbfe40 | 143 | |
4f852a1a | 144 | function C_String_Length (S : Address) return CRTL.size_t; |
39f4e199 | 145 | -- Returns length of a C string (zero for a null address) |
38cbfe40 RK |
146 | |
147 | function To_Path_String_Access | |
148 | (Path_Addr : Address; | |
4f852a1a | 149 | Path_Len : CRTL.size_t) return String_Access; |
39f4e199 VC |
150 | -- Converts a C String to an Ada String. Are we doing this to avoid withing |
151 | -- Interfaces.C.Strings ??? | |
c9df623a | 152 | -- Caller must free result. |
38cbfe40 | 153 | |
3743d5bd AC |
154 | function Include_Dir_Default_Prefix return String_Access; |
155 | -- Same as exported version, except returns a String_Access | |
156 | ||
38cbfe40 RK |
157 | ------------------------------ |
158 | -- Other Local Declarations -- | |
159 | ------------------------------ | |
160 | ||
38cbfe40 RK |
161 | EOL : constant Character := ASCII.LF; |
162 | -- End of line character | |
163 | ||
16e764a7 | 164 | Number_File_Names : Nat := 0; |
6de1be02 | 165 | -- Number of file names found on command line and placed in File_Names |
38cbfe40 | 166 | |
38cbfe40 | 167 | Look_In_Primary_Directory_For_Current_Main : Boolean := False; |
39f4e199 VC |
168 | -- When this variable is True, Find_File only looks in Primary_Directory |
169 | -- for the Current_Main file. This variable is always set to True for the | |
dec55d76 | 170 | -- compiler. It is also True for gnatmake, when the source name given on |
39f4e199 | 171 | -- the command line has directory information. |
38cbfe40 RK |
172 | |
173 | Current_Full_Source_Name : File_Name_Type := No_File; | |
174 | Current_Full_Source_Stamp : Time_Stamp_Type := Empty_Time_Stamp; | |
175 | Current_Full_Lib_Name : File_Name_Type := No_File; | |
176 | Current_Full_Lib_Stamp : Time_Stamp_Type := Empty_Time_Stamp; | |
177 | Current_Full_Obj_Name : File_Name_Type := No_File; | |
178 | Current_Full_Obj_Stamp : Time_Stamp_Type := Empty_Time_Stamp; | |
39f4e199 VC |
179 | -- Respectively full name (with directory info) and time stamp of the |
180 | -- latest source, library and object files opened by Read_Source_File and | |
181 | -- Read_Library_Info. | |
38cbfe40 | 182 | |
3743d5bd AC |
183 | package File_Name_Chars is new Table.Table ( |
184 | Table_Component_Type => Character, | |
185 | Table_Index_Type => Int, | |
186 | Table_Low_Bound => 1, | |
187 | Table_Initial => Alloc.File_Name_Chars_Initial, | |
188 | Table_Increment => Alloc.File_Name_Chars_Increment, | |
189 | Table_Name => "File_Name_Chars"); | |
190 | -- Table to store text to be printed by Dump_Source_File_Names | |
191 | ||
192 | The_Include_Dir_Default_Prefix : String_Access := null; | |
193 | -- Value returned by Include_Dir_Default_Prefix. We don't initialize it | |
194 | -- here, because that causes an elaboration cycle with Sdefault; we | |
195 | -- initialize it lazily instead. | |
196 | ||
38cbfe40 RK |
197 | ------------------ |
198 | -- Search Paths -- | |
199 | ------------------ | |
200 | ||
201 | Primary_Directory : constant := 0; | |
202 | -- This is index in the tables created below for the first directory to | |
39f4e199 VC |
203 | -- search in for source or library information files. This is the directory |
204 | -- containing the latest main input file (a source file for the compiler or | |
205 | -- a library file for the binder). | |
38cbfe40 RK |
206 | |
207 | package Src_Search_Directories is new Table.Table ( | |
208 | Table_Component_Type => String_Ptr, | |
39f4e199 | 209 | Table_Index_Type => Integer, |
38cbfe40 RK |
210 | Table_Low_Bound => Primary_Directory, |
211 | Table_Initial => 10, | |
212 | Table_Increment => 100, | |
213 | Table_Name => "Osint.Src_Search_Directories"); | |
214 | -- Table of names of directories in which to search for source (Compiler) | |
215 | -- files. This table is filled in the order in which the directories are | |
216 | -- to be searched, and then used in that order. | |
217 | ||
218 | package Lib_Search_Directories is new Table.Table ( | |
219 | Table_Component_Type => String_Ptr, | |
39f4e199 | 220 | Table_Index_Type => Integer, |
38cbfe40 RK |
221 | Table_Low_Bound => Primary_Directory, |
222 | Table_Initial => 10, | |
223 | Table_Increment => 100, | |
224 | Table_Name => "Osint.Lib_Search_Directories"); | |
225 | -- Table of names of directories in which to search for library (Binder) | |
226 | -- files. This table is filled in the order in which the directories are | |
227 | -- to be searched and then used in that order. The reason for having two | |
228 | -- distinct tables is that we need them both in gnatmake. | |
229 | ||
230 | --------------------- | |
231 | -- File Hash Table -- | |
232 | --------------------- | |
233 | ||
234 | -- The file hash table is provided to free the programmer from any | |
235 | -- efficiency concern when retrieving full file names or time stamps of | |
236 | -- source files. If the programmer calls Source_File_Data (Cache => True) | |
dec55d76 | 237 | -- he is guaranteed that the price to retrieve the full name (i.e. with |
39f4e199 VC |
238 | -- directory info) or time stamp of the file will be payed only once, the |
239 | -- first time the full name is actually searched (or the first time the | |
240 | -- time stamp is actually retrieved). This is achieved by employing a hash | |
241 | -- table that stores as a key the File_Name_Type of the file and associates | |
242 | -- to that File_Name_Type the full file name and time stamp of the file. | |
38cbfe40 RK |
243 | |
244 | File_Cache_Enabled : Boolean := False; | |
9de61fcb | 245 | -- Set to true if you want the enable the file data caching mechanism |
38cbfe40 RK |
246 | |
247 | type File_Hash_Num is range 0 .. 1020; | |
248 | ||
249 | function File_Hash (F : File_Name_Type) return File_Hash_Num; | |
250 | -- Compute hash index for use by Simple_HTable | |
251 | ||
48263c9a EB |
252 | type File_Info_Cache is record |
253 | File : File_Name_Type; | |
254 | Attr : aliased File_Attributes; | |
255 | end record; | |
d56e7acd | 256 | |
f70b0116 | 257 | No_File_Info_Cache : constant File_Info_Cache := (No_File, (others => 0)); |
38cbfe40 | 258 | |
48263c9a | 259 | package File_Name_Hash_Table is new GNAT.HTable.Simple_HTable ( |
38cbfe40 | 260 | Header_Num => File_Hash_Num, |
48263c9a EB |
261 | Element => File_Info_Cache, |
262 | No_Element => No_File_Info_Cache, | |
38cbfe40 RK |
263 | Key => File_Name_Type, |
264 | Hash => File_Hash, | |
265 | Equal => "="); | |
266 | ||
267 | function Smart_Find_File | |
65356e64 AC |
268 | (N : File_Name_Type; |
269 | T : File_Type) return File_Name_Type; | |
38cbfe40 RK |
270 | -- Exactly like Find_File except that if File_Cache_Enabled is True this |
271 | -- routine looks first in the hash table to see if the full name of the | |
272 | -- file is already available. | |
273 | ||
274 | function Smart_File_Stamp | |
65356e64 AC |
275 | (N : File_Name_Type; |
276 | T : File_Type) return Time_Stamp_Type; | |
39f4e199 VC |
277 | -- Takes the same parameter as the routine above (N is a file name without |
278 | -- any prefix directory information) and behaves like File_Stamp except | |
279 | -- that if File_Cache_Enabled is True this routine looks first in the hash | |
280 | -- table to see if the file stamp of the file is already available. | |
38cbfe40 RK |
281 | |
282 | ----------------------------- | |
283 | -- Add_Default_Search_Dirs -- | |
284 | ----------------------------- | |
285 | ||
286 | procedure Add_Default_Search_Dirs is | |
fbf5a39b AC |
287 | Search_Dir : String_Access; |
288 | Search_Path : String_Access; | |
289 | Path_File_Name : String_Access; | |
38cbfe40 | 290 | |
fbf5a39b AC |
291 | procedure Add_Search_Dir |
292 | (Search_Dir : String; | |
293 | Additional_Source_Dir : Boolean); | |
38cbfe40 RK |
294 | procedure Add_Search_Dir |
295 | (Search_Dir : String_Access; | |
296 | Additional_Source_Dir : Boolean); | |
07fc65c4 GB |
297 | -- Add a source search dir or a library search dir, depending on the |
298 | -- value of Additional_Source_Dir. | |
38cbfe40 | 299 | |
fbf5a39b AC |
300 | procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean); |
301 | -- Open a path file and read the directory to search, one per line | |
302 | ||
38cbfe40 RK |
303 | function Get_Libraries_From_Registry return String_Ptr; |
304 | -- On Windows systems, get the list of installed standard libraries | |
305 | -- from the registry key: | |
4ecc031c | 306 | -- |
38cbfe40 RK |
307 | -- HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\ |
308 | -- GNAT\Standard Libraries | |
c4dec83f JR |
309 | -- Return an empty string on other systems. |
310 | -- | |
311 | -- Note that this is an undocumented legacy feature, and that it | |
312 | -- works only when using the default runtime library (i.e. no --RTS= | |
313 | -- command line switch). | |
38cbfe40 | 314 | |
38cbfe40 RK |
315 | -------------------- |
316 | -- Add_Search_Dir -- | |
317 | -------------------- | |
318 | ||
fbf5a39b AC |
319 | procedure Add_Search_Dir |
320 | (Search_Dir : String; | |
321 | Additional_Source_Dir : Boolean) | |
322 | is | |
323 | begin | |
324 | if Additional_Source_Dir then | |
325 | Add_Src_Search_Dir (Search_Dir); | |
326 | else | |
327 | Add_Lib_Search_Dir (Search_Dir); | |
328 | end if; | |
329 | end Add_Search_Dir; | |
330 | ||
38cbfe40 RK |
331 | procedure Add_Search_Dir |
332 | (Search_Dir : String_Access; | |
333 | Additional_Source_Dir : Boolean) | |
334 | is | |
335 | begin | |
336 | if Additional_Source_Dir then | |
337 | Add_Src_Search_Dir (Search_Dir.all); | |
338 | else | |
339 | Add_Lib_Search_Dir (Search_Dir.all); | |
340 | end if; | |
341 | end Add_Search_Dir; | |
342 | ||
fbf5a39b AC |
343 | ------------------------ |
344 | -- Get_Dirs_From_File -- | |
345 | ------------------------ | |
346 | ||
347 | procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean) is | |
348 | File_FD : File_Descriptor; | |
4ecc031c | 349 | Buffer : constant String := Path_File_Name.all & ASCII.NUL; |
fbf5a39b AC |
350 | Len : Natural; |
351 | Actual_Len : Natural; | |
352 | S : String_Access; | |
353 | Curr : Natural; | |
354 | First : Natural; | |
355 | Ch : Character; | |
356 | ||
357 | Status : Boolean; | |
67ce0d7e | 358 | pragma Warnings (Off, Status); |
8c64de1e | 359 | -- For the call to Close where status is ignored |
fbf5a39b AC |
360 | |
361 | begin | |
fbf5a39b AC |
362 | File_FD := Open_Read (Buffer'Address, Binary); |
363 | ||
364 | -- If we cannot open the file, we ignore it, we don't fail | |
365 | ||
366 | if File_FD = Invalid_FD then | |
367 | return; | |
368 | end if; | |
369 | ||
370 | Len := Integer (File_Length (File_FD)); | |
371 | ||
372 | S := new String (1 .. Len); | |
373 | ||
7a5b62b0 AC |
374 | -- Read the file. Note that the loop is probably not necessary any |
375 | -- more since the whole file is read in at once on all targets. But | |
376 | -- it is harmless and might be needed in future. | |
fbf5a39b AC |
377 | |
378 | Curr := 1; | |
379 | Actual_Len := Len; | |
380 | while Curr <= Len and then Actual_Len /= 0 loop | |
381 | Actual_Len := Read (File_FD, S (Curr)'Address, Len); | |
382 | Curr := Curr + Actual_Len; | |
383 | end loop; | |
384 | ||
39f4e199 VC |
385 | -- We are done with the file, so we close it (ignore any error on |
386 | -- the close, since we have successfully read the file). | |
fbf5a39b AC |
387 | |
388 | Close (File_FD, Status); | |
fbf5a39b AC |
389 | |
390 | -- Now, we read line by line | |
391 | ||
392 | First := 1; | |
393 | Curr := 0; | |
fbf5a39b AC |
394 | while Curr < Len loop |
395 | Ch := S (Curr + 1); | |
396 | ||
397 | if Ch = ASCII.CR or else Ch = ASCII.LF | |
398 | or else Ch = ASCII.FF or else Ch = ASCII.VT | |
399 | then | |
400 | if First <= Curr then | |
401 | Add_Search_Dir (S (First .. Curr), Additional_Source_Dir); | |
402 | end if; | |
403 | ||
404 | First := Curr + 2; | |
405 | end if; | |
406 | ||
407 | Curr := Curr + 1; | |
408 | end loop; | |
409 | ||
410 | -- Last line is a special case, if the file does not end with | |
411 | -- an end of line mark. | |
412 | ||
413 | if First <= S'Last then | |
414 | Add_Search_Dir (S (First .. S'Last), Additional_Source_Dir); | |
415 | end if; | |
416 | end Get_Dirs_From_File; | |
417 | ||
38cbfe40 RK |
418 | --------------------------------- |
419 | -- Get_Libraries_From_Registry -- | |
420 | --------------------------------- | |
421 | ||
422 | function Get_Libraries_From_Registry return String_Ptr is | |
423 | function C_Get_Libraries_From_Registry return Address; | |
424 | pragma Import (C, C_Get_Libraries_From_Registry, | |
425 | "__gnat_get_libraries_from_registry"); | |
4ecc031c | 426 | |
4ecc031c | 427 | Result_Ptr : Address; |
4f852a1a | 428 | Result_Length : CRTL.size_t; |
4ecc031c | 429 | Out_String : String_Ptr; |
38cbfe40 RK |
430 | |
431 | begin | |
432 | Result_Ptr := C_Get_Libraries_From_Registry; | |
4f852a1a | 433 | Result_Length := CRTL.strlen (Result_Ptr); |
38cbfe40 | 434 | |
4f852a1a EB |
435 | Out_String := new String (1 .. Integer (Result_Length)); |
436 | CRTL.strncpy (Out_String.all'Address, Result_Ptr, Result_Length); | |
262991d8 | 437 | |
4f852a1a | 438 | CRTL.free (Result_Ptr); |
262991d8 | 439 | |
38cbfe40 RK |
440 | return Out_String; |
441 | end Get_Libraries_From_Registry; | |
442 | ||
38cbfe40 RK |
443 | -- Start of processing for Add_Default_Search_Dirs |
444 | ||
445 | begin | |
36504e5f AC |
446 | -- If there was a -gnateO switch, add all object directories from the |
447 | -- file given in argument to the library search list. | |
448 | ||
449 | if Object_Path_File_Name /= null then | |
450 | Path_File_Name := String_Access (Object_Path_File_Name); | |
451 | pragma Assert (Path_File_Name'Length > 0); | |
452 | Get_Dirs_From_File (Additional_Source_Dir => False); | |
453 | end if; | |
454 | ||
38cbfe40 RK |
455 | -- After the locations specified on the command line, the next places |
456 | -- to look for files are the directories specified by the appropriate | |
457 | -- environment variable. Get this value, extract the directory names | |
458 | -- and store in the tables. | |
459 | ||
96f2e32f VC |
460 | -- Check for eventual project path file env vars |
461 | ||
462 | Path_File_Name := Getenv (Project_Include_Path_File); | |
463 | ||
464 | if Path_File_Name'Length > 0 then | |
465 | Get_Dirs_From_File (Additional_Source_Dir => True); | |
466 | end if; | |
467 | ||
468 | Path_File_Name := Getenv (Project_Objects_Path_File); | |
469 | ||
470 | if Path_File_Name'Length > 0 then | |
471 | Get_Dirs_From_File (Additional_Source_Dir => False); | |
472 | end if; | |
473 | ||
7a5b62b0 | 474 | -- Put path name in canonical form |
38cbfe40 RK |
475 | |
476 | for Additional_Source_Dir in False .. True loop | |
38cbfe40 | 477 | if Additional_Source_Dir then |
fbf5a39b | 478 | Search_Path := Getenv (Ada_Include_Path); |
4ecc031c | 479 | |
38cbfe40 | 480 | else |
fbf5a39b | 481 | Search_Path := Getenv (Ada_Objects_Path); |
4ecc031c | 482 | |
38cbfe40 RK |
483 | end if; |
484 | ||
485 | Get_Next_Dir_In_Path_Init (Search_Path); | |
486 | loop | |
487 | Search_Dir := Get_Next_Dir_In_Path (Search_Path); | |
488 | exit when Search_Dir = null; | |
489 | Add_Search_Dir (Search_Dir, Additional_Source_Dir); | |
490 | end loop; | |
491 | end loop; | |
492 | ||
96f2e32f | 493 | -- For the compiler, if --RTS= was specified, add the runtime |
fbf5a39b | 494 | -- directories. |
38cbfe40 | 495 | |
7a5b62b0 | 496 | if RTS_Src_Path_Name /= null and then RTS_Lib_Path_Name /= null then |
fbf5a39b AC |
497 | Add_Search_Dirs (RTS_Src_Path_Name, Include); |
498 | Add_Search_Dirs (RTS_Lib_Path_Name, Objects); | |
499 | ||
500 | else | |
501 | if not Opt.No_Stdinc then | |
502 | ||
503 | -- For WIN32 systems, look for any system libraries defined in | |
504 | -- the registry. These are added to both source and object | |
505 | -- directories. | |
506 | ||
507 | Search_Path := String_Access (Get_Libraries_From_Registry); | |
508 | ||
509 | Get_Next_Dir_In_Path_Init (Search_Path); | |
510 | loop | |
511 | Search_Dir := Get_Next_Dir_In_Path (Search_Path); | |
512 | exit when Search_Dir = null; | |
513 | Add_Search_Dir (Search_Dir, False); | |
514 | Add_Search_Dir (Search_Dir, True); | |
515 | end loop; | |
516 | ||
517 | -- The last place to look are the defaults | |
518 | ||
519 | Search_Path := | |
520 | Read_Default_Search_Dirs | |
521 | (String_Access (Update_Path (Search_Dir_Prefix)), | |
522 | Include_Search_File, | |
523 | String_Access (Update_Path (Include_Dir_Default_Name))); | |
524 | ||
525 | Get_Next_Dir_In_Path_Init (Search_Path); | |
526 | loop | |
527 | Search_Dir := Get_Next_Dir_In_Path (Search_Path); | |
528 | exit when Search_Dir = null; | |
529 | Add_Search_Dir (Search_Dir, True); | |
530 | end loop; | |
531 | end if; | |
38cbfe40 | 532 | |
946db1e2 AC |
533 | -- Even when -nostdlib is used, we still want to have visibility on |
534 | -- the run-time object directory, as it is used by gnatbind to find | |
535 | -- the run-time ALI files in "real" ZFP set up. | |
536 | ||
537 | if not Opt.RTS_Switch then | |
fbf5a39b AC |
538 | Search_Path := |
539 | Read_Default_Search_Dirs | |
540 | (String_Access (Update_Path (Search_Dir_Prefix)), | |
541 | Objects_Search_File, | |
542 | String_Access (Update_Path (Object_Dir_Default_Name))); | |
543 | ||
544 | Get_Next_Dir_In_Path_Init (Search_Path); | |
545 | loop | |
546 | Search_Dir := Get_Next_Dir_In_Path (Search_Path); | |
547 | exit when Search_Dir = null; | |
548 | Add_Search_Dir (Search_Dir, False); | |
549 | end loop; | |
550 | end if; | |
551 | end if; | |
38cbfe40 RK |
552 | end Add_Default_Search_Dirs; |
553 | ||
554 | -------------- | |
555 | -- Add_File -- | |
556 | -------------- | |
557 | ||
aa720a54 | 558 | procedure Add_File (File_Name : String; Index : Int := No_Index) is |
38cbfe40 RK |
559 | begin |
560 | Number_File_Names := Number_File_Names + 1; | |
561 | ||
39f4e199 VC |
562 | -- As Add_File may be called for mains specified inside a project file, |
563 | -- File_Names may be too short and needs to be extended. | |
38cbfe40 RK |
564 | |
565 | if Number_File_Names > File_Names'Last then | |
566 | File_Names := new File_Name_Array'(File_Names.all & File_Names.all); | |
aa720a54 AC |
567 | File_Indexes := |
568 | new File_Index_Array'(File_Indexes.all & File_Indexes.all); | |
38cbfe40 RK |
569 | end if; |
570 | ||
aa720a54 AC |
571 | File_Names (Number_File_Names) := new String'(File_Name); |
572 | File_Indexes (Number_File_Names) := Index; | |
38cbfe40 RK |
573 | end Add_File; |
574 | ||
575 | ------------------------ | |
576 | -- Add_Lib_Search_Dir -- | |
577 | ------------------------ | |
578 | ||
579 | procedure Add_Lib_Search_Dir (Dir : String) is | |
580 | begin | |
581 | if Dir'Length = 0 then | |
582 | Fail ("missing library directory name"); | |
583 | end if; | |
584 | ||
cafdbd2e AC |
585 | declare |
586 | Norm : String_Ptr := Normalize_Directory_Name (Dir); | |
cafdbd2e | 587 | |
d56e7acd | 588 | begin |
cafdbd2e AC |
589 | -- Do nothing if the directory is already in the list. This saves |
590 | -- system calls and avoid unneeded work | |
591 | ||
592 | for D in Lib_Search_Directories.First .. | |
d56e7acd | 593 | Lib_Search_Directories.Last |
cafdbd2e AC |
594 | loop |
595 | if Lib_Search_Directories.Table (D).all = Norm.all then | |
596 | Free (Norm); | |
597 | return; | |
598 | end if; | |
599 | end loop; | |
600 | ||
601 | Lib_Search_Directories.Increment_Last; | |
602 | Lib_Search_Directories.Table (Lib_Search_Directories.Last) := Norm; | |
603 | end; | |
38cbfe40 RK |
604 | end Add_Lib_Search_Dir; |
605 | ||
07fc65c4 GB |
606 | --------------------- |
607 | -- Add_Search_Dirs -- | |
608 | --------------------- | |
609 | ||
610 | procedure Add_Search_Dirs | |
611 | (Search_Path : String_Ptr; | |
612 | Path_Type : Search_File_Type) | |
613 | is | |
614 | Current_Search_Path : String_Access; | |
615 | ||
616 | begin | |
617 | Get_Next_Dir_In_Path_Init (String_Access (Search_Path)); | |
618 | loop | |
619 | Current_Search_Path := | |
620 | Get_Next_Dir_In_Path (String_Access (Search_Path)); | |
621 | exit when Current_Search_Path = null; | |
622 | ||
623 | if Path_Type = Include then | |
624 | Add_Src_Search_Dir (Current_Search_Path.all); | |
625 | else | |
626 | Add_Lib_Search_Dir (Current_Search_Path.all); | |
627 | end if; | |
628 | end loop; | |
629 | end Add_Search_Dirs; | |
630 | ||
38cbfe40 RK |
631 | ------------------------ |
632 | -- Add_Src_Search_Dir -- | |
633 | ------------------------ | |
634 | ||
635 | procedure Add_Src_Search_Dir (Dir : String) is | |
636 | begin | |
637 | if Dir'Length = 0 then | |
638 | Fail ("missing source directory name"); | |
639 | end if; | |
640 | ||
641 | Src_Search_Directories.Increment_Last; | |
642 | Src_Search_Directories.Table (Src_Search_Directories.Last) := | |
643 | Normalize_Directory_Name (Dir); | |
644 | end Add_Src_Search_Dir; | |
645 | ||
646 | -------------------------------- | |
647 | -- Append_Suffix_To_File_Name -- | |
648 | -------------------------------- | |
649 | ||
650 | function Append_Suffix_To_File_Name | |
39f4e199 VC |
651 | (Name : File_Name_Type; |
652 | Suffix : String) return File_Name_Type | |
38cbfe40 RK |
653 | is |
654 | begin | |
655 | Get_Name_String (Name); | |
656 | Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix; | |
657 | Name_Len := Name_Len + Suffix'Length; | |
658 | return Name_Find; | |
659 | end Append_Suffix_To_File_Name; | |
660 | ||
661 | --------------------- | |
662 | -- C_String_Length -- | |
663 | --------------------- | |
664 | ||
4f852a1a | 665 | function C_String_Length (S : Address) return CRTL.size_t is |
38cbfe40 RK |
666 | begin |
667 | if S = Null_Address then | |
668 | return 0; | |
669 | else | |
4f852a1a | 670 | return CRTL.strlen (S); |
38cbfe40 RK |
671 | end if; |
672 | end C_String_Length; | |
673 | ||
674 | ------------------------------ | |
675 | -- Canonical_Case_File_Name -- | |
676 | ------------------------------ | |
677 | ||
38cbfe40 RK |
678 | procedure Canonical_Case_File_Name (S : in out String) is |
679 | begin | |
680 | if not File_Names_Case_Sensitive then | |
bd29d519 | 681 | To_Lower (S); |
38cbfe40 RK |
682 | end if; |
683 | end Canonical_Case_File_Name; | |
684 | ||
0e35524d VC |
685 | --------------------------------- |
686 | -- Canonical_Case_Env_Var_Name -- | |
687 | --------------------------------- | |
688 | ||
689 | procedure Canonical_Case_Env_Var_Name (S : in out String) is | |
690 | begin | |
691 | if not Env_Vars_Case_Sensitive then | |
bd29d519 | 692 | To_Lower (S); |
0e35524d VC |
693 | end if; |
694 | end Canonical_Case_Env_Var_Name; | |
695 | ||
38cbfe40 RK |
696 | --------------------------- |
697 | -- Create_File_And_Check -- | |
698 | --------------------------- | |
699 | ||
700 | procedure Create_File_And_Check | |
701 | (Fdesc : out File_Descriptor; | |
702 | Fmode : Mode) | |
703 | is | |
704 | begin | |
705 | Output_File_Name := Name_Enter; | |
706 | Fdesc := Create_File (Name_Buffer'Address, Fmode); | |
707 | ||
708 | if Fdesc = Invalid_FD then | |
3dd9959c | 709 | Fail ("Cannot create: " & Name_Buffer (1 .. Name_Len)); |
38cbfe40 RK |
710 | end if; |
711 | end Create_File_And_Check; | |
712 | ||
41d8ee1d AC |
713 | ----------------------------------- |
714 | -- Open_File_To_Append_And_Check -- | |
715 | ----------------------------------- | |
716 | ||
717 | procedure Open_File_To_Append_And_Check | |
718 | (Fdesc : out File_Descriptor; | |
719 | Fmode : Mode) | |
720 | is | |
721 | begin | |
722 | Output_File_Name := Name_Enter; | |
723 | Fdesc := Open_Append (Name_Buffer'Address, Fmode); | |
724 | ||
725 | if Fdesc = Invalid_FD then | |
726 | Fail ("Cannot create: " & Name_Buffer (1 .. Name_Len)); | |
727 | end if; | |
728 | end Open_File_To_Append_And_Check; | |
729 | ||
aa720a54 AC |
730 | ------------------------ |
731 | -- Current_File_Index -- | |
732 | ------------------------ | |
733 | ||
734 | function Current_File_Index return Int is | |
735 | begin | |
736 | return File_Indexes (Current_File_Name_Index); | |
737 | end Current_File_Index; | |
738 | ||
38cbfe40 RK |
739 | -------------------------------- |
740 | -- Current_Library_File_Stamp -- | |
741 | -------------------------------- | |
742 | ||
743 | function Current_Library_File_Stamp return Time_Stamp_Type is | |
744 | begin | |
745 | return Current_Full_Lib_Stamp; | |
746 | end Current_Library_File_Stamp; | |
747 | ||
748 | ------------------------------- | |
749 | -- Current_Object_File_Stamp -- | |
750 | ------------------------------- | |
751 | ||
752 | function Current_Object_File_Stamp return Time_Stamp_Type is | |
753 | begin | |
754 | return Current_Full_Obj_Stamp; | |
755 | end Current_Object_File_Stamp; | |
756 | ||
757 | ------------------------------- | |
758 | -- Current_Source_File_Stamp -- | |
759 | ------------------------------- | |
760 | ||
761 | function Current_Source_File_Stamp return Time_Stamp_Type is | |
762 | begin | |
763 | return Current_Full_Source_Stamp; | |
764 | end Current_Source_File_Stamp; | |
765 | ||
38cbfe40 RK |
766 | ---------------------------- |
767 | -- Dir_In_Obj_Search_Path -- | |
768 | ---------------------------- | |
769 | ||
770 | function Dir_In_Obj_Search_Path (Position : Natural) return String_Ptr is | |
771 | begin | |
772 | if Opt.Look_In_Primary_Dir then | |
773 | return | |
774 | Lib_Search_Directories.Table (Primary_Directory + Position - 1); | |
775 | else | |
776 | return Lib_Search_Directories.Table (Primary_Directory + Position); | |
777 | end if; | |
778 | end Dir_In_Obj_Search_Path; | |
779 | ||
780 | ---------------------------- | |
781 | -- Dir_In_Src_Search_Path -- | |
782 | ---------------------------- | |
783 | ||
784 | function Dir_In_Src_Search_Path (Position : Natural) return String_Ptr is | |
785 | begin | |
786 | if Opt.Look_In_Primary_Dir then | |
787 | return | |
788 | Src_Search_Directories.Table (Primary_Directory + Position - 1); | |
789 | else | |
790 | return Src_Search_Directories.Table (Primary_Directory + Position); | |
791 | end if; | |
792 | end Dir_In_Src_Search_Path; | |
793 | ||
5fc26697 YM |
794 | ----------------------------------------- |
795 | -- Dump_Command_Line_Source_File_Names -- | |
796 | ----------------------------------------- | |
797 | ||
798 | procedure Dump_Command_Line_Source_File_Names is | |
799 | begin | |
800 | for J in 1 .. Number_Of_Files loop | |
801 | Write_Str (File_Names (J).all & " "); | |
802 | end loop; | |
803 | end Dump_Command_Line_Source_File_Names; | |
804 | ||
3743d5bd AC |
805 | ---------------------------- |
806 | -- Dump_Source_File_Names -- | |
807 | ---------------------------- | |
808 | ||
809 | procedure Dump_Source_File_Names is | |
810 | subtype Rng is Int range File_Name_Chars.First .. File_Name_Chars.Last; | |
811 | begin | |
812 | Write_Str (String (File_Name_Chars.Table (Rng))); | |
813 | end Dump_Source_File_Names; | |
814 | ||
38cbfe40 RK |
815 | --------------------- |
816 | -- Executable_Name -- | |
817 | --------------------- | |
818 | ||
82878151 AC |
819 | function Executable_Name |
820 | (Name : File_Name_Type; | |
821 | Only_If_No_Suffix : Boolean := False) return File_Name_Type | |
822 | is | |
38cbfe40 | 823 | Exec_Suffix : String_Access; |
82878151 | 824 | Add_Suffix : Boolean; |
39f4e199 | 825 | |
38cbfe40 RK |
826 | begin |
827 | if Name = No_File then | |
828 | return No_File; | |
829 | end if; | |
830 | ||
4ecc031c RD |
831 | if Executable_Extension_On_Target = No_Name then |
832 | Exec_Suffix := Get_Target_Executable_Suffix; | |
833 | else | |
834 | Get_Name_String (Executable_Extension_On_Target); | |
835 | Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len)); | |
836 | end if; | |
837 | ||
4ecc031c | 838 | if Exec_Suffix'Length /= 0 then |
c3ed1992 AC |
839 | Get_Name_String (Name); |
840 | ||
43ccd04b AC |
841 | Add_Suffix := True; |
842 | if Only_If_No_Suffix then | |
843 | for J in reverse 1 .. Name_Len loop | |
82878151 | 844 | if Name_Buffer (J) = '.' then |
43ccd04b AC |
845 | Add_Suffix := False; |
846 | exit; | |
847 | ||
9f4b346b | 848 | elsif Is_Directory_Separator (Name_Buffer (J)) then |
82878151 AC |
849 | exit; |
850 | end if; | |
851 | end loop; | |
852 | end if; | |
4ecc031c | 853 | |
82878151 | 854 | if Add_Suffix then |
82878151 AC |
855 | declare |
856 | Buffer : String := Name_Buffer (1 .. Name_Len); | |
4ecc031c | 857 | |
82878151 | 858 | begin |
7a5b62b0 AC |
859 | -- Get the file name in canonical case to accept as is. Names |
860 | -- end with ".EXE" on Windows. | |
82878151 AC |
861 | |
862 | Canonical_Case_File_Name (Buffer); | |
863 | ||
7a5b62b0 | 864 | -- If Executable doesn't end with the executable suffix, add it |
82878151 AC |
865 | |
866 | if Buffer'Length <= Exec_Suffix'Length | |
867 | or else | |
868 | Buffer (Buffer'Last - Exec_Suffix'Length + 1 .. Buffer'Last) | |
d0995fa2 | 869 | /= Exec_Suffix.all |
82878151 AC |
870 | then |
871 | Name_Buffer | |
872 | (Name_Len + 1 .. Name_Len + Exec_Suffix'Length) := | |
d0995fa2 | 873 | Exec_Suffix.all; |
82878151 AC |
874 | Name_Len := Name_Len + Exec_Suffix'Length; |
875 | Free (Exec_Suffix); | |
876 | return Name_Find; | |
877 | end if; | |
878 | end; | |
879 | end if; | |
4ecc031c | 880 | end if; |
38cbfe40 | 881 | |
fbf5a39b | 882 | Free (Exec_Suffix); |
4ecc031c RD |
883 | return Name; |
884 | end Executable_Name; | |
885 | ||
82878151 AC |
886 | function Executable_Name |
887 | (Name : String; | |
888 | Only_If_No_Suffix : Boolean := False) return String | |
889 | is | |
4ecc031c | 890 | Exec_Suffix : String_Access; |
82878151 | 891 | Add_Suffix : Boolean; |
4ecc031c RD |
892 | Canonical_Name : String := Name; |
893 | ||
894 | begin | |
895 | if Executable_Extension_On_Target = No_Name then | |
896 | Exec_Suffix := Get_Target_Executable_Suffix; | |
897 | else | |
898 | Get_Name_String (Executable_Extension_On_Target); | |
899 | Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len)); | |
900 | end if; | |
901 | ||
43ccd04b | 902 | if Exec_Suffix'Length = 0 then |
4ecc031c | 903 | Free (Exec_Suffix); |
43ccd04b | 904 | return Name; |
82878151 | 905 | |
43ccd04b AC |
906 | else |
907 | declare | |
908 | Suffix : constant String := Exec_Suffix.all; | |
909 | ||
910 | begin | |
911 | Free (Exec_Suffix); | |
912 | Canonical_Case_File_Name (Canonical_Name); | |
913 | ||
914 | Add_Suffix := True; | |
915 | if Only_If_No_Suffix then | |
2558db6f AC |
916 | for J in reverse Canonical_Name'Range loop |
917 | if Canonical_Name (J) = '.' then | |
43ccd04b AC |
918 | Add_Suffix := False; |
919 | exit; | |
920 | ||
9f4b346b | 921 | elsif Is_Directory_Separator (Canonical_Name (J)) then |
43ccd04b AC |
922 | exit; |
923 | end if; | |
924 | end loop; | |
925 | end if; | |
4ecc031c | 926 | |
43ccd04b AC |
927 | if Add_Suffix and then |
928 | (Canonical_Name'Length <= Suffix'Length | |
929 | or else Canonical_Name (Canonical_Name'Last - Suffix'Length + 1 | |
930 | .. Canonical_Name'Last) /= Suffix) | |
931 | then | |
932 | declare | |
933 | Result : String (1 .. Name'Length + Suffix'Length); | |
934 | begin | |
935 | Result (1 .. Name'Length) := Name; | |
936 | Result (Name'Length + 1 .. Result'Last) := Suffix; | |
937 | return Result; | |
938 | end; | |
939 | else | |
940 | return Name; | |
941 | end if; | |
942 | end; | |
943 | end if; | |
38cbfe40 RK |
944 | end Executable_Name; |
945 | ||
2820d220 | 946 | ----------------------- |
2cdc8909 | 947 | -- Executable_Prefix -- |
2820d220 | 948 | ----------------------- |
2cdc8909 AC |
949 | |
950 | function Executable_Prefix return String_Ptr is | |
39f4e199 | 951 | |
2cdc8909 | 952 | function Get_Install_Dir (Exec : String) return String_Ptr; |
dec55d76 | 953 | -- S is the executable name preceded by the absolute or relative |
2cdc8909 AC |
954 | -- path, e.g. "c:\usr\bin\gcc.exe" or "..\bin\gcc". |
955 | ||
956 | --------------------- | |
957 | -- Get_Install_Dir -- | |
958 | --------------------- | |
959 | ||
960 | function Get_Install_Dir (Exec : String) return String_Ptr is | |
4ecc031c RD |
961 | Full_Path : constant String := Normalize_Pathname (Exec); |
962 | -- Use the full path, so that we find "lib" or "bin", even when | |
963 | -- the tool has been invoked with a relative path, as in | |
964 | -- "./gnatls -v" invoked in the GNAT bin directory. | |
965 | ||
2cdc8909 | 966 | begin |
4ecc031c RD |
967 | for J in reverse Full_Path'Range loop |
968 | if Is_Directory_Separator (Full_Path (J)) then | |
969 | if J < Full_Path'Last - 5 then | |
970 | if (To_Lower (Full_Path (J + 1)) = 'l' | |
971 | and then To_Lower (Full_Path (J + 2)) = 'i' | |
972 | and then To_Lower (Full_Path (J + 3)) = 'b') | |
2cdc8909 | 973 | or else |
4ecc031c RD |
974 | (To_Lower (Full_Path (J + 1)) = 'b' |
975 | and then To_Lower (Full_Path (J + 2)) = 'i' | |
976 | and then To_Lower (Full_Path (J + 3)) = 'n') | |
2cdc8909 | 977 | then |
4ecc031c | 978 | return new String'(Full_Path (Full_Path'First .. J)); |
2cdc8909 AC |
979 | end if; |
980 | end if; | |
981 | end if; | |
982 | end loop; | |
983 | ||
984 | return new String'(""); | |
985 | end Get_Install_Dir; | |
986 | ||
65356e64 | 987 | -- Start of processing for Executable_Prefix |
2cdc8909 AC |
988 | |
989 | begin | |
2820d220 AC |
990 | if Exec_Name = null then |
991 | Exec_Name := new String (1 .. Len_Arg (0)); | |
992 | Osint.Fill_Arg (Exec_Name (1)'Address, 0); | |
993 | end if; | |
2cdc8909 AC |
994 | |
995 | -- First determine if a path prefix was placed in front of the | |
996 | -- executable name. | |
997 | ||
998 | for J in reverse Exec_Name'Range loop | |
999 | if Is_Directory_Separator (Exec_Name (J)) then | |
2820d220 | 1000 | return Get_Install_Dir (Exec_Name.all); |
2cdc8909 AC |
1001 | end if; |
1002 | end loop; | |
1003 | ||
65356e64 | 1004 | -- If we come here, the user has typed the executable name with no |
2cdc8909 AC |
1005 | -- directory prefix. |
1006 | ||
33c423c8 | 1007 | return Get_Install_Dir (Locate_Exec_On_Path (Exec_Name.all).all); |
2cdc8909 AC |
1008 | end Executable_Prefix; |
1009 | ||
38cbfe40 RK |
1010 | ------------------ |
1011 | -- Exit_Program -- | |
1012 | ------------------ | |
1013 | ||
1014 | procedure Exit_Program (Exit_Code : Exit_Code_Type) is | |
1015 | begin | |
1016 | -- The program will exit with the following status: | |
91b1417d | 1017 | |
38cbfe40 RK |
1018 | -- 0 if the object file has been generated (with or without warnings) |
1019 | -- 1 if recompilation was not needed (smart recompilation) | |
1020 | -- 2 if gnat1 has been killed by a signal (detected by GCC) | |
38cbfe40 RK |
1021 | -- 4 for a fatal error |
1022 | -- 5 if there were errors | |
fbf5a39b | 1023 | -- 6 if no code has been generated (spec) |
91b1417d | 1024 | |
fbf5a39b AC |
1025 | -- Note that exit code 3 is not used and must not be used as this is |
1026 | -- the code returned by a program aborted via C abort() routine on | |
1027 | -- Windows. GCC checks for that case and thinks that the child process | |
1028 | -- has been aborted. This code (exit code 3) used to be the code used | |
1029 | -- for E_No_Code, but E_No_Code was changed to 6 for this reason. | |
38cbfe40 RK |
1030 | |
1031 | case Exit_Code is | |
1032 | when E_Success => OS_Exit (0); | |
1033 | when E_Warnings => OS_Exit (0); | |
1034 | when E_No_Compile => OS_Exit (1); | |
38cbfe40 RK |
1035 | when E_Fatal => OS_Exit (4); |
1036 | when E_Errors => OS_Exit (5); | |
fbf5a39b | 1037 | when E_No_Code => OS_Exit (6); |
38cbfe40 RK |
1038 | when E_Abort => OS_Abort; |
1039 | end case; | |
1040 | end Exit_Program; | |
1041 | ||
1042 | ---------- | |
1043 | -- Fail -- | |
1044 | ---------- | |
1045 | ||
3dd9959c | 1046 | procedure Fail (S : String) is |
38cbfe40 | 1047 | begin |
0247964d AC |
1048 | -- We use Output in case there is a special output set up. In this case |
1049 | -- Set_Standard_Error will have no immediate effect. | |
07fc65c4 | 1050 | |
38cbfe40 RK |
1051 | Set_Standard_Error; |
1052 | Osint.Write_Program_Name; | |
1053 | Write_Str (": "); | |
3dd9959c | 1054 | Write_Str (S); |
38cbfe40 RK |
1055 | Write_Eol; |
1056 | ||
38cbfe40 RK |
1057 | Exit_Program (E_Fatal); |
1058 | end Fail; | |
1059 | ||
1060 | --------------- | |
1061 | -- File_Hash -- | |
1062 | --------------- | |
1063 | ||
1064 | function File_Hash (F : File_Name_Type) return File_Hash_Num is | |
1065 | begin | |
1066 | return File_Hash_Num (Int (F) rem File_Hash_Num'Range_Length); | |
1067 | end File_Hash; | |
1068 | ||
48263c9a EB |
1069 | ----------------- |
1070 | -- File_Length -- | |
1071 | ----------------- | |
1072 | ||
1073 | function File_Length | |
d56e7acd AC |
1074 | (Name : C_File_Name; |
1075 | Attr : access File_Attributes) return Long_Integer | |
48263c9a EB |
1076 | is |
1077 | function Internal | |
d56e7acd AC |
1078 | (F : Integer; |
1079 | N : C_File_Name; | |
0ef40c64 | 1080 | A : System.Address) return CRTL.int64; |
48263c9a | 1081 | pragma Import (C, Internal, "__gnat_file_length_attr"); |
ea0c8cfb | 1082 | |
48263c9a | 1083 | begin |
0ef40c64 | 1084 | -- The conversion from int64 to Long_Integer is ok here as this |
148c744a PO |
1085 | -- routine is only to be used by the compiler and we do not expect |
1086 | -- a unit to be larger than a 32bit integer. | |
ea0c8cfb | 1087 | |
148c744a | 1088 | return Long_Integer (Internal (-1, Name, Attr.all'Address)); |
48263c9a EB |
1089 | end File_Length; |
1090 | ||
1091 | --------------------- | |
1092 | -- File_Time_Stamp -- | |
1093 | --------------------- | |
1094 | ||
1095 | function File_Time_Stamp | |
d56e7acd AC |
1096 | (Name : C_File_Name; |
1097 | Attr : access File_Attributes) return OS_Time | |
48263c9a EB |
1098 | is |
1099 | function Internal (N : C_File_Name; A : System.Address) return OS_Time; | |
1100 | pragma Import (C, Internal, "__gnat_file_time_name_attr"); | |
1101 | begin | |
1102 | return Internal (Name, Attr.all'Address); | |
1103 | end File_Time_Stamp; | |
1104 | ||
cca5ded0 AC |
1105 | function File_Time_Stamp |
1106 | (Name : Path_Name_Type; | |
637da456 RD |
1107 | Attr : access File_Attributes) return Time_Stamp_Type |
1108 | is | |
cca5ded0 AC |
1109 | begin |
1110 | if Name = No_Path then | |
1111 | return Empty_Time_Stamp; | |
1112 | end if; | |
1113 | ||
1114 | Get_Name_String (Name); | |
1115 | Name_Buffer (Name_Len + 1) := ASCII.NUL; | |
1116 | return OS_Time_To_GNAT_Time | |
637da456 | 1117 | (File_Time_Stamp (Name_Buffer'Address, Attr)); |
cca5ded0 AC |
1118 | end File_Time_Stamp; |
1119 | ||
38cbfe40 RK |
1120 | ---------------- |
1121 | -- File_Stamp -- | |
1122 | ---------------- | |
1123 | ||
1124 | function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type is | |
1125 | begin | |
1126 | if Name = No_File then | |
1127 | return Empty_Time_Stamp; | |
1128 | end if; | |
1129 | ||
1130 | Get_Name_String (Name); | |
1131 | ||
d56e7acd AC |
1132 | -- File_Time_Stamp will always return Invalid_Time if the file does |
1133 | -- not exist, and OS_Time_To_GNAT_Time will convert this value to | |
1134 | -- Empty_Time_Stamp. Therefore we do not need to first test whether | |
1135 | -- the file actually exists, which saves a system call. | |
5fd3fd79 AC |
1136 | |
1137 | return OS_Time_To_GNAT_Time | |
d56e7acd | 1138 | (File_Time_Stamp (Name_Buffer (1 .. Name_Len))); |
38cbfe40 RK |
1139 | end File_Stamp; |
1140 | ||
39f4e199 VC |
1141 | function File_Stamp (Name : Path_Name_Type) return Time_Stamp_Type is |
1142 | begin | |
1143 | return File_Stamp (File_Name_Type (Name)); | |
1144 | end File_Stamp; | |
1145 | ||
38cbfe40 RK |
1146 | --------------- |
1147 | -- Find_File -- | |
1148 | --------------- | |
1149 | ||
1150 | function Find_File | |
3ccedacc AC |
1151 | (N : File_Name_Type; |
1152 | T : File_Type; | |
1153 | Full_Name : Boolean := False) return File_Name_Type | |
38cbfe40 | 1154 | is |
48263c9a EB |
1155 | Attr : aliased File_Attributes; |
1156 | Found : File_Name_Type; | |
1157 | begin | |
3ccedacc | 1158 | Find_File (N, T, Found, Attr'Access, Full_Name); |
48263c9a EB |
1159 | return Found; |
1160 | end Find_File; | |
1161 | ||
1162 | --------------- | |
1163 | -- Find_File -- | |
1164 | --------------- | |
1165 | ||
1166 | procedure Find_File | |
3ccedacc AC |
1167 | (N : File_Name_Type; |
1168 | T : File_Type; | |
1169 | Found : out File_Name_Type; | |
1170 | Attr : access File_Attributes; | |
4ff2b6dc AC |
1171 | Full_Name : Boolean := False) |
1172 | is | |
38cbfe40 RK |
1173 | begin |
1174 | Get_Name_String (N); | |
1175 | ||
1176 | declare | |
1177 | File_Name : String renames Name_Buffer (1 .. Name_Len); | |
1178 | File : File_Name_Type := No_File; | |
1179 | Last_Dir : Natural; | |
1180 | ||
1181 | begin | |
1182 | -- If we are looking for a config file, look only in the current | |
d56e7acd | 1183 | -- directory, i.e. return input argument unchanged. Also look only in |
308e6f3a | 1184 | -- the current directory if we are looking for a .dg file (happens in |
d56e7acd | 1185 | -- -gnatD mode). |
38cbfe40 RK |
1186 | |
1187 | if T = Config | |
1188 | or else (Debug_Generated_Code | |
7a5b62b0 AC |
1189 | and then Name_Len > 3 |
1190 | and then Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg") | |
38cbfe40 | 1191 | then |
48263c9a | 1192 | Found := N; |
94d3a18d | 1193 | Attr.all := Unknown_Attributes; |
3ccedacc | 1194 | |
b043ae01 AC |
1195 | if T = Config then |
1196 | if Full_Name then | |
1197 | declare | |
1198 | Full_Path : constant String := | |
1199 | Normalize_Pathname (Get_Name_String (N)); | |
1200 | Full_Size : constant Natural := Full_Path'Length; | |
1201 | ||
1202 | begin | |
1203 | Name_Buffer (1 .. Full_Size) := Full_Path; | |
1204 | Name_Len := Full_Size; | |
94d3a18d | 1205 | Found := Name_Find; |
b043ae01 AC |
1206 | end; |
1207 | end if; | |
1208 | ||
1209 | -- Check that it is a file, not a directory | |
1210 | ||
1211 | if not Is_Regular_File (Get_Name_String (Found)) then | |
1212 | Found := No_File; | |
1213 | end if; | |
3ccedacc AC |
1214 | end if; |
1215 | ||
48263c9a | 1216 | return; |
38cbfe40 RK |
1217 | |
1218 | -- If we are trying to find the current main file just look in the | |
1219 | -- directory where the user said it was. | |
1220 | ||
1221 | elsif Look_In_Primary_Directory_For_Current_Main | |
17c5c8a5 GB |
1222 | and then Current_Main = N |
1223 | then | |
48263c9a EB |
1224 | Locate_File (N, T, Primary_Directory, File_Name, Found, Attr); |
1225 | return; | |
38cbfe40 RK |
1226 | |
1227 | -- Otherwise do standard search for source file | |
1228 | ||
1229 | else | |
6510f4c9 GB |
1230 | -- Check the mapping of this file name |
1231 | ||
17c5c8a5 | 1232 | File := Mapped_Path_Name (N); |
6510f4c9 GB |
1233 | |
1234 | -- If the file name is mapped to a path name, return the | |
1235 | -- corresponding path name | |
1236 | ||
1237 | if File /= No_File then | |
39f4e199 | 1238 | |
fbf5a39b AC |
1239 | -- For locally removed file, Error_Name is returned; then |
1240 | -- return No_File, indicating the file is not a source. | |
1241 | ||
39f4e199 | 1242 | if File = Error_File_Name then |
48263c9a | 1243 | Found := No_File; |
fbf5a39b | 1244 | else |
48263c9a | 1245 | Found := File; |
fbf5a39b | 1246 | end if; |
48263c9a EB |
1247 | |
1248 | Attr.all := Unknown_Attributes; | |
1249 | return; | |
6510f4c9 GB |
1250 | end if; |
1251 | ||
38cbfe40 RK |
1252 | -- First place to look is in the primary directory (i.e. the same |
1253 | -- directory as the source) unless this has been disabled with -I- | |
1254 | ||
1255 | if Opt.Look_In_Primary_Dir then | |
48263c9a | 1256 | Locate_File (N, T, Primary_Directory, File_Name, Found, Attr); |
38cbfe40 | 1257 | |
48263c9a EB |
1258 | if Found /= No_File then |
1259 | return; | |
38cbfe40 RK |
1260 | end if; |
1261 | end if; | |
1262 | ||
1263 | -- Finally look in directories specified with switches -I/-aI/-aO | |
1264 | ||
1265 | if T = Library then | |
1266 | Last_Dir := Lib_Search_Directories.Last; | |
1267 | else | |
1268 | Last_Dir := Src_Search_Directories.Last; | |
1269 | end if; | |
1270 | ||
1271 | for D in Primary_Directory + 1 .. Last_Dir loop | |
48263c9a | 1272 | Locate_File (N, T, D, File_Name, Found, Attr); |
38cbfe40 | 1273 | |
48263c9a EB |
1274 | if Found /= No_File then |
1275 | return; | |
38cbfe40 RK |
1276 | end if; |
1277 | end loop; | |
1278 | ||
48263c9a EB |
1279 | Attr.all := Unknown_Attributes; |
1280 | Found := No_File; | |
38cbfe40 RK |
1281 | end if; |
1282 | end; | |
1283 | end Find_File; | |
1284 | ||
1285 | ----------------------- | |
1286 | -- Find_Program_Name -- | |
1287 | ----------------------- | |
1288 | ||
1289 | procedure Find_Program_Name is | |
1290 | Command_Name : String (1 .. Len_Arg (0)); | |
39f4e199 VC |
1291 | Cindex1 : Integer := Command_Name'First; |
1292 | Cindex2 : Integer := Command_Name'Last; | |
38cbfe40 RK |
1293 | |
1294 | begin | |
1295 | Fill_Arg (Command_Name'Address, 0); | |
1296 | ||
33c423c8 AC |
1297 | if Command_Name = "" then |
1298 | Name_Len := 0; | |
1299 | return; | |
1300 | end if; | |
1301 | ||
38cbfe40 RK |
1302 | -- The program name might be specified by a full path name. However, |
1303 | -- we don't want to print that all out in an error message, so the | |
1304 | -- path might need to be stripped away. | |
1305 | ||
1306 | for J in reverse Cindex1 .. Cindex2 loop | |
1307 | if Is_Directory_Separator (Command_Name (J)) then | |
1308 | Cindex1 := J + 1; | |
1309 | exit; | |
1310 | end if; | |
1311 | end loop; | |
1312 | ||
4afae4b9 JS |
1313 | -- Command_Name(Cindex1 .. Cindex2) is now the equivalent of the |
1314 | -- POSIX command "basename argv[0]" | |
1315 | ||
4afae4b9 JS |
1316 | -- Strip off any executable extension (usually nothing or .exe) |
1317 | -- but formally reported by autoconf in the variable EXEEXT | |
1318 | ||
1319 | if Cindex2 - Cindex1 >= 4 then | |
1320 | if To_Lower (Command_Name (Cindex2 - 3)) = '.' | |
1321 | and then To_Lower (Command_Name (Cindex2 - 2)) = 'e' | |
1322 | and then To_Lower (Command_Name (Cindex2 - 1)) = 'x' | |
1323 | and then To_Lower (Command_Name (Cindex2)) = 'e' | |
1324 | then | |
1325 | Cindex2 := Cindex2 - 4; | |
38cbfe40 | 1326 | end if; |
4afae4b9 | 1327 | end if; |
38cbfe40 RK |
1328 | |
1329 | Name_Len := Cindex2 - Cindex1 + 1; | |
1330 | Name_Buffer (1 .. Name_Len) := Command_Name (Cindex1 .. Cindex2); | |
1331 | end Find_Program_Name; | |
1332 | ||
1333 | ------------------------ | |
1334 | -- Full_Lib_File_Name -- | |
1335 | ------------------------ | |
1336 | ||
48263c9a EB |
1337 | procedure Full_Lib_File_Name |
1338 | (N : File_Name_Type; | |
1339 | Lib_File : out File_Name_Type; | |
1340 | Attr : out File_Attributes) | |
1341 | is | |
1342 | A : aliased File_Attributes; | |
1343 | begin | |
1344 | -- ??? seems we could use Smart_Find_File here | |
1345 | Find_File (N, Library, Lib_File, A'Access); | |
1346 | Attr := A; | |
1347 | end Full_Lib_File_Name; | |
1348 | ||
1349 | ------------------------ | |
1350 | -- Full_Lib_File_Name -- | |
1351 | ------------------------ | |
1352 | ||
38cbfe40 | 1353 | function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type is |
48263c9a EB |
1354 | Attr : File_Attributes; |
1355 | File : File_Name_Type; | |
38cbfe40 | 1356 | begin |
48263c9a EB |
1357 | Full_Lib_File_Name (N, File, Attr); |
1358 | return File; | |
38cbfe40 RK |
1359 | end Full_Lib_File_Name; |
1360 | ||
1361 | ---------------------------- | |
1362 | -- Full_Library_Info_Name -- | |
1363 | ---------------------------- | |
1364 | ||
1365 | function Full_Library_Info_Name return File_Name_Type is | |
1366 | begin | |
1367 | return Current_Full_Lib_Name; | |
1368 | end Full_Library_Info_Name; | |
1369 | ||
1370 | --------------------------- | |
1371 | -- Full_Object_File_Name -- | |
1372 | --------------------------- | |
1373 | ||
1374 | function Full_Object_File_Name return File_Name_Type is | |
1375 | begin | |
1376 | return Current_Full_Obj_Name; | |
1377 | end Full_Object_File_Name; | |
1378 | ||
1379 | ---------------------- | |
1380 | -- Full_Source_Name -- | |
1381 | ---------------------- | |
1382 | ||
1383 | function Full_Source_Name return File_Name_Type is | |
1384 | begin | |
1385 | return Current_Full_Source_Name; | |
1386 | end Full_Source_Name; | |
1387 | ||
1388 | ---------------------- | |
1389 | -- Full_Source_Name -- | |
1390 | ---------------------- | |
1391 | ||
1392 | function Full_Source_Name (N : File_Name_Type) return File_Name_Type is | |
1393 | begin | |
1394 | return Smart_Find_File (N, Source); | |
1395 | end Full_Source_Name; | |
1396 | ||
48263c9a EB |
1397 | ---------------------- |
1398 | -- Full_Source_Name -- | |
1399 | ---------------------- | |
1400 | ||
1401 | procedure Full_Source_Name | |
1402 | (N : File_Name_Type; | |
1403 | Full_File : out File_Name_Type; | |
1404 | Attr : access File_Attributes) is | |
1405 | begin | |
1406 | Smart_Find_File (N, Source, Full_File, Attr.all); | |
1407 | end Full_Source_Name; | |
1408 | ||
38cbfe40 RK |
1409 | ------------------- |
1410 | -- Get_Directory -- | |
1411 | ------------------- | |
1412 | ||
1413 | function Get_Directory (Name : File_Name_Type) return File_Name_Type is | |
1414 | begin | |
1415 | Get_Name_String (Name); | |
1416 | ||
1417 | for J in reverse 1 .. Name_Len loop | |
1418 | if Is_Directory_Separator (Name_Buffer (J)) then | |
1419 | Name_Len := J; | |
1420 | return Name_Find; | |
1421 | end if; | |
1422 | end loop; | |
1423 | ||
1424 | Name_Len := Hostparm.Normalized_CWD'Length; | |
1425 | Name_Buffer (1 .. Name_Len) := Hostparm.Normalized_CWD; | |
1426 | return Name_Find; | |
1427 | end Get_Directory; | |
1428 | ||
10aea826 JK |
1429 | ------------------------------ |
1430 | -- Get_First_Main_File_Name -- | |
1431 | ------------------------------ | |
1432 | ||
1433 | function Get_First_Main_File_Name return String is | |
1434 | begin | |
1435 | return File_Names (1).all; | |
1436 | end Get_First_Main_File_Name; | |
1437 | ||
38cbfe40 RK |
1438 | -------------------------- |
1439 | -- Get_Next_Dir_In_Path -- | |
1440 | -------------------------- | |
1441 | ||
1442 | Search_Path_Pos : Integer; | |
1443 | -- Keeps track of current position in search path. Initialized by the | |
1444 | -- call to Get_Next_Dir_In_Path_Init, updated by Get_Next_Dir_In_Path. | |
1445 | ||
1446 | function Get_Next_Dir_In_Path | |
65356e64 | 1447 | (Search_Path : String_Access) return String_Access |
38cbfe40 RK |
1448 | is |
1449 | Lower_Bound : Positive := Search_Path_Pos; | |
1450 | Upper_Bound : Positive; | |
1451 | ||
1452 | begin | |
1453 | loop | |
1454 | while Lower_Bound <= Search_Path'Last | |
1455 | and then Search_Path.all (Lower_Bound) = Path_Separator | |
1456 | loop | |
1457 | Lower_Bound := Lower_Bound + 1; | |
1458 | end loop; | |
1459 | ||
1460 | exit when Lower_Bound > Search_Path'Last; | |
1461 | ||
1462 | Upper_Bound := Lower_Bound; | |
1463 | while Upper_Bound <= Search_Path'Last | |
1464 | and then Search_Path.all (Upper_Bound) /= Path_Separator | |
1465 | loop | |
1466 | Upper_Bound := Upper_Bound + 1; | |
1467 | end loop; | |
1468 | ||
1469 | Search_Path_Pos := Upper_Bound; | |
1470 | return new String'(Search_Path.all (Lower_Bound .. Upper_Bound - 1)); | |
1471 | end loop; | |
1472 | ||
1473 | return null; | |
1474 | end Get_Next_Dir_In_Path; | |
1475 | ||
1476 | ------------------------------- | |
1477 | -- Get_Next_Dir_In_Path_Init -- | |
1478 | ------------------------------- | |
1479 | ||
1480 | procedure Get_Next_Dir_In_Path_Init (Search_Path : String_Access) is | |
1481 | begin | |
1482 | Search_Path_Pos := Search_Path'First; | |
1483 | end Get_Next_Dir_In_Path_Init; | |
1484 | ||
1485 | -------------------------------------- | |
1486 | -- Get_Primary_Src_Search_Directory -- | |
1487 | -------------------------------------- | |
1488 | ||
1489 | function Get_Primary_Src_Search_Directory return String_Ptr is | |
1490 | begin | |
1491 | return Src_Search_Directories.Table (Primary_Directory); | |
1492 | end Get_Primary_Src_Search_Directory; | |
1493 | ||
15ce9ca2 AC |
1494 | ------------------------ |
1495 | -- Get_RTS_Search_Dir -- | |
1496 | ------------------------ | |
38cbfe40 | 1497 | |
07fc65c4 GB |
1498 | function Get_RTS_Search_Dir |
1499 | (Search_Dir : String; | |
65356e64 | 1500 | File_Type : Search_File_Type) return String_Ptr |
07fc65c4 GB |
1501 | is |
1502 | procedure Get_Current_Dir | |
1503 | (Dir : System.Address; | |
1504 | Length : System.Address); | |
1505 | pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir"); | |
1506 | ||
1507 | Max_Path : Integer; | |
019310ac | 1508 | pragma Import (C, Max_Path, "__gnat_max_path_len"); |
07fc65c4 GB |
1509 | -- Maximum length of a path name |
1510 | ||
1511 | Current_Dir : String_Ptr; | |
1512 | Default_Search_Dir : String_Access; | |
1513 | Default_Suffix_Dir : String_Access; | |
1514 | Local_Search_Dir : String_Access; | |
1515 | Norm_Search_Dir : String_Access; | |
1516 | Result_Search_Dir : String_Access; | |
1517 | Search_File : String_Access; | |
1518 | Temp_String : String_Ptr; | |
1519 | ||
1520 | begin | |
1521 | -- Add a directory separator at the end of the directory if necessary | |
1522 | -- so that we can directly append a file to the directory | |
1523 | ||
9f4b346b | 1524 | if not Is_Directory_Separator (Search_Dir (Search_Dir'Last)) then |
4ecc031c RD |
1525 | Local_Search_Dir := |
1526 | new String'(Search_Dir & String'(1 => Directory_Separator)); | |
07fc65c4 | 1527 | else |
fbf5a39b | 1528 | Local_Search_Dir := new String'(Search_Dir); |
07fc65c4 | 1529 | end if; |
38cbfe40 | 1530 | |
07fc65c4 GB |
1531 | if File_Type = Include then |
1532 | Search_File := Include_Search_File; | |
1533 | Default_Suffix_Dir := new String'("adainclude"); | |
1534 | else | |
1535 | Search_File := Objects_Search_File; | |
fbf5a39b | 1536 | Default_Suffix_Dir := new String'("adalib"); |
07fc65c4 | 1537 | end if; |
38cbfe40 | 1538 | |
e0666fc6 | 1539 | Norm_Search_Dir := Local_Search_Dir; |
38cbfe40 | 1540 | |
07fc65c4 | 1541 | if Is_Absolute_Path (Norm_Search_Dir.all) then |
38cbfe40 | 1542 | |
07fc65c4 GB |
1543 | -- We first verify if there is a directory Include_Search_Dir |
1544 | -- containing default search directories | |
38cbfe40 | 1545 | |
39f4e199 VC |
1546 | Result_Search_Dir := |
1547 | Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null); | |
4ecc031c RD |
1548 | Default_Search_Dir := |
1549 | new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all); | |
07fc65c4 | 1550 | Free (Norm_Search_Dir); |
38cbfe40 | 1551 | |
07fc65c4 GB |
1552 | if Result_Search_Dir /= null then |
1553 | return String_Ptr (Result_Search_Dir); | |
1554 | elsif Is_Directory (Default_Search_Dir.all) then | |
1555 | return String_Ptr (Default_Search_Dir); | |
1556 | else | |
1557 | return null; | |
1558 | end if; | |
38cbfe40 | 1559 | |
91b1417d | 1560 | -- Search in the current directory |
38cbfe40 | 1561 | |
91b1417d | 1562 | else |
07fc65c4 | 1563 | -- Get the current directory |
38cbfe40 | 1564 | |
07fc65c4 GB |
1565 | declare |
1566 | Buffer : String (1 .. Max_Path + 2); | |
1567 | Path_Len : Natural := Max_Path; | |
38cbfe40 | 1568 | |
07fc65c4 GB |
1569 | begin |
1570 | Get_Current_Dir (Buffer'Address, Path_Len'Address); | |
38cbfe40 | 1571 | |
7a71a7c4 AC |
1572 | if Path_Len = 0 then |
1573 | raise Program_Error; | |
1574 | end if; | |
1575 | ||
9f4b346b | 1576 | if not Is_Directory_Separator (Buffer (Path_Len)) then |
07fc65c4 GB |
1577 | Path_Len := Path_Len + 1; |
1578 | Buffer (Path_Len) := Directory_Separator; | |
1579 | end if; | |
38cbfe40 | 1580 | |
07fc65c4 GB |
1581 | Current_Dir := new String'(Buffer (1 .. Path_Len)); |
1582 | end; | |
38cbfe40 | 1583 | |
07fc65c4 | 1584 | Norm_Search_Dir := |
4ecc031c | 1585 | new String'(Current_Dir.all & Local_Search_Dir.all); |
38cbfe40 | 1586 | |
07fc65c4 | 1587 | Result_Search_Dir := |
fbf5a39b | 1588 | Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null); |
38cbfe40 | 1589 | |
07fc65c4 | 1590 | Default_Search_Dir := |
4ecc031c | 1591 | new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all); |
38cbfe40 | 1592 | |
07fc65c4 | 1593 | Free (Norm_Search_Dir); |
38cbfe40 | 1594 | |
07fc65c4 GB |
1595 | if Result_Search_Dir /= null then |
1596 | return String_Ptr (Result_Search_Dir); | |
1597 | ||
1598 | elsif Is_Directory (Default_Search_Dir.all) then | |
1599 | return String_Ptr (Default_Search_Dir); | |
1600 | ||
1601 | else | |
1602 | -- Search in Search_Dir_Prefix/Search_Dir | |
1603 | ||
1604 | Norm_Search_Dir := | |
1605 | new String' | |
4ecc031c | 1606 | (Update_Path (Search_Dir_Prefix).all & Local_Search_Dir.all); |
07fc65c4 GB |
1607 | |
1608 | Result_Search_Dir := | |
fbf5a39b | 1609 | Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null); |
07fc65c4 GB |
1610 | |
1611 | Default_Search_Dir := | |
4ecc031c | 1612 | new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all); |
07fc65c4 GB |
1613 | |
1614 | Free (Norm_Search_Dir); | |
38cbfe40 | 1615 | |
07fc65c4 GB |
1616 | if Result_Search_Dir /= null then |
1617 | return String_Ptr (Result_Search_Dir); | |
1618 | ||
1619 | elsif Is_Directory (Default_Search_Dir.all) then | |
1620 | return String_Ptr (Default_Search_Dir); | |
1621 | ||
1622 | else | |
1623 | -- We finally search in Search_Dir_Prefix/rts-Search_Dir | |
1624 | ||
1625 | Temp_String := | |
4ecc031c | 1626 | new String'(Update_Path (Search_Dir_Prefix).all & "rts-"); |
07fc65c4 GB |
1627 | |
1628 | Norm_Search_Dir := | |
4ecc031c | 1629 | new String'(Temp_String.all & Local_Search_Dir.all); |
07fc65c4 GB |
1630 | |
1631 | Result_Search_Dir := | |
fbf5a39b | 1632 | Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null); |
07fc65c4 GB |
1633 | |
1634 | Default_Search_Dir := | |
4ecc031c | 1635 | new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all); |
07fc65c4 GB |
1636 | Free (Norm_Search_Dir); |
1637 | ||
1638 | if Result_Search_Dir /= null then | |
1639 | return String_Ptr (Result_Search_Dir); | |
1640 | ||
1641 | elsif Is_Directory (Default_Search_Dir.all) then | |
1642 | return String_Ptr (Default_Search_Dir); | |
1643 | ||
1644 | else | |
1645 | return null; | |
1646 | end if; | |
1647 | end if; | |
1648 | end if; | |
1649 | end if; | |
1650 | end Get_RTS_Search_Dir; | |
38cbfe40 | 1651 | |
65356e64 AC |
1652 | -------------------------------- |
1653 | -- Include_Dir_Default_Prefix -- | |
1654 | -------------------------------- | |
1655 | ||
3743d5bd | 1656 | function Include_Dir_Default_Prefix return String_Access is |
65356e64 | 1657 | begin |
3743d5bd AC |
1658 | if The_Include_Dir_Default_Prefix = null then |
1659 | The_Include_Dir_Default_Prefix := | |
1660 | String_Access (Update_Path (Include_Dir_Default_Name)); | |
65356e64 | 1661 | end if; |
3743d5bd AC |
1662 | |
1663 | return The_Include_Dir_Default_Prefix; | |
1664 | end Include_Dir_Default_Prefix; | |
1665 | ||
1666 | function Include_Dir_Default_Prefix return String is | |
1667 | begin | |
1668 | return Include_Dir_Default_Prefix.all; | |
65356e64 AC |
1669 | end Include_Dir_Default_Prefix; |
1670 | ||
fbf5a39b AC |
1671 | ---------------- |
1672 | -- Initialize -- | |
1673 | ---------------- | |
1674 | ||
1675 | procedure Initialize is | |
1676 | begin | |
1677 | Number_File_Names := 0; | |
1678 | Current_File_Name_Index := 0; | |
1679 | ||
1680 | Src_Search_Directories.Init; | |
1681 | Lib_Search_Directories.Init; | |
1682 | ||
05b34c18 AC |
1683 | -- Start off by setting all suppress options, to False. The special |
1684 | -- overflow fields are set to Not_Set (they will be set by -gnatp, or | |
1685 | -- by -gnato, or, if neither of these appear, in Adjust_Global_Switches | |
5707e389 | 1686 | -- in Gnat1drv). |
fbf5a39b | 1687 | |
05b34c18 | 1688 | Suppress_Options := ((others => False), Not_Set, Not_Set); |
fbf5a39b AC |
1689 | |
1690 | -- Reserve the first slot in the search paths table. This is the | |
39f4e199 VC |
1691 | -- directory of the main source file or main library file and is filled |
1692 | -- in by each call to Next_Main_Source/Next_Main_Lib_File with the | |
1693 | -- directory specified for this main source or library file. This is the | |
1694 | -- directory which is searched first by default. This default search is | |
1695 | -- inhibited by the option -I- for both source and library files. | |
fbf5a39b AC |
1696 | |
1697 | Src_Search_Directories.Set_Last (Primary_Directory); | |
1698 | Src_Search_Directories.Table (Primary_Directory) := new String'(""); | |
1699 | ||
1700 | Lib_Search_Directories.Set_Last (Primary_Directory); | |
1701 | Lib_Search_Directories.Table (Primary_Directory) := new String'(""); | |
1702 | end Initialize; | |
1703 | ||
48263c9a EB |
1704 | ------------------ |
1705 | -- Is_Directory -- | |
1706 | ------------------ | |
1707 | ||
1708 | function Is_Directory | |
1709 | (Name : C_File_Name; Attr : access File_Attributes) return Boolean | |
1710 | is | |
1711 | function Internal (N : C_File_Name; A : System.Address) return Integer; | |
1712 | pragma Import (C, Internal, "__gnat_is_directory_attr"); | |
1713 | begin | |
1714 | return Internal (Name, Attr.all'Address) /= 0; | |
1715 | end Is_Directory; | |
1716 | ||
38cbfe40 RK |
1717 | ---------------------------- |
1718 | -- Is_Directory_Separator -- | |
1719 | ---------------------------- | |
1720 | ||
1721 | function Is_Directory_Separator (C : Character) return Boolean is | |
1722 | begin | |
1723 | -- In addition to the default directory_separator allow the '/' to | |
7a5b62b0 AC |
1724 | -- act as separator since this is allowed in MS-DOS and Windows. |
1725 | ||
1726 | return C = Directory_Separator or else C = '/'; | |
38cbfe40 RK |
1727 | end Is_Directory_Separator; |
1728 | ||
1729 | ------------------------- | |
1730 | -- Is_Readonly_Library -- | |
1731 | ------------------------- | |
1732 | ||
0ae9f22f | 1733 | function Is_Readonly_Library (File : File_Name_Type) return Boolean is |
38cbfe40 RK |
1734 | begin |
1735 | Get_Name_String (File); | |
1736 | ||
1737 | pragma Assert (Name_Buffer (Name_Len - 3 .. Name_Len) = ".ali"); | |
1738 | ||
1739 | return not Is_Writable_File (Name_Buffer (1 .. Name_Len)); | |
1740 | end Is_Readonly_Library; | |
1741 | ||
48263c9a EB |
1742 | ------------------------ |
1743 | -- Is_Executable_File -- | |
1744 | ------------------------ | |
1745 | ||
1746 | function Is_Executable_File | |
1747 | (Name : C_File_Name; Attr : access File_Attributes) return Boolean | |
1748 | is | |
1749 | function Internal (N : C_File_Name; A : System.Address) return Integer; | |
1750 | pragma Import (C, Internal, "__gnat_is_executable_file_attr"); | |
1751 | begin | |
1752 | return Internal (Name, Attr.all'Address) /= 0; | |
1753 | end Is_Executable_File; | |
1754 | ||
1755 | ---------------------- | |
1756 | -- Is_Readable_File -- | |
1757 | ---------------------- | |
1758 | ||
1759 | function Is_Readable_File | |
1760 | (Name : C_File_Name; Attr : access File_Attributes) return Boolean | |
1761 | is | |
1762 | function Internal (N : C_File_Name; A : System.Address) return Integer; | |
1763 | pragma Import (C, Internal, "__gnat_is_readable_file_attr"); | |
1764 | begin | |
1765 | return Internal (Name, Attr.all'Address) /= 0; | |
1766 | end Is_Readable_File; | |
1767 | ||
1768 | --------------------- | |
1769 | -- Is_Regular_File -- | |
1770 | --------------------- | |
1771 | ||
1772 | function Is_Regular_File | |
1773 | (Name : C_File_Name; Attr : access File_Attributes) return Boolean | |
1774 | is | |
1775 | function Internal (N : C_File_Name; A : System.Address) return Integer; | |
1776 | pragma Import (C, Internal, "__gnat_is_regular_file_attr"); | |
1777 | begin | |
1778 | return Internal (Name, Attr.all'Address) /= 0; | |
1779 | end Is_Regular_File; | |
1780 | ||
1781 | ---------------------- | |
1782 | -- Is_Symbolic_Link -- | |
1783 | ---------------------- | |
1784 | ||
1785 | function Is_Symbolic_Link | |
1786 | (Name : C_File_Name; Attr : access File_Attributes) return Boolean | |
1787 | is | |
1788 | function Internal (N : C_File_Name; A : System.Address) return Integer; | |
1789 | pragma Import (C, Internal, "__gnat_is_symbolic_link_attr"); | |
1790 | begin | |
1791 | return Internal (Name, Attr.all'Address) /= 0; | |
1792 | end Is_Symbolic_Link; | |
1793 | ||
1794 | ---------------------- | |
1795 | -- Is_Writable_File -- | |
1796 | ---------------------- | |
1797 | ||
1798 | function Is_Writable_File | |
1799 | (Name : C_File_Name; Attr : access File_Attributes) return Boolean | |
1800 | is | |
1801 | function Internal (N : C_File_Name; A : System.Address) return Integer; | |
1802 | pragma Import (C, Internal, "__gnat_is_writable_file_attr"); | |
1803 | begin | |
1804 | return Internal (Name, Attr.all'Address) /= 0; | |
1805 | end Is_Writable_File; | |
1806 | ||
38cbfe40 RK |
1807 | ------------------- |
1808 | -- Lib_File_Name -- | |
1809 | ------------------- | |
1810 | ||
1811 | function Lib_File_Name | |
2820d220 AC |
1812 | (Source_File : File_Name_Type; |
1813 | Munit_Index : Nat := 0) return File_Name_Type | |
38cbfe40 | 1814 | is |
38cbfe40 RK |
1815 | begin |
1816 | Get_Name_String (Source_File); | |
38cbfe40 | 1817 | |
07fc65c4 | 1818 | for J in reverse 2 .. Name_Len loop |
38cbfe40 | 1819 | if Name_Buffer (J) = '.' then |
2820d220 | 1820 | Name_Len := J - 1; |
38cbfe40 RK |
1821 | exit; |
1822 | end if; | |
1823 | end loop; | |
1824 | ||
2820d220 | 1825 | if Munit_Index /= 0 then |
6b6fcd3e | 1826 | Add_Char_To_Name_Buffer (Multi_Unit_Index_Character); |
2820d220 AC |
1827 | Add_Nat_To_Name_Buffer (Munit_Index); |
1828 | end if; | |
1829 | ||
1830 | Add_Char_To_Name_Buffer ('.'); | |
1831 | Add_Str_To_Name_Buffer (ALI_Suffix.all); | |
38cbfe40 RK |
1832 | return Name_Find; |
1833 | end Lib_File_Name; | |
1834 | ||
38cbfe40 RK |
1835 | ----------------- |
1836 | -- Locate_File -- | |
1837 | ----------------- | |
1838 | ||
48263c9a EB |
1839 | procedure Locate_File |
1840 | (N : File_Name_Type; | |
1841 | T : File_Type; | |
1842 | Dir : Natural; | |
1843 | Name : String; | |
1844 | Found : out File_Name_Type; | |
1845 | Attr : access File_Attributes) | |
38cbfe40 RK |
1846 | is |
1847 | Dir_Name : String_Ptr; | |
1848 | ||
1849 | begin | |
d05ef0ab AC |
1850 | -- If Name is already an absolute path, do not look for a directory |
1851 | ||
1852 | if Is_Absolute_Path (Name) then | |
1853 | Dir_Name := No_Dir; | |
1854 | ||
1855 | elsif T = Library then | |
38cbfe40 RK |
1856 | Dir_Name := Lib_Search_Directories.Table (Dir); |
1857 | ||
cafdbd2e AC |
1858 | else |
1859 | pragma Assert (T /= Config); | |
38cbfe40 RK |
1860 | Dir_Name := Src_Search_Directories.Table (Dir); |
1861 | end if; | |
1862 | ||
1863 | declare | |
48263c9a | 1864 | Full_Name : String (1 .. Dir_Name'Length + Name'Length + 1); |
38cbfe40 RK |
1865 | |
1866 | begin | |
1867 | Full_Name (1 .. Dir_Name'Length) := Dir_Name.all; | |
48263c9a EB |
1868 | Full_Name (Dir_Name'Length + 1 .. Full_Name'Last - 1) := Name; |
1869 | Full_Name (Full_Name'Last) := ASCII.NUL; | |
1870 | ||
1871 | Attr.all := Unknown_Attributes; | |
38cbfe40 | 1872 | |
48263c9a EB |
1873 | if not Is_Regular_File (Full_Name'Address, Attr) then |
1874 | Found := No_File; | |
38cbfe40 RK |
1875 | |
1876 | else | |
1877 | -- If the file is in the current directory then return N itself | |
1878 | ||
1879 | if Dir_Name'Length = 0 then | |
48263c9a | 1880 | Found := N; |
38cbfe40 | 1881 | else |
48263c9a EB |
1882 | Name_Len := Full_Name'Length - 1; |
1883 | Name_Buffer (1 .. Name_Len) := | |
1884 | Full_Name (1 .. Full_Name'Last - 1); | |
1885 | Found := Name_Find; -- ??? Was Name_Enter, no obvious reason | |
38cbfe40 RK |
1886 | end if; |
1887 | end if; | |
1888 | end; | |
1889 | end Locate_File; | |
1890 | ||
1891 | ------------------------------- | |
1892 | -- Matching_Full_Source_Name -- | |
1893 | ------------------------------- | |
1894 | ||
1895 | function Matching_Full_Source_Name | |
65356e64 AC |
1896 | (N : File_Name_Type; |
1897 | T : Time_Stamp_Type) return File_Name_Type | |
38cbfe40 RK |
1898 | is |
1899 | begin | |
1900 | Get_Name_String (N); | |
1901 | ||
1902 | declare | |
1903 | File_Name : constant String := Name_Buffer (1 .. Name_Len); | |
1904 | File : File_Name_Type := No_File; | |
48263c9a | 1905 | Attr : aliased File_Attributes; |
38cbfe40 RK |
1906 | Last_Dir : Natural; |
1907 | ||
1908 | begin | |
1909 | if Opt.Look_In_Primary_Dir then | |
48263c9a EB |
1910 | Locate_File |
1911 | (N, Source, Primary_Directory, File_Name, File, Attr'Access); | |
38cbfe40 RK |
1912 | |
1913 | if File /= No_File and then T = File_Stamp (N) then | |
1914 | return File; | |
1915 | end if; | |
1916 | end if; | |
1917 | ||
1918 | Last_Dir := Src_Search_Directories.Last; | |
1919 | ||
1920 | for D in Primary_Directory + 1 .. Last_Dir loop | |
48263c9a | 1921 | Locate_File (N, Source, D, File_Name, File, Attr'Access); |
38cbfe40 RK |
1922 | |
1923 | if File /= No_File and then T = File_Stamp (File) then | |
1924 | return File; | |
1925 | end if; | |
1926 | end loop; | |
1927 | ||
1928 | return No_File; | |
1929 | end; | |
1930 | end Matching_Full_Source_Name; | |
1931 | ||
1932 | ---------------- | |
1933 | -- More_Files -- | |
1934 | ---------------- | |
1935 | ||
1936 | function More_Files return Boolean is | |
1937 | begin | |
1938 | return (Current_File_Name_Index < Number_File_Names); | |
1939 | end More_Files; | |
1940 | ||
38cbfe40 RK |
1941 | ------------------------------- |
1942 | -- Nb_Dir_In_Obj_Search_Path -- | |
1943 | ------------------------------- | |
1944 | ||
1945 | function Nb_Dir_In_Obj_Search_Path return Natural is | |
1946 | begin | |
1947 | if Opt.Look_In_Primary_Dir then | |
1948 | return Lib_Search_Directories.Last - Primary_Directory + 1; | |
1949 | else | |
1950 | return Lib_Search_Directories.Last - Primary_Directory; | |
1951 | end if; | |
1952 | end Nb_Dir_In_Obj_Search_Path; | |
1953 | ||
1954 | ------------------------------- | |
1955 | -- Nb_Dir_In_Src_Search_Path -- | |
1956 | ------------------------------- | |
1957 | ||
1958 | function Nb_Dir_In_Src_Search_Path return Natural is | |
1959 | begin | |
1960 | if Opt.Look_In_Primary_Dir then | |
1961 | return Src_Search_Directories.Last - Primary_Directory + 1; | |
1962 | else | |
1963 | return Src_Search_Directories.Last - Primary_Directory; | |
1964 | end if; | |
1965 | end Nb_Dir_In_Src_Search_Path; | |
1966 | ||
1967 | -------------------- | |
1968 | -- Next_Main_File -- | |
1969 | -------------------- | |
1970 | ||
1971 | function Next_Main_File return File_Name_Type is | |
1972 | File_Name : String_Ptr; | |
1973 | Dir_Name : String_Ptr; | |
1974 | Fptr : Natural; | |
1975 | ||
1976 | begin | |
1977 | pragma Assert (More_Files); | |
1978 | ||
1979 | Current_File_Name_Index := Current_File_Name_Index + 1; | |
1980 | ||
1981 | -- Get the file and directory name | |
1982 | ||
1983 | File_Name := File_Names (Current_File_Name_Index); | |
1984 | Fptr := File_Name'First; | |
1985 | ||
1986 | for J in reverse File_Name'Range loop | |
9f4b346b | 1987 | if Is_Directory_Separator (File_Name (J)) then |
38cbfe40 RK |
1988 | if J = File_Name'Last then |
1989 | Fail ("File name missing"); | |
1990 | end if; | |
1991 | ||
1992 | Fptr := J + 1; | |
1993 | exit; | |
1994 | end if; | |
1995 | end loop; | |
1996 | ||
1997 | -- Save name of directory in which main unit resides for use in | |
1998 | -- locating other units | |
1999 | ||
2000 | Dir_Name := new String'(File_Name (File_Name'First .. Fptr - 1)); | |
2001 | ||
07fc65c4 | 2002 | case Running_Program is |
07fc65c4 GB |
2003 | when Compiler => |
2004 | Src_Search_Directories.Table (Primary_Directory) := Dir_Name; | |
38cbfe40 | 2005 | Look_In_Primary_Directory_For_Current_Main := True; |
38cbfe40 | 2006 | |
07fc65c4 GB |
2007 | when Make => |
2008 | Src_Search_Directories.Table (Primary_Directory) := Dir_Name; | |
2009 | ||
2010 | if Fptr > File_Name'First then | |
2011 | Look_In_Primary_Directory_For_Current_Main := True; | |
2012 | end if; | |
2013 | ||
d8f43ee6 HK |
2014 | when Binder |
2015 | | Gnatls | |
2016 | => | |
07fc65c4 GB |
2017 | Dir_Name := Normalize_Directory_Name (Dir_Name.all); |
2018 | Lib_Search_Directories.Table (Primary_Directory) := Dir_Name; | |
2019 | ||
2020 | when Unspecified => | |
2021 | null; | |
2022 | end case; | |
38cbfe40 RK |
2023 | |
2024 | Name_Len := File_Name'Last - Fptr + 1; | |
2025 | Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last); | |
2026 | Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); | |
39f4e199 | 2027 | Current_Main := Name_Find; |
38cbfe40 RK |
2028 | |
2029 | -- In the gnatmake case, the main file may have not have the | |
2030 | -- extension. Try ".adb" first then ".ads" | |
2031 | ||
07fc65c4 | 2032 | if Running_Program = Make then |
38cbfe40 | 2033 | declare |
fbf5a39b | 2034 | Orig_Main : constant File_Name_Type := Current_Main; |
38cbfe40 RK |
2035 | |
2036 | begin | |
2037 | if Strip_Suffix (Orig_Main) = Orig_Main then | |
39f4e199 VC |
2038 | Current_Main := |
2039 | Append_Suffix_To_File_Name (Orig_Main, ".adb"); | |
38cbfe40 RK |
2040 | |
2041 | if Full_Source_Name (Current_Main) = No_File then | |
2042 | Current_Main := | |
2043 | Append_Suffix_To_File_Name (Orig_Main, ".ads"); | |
2044 | ||
2045 | if Full_Source_Name (Current_Main) = No_File then | |
2046 | Current_Main := Orig_Main; | |
2047 | end if; | |
2048 | end if; | |
2049 | end if; | |
2050 | end; | |
2051 | end if; | |
2052 | ||
2053 | return Current_Main; | |
2054 | end Next_Main_File; | |
2055 | ||
38cbfe40 RK |
2056 | ------------------------------ |
2057 | -- Normalize_Directory_Name -- | |
2058 | ------------------------------ | |
2059 | ||
2060 | function Normalize_Directory_Name (Directory : String) return String_Ptr is | |
fbf5a39b AC |
2061 | |
2062 | function Is_Quoted (Path : String) return Boolean; | |
2063 | pragma Inline (Is_Quoted); | |
2064 | -- Returns true if Path is quoted (either double or single quotes) | |
2065 | ||
2066 | --------------- | |
2067 | -- Is_Quoted -- | |
2068 | --------------- | |
2069 | ||
2070 | function Is_Quoted (Path : String) return Boolean is | |
2071 | First : constant Character := Path (Path'First); | |
2072 | Last : constant Character := Path (Path'Last); | |
2073 | ||
2074 | begin | |
2075 | if (First = ''' and then Last = ''') | |
2076 | or else | |
2077 | (First = '"' and then Last = '"') | |
2078 | then | |
2079 | return True; | |
2080 | else | |
2081 | return False; | |
2082 | end if; | |
2083 | end Is_Quoted; | |
2084 | ||
38cbfe40 RK |
2085 | Result : String_Ptr; |
2086 | ||
fbf5a39b AC |
2087 | -- Start of processing for Normalize_Directory_Name |
2088 | ||
38cbfe40 RK |
2089 | begin |
2090 | if Directory'Length = 0 then | |
2091 | Result := new String'(Hostparm.Normalized_CWD); | |
2092 | ||
2093 | elsif Is_Directory_Separator (Directory (Directory'Last)) then | |
2094 | Result := new String'(Directory); | |
fbf5a39b AC |
2095 | |
2096 | elsif Is_Quoted (Directory) then | |
2097 | ||
2098 | -- This is a quoted string, it certainly means that the directory | |
2099 | -- contains some spaces for example. We can safely remove the quotes | |
2100 | -- here as the OS_Lib.Normalize_Arguments will be called before any | |
2101 | -- spawn routines. This ensure that quotes will be added when needed. | |
2102 | ||
2103 | Result := new String (1 .. Directory'Length - 1); | |
4ecc031c | 2104 | Result (1 .. Directory'Length - 2) := |
fbf5a39b AC |
2105 | Directory (Directory'First + 1 .. Directory'Last - 1); |
2106 | Result (Result'Last) := Directory_Separator; | |
2107 | ||
38cbfe40 RK |
2108 | else |
2109 | Result := new String (1 .. Directory'Length + 1); | |
2110 | Result (1 .. Directory'Length) := Directory; | |
2111 | Result (Directory'Length + 1) := Directory_Separator; | |
2112 | end if; | |
2113 | ||
2114 | return Result; | |
2115 | end Normalize_Directory_Name; | |
2116 | ||
2117 | --------------------- | |
2118 | -- Number_Of_Files -- | |
2119 | --------------------- | |
2120 | ||
16e764a7 | 2121 | function Number_Of_Files return Nat is |
38cbfe40 RK |
2122 | begin |
2123 | return Number_File_Names; | |
2124 | end Number_Of_Files; | |
2125 | ||
65356e64 AC |
2126 | ------------------------------- |
2127 | -- Object_Dir_Default_Prefix -- | |
2128 | ------------------------------- | |
2129 | ||
2130 | function Object_Dir_Default_Prefix return String is | |
2131 | Object_Dir : String_Access := | |
2132 | String_Access (Update_Path (Object_Dir_Default_Name)); | |
2133 | ||
2134 | begin | |
2135 | if Object_Dir = null then | |
2136 | return ""; | |
2137 | ||
2138 | else | |
2139 | declare | |
2140 | Result : constant String := Object_Dir.all; | |
2141 | begin | |
2142 | Free (Object_Dir); | |
2143 | return Result; | |
2144 | end; | |
2145 | end if; | |
2146 | end Object_Dir_Default_Prefix; | |
2147 | ||
38cbfe40 RK |
2148 | ---------------------- |
2149 | -- Object_File_Name -- | |
2150 | ---------------------- | |
2151 | ||
2152 | function Object_File_Name (N : File_Name_Type) return File_Name_Type is | |
2153 | begin | |
2154 | if N = No_File then | |
2155 | return No_File; | |
2156 | end if; | |
2157 | ||
2158 | Get_Name_String (N); | |
2159 | Name_Len := Name_Len - ALI_Suffix'Length - 1; | |
2160 | ||
bb4daba3 | 2161 | for J in Target_Object_Suffix'Range loop |
38cbfe40 | 2162 | Name_Len := Name_Len + 1; |
bb4daba3 | 2163 | Name_Buffer (Name_Len) := Target_Object_Suffix (J); |
38cbfe40 RK |
2164 | end loop; |
2165 | ||
2166 | return Name_Enter; | |
2167 | end Object_File_Name; | |
2168 | ||
33c423c8 AC |
2169 | ------------------------------- |
2170 | -- OS_Exit_Through_Exception -- | |
2171 | ------------------------------- | |
2172 | ||
2173 | procedure OS_Exit_Through_Exception (Status : Integer) is | |
2174 | begin | |
2175 | Current_Exit_Status := Status; | |
2176 | raise Types.Terminate_Program; | |
2177 | end OS_Exit_Through_Exception; | |
2178 | ||
38cbfe40 RK |
2179 | -------------------------- |
2180 | -- OS_Time_To_GNAT_Time -- | |
2181 | -------------------------- | |
2182 | ||
2183 | function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type is | |
2184 | GNAT_Time : Time_Stamp_Type; | |
2185 | ||
25a0f9cf AC |
2186 | type Underlying_OS_Time is |
2187 | range -(2 ** (Standard'Address_Size - Integer'(1))) .. | |
2188 | +(2 ** (Standard'Address_Size - Integer'(1)) - 1); | |
2189 | -- Underlying_OS_Time is a redeclaration of OS_Time to allow integer | |
2190 | -- manipulation. Remove this in favor of To_Ada/To_C once newer | |
2191 | -- GNAT releases are available with these functions. | |
2192 | ||
2193 | function To_Int is | |
2194 | new Unchecked_Conversion (OS_Time, Underlying_OS_Time); | |
2195 | function From_Int is | |
2196 | new Unchecked_Conversion (Underlying_OS_Time, OS_Time); | |
2197 | ||
2198 | TI : Underlying_OS_Time := To_Int (T); | |
38cbfe40 RK |
2199 | Y : Year_Type; |
2200 | Mo : Month_Type; | |
2201 | D : Day_Type; | |
2202 | H : Hour_Type; | |
2203 | Mn : Minute_Type; | |
2204 | S : Second_Type; | |
2205 | ||
2206 | begin | |
5fd3fd79 AC |
2207 | if T = Invalid_Time then |
2208 | return Empty_Time_Stamp; | |
2209 | end if; | |
2210 | ||
64989f18 DA |
2211 | if On_Windows and then TI mod 2 > 0 then |
2212 | -- Windows ALI files had timestamps rounded to even seconds | |
2213 | -- historically. The rounding was originally done in GM_Split. | |
2214 | -- Now that GM_Split no longer does it, we are rounding it here | |
2215 | -- only for ALI files. | |
2216 | ||
2217 | TI := TI + 1; | |
2218 | end if; | |
2219 | ||
25a0f9cf | 2220 | GM_Split (From_Int (TI), Y, Mo, D, H, Mn, S); |
64989f18 | 2221 | |
38cbfe40 RK |
2222 | Make_Time_Stamp |
2223 | (Year => Nat (Y), | |
2224 | Month => Nat (Mo), | |
2225 | Day => Nat (D), | |
2226 | Hour => Nat (H), | |
2227 | Minutes => Nat (Mn), | |
2228 | Seconds => Nat (S), | |
2229 | TS => GNAT_Time); | |
2230 | ||
2231 | return GNAT_Time; | |
2232 | end OS_Time_To_GNAT_Time; | |
2233 | ||
bbe9779c AC |
2234 | ----------------- |
2235 | -- Prep_Suffix -- | |
2236 | ----------------- | |
2237 | ||
2238 | function Prep_Suffix return String is | |
2239 | begin | |
7a5b62b0 | 2240 | return ".prep"; |
bbe9779c AC |
2241 | end Prep_Suffix; |
2242 | ||
38cbfe40 RK |
2243 | ------------------ |
2244 | -- Program_Name -- | |
2245 | ------------------ | |
2246 | ||
686b7752 AC |
2247 | function Program_Name (Nam : String; Prog : String) return String_Access is |
2248 | End_Of_Prefix : Natural := 0; | |
2249 | Start_Of_Prefix : Positive := 1; | |
2250 | Start_Of_Suffix : Positive; | |
38cbfe40 RK |
2251 | |
2252 | begin | |
2253 | -- Get the name of the current program being executed | |
2254 | ||
2255 | Find_Program_Name; | |
2256 | ||
686b7752 | 2257 | Start_Of_Suffix := Name_Len + 1; |
3984e89a | 2258 | |
686b7752 AC |
2259 | -- Find the target prefix if any, for the cross compilation case. |
2260 | -- For instance in "powerpc-elf-gcc" the target prefix is | |
2261 | -- "powerpc-elf-" | |
2262 | -- Ditto for suffix, e.g. in "gcc-4.1", the suffix is "-4.1" | |
3984e89a | 2263 | |
686b7752 | 2264 | for J in reverse 1 .. Name_Len loop |
9f4b346b | 2265 | if Is_Directory_Separator (Name_Buffer (J)) |
686b7752 AC |
2266 | or else Name_Buffer (J) = ':' |
2267 | then | |
2268 | Start_Of_Prefix := J + 1; | |
38cbfe40 | 2269 | exit; |
686b7752 AC |
2270 | end if; |
2271 | end loop; | |
3984e89a | 2272 | |
686b7752 | 2273 | -- Find End_Of_Prefix |
3984e89a | 2274 | |
686b7752 AC |
2275 | for J in Start_Of_Prefix .. Name_Len - Prog'Length + 1 loop |
2276 | if Name_Buffer (J .. J + Prog'Length - 1) = Prog then | |
2277 | End_Of_Prefix := J - 1; | |
3984e89a | 2278 | exit; |
38cbfe40 | 2279 | end if; |
38cbfe40 RK |
2280 | end loop; |
2281 | ||
686b7752 AC |
2282 | if End_Of_Prefix > 1 then |
2283 | Start_Of_Suffix := End_Of_Prefix + Prog'Length + 1; | |
2284 | end if; | |
2285 | ||
38cbfe40 RK |
2286 | -- Create the new program name |
2287 | ||
686b7752 AC |
2288 | return new String' |
2289 | (Name_Buffer (Start_Of_Prefix .. End_Of_Prefix) | |
2290 | & Nam | |
2291 | & Name_Buffer (Start_Of_Suffix .. Name_Len)); | |
38cbfe40 RK |
2292 | end Program_Name; |
2293 | ||
2294 | ------------------------------ | |
2295 | -- Read_Default_Search_Dirs -- | |
2296 | ------------------------------ | |
2297 | ||
2298 | function Read_Default_Search_Dirs | |
90a9fff2 PO |
2299 | (Search_Dir_Prefix : String_Access; |
2300 | Search_File : String_Access; | |
65356e64 | 2301 | Search_Dir_Default_Name : String_Access) return String_Access |
38cbfe40 RK |
2302 | is |
2303 | Prefix_Len : constant Integer := Search_Dir_Prefix.all'Length; | |
2304 | Buffer : String (1 .. Prefix_Len + Search_File.all'Length + 1); | |
2305 | File_FD : File_Descriptor; | |
2306 | S, S1 : String_Access; | |
2307 | Len : Integer; | |
2308 | Curr : Integer; | |
2309 | Actual_Len : Integer; | |
2310 | J1 : Integer; | |
2311 | ||
2312 | Prev_Was_Separator : Boolean; | |
2313 | Nb_Relative_Dir : Integer; | |
2314 | ||
90a9fff2 PO |
2315 | function Is_Relative (S : String; K : Positive) return Boolean; |
2316 | pragma Inline (Is_Relative); | |
2317 | -- Returns True if a relative directory specification is found | |
2318 | -- in S at position K, False otherwise. | |
38cbfe40 | 2319 | |
90a9fff2 PO |
2320 | ----------------- |
2321 | -- Is_Relative -- | |
2322 | ----------------- | |
2323 | ||
2324 | function Is_Relative (S : String; K : Positive) return Boolean is | |
2325 | begin | |
2326 | return not Is_Absolute_Path (S (K .. S'Last)); | |
2327 | end Is_Relative; | |
2328 | ||
2329 | -- Start of processing for Read_Default_Search_Dirs | |
2330 | ||
2331 | begin | |
91b1417d | 2332 | -- Construct a C compatible character string buffer |
38cbfe40 RK |
2333 | |
2334 | Buffer (1 .. Search_Dir_Prefix.all'Length) | |
2335 | := Search_Dir_Prefix.all; | |
2336 | Buffer (Search_Dir_Prefix.all'Length + 1 .. Buffer'Last - 1) | |
2337 | := Search_File.all; | |
2338 | Buffer (Buffer'Last) := ASCII.NUL; | |
2339 | ||
2340 | File_FD := Open_Read (Buffer'Address, Binary); | |
2341 | if File_FD = Invalid_FD then | |
2342 | return Search_Dir_Default_Name; | |
2343 | end if; | |
2344 | ||
2345 | Len := Integer (File_Length (File_FD)); | |
2346 | ||
2347 | -- An extra character for a trailing Path_Separator is allocated | |
2348 | ||
2349 | S := new String (1 .. Len + 1); | |
2350 | S (Len + 1) := Path_Separator; | |
2351 | ||
7a5b62b0 AC |
2352 | -- Read the file. Note that the loop is probably not necessary since the |
2353 | -- whole file is read at once but the loop is harmless and that way we | |
2d249f52 | 2354 | -- are sure to accommodate systems where this is not the case. |
38cbfe40 RK |
2355 | |
2356 | Curr := 1; | |
2357 | Actual_Len := Len; | |
2358 | while Actual_Len /= 0 loop | |
2359 | Actual_Len := Read (File_FD, S (Curr)'Address, Len); | |
2360 | Curr := Curr + Actual_Len; | |
2361 | end loop; | |
2362 | ||
c4dec83f | 2363 | -- Process the file, dealing with path separators |
38cbfe40 RK |
2364 | |
2365 | Prev_Was_Separator := True; | |
2366 | Nb_Relative_Dir := 0; | |
2367 | for J in 1 .. Len loop | |
c4dec83f JR |
2368 | |
2369 | -- Treat any control character as a path separator. Note that we do | |
2370 | -- not treat space as a path separator (we used to treat space as a | |
2371 | -- path separator in an earlier version). That way space can appear | |
2372 | -- as a legitimate character in a path name. | |
2373 | ||
2374 | -- Why do we treat all control characters as path separators??? | |
2375 | ||
2376 | if S (J) in ASCII.NUL .. ASCII.US then | |
38cbfe40 RK |
2377 | S (J) := Path_Separator; |
2378 | end if; | |
2379 | ||
c4dec83f JR |
2380 | -- Test for explicit path separator (or control char as above) |
2381 | ||
90a9fff2 | 2382 | if S (J) = Path_Separator then |
38cbfe40 | 2383 | Prev_Was_Separator := True; |
39f4e199 | 2384 | |
c4dec83f JR |
2385 | -- If not path separator, register use of relative directory |
2386 | ||
38cbfe40 | 2387 | else |
90a9fff2 | 2388 | if Prev_Was_Separator and then Is_Relative (S.all, J) then |
38cbfe40 RK |
2389 | Nb_Relative_Dir := Nb_Relative_Dir + 1; |
2390 | end if; | |
90a9fff2 | 2391 | |
38cbfe40 RK |
2392 | Prev_Was_Separator := False; |
2393 | end if; | |
2394 | end loop; | |
2395 | ||
2396 | if Nb_Relative_Dir = 0 then | |
2397 | return S; | |
2398 | end if; | |
2399 | ||
2400 | -- Add the Search_Dir_Prefix to all relative paths | |
2401 | ||
2402 | S1 := new String (1 .. S'Length + Nb_Relative_Dir * Prefix_Len); | |
2403 | J1 := 1; | |
2404 | Prev_Was_Separator := True; | |
2405 | for J in 1 .. Len + 1 loop | |
90a9fff2 | 2406 | if S (J) = Path_Separator then |
38cbfe40 RK |
2407 | Prev_Was_Separator := True; |
2408 | ||
2409 | else | |
90a9fff2 | 2410 | if Prev_Was_Separator and then Is_Relative (S.all, J) then |
fbf5a39b | 2411 | S1 (J1 .. J1 + Prefix_Len - 1) := Search_Dir_Prefix.all; |
38cbfe40 RK |
2412 | J1 := J1 + Prefix_Len; |
2413 | end if; | |
2414 | ||
2415 | Prev_Was_Separator := False; | |
2416 | end if; | |
2417 | S1 (J1) := S (J); | |
2418 | J1 := J1 + 1; | |
2419 | end loop; | |
2420 | ||
2421 | Free (S); | |
2422 | return S1; | |
2423 | end Read_Default_Search_Dirs; | |
2424 | ||
2425 | ----------------------- | |
2426 | -- Read_Library_Info -- | |
2427 | ----------------------- | |
2428 | ||
2429 | function Read_Library_Info | |
2430 | (Lib_File : File_Name_Type; | |
48263c9a EB |
2431 | Fatal_Err : Boolean := False) return Text_Buffer_Ptr |
2432 | is | |
2433 | File : File_Name_Type; | |
2434 | Attr : aliased File_Attributes; | |
b11cb5fd | 2435 | begin |
48263c9a | 2436 | Find_File (Lib_File, Library, File, Attr'Access); |
b11cb5fd | 2437 | return Read_Library_Info_From_Full |
48263c9a EB |
2438 | (Full_Lib_File => File, |
2439 | Lib_File_Attr => Attr'Access, | |
b11cb5fd EB |
2440 | Fatal_Err => Fatal_Err); |
2441 | end Read_Library_Info; | |
2442 | ||
2443 | --------------------------------- | |
2444 | -- Read_Library_Info_From_Full -- | |
2445 | --------------------------------- | |
2446 | ||
2447 | function Read_Library_Info_From_Full | |
2448 | (Full_Lib_File : File_Name_Type; | |
48263c9a | 2449 | Lib_File_Attr : access File_Attributes; |
b11cb5fd | 2450 | Fatal_Err : Boolean := False) return Text_Buffer_Ptr |
38cbfe40 RK |
2451 | is |
2452 | Lib_FD : File_Descriptor; | |
2453 | -- The file descriptor for the current library file. A negative value | |
2454 | -- indicates failure to open the specified source file. | |
2455 | ||
48263c9a EB |
2456 | Len : Integer; |
2457 | -- Length of source file text (ALI). If it doesn't fit in an integer | |
a90bd866 RD |
2458 | -- we're probably stuck anyway (>2 gigs of source seems a lot, and |
2459 | -- there are other places in the compiler that make this assumption). | |
48263c9a | 2460 | |
38cbfe40 | 2461 | Text : Text_Buffer_Ptr; |
91b1417d | 2462 | -- Allocated text buffer |
38cbfe40 | 2463 | |
fbf5a39b | 2464 | Status : Boolean; |
67ce0d7e | 2465 | pragma Warnings (Off, Status); |
fbf5a39b AC |
2466 | -- For the calls to Close |
2467 | ||
38cbfe40 | 2468 | begin |
b11cb5fd | 2469 | Current_Full_Lib_Name := Full_Lib_File; |
38cbfe40 RK |
2470 | Current_Full_Obj_Name := Object_File_Name (Current_Full_Lib_Name); |
2471 | ||
2472 | if Current_Full_Lib_Name = No_File then | |
2473 | if Fatal_Err then | |
3dd9959c | 2474 | Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len)); |
38cbfe40 RK |
2475 | else |
2476 | Current_Full_Obj_Stamp := Empty_Time_Stamp; | |
2477 | return null; | |
2478 | end if; | |
2479 | end if; | |
2480 | ||
2481 | Get_Name_String (Current_Full_Lib_Name); | |
2482 | Name_Buffer (Name_Len + 1) := ASCII.NUL; | |
2483 | ||
2484 | -- Open the library FD, note that we open in binary mode, because as | |
2485 | -- documented in the spec, the caller is expected to handle either | |
2486 | -- DOS or Unix mode files, and there is no point in wasting time on | |
2487 | -- text translation when it is not required. | |
2488 | ||
2489 | Lib_FD := Open_Read (Name_Buffer'Address, Binary); | |
2490 | ||
2491 | if Lib_FD = Invalid_FD then | |
2492 | if Fatal_Err then | |
3dd9959c | 2493 | Fail ("Cannot open: " & Name_Buffer (1 .. Name_Len)); |
38cbfe40 RK |
2494 | else |
2495 | Current_Full_Obj_Stamp := Empty_Time_Stamp; | |
2496 | return null; | |
2497 | end if; | |
2498 | end if; | |
2499 | ||
48263c9a EB |
2500 | -- Compute the length of the file (potentially also preparing other data |
2501 | -- like the timestamp and whether the file is read-only, for future use) | |
2502 | ||
2503 | Len := Integer (File_Length (Name_Buffer'Address, Lib_File_Attr)); | |
2504 | ||
38cbfe40 RK |
2505 | -- Check for object file consistency if requested |
2506 | ||
2507 | if Opt.Check_Object_Consistency then | |
48263c9a | 2508 | -- On most systems, this does not result in an extra system call |
d56e7acd AC |
2509 | |
2510 | Current_Full_Lib_Stamp := | |
2511 | OS_Time_To_GNAT_Time | |
2512 | (File_Time_Stamp (Name_Buffer'Address, Lib_File_Attr)); | |
48263c9a EB |
2513 | |
2514 | -- ??? One system call here | |
d56e7acd | 2515 | |
38cbfe40 RK |
2516 | Current_Full_Obj_Stamp := File_Stamp (Current_Full_Obj_Name); |
2517 | ||
2518 | if Current_Full_Obj_Stamp (1) = ' ' then | |
2519 | ||
39f4e199 | 2520 | -- When the library is readonly always assume object is consistent |
48263c9a EB |
2521 | -- The call to Is_Writable_File only results in a system call on |
2522 | -- some systems, but in most cases it has already been computed as | |
2523 | -- part of the call to File_Length above. | |
2524 | ||
2525 | Get_Name_String (Current_Full_Lib_Name); | |
2526 | Name_Buffer (Name_Len + 1) := ASCII.NUL; | |
38cbfe40 | 2527 | |
48263c9a | 2528 | if not Is_Writable_File (Name_Buffer'Address, Lib_File_Attr) then |
38cbfe40 RK |
2529 | Current_Full_Obj_Stamp := Current_Full_Lib_Stamp; |
2530 | ||
2531 | elsif Fatal_Err then | |
2532 | Get_Name_String (Current_Full_Obj_Name); | |
fbf5a39b | 2533 | Close (Lib_FD, Status); |
39f4e199 | 2534 | |
fbf5a39b AC |
2535 | -- No need to check the status, we fail anyway |
2536 | ||
3dd9959c | 2537 | Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len)); |
38cbfe40 RK |
2538 | |
2539 | else | |
2540 | Current_Full_Obj_Stamp := Empty_Time_Stamp; | |
fbf5a39b | 2541 | Close (Lib_FD, Status); |
fbf5a39b | 2542 | |
fbf5a39b AC |
2543 | -- No need to check the status, we return null anyway |
2544 | ||
38cbfe40 RK |
2545 | return null; |
2546 | end if; | |
a3f2babd AC |
2547 | |
2548 | elsif Current_Full_Obj_Stamp < Current_Full_Lib_Stamp then | |
2549 | Close (Lib_FD, Status); | |
2550 | ||
2551 | -- No need to check the status, we return null anyway | |
2552 | ||
2553 | return null; | |
38cbfe40 RK |
2554 | end if; |
2555 | end if; | |
2556 | ||
2557 | -- Read data from the file | |
2558 | ||
2559 | declare | |
38cbfe40 RK |
2560 | Actual_Len : Integer := 0; |
2561 | ||
fbf5a39b | 2562 | Lo : constant Text_Ptr := 0; |
38cbfe40 RK |
2563 | -- Low bound for allocated text buffer |
2564 | ||
2565 | Hi : Text_Ptr := Text_Ptr (Len); | |
2566 | -- High bound for allocated text buffer. Note length is Len + 1 | |
2567 | -- which allows for extra EOF character at the end of the buffer. | |
2568 | ||
2569 | begin | |
2570 | -- Allocate text buffer. Note extra character at end for EOF | |
2571 | ||
2572 | Text := new Text_Buffer (Lo .. Hi); | |
2573 | ||
7a5b62b0 AC |
2574 | -- Some systems have file types that require one read per line, |
2575 | -- so read until we get the Len bytes or until there are no more | |
2576 | -- characters. | |
38cbfe40 RK |
2577 | |
2578 | Hi := Lo; | |
2579 | loop | |
2580 | Actual_Len := Read (Lib_FD, Text (Hi)'Address, Len); | |
2581 | Hi := Hi + Text_Ptr (Actual_Len); | |
d1ced162 | 2582 | exit when Actual_Len = Len or else Actual_Len <= 0; |
38cbfe40 RK |
2583 | end loop; |
2584 | ||
2585 | Text (Hi) := EOF; | |
2586 | end; | |
2587 | ||
2588 | -- Read is complete, close file and we are done | |
2589 | ||
fbf5a39b AC |
2590 | Close (Lib_FD, Status); |
2591 | -- The status should never be False. But, if it is, what can we do? | |
2592 | -- So, we don't test it. | |
2593 | ||
38cbfe40 RK |
2594 | return Text; |
2595 | ||
b11cb5fd | 2596 | end Read_Library_Info_From_Full; |
38cbfe40 | 2597 | |
38cbfe40 RK |
2598 | ---------------------- |
2599 | -- Read_Source_File -- | |
2600 | ---------------------- | |
2601 | ||
2602 | procedure Read_Source_File | |
2603 | (N : File_Name_Type; | |
2604 | Lo : Source_Ptr; | |
2605 | Hi : out Source_Ptr; | |
2606 | Src : out Source_Buffer_Ptr; | |
cd644ae2 | 2607 | FD : out File_Descriptor; |
38cbfe40 RK |
2608 | T : File_Type := Source) |
2609 | is | |
38cbfe40 | 2610 | Len : Integer; |
a90bd866 | 2611 | -- Length of file, assume no more than 2 gigabytes of source |
38cbfe40 RK |
2612 | |
2613 | Actual_Len : Integer; | |
2614 | ||
fbf5a39b | 2615 | Status : Boolean; |
67ce0d7e | 2616 | pragma Warnings (Off, Status); |
fbf5a39b AC |
2617 | -- For the call to Close |
2618 | ||
38cbfe40 | 2619 | begin |
3ccedacc | 2620 | Current_Full_Source_Name := Find_File (N, T, Full_Name => True); |
38cbfe40 RK |
2621 | Current_Full_Source_Stamp := File_Stamp (Current_Full_Source_Name); |
2622 | ||
2623 | if Current_Full_Source_Name = No_File then | |
2624 | ||
39f4e199 VC |
2625 | -- If we were trying to access the main file and we could not find |
2626 | -- it, we have an error. | |
38cbfe40 RK |
2627 | |
2628 | if N = Current_Main then | |
2629 | Get_Name_String (N); | |
3dd9959c | 2630 | Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len)); |
38cbfe40 RK |
2631 | end if; |
2632 | ||
cd644ae2 | 2633 | FD := Null_FD; |
38cbfe40 RK |
2634 | Src := null; |
2635 | Hi := No_Location; | |
2636 | return; | |
2637 | end if; | |
2638 | ||
2639 | Get_Name_String (Current_Full_Source_Name); | |
2640 | Name_Buffer (Name_Len + 1) := ASCII.NUL; | |
2641 | ||
2642 | -- Open the source FD, note that we open in binary mode, because as | |
2643 | -- documented in the spec, the caller is expected to handle either | |
2644 | -- DOS or Unix mode files, and there is no point in wasting time on | |
2645 | -- text translation when it is not required. | |
2646 | ||
cd644ae2 | 2647 | FD := Open_Read (Name_Buffer'Address, Binary); |
38cbfe40 | 2648 | |
cd644ae2 | 2649 | if FD = Invalid_FD then |
38cbfe40 RK |
2650 | Src := null; |
2651 | Hi := No_Location; | |
2652 | return; | |
2653 | end if; | |
2654 | ||
a921e83c AC |
2655 | -- If it's a Source file, print out the file name, if requested, and if |
2656 | -- it's not part of the runtimes, store it in File_Name_Chars. We don't | |
2657 | -- want to print non-Source files, like GNAT-TEMP-000001.TMP used to | |
2658 | -- pass information from gprbuild to gcc. We don't want to save runtime | |
2659 | -- file names, because we don't want users to send them in bug reports. | |
3743d5bd | 2660 | |
a921e83c AC |
2661 | if T = Source then |
2662 | declare | |
2663 | Name : String renames Name_Buffer (1 .. Name_Len); | |
2664 | Inc : String renames Include_Dir_Default_Prefix.all; | |
3743d5bd | 2665 | |
a921e83c AC |
2666 | Part_Of_Runtimes : constant Boolean := |
2667 | Inc /= "" | |
2668 | and then Inc'Length < Name_Len | |
2669 | and then Name_Buffer (1 .. Inc'Length) = Inc; | |
55c078ac | 2670 | |
a921e83c AC |
2671 | begin |
2672 | if Debug.Debug_Flag_Dot_N then | |
2673 | Write_Line (Name); | |
2674 | end if; | |
3743d5bd | 2675 | |
a921e83c AC |
2676 | if not Part_Of_Runtimes then |
2677 | File_Name_Chars.Append_All (File_Name_Chars.Table_Type (Name)); | |
2678 | File_Name_Chars.Append (ASCII.LF); | |
2679 | end if; | |
2680 | end; | |
2681 | end if; | |
3743d5bd | 2682 | |
38cbfe40 RK |
2683 | -- Prepare to read data from the file |
2684 | ||
cd644ae2 | 2685 | Len := Integer (File_Length (FD)); |
38cbfe40 RK |
2686 | |
2687 | -- Set Hi so that length is one more than the physical length, | |
2688 | -- allowing for the extra EOF character at the end of the buffer | |
2689 | ||
2690 | Hi := Lo + Source_Ptr (Len); | |
2691 | ||
2692 | -- Do the actual read operation | |
2693 | ||
2694 | declare | |
211e7410 AC |
2695 | Var_Ptr : constant Source_Buffer_Ptr_Var := |
2696 | new Source_Buffer (Lo .. Hi); | |
38cbfe40 | 2697 | -- Allocate source buffer, allowing extra character at end for EOF |
211e7410 | 2698 | begin |
7a5b62b0 AC |
2699 | -- Some systems have file types that require one read per line, |
2700 | -- so read until we get the Len bytes or until there are no more | |
2701 | -- characters. | |
38cbfe40 RK |
2702 | |
2703 | Hi := Lo; | |
2704 | loop | |
cd644ae2 | 2705 | Actual_Len := Read (FD, Var_Ptr (Hi)'Address, Len); |
38cbfe40 | 2706 | Hi := Hi + Source_Ptr (Actual_Len); |
d1ced162 | 2707 | exit when Actual_Len = Len or else Actual_Len <= 0; |
38cbfe40 RK |
2708 | end loop; |
2709 | ||
211e7410 AC |
2710 | Var_Ptr (Hi) := EOF; |
2711 | Src := Var_Ptr.all'Access; | |
38cbfe40 RK |
2712 | end; |
2713 | ||
2714 | -- Read is complete, get time stamp and close file and we are done | |
2715 | ||
cd644ae2 | 2716 | Close (FD, Status); |
91b1417d | 2717 | |
fbf5a39b AC |
2718 | -- The status should never be False. But, if it is, what can we do? |
2719 | -- So, we don't test it. | |
38cbfe40 | 2720 | |
211e7410 AC |
2721 | -- ???We don't really need to return Hi anymore; We could get rid of |
2722 | -- it. We could also make this into a function. | |
2723 | ||
2724 | pragma Assert (Hi = Src'Last); | |
38cbfe40 RK |
2725 | end Read_Source_File; |
2726 | ||
2cdc8909 AC |
2727 | ------------------- |
2728 | -- Relocate_Path -- | |
2729 | ------------------- | |
2730 | ||
2731 | function Relocate_Path | |
2732 | (Prefix : String; | |
2733 | Path : String) return String_Ptr | |
2734 | is | |
2735 | S : String_Ptr; | |
2736 | ||
2737 | procedure set_std_prefix (S : String; Len : Integer); | |
2738 | pragma Import (C, set_std_prefix); | |
2739 | ||
2740 | begin | |
2741 | if Std_Prefix = null then | |
2742 | Std_Prefix := Executable_Prefix; | |
2743 | ||
2744 | if Std_Prefix.all /= "" then | |
91b1417d | 2745 | |
2cdc8909 AC |
2746 | -- Remove trailing directory separator when calling set_std_prefix |
2747 | ||
2748 | set_std_prefix (Std_Prefix.all, Std_Prefix'Length - 1); | |
2749 | end if; | |
2750 | end if; | |
2751 | ||
9a476d75 | 2752 | if Path'Last >= Prefix'Last and then Path (Prefix'Range) = Prefix then |
2cdc8909 AC |
2753 | if Std_Prefix.all /= "" then |
2754 | S := new String | |
2755 | (1 .. Std_Prefix'Length + Path'Last - Prefix'Last); | |
2756 | S (1 .. Std_Prefix'Length) := Std_Prefix.all; | |
2757 | S (Std_Prefix'Length + 1 .. S'Last) := | |
2758 | Path (Prefix'Last + 1 .. Path'Last); | |
2759 | return S; | |
2760 | end if; | |
2761 | end if; | |
2762 | ||
2763 | return new String'(Path); | |
2764 | end Relocate_Path; | |
2765 | ||
07fc65c4 GB |
2766 | ----------------- |
2767 | -- Set_Program -- | |
2768 | ----------------- | |
38cbfe40 | 2769 | |
07fc65c4 | 2770 | procedure Set_Program (P : Program_Type) is |
38cbfe40 | 2771 | begin |
07fc65c4 GB |
2772 | if Program_Set then |
2773 | Fail ("Set_Program called twice"); | |
38cbfe40 RK |
2774 | end if; |
2775 | ||
07fc65c4 GB |
2776 | Program_Set := True; |
2777 | Running_Program := P; | |
2778 | end Set_Program; | |
38cbfe40 | 2779 | |
91b1417d AC |
2780 | ---------------- |
2781 | -- Shared_Lib -- | |
2782 | ---------------- | |
2783 | ||
2784 | function Shared_Lib (Name : String) return String is | |
2785 | Library : String (1 .. Name'Length + Library_Version'Length + 3); | |
2786 | -- 3 = 2 for "-l" + 1 for "-" before lib version | |
2787 | ||
2788 | begin | |
2789 | Library (1 .. 2) := "-l"; | |
2790 | Library (3 .. 2 + Name'Length) := Name; | |
2791 | Library (3 + Name'Length) := '-'; | |
2792 | Library (4 + Name'Length .. Library'Last) := Library_Version; | |
91b1417d AC |
2793 | return Library; |
2794 | end Shared_Lib; | |
2795 | ||
38cbfe40 RK |
2796 | ---------------------- |
2797 | -- Smart_File_Stamp -- | |
2798 | ---------------------- | |
2799 | ||
2800 | function Smart_File_Stamp | |
65356e64 AC |
2801 | (N : File_Name_Type; |
2802 | T : File_Type) return Time_Stamp_Type | |
38cbfe40 | 2803 | is |
48263c9a EB |
2804 | File : File_Name_Type; |
2805 | Attr : aliased File_Attributes; | |
d56e7acd | 2806 | |
38cbfe40 RK |
2807 | begin |
2808 | if not File_Cache_Enabled then | |
48263c9a EB |
2809 | Find_File (N, T, File, Attr'Access); |
2810 | else | |
2811 | Smart_Find_File (N, T, File, Attr); | |
38cbfe40 RK |
2812 | end if; |
2813 | ||
48263c9a EB |
2814 | if File = No_File then |
2815 | return Empty_Time_Stamp; | |
2816 | else | |
2817 | Get_Name_String (File); | |
2818 | Name_Buffer (Name_Len + 1) := ASCII.NUL; | |
d56e7acd AC |
2819 | return |
2820 | OS_Time_To_GNAT_Time | |
2821 | (File_Time_Stamp (Name_Buffer'Address, Attr'Access)); | |
38cbfe40 | 2822 | end if; |
38cbfe40 RK |
2823 | end Smart_File_Stamp; |
2824 | ||
2825 | --------------------- | |
2826 | -- Smart_Find_File -- | |
2827 | --------------------- | |
2828 | ||
2829 | function Smart_Find_File | |
2830 | (N : File_Name_Type; | |
65356e64 | 2831 | T : File_Type) return File_Name_Type |
38cbfe40 | 2832 | is |
48263c9a EB |
2833 | File : File_Name_Type; |
2834 | Attr : File_Attributes; | |
38cbfe40 | 2835 | begin |
48263c9a EB |
2836 | Smart_Find_File (N, T, File, Attr); |
2837 | return File; | |
2838 | end Smart_Find_File; | |
38cbfe40 | 2839 | |
48263c9a EB |
2840 | --------------------- |
2841 | -- Smart_Find_File -- | |
2842 | --------------------- | |
38cbfe40 | 2843 | |
48263c9a EB |
2844 | procedure Smart_Find_File |
2845 | (N : File_Name_Type; | |
2846 | T : File_Type; | |
2847 | Found : out File_Name_Type; | |
2848 | Attr : out File_Attributes) | |
2849 | is | |
2850 | Info : File_Info_Cache; | |
2851 | ||
2852 | begin | |
2853 | if not File_Cache_Enabled then | |
2854 | Find_File (N, T, Info.File, Info.Attr'Access); | |
d56e7acd | 2855 | |
48263c9a EB |
2856 | else |
2857 | Info := File_Name_Hash_Table.Get (N); | |
d56e7acd | 2858 | |
48263c9a EB |
2859 | if Info.File = No_File then |
2860 | Find_File (N, T, Info.File, Info.Attr'Access); | |
2861 | File_Name_Hash_Table.Set (N, Info); | |
2862 | end if; | |
38cbfe40 RK |
2863 | end if; |
2864 | ||
48263c9a EB |
2865 | Found := Info.File; |
2866 | Attr := Info.Attr; | |
38cbfe40 RK |
2867 | end Smart_Find_File; |
2868 | ||
2869 | ---------------------- | |
2870 | -- Source_File_Data -- | |
2871 | ---------------------- | |
2872 | ||
2873 | procedure Source_File_Data (Cache : Boolean) is | |
2874 | begin | |
2875 | File_Cache_Enabled := Cache; | |
2876 | end Source_File_Data; | |
2877 | ||
2878 | ----------------------- | |
2879 | -- Source_File_Stamp -- | |
2880 | ----------------------- | |
2881 | ||
2882 | function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type is | |
2883 | begin | |
2884 | return Smart_File_Stamp (N, Source); | |
2885 | end Source_File_Stamp; | |
2886 | ||
2887 | --------------------- | |
2888 | -- Strip_Directory -- | |
2889 | --------------------- | |
2890 | ||
2891 | function Strip_Directory (Name : File_Name_Type) return File_Name_Type is | |
2892 | begin | |
2893 | Get_Name_String (Name); | |
2894 | ||
07fc65c4 | 2895 | for J in reverse 1 .. Name_Len - 1 loop |
91b1417d | 2896 | |
07fc65c4 | 2897 | -- If we find the last directory separator |
38cbfe40 | 2898 | |
07fc65c4 | 2899 | if Is_Directory_Separator (Name_Buffer (J)) then |
91b1417d | 2900 | |
d56e7acd | 2901 | -- Return part of Name that follows this last directory separator |
38cbfe40 | 2902 | |
07fc65c4 GB |
2903 | Name_Buffer (1 .. Name_Len - J) := Name_Buffer (J + 1 .. Name_Len); |
2904 | Name_Len := Name_Len - J; | |
2905 | return Name_Find; | |
38cbfe40 | 2906 | end if; |
07fc65c4 | 2907 | end loop; |
38cbfe40 | 2908 | |
07fc65c4 GB |
2909 | -- There were no directory separator, just return Name |
2910 | ||
2911 | return Name; | |
38cbfe40 RK |
2912 | end Strip_Directory; |
2913 | ||
2914 | ------------------ | |
2915 | -- Strip_Suffix -- | |
2916 | ------------------ | |
2917 | ||
2918 | function Strip_Suffix (Name : File_Name_Type) return File_Name_Type is | |
2919 | begin | |
2920 | Get_Name_String (Name); | |
2921 | ||
07fc65c4 GB |
2922 | for J in reverse 2 .. Name_Len loop |
2923 | ||
91b1417d | 2924 | -- If we found the last '.', return part of Name that precedes it |
07fc65c4 | 2925 | |
38cbfe40 RK |
2926 | if Name_Buffer (J) = '.' then |
2927 | Name_Len := J - 1; | |
2928 | return Name_Enter; | |
2929 | end if; | |
2930 | end loop; | |
2931 | ||
2932 | return Name; | |
2933 | end Strip_Suffix; | |
2934 | ||
38cbfe40 RK |
2935 | --------------------------- |
2936 | -- To_Canonical_File_List -- | |
2937 | --------------------------- | |
2938 | ||
2939 | function To_Canonical_File_List | |
2940 | (Wildcard_Host_File : String; | |
65356e64 | 2941 | Only_Dirs : Boolean) return String_Access_List_Access |
38cbfe40 RK |
2942 | is |
2943 | function To_Canonical_File_List_Init | |
2944 | (Host_File : Address; | |
65356e64 | 2945 | Only_Dirs : Integer) return Integer; |
38cbfe40 RK |
2946 | pragma Import (C, To_Canonical_File_List_Init, |
2947 | "__gnat_to_canonical_file_list_init"); | |
2948 | ||
2949 | function To_Canonical_File_List_Next return Address; | |
2950 | pragma Import (C, To_Canonical_File_List_Next, | |
2951 | "__gnat_to_canonical_file_list_next"); | |
2952 | ||
2953 | procedure To_Canonical_File_List_Free; | |
2954 | pragma Import (C, To_Canonical_File_List_Free, | |
2955 | "__gnat_to_canonical_file_list_free"); | |
2956 | ||
2957 | Num_Files : Integer; | |
2958 | C_Wildcard_Host_File : String (1 .. Wildcard_Host_File'Length + 1); | |
2959 | ||
2960 | begin | |
2961 | C_Wildcard_Host_File (1 .. Wildcard_Host_File'Length) := | |
2962 | Wildcard_Host_File; | |
2963 | C_Wildcard_Host_File (C_Wildcard_Host_File'Last) := ASCII.NUL; | |
2964 | ||
2965 | -- Do the expansion and say how many there are | |
2966 | ||
2967 | Num_Files := To_Canonical_File_List_Init | |
2968 | (C_Wildcard_Host_File'Address, Boolean'Pos (Only_Dirs)); | |
2969 | ||
2970 | declare | |
2971 | Canonical_File_List : String_Access_List (1 .. Num_Files); | |
2972 | Canonical_File_Addr : Address; | |
4f852a1a | 2973 | Canonical_File_Len : CRTL.size_t; |
38cbfe40 RK |
2974 | |
2975 | begin | |
dec55d76 | 2976 | -- Retrieve the expanded directory names and build the list |
38cbfe40 RK |
2977 | |
2978 | for J in 1 .. Num_Files loop | |
2979 | Canonical_File_Addr := To_Canonical_File_List_Next; | |
2980 | Canonical_File_Len := C_String_Length (Canonical_File_Addr); | |
2981 | Canonical_File_List (J) := To_Path_String_Access | |
2982 | (Canonical_File_Addr, Canonical_File_Len); | |
2983 | end loop; | |
2984 | ||
2985 | -- Free up the storage | |
2986 | ||
2987 | To_Canonical_File_List_Free; | |
2988 | ||
2989 | return new String_Access_List'(Canonical_File_List); | |
2990 | end; | |
2991 | end To_Canonical_File_List; | |
2992 | ||
a01da44a | 2993 | ---------------------- |
38cbfe40 | 2994 | -- To_Host_Dir_Spec -- |
a01da44a | 2995 | ---------------------- |
38cbfe40 RK |
2996 | |
2997 | function To_Host_Dir_Spec | |
2998 | (Canonical_Dir : String; | |
65356e64 | 2999 | Prefix_Style : Boolean) return String_Access |
38cbfe40 RK |
3000 | is |
3001 | function To_Host_Dir_Spec | |
3002 | (Canonical_Dir : Address; | |
65356e64 | 3003 | Prefix_Flag : Integer) return Address; |
38cbfe40 RK |
3004 | pragma Import (C, To_Host_Dir_Spec, "__gnat_to_host_dir_spec"); |
3005 | ||
3006 | C_Canonical_Dir : String (1 .. Canonical_Dir'Length + 1); | |
3007 | Host_Dir_Addr : Address; | |
4f852a1a | 3008 | Host_Dir_Len : CRTL.size_t; |
38cbfe40 RK |
3009 | |
3010 | begin | |
3011 | C_Canonical_Dir (1 .. Canonical_Dir'Length) := Canonical_Dir; | |
3012 | C_Canonical_Dir (C_Canonical_Dir'Last) := ASCII.NUL; | |
3013 | ||
3014 | if Prefix_Style then | |
3015 | Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 1); | |
3016 | else | |
3017 | Host_Dir_Addr := To_Host_Dir_Spec (C_Canonical_Dir'Address, 0); | |
3018 | end if; | |
3019 | Host_Dir_Len := C_String_Length (Host_Dir_Addr); | |
3020 | ||
3021 | if Host_Dir_Len = 0 then | |
3022 | return null; | |
3023 | else | |
3024 | return To_Path_String_Access (Host_Dir_Addr, Host_Dir_Len); | |
3025 | end if; | |
3026 | end To_Host_Dir_Spec; | |
3027 | ||
a01da44a | 3028 | ----------------------- |
38cbfe40 | 3029 | -- To_Host_File_Spec -- |
a01da44a | 3030 | ----------------------- |
38cbfe40 RK |
3031 | |
3032 | function To_Host_File_Spec | |
65356e64 | 3033 | (Canonical_File : String) return String_Access |
38cbfe40 RK |
3034 | is |
3035 | function To_Host_File_Spec (Canonical_File : Address) return Address; | |
3036 | pragma Import (C, To_Host_File_Spec, "__gnat_to_host_file_spec"); | |
3037 | ||
3038 | C_Canonical_File : String (1 .. Canonical_File'Length + 1); | |
3039 | Host_File_Addr : Address; | |
4f852a1a | 3040 | Host_File_Len : CRTL.size_t; |
38cbfe40 RK |
3041 | |
3042 | begin | |
3043 | C_Canonical_File (1 .. Canonical_File'Length) := Canonical_File; | |
3044 | C_Canonical_File (C_Canonical_File'Last) := ASCII.NUL; | |
3045 | ||
3046 | Host_File_Addr := To_Host_File_Spec (C_Canonical_File'Address); | |
3047 | Host_File_Len := C_String_Length (Host_File_Addr); | |
3048 | ||
3049 | if Host_File_Len = 0 then | |
3050 | return null; | |
3051 | else | |
3052 | return To_Path_String_Access | |
3053 | (Host_File_Addr, Host_File_Len); | |
3054 | end if; | |
3055 | end To_Host_File_Spec; | |
3056 | ||
3057 | --------------------------- | |
3058 | -- To_Path_String_Access -- | |
3059 | --------------------------- | |
3060 | ||
3061 | function To_Path_String_Access | |
3062 | (Path_Addr : Address; | |
4f852a1a | 3063 | Path_Len : CRTL.size_t) return String_Access |
38cbfe40 | 3064 | is |
4f852a1a | 3065 | subtype Path_String is String (1 .. Integer (Path_Len)); |
91b1417d | 3066 | type Path_String_Access is access Path_String; |
38cbfe40 RK |
3067 | |
3068 | function Address_To_Access is new | |
3069 | Unchecked_Conversion (Source => Address, | |
3070 | Target => Path_String_Access); | |
3071 | ||
fbf5a39b AC |
3072 | Path_Access : constant Path_String_Access := |
3073 | Address_To_Access (Path_Addr); | |
38cbfe40 | 3074 | |
91b1417d | 3075 | Return_Val : String_Access; |
38cbfe40 RK |
3076 | |
3077 | begin | |
4f852a1a | 3078 | Return_Val := new String (1 .. Integer (Path_Len)); |
38cbfe40 | 3079 | |
4f852a1a | 3080 | for J in 1 .. Integer (Path_Len) loop |
38cbfe40 RK |
3081 | Return_Val (J) := Path_Access (J); |
3082 | end loop; | |
3083 | ||
3084 | return Return_Val; | |
3085 | end To_Path_String_Access; | |
3086 | ||
38cbfe40 | 3087 | ----------------- |
07fc65c4 | 3088 | -- Update_Path -- |
38cbfe40 RK |
3089 | ----------------- |
3090 | ||
07fc65c4 | 3091 | function Update_Path (Path : String_Ptr) return String_Ptr is |
38cbfe40 | 3092 | |
07fc65c4 GB |
3093 | function C_Update_Path (Path, Component : Address) return Address; |
3094 | pragma Import (C, C_Update_Path, "update_path"); | |
38cbfe40 | 3095 | |
07fc65c4 GB |
3096 | In_Length : constant Integer := Path'Length; |
3097 | In_String : String (1 .. In_Length + 1); | |
2cdc8909 | 3098 | Component_Name : aliased String := "GCC" & ASCII.NUL; |
07fc65c4 | 3099 | Result_Ptr : Address; |
4f852a1a | 3100 | Result_Length : CRTL.size_t; |
07fc65c4 | 3101 | Out_String : String_Ptr; |
38cbfe40 | 3102 | |
07fc65c4 GB |
3103 | begin |
3104 | In_String (1 .. In_Length) := Path.all; | |
3105 | In_String (In_Length + 1) := ASCII.NUL; | |
39f4e199 | 3106 | Result_Ptr := C_Update_Path (In_String'Address, Component_Name'Address); |
4f852a1a | 3107 | Result_Length := CRTL.strlen (Result_Ptr); |
38cbfe40 | 3108 | |
4f852a1a EB |
3109 | Out_String := new String (1 .. Integer (Result_Length)); |
3110 | CRTL.strncpy (Out_String.all'Address, Result_Ptr, Result_Length); | |
07fc65c4 GB |
3111 | return Out_String; |
3112 | end Update_Path; | |
38cbfe40 RK |
3113 | |
3114 | ---------------- | |
3115 | -- Write_Info -- | |
3116 | ---------------- | |
3117 | ||
3118 | procedure Write_Info (Info : String) is | |
3119 | begin | |
38cbfe40 RK |
3120 | Write_With_Check (Info'Address, Info'Length); |
3121 | Write_With_Check (EOL'Address, 1); | |
3122 | end Write_Info; | |
3123 | ||
38cbfe40 RK |
3124 | ------------------------ |
3125 | -- Write_Program_Name -- | |
3126 | ------------------------ | |
3127 | ||
3128 | procedure Write_Program_Name is | |
fbf5a39b AC |
3129 | Save_Buffer : constant String (1 .. Name_Len) := |
3130 | Name_Buffer (1 .. Name_Len); | |
38cbfe40 RK |
3131 | |
3132 | begin | |
38cbfe40 RK |
3133 | Find_Program_Name; |
3134 | ||
3135 | -- Convert the name to lower case so error messages are the same on | |
3136 | -- all systems. | |
3137 | ||
3138 | for J in 1 .. Name_Len loop | |
3139 | if Name_Buffer (J) in 'A' .. 'Z' then | |
3140 | Name_Buffer (J) := | |
3141 | Character'Val (Character'Pos (Name_Buffer (J)) + 32); | |
3142 | end if; | |
3143 | end loop; | |
3144 | ||
3145 | Write_Str (Name_Buffer (1 .. Name_Len)); | |
3146 | ||
3147 | -- Restore Name_Buffer which was clobbered by the call to | |
3148 | -- Find_Program_Name | |
3149 | ||
3150 | Name_Len := Save_Buffer'Last; | |
3151 | Name_Buffer (1 .. Name_Len) := Save_Buffer; | |
3152 | end Write_Program_Name; | |
3153 | ||
3154 | ---------------------- | |
3155 | -- Write_With_Check -- | |
3156 | ---------------------- | |
3157 | ||
3158 | procedure Write_With_Check (A : Address; N : Integer) is | |
3159 | Ignore : Boolean; | |
38cbfe40 RK |
3160 | begin |
3161 | if N = Write (Output_FD, A, N) then | |
3162 | return; | |
38cbfe40 RK |
3163 | else |
3164 | Write_Str ("error: disk full writing "); | |
3165 | Write_Name_Decoded (Output_File_Name); | |
3166 | Write_Eol; | |
3167 | Name_Len := Name_Len + 1; | |
3168 | Name_Buffer (Name_Len) := ASCII.NUL; | |
3169 | Delete_File (Name_Buffer'Address, Ignore); | |
3170 | Exit_Program (E_Fatal); | |
3171 | end if; | |
3172 | end Write_With_Check; | |
3173 | ||
07fc65c4 GB |
3174 | ---------------------------- |
3175 | -- Package Initialization -- | |
3176 | ---------------------------- | |
3177 | ||
48263c9a | 3178 | procedure Reset_File_Attributes (Attr : System.Address); |
6528a7ed | 3179 | pragma Import (C, Reset_File_Attributes, "__gnat_reset_attributes"); |
48263c9a | 3180 | |
07fc65c4 GB |
3181 | begin |
3182 | Initialization : declare | |
3183 | ||
3184 | function Get_Default_Identifier_Character_Set return Character; | |
3185 | pragma Import (C, Get_Default_Identifier_Character_Set, | |
3186 | "__gnat_get_default_identifier_character_set"); | |
3187 | -- Function to determine the default identifier character set, | |
3188 | -- which is system dependent. See Opt package spec for a list of | |
3189 | -- the possible character codes and their interpretations. | |
3190 | ||
3191 | function Get_Maximum_File_Name_Length return Int; | |
3192 | pragma Import (C, Get_Maximum_File_Name_Length, | |
3193 | "__gnat_get_maximum_file_name_length"); | |
3194 | -- Function to get maximum file name length for system | |
3195 | ||
48263c9a EB |
3196 | Sizeof_File_Attributes : Integer; |
3197 | pragma Import (C, Sizeof_File_Attributes, | |
6528a7ed | 3198 | "__gnat_size_of_file_attributes"); |
48263c9a | 3199 | |
07fc65c4 | 3200 | begin |
48263c9a EB |
3201 | pragma Assert (Sizeof_File_Attributes <= File_Attributes_Size); |
3202 | ||
3203 | Reset_File_Attributes (Unknown_Attributes'Address); | |
3204 | ||
07fc65c4 GB |
3205 | Identifier_Character_Set := Get_Default_Identifier_Character_Set; |
3206 | Maximum_File_Name_Length := Get_Maximum_File_Name_Length; | |
3207 | ||
3208 | -- Following should be removed by having above function return | |
3209 | -- Integer'Last as indication of no maximum instead of -1 ??? | |
3210 | ||
3211 | if Maximum_File_Name_Length = -1 then | |
3212 | Maximum_File_Name_Length := Int'Last; | |
3213 | end if; | |
3214 | ||
07fc65c4 GB |
3215 | Src_Search_Directories.Set_Last (Primary_Directory); |
3216 | Src_Search_Directories.Table (Primary_Directory) := new String'(""); | |
3217 | ||
3218 | Lib_Search_Directories.Set_Last (Primary_Directory); | |
3219 | Lib_Search_Directories.Table (Primary_Directory) := new String'(""); | |
fbf5a39b | 3220 | |
35ae2ed8 | 3221 | Osint.Initialize; |
07fc65c4 GB |
3222 | end Initialization; |
3223 | ||
38cbfe40 | 3224 | end Osint; |