|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- O S I N T --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
145
|
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
|
|
111
|
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- --
|
|
|
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
|
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
|
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
|
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
|
|
17 -- for more details. You should have received a copy of the GNU General --
|
|
|
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
|
|
|
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
|
|
|
20 -- --
|
|
|
21 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
23 -- --
|
|
|
24 ------------------------------------------------------------------------------
|
|
|
25
|
|
|
26 with Alloc;
|
|
|
27 with Debug;
|
|
|
28 with Fmap; use Fmap;
|
|
|
29 with Gnatvsn; use Gnatvsn;
|
|
|
30 with Hostparm;
|
|
|
31 with Opt; use Opt;
|
|
|
32 with Output; use Output;
|
|
|
33 with Sdefault; use Sdefault;
|
|
|
34 with Table;
|
|
|
35 with Targparm; use Targparm;
|
|
|
36
|
|
|
37 with Unchecked_Conversion;
|
|
|
38
|
|
|
39 pragma Warnings (Off);
|
|
|
40 -- This package is used also by gnatcoll
|
|
|
41 with System.Case_Util; use System.Case_Util;
|
|
|
42 with System.CRTL;
|
|
|
43 pragma Warnings (On);
|
|
|
44
|
|
|
45 with GNAT.HTable;
|
|
|
46
|
|
|
47 package body Osint is
|
|
|
48
|
|
|
49 use type CRTL.size_t;
|
|
|
50
|
|
|
51 Running_Program : Program_Type := Unspecified;
|
|
|
52 -- comment required here ???
|
|
|
53
|
|
|
54 Program_Set : Boolean := False;
|
|
|
55 -- comment required here ???
|
|
|
56
|
|
|
57 Std_Prefix : String_Ptr;
|
|
|
58 -- Standard prefix, computed dynamically the first time Relocate_Path
|
|
|
59 -- is called, and cached for subsequent calls.
|
|
|
60
|
|
|
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
|
|
|
66 -------------------------------------
|
|
|
67 -- Use of Name_Find and Name_Enter --
|
|
|
68 -------------------------------------
|
|
|
69
|
|
|
70 -- This package creates a number of source, ALI and object file names
|
|
|
71 -- that are used to locate the actual file and for the purpose of message
|
|
|
72 -- construction. These names need not be accessible by Name_Find, and can
|
|
|
73 -- be therefore created by using routine Name_Enter. The files in question
|
|
|
74 -- are file names with a prefix directory (i.e., the files not in the
|
|
|
75 -- current directory). File names without a prefix directory are entered
|
|
|
76 -- with Name_Find because special values might be attached to the various
|
|
|
77 -- Info fields of the corresponding name table entry.
|
|
|
78
|
|
|
79 -----------------------
|
|
|
80 -- Local Subprograms --
|
|
|
81 -----------------------
|
|
|
82
|
|
|
83 function Append_Suffix_To_File_Name
|
|
|
84 (Name : File_Name_Type;
|
|
|
85 Suffix : String) return File_Name_Type;
|
|
|
86 -- Appends Suffix to Name and returns the new name
|
|
|
87
|
|
|
88 function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type;
|
|
|
89 -- Convert OS format time to GNAT format time stamp. If T is Invalid_Time,
|
|
|
90 -- then returns Empty_Time_Stamp.
|
|
145
|
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.
|
|
111
|
95
|
|
|
96 function Executable_Prefix return String_Ptr;
|
|
|
97 -- Returns the name of the root directory where the executable is stored.
|
|
|
98 -- The executable must be located in a directory called "bin", or under
|
|
|
99 -- root/lib/gcc-lib/..., or under root/libexec/gcc/... For example, if
|
|
|
100 -- executable is stored in directory "/foo/bar/bin", this routine returns
|
|
|
101 -- "/foo/bar/". Return "" if location is not recognized as described above.
|
|
|
102
|
|
|
103 function Update_Path (Path : String_Ptr) return String_Ptr;
|
|
|
104 -- Update the specified path to replace the prefix with the location where
|
|
|
105 -- GNAT is installed. See the file prefix.c in GCC for details.
|
|
|
106
|
|
|
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);
|
|
|
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.
|
|
|
119 --
|
|
|
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.
|
|
|
123 --
|
|
|
124 -- Attr is always reset in this call to Unknown_Attributes, even in case of
|
|
|
125 -- failure
|
|
|
126
|
|
|
127 procedure Find_File
|
|
|
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);
|
|
|
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
|
|
|
143
|
|
|
144 function C_String_Length (S : Address) return CRTL.size_t;
|
|
|
145 -- Returns length of a C string (zero for a null address)
|
|
|
146
|
|
|
147 function To_Path_String_Access
|
|
|
148 (Path_Addr : Address;
|
|
|
149 Path_Len : CRTL.size_t) return String_Access;
|
|
|
150 -- Converts a C String to an Ada String. Are we doing this to avoid withing
|
|
|
151 -- Interfaces.C.Strings ???
|
|
|
152 -- Caller must free result.
|
|
|
153
|
|
|
154 function Include_Dir_Default_Prefix return String_Access;
|
|
|
155 -- Same as exported version, except returns a String_Access
|
|
|
156
|
|
|
157 ------------------------------
|
|
|
158 -- Other Local Declarations --
|
|
|
159 ------------------------------
|
|
|
160
|
|
|
161 EOL : constant Character := ASCII.LF;
|
|
|
162 -- End of line character
|
|
|
163
|
|
|
164 Number_File_Names : Nat := 0;
|
|
|
165 -- Number of file names found on command line and placed in File_Names
|
|
|
166
|
|
|
167 Look_In_Primary_Directory_For_Current_Main : Boolean := False;
|
|
|
168 -- When this variable is True, Find_File only looks in Primary_Directory
|
|
|
169 -- for the Current_Main file. This variable is always set to True for the
|
|
|
170 -- compiler. It is also True for gnatmake, when the source name given on
|
|
|
171 -- the command line has directory information.
|
|
|
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;
|
|
|
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.
|
|
|
182
|
|
|
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
|
|
|
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
|
|
|
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).
|
|
|
206
|
|
|
207 package Src_Search_Directories is new Table.Table (
|
|
|
208 Table_Component_Type => String_Ptr,
|
|
|
209 Table_Index_Type => Integer,
|
|
|
210 Table_Low_Bound => Primary_Directory,
|
|
|
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,
|
|
|
220 Table_Index_Type => Integer,
|
|
|
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)
|
|
|
237 -- he is guaranteed that the price to retrieve the full name (i.e. with
|
|
|
238 -- directory info) or time stamp of the file will be payed only once, the
|
|
|
239 -- first time the full name is actually searched (or the first time the
|
|
|
240 -- time stamp is actually retrieved). This is achieved by employing a hash
|
|
|
241 -- table that stores as a key the File_Name_Type of the file and associates
|
|
|
242 -- to that File_Name_Type the full file name and time stamp of the file.
|
|
|
243
|
|
|
244 File_Cache_Enabled : Boolean := False;
|
|
|
245 -- Set to true if you want the enable the file data caching mechanism
|
|
|
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
|
|
|
252 type File_Info_Cache is record
|
|
|
253 File : File_Name_Type;
|
|
|
254 Attr : aliased File_Attributes;
|
|
|
255 end record;
|
|
|
256
|
|
131
|
257 No_File_Info_Cache : constant File_Info_Cache := (No_File, (others => 0));
|
|
111
|
258
|
|
|
259 package File_Name_Hash_Table is new GNAT.HTable.Simple_HTable (
|
|
|
260 Header_Num => File_Hash_Num,
|
|
|
261 Element => File_Info_Cache,
|
|
|
262 No_Element => No_File_Info_Cache,
|
|
|
263 Key => File_Name_Type,
|
|
|
264 Hash => File_Hash,
|
|
|
265 Equal => "=");
|
|
|
266
|
|
|
267 function Smart_Find_File
|
|
|
268 (N : File_Name_Type;
|
|
|
269 T : File_Type) return File_Name_Type;
|
|
|
270 -- Exactly like Find_File except that if File_Cache_Enabled is True this
|
|
|
271 -- routine looks first in the hash table to see if the full name of the
|
|
|
272 -- file is already available.
|
|
|
273
|
|
|
274 function Smart_File_Stamp
|
|
|
275 (N : File_Name_Type;
|
|
|
276 T : File_Type) return Time_Stamp_Type;
|
|
|
277 -- Takes the same parameter as the routine above (N is a file name without
|
|
|
278 -- any prefix directory information) and behaves like File_Stamp except
|
|
|
279 -- that if File_Cache_Enabled is True this routine looks first in the hash
|
|
|
280 -- table to see if the file stamp of the file is already available.
|
|
|
281
|
|
|
282 -----------------------------
|
|
|
283 -- Add_Default_Search_Dirs --
|
|
|
284 -----------------------------
|
|
|
285
|
|
|
286 procedure Add_Default_Search_Dirs is
|
|
|
287 Search_Dir : String_Access;
|
|
|
288 Search_Path : String_Access;
|
|
|
289 Path_File_Name : String_Access;
|
|
|
290
|
|
|
291 procedure Add_Search_Dir
|
|
|
292 (Search_Dir : String;
|
|
|
293 Additional_Source_Dir : Boolean);
|
|
|
294 procedure Add_Search_Dir
|
|
|
295 (Search_Dir : String_Access;
|
|
|
296 Additional_Source_Dir : Boolean);
|
|
|
297 -- Add a source search dir or a library search dir, depending on the
|
|
|
298 -- value of Additional_Source_Dir.
|
|
|
299
|
|
|
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
|
|
|
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:
|
|
|
306 --
|
|
|
307 -- HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\
|
|
|
308 -- GNAT\Standard Libraries
|
|
|
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).
|
|
|
314
|
|
|
315 --------------------
|
|
|
316 -- Add_Search_Dir --
|
|
|
317 --------------------
|
|
|
318
|
|
|
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
|
|
|
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
|
|
|
343 ------------------------
|
|
|
344 -- Get_Dirs_From_File --
|
|
|
345 ------------------------
|
|
|
346
|
|
|
347 procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean) is
|
|
|
348 File_FD : File_Descriptor;
|
|
|
349 Buffer : constant String := Path_File_Name.all & ASCII.NUL;
|
|
|
350 Len : Natural;
|
|
|
351 Actual_Len : Natural;
|
|
|
352 S : String_Access;
|
|
|
353 Curr : Natural;
|
|
|
354 First : Natural;
|
|
|
355 Ch : Character;
|
|
|
356
|
|
|
357 Status : Boolean;
|
|
|
358 pragma Warnings (Off, Status);
|
|
|
359 -- For the call to Close where status is ignored
|
|
|
360
|
|
|
361 begin
|
|
|
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
|
|
|
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.
|
|
|
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
|
|
|
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).
|
|
|
387
|
|
|
388 Close (File_FD, Status);
|
|
|
389
|
|
|
390 -- Now, we read line by line
|
|
|
391
|
|
|
392 First := 1;
|
|
|
393 Curr := 0;
|
|
|
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
|
|
|
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");
|
|
|
426
|
|
|
427 Result_Ptr : Address;
|
|
|
428 Result_Length : CRTL.size_t;
|
|
|
429 Out_String : String_Ptr;
|
|
|
430
|
|
|
431 begin
|
|
|
432 Result_Ptr := C_Get_Libraries_From_Registry;
|
|
|
433 Result_Length := CRTL.strlen (Result_Ptr);
|
|
|
434
|
|
|
435 Out_String := new String (1 .. Integer (Result_Length));
|
|
|
436 CRTL.strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
|
|
|
437
|
|
|
438 CRTL.free (Result_Ptr);
|
|
|
439
|
|
|
440 return Out_String;
|
|
|
441 end Get_Libraries_From_Registry;
|
|
|
442
|
|
|
443 -- Start of processing for Add_Default_Search_Dirs
|
|
|
444
|
|
|
445 begin
|
|
|
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
|
|
|
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
|
|
|
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
|
|
|
474 -- Put path name in canonical form
|
|
|
475
|
|
|
476 for Additional_Source_Dir in False .. True loop
|
|
|
477 if Additional_Source_Dir then
|
|
|
478 Search_Path := Getenv (Ada_Include_Path);
|
|
|
479
|
|
|
480 else
|
|
|
481 Search_Path := Getenv (Ada_Objects_Path);
|
|
|
482
|
|
|
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
|
|
|
493 -- For the compiler, if --RTS= was specified, add the runtime
|
|
|
494 -- directories.
|
|
|
495
|
|
|
496 if RTS_Src_Path_Name /= null and then RTS_Lib_Path_Name /= null then
|
|
|
497 Add_Search_Dirs (RTS_Src_Path_Name, Include);
|
|
|
498 Add_Search_Dirs (RTS_Lib_Path_Name, Objects);
|
|
|
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;
|
|
|
532
|
|
|
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
|
|
|
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;
|
|
|
552 end Add_Default_Search_Dirs;
|
|
|
553
|
|
|
554 --------------
|
|
|
555 -- Add_File --
|
|
|
556 --------------
|
|
|
557
|
|
|
558 procedure Add_File (File_Name : String; Index : Int := No_Index) is
|
|
|
559 begin
|
|
|
560 Number_File_Names := Number_File_Names + 1;
|
|
|
561
|
|
|
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.
|
|
|
564
|
|
|
565 if Number_File_Names > File_Names'Last then
|
|
|
566 File_Names := new File_Name_Array'(File_Names.all & File_Names.all);
|
|
|
567 File_Indexes :=
|
|
|
568 new File_Index_Array'(File_Indexes.all & File_Indexes.all);
|
|
|
569 end if;
|
|
|
570
|
|
|
571 File_Names (Number_File_Names) := new String'(File_Name);
|
|
|
572 File_Indexes (Number_File_Names) := Index;
|
|
|
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
|
|
|
585 declare
|
|
|
586 Norm : String_Ptr := Normalize_Directory_Name (Dir);
|
|
|
587
|
|
|
588 begin
|
|
|
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 ..
|
|
|
593 Lib_Search_Directories.Last
|
|
|
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;
|
|
|
604 end Add_Lib_Search_Dir;
|
|
|
605
|
|
|
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
|
|
|
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
|
|
|
651 (Name : File_Name_Type;
|
|
|
652 Suffix : String) return File_Name_Type
|
|
|
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
|
|
|
665 function C_String_Length (S : Address) return CRTL.size_t is
|
|
|
666 begin
|
|
|
667 if S = Null_Address then
|
|
|
668 return 0;
|
|
|
669 else
|
|
|
670 return CRTL.strlen (S);
|
|
|
671 end if;
|
|
|
672 end C_String_Length;
|
|
|
673
|
|
|
674 ------------------------------
|
|
|
675 -- Canonical_Case_File_Name --
|
|
|
676 ------------------------------
|
|
|
677
|
|
|
678 procedure Canonical_Case_File_Name (S : in out String) is
|
|
|
679 begin
|
|
|
680 if not File_Names_Case_Sensitive then
|
|
|
681 To_Lower (S);
|
|
|
682 end if;
|
|
|
683 end Canonical_Case_File_Name;
|
|
|
684
|
|
|
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
|
|
|
692 To_Lower (S);
|
|
|
693 end if;
|
|
|
694 end Canonical_Case_Env_Var_Name;
|
|
|
695
|
|
|
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
|
|
|
709 Fail ("Cannot create: " & Name_Buffer (1 .. Name_Len));
|
|
|
710 end if;
|
|
|
711 end Create_File_And_Check;
|
|
|
712
|
|
|
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
|
|
|
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
|
|
|
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
|
|
|
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
|
|
145
|
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
|
|
111
|
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
|
|
|
815 ---------------------
|
|
|
816 -- Executable_Name --
|
|
|
817 ---------------------
|
|
|
818
|
|
|
819 function Executable_Name
|
|
|
820 (Name : File_Name_Type;
|
|
|
821 Only_If_No_Suffix : Boolean := False) return File_Name_Type
|
|
|
822 is
|
|
|
823 Exec_Suffix : String_Access;
|
|
|
824 Add_Suffix : Boolean;
|
|
|
825
|
|
|
826 begin
|
|
|
827 if Name = No_File then
|
|
|
828 return No_File;
|
|
|
829 end if;
|
|
|
830
|
|
|
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
|
|
|
838 if Exec_Suffix'Length /= 0 then
|
|
|
839 Get_Name_String (Name);
|
|
|
840
|
|
|
841 Add_Suffix := True;
|
|
|
842 if Only_If_No_Suffix then
|
|
|
843 for J in reverse 1 .. Name_Len loop
|
|
|
844 if Name_Buffer (J) = '.' then
|
|
|
845 Add_Suffix := False;
|
|
|
846 exit;
|
|
|
847
|
|
131
|
848 elsif Is_Directory_Separator (Name_Buffer (J)) then
|
|
111
|
849 exit;
|
|
|
850 end if;
|
|
|
851 end loop;
|
|
|
852 end if;
|
|
|
853
|
|
|
854 if Add_Suffix then
|
|
|
855 declare
|
|
|
856 Buffer : String := Name_Buffer (1 .. Name_Len);
|
|
|
857
|
|
|
858 begin
|
|
|
859 -- Get the file name in canonical case to accept as is. Names
|
|
|
860 -- end with ".EXE" on Windows.
|
|
|
861
|
|
|
862 Canonical_Case_File_Name (Buffer);
|
|
|
863
|
|
|
864 -- If Executable doesn't end with the executable suffix, add it
|
|
|
865
|
|
|
866 if Buffer'Length <= Exec_Suffix'Length
|
|
|
867 or else
|
|
|
868 Buffer (Buffer'Last - Exec_Suffix'Length + 1 .. Buffer'Last)
|
|
|
869 /= Exec_Suffix.all
|
|
|
870 then
|
|
|
871 Name_Buffer
|
|
|
872 (Name_Len + 1 .. Name_Len + Exec_Suffix'Length) :=
|
|
|
873 Exec_Suffix.all;
|
|
|
874 Name_Len := Name_Len + Exec_Suffix'Length;
|
|
|
875 Free (Exec_Suffix);
|
|
|
876 return Name_Find;
|
|
|
877 end if;
|
|
|
878 end;
|
|
|
879 end if;
|
|
|
880 end if;
|
|
|
881
|
|
|
882 Free (Exec_Suffix);
|
|
|
883 return Name;
|
|
|
884 end Executable_Name;
|
|
|
885
|
|
|
886 function Executable_Name
|
|
|
887 (Name : String;
|
|
|
888 Only_If_No_Suffix : Boolean := False) return String
|
|
|
889 is
|
|
|
890 Exec_Suffix : String_Access;
|
|
|
891 Add_Suffix : Boolean;
|
|
|
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
|
|
|
902 if Exec_Suffix'Length = 0 then
|
|
|
903 Free (Exec_Suffix);
|
|
|
904 return Name;
|
|
|
905
|
|
|
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
|
|
|
916 for J in reverse Canonical_Name'Range loop
|
|
|
917 if Canonical_Name (J) = '.' then
|
|
|
918 Add_Suffix := False;
|
|
|
919 exit;
|
|
|
920
|
|
131
|
921 elsif Is_Directory_Separator (Canonical_Name (J)) then
|
|
111
|
922 exit;
|
|
|
923 end if;
|
|
|
924 end loop;
|
|
|
925 end if;
|
|
|
926
|
|
|
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;
|
|
|
944 end Executable_Name;
|
|
|
945
|
|
|
946 -----------------------
|
|
|
947 -- Executable_Prefix --
|
|
|
948 -----------------------
|
|
|
949
|
|
|
950 function Executable_Prefix return String_Ptr is
|
|
|
951
|
|
|
952 function Get_Install_Dir (Exec : String) return String_Ptr;
|
|
|
953 -- S is the executable name preceded by the absolute or relative
|
|
|
954 -- path, e.g. "c:\usr\bin\gcc.exe" or "..\bin\gcc".
|
|
|
955
|
|
|
956 ---------------------
|
|
|
957 -- Get_Install_Dir --
|
|
|
958 ---------------------
|
|
|
959
|
|
|
960 function Get_Install_Dir (Exec : String) return String_Ptr is
|
|
|
961 Full_Path : constant String := Normalize_Pathname (Exec);
|
|
|
962 -- Use the full path, so that we find "lib" or "bin", even when
|
|
|
963 -- the tool has been invoked with a relative path, as in
|
|
|
964 -- "./gnatls -v" invoked in the GNAT bin directory.
|
|
|
965
|
|
|
966 begin
|
|
|
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')
|
|
|
973 or else
|
|
|
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')
|
|
|
977 then
|
|
|
978 return new String'(Full_Path (Full_Path'First .. J));
|
|
|
979 end if;
|
|
|
980 end if;
|
|
|
981 end if;
|
|
|
982 end loop;
|
|
|
983
|
|
|
984 return new String'("");
|
|
|
985 end Get_Install_Dir;
|
|
|
986
|
|
|
987 -- Start of processing for Executable_Prefix
|
|
|
988
|
|
|
989 begin
|
|
|
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;
|
|
|
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
|
|
|
1000 return Get_Install_Dir (Exec_Name.all);
|
|
|
1001 end if;
|
|
|
1002 end loop;
|
|
|
1003
|
|
|
1004 -- If we come here, the user has typed the executable name with no
|
|
|
1005 -- directory prefix.
|
|
|
1006
|
|
|
1007 return Get_Install_Dir (Locate_Exec_On_Path (Exec_Name.all).all);
|
|
|
1008 end Executable_Prefix;
|
|
|
1009
|
|
|
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:
|
|
|
1017
|
|
|
1018 -- 0 if the object file has been generated (with or without warnings)
|
|
|
1019 -- 1 if recompilation was not needed (smart recompilation)
|
|
|
1020 -- 2 if gnat1 has been killed by a signal (detected by GCC)
|
|
|
1021 -- 4 for a fatal error
|
|
|
1022 -- 5 if there were errors
|
|
|
1023 -- 6 if no code has been generated (spec)
|
|
|
1024
|
|
|
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.
|
|
|
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);
|
|
|
1035 when E_Fatal => OS_Exit (4);
|
|
|
1036 when E_Errors => OS_Exit (5);
|
|
|
1037 when E_No_Code => OS_Exit (6);
|
|
|
1038 when E_Abort => OS_Abort;
|
|
|
1039 end case;
|
|
|
1040 end Exit_Program;
|
|
|
1041
|
|
|
1042 ----------
|
|
|
1043 -- Fail --
|
|
|
1044 ----------
|
|
|
1045
|
|
|
1046 procedure Fail (S : String) is
|
|
|
1047 begin
|
|
|
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.
|
|
|
1050
|
|
|
1051 Set_Standard_Error;
|
|
|
1052 Osint.Write_Program_Name;
|
|
|
1053 Write_Str (": ");
|
|
|
1054 Write_Str (S);
|
|
|
1055 Write_Eol;
|
|
|
1056
|
|
|
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
|
|
|
1069 -----------------
|
|
|
1070 -- File_Length --
|
|
|
1071 -----------------
|
|
|
1072
|
|
|
1073 function File_Length
|
|
|
1074 (Name : C_File_Name;
|
|
|
1075 Attr : access File_Attributes) return Long_Integer
|
|
|
1076 is
|
|
|
1077 function Internal
|
|
|
1078 (F : Integer;
|
|
|
1079 N : C_File_Name;
|
|
|
1080 A : System.Address) return CRTL.int64;
|
|
|
1081 pragma Import (C, Internal, "__gnat_file_length_attr");
|
|
|
1082
|
|
|
1083 begin
|
|
|
1084 -- The conversion from int64 to Long_Integer is ok here as this
|
|
|
1085 -- routine is only to be used by the compiler and we do not expect
|
|
|
1086 -- a unit to be larger than a 32bit integer.
|
|
|
1087
|
|
|
1088 return Long_Integer (Internal (-1, Name, Attr.all'Address));
|
|
|
1089 end File_Length;
|
|
|
1090
|
|
|
1091 ---------------------
|
|
|
1092 -- File_Time_Stamp --
|
|
|
1093 ---------------------
|
|
|
1094
|
|
|
1095 function File_Time_Stamp
|
|
|
1096 (Name : C_File_Name;
|
|
|
1097 Attr : access File_Attributes) return OS_Time
|
|
|
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
|
|
|
1105 function File_Time_Stamp
|
|
|
1106 (Name : Path_Name_Type;
|
|
|
1107 Attr : access File_Attributes) return Time_Stamp_Type
|
|
|
1108 is
|
|
|
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
|
|
|
1117 (File_Time_Stamp (Name_Buffer'Address, Attr));
|
|
|
1118 end File_Time_Stamp;
|
|
|
1119
|
|
|
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
|
|
|
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.
|
|
|
1136
|
|
|
1137 return OS_Time_To_GNAT_Time
|
|
|
1138 (File_Time_Stamp (Name_Buffer (1 .. Name_Len)));
|
|
|
1139 end File_Stamp;
|
|
|
1140
|
|
|
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
|
|
|
1146 ---------------
|
|
|
1147 -- Find_File --
|
|
|
1148 ---------------
|
|
|
1149
|
|
|
1150 function Find_File
|
|
|
1151 (N : File_Name_Type;
|
|
|
1152 T : File_Type;
|
|
|
1153 Full_Name : Boolean := False) return File_Name_Type
|
|
|
1154 is
|
|
|
1155 Attr : aliased File_Attributes;
|
|
|
1156 Found : File_Name_Type;
|
|
|
1157 begin
|
|
|
1158 Find_File (N, T, Found, Attr'Access, Full_Name);
|
|
|
1159 return Found;
|
|
|
1160 end Find_File;
|
|
|
1161
|
|
|
1162 ---------------
|
|
|
1163 -- Find_File --
|
|
|
1164 ---------------
|
|
|
1165
|
|
|
1166 procedure Find_File
|
|
|
1167 (N : File_Name_Type;
|
|
|
1168 T : File_Type;
|
|
|
1169 Found : out File_Name_Type;
|
|
|
1170 Attr : access File_Attributes;
|
|
|
1171 Full_Name : Boolean := False)
|
|
|
1172 is
|
|
|
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
|
|
|
1183 -- directory, i.e. return input argument unchanged. Also look only in
|
|
|
1184 -- the current directory if we are looking for a .dg file (happens in
|
|
|
1185 -- -gnatD mode).
|
|
|
1186
|
|
|
1187 if T = Config
|
|
|
1188 or else (Debug_Generated_Code
|
|
|
1189 and then Name_Len > 3
|
|
|
1190 and then Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg")
|
|
|
1191 then
|
|
|
1192 Found := N;
|
|
|
1193 Attr.all := Unknown_Attributes;
|
|
|
1194
|
|
|
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;
|
|
|
1205 Found := Name_Find;
|
|
|
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;
|
|
|
1214 end if;
|
|
|
1215
|
|
|
1216 return;
|
|
|
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
|
|
|
1222 and then Current_Main = N
|
|
|
1223 then
|
|
|
1224 Locate_File (N, T, Primary_Directory, File_Name, Found, Attr);
|
|
|
1225 return;
|
|
|
1226
|
|
|
1227 -- Otherwise do standard search for source file
|
|
|
1228
|
|
|
1229 else
|
|
|
1230 -- Check the mapping of this file name
|
|
|
1231
|
|
|
1232 File := Mapped_Path_Name (N);
|
|
|
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
|
|
|
1238
|
|
|
1239 -- For locally removed file, Error_Name is returned; then
|
|
|
1240 -- return No_File, indicating the file is not a source.
|
|
|
1241
|
|
|
1242 if File = Error_File_Name then
|
|
|
1243 Found := No_File;
|
|
|
1244 else
|
|
|
1245 Found := File;
|
|
|
1246 end if;
|
|
|
1247
|
|
|
1248 Attr.all := Unknown_Attributes;
|
|
|
1249 return;
|
|
|
1250 end if;
|
|
|
1251
|
|
|
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
|
|
|
1256 Locate_File (N, T, Primary_Directory, File_Name, Found, Attr);
|
|
|
1257
|
|
|
1258 if Found /= No_File then
|
|
|
1259 return;
|
|
|
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
|
|
|
1272 Locate_File (N, T, D, File_Name, Found, Attr);
|
|
|
1273
|
|
|
1274 if Found /= No_File then
|
|
|
1275 return;
|
|
|
1276 end if;
|
|
|
1277 end loop;
|
|
|
1278
|
|
|
1279 Attr.all := Unknown_Attributes;
|
|
|
1280 Found := No_File;
|
|
|
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));
|
|
|
1291 Cindex1 : Integer := Command_Name'First;
|
|
|
1292 Cindex2 : Integer := Command_Name'Last;
|
|
|
1293
|
|
|
1294 begin
|
|
|
1295 Fill_Arg (Command_Name'Address, 0);
|
|
|
1296
|
|
|
1297 if Command_Name = "" then
|
|
|
1298 Name_Len := 0;
|
|
|
1299 return;
|
|
|
1300 end if;
|
|
|
1301
|
|
|
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
|
|
|
1313 -- Command_Name(Cindex1 .. Cindex2) is now the equivalent of the
|
|
|
1314 -- POSIX command "basename argv[0]"
|
|
|
1315
|
|
|
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;
|
|
|
1326 end if;
|
|
|
1327 end if;
|
|
|
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
|
|
|
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
|
|
|
1353 function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type is
|
|
|
1354 Attr : File_Attributes;
|
|
|
1355 File : File_Name_Type;
|
|
|
1356 begin
|
|
|
1357 Full_Lib_File_Name (N, File, Attr);
|
|
|
1358 return File;
|
|
|
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
|
|
|
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
|
|
|
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
|
|
145
|
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
|
|
111
|
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
|
|
|
1447 (Search_Path : String_Access) return String_Access
|
|
|
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
|
|
|
1494 ------------------------
|
|
|
1495 -- Get_RTS_Search_Dir --
|
|
|
1496 ------------------------
|
|
|
1497
|
|
|
1498 function Get_RTS_Search_Dir
|
|
|
1499 (Search_Dir : String;
|
|
|
1500 File_Type : Search_File_Type) return String_Ptr
|
|
|
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;
|
|
|
1508 pragma Import (C, Max_Path, "__gnat_max_path_len");
|
|
|
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
|
|
131
|
1524 if not Is_Directory_Separator (Search_Dir (Search_Dir'Last)) then
|
|
111
|
1525 Local_Search_Dir :=
|
|
|
1526 new String'(Search_Dir & String'(1 => Directory_Separator));
|
|
|
1527 else
|
|
|
1528 Local_Search_Dir := new String'(Search_Dir);
|
|
|
1529 end if;
|
|
|
1530
|
|
|
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;
|
|
|
1536 Default_Suffix_Dir := new String'("adalib");
|
|
|
1537 end if;
|
|
|
1538
|
|
|
1539 Norm_Search_Dir := Local_Search_Dir;
|
|
|
1540
|
|
|
1541 if Is_Absolute_Path (Norm_Search_Dir.all) then
|
|
|
1542
|
|
|
1543 -- We first verify if there is a directory Include_Search_Dir
|
|
|
1544 -- containing default search directories
|
|
|
1545
|
|
|
1546 Result_Search_Dir :=
|
|
|
1547 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
|
|
|
1548 Default_Search_Dir :=
|
|
|
1549 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
|
|
|
1550 Free (Norm_Search_Dir);
|
|
|
1551
|
|
|
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;
|
|
|
1559
|
|
|
1560 -- Search in the current directory
|
|
|
1561
|
|
|
1562 else
|
|
|
1563 -- Get the current directory
|
|
|
1564
|
|
|
1565 declare
|
|
|
1566 Buffer : String (1 .. Max_Path + 2);
|
|
|
1567 Path_Len : Natural := Max_Path;
|
|
|
1568
|
|
|
1569 begin
|
|
|
1570 Get_Current_Dir (Buffer'Address, Path_Len'Address);
|
|
|
1571
|
|
|
1572 if Path_Len = 0 then
|
|
|
1573 raise Program_Error;
|
|
|
1574 end if;
|
|
|
1575
|
|
131
|
1576 if not Is_Directory_Separator (Buffer (Path_Len)) then
|
|
111
|
1577 Path_Len := Path_Len + 1;
|
|
|
1578 Buffer (Path_Len) := Directory_Separator;
|
|
|
1579 end if;
|
|
|
1580
|
|
|
1581 Current_Dir := new String'(Buffer (1 .. Path_Len));
|
|
|
1582 end;
|
|
|
1583
|
|
|
1584 Norm_Search_Dir :=
|
|
|
1585 new String'(Current_Dir.all & Local_Search_Dir.all);
|
|
|
1586
|
|
|
1587 Result_Search_Dir :=
|
|
|
1588 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
|
|
|
1589
|
|
|
1590 Default_Search_Dir :=
|
|
|
1591 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
|
|
|
1592
|
|
|
1593 Free (Norm_Search_Dir);
|
|
|
1594
|
|
|
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'
|
|
|
1606 (Update_Path (Search_Dir_Prefix).all & Local_Search_Dir.all);
|
|
|
1607
|
|
|
1608 Result_Search_Dir :=
|
|
|
1609 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
|
|
|
1610
|
|
|
1611 Default_Search_Dir :=
|
|
|
1612 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
|
|
|
1613
|
|
|
1614 Free (Norm_Search_Dir);
|
|
|
1615
|
|
|
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 :=
|
|
|
1626 new String'(Update_Path (Search_Dir_Prefix).all & "rts-");
|
|
|
1627
|
|
|
1628 Norm_Search_Dir :=
|
|
|
1629 new String'(Temp_String.all & Local_Search_Dir.all);
|
|
|
1630
|
|
|
1631 Result_Search_Dir :=
|
|
|
1632 Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
|
|
|
1633
|
|
|
1634 Default_Search_Dir :=
|
|
|
1635 new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
|
|
|
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;
|
|
|
1651
|
|
|
1652 --------------------------------
|
|
|
1653 -- Include_Dir_Default_Prefix --
|
|
|
1654 --------------------------------
|
|
|
1655
|
|
|
1656 function Include_Dir_Default_Prefix return String_Access is
|
|
|
1657 begin
|
|
|
1658 if The_Include_Dir_Default_Prefix = null then
|
|
|
1659 The_Include_Dir_Default_Prefix :=
|
|
|
1660 String_Access (Update_Path (Include_Dir_Default_Name));
|
|
|
1661 end if;
|
|
|
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;
|
|
|
1669 end Include_Dir_Default_Prefix;
|
|
|
1670
|
|
|
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
|
|
|
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
|
|
|
1686 -- in Gnat1drv).
|
|
|
1687
|
|
|
1688 Suppress_Options := ((others => False), Not_Set, Not_Set);
|
|
|
1689
|
|
|
1690 -- Reserve the first slot in the search paths table. This is the
|
|
|
1691 -- directory of the main source file or main library file and is filled
|
|
|
1692 -- in by each call to Next_Main_Source/Next_Main_Lib_File with the
|
|
|
1693 -- directory specified for this main source or library file. This is the
|
|
|
1694 -- directory which is searched first by default. This default search is
|
|
|
1695 -- inhibited by the option -I- for both source and library files.
|
|
|
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
|
|
|
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
|
|
|
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
|
|
|
1724 -- act as separator since this is allowed in MS-DOS and Windows.
|
|
|
1725
|
|
|
1726 return C = Directory_Separator or else C = '/';
|
|
|
1727 end Is_Directory_Separator;
|
|
|
1728
|
|
|
1729 -------------------------
|
|
|
1730 -- Is_Readonly_Library --
|
|
|
1731 -------------------------
|
|
|
1732
|
|
|
1733 function Is_Readonly_Library (File : File_Name_Type) return Boolean is
|
|
|
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
|
|
|
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
|
|
|
1807 -------------------
|
|
|
1808 -- Lib_File_Name --
|
|
|
1809 -------------------
|
|
|
1810
|
|
|
1811 function Lib_File_Name
|
|
|
1812 (Source_File : File_Name_Type;
|
|
|
1813 Munit_Index : Nat := 0) return File_Name_Type
|
|
|
1814 is
|
|
|
1815 begin
|
|
|
1816 Get_Name_String (Source_File);
|
|
|
1817
|
|
|
1818 for J in reverse 2 .. Name_Len loop
|
|
|
1819 if Name_Buffer (J) = '.' then
|
|
|
1820 Name_Len := J - 1;
|
|
|
1821 exit;
|
|
|
1822 end if;
|
|
|
1823 end loop;
|
|
|
1824
|
|
|
1825 if Munit_Index /= 0 then
|
|
|
1826 Add_Char_To_Name_Buffer (Multi_Unit_Index_Character);
|
|
|
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);
|
|
|
1832 return Name_Find;
|
|
|
1833 end Lib_File_Name;
|
|
|
1834
|
|
|
1835 -----------------
|
|
|
1836 -- Locate_File --
|
|
|
1837 -----------------
|
|
|
1838
|
|
|
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)
|
|
|
1846 is
|
|
|
1847 Dir_Name : String_Ptr;
|
|
|
1848
|
|
|
1849 begin
|
|
|
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
|
|
|
1856 Dir_Name := Lib_Search_Directories.Table (Dir);
|
|
|
1857
|
|
|
1858 else
|
|
|
1859 pragma Assert (T /= Config);
|
|
|
1860 Dir_Name := Src_Search_Directories.Table (Dir);
|
|
|
1861 end if;
|
|
|
1862
|
|
|
1863 declare
|
|
|
1864 Full_Name : String (1 .. Dir_Name'Length + Name'Length + 1);
|
|
|
1865
|
|
|
1866 begin
|
|
|
1867 Full_Name (1 .. Dir_Name'Length) := Dir_Name.all;
|
|
|
1868 Full_Name (Dir_Name'Length + 1 .. Full_Name'Last - 1) := Name;
|
|
|
1869 Full_Name (Full_Name'Last) := ASCII.NUL;
|
|
|
1870
|
|
|
1871 Attr.all := Unknown_Attributes;
|
|
|
1872
|
|
|
1873 if not Is_Regular_File (Full_Name'Address, Attr) then
|
|
|
1874 Found := No_File;
|
|
|
1875
|
|
|
1876 else
|
|
|
1877 -- If the file is in the current directory then return N itself
|
|
|
1878
|
|
|
1879 if Dir_Name'Length = 0 then
|
|
|
1880 Found := N;
|
|
|
1881 else
|
|
|
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
|
|
|
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
|
|
|
1896 (N : File_Name_Type;
|
|
|
1897 T : Time_Stamp_Type) return File_Name_Type
|
|
|
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;
|
|
|
1905 Attr : aliased File_Attributes;
|
|
|
1906 Last_Dir : Natural;
|
|
|
1907
|
|
|
1908 begin
|
|
|
1909 if Opt.Look_In_Primary_Dir then
|
|
|
1910 Locate_File
|
|
|
1911 (N, Source, Primary_Directory, File_Name, File, Attr'Access);
|
|
|
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
|
|
|
1921 Locate_File (N, Source, D, File_Name, File, Attr'Access);
|
|
|
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
|
|
|
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
|
|
131
|
1987 if Is_Directory_Separator (File_Name (J)) then
|
|
111
|
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
|
|
|
2002 case Running_Program is
|
|
|
2003 when Compiler =>
|
|
|
2004 Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
|
|
|
2005 Look_In_Primary_Directory_For_Current_Main := True;
|
|
|
2006
|
|
|
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
|
|
|
2014 when Binder
|
|
|
2015 | Gnatls
|
|
|
2016 =>
|
|
|
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;
|
|
|
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));
|
|
|
2027 Current_Main := Name_Find;
|
|
|
2028
|
|
|
2029 -- In the gnatmake case, the main file may have not have the
|
|
|
2030 -- extension. Try ".adb" first then ".ads"
|
|
|
2031
|
|
|
2032 if Running_Program = Make then
|
|
|
2033 declare
|
|
|
2034 Orig_Main : constant File_Name_Type := Current_Main;
|
|
|
2035
|
|
|
2036 begin
|
|
|
2037 if Strip_Suffix (Orig_Main) = Orig_Main then
|
|
|
2038 Current_Main :=
|
|
|
2039 Append_Suffix_To_File_Name (Orig_Main, ".adb");
|
|
|
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
|
|
|
2056 ------------------------------
|
|
|
2057 -- Normalize_Directory_Name --
|
|
|
2058 ------------------------------
|
|
|
2059
|
|
|
2060 function Normalize_Directory_Name (Directory : String) return String_Ptr is
|
|
|
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
|
|
|
2085 Result : String_Ptr;
|
|
|
2086
|
|
|
2087 -- Start of processing for Normalize_Directory_Name
|
|
|
2088
|
|
|
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);
|
|
|
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);
|
|
|
2104 Result (1 .. Directory'Length - 2) :=
|
|
|
2105 Directory (Directory'First + 1 .. Directory'Last - 1);
|
|
|
2106 Result (Result'Last) := Directory_Separator;
|
|
|
2107
|
|
|
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
|
|
|
2121 function Number_Of_Files return Nat is
|
|
|
2122 begin
|
|
|
2123 return Number_File_Names;
|
|
|
2124 end Number_Of_Files;
|
|
|
2125
|
|
|
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
|
|
|
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
|
|
|
2161 for J in Target_Object_Suffix'Range loop
|
|
|
2162 Name_Len := Name_Len + 1;
|
|
|
2163 Name_Buffer (Name_Len) := Target_Object_Suffix (J);
|
|
|
2164 end loop;
|
|
|
2165
|
|
|
2166 return Name_Enter;
|
|
|
2167 end Object_File_Name;
|
|
|
2168
|
|
|
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
|
|
|
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
|
|
145
|
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);
|
|
111
|
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
|
|
|
2207 if T = Invalid_Time then
|
|
|
2208 return Empty_Time_Stamp;
|
|
|
2209 end if;
|
|
|
2210
|
|
145
|
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
|
|
|
2220 GM_Split (From_Int (TI), Y, Mo, D, H, Mn, S);
|
|
|
2221
|
|
111
|
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
|
|
|
2234 -----------------
|
|
|
2235 -- Prep_Suffix --
|
|
|
2236 -----------------
|
|
|
2237
|
|
|
2238 function Prep_Suffix return String is
|
|
|
2239 begin
|
|
|
2240 return ".prep";
|
|
|
2241 end Prep_Suffix;
|
|
|
2242
|
|
|
2243 ------------------
|
|
|
2244 -- Program_Name --
|
|
|
2245 ------------------
|
|
|
2246
|
|
|
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;
|
|
|
2251
|
|
|
2252 begin
|
|
|
2253 -- Get the name of the current program being executed
|
|
|
2254
|
|
|
2255 Find_Program_Name;
|
|
|
2256
|
|
|
2257 Start_Of_Suffix := Name_Len + 1;
|
|
|
2258
|
|
|
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"
|
|
|
2263
|
|
|
2264 for J in reverse 1 .. Name_Len loop
|
|
131
|
2265 if Is_Directory_Separator (Name_Buffer (J))
|
|
111
|
2266 or else Name_Buffer (J) = ':'
|
|
|
2267 then
|
|
|
2268 Start_Of_Prefix := J + 1;
|
|
|
2269 exit;
|
|
|
2270 end if;
|
|
|
2271 end loop;
|
|
|
2272
|
|
|
2273 -- Find End_Of_Prefix
|
|
|
2274
|
|
|
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;
|
|
|
2278 exit;
|
|
|
2279 end if;
|
|
|
2280 end loop;
|
|
|
2281
|
|
|
2282 if End_Of_Prefix > 1 then
|
|
|
2283 Start_Of_Suffix := End_Of_Prefix + Prog'Length + 1;
|
|
|
2284 end if;
|
|
|
2285
|
|
|
2286 -- Create the new program name
|
|
|
2287
|
|
|
2288 return new String'
|
|
|
2289 (Name_Buffer (Start_Of_Prefix .. End_Of_Prefix)
|
|
|
2290 & Nam
|
|
|
2291 & Name_Buffer (Start_Of_Suffix .. Name_Len));
|
|
|
2292 end Program_Name;
|
|
|
2293
|
|
|
2294 ------------------------------
|
|
|
2295 -- Read_Default_Search_Dirs --
|
|
|
2296 ------------------------------
|
|
|
2297
|
|
|
2298 function Read_Default_Search_Dirs
|
|
|
2299 (Search_Dir_Prefix : String_Access;
|
|
|
2300 Search_File : String_Access;
|
|
|
2301 Search_Dir_Default_Name : String_Access) return String_Access
|
|
|
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
|
|
|
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.
|
|
|
2319
|
|
|
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
|
|
|
2332 -- Construct a C compatible character string buffer
|
|
|
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
|
|
|
2352 -- Read the file. Note that the loop is probably not necessary since the
|
|
|
2353 -- whole file is read at once but the loop is harmless and that way we
|
|
|
2354 -- are sure to accommodate systems where this is not the case.
|
|
|
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
|
|
|
2363 -- Process the file, dealing with path separators
|
|
|
2364
|
|
|
2365 Prev_Was_Separator := True;
|
|
|
2366 Nb_Relative_Dir := 0;
|
|
|
2367 for J in 1 .. Len loop
|
|
|
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
|
|
|
2377 S (J) := Path_Separator;
|
|
|
2378 end if;
|
|
|
2379
|
|
|
2380 -- Test for explicit path separator (or control char as above)
|
|
|
2381
|
|
|
2382 if S (J) = Path_Separator then
|
|
|
2383 Prev_Was_Separator := True;
|
|
|
2384
|
|
|
2385 -- If not path separator, register use of relative directory
|
|
|
2386
|
|
|
2387 else
|
|
|
2388 if Prev_Was_Separator and then Is_Relative (S.all, J) then
|
|
|
2389 Nb_Relative_Dir := Nb_Relative_Dir + 1;
|
|
|
2390 end if;
|
|
|
2391
|
|
|
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
|
|
|
2406 if S (J) = Path_Separator then
|
|
|
2407 Prev_Was_Separator := True;
|
|
|
2408
|
|
|
2409 else
|
|
|
2410 if Prev_Was_Separator and then Is_Relative (S.all, J) then
|
|
|
2411 S1 (J1 .. J1 + Prefix_Len - 1) := Search_Dir_Prefix.all;
|
|
|
2412 J1 := J1 + Prefix_Len;
|
|
|
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;
|
|
|
2431 Fatal_Err : Boolean := False) return Text_Buffer_Ptr
|
|
|
2432 is
|
|
|
2433 File : File_Name_Type;
|
|
|
2434 Attr : aliased File_Attributes;
|
|
|
2435 begin
|
|
|
2436 Find_File (Lib_File, Library, File, Attr'Access);
|
|
|
2437 return Read_Library_Info_From_Full
|
|
|
2438 (Full_Lib_File => File,
|
|
|
2439 Lib_File_Attr => Attr'Access,
|
|
|
2440 Fatal_Err => Fatal_Err);
|
|
|
2441 end Read_Library_Info;
|
|
|
2442
|
|
|
2443 ---------------------------------
|
|
|
2444 -- Read_Library_Info_From_Full --
|
|
|
2445 ---------------------------------
|
|
|
2446
|
|
|
2447 function Read_Library_Info_From_Full
|
|
|
2448 (Full_Lib_File : File_Name_Type;
|
|
|
2449 Lib_File_Attr : access File_Attributes;
|
|
|
2450 Fatal_Err : Boolean := False) return Text_Buffer_Ptr
|
|
|
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
|
|
|
2456 Len : Integer;
|
|
|
2457 -- Length of source file text (ALI). If it doesn't fit in an integer
|
|
|
2458 -- we're probably stuck anyway (>2 gigs of source seems a lot, and
|
|
|
2459 -- there are other places in the compiler that make this assumption).
|
|
|
2460
|
|
|
2461 Text : Text_Buffer_Ptr;
|
|
|
2462 -- Allocated text buffer
|
|
|
2463
|
|
|
2464 Status : Boolean;
|
|
|
2465 pragma Warnings (Off, Status);
|
|
|
2466 -- For the calls to Close
|
|
|
2467
|
|
|
2468 begin
|
|
|
2469 Current_Full_Lib_Name := Full_Lib_File;
|
|
|
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
|
|
|
2474 Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
|
|
|
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
|
|
|
2493 Fail ("Cannot open: " & Name_Buffer (1 .. Name_Len));
|
|
|
2494 else
|
|
|
2495 Current_Full_Obj_Stamp := Empty_Time_Stamp;
|
|
|
2496 return null;
|
|
|
2497 end if;
|
|
|
2498 end if;
|
|
|
2499
|
|
|
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
|
|
|
2505 -- Check for object file consistency if requested
|
|
|
2506
|
|
|
2507 if Opt.Check_Object_Consistency then
|
|
|
2508 -- On most systems, this does not result in an extra system call
|
|
|
2509
|
|
|
2510 Current_Full_Lib_Stamp :=
|
|
|
2511 OS_Time_To_GNAT_Time
|
|
|
2512 (File_Time_Stamp (Name_Buffer'Address, Lib_File_Attr));
|
|
|
2513
|
|
|
2514 -- ??? One system call here
|
|
|
2515
|
|
|
2516 Current_Full_Obj_Stamp := File_Stamp (Current_Full_Obj_Name);
|
|
|
2517
|
|
|
2518 if Current_Full_Obj_Stamp (1) = ' ' then
|
|
|
2519
|
|
|
2520 -- When the library is readonly always assume object is consistent
|
|
|
2521 -- The call to Is_Writable_File only results in a system call on
|
|
|
2522 -- some systems, but in most cases it has already been computed as
|
|
|
2523 -- part of the call to File_Length above.
|
|
|
2524
|
|
|
2525 Get_Name_String (Current_Full_Lib_Name);
|
|
|
2526 Name_Buffer (Name_Len + 1) := ASCII.NUL;
|
|
|
2527
|
|
|
2528 if not Is_Writable_File (Name_Buffer'Address, Lib_File_Attr) then
|
|
|
2529 Current_Full_Obj_Stamp := Current_Full_Lib_Stamp;
|
|
|
2530
|
|
|
2531 elsif Fatal_Err then
|
|
|
2532 Get_Name_String (Current_Full_Obj_Name);
|
|
|
2533 Close (Lib_FD, Status);
|
|
|
2534
|
|
|
2535 -- No need to check the status, we fail anyway
|
|
|
2536
|
|
|
2537 Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
|
|
|
2538
|
|
|
2539 else
|
|
|
2540 Current_Full_Obj_Stamp := Empty_Time_Stamp;
|
|
|
2541 Close (Lib_FD, Status);
|
|
|
2542
|
|
|
2543 -- No need to check the status, we return null anyway
|
|
|
2544
|
|
|
2545 return null;
|
|
|
2546 end if;
|
|
|
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;
|
|
|
2554 end if;
|
|
|
2555 end if;
|
|
|
2556
|
|
|
2557 -- Read data from the file
|
|
|
2558
|
|
|
2559 declare
|
|
|
2560 Actual_Len : Integer := 0;
|
|
|
2561
|
|
|
2562 Lo : constant Text_Ptr := 0;
|
|
|
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
|
|
|
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.
|
|
|
2577
|
|
|
2578 Hi := Lo;
|
|
|
2579 loop
|
|
|
2580 Actual_Len := Read (Lib_FD, Text (Hi)'Address, Len);
|
|
|
2581 Hi := Hi + Text_Ptr (Actual_Len);
|
|
|
2582 exit when Actual_Len = Len or else Actual_Len <= 0;
|
|
|
2583 end loop;
|
|
|
2584
|
|
|
2585 Text (Hi) := EOF;
|
|
|
2586 end;
|
|
|
2587
|
|
|
2588 -- Read is complete, close file and we are done
|
|
|
2589
|
|
|
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
|
|
|
2594 return Text;
|
|
|
2595
|
|
|
2596 end Read_Library_Info_From_Full;
|
|
|
2597
|
|
|
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;
|
|
|
2607 FD : out File_Descriptor;
|
|
|
2608 T : File_Type := Source)
|
|
|
2609 is
|
|
|
2610 Len : Integer;
|
|
|
2611 -- Length of file, assume no more than 2 gigabytes of source
|
|
|
2612
|
|
|
2613 Actual_Len : Integer;
|
|
|
2614
|
|
|
2615 Status : Boolean;
|
|
|
2616 pragma Warnings (Off, Status);
|
|
|
2617 -- For the call to Close
|
|
|
2618
|
|
|
2619 begin
|
|
|
2620 Current_Full_Source_Name := Find_File (N, T, Full_Name => True);
|
|
|
2621 Current_Full_Source_Stamp := File_Stamp (Current_Full_Source_Name);
|
|
|
2622
|
|
|
2623 if Current_Full_Source_Name = No_File then
|
|
|
2624
|
|
|
2625 -- If we were trying to access the main file and we could not find
|
|
|
2626 -- it, we have an error.
|
|
|
2627
|
|
|
2628 if N = Current_Main then
|
|
|
2629 Get_Name_String (N);
|
|
|
2630 Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len));
|
|
|
2631 end if;
|
|
|
2632
|
|
|
2633 FD := Null_FD;
|
|
|
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
|
|
|
2647 FD := Open_Read (Name_Buffer'Address, Binary);
|
|
|
2648
|
|
|
2649 if FD = Invalid_FD then
|
|
|
2650 Src := null;
|
|
|
2651 Hi := No_Location;
|
|
|
2652 return;
|
|
|
2653 end if;
|
|
|
2654
|
|
|
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.
|
|
|
2660
|
|
|
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;
|
|
|
2665
|
|
|
2666 Part_Of_Runtimes : constant Boolean :=
|
|
|
2667 Inc /= ""
|
|
|
2668 and then Inc'Length < Name_Len
|
|
|
2669 and then Name_Buffer (1 .. Inc'Length) = Inc;
|
|
|
2670
|
|
|
2671 begin
|
|
|
2672 if Debug.Debug_Flag_Dot_N then
|
|
|
2673 Write_Line (Name);
|
|
|
2674 end if;
|
|
|
2675
|
|
|
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;
|
|
|
2682
|
|
|
2683 -- Prepare to read data from the file
|
|
|
2684
|
|
|
2685 Len := Integer (File_Length (FD));
|
|
|
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
|
|
|
2695 Var_Ptr : constant Source_Buffer_Ptr_Var :=
|
|
|
2696 new Source_Buffer (Lo .. Hi);
|
|
|
2697 -- Allocate source buffer, allowing extra character at end for EOF
|
|
|
2698 begin
|
|
|
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.
|
|
|
2702
|
|
|
2703 Hi := Lo;
|
|
|
2704 loop
|
|
|
2705 Actual_Len := Read (FD, Var_Ptr (Hi)'Address, Len);
|
|
|
2706 Hi := Hi + Source_Ptr (Actual_Len);
|
|
|
2707 exit when Actual_Len = Len or else Actual_Len <= 0;
|
|
|
2708 end loop;
|
|
|
2709
|
|
|
2710 Var_Ptr (Hi) := EOF;
|
|
|
2711 Src := Var_Ptr.all'Access;
|
|
|
2712 end;
|
|
|
2713
|
|
|
2714 -- Read is complete, get time stamp and close file and we are done
|
|
|
2715
|
|
|
2716 Close (FD, Status);
|
|
|
2717
|
|
|
2718 -- The status should never be False. But, if it is, what can we do?
|
|
|
2719 -- So, we don't test it.
|
|
|
2720
|
|
|
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);
|
|
|
2725 end Read_Source_File;
|
|
|
2726
|
|
|
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
|
|
|
2745
|
|
|
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
|
|
|
2752 if Path'Last >= Prefix'Last and then Path (Prefix'Range) = Prefix then
|
|
|
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
|
|
|
2766 -----------------
|
|
|
2767 -- Set_Program --
|
|
|
2768 -----------------
|
|
|
2769
|
|
|
2770 procedure Set_Program (P : Program_Type) is
|
|
|
2771 begin
|
|
|
2772 if Program_Set then
|
|
|
2773 Fail ("Set_Program called twice");
|
|
|
2774 end if;
|
|
|
2775
|
|
|
2776 Program_Set := True;
|
|
|
2777 Running_Program := P;
|
|
|
2778 end Set_Program;
|
|
|
2779
|
|
|
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;
|
|
|
2793 return Library;
|
|
|
2794 end Shared_Lib;
|
|
|
2795
|
|
|
2796 ----------------------
|
|
|
2797 -- Smart_File_Stamp --
|
|
|
2798 ----------------------
|
|
|
2799
|
|
|
2800 function Smart_File_Stamp
|
|
|
2801 (N : File_Name_Type;
|
|
|
2802 T : File_Type) return Time_Stamp_Type
|
|
|
2803 is
|
|
|
2804 File : File_Name_Type;
|
|
|
2805 Attr : aliased File_Attributes;
|
|
|
2806
|
|
|
2807 begin
|
|
|
2808 if not File_Cache_Enabled then
|
|
|
2809 Find_File (N, T, File, Attr'Access);
|
|
|
2810 else
|
|
|
2811 Smart_Find_File (N, T, File, Attr);
|
|
|
2812 end if;
|
|
|
2813
|
|
|
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;
|
|
|
2819 return
|
|
|
2820 OS_Time_To_GNAT_Time
|
|
|
2821 (File_Time_Stamp (Name_Buffer'Address, Attr'Access));
|
|
|
2822 end if;
|
|
|
2823 end Smart_File_Stamp;
|
|
|
2824
|
|
|
2825 ---------------------
|
|
|
2826 -- Smart_Find_File --
|
|
|
2827 ---------------------
|
|
|
2828
|
|
|
2829 function Smart_Find_File
|
|
|
2830 (N : File_Name_Type;
|
|
|
2831 T : File_Type) return File_Name_Type
|
|
|
2832 is
|
|
|
2833 File : File_Name_Type;
|
|
|
2834 Attr : File_Attributes;
|
|
|
2835 begin
|
|
|
2836 Smart_Find_File (N, T, File, Attr);
|
|
|
2837 return File;
|
|
|
2838 end Smart_Find_File;
|
|
|
2839
|
|
|
2840 ---------------------
|
|
|
2841 -- Smart_Find_File --
|
|
|
2842 ---------------------
|
|
|
2843
|
|
|
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);
|
|
|
2855
|
|
|
2856 else
|
|
|
2857 Info := File_Name_Hash_Table.Get (N);
|
|
|
2858
|
|
|
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;
|
|
|
2863 end if;
|
|
|
2864
|
|
|
2865 Found := Info.File;
|
|
|
2866 Attr := Info.Attr;
|
|
|
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
|
|
|
2895 for J in reverse 1 .. Name_Len - 1 loop
|
|
|
2896
|
|
|
2897 -- If we find the last directory separator
|
|
|
2898
|
|
|
2899 if Is_Directory_Separator (Name_Buffer (J)) then
|
|
|
2900
|
|
|
2901 -- Return part of Name that follows this last directory separator
|
|
|
2902
|
|
|
2903 Name_Buffer (1 .. Name_Len - J) := Name_Buffer (J + 1 .. Name_Len);
|
|
|
2904 Name_Len := Name_Len - J;
|
|
|
2905 return Name_Find;
|
|
|
2906 end if;
|
|
|
2907 end loop;
|
|
|
2908
|
|
|
2909 -- There were no directory separator, just return Name
|
|
|
2910
|
|
|
2911 return Name;
|
|
|
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
|
|
|
2922 for J in reverse 2 .. Name_Len loop
|
|
|
2923
|
|
|
2924 -- If we found the last '.', return part of Name that precedes it
|
|
|
2925
|
|
|
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
|
|
|
2935 ---------------------------
|
|
|
2936 -- To_Canonical_File_List --
|
|
|
2937 ---------------------------
|
|
|
2938
|
|
|
2939 function To_Canonical_File_List
|
|
|
2940 (Wildcard_Host_File : String;
|
|
|
2941 Only_Dirs : Boolean) return String_Access_List_Access
|
|
|
2942 is
|
|
|
2943 function To_Canonical_File_List_Init
|
|
|
2944 (Host_File : Address;
|
|
|
2945 Only_Dirs : Integer) return Integer;
|
|
|
2946 pragma Import (C, To_Canonical_File_List_Init,
|
|
|
2947 "__gnat_to_canonical_file_list_init");
|
|
|
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;
|
|
|
2973 Canonical_File_Len : CRTL.size_t;
|
|
|
2974
|
|
|
2975 begin
|
|
|
2976 -- Retrieve the expanded directory names and build the list
|
|
|
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
|
|
|
2993 ----------------------
|
|
|
2994 -- To_Host_Dir_Spec --
|
|
|
2995 ----------------------
|
|
|
2996
|
|
|
2997 function To_Host_Dir_Spec
|
|
|
2998 (Canonical_Dir : String;
|
|
|
2999 Prefix_Style : Boolean) return String_Access
|
|
|
3000 is
|
|
|
3001 function To_Host_Dir_Spec
|
|
|
3002 (Canonical_Dir : Address;
|
|
|
3003 Prefix_Flag : Integer) return Address;
|
|
|
3004 pragma Import (C, To_Host_Dir_Spec, "__gnat_to_host_dir_spec");
|
|
|
3005
|
|
|
3006 C_Canonical_Dir : String (1 .. Canonical_Dir'Length + 1);
|
|
|
3007 Host_Dir_Addr : Address;
|
|
|
3008 Host_Dir_Len : CRTL.size_t;
|
|
|
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
|
|
|
3028 -----------------------
|
|
|
3029 -- To_Host_File_Spec --
|
|
|
3030 -----------------------
|
|
|
3031
|
|
|
3032 function To_Host_File_Spec
|
|
|
3033 (Canonical_File : String) return String_Access
|
|
|
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;
|
|
|
3040 Host_File_Len : CRTL.size_t;
|
|
|
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;
|
|
|
3063 Path_Len : CRTL.size_t) return String_Access
|
|
|
3064 is
|
|
|
3065 subtype Path_String is String (1 .. Integer (Path_Len));
|
|
|
3066 type Path_String_Access is access Path_String;
|
|
|
3067
|
|
|
3068 function Address_To_Access is new
|
|
|
3069 Unchecked_Conversion (Source => Address,
|
|
|
3070 Target => Path_String_Access);
|
|
|
3071
|
|
|
3072 Path_Access : constant Path_String_Access :=
|
|
|
3073 Address_To_Access (Path_Addr);
|
|
|
3074
|
|
|
3075 Return_Val : String_Access;
|
|
|
3076
|
|
|
3077 begin
|
|
|
3078 Return_Val := new String (1 .. Integer (Path_Len));
|
|
|
3079
|
|
|
3080 for J in 1 .. Integer (Path_Len) loop
|
|
|
3081 Return_Val (J) := Path_Access (J);
|
|
|
3082 end loop;
|
|
|
3083
|
|
|
3084 return Return_Val;
|
|
|
3085 end To_Path_String_Access;
|
|
|
3086
|
|
|
3087 -----------------
|
|
|
3088 -- Update_Path --
|
|
|
3089 -----------------
|
|
|
3090
|
|
|
3091 function Update_Path (Path : String_Ptr) return String_Ptr is
|
|
|
3092
|
|
|
3093 function C_Update_Path (Path, Component : Address) return Address;
|
|
|
3094 pragma Import (C, C_Update_Path, "update_path");
|
|
|
3095
|
|
|
3096 In_Length : constant Integer := Path'Length;
|
|
|
3097 In_String : String (1 .. In_Length + 1);
|
|
|
3098 Component_Name : aliased String := "GCC" & ASCII.NUL;
|
|
|
3099 Result_Ptr : Address;
|
|
|
3100 Result_Length : CRTL.size_t;
|
|
|
3101 Out_String : String_Ptr;
|
|
|
3102
|
|
|
3103 begin
|
|
|
3104 In_String (1 .. In_Length) := Path.all;
|
|
|
3105 In_String (In_Length + 1) := ASCII.NUL;
|
|
|
3106 Result_Ptr := C_Update_Path (In_String'Address, Component_Name'Address);
|
|
|
3107 Result_Length := CRTL.strlen (Result_Ptr);
|
|
|
3108
|
|
|
3109 Out_String := new String (1 .. Integer (Result_Length));
|
|
|
3110 CRTL.strncpy (Out_String.all'Address, Result_Ptr, Result_Length);
|
|
|
3111 return Out_String;
|
|
|
3112 end Update_Path;
|
|
|
3113
|
|
|
3114 ----------------
|
|
|
3115 -- Write_Info --
|
|
|
3116 ----------------
|
|
|
3117
|
|
|
3118 procedure Write_Info (Info : String) is
|
|
|
3119 begin
|
|
|
3120 Write_With_Check (Info'Address, Info'Length);
|
|
|
3121 Write_With_Check (EOL'Address, 1);
|
|
|
3122 end Write_Info;
|
|
|
3123
|
|
|
3124 ------------------------
|
|
|
3125 -- Write_Program_Name --
|
|
|
3126 ------------------------
|
|
|
3127
|
|
|
3128 procedure Write_Program_Name is
|
|
|
3129 Save_Buffer : constant String (1 .. Name_Len) :=
|
|
|
3130 Name_Buffer (1 .. Name_Len);
|
|
|
3131
|
|
|
3132 begin
|
|
|
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;
|
|
|
3160 begin
|
|
|
3161 if N = Write (Output_FD, A, N) then
|
|
|
3162 return;
|
|
|
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
|
|
|
3174 ----------------------------
|
|
|
3175 -- Package Initialization --
|
|
|
3176 ----------------------------
|
|
|
3177
|
|
|
3178 procedure Reset_File_Attributes (Attr : System.Address);
|
|
|
3179 pragma Import (C, Reset_File_Attributes, "__gnat_reset_attributes");
|
|
|
3180
|
|
|
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
|
|
|
3196 Sizeof_File_Attributes : Integer;
|
|
|
3197 pragma Import (C, Sizeof_File_Attributes,
|
|
|
3198 "__gnat_size_of_file_attributes");
|
|
|
3199
|
|
|
3200 begin
|
|
|
3201 pragma Assert (Sizeof_File_Attributes <= File_Attributes_Size);
|
|
|
3202
|
|
|
3203 Reset_File_Attributes (Unknown_Attributes'Address);
|
|
|
3204
|
|
|
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
|
|
|
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'("");
|
|
|
3220
|
|
|
3221 Osint.Initialize;
|
|
|
3222 end Initialization;
|
|
|
3223
|
|
|
3224 end Osint;
|
