|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- M A K E _ U T I L --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
|
9 -- Copyright (C) 2004-2017, Free Software Foundation, Inc. --
|
|
|
10 -- --
|
|
|
11 -- GNAT is free software; you can redistribute it and/or modify it under --
|
|
|
12 -- terms of the GNU General Public License as published by the Free Soft- --
|
|
|
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
|
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
|
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
|
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
|
|
17 -- for more details. You should have received a copy of the GNU General --
|
|
|
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
|
|
|
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
|
|
|
20 -- --
|
|
|
21 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
23 -- --
|
|
|
24 ------------------------------------------------------------------------------
|
|
|
25
|
|
|
26 with Atree; use Atree;
|
|
|
27 with Debug;
|
|
|
28 with Errutil;
|
|
|
29 with Osint; use Osint;
|
|
|
30 with Output; use Output;
|
|
|
31 with Opt; use Opt;
|
|
|
32 with Table;
|
|
|
33
|
|
|
34 with Ada.Command_Line; use Ada.Command_Line;
|
|
|
35
|
|
|
36 with GNAT.Case_Util; use GNAT.Case_Util;
|
|
|
37 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
|
|
|
38 with GNAT.HTable;
|
|
|
39
|
|
|
40 package body Make_Util is
|
|
|
41
|
|
|
42 ---------
|
|
|
43 -- Add --
|
|
|
44 ---------
|
|
|
45
|
|
|
46 procedure Add
|
|
|
47 (Option : String_Access;
|
|
|
48 To : in out String_List_Access;
|
|
|
49 Last : in out Natural)
|
|
|
50 is
|
|
|
51 begin
|
|
|
52 if Last = To'Last then
|
|
|
53 declare
|
|
|
54 New_Options : constant String_List_Access :=
|
|
|
55 new String_List (1 .. To'Last * 2);
|
|
|
56
|
|
|
57 begin
|
|
|
58 New_Options (To'Range) := To.all;
|
|
|
59
|
|
|
60 -- Set all elements of the original options to null to avoid
|
|
|
61 -- deallocation of copies.
|
|
|
62
|
|
|
63 To.all := (others => null);
|
|
|
64
|
|
|
65 Free (To);
|
|
|
66 To := New_Options;
|
|
|
67 end;
|
|
|
68 end if;
|
|
|
69
|
|
|
70 Last := Last + 1;
|
|
|
71 To (Last) := Option;
|
|
|
72 end Add;
|
|
|
73
|
|
|
74 procedure Add
|
|
|
75 (Option : String;
|
|
|
76 To : in out String_List_Access;
|
|
|
77 Last : in out Natural)
|
|
|
78 is
|
|
|
79 begin
|
|
|
80 Add (Option => new String'(Option), To => To, Last => Last);
|
|
|
81 end Add;
|
|
|
82
|
|
|
83 -------------------------
|
|
|
84 -- Base_Name_Index_For --
|
|
|
85 -------------------------
|
|
|
86
|
|
|
87 function Base_Name_Index_For
|
|
|
88 (Main : String;
|
|
|
89 Main_Index : Int;
|
|
|
90 Index_Separator : Character) return File_Name_Type
|
|
|
91 is
|
|
|
92 Result : File_Name_Type;
|
|
|
93
|
|
|
94 begin
|
|
|
95 Name_Len := 0;
|
|
|
96 Add_Str_To_Name_Buffer (Base_Name (Main));
|
|
|
97
|
|
|
98 -- Remove the extension, if any, that is the last part of the base name
|
|
|
99 -- starting with a dot and following some characters.
|
|
|
100
|
|
|
101 for J in reverse 2 .. Name_Len loop
|
|
|
102 if Name_Buffer (J) = '.' then
|
|
|
103 Name_Len := J - 1;
|
|
|
104 exit;
|
|
|
105 end if;
|
|
|
106 end loop;
|
|
|
107
|
|
|
108 -- Add the index info, if index is different from 0
|
|
|
109
|
|
|
110 if Main_Index > 0 then
|
|
|
111 Add_Char_To_Name_Buffer (Index_Separator);
|
|
|
112
|
|
|
113 declare
|
|
|
114 Img : constant String := Main_Index'Img;
|
|
|
115 begin
|
|
|
116 Add_Str_To_Name_Buffer (Img (2 .. Img'Last));
|
|
|
117 end;
|
|
|
118 end if;
|
|
|
119
|
|
|
120 Result := Name_Find;
|
|
|
121 return Result;
|
|
|
122 end Base_Name_Index_For;
|
|
|
123
|
|
|
124 -----------------
|
|
|
125 -- Create_Name --
|
|
|
126 -----------------
|
|
|
127
|
|
|
128 function Create_Name (Name : String) return File_Name_Type is
|
|
|
129 begin
|
|
|
130 Name_Len := 0;
|
|
|
131 Add_Str_To_Name_Buffer (Name);
|
|
|
132 return Name_Find;
|
|
|
133 end Create_Name;
|
|
|
134
|
|
|
135 function Create_Name (Name : String) return Name_Id is
|
|
|
136 begin
|
|
|
137 Name_Len := 0;
|
|
|
138 Add_Str_To_Name_Buffer (Name);
|
|
|
139 return Name_Find;
|
|
|
140 end Create_Name;
|
|
|
141
|
|
|
142 function Create_Name (Name : String) return Path_Name_Type is
|
|
|
143 begin
|
|
|
144 Name_Len := 0;
|
|
|
145 Add_Str_To_Name_Buffer (Name);
|
|
|
146 return Name_Find;
|
|
|
147 end Create_Name;
|
|
|
148
|
|
|
149 ---------------------------
|
|
|
150 -- Ensure_Absolute_Path --
|
|
|
151 ---------------------------
|
|
|
152
|
|
|
153 procedure Ensure_Absolute_Path
|
|
|
154 (Switch : in out String_Access;
|
|
|
155 Parent : String;
|
|
|
156 Do_Fail : Fail_Proc;
|
|
|
157 For_Gnatbind : Boolean := False;
|
|
|
158 Including_Non_Switch : Boolean := True;
|
|
|
159 Including_RTS : Boolean := False)
|
|
|
160 is
|
|
|
161 begin
|
|
|
162 if Switch /= null then
|
|
|
163 declare
|
|
|
164 Sw : String (1 .. Switch'Length);
|
|
|
165 Start : Positive;
|
|
|
166
|
|
|
167 begin
|
|
|
168 Sw := Switch.all;
|
|
|
169
|
|
|
170 if Sw (1) = '-' then
|
|
|
171 if Sw'Length >= 3
|
|
|
172 and then (Sw (2) = 'I'
|
|
|
173 or else (not For_Gnatbind
|
|
|
174 and then (Sw (2) = 'L'
|
|
|
175 or else
|
|
|
176 Sw (2) = 'A')))
|
|
|
177 then
|
|
|
178 Start := 3;
|
|
|
179
|
|
|
180 if Sw = "-I-" then
|
|
|
181 return;
|
|
|
182 end if;
|
|
|
183
|
|
|
184 elsif Sw'Length >= 4
|
|
|
185 and then
|
|
|
186 (Sw (2 .. 3) = "aL" or else
|
|
|
187 Sw (2 .. 3) = "aO" or else
|
|
|
188 Sw (2 .. 3) = "aI"
|
|
|
189 or else (For_Gnatbind and then Sw (2 .. 3) = "A="))
|
|
|
190 then
|
|
|
191 Start := 4;
|
|
|
192
|
|
|
193 elsif Including_RTS
|
|
|
194 and then Sw'Length >= 7
|
|
|
195 and then Sw (2 .. 6) = "-RTS="
|
|
|
196 then
|
|
|
197 Start := 7;
|
|
|
198
|
|
|
199 else
|
|
|
200 return;
|
|
|
201 end if;
|
|
|
202
|
|
|
203 -- Because relative path arguments to --RTS= may be relative to
|
|
|
204 -- the search directory prefix, those relative path arguments
|
|
|
205 -- are converted only when they include directory information.
|
|
|
206
|
|
|
207 if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then
|
|
|
208 if Parent'Length = 0 then
|
|
|
209 Do_Fail
|
|
|
210 ("relative search path switches ("""
|
|
|
211 & Sw
|
|
|
212 & """) are not allowed");
|
|
|
213
|
|
|
214 elsif Including_RTS then
|
|
|
215 for J in Start .. Sw'Last loop
|
|
|
216 if Sw (J) = Directory_Separator then
|
|
|
217 Switch :=
|
|
|
218 new String'
|
|
|
219 (Sw (1 .. Start - 1)
|
|
|
220 & Parent
|
|
|
221 & Directory_Separator
|
|
|
222 & Sw (Start .. Sw'Last));
|
|
|
223 return;
|
|
|
224 end if;
|
|
|
225 end loop;
|
|
|
226
|
|
|
227 else
|
|
|
228 Switch :=
|
|
|
229 new String'
|
|
|
230 (Sw (1 .. Start - 1)
|
|
|
231 & Parent
|
|
|
232 & Directory_Separator
|
|
|
233 & Sw (Start .. Sw'Last));
|
|
|
234 end if;
|
|
|
235 end if;
|
|
|
236
|
|
|
237 elsif Including_Non_Switch then
|
|
|
238 if not Is_Absolute_Path (Sw) then
|
|
|
239 if Parent'Length = 0 then
|
|
|
240 Do_Fail
|
|
|
241 ("relative paths (""" & Sw & """) are not allowed");
|
|
|
242 else
|
|
|
243 Switch := new String'(Parent & Directory_Separator & Sw);
|
|
|
244 end if;
|
|
|
245 end if;
|
|
|
246 end if;
|
|
|
247 end;
|
|
|
248 end if;
|
|
|
249 end Ensure_Absolute_Path;
|
|
|
250
|
|
|
251 ----------------------------
|
|
|
252 -- Executable_Prefix_Path --
|
|
|
253 ----------------------------
|
|
|
254
|
|
|
255 function Executable_Prefix_Path return String is
|
|
|
256 Exec_Name : constant String := Command_Name;
|
|
|
257
|
|
|
258 function Get_Install_Dir (S : String) return String;
|
|
|
259 -- S is the executable name preceded by the absolute or relative path,
|
|
|
260 -- e.g. "c:\usr\bin\gcc.exe". Returns the absolute directory where "bin"
|
|
|
261 -- lies (in the example "C:\usr"). If the executable is not in a "bin"
|
|
|
262 -- directory, return "".
|
|
|
263
|
|
|
264 ---------------------
|
|
|
265 -- Get_Install_Dir --
|
|
|
266 ---------------------
|
|
|
267
|
|
|
268 function Get_Install_Dir (S : String) return String is
|
|
|
269 Exec : String := S;
|
|
|
270 Path_Last : Integer := 0;
|
|
|
271
|
|
|
272 begin
|
|
|
273 for J in reverse Exec'Range loop
|
|
|
274 if Exec (J) = Directory_Separator then
|
|
|
275 Path_Last := J - 1;
|
|
|
276 exit;
|
|
|
277 end if;
|
|
|
278 end loop;
|
|
|
279
|
|
|
280 if Path_Last >= Exec'First + 2 then
|
|
|
281 To_Lower (Exec (Path_Last - 2 .. Path_Last));
|
|
|
282 end if;
|
|
|
283
|
|
|
284 if Path_Last < Exec'First + 2
|
|
|
285 or else Exec (Path_Last - 2 .. Path_Last) /= "bin"
|
|
|
286 or else (Path_Last - 3 >= Exec'First
|
|
|
287 and then Exec (Path_Last - 3) /= Directory_Separator)
|
|
|
288 then
|
|
|
289 return "";
|
|
|
290 end if;
|
|
|
291
|
|
|
292 return Normalize_Pathname
|
|
|
293 (Exec (Exec'First .. Path_Last - 4),
|
|
|
294 Resolve_Links => Opt.Follow_Links_For_Dirs)
|
|
|
295 & Directory_Separator;
|
|
|
296 end Get_Install_Dir;
|
|
|
297
|
|
|
298 -- Beginning of Executable_Prefix_Path
|
|
|
299
|
|
|
300 begin
|
|
|
301 -- First determine if a path prefix was placed in front of the
|
|
|
302 -- executable name.
|
|
|
303
|
|
|
304 for J in reverse Exec_Name'Range loop
|
|
|
305 if Exec_Name (J) = Directory_Separator then
|
|
|
306 return Get_Install_Dir (Exec_Name);
|
|
|
307 end if;
|
|
|
308 end loop;
|
|
|
309
|
|
|
310 -- If we get here, the user has typed the executable name with no
|
|
|
311 -- directory prefix.
|
|
|
312
|
|
|
313 declare
|
|
|
314 Path : String_Access := Locate_Exec_On_Path (Exec_Name);
|
|
|
315 begin
|
|
|
316 if Path = null then
|
|
|
317 return "";
|
|
|
318 else
|
|
|
319 declare
|
|
|
320 Dir : constant String := Get_Install_Dir (Path.all);
|
|
|
321 begin
|
|
|
322 Free (Path);
|
|
|
323 return Dir;
|
|
|
324 end;
|
|
|
325 end if;
|
|
|
326 end;
|
|
|
327 end Executable_Prefix_Path;
|
|
|
328
|
|
|
329 ------------------
|
|
|
330 -- Fail_Program --
|
|
|
331 ------------------
|
|
|
332
|
|
|
333 procedure Fail_Program
|
|
|
334 (S : String;
|
|
|
335 Flush_Messages : Boolean := True)
|
|
|
336 is
|
|
|
337 begin
|
|
|
338 if Flush_Messages and not No_Exit_Message then
|
|
|
339 if Total_Errors_Detected /= 0 or else Warnings_Detected /= 0 then
|
|
|
340 Errutil.Finalize;
|
|
|
341 end if;
|
|
|
342 end if;
|
|
|
343
|
|
|
344 Finish_Program (E_Fatal, S => S);
|
|
|
345 end Fail_Program;
|
|
|
346
|
|
|
347 --------------------
|
|
|
348 -- Finish_Program --
|
|
|
349 --------------------
|
|
|
350
|
|
|
351 procedure Finish_Program
|
|
|
352 (Exit_Code : Osint.Exit_Code_Type := Osint.E_Success;
|
|
|
353 S : String := "")
|
|
|
354 is
|
|
|
355 begin
|
|
|
356 if S'Length > 0 then
|
|
|
357 if Exit_Code /= E_Success then
|
|
|
358 if No_Exit_Message then
|
|
|
359 Osint.Exit_Program (E_Fatal);
|
|
|
360 else
|
|
|
361 Osint.Fail (S);
|
|
|
362 end if;
|
|
|
363
|
|
|
364 elsif not No_Exit_Message then
|
|
|
365 Write_Str (S);
|
|
|
366 end if;
|
|
|
367 end if;
|
|
|
368
|
|
|
369 -- Output Namet statistics
|
|
|
370
|
|
|
371 Namet.Finalize;
|
|
|
372
|
|
|
373 Exit_Program (Exit_Code);
|
|
|
374 end Finish_Program;
|
|
|
375
|
|
|
376 ----------
|
|
|
377 -- Hash --
|
|
|
378 ----------
|
|
|
379
|
|
|
380 function Hash is new GNAT.HTable.Hash (Header_Num => Header_Num);
|
|
|
381 -- Used in implementation of other functions Hash below
|
|
|
382
|
|
|
383 ----------
|
|
|
384 -- Hash --
|
|
|
385 ----------
|
|
|
386
|
|
|
387 function Hash (Name : File_Name_Type) return Header_Num is
|
|
|
388 begin
|
|
|
389 return Hash (Get_Name_String (Name));
|
|
|
390 end Hash;
|
|
|
391
|
|
|
392 function Hash (Name : Name_Id) return Header_Num is
|
|
|
393 begin
|
|
|
394 return Hash (Get_Name_String (Name));
|
|
|
395 end Hash;
|
|
|
396
|
|
|
397 function Hash (Name : Path_Name_Type) return Header_Num is
|
|
|
398 begin
|
|
|
399 return Hash (Get_Name_String (Name));
|
|
|
400 end Hash;
|
|
|
401
|
|
|
402 ------------
|
|
|
403 -- Inform --
|
|
|
404 ------------
|
|
|
405
|
|
|
406 procedure Inform (N : File_Name_Type; Msg : String) is
|
|
|
407 begin
|
|
|
408 Inform (Name_Id (N), Msg);
|
|
|
409 end Inform;
|
|
|
410
|
|
|
411 procedure Inform (N : Name_Id := No_Name; Msg : String) is
|
|
|
412 begin
|
|
|
413 Osint.Write_Program_Name;
|
|
|
414
|
|
|
415 Write_Str (": ");
|
|
|
416
|
|
|
417 if N /= No_Name then
|
|
|
418 Write_Str ("""");
|
|
|
419
|
|
|
420 declare
|
|
|
421 Name : constant String := Get_Name_String (N);
|
|
|
422 begin
|
|
|
423 if Debug.Debug_Flag_F and then Is_Absolute_Path (Name) then
|
|
|
424 Write_Str (File_Name (Name));
|
|
|
425 else
|
|
|
426 Write_Str (Name);
|
|
|
427 end if;
|
|
|
428 end;
|
|
|
429
|
|
|
430 Write_Str (""" ");
|
|
|
431 end if;
|
|
|
432
|
|
|
433 Write_Str (Msg);
|
|
|
434 Write_Eol;
|
|
|
435 end Inform;
|
|
|
436
|
|
|
437 -----------
|
|
|
438 -- Mains --
|
|
|
439 -----------
|
|
|
440
|
|
|
441 package body Mains is
|
|
|
442
|
|
|
443 package Names is new Table.Table
|
|
|
444 (Table_Component_Type => Main_Info,
|
|
|
445 Table_Index_Type => Integer,
|
|
|
446 Table_Low_Bound => 1,
|
|
|
447 Table_Initial => 10,
|
|
|
448 Table_Increment => 100,
|
|
|
449 Table_Name => "Makeutl.Mains.Names");
|
|
|
450 -- The table that stores the mains
|
|
|
451
|
|
|
452 Current : Natural := 0;
|
|
|
453 -- The index of the last main retrieved from the table
|
|
|
454
|
|
|
455 Count_Of_Mains_With_No_Tree : Natural := 0;
|
|
|
456 -- Number of main units for which we do not know the project tree
|
|
|
457
|
|
|
458 --------------
|
|
|
459 -- Add_Main --
|
|
|
460 --------------
|
|
|
461
|
|
|
462 procedure Add_Main (Name : String; Index : Int := 0) is
|
|
|
463 begin
|
|
|
464 Name_Len := 0;
|
|
|
465 Add_Str_To_Name_Buffer (Name);
|
|
|
466 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
|
|
|
467
|
|
|
468 Names.Increment_Last;
|
|
|
469 Names.Table (Names.Last) := (Name_Find, Index);
|
|
|
470
|
|
|
471 Mains.Count_Of_Mains_With_No_Tree :=
|
|
|
472 Mains.Count_Of_Mains_With_No_Tree + 1;
|
|
|
473 end Add_Main;
|
|
|
474
|
|
|
475 ------------
|
|
|
476 -- Delete --
|
|
|
477 ------------
|
|
|
478
|
|
|
479 procedure Delete is
|
|
|
480 begin
|
|
|
481 Names.Set_Last (0);
|
|
|
482 Mains.Reset;
|
|
|
483 end Delete;
|
|
|
484
|
|
|
485 ---------------
|
|
|
486 -- Next_Main --
|
|
|
487 ---------------
|
|
|
488
|
|
|
489 function Next_Main return String is
|
|
|
490 Info : constant Main_Info := Next_Main;
|
|
|
491 begin
|
|
|
492 if Info = No_Main_Info then
|
|
|
493 return "";
|
|
|
494 else
|
|
|
495 return Get_Name_String (Info.File);
|
|
|
496 end if;
|
|
|
497 end Next_Main;
|
|
|
498
|
|
|
499 function Next_Main return Main_Info is
|
|
|
500 begin
|
|
|
501 if Current >= Names.Last then
|
|
|
502 return No_Main_Info;
|
|
|
503 else
|
|
|
504 Current := Current + 1;
|
|
|
505
|
|
|
506 declare
|
|
|
507 Orig_Main : constant File_Name_Type :=
|
|
|
508 Names.Table (Current).File;
|
|
|
509 Current_Main : File_Name_Type;
|
|
|
510
|
|
|
511 begin
|
|
|
512 if Strip_Suffix (Orig_Main) = Orig_Main then
|
|
|
513 Get_Name_String (Orig_Main);
|
|
|
514 Add_Str_To_Name_Buffer (".adb");
|
|
|
515 Current_Main := Name_Find;
|
|
|
516
|
|
|
517 if Full_Source_Name (Current_Main) = No_File then
|
|
|
518 Get_Name_String (Orig_Main);
|
|
|
519 Add_Str_To_Name_Buffer (".ads");
|
|
|
520 Current_Main := Name_Find;
|
|
|
521
|
|
|
522 if Full_Source_Name (Current_Main) /= No_File then
|
|
|
523 Names.Table (Current).File := Current_Main;
|
|
|
524 end if;
|
|
|
525
|
|
|
526 else
|
|
|
527 Names.Table (Current).File := Current_Main;
|
|
|
528 end if;
|
|
|
529 end if;
|
|
|
530 end;
|
|
|
531
|
|
|
532 return Names.Table (Current);
|
|
|
533 end if;
|
|
|
534 end Next_Main;
|
|
|
535
|
|
|
536 ---------------------
|
|
|
537 -- Number_Of_Mains --
|
|
|
538 ---------------------
|
|
|
539
|
|
|
540 function Number_Of_Mains return Natural is
|
|
|
541 begin
|
|
|
542 return Names.Last;
|
|
|
543 end Number_Of_Mains;
|
|
|
544
|
|
|
545 -----------
|
|
|
546 -- Reset --
|
|
|
547 -----------
|
|
|
548
|
|
|
549 procedure Reset is
|
|
|
550 begin
|
|
|
551 Current := 0;
|
|
|
552 end Reset;
|
|
|
553
|
|
|
554 --------------------------
|
|
|
555 -- Set_Multi_Unit_Index --
|
|
|
556 --------------------------
|
|
|
557
|
|
|
558 procedure Set_Multi_Unit_Index
|
|
|
559 (Index : Int := 0)
|
|
|
560 is
|
|
|
561 begin
|
|
|
562 if Index /= 0 then
|
|
|
563 if Names.Last = 0 then
|
|
|
564 Fail_Program
|
|
|
565 ("cannot specify a multi-unit index but no main "
|
|
|
566 & "on the command line");
|
|
|
567
|
|
|
568 elsif Names.Last > 1 then
|
|
|
569 Fail_Program
|
|
|
570 ("cannot specify several mains with a multi-unit index");
|
|
|
571
|
|
|
572 else
|
|
|
573 Names.Table (Names.Last).Index := Index;
|
|
|
574 end if;
|
|
|
575 end if;
|
|
|
576 end Set_Multi_Unit_Index;
|
|
|
577
|
|
|
578 end Mains;
|
|
|
579
|
|
|
580 -----------------------
|
|
|
581 -- Path_Or_File_Name --
|
|
|
582 -----------------------
|
|
|
583
|
|
|
584 function Path_Or_File_Name (Path : Path_Name_Type) return String is
|
|
|
585 Path_Name : constant String := Get_Name_String (Path);
|
|
|
586 begin
|
|
|
587 if Debug.Debug_Flag_F then
|
|
|
588 return File_Name (Path_Name);
|
|
|
589 else
|
|
|
590 return Path_Name;
|
|
|
591 end if;
|
|
|
592 end Path_Or_File_Name;
|
|
|
593
|
|
|
594 -------------------
|
|
|
595 -- Unit_Index_Of --
|
|
|
596 -------------------
|
|
|
597
|
|
|
598 function Unit_Index_Of (ALI_File : File_Name_Type) return Int is
|
|
|
599 Start : Natural;
|
|
|
600 Finish : Natural;
|
|
|
601 Result : Int := 0;
|
|
|
602
|
|
|
603 begin
|
|
|
604 Get_Name_String (ALI_File);
|
|
|
605
|
|
|
606 -- First, find the last dot
|
|
|
607
|
|
|
608 Finish := Name_Len;
|
|
|
609
|
|
|
610 while Finish >= 1 and then Name_Buffer (Finish) /= '.' loop
|
|
|
611 Finish := Finish - 1;
|
|
|
612 end loop;
|
|
|
613
|
|
|
614 if Finish = 1 then
|
|
|
615 return 0;
|
|
|
616 end if;
|
|
|
617
|
|
|
618 -- Now check that the dot is preceded by digits
|
|
|
619
|
|
|
620 Start := Finish;
|
|
|
621 Finish := Finish - 1;
|
|
|
622 while Start >= 1 and then Name_Buffer (Start - 1) in '0' .. '9' loop
|
|
|
623 Start := Start - 1;
|
|
|
624 end loop;
|
|
|
625
|
|
|
626 -- If there are no digits, or if the digits are not preceded by the
|
|
|
627 -- character that precedes a unit index, this is not the ALI file of
|
|
|
628 -- a unit in a multi-unit source.
|
|
|
629
|
|
|
630 if Start > Finish
|
|
|
631 or else Start = 1
|
|
|
632 or else Name_Buffer (Start - 1) /= Multi_Unit_Index_Character
|
|
|
633 then
|
|
|
634 return 0;
|
|
|
635 end if;
|
|
|
636
|
|
|
637 -- Build the index from the digit(s)
|
|
|
638
|
|
|
639 while Start <= Finish loop
|
|
|
640 Result := Result * 10 +
|
|
|
641 Character'Pos (Name_Buffer (Start)) - Character'Pos ('0');
|
|
|
642 Start := Start + 1;
|
|
|
643 end loop;
|
|
|
644
|
|
|
645 return Result;
|
|
|
646 end Unit_Index_Of;
|
|
|
647
|
|
|
648 -----------------
|
|
|
649 -- Verbose_Msg --
|
|
|
650 -----------------
|
|
|
651
|
|
|
652 procedure Verbose_Msg
|
|
|
653 (N1 : Name_Id;
|
|
|
654 S1 : String;
|
|
|
655 N2 : Name_Id := No_Name;
|
|
|
656 S2 : String := "";
|
|
|
657 Prefix : String := " -> ";
|
|
|
658 Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low)
|
|
|
659 is
|
|
|
660 begin
|
|
|
661 if not Opt.Verbose_Mode
|
|
|
662 or else Minimum_Verbosity > Opt.Verbosity_Level
|
|
|
663 then
|
|
|
664 return;
|
|
|
665 end if;
|
|
|
666
|
|
|
667 Write_Str (Prefix);
|
|
|
668 Write_Str ("""");
|
|
|
669 Write_Name (N1);
|
|
|
670 Write_Str (""" ");
|
|
|
671 Write_Str (S1);
|
|
|
672
|
|
|
673 if N2 /= No_Name then
|
|
|
674 Write_Str (" """);
|
|
|
675 Write_Name (N2);
|
|
|
676 Write_Str (""" ");
|
|
|
677 end if;
|
|
|
678
|
|
|
679 Write_Str (S2);
|
|
|
680 Write_Eol;
|
|
|
681 end Verbose_Msg;
|
|
|
682
|
|
|
683 procedure Verbose_Msg
|
|
|
684 (N1 : File_Name_Type;
|
|
|
685 S1 : String;
|
|
|
686 N2 : File_Name_Type := No_File;
|
|
|
687 S2 : String := "";
|
|
|
688 Prefix : String := " -> ";
|
|
|
689 Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low)
|
|
|
690 is
|
|
|
691 begin
|
|
|
692 Verbose_Msg
|
|
|
693 (Name_Id (N1), S1, Name_Id (N2), S2, Prefix, Minimum_Verbosity);
|
|
|
694 end Verbose_Msg;
|
|
|
695
|
|
|
696 -----------
|
|
|
697 -- Queue --
|
|
|
698 -----------
|
|
|
699
|
|
|
700 package body Queue is
|
|
|
701
|
|
|
702 type Q_Record is record
|
|
|
703 Info : Source_Info;
|
|
|
704 Processed : Boolean;
|
|
|
705 end record;
|
|
|
706
|
|
|
707 package Q is new Table.Table
|
|
|
708 (Table_Component_Type => Q_Record,
|
|
|
709 Table_Index_Type => Natural,
|
|
|
710 Table_Low_Bound => 1,
|
|
|
711 Table_Initial => 1000,
|
|
|
712 Table_Increment => 100,
|
|
|
713 Table_Name => "Makeutl.Queue.Q");
|
|
|
714 -- This is the actual Queue
|
|
|
715
|
|
|
716 type Mark_Key is record
|
|
|
717 File : File_Name_Type;
|
|
|
718 Index : Int;
|
|
|
719 end record;
|
|
|
720 -- Identify either a mono-unit source (when Index = 0) or a specific
|
|
|
721 -- unit (index = 1's origin index of unit) in a multi-unit source.
|
|
|
722
|
|
|
723 Max_Mask_Num : constant := 2048;
|
|
|
724 subtype Mark_Num is Union_Id range 0 .. Max_Mask_Num - 1;
|
|
|
725
|
|
|
726 function Hash (Key : Mark_Key) return Mark_Num;
|
|
|
727
|
|
|
728 package Marks is new GNAT.HTable.Simple_HTable
|
|
|
729 (Header_Num => Mark_Num,
|
|
|
730 Element => Boolean,
|
|
|
731 No_Element => False,
|
|
|
732 Key => Mark_Key,
|
|
|
733 Hash => Hash,
|
|
|
734 Equal => "=");
|
|
|
735 -- A hash table to keep tracks of the marked units.
|
|
|
736 -- These are the units that have already been processed, when using the
|
|
|
737 -- gnatmake format. When using the gprbuild format, we can directly
|
|
|
738 -- store in the source_id whether the file has already been processed.
|
|
|
739
|
|
|
740 procedure Mark (Source_File : File_Name_Type; Index : Int := 0);
|
|
|
741 -- Mark a unit, identified by its source file and, when Index is not 0,
|
|
|
742 -- the index of the unit in the source file. Marking is used to signal
|
|
|
743 -- that the unit has already been inserted in the Q.
|
|
|
744
|
|
|
745 function Is_Marked
|
|
|
746 (Source_File : File_Name_Type;
|
|
|
747 Index : Int := 0) return Boolean;
|
|
|
748 -- Returns True if the unit was previously marked
|
|
|
749
|
|
|
750 Q_Processed : Natural := 0;
|
|
|
751 Q_Initialized : Boolean := False;
|
|
|
752
|
|
|
753 Q_First : Natural := 1;
|
|
|
754 -- Points to the first valid element in the queue
|
|
|
755
|
|
|
756 procedure Debug_Display (S : Source_Info);
|
|
|
757 -- A debug display for S
|
|
|
758
|
|
|
759 function Was_Processed (S : Source_Info) return Boolean;
|
|
|
760 -- Whether S has already been processed. This marks the source as
|
|
|
761 -- processed, if it hasn't already been processed.
|
|
|
762
|
|
|
763 -------------------
|
|
|
764 -- Was_Processed --
|
|
|
765 -------------------
|
|
|
766
|
|
|
767 function Was_Processed (S : Source_Info) return Boolean is
|
|
|
768 begin
|
|
|
769 if Is_Marked (S.File, S.Index) then
|
|
|
770 return True;
|
|
|
771 end if;
|
|
|
772
|
|
|
773 Mark (S.File, Index => S.Index);
|
|
|
774
|
|
|
775 return False;
|
|
|
776 end Was_Processed;
|
|
|
777
|
|
|
778 -------------------
|
|
|
779 -- Debug_Display --
|
|
|
780 -------------------
|
|
|
781
|
|
|
782 procedure Debug_Display (S : Source_Info) is
|
|
|
783 begin
|
|
|
784 Write_Name (S.File);
|
|
|
785
|
|
|
786 if S.Index /= 0 then
|
|
|
787 Write_Str (", ");
|
|
|
788 Write_Int (S.Index);
|
|
|
789 end if;
|
|
|
790 end Debug_Display;
|
|
|
791
|
|
|
792 ----------
|
|
|
793 -- Hash --
|
|
|
794 ----------
|
|
|
795
|
|
|
796 function Hash (Key : Mark_Key) return Mark_Num is
|
|
|
797 begin
|
|
|
798 return Union_Id (Key.File) mod Max_Mask_Num;
|
|
|
799 end Hash;
|
|
|
800
|
|
|
801 ---------------
|
|
|
802 -- Is_Marked --
|
|
|
803 ---------------
|
|
|
804
|
|
|
805 function Is_Marked
|
|
|
806 (Source_File : File_Name_Type;
|
|
|
807 Index : Int := 0) return Boolean
|
|
|
808 is
|
|
|
809 begin
|
|
|
810 return Marks.Get (K => (File => Source_File, Index => Index));
|
|
|
811 end Is_Marked;
|
|
|
812
|
|
|
813 ----------
|
|
|
814 -- Mark --
|
|
|
815 ----------
|
|
|
816
|
|
|
817 procedure Mark (Source_File : File_Name_Type; Index : Int := 0) is
|
|
|
818 begin
|
|
|
819 Marks.Set (K => (File => Source_File, Index => Index), E => True);
|
|
|
820 end Mark;
|
|
|
821
|
|
|
822 -------------
|
|
|
823 -- Extract --
|
|
|
824 -------------
|
|
|
825
|
|
|
826 procedure Extract
|
|
|
827 (Found : out Boolean;
|
|
|
828 Source : out Source_Info)
|
|
|
829 is
|
|
|
830 begin
|
|
|
831 Found := False;
|
|
|
832
|
|
|
833 if Q_First <= Q.Last then
|
|
|
834 Source := Q.Table (Q_First).Info;
|
|
|
835 Q.Table (Q_First).Processed := True;
|
|
|
836 Q_First := Q_First + 1;
|
|
|
837 Found := True;
|
|
|
838 end if;
|
|
|
839
|
|
|
840 if Found then
|
|
|
841 Q_Processed := Q_Processed + 1;
|
|
|
842 end if;
|
|
|
843
|
|
|
844 if Found and then Debug.Debug_Flag_Q then
|
|
|
845 Write_Str (" Q := Q - [ ");
|
|
|
846 Debug_Display (Source);
|
|
|
847 Write_Str (" ]");
|
|
|
848 Write_Eol;
|
|
|
849
|
|
|
850 Write_Str (" Q_First =");
|
|
|
851 Write_Int (Int (Q_First));
|
|
|
852 Write_Eol;
|
|
|
853
|
|
|
854 Write_Str (" Q.Last =");
|
|
|
855 Write_Int (Int (Q.Last));
|
|
|
856 Write_Eol;
|
|
|
857 end if;
|
|
|
858 end Extract;
|
|
|
859
|
|
|
860 ---------------
|
|
|
861 -- Processed --
|
|
|
862 ---------------
|
|
|
863
|
|
|
864 function Processed return Natural is
|
|
|
865 begin
|
|
|
866 return Q_Processed;
|
|
|
867 end Processed;
|
|
|
868
|
|
|
869 ----------------
|
|
|
870 -- Initialize --
|
|
|
871 ----------------
|
|
|
872
|
|
|
873 procedure Initialize (Force : Boolean := False) is
|
|
|
874 begin
|
|
|
875 if Force or else not Q_Initialized then
|
|
|
876 Q_Initialized := True;
|
|
|
877 Q.Init;
|
|
|
878 Q_Processed := 0;
|
|
|
879 Q_First := 1;
|
|
|
880 end if;
|
|
|
881 end Initialize;
|
|
|
882
|
|
|
883 ------------
|
|
|
884 -- Insert --
|
|
|
885 ------------
|
|
|
886
|
|
|
887 function Insert (Source : Source_Info) return Boolean is
|
|
|
888 begin
|
|
|
889 -- Only insert in the Q if it is not already done, to avoid
|
|
|
890 -- simultaneous compilations if -jnnn is used.
|
|
|
891
|
|
|
892 if Was_Processed (Source) then
|
|
|
893 return False;
|
|
|
894 end if;
|
|
|
895
|
|
|
896 Q.Append (New_Val => (Info => Source, Processed => False));
|
|
|
897
|
|
|
898 if Debug.Debug_Flag_Q then
|
|
|
899 Write_Str (" Q := Q + [ ");
|
|
|
900 Debug_Display (Source);
|
|
|
901 Write_Str (" ] ");
|
|
|
902 Write_Eol;
|
|
|
903
|
|
|
904 Write_Str (" Q_First =");
|
|
|
905 Write_Int (Int (Q_First));
|
|
|
906 Write_Eol;
|
|
|
907
|
|
|
908 Write_Str (" Q.Last =");
|
|
|
909 Write_Int (Int (Q.Last));
|
|
|
910 Write_Eol;
|
|
|
911 end if;
|
|
|
912
|
|
|
913 return True;
|
|
|
914 end Insert;
|
|
|
915
|
|
|
916 procedure Insert (Source : Source_Info) is
|
|
|
917 Discard : Boolean;
|
|
|
918 begin
|
|
|
919 Discard := Insert (Source);
|
|
|
920 end Insert;
|
|
|
921
|
|
|
922 --------------
|
|
|
923 -- Is_Empty --
|
|
|
924 --------------
|
|
|
925
|
|
|
926 function Is_Empty return Boolean is
|
|
|
927 begin
|
|
|
928 return Q_Processed >= Q.Last;
|
|
|
929 end Is_Empty;
|
|
|
930
|
|
|
931 ----------
|
|
|
932 -- Size --
|
|
|
933 ----------
|
|
|
934
|
|
|
935 function Size return Natural is
|
|
|
936 begin
|
|
|
937 return Q.Last;
|
|
|
938 end Size;
|
|
|
939
|
|
|
940 -------------
|
|
|
941 -- Element --
|
|
|
942 -------------
|
|
|
943
|
|
|
944 function Element (Rank : Positive) return File_Name_Type is
|
|
|
945 begin
|
|
|
946 if Rank <= Q.Last then
|
|
|
947 return Q.Table (Rank).Info.File;
|
|
|
948 else
|
|
|
949 return No_File;
|
|
|
950 end if;
|
|
|
951 end Element;
|
|
|
952
|
|
|
953 ------------------
|
|
|
954 -- Remove_Marks --
|
|
|
955 ------------------
|
|
|
956
|
|
|
957 procedure Remove_Marks is
|
|
|
958 begin
|
|
|
959 Marks.Reset;
|
|
|
960 end Remove_Marks;
|
|
|
961
|
|
|
962 end Queue;
|
|
|
963
|
|
|
964 end Make_Util;
|
