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