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