]>
Commit | Line | Data |
---|---|---|
8f9df7d8 VC |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- M A K E U T L -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
c0e538ad | 9 | -- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- |
8f9df7d8 VC |
10 | -- -- |
11 | -- GNAT is free software; you can redistribute it and/or modify it under -- | |
12 | -- terms of the GNU General Public License as published by the Free Soft- -- | |
b5c84c3c | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
8f9df7d8 VC |
14 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
15 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- | |
16 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- | |
17 | -- for more details. You should have received a copy of the GNU General -- | |
b5c84c3c RD |
18 | -- Public License distributed with GNAT; see file COPYING3. If not, go to -- |
19 | -- http://www.gnu.org/licenses for a complete copy of the license. -- | |
8f9df7d8 VC |
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 | ||
38990220 | 26 | with ALI; use ALI; |
7d903840 | 27 | with Debug; |
fccd42a9 AC |
28 | with Err_Vars; use Err_Vars; |
29 | with Errutil; | |
fdfcc663 | 30 | with Fname; |
88b17d45 | 31 | with Hostparm; |
5950a3ac | 32 | with Osint; use Osint; |
2cd44f5a | 33 | with Output; use Output; |
f7e71125 | 34 | with Opt; use Opt; |
4fdebd93 | 35 | with Prj.Err; |
8f9df7d8 | 36 | with Prj.Ext; |
9434c32e | 37 | with Prj.Util; use Prj.Util; |
fccd42a9 | 38 | with Sinput.P; |
5950a3ac | 39 | with Snames; use Snames; |
8f9df7d8 | 40 | with Table; |
a113c55d | 41 | with Tempdir; |
8f9df7d8 | 42 | |
2c1b72d7 AC |
43 | with Ada.Command_Line; use Ada.Command_Line; |
44 | with Ada.Unchecked_Deallocation; | |
e917aec2 | 45 | |
2c1b72d7 AC |
46 | with GNAT.Case_Util; use GNAT.Case_Util; |
47 | with GNAT.Directory_Operations; use GNAT.Directory_Operations; | |
e917aec2 | 48 | with GNAT.HTable; |
2c1b72d7 | 49 | with GNAT.Regexp; use GNAT.Regexp; |
e917aec2 | 50 | |
8f9df7d8 VC |
51 | package body Makeutl is |
52 | ||
53 | type Linker_Options_Data is record | |
54 | Project : Project_Id; | |
55 | Options : String_List_Id; | |
56 | end record; | |
57 | ||
58 | Linker_Option_Initial_Count : constant := 20; | |
59 | ||
60 | Linker_Options_Buffer : String_List_Access := | |
61 | new String_List (1 .. Linker_Option_Initial_Count); | |
62 | ||
63 | Last_Linker_Option : Natural := 0; | |
64 | ||
65 | package Linker_Opts is new Table.Table ( | |
66 | Table_Component_Type => Linker_Options_Data, | |
67 | Table_Index_Type => Integer, | |
68 | Table_Low_Bound => 1, | |
69 | Table_Initial => 10, | |
70 | Table_Increment => 100, | |
71 | Table_Name => "Make.Linker_Opts"); | |
72 | ||
73 | procedure Add_Linker_Option (Option : String); | |
74 | ||
2cd44f5a VC |
75 | --------- |
76 | -- Add -- | |
77 | --------- | |
78 | ||
79 | procedure Add | |
80 | (Option : String_Access; | |
81 | To : in out String_List_Access; | |
82 | Last : in out Natural) | |
83 | is | |
84 | begin | |
85 | if Last = To'Last then | |
86 | declare | |
87 | New_Options : constant String_List_Access := | |
88 | new String_List (1 .. To'Last * 2); | |
74744c7b | 89 | |
2cd44f5a VC |
90 | begin |
91 | New_Options (To'Range) := To.all; | |
92 | ||
93 | -- Set all elements of the original options to null to avoid | |
94 | -- deallocation of copies. | |
95 | ||
96 | To.all := (others => null); | |
97 | ||
98 | Free (To); | |
99 | To := New_Options; | |
100 | end; | |
101 | end if; | |
102 | ||
103 | Last := Last + 1; | |
104 | To (Last) := Option; | |
105 | end Add; | |
106 | ||
107 | procedure Add | |
108 | (Option : String; | |
109 | To : in out String_List_Access; | |
110 | Last : in out Natural) | |
111 | is | |
112 | begin | |
113 | Add (Option => new String'(Option), To => To, Last => Last); | |
114 | end Add; | |
115 | ||
8f9df7d8 VC |
116 | ----------------------- |
117 | -- Add_Linker_Option -- | |
118 | ----------------------- | |
119 | ||
120 | procedure Add_Linker_Option (Option : String) is | |
121 | begin | |
122 | if Option'Length > 0 then | |
123 | if Last_Linker_Option = Linker_Options_Buffer'Last then | |
124 | declare | |
125 | New_Buffer : constant String_List_Access := | |
5950a3ac AC |
126 | new String_List |
127 | (1 .. Linker_Options_Buffer'Last + | |
128 | Linker_Option_Initial_Count); | |
8f9df7d8 VC |
129 | begin |
130 | New_Buffer (Linker_Options_Buffer'Range) := | |
131 | Linker_Options_Buffer.all; | |
132 | Linker_Options_Buffer.all := (others => null); | |
133 | Free (Linker_Options_Buffer); | |
134 | Linker_Options_Buffer := New_Buffer; | |
135 | end; | |
136 | end if; | |
137 | ||
138 | Last_Linker_Option := Last_Linker_Option + 1; | |
139 | Linker_Options_Buffer (Last_Linker_Option) := new String'(Option); | |
140 | end if; | |
141 | end Add_Linker_Option; | |
142 | ||
c9df623a AC |
143 | ------------------------- |
144 | -- Base_Name_Index_For -- | |
145 | ------------------------- | |
146 | ||
147 | function Base_Name_Index_For | |
148 | (Main : String; | |
149 | Main_Index : Int; | |
150 | Index_Separator : Character) return File_Name_Type | |
151 | is | |
152 | Result : File_Name_Type; | |
c8c41617 | 153 | |
c9df623a AC |
154 | begin |
155 | Name_Len := 0; | |
156 | Add_Str_To_Name_Buffer (Base_Name (Main)); | |
157 | ||
c8c41617 RD |
158 | -- Remove the extension, if any, that is the last part of the base name |
159 | -- starting with a dot and following some characters. | |
c9df623a AC |
160 | |
161 | for J in reverse 2 .. Name_Len loop | |
162 | if Name_Buffer (J) = '.' then | |
163 | Name_Len := J - 1; | |
164 | exit; | |
165 | end if; | |
166 | end loop; | |
167 | ||
168 | -- Add the index info, if index is different from 0 | |
169 | ||
170 | if Main_Index > 0 then | |
171 | Add_Char_To_Name_Buffer (Index_Separator); | |
172 | ||
173 | declare | |
174 | Img : constant String := Main_Index'Img; | |
175 | begin | |
176 | Add_Str_To_Name_Buffer (Img (2 .. Img'Last)); | |
177 | end; | |
178 | end if; | |
c8c41617 | 179 | |
c9df623a AC |
180 | Result := Name_Find; |
181 | return Result; | |
182 | end Base_Name_Index_For; | |
183 | ||
38990220 EB |
184 | ------------------------------ |
185 | -- Check_Source_Info_In_ALI -- | |
186 | ------------------------------ | |
187 | ||
72e9f2b9 | 188 | function Check_Source_Info_In_ALI |
f9ad6b62 AC |
189 | (The_ALI : ALI_Id; |
190 | Tree : Project_Tree_Ref) return Boolean | |
72e9f2b9 | 191 | is |
38990220 | 192 | Unit_Name : Name_Id; |
8d12c865 | 193 | |
38990220 | 194 | begin |
8d12c865 RD |
195 | -- Loop through units |
196 | ||
197 | for U in ALIs.Table (The_ALI).First_Unit .. | |
198 | ALIs.Table (The_ALI).Last_Unit | |
38990220 | 199 | loop |
8d12c865 | 200 | -- Check if the file name is one of the source of the unit |
38990220 EB |
201 | |
202 | Get_Name_String (Units.Table (U).Uname); | |
203 | Name_Len := Name_Len - 2; | |
204 | Unit_Name := Name_Find; | |
205 | ||
98c99a5a | 206 | if File_Not_A_Source_Of (Tree, Unit_Name, Units.Table (U).Sfile) then |
38990220 EB |
207 | return False; |
208 | end if; | |
209 | ||
8d12c865 | 210 | -- Loop to do same check for each of the withed units |
38990220 | 211 | |
38990220 EB |
212 | for W in Units.Table (U).First_With .. Units.Table (U).Last_With loop |
213 | declare | |
214 | WR : ALI.With_Record renames Withs.Table (W); | |
8d12c865 | 215 | |
38990220 EB |
216 | begin |
217 | if WR.Sfile /= No_File then | |
218 | Get_Name_String (WR.Uname); | |
219 | Name_Len := Name_Len - 2; | |
220 | Unit_Name := Name_Find; | |
221 | ||
98c99a5a | 222 | if File_Not_A_Source_Of (Tree, Unit_Name, WR.Sfile) then |
38990220 EB |
223 | return False; |
224 | end if; | |
225 | end if; | |
226 | end; | |
8d12c865 RD |
227 | end loop; |
228 | end loop; | |
38990220 | 229 | |
72e9f2b9 | 230 | -- Loop to check subunits and replaced sources |
38990220 | 231 | |
8d12c865 RD |
232 | for D in ALIs.Table (The_ALI).First_Sdep .. |
233 | ALIs.Table (The_ALI).Last_Sdep | |
38990220 EB |
234 | loop |
235 | declare | |
236 | SD : Sdep_Record renames Sdep.Table (D); | |
8d12c865 | 237 | |
38990220 EB |
238 | begin |
239 | Unit_Name := SD.Subunit_Name; | |
240 | ||
72e9f2b9 AC |
241 | if Unit_Name = No_Name then |
242 | -- Check if this source file has been replaced by a source with | |
243 | -- a different file name. | |
244 | ||
245 | if Tree /= null and then Tree.Replaced_Source_Number > 0 then | |
246 | declare | |
247 | Replacement : constant File_Name_Type := | |
248 | Replaced_Source_HTable.Get | |
249 | (Tree.Replaced_Sources, SD.Sfile); | |
250 | ||
251 | begin | |
252 | if Replacement /= No_File then | |
253 | if Verbose_Mode then | |
254 | Write_Line | |
255 | ("source file" & | |
256 | Get_Name_String (SD.Sfile) & | |
257 | " has been replaced by " & | |
258 | Get_Name_String (Replacement)); | |
259 | end if; | |
260 | ||
261 | return False; | |
262 | end if; | |
263 | end; | |
264 | end if; | |
8d12c865 | 265 | |
72e9f2b9 | 266 | else |
38990220 | 267 | -- For separates, the file is no longer associated with the |
fdfcc663 AC |
268 | -- unit ("proc-sep.adb" is not associated with unit "proc.sep") |
269 | -- so we need to check whether the source file still exists in | |
38990220 EB |
270 | -- the source tree: it will if it matches the naming scheme |
271 | -- (and then will be for the same unit). | |
272 | ||
273 | if Find_Source | |
98c99a5a | 274 | (In_Tree => Tree, |
76b84bf0 AC |
275 | Project => No_Project, |
276 | Base_Name => SD.Sfile) = No_Source | |
38990220 | 277 | then |
fdfcc663 AC |
278 | -- If this is not a runtime file or if, when gnatmake switch |
279 | -- -a is used, we are not able to find this subunit in the | |
280 | -- source directories, then recompilation is needed. | |
281 | ||
282 | if not Fname.Is_Internal_File_Name (SD.Sfile) | |
283 | or else | |
76b84bf0 | 284 | (Check_Readonly_Files |
c5fdd4ad | 285 | and then Full_Source_Name (SD.Sfile) = No_File) |
38990220 EB |
286 | then |
287 | if Verbose_Mode then | |
288 | Write_Line | |
fdfcc663 | 289 | ("While parsing ALI file, file " |
38990220 | 290 | & Get_Name_String (SD.Sfile) |
fdfcc663 AC |
291 | & " is indicated as containing subunit " |
292 | & Get_Name_String (Unit_Name) | |
38990220 EB |
293 | & " but this does not match what was found while" |
294 | & " parsing the project. Will recompile"); | |
295 | end if; | |
76b84bf0 | 296 | |
38990220 EB |
297 | return False; |
298 | end if; | |
299 | end if; | |
300 | end if; | |
301 | end; | |
8d12c865 | 302 | end loop; |
38990220 EB |
303 | |
304 | return True; | |
305 | end Check_Source_Info_In_ALI; | |
306 | ||
a113c55d AC |
307 | -------------------------------- |
308 | -- Create_Binder_Mapping_File -- | |
309 | -------------------------------- | |
310 | ||
98c99a5a AC |
311 | function Create_Binder_Mapping_File |
312 | (Project_Tree : Project_Tree_Ref) return Path_Name_Type | |
313 | is | |
a113c55d AC |
314 | Mapping_Path : Path_Name_Type := No_Path; |
315 | ||
316 | Mapping_FD : File_Descriptor := Invalid_FD; | |
317 | -- A File Descriptor for an eventual mapping file | |
318 | ||
319 | ALI_Unit : Unit_Name_Type := No_Unit_Name; | |
320 | -- The unit name of an ALI file | |
321 | ||
322 | ALI_Name : File_Name_Type := No_File; | |
323 | -- The file name of the ALI file | |
324 | ||
325 | ALI_Project : Project_Id := No_Project; | |
326 | -- The project of the ALI file | |
327 | ||
328 | Bytes : Integer; | |
329 | OK : Boolean := False; | |
330 | Unit : Unit_Index; | |
331 | ||
332 | Status : Boolean; | |
333 | -- For call to Close | |
334 | ||
335 | begin | |
336 | Tempdir.Create_Temp_File (Mapping_FD, Mapping_Path); | |
98c99a5a | 337 | Record_Temp_File (Project_Tree.Shared, Mapping_Path); |
a113c55d AC |
338 | |
339 | if Mapping_FD /= Invalid_FD then | |
340 | OK := True; | |
341 | ||
342 | -- Traverse all units | |
343 | ||
344 | Unit := Units_Htable.Get_First (Project_Tree.Units_HT); | |
345 | while Unit /= No_Unit_Index loop | |
346 | if Unit.Name /= No_Name then | |
347 | ||
348 | -- If there is a body, put it in the mapping | |
349 | ||
350 | if Unit.File_Names (Impl) /= No_Source | |
351 | and then Unit.File_Names (Impl).Project /= No_Project | |
352 | then | |
353 | Get_Name_String (Unit.Name); | |
354 | Add_Str_To_Name_Buffer ("%b"); | |
355 | ALI_Unit := Name_Find; | |
356 | ALI_Name := | |
357 | Lib_File_Name (Unit.File_Names (Impl).Display_File); | |
358 | ALI_Project := Unit.File_Names (Impl).Project; | |
359 | ||
360 | -- Otherwise, if there is a spec, put it in the mapping | |
361 | ||
362 | elsif Unit.File_Names (Spec) /= No_Source | |
363 | and then Unit.File_Names (Spec).Project /= No_Project | |
364 | then | |
365 | Get_Name_String (Unit.Name); | |
366 | Add_Str_To_Name_Buffer ("%s"); | |
367 | ALI_Unit := Name_Find; | |
368 | ALI_Name := | |
369 | Lib_File_Name (Unit.File_Names (Spec).Display_File); | |
370 | ALI_Project := Unit.File_Names (Spec).Project; | |
371 | ||
372 | else | |
373 | ALI_Name := No_File; | |
374 | end if; | |
375 | ||
376 | -- If we have something to put in the mapping then do it now. | |
377 | -- However, if the project is extended, we don't put anything | |
378 | -- in the mapping file, since we don't know where the ALI file | |
379 | -- is: it might be in the extended project object directory as | |
380 | -- well as in the extending project object directory. | |
381 | ||
382 | if ALI_Name /= No_File | |
383 | and then ALI_Project.Extended_By = No_Project | |
384 | and then ALI_Project.Extends = No_Project | |
385 | then | |
386 | -- First check if the ALI file exists. If it does not, do | |
387 | -- not put the unit in the mapping file. | |
388 | ||
389 | declare | |
390 | ALI : constant String := Get_Name_String (ALI_Name); | |
391 | ||
392 | begin | |
393 | -- For library projects, use the library ALI directory, | |
394 | -- for other projects, use the object directory. | |
395 | ||
396 | if ALI_Project.Library then | |
397 | Get_Name_String | |
398 | (ALI_Project.Library_ALI_Dir.Display_Name); | |
399 | else | |
400 | Get_Name_String | |
401 | (ALI_Project.Object_Directory.Display_Name); | |
402 | end if; | |
403 | ||
a113c55d AC |
404 | Add_Str_To_Name_Buffer (ALI); |
405 | Add_Char_To_Name_Buffer (ASCII.LF); | |
406 | ||
407 | declare | |
408 | ALI_Path_Name : constant String := | |
23685ae6 | 409 | Name_Buffer (1 .. Name_Len); |
a113c55d AC |
410 | |
411 | begin | |
412 | if Is_Regular_File | |
413 | (ALI_Path_Name (1 .. ALI_Path_Name'Last - 1)) | |
414 | then | |
415 | -- First line is the unit name | |
416 | ||
417 | Get_Name_String (ALI_Unit); | |
418 | Add_Char_To_Name_Buffer (ASCII.LF); | |
419 | Bytes := | |
420 | Write | |
421 | (Mapping_FD, | |
422 | Name_Buffer (1)'Address, | |
423 | Name_Len); | |
424 | OK := Bytes = Name_Len; | |
425 | ||
426 | exit when not OK; | |
427 | ||
428 | -- Second line it the ALI file name | |
429 | ||
430 | Get_Name_String (ALI_Name); | |
431 | Add_Char_To_Name_Buffer (ASCII.LF); | |
432 | Bytes := | |
433 | Write | |
434 | (Mapping_FD, | |
435 | Name_Buffer (1)'Address, | |
436 | Name_Len); | |
437 | OK := (Bytes = Name_Len); | |
438 | ||
439 | exit when not OK; | |
440 | ||
441 | -- Third line it the ALI path name | |
442 | ||
443 | Bytes := | |
444 | Write | |
445 | (Mapping_FD, | |
446 | ALI_Path_Name (1)'Address, | |
447 | ALI_Path_Name'Length); | |
448 | OK := (Bytes = ALI_Path_Name'Length); | |
449 | ||
450 | -- If OK is False, it means we were unable to | |
451 | -- write a line. No point in continuing with the | |
452 | -- other units. | |
453 | ||
454 | exit when not OK; | |
455 | end if; | |
456 | end; | |
457 | end; | |
458 | end if; | |
459 | end if; | |
460 | ||
461 | Unit := Units_Htable.Get_Next (Project_Tree.Units_HT); | |
462 | end loop; | |
463 | ||
464 | Close (Mapping_FD, Status); | |
465 | ||
466 | OK := OK and Status; | |
467 | end if; | |
468 | ||
469 | -- If the creation of the mapping file was successful, we add the switch | |
470 | -- to the arguments of gnatbind. | |
471 | ||
472 | if OK then | |
473 | return Mapping_Path; | |
474 | ||
475 | else | |
476 | return No_Path; | |
477 | end if; | |
478 | end Create_Binder_Mapping_File; | |
479 | ||
2cd44f5a VC |
480 | ----------------- |
481 | -- Create_Name -- | |
482 | ----------------- | |
483 | ||
484 | function Create_Name (Name : String) return File_Name_Type is | |
485 | begin | |
486 | Name_Len := 0; | |
487 | Add_Str_To_Name_Buffer (Name); | |
488 | return Name_Find; | |
489 | end Create_Name; | |
490 | ||
491 | function Create_Name (Name : String) return Name_Id is | |
492 | begin | |
493 | Name_Len := 0; | |
494 | Add_Str_To_Name_Buffer (Name); | |
495 | return Name_Find; | |
496 | end Create_Name; | |
497 | ||
498 | function Create_Name (Name : String) return Path_Name_Type is | |
499 | begin | |
500 | Name_Len := 0; | |
501 | Add_Str_To_Name_Buffer (Name); | |
502 | return Name_Find; | |
503 | end Create_Name; | |
504 | ||
958a816e VC |
505 | ---------------------------- |
506 | -- Executable_Prefix_Path -- | |
507 | ---------------------------- | |
508 | ||
509 | function Executable_Prefix_Path return String is | |
510 | Exec_Name : constant String := Command_Name; | |
511 | ||
512 | function Get_Install_Dir (S : String) return String; | |
74744c7b AC |
513 | -- S is the executable name preceded by the absolute or relative path, |
514 | -- e.g. "c:\usr\bin\gcc.exe". Returns the absolute directory where "bin" | |
515 | -- lies (in the example "C:\usr"). If the executable is not in a "bin" | |
516 | -- directory, return "". | |
958a816e VC |
517 | |
518 | --------------------- | |
519 | -- Get_Install_Dir -- | |
520 | --------------------- | |
521 | ||
522 | function Get_Install_Dir (S : String) return String is | |
523 | Exec : String := S; | |
524 | Path_Last : Integer := 0; | |
525 | ||
526 | begin | |
527 | for J in reverse Exec'Range loop | |
528 | if Exec (J) = Directory_Separator then | |
529 | Path_Last := J - 1; | |
530 | exit; | |
531 | end if; | |
532 | end loop; | |
533 | ||
534 | if Path_Last >= Exec'First + 2 then | |
535 | To_Lower (Exec (Path_Last - 2 .. Path_Last)); | |
536 | end if; | |
537 | ||
538 | if Path_Last < Exec'First + 2 | |
539 | or else Exec (Path_Last - 2 .. Path_Last) /= "bin" | |
540 | or else (Path_Last - 3 >= Exec'First | |
541 | and then Exec (Path_Last - 3) /= Directory_Separator) | |
542 | then | |
543 | return ""; | |
544 | end if; | |
545 | ||
5fd3fd79 | 546 | return Normalize_Pathname |
d56e7acd AC |
547 | (Exec (Exec'First .. Path_Last - 4), |
548 | Resolve_Links => Opt.Follow_Links_For_Dirs) | |
659819b9 | 549 | & Directory_Separator; |
958a816e VC |
550 | end Get_Install_Dir; |
551 | ||
552 | -- Beginning of Executable_Prefix_Path | |
553 | ||
554 | begin | |
88b17d45 AC |
555 | -- For VMS, the path returned is always /gnu/ |
556 | ||
557 | if Hostparm.OpenVMS then | |
558 | return "/gnu/"; | |
559 | end if; | |
560 | ||
958a816e VC |
561 | -- First determine if a path prefix was placed in front of the |
562 | -- executable name. | |
563 | ||
564 | for J in reverse Exec_Name'Range loop | |
565 | if Exec_Name (J) = Directory_Separator then | |
566 | return Get_Install_Dir (Exec_Name); | |
567 | end if; | |
568 | end loop; | |
569 | ||
570 | -- If we get here, the user has typed the executable name with no | |
571 | -- directory prefix. | |
572 | ||
67d7b0ab | 573 | declare |
659819b9 | 574 | Path : String_Access := Locate_Exec_On_Path (Exec_Name); |
67d7b0ab VC |
575 | begin |
576 | if Path = null then | |
577 | return ""; | |
67d7b0ab | 578 | else |
659819b9 AC |
579 | declare |
580 | Dir : constant String := Get_Install_Dir (Path.all); | |
581 | begin | |
582 | Free (Path); | |
583 | return Dir; | |
584 | end; | |
67d7b0ab VC |
585 | end if; |
586 | end; | |
958a816e VC |
587 | end Executable_Prefix_Path; |
588 | ||
fccd42a9 AC |
589 | ------------------ |
590 | -- Fail_Program -- | |
591 | ------------------ | |
592 | ||
593 | procedure Fail_Program | |
594 | (Project_Tree : Project_Tree_Ref; | |
595 | S : String; | |
596 | Flush_Messages : Boolean := True) | |
597 | is | |
598 | begin | |
599 | if Flush_Messages then | |
600 | if Total_Errors_Detected /= 0 or else Warnings_Detected /= 0 then | |
601 | Errutil.Finalize; | |
602 | end if; | |
603 | end if; | |
604 | ||
605 | Finish_Program (Project_Tree, E_Fatal, S => S); | |
606 | end Fail_Program; | |
607 | ||
608 | -------------------- | |
609 | -- Finish_Program -- | |
610 | -------------------- | |
611 | ||
612 | procedure Finish_Program | |
613 | (Project_Tree : Project_Tree_Ref; | |
614 | Exit_Code : Osint.Exit_Code_Type := Osint.E_Success; | |
615 | S : String := "") | |
616 | is | |
617 | begin | |
618 | if not Debug.Debug_Flag_N then | |
619 | Delete_Temp_Config_Files (Project_Tree); | |
620 | ||
621 | if Project_Tree /= null then | |
622 | Delete_All_Temp_Files (Project_Tree.Shared); | |
623 | end if; | |
624 | end if; | |
625 | ||
626 | if S'Length > 0 then | |
627 | if Exit_Code /= E_Success then | |
628 | Osint.Fail (S); | |
629 | else | |
630 | Write_Str (S); | |
631 | end if; | |
632 | end if; | |
633 | ||
634 | -- Output Namet statistics | |
635 | ||
636 | Namet.Finalize; | |
637 | ||
638 | Exit_Program (Exit_Code); | |
639 | end Finish_Program; | |
640 | ||
f7e71125 AC |
641 | -------------------------- |
642 | -- File_Not_A_Source_Of -- | |
643 | -------------------------- | |
644 | ||
645 | function File_Not_A_Source_Of | |
98c99a5a AC |
646 | (Project_Tree : Project_Tree_Ref; |
647 | Uname : Name_Id; | |
648 | Sfile : File_Name_Type) return Boolean | |
f7e71125 AC |
649 | is |
650 | Unit : constant Unit_Index := | |
651 | Units_Htable.Get (Project_Tree.Units_HT, Uname); | |
652 | ||
653 | At_Least_One_File : Boolean := False; | |
654 | ||
655 | begin | |
656 | if Unit /= No_Unit_Index then | |
657 | for F in Unit.File_Names'Range loop | |
658 | if Unit.File_Names (F) /= null then | |
659 | At_Least_One_File := True; | |
660 | if Unit.File_Names (F).File = Sfile then | |
661 | return False; | |
662 | end if; | |
663 | end if; | |
664 | end loop; | |
665 | ||
666 | if not At_Least_One_File then | |
667 | ||
668 | -- The unit was probably created initially for a separate unit | |
669 | -- (which are initially created as IMPL when both suffixes are the | |
670 | -- same). Later on, Override_Kind changed the type of the file, | |
671 | -- and the unit is no longer valid in fact. | |
672 | ||
673 | return False; | |
674 | end if; | |
675 | ||
676 | Verbose_Msg (Uname, "sources do not include ", Name_Id (Sfile)); | |
677 | return True; | |
678 | end if; | |
679 | ||
680 | return False; | |
681 | end File_Not_A_Source_Of; | |
682 | ||
34798441 EB |
683 | ------------------ |
684 | -- Get_Switches -- | |
685 | ------------------ | |
686 | ||
687 | procedure Get_Switches | |
688 | (Source : Prj.Source_Id; | |
689 | Pkg_Name : Name_Id; | |
690 | Project_Tree : Project_Tree_Ref; | |
691 | Value : out Variable_Value; | |
692 | Is_Default : out Boolean) | |
693 | is | |
694 | begin | |
695 | Get_Switches | |
696 | (Source_File => Source.File, | |
697 | Source_Lang => Source.Language.Name, | |
698 | Source_Prj => Source.Project, | |
699 | Pkg_Name => Pkg_Name, | |
700 | Project_Tree => Project_Tree, | |
701 | Value => Value, | |
702 | Is_Default => Is_Default); | |
703 | end Get_Switches; | |
704 | ||
705 | ------------------ | |
706 | -- Get_Switches -- | |
707 | ------------------ | |
708 | ||
709 | procedure Get_Switches | |
9fde638d RD |
710 | (Source_File : File_Name_Type; |
711 | Source_Lang : Name_Id; | |
712 | Source_Prj : Project_Id; | |
713 | Pkg_Name : Name_Id; | |
714 | Project_Tree : Project_Tree_Ref; | |
715 | Value : out Variable_Value; | |
716 | Is_Default : out Boolean; | |
9466892f AC |
717 | Test_Without_Suffix : Boolean := False; |
718 | Check_ALI_Suffix : Boolean := False) | |
34798441 | 719 | is |
49bfcf43 AC |
720 | Project : constant Project_Id := |
721 | Ultimate_Extending_Project_Of (Source_Prj); | |
722 | Pkg : constant Package_Id := | |
723 | Prj.Util.Value_Of | |
724 | (Name => Pkg_Name, | |
725 | In_Packages => Project.Decl.Packages, | |
40ecf2f5 | 726 | Shared => Project_Tree.Shared); |
9466892f | 727 | Lang : Language_Ptr; |
9fde638d | 728 | |
34798441 EB |
729 | begin |
730 | Is_Default := False; | |
731 | ||
732 | if Source_File /= No_File then | |
733 | Value := Prj.Util.Value_Of | |
734 | (Name => Name_Id (Source_File), | |
735 | Attribute_Or_Array_Name => Name_Switches, | |
736 | In_Package => Pkg, | |
40ecf2f5 | 737 | Shared => Project_Tree.Shared, |
34798441 EB |
738 | Allow_Wildcards => True); |
739 | end if; | |
740 | ||
9466892f AC |
741 | if Value = Nil_Variable_Value |
742 | and then Test_Without_Suffix | |
743 | then | |
744 | Lang := | |
745 | Get_Language_From_Name (Project, Get_Name_String (Source_Lang)); | |
746 | ||
747 | if Lang /= null then | |
748 | declare | |
749 | Naming : Lang_Naming_Data renames Lang.Config.Naming_Data; | |
750 | SF_Name : constant String := Get_Name_String (Source_File); | |
751 | Last : Positive := SF_Name'Length; | |
752 | Name : String (1 .. Last + 3); | |
753 | Spec_Suffix : String := Get_Name_String (Naming.Spec_Suffix); | |
754 | Body_Suffix : String := Get_Name_String (Naming.Body_Suffix); | |
755 | Truncated : Boolean := False; | |
9fde638d | 756 | |
9466892f AC |
757 | begin |
758 | Canonical_Case_File_Name (Spec_Suffix); | |
759 | Canonical_Case_File_Name (Body_Suffix); | |
760 | Name (1 .. Last) := SF_Name; | |
761 | ||
762 | if Last > Body_Suffix'Length | |
763 | and then Name (Last - Body_Suffix'Length + 1 .. Last) = | |
764 | Body_Suffix | |
765 | then | |
766 | Truncated := True; | |
767 | Last := Last - Body_Suffix'Length; | |
768 | end if; | |
769 | ||
770 | if not Truncated | |
771 | and then Last > Spec_Suffix'Length | |
772 | and then Name (Last - Spec_Suffix'Length + 1 .. Last) = | |
773 | Spec_Suffix | |
774 | then | |
775 | Truncated := True; | |
776 | Last := Last - Spec_Suffix'Length; | |
777 | end if; | |
778 | ||
779 | if Truncated then | |
780 | Name_Len := 0; | |
781 | Add_Str_To_Name_Buffer (Name (1 .. Last)); | |
782 | ||
783 | Value := Prj.Util.Value_Of | |
784 | (Name => Name_Find, | |
785 | Attribute_Or_Array_Name => Name_Switches, | |
786 | In_Package => Pkg, | |
40ecf2f5 | 787 | Shared => Project_Tree.Shared, |
9466892f AC |
788 | Allow_Wildcards => True); |
789 | end if; | |
790 | ||
791 | if Value = Nil_Variable_Value | |
792 | and then Check_ALI_Suffix | |
793 | then | |
794 | Last := SF_Name'Length; | |
795 | while Name (Last) /= '.' loop | |
796 | Last := Last - 1; | |
797 | end loop; | |
798 | ||
799 | Name_Len := 0; | |
800 | Add_Str_To_Name_Buffer (Name (1 .. Last)); | |
801 | Add_Str_To_Name_Buffer ("ali"); | |
802 | ||
803 | Value := Prj.Util.Value_Of | |
804 | (Name => Name_Find, | |
805 | Attribute_Or_Array_Name => Name_Switches, | |
806 | In_Package => Pkg, | |
40ecf2f5 | 807 | Shared => Project_Tree.Shared, |
9466892f AC |
808 | Allow_Wildcards => True); |
809 | end if; | |
810 | end; | |
811 | end if; | |
812 | end if; | |
813 | ||
34798441 | 814 | if Value = Nil_Variable_Value then |
34798441 EB |
815 | Is_Default := True; |
816 | Value := | |
817 | Prj.Util.Value_Of | |
818 | (Name => Source_Lang, | |
819 | Attribute_Or_Array_Name => Name_Switches, | |
820 | In_Package => Pkg, | |
40ecf2f5 | 821 | Shared => Project_Tree.Shared, |
34798441 EB |
822 | Force_Lower_Case_Index => True); |
823 | end if; | |
824 | ||
825 | if Value = Nil_Variable_Value then | |
826 | Value := | |
827 | Prj.Util.Value_Of | |
828 | (Name => All_Other_Names, | |
829 | Attribute_Or_Array_Name => Name_Switches, | |
830 | In_Package => Pkg, | |
40ecf2f5 | 831 | Shared => Project_Tree.Shared, |
34798441 EB |
832 | Force_Lower_Case_Index => True); |
833 | end if; | |
834 | ||
835 | if Value = Nil_Variable_Value then | |
836 | Value := | |
837 | Prj.Util.Value_Of | |
838 | (Name => Source_Lang, | |
839 | Attribute_Or_Array_Name => Name_Default_Switches, | |
840 | In_Package => Pkg, | |
40ecf2f5 | 841 | Shared => Project_Tree.Shared); |
34798441 EB |
842 | end if; |
843 | end Get_Switches; | |
844 | ||
2cd44f5a VC |
845 | ------------ |
846 | -- Inform -- | |
847 | ------------ | |
848 | ||
849 | procedure Inform (N : File_Name_Type; Msg : String) is | |
850 | begin | |
851 | Inform (Name_Id (N), Msg); | |
852 | end Inform; | |
853 | ||
854 | procedure Inform (N : Name_Id := No_Name; Msg : String) is | |
855 | begin | |
856 | Osint.Write_Program_Name; | |
857 | ||
858 | Write_Str (": "); | |
859 | ||
860 | if N /= No_Name then | |
861 | Write_Str (""""); | |
7d903840 AC |
862 | |
863 | declare | |
864 | Name : constant String := Get_Name_String (N); | |
865 | begin | |
866 | if Debug.Debug_Flag_F and then Is_Absolute_Path (Name) then | |
867 | Write_Str (File_Name (Name)); | |
868 | else | |
869 | Write_Str (Name); | |
870 | end if; | |
871 | end; | |
872 | ||
2cd44f5a VC |
873 | Write_Str (""" "); |
874 | end if; | |
875 | ||
876 | Write_Str (Msg); | |
877 | Write_Eol; | |
878 | end Inform; | |
879 | ||
fccd42a9 AC |
880 | ------------------------------ |
881 | -- Initialize_Source_Record -- | |
882 | ------------------------------ | |
883 | ||
884 | procedure Initialize_Source_Record (Source : Prj.Source_Id) is | |
885 | procedure Set_Object_Project | |
886 | (Obj_Dir : String; Obj_Proj : Project_Id; Obj_Path : Path_Name_Type; | |
887 | Stamp : Time_Stamp_Type); | |
888 | -- Update information about object file, switches file,... | |
889 | ||
890 | ------------------------ | |
891 | -- Set_Object_Project -- | |
892 | ------------------------ | |
893 | ||
894 | procedure Set_Object_Project | |
895 | (Obj_Dir : String; Obj_Proj : Project_Id; Obj_Path : Path_Name_Type; | |
896 | Stamp : Time_Stamp_Type) is | |
897 | begin | |
898 | Source.Object_Project := Obj_Proj; | |
899 | Source.Object_Path := Obj_Path; | |
900 | Source.Object_TS := Stamp; | |
901 | ||
902 | if Source.Language.Config.Dependency_Kind /= None then | |
903 | declare | |
904 | Dep_Path : constant String := | |
905 | Normalize_Pathname | |
906 | (Name => Get_Name_String (Source.Dep_Name), | |
907 | Resolve_Links => Opt.Follow_Links_For_Files, | |
908 | Directory => Obj_Dir); | |
909 | begin | |
910 | Source.Dep_Path := Create_Name (Dep_Path); | |
911 | Source.Dep_TS := Osint.Unknown_Attributes; | |
912 | end; | |
913 | end if; | |
914 | ||
915 | -- Get the path of the switches file, even if Opt.Check_Switches is | |
916 | -- not set, as switch -s may be in the Builder switches that have not | |
917 | -- been scanned yet. | |
918 | ||
919 | declare | |
920 | Switches_Path : constant String := | |
921 | Normalize_Pathname | |
922 | (Name => Get_Name_String (Source.Switches), | |
923 | Resolve_Links => Opt.Follow_Links_For_Files, | |
924 | Directory => Obj_Dir); | |
925 | begin | |
926 | Source.Switches_Path := Create_Name (Switches_Path); | |
927 | ||
928 | if Stamp /= Empty_Time_Stamp then | |
929 | Source.Switches_TS := File_Stamp (Source.Switches_Path); | |
930 | end if; | |
931 | end; | |
932 | end Set_Object_Project; | |
933 | ||
934 | Obj_Proj : Project_Id; | |
935 | ||
936 | begin | |
937 | -- Nothing to do if source record has already been fully initialized | |
938 | ||
939 | if Source.Initialized then | |
940 | return; | |
941 | end if; | |
942 | ||
943 | -- Systematically recompute the time stamp | |
944 | ||
945 | Source.Source_TS := File_Stamp (Source.Path.Display_Name); | |
946 | ||
947 | -- Parse the source file to check whether we have a subunit | |
948 | ||
949 | if Source.Language.Config.Kind = Unit_Based | |
950 | and then Source.Kind = Impl | |
951 | and then Is_Subunit (Source) | |
952 | then | |
953 | Source.Kind := Sep; | |
954 | end if; | |
955 | ||
956 | if Source.Language.Config.Object_Generated | |
957 | and then Is_Compilable (Source) | |
958 | then | |
959 | -- First, get the correct object file name and dependency file name | |
960 | -- if the source is in a multi-unit file. | |
961 | ||
962 | if Source.Index /= 0 then | |
963 | Source.Object := | |
964 | Object_Name | |
965 | (Source_File_Name => Source.File, | |
966 | Source_Index => Source.Index, | |
967 | Index_Separator => | |
968 | Source.Language.Config.Multi_Unit_Object_Separator, | |
969 | Object_File_Suffix => | |
970 | Source.Language.Config.Object_File_Suffix); | |
971 | ||
972 | Source.Dep_Name := | |
973 | Dependency_Name | |
974 | (Source.Object, Source.Language.Config.Dependency_Kind); | |
975 | end if; | |
976 | ||
977 | -- Find the object file for that source. It could be either in | |
978 | -- the current project or in an extended project (it might actually | |
979 | -- not exist yet in the ultimate extending project, but if not found | |
980 | -- elsewhere that's where we'll expect to find it). | |
981 | ||
982 | Obj_Proj := Source.Project; | |
983 | while Obj_Proj /= No_Project loop | |
984 | declare | |
985 | Dir : constant String := Get_Name_String | |
986 | (Obj_Proj.Object_Directory.Display_Name); | |
987 | ||
988 | Object_Path : constant String := | |
989 | Normalize_Pathname | |
990 | (Name => | |
991 | Get_Name_String (Source.Object), | |
992 | Resolve_Links => | |
993 | Opt.Follow_Links_For_Files, | |
994 | Directory => Dir); | |
995 | ||
996 | Obj_Path : constant Path_Name_Type := Create_Name (Object_Path); | |
997 | Stamp : Time_Stamp_Type := Empty_Time_Stamp; | |
998 | ||
999 | begin | |
1000 | -- For specs, we do not check object files if there is a body. | |
1001 | -- This saves a system call. On the other hand, we do need to | |
1002 | -- know the object_path, in case the user has passed the .ads | |
1003 | -- on the command line to compile the spec only | |
1004 | ||
1005 | if Source.Kind /= Spec | |
1006 | or else Source.Unit = No_Unit_Index | |
1007 | or else Source.Unit.File_Names (Impl) = No_Source | |
1008 | then | |
1009 | Stamp := File_Stamp (Obj_Path); | |
1010 | end if; | |
1011 | ||
1012 | if Stamp /= Empty_Time_Stamp | |
1013 | or else (Obj_Proj.Extended_By = No_Project | |
1014 | and then Source.Object_Project = No_Project) | |
1015 | then | |
1016 | Set_Object_Project (Dir, Obj_Proj, Obj_Path, Stamp); | |
1017 | end if; | |
1018 | ||
1019 | Obj_Proj := Obj_Proj.Extended_By; | |
1020 | end; | |
1021 | end loop; | |
1022 | ||
1023 | elsif Source.Language.Config.Dependency_Kind = Makefile then | |
1024 | declare | |
1025 | Object_Dir : constant String := | |
1026 | Get_Name_String | |
1027 | (Source.Project.Object_Directory.Display_Name); | |
1028 | Dep_Path : constant String := | |
1029 | Normalize_Pathname | |
1030 | (Name => Get_Name_String (Source.Dep_Name), | |
1031 | Resolve_Links => | |
1032 | Opt.Follow_Links_For_Files, | |
1033 | Directory => Object_Dir); | |
1034 | begin | |
1035 | Source.Dep_Path := Create_Name (Dep_Path); | |
1036 | Source.Dep_TS := Osint.Unknown_Attributes; | |
1037 | end; | |
1038 | end if; | |
1039 | ||
1040 | Source.Initialized := True; | |
1041 | end Initialize_Source_Record; | |
1042 | ||
8f9df7d8 VC |
1043 | ---------------------------- |
1044 | -- Is_External_Assignment -- | |
1045 | ---------------------------- | |
1046 | ||
daa72421 | 1047 | function Is_External_Assignment |
804fe3c4 | 1048 | (Env : Prj.Tree.Environment; |
daa72421 AC |
1049 | Argv : String) return Boolean |
1050 | is | |
8f9df7d8 VC |
1051 | Start : Positive := 3; |
1052 | Finish : Natural := Argv'Last; | |
8f9df7d8 | 1053 | |
bfc8aa81 RD |
1054 | pragma Assert (Argv'First = 1); |
1055 | pragma Assert (Argv (1 .. 2) = "-X"); | |
1056 | ||
8f9df7d8 VC |
1057 | begin |
1058 | if Argv'Last < 5 then | |
1059 | return False; | |
1060 | ||
1061 | elsif Argv (3) = '"' then | |
1062 | if Argv (Argv'Last) /= '"' or else Argv'Last < 7 then | |
1063 | return False; | |
1064 | else | |
1065 | Start := 4; | |
1066 | Finish := Argv'Last - 1; | |
1067 | end if; | |
1068 | end if; | |
1069 | ||
d9b4a5d3 | 1070 | return Prj.Ext.Check |
804fe3c4 | 1071 | (Self => Env.External, |
d9b4a5d3 | 1072 | Declaration => Argv (Start .. Finish)); |
8f9df7d8 VC |
1073 | end Is_External_Assignment; |
1074 | ||
fccd42a9 AC |
1075 | ---------------- |
1076 | -- Is_Subunit -- | |
1077 | ---------------- | |
1078 | ||
1079 | function Is_Subunit (Source : Prj.Source_Id) return Boolean is | |
1080 | Src_Ind : Source_File_Index; | |
2c1b72d7 | 1081 | |
fccd42a9 AC |
1082 | begin |
1083 | if Source.Kind = Sep then | |
1084 | return True; | |
1085 | ||
1086 | -- A Spec, a file based language source or a body with a spec cannot be | |
1087 | -- a subunit. | |
1088 | ||
2c1b72d7 AC |
1089 | elsif Source.Kind = Spec |
1090 | or else Source.Unit = No_Unit_Index | |
1091 | or else Other_Part (Source) /= No_Source | |
fccd42a9 AC |
1092 | then |
1093 | return False; | |
1094 | end if; | |
1095 | ||
1096 | -- Here, we are assuming that the language is Ada, as it is the only | |
1097 | -- unit based language that we know. | |
1098 | ||
1099 | Src_Ind := | |
1100 | Sinput.P.Load_Project_File | |
1101 | (Get_Name_String (Source.Path.Display_Name)); | |
1102 | ||
1103 | return Sinput.P.Source_File_Is_Subunit (Src_Ind); | |
1104 | end Is_Subunit; | |
1105 | ||
8f9df7d8 VC |
1106 | ----------------------------- |
1107 | -- Linker_Options_Switches -- | |
1108 | ----------------------------- | |
1109 | ||
1110 | function Linker_Options_Switches | |
7e98a4c6 | 1111 | (Project : Project_Id; |
98c99a5a | 1112 | Do_Fail : Fail_Proc; |
7e98a4c6 | 1113 | In_Tree : Project_Tree_Ref) return String_List |
8f9df7d8 | 1114 | is |
40ecf2f5 EB |
1115 | procedure Recursive_Add |
1116 | (Proj : Project_Id; | |
1117 | In_Tree : Project_Tree_Ref; | |
1118 | Dummy : in out Boolean); | |
5950a3ac | 1119 | -- The recursive routine used to add linker options |
8f9df7d8 | 1120 | |
8b9890fa EB |
1121 | ------------------- |
1122 | -- Recursive_Add -- | |
1123 | ------------------- | |
8f9df7d8 | 1124 | |
40ecf2f5 EB |
1125 | procedure Recursive_Add |
1126 | (Proj : Project_Id; | |
1127 | In_Tree : Project_Tree_Ref; | |
1128 | Dummy : in out Boolean) | |
1129 | is | |
8b9890fa | 1130 | pragma Unreferenced (Dummy); |
74744c7b | 1131 | |
8f9df7d8 | 1132 | Linker_Package : Package_Id; |
5950a3ac | 1133 | Options : Variable_Value; |
5950a3ac | 1134 | |
8f9df7d8 | 1135 | begin |
8b9890fa EB |
1136 | Linker_Package := |
1137 | Prj.Util.Value_Of | |
1138 | (Name => Name_Linker, | |
66713d62 | 1139 | In_Packages => Proj.Decl.Packages, |
40ecf2f5 | 1140 | Shared => In_Tree.Shared); |
74744c7b | 1141 | |
8b9890fa EB |
1142 | Options := |
1143 | Prj.Util.Value_Of | |
1144 | (Name => Name_Ada, | |
1145 | Index => 0, | |
1146 | Attribute_Or_Array_Name => Name_Linker_Options, | |
1147 | In_Package => Linker_Package, | |
40ecf2f5 | 1148 | Shared => In_Tree.Shared); |
8b9890fa EB |
1149 | |
1150 | -- If attribute is present, add the project with | |
1151 | -- the attribute to table Linker_Opts. | |
1152 | ||
1153 | if Options /= Nil_Variable_Value then | |
1154 | Linker_Opts.Increment_Last; | |
1155 | Linker_Opts.Table (Linker_Opts.Last) := | |
1156 | (Project => Proj, Options => Options.Values); | |
8f9df7d8 | 1157 | end if; |
8b9890fa EB |
1158 | end Recursive_Add; |
1159 | ||
1160 | procedure For_All_Projects is | |
1161 | new For_Every_Project_Imported (Boolean, Recursive_Add); | |
74744c7b | 1162 | |
8b9890fa | 1163 | Dummy : Boolean := False; |
8f9df7d8 | 1164 | |
5950a3ac AC |
1165 | -- Start of processing for Linker_Options_Switches |
1166 | ||
8f9df7d8 VC |
1167 | begin |
1168 | Linker_Opts.Init; | |
1169 | ||
40ecf2f5 | 1170 | For_All_Projects (Project, In_Tree, Dummy, Imported_First => True); |
8f9df7d8 VC |
1171 | |
1172 | Last_Linker_Option := 0; | |
1173 | ||
1174 | for Index in reverse 1 .. Linker_Opts.Last loop | |
1175 | declare | |
66713d62 | 1176 | Options : String_List_Id; |
8f9df7d8 | 1177 | Proj : constant Project_Id := |
74744c7b | 1178 | Linker_Opts.Table (Index).Project; |
8f9df7d8 | 1179 | Option : Name_Id; |
2324b3fd | 1180 | Dir_Path : constant String := |
66713d62 | 1181 | Get_Name_String (Proj.Directory.Name); |
8f9df7d8 VC |
1182 | |
1183 | begin | |
66713d62 | 1184 | Options := Linker_Opts.Table (Index).Options; |
8f9df7d8 | 1185 | while Options /= Nil_String loop |
40ecf2f5 | 1186 | Option := In_Tree.Shared.String_Elements.Table (Options).Value; |
f2c573b1 VC |
1187 | Get_Name_String (Option); |
1188 | ||
1189 | -- Do not consider empty linker options | |
1190 | ||
1191 | if Name_Len /= 0 then | |
1192 | Add_Linker_Option (Name_Buffer (1 .. Name_Len)); | |
1193 | ||
1194 | -- Object files and -L switches specified with relative | |
1195 | -- paths must be converted to absolute paths. | |
1196 | ||
1197 | Test_If_Relative_Path | |
f9ad6b62 AC |
1198 | (Switch => Linker_Options_Buffer (Last_Linker_Option), |
1199 | Parent => Dir_Path, | |
98c99a5a | 1200 | Do_Fail => Do_Fail, |
f2c573b1 VC |
1201 | Including_L_Switch => True); |
1202 | end if; | |
1203 | ||
40ecf2f5 | 1204 | Options := In_Tree.Shared.String_Elements.Table (Options).Next; |
8f9df7d8 VC |
1205 | end loop; |
1206 | end; | |
1207 | end loop; | |
1208 | ||
1209 | return Linker_Options_Buffer (1 .. Last_Linker_Option); | |
1210 | end Linker_Options_Switches; | |
1211 | ||
1212 | ----------- | |
1213 | -- Mains -- | |
1214 | ----------- | |
1215 | ||
1216 | package body Mains is | |
1217 | ||
1218 | package Names is new Table.Table | |
fccd42a9 | 1219 | (Table_Component_Type => Main_Info, |
8f9df7d8 VC |
1220 | Table_Index_Type => Integer, |
1221 | Table_Low_Bound => 1, | |
1222 | Table_Initial => 10, | |
1223 | Table_Increment => 100, | |
1224 | Table_Name => "Makeutl.Mains.Names"); | |
1225 | -- The table that stores the mains | |
1226 | ||
1227 | Current : Natural := 0; | |
1228 | -- The index of the last main retrieved from the table | |
1229 | ||
316d9d4f EB |
1230 | Count_Of_Mains_With_No_Tree : Natural := 0; |
1231 | -- Number of main units for which we do not know the project tree | |
1232 | ||
8f9df7d8 VC |
1233 | -------------- |
1234 | -- Add_Main -- | |
1235 | -------------- | |
1236 | ||
fccd42a9 AC |
1237 | procedure Add_Main |
1238 | (Name : String; | |
1239 | Index : Int := 0; | |
41ba34db EB |
1240 | Location : Source_Ptr := No_Location; |
1241 | Project : Project_Id := No_Project; | |
1242 | Tree : Project_Tree_Ref := null) | |
fccd42a9 | 1243 | is |
8f9df7d8 | 1244 | begin |
316d9d4f EB |
1245 | if Current_Verbosity = High then |
1246 | Debug_Output ("Add_Main """ & Name & """ " & Index'Img | |
1247 | & " with_tree? " | |
1248 | & Boolean'Image (Tree /= null)); | |
1249 | end if; | |
1250 | ||
8f9df7d8 VC |
1251 | Name_Len := 0; |
1252 | Add_Str_To_Name_Buffer (Name); | |
fccd42a9 AC |
1253 | Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); |
1254 | ||
8f9df7d8 | 1255 | Names.Increment_Last; |
41ba34db EB |
1256 | Names.Table (Names.Last) := |
1257 | (Name_Find, Index, Location, No_Source, Project, Tree); | |
316d9d4f EB |
1258 | |
1259 | if Tree /= null then | |
1260 | Builder_Data (Tree).Number_Of_Mains := | |
1261 | Builder_Data (Tree).Number_Of_Mains + 1; | |
1262 | else | |
1263 | Mains.Count_Of_Mains_With_No_Tree := | |
1264 | Mains.Count_Of_Mains_With_No_Tree + 1; | |
1265 | end if; | |
8f9df7d8 VC |
1266 | end Add_Main; |
1267 | ||
316d9d4f EB |
1268 | -------------------- |
1269 | -- Complete_Mains -- | |
1270 | -------------------- | |
1271 | ||
1272 | procedure Complete_Mains | |
4fdebd93 AC |
1273 | (Flags : Processing_Flags; |
1274 | Root_Project : Project_Id; | |
316d9d4f EB |
1275 | Project_Tree : Project_Tree_Ref) |
1276 | is | |
1277 | procedure Do_Complete (Project : Project_Id; Tree : Project_Tree_Ref); | |
1278 | -- Check the mains for this specific project | |
1279 | ||
1280 | procedure Complete_All is new For_Project_And_Aggregated | |
1281 | (Do_Complete); | |
1282 | ||
1283 | procedure Do_Complete | |
1284 | (Project : Project_Id; Tree : Project_Tree_Ref) is | |
1285 | begin | |
1286 | if Mains.Number_Of_Mains (Tree) > 0 | |
1287 | or else Mains.Count_Of_Mains_With_No_Tree > 0 | |
1288 | then | |
1289 | for J in Names.First .. Names.Last loop | |
1290 | declare | |
1291 | File : Main_Info := Names.Table (J); | |
1292 | Main_Id : File_Name_Type := File.File; | |
1293 | Main : constant String := Get_Name_String (Main_Id); | |
1294 | Source : Prj.Source_Id := No_Source; | |
1295 | Suffix : File_Name_Type; | |
1296 | Iter : Source_Iterator; | |
4fdebd93 | 1297 | Is_Absolute : Boolean := False; |
316d9d4f EB |
1298 | |
1299 | begin | |
1300 | if Base_Name (Main) /= Main then | |
1301 | if Is_Absolute_Path (Main) then | |
1302 | Main_Id := Create_Name (Base_Name (Main)); | |
4fdebd93 | 1303 | Is_Absolute := True; |
316d9d4f EB |
1304 | else |
1305 | Fail_Program | |
1306 | (Tree, | |
1307 | "mains cannot include directory information (""" | |
1308 | & Main & """)"); | |
1309 | end if; | |
1310 | end if; | |
1311 | ||
1312 | -- If no project or tree was specified for the main, it | |
1313 | -- came from the command line. In this case, it needs to | |
1314 | -- belong to the root project. | |
1315 | -- Note that the assignments below will not modify inside | |
1316 | -- the table itself. | |
1317 | ||
1318 | if File.Project = null then | |
1319 | File.Project := Project; | |
1320 | end if; | |
1321 | ||
1322 | if File.Tree = null then | |
4fdebd93 | 1323 | File.Tree := Tree; |
316d9d4f EB |
1324 | end if; |
1325 | ||
1326 | if File.Source = null then | |
4fdebd93 AC |
1327 | if Current_Verbosity = High then |
1328 | Debug_Output | |
1329 | ("Search for main """ & Main | |
1330 | & """ in " | |
1331 | & Get_Name_String (Debug_Name (File.Tree)) | |
1332 | & ", project", Project.Name); | |
1333 | end if; | |
316d9d4f EB |
1334 | |
1335 | -- First, look for the main as specified. | |
4fdebd93 AC |
1336 | -- We need to search for the base name though, and |
1337 | -- if needed check later that we found the correct | |
1338 | -- file. | |
316d9d4f EB |
1339 | |
1340 | Source := Find_Source | |
1341 | (In_Tree => File.Tree, | |
1342 | Project => File.Project, | |
4fdebd93 | 1343 | Base_Name => Main_Id, |
316d9d4f EB |
1344 | Index => File.Index); |
1345 | ||
1346 | if Source = No_Source then | |
1347 | -- Now look for the main with a body suffix | |
1348 | ||
1349 | declare | |
1350 | -- Main already has a canonical casing | |
1351 | Main : constant String := | |
1352 | Get_Name_String (Main_Id); | |
1353 | Project : Project_Id; | |
1354 | begin | |
1355 | Project := File.Project; | |
1356 | while Source = No_Source | |
1357 | and then Project /= No_Project | |
1358 | loop | |
1359 | Iter := For_Each_Source (File.Tree, Project); | |
1360 | loop | |
1361 | Source := Prj.Element (Iter); | |
1362 | exit when Source = No_Source; | |
1363 | ||
1364 | -- Only consider bodies | |
1365 | ||
1366 | if Source.Kind = Impl then | |
1367 | Get_Name_String (Source.File); | |
1368 | ||
1369 | if Name_Len > Main'Length | |
1370 | and then Name_Buffer | |
1371 | (1 .. Main'Length) = Main | |
1372 | then | |
1373 | Suffix := | |
1374 | Source.Language | |
1375 | .Config.Naming_Data.Body_Suffix; | |
1376 | ||
1377 | exit when Suffix /= No_File and then | |
1378 | Name_Buffer | |
1379 | (Main'Length + 1 .. Name_Len) = | |
1380 | Get_Name_String (Suffix); | |
1381 | end if; | |
1382 | end if; | |
1383 | ||
1384 | Next (Iter); | |
1385 | end loop; | |
1386 | ||
1387 | Project := Project.Extends; | |
1388 | end loop; | |
1389 | end; | |
4fdebd93 AC |
1390 | |
1391 | else | |
1392 | if Is_Absolute then | |
1393 | if File_Name_Type (Source.Path.Display_Name) /= | |
1394 | File.File | |
1395 | then | |
1396 | Debug_Output | |
1397 | ("Found a non-matching file", | |
1398 | Name_Id (Source.Path.Display_Name)); | |
1399 | Source := No_Source; | |
1400 | end if; | |
1401 | end if; | |
316d9d4f EB |
1402 | end if; |
1403 | ||
1404 | if Source /= No_Source then | |
4fdebd93 | 1405 | |
316d9d4f | 1406 | Debug_Output ("Found main in project", |
78efd712 | 1407 | Source.Project.Name); |
316d9d4f EB |
1408 | Names.Table (J).File := Source.File; |
1409 | Names.Table (J).Project := File.Project; | |
1410 | ||
1411 | if Names.Table (J).Tree = null then | |
1412 | Names.Table (J).Tree := File.Tree; | |
1413 | ||
1414 | Builder_Data (File.Tree).Number_Of_Mains := | |
1415 | Builder_Data (File.Tree).Number_Of_Mains + 1; | |
1416 | Mains.Count_Of_Mains_With_No_Tree := | |
1417 | Mains.Count_Of_Mains_With_No_Tree - 1; | |
1418 | end if; | |
1419 | ||
1420 | Names.Table (J).Source := Source; | |
1421 | ||
1422 | elsif File.Location /= No_Location then | |
1423 | -- If the main is declared in package Builder of | |
1424 | -- the main project, report an error. If the main | |
1425 | -- is on the command line, it may be a main from | |
1426 | -- another project, so do nothing: if the main does | |
1427 | -- not exist in another project, an error will be | |
1428 | -- reported later. | |
1429 | ||
1430 | Error_Msg_File_1 := Main_Id; | |
1431 | Error_Msg_Name_1 := Root_Project.Name; | |
4fdebd93 AC |
1432 | Prj.Err.Error_Msg |
1433 | (Flags, | |
1434 | "{ is not a source of project %%", | |
1435 | File.Location, Project); | |
316d9d4f EB |
1436 | end if; |
1437 | end if; | |
1438 | end; | |
1439 | end loop; | |
1440 | end if; | |
1441 | ||
1442 | if Total_Errors_Detected > 0 then | |
1443 | Fail_Program (Tree, "problems with main sources"); | |
1444 | end if; | |
1445 | end Do_Complete; | |
1446 | ||
2c1b72d7 AC |
1447 | -- Start of processing for Complete_Mains |
1448 | ||
316d9d4f EB |
1449 | begin |
1450 | Complete_All (Root_Project, Project_Tree); | |
4fdebd93 AC |
1451 | |
1452 | if Mains.Count_Of_Mains_With_No_Tree > 0 then | |
1453 | for J in Names.First .. Names.Last loop | |
1454 | Fail_Program | |
1455 | (Project_Tree, '"' & Get_Name_String (Names.Table (J).File) | |
1456 | & """ is not a source of any project"); | |
1457 | end loop; | |
1458 | end if; | |
316d9d4f EB |
1459 | end Complete_Mains; |
1460 | ||
2c1b72d7 AC |
1461 | ------------ |
1462 | -- Delete -- | |
1463 | ------------ | |
1464 | ||
1465 | procedure Delete is | |
1466 | begin | |
1467 | Names.Set_Last (0); | |
1468 | Mains.Reset; | |
1469 | end Delete; | |
1470 | ||
fccd42a9 | 1471 | ----------------------- |
2c1b72d7 | 1472 | -- Fill_From_Project -- |
fccd42a9 | 1473 | ----------------------- |
c9df623a | 1474 | |
fccd42a9 AC |
1475 | procedure Fill_From_Project |
1476 | (Root_Project : Project_Id; | |
41ba34db EB |
1477 | Project_Tree : Project_Tree_Ref) |
1478 | is | |
1479 | procedure Add_Mains_From_Project | |
1480 | (Project : Project_Id; Tree : Project_Tree_Ref); | |
316d9d4f EB |
1481 | -- Add the main units from this project into Mains. |
1482 | -- This takes into account the aggregated projects | |
41ba34db | 1483 | |
2c1b72d7 AC |
1484 | ---------------------------- |
1485 | -- Add_Mains_From_Project -- | |
1486 | ---------------------------- | |
1487 | ||
41ba34db EB |
1488 | procedure Add_Mains_From_Project |
1489 | (Project : Project_Id; | |
1490 | Tree : Project_Tree_Ref) | |
1491 | is | |
1492 | List : String_List_Id; | |
1493 | Element : String_Element; | |
41ba34db | 1494 | begin |
316d9d4f EB |
1495 | if Number_Of_Mains (Tree) = 0 |
1496 | and then Mains.Count_Of_Mains_With_No_Tree = 0 | |
1497 | then | |
1498 | Debug_Output ("Add_Mains_From_Project", Project.Name); | |
1499 | List := Project.Mains; | |
1500 | if List /= Prj.Nil_String then | |
1501 | -- The attribute Main is not an empty list. | |
1502 | -- Get the mains in the list | |
c9df623a | 1503 | |
316d9d4f EB |
1504 | while List /= Prj.Nil_String loop |
1505 | Element := Tree.Shared.String_Elements.Table (List); | |
1506 | Debug_Output ("Add_Main", Element.Value); | |
1e887886 | 1507 | |
316d9d4f | 1508 | if Project.Library then |
fccd42a9 | 1509 | Fail_Program |
316d9d4f EB |
1510 | (Tree, |
1511 | "cannot specify a main program " & | |
1512 | "for a library project file"); | |
fccd42a9 | 1513 | end if; |
fccd42a9 | 1514 | |
316d9d4f EB |
1515 | Add_Main (Name => Get_Name_String (Element.Value), |
1516 | Index => Element.Index, | |
1517 | Location => Element.Location, | |
1518 | Project => Project, | |
1519 | Tree => Tree); | |
1520 | List := Element.Next; | |
1521 | end loop; | |
1522 | end if; | |
1523 | end if; | |
fccd42a9 | 1524 | |
316d9d4f EB |
1525 | if Total_Errors_Detected > 0 then |
1526 | Fail_Program (Tree, "problems with main sources"); | |
1527 | end if; | |
1528 | end Add_Mains_From_Project; | |
fccd42a9 | 1529 | |
316d9d4f EB |
1530 | procedure Fill_All is new For_Project_And_Aggregated |
1531 | (Add_Mains_From_Project); | |
fccd42a9 | 1532 | |
2c1b72d7 AC |
1533 | -- Start of processing for Fill_From_Project |
1534 | ||
316d9d4f EB |
1535 | begin |
1536 | Fill_All (Root_Project, Project_Tree); | |
fccd42a9 AC |
1537 | end Fill_From_Project; |
1538 | ||
1539 | --------------- | |
1540 | -- Next_Main -- | |
1541 | --------------- | |
1542 | ||
1543 | function Next_Main return String is | |
2c1b72d7 | 1544 | Info : constant Main_Info := Next_Main; |
1e887886 | 1545 | begin |
fccd42a9 AC |
1546 | if Info = No_Main_Info then |
1547 | return ""; | |
1e887886 | 1548 | else |
fccd42a9 | 1549 | return Get_Name_String (Info.File); |
1e887886 | 1550 | end if; |
fccd42a9 | 1551 | end Next_Main; |
1e887886 | 1552 | |
fccd42a9 | 1553 | function Next_Main return Main_Info is |
8f9df7d8 VC |
1554 | begin |
1555 | if Current >= Names.Last then | |
fccd42a9 | 1556 | return No_Main_Info; |
8f9df7d8 VC |
1557 | else |
1558 | Current := Current + 1; | |
fccd42a9 | 1559 | return Names.Table (Current); |
8f9df7d8 VC |
1560 | end if; |
1561 | end Next_Main; | |
1562 | ||
1563 | --------------------- | |
1564 | -- Number_Of_Mains -- | |
1565 | --------------------- | |
1566 | ||
316d9d4f | 1567 | function Number_Of_Mains (Tree : Project_Tree_Ref) return Natural is |
8f9df7d8 | 1568 | begin |
316d9d4f EB |
1569 | if Tree = null then |
1570 | return Names.Last; | |
1571 | else | |
1572 | return Builder_Data (Tree).Number_Of_Mains; | |
1573 | end if; | |
8f9df7d8 VC |
1574 | end Number_Of_Mains; |
1575 | ||
1576 | ----------- | |
1577 | -- Reset -- | |
1578 | ----------- | |
1579 | ||
1580 | procedure Reset is | |
1581 | begin | |
1582 | Current := 0; | |
1583 | end Reset; | |
2c1b72d7 AC |
1584 | |
1585 | -------------------------- | |
1586 | -- Set_Multi_Unit_Index -- | |
1587 | -------------------------- | |
1588 | ||
1589 | procedure Set_Multi_Unit_Index | |
1590 | (Project_Tree : Project_Tree_Ref := null; | |
1591 | Index : Int := 0) | |
1592 | is | |
1593 | begin | |
1594 | if Index /= 0 then | |
1595 | if Names.Last = 0 then | |
1596 | Fail_Program | |
1597 | (Project_Tree, | |
1598 | "cannot specify a multi-unit index but no main " & | |
1599 | "on the command line"); | |
1600 | ||
1601 | elsif Names.Last > 1 then | |
1602 | Fail_Program | |
1603 | (Project_Tree, | |
1604 | "cannot specify several mains with a multi-unit index"); | |
1605 | ||
1606 | else | |
1607 | Names.Table (Names.Last).Index := Index; | |
1608 | end if; | |
1609 | end if; | |
1610 | end Set_Multi_Unit_Index; | |
1611 | ||
8f9df7d8 VC |
1612 | end Mains; |
1613 | ||
7d903840 AC |
1614 | ----------------------- |
1615 | -- Path_Or_File_Name -- | |
1616 | ----------------------- | |
1617 | ||
1618 | function Path_Or_File_Name (Path : Path_Name_Type) return String is | |
1619 | Path_Name : constant String := Get_Name_String (Path); | |
1620 | begin | |
1621 | if Debug.Debug_Flag_F then | |
1622 | return File_Name (Path_Name); | |
1623 | else | |
1624 | return Path_Name; | |
1625 | end if; | |
1626 | end Path_Or_File_Name; | |
1627 | ||
8f9df7d8 VC |
1628 | --------------------------- |
1629 | -- Test_If_Relative_Path -- | |
1630 | --------------------------- | |
1631 | ||
1632 | procedure Test_If_Relative_Path | |
1086c39b | 1633 | (Switch : in out String_Access; |
2324b3fd | 1634 | Parent : String; |
98c99a5a | 1635 | Do_Fail : Fail_Proc; |
1086c39b | 1636 | Including_L_Switch : Boolean := True; |
35debead EB |
1637 | Including_Non_Switch : Boolean := True; |
1638 | Including_RTS : Boolean := False) | |
8f9df7d8 VC |
1639 | is |
1640 | begin | |
1641 | if Switch /= null then | |
8f9df7d8 | 1642 | declare |
74744c7b | 1643 | Sw : String (1 .. Switch'Length); |
8f9df7d8 VC |
1644 | Start : Positive; |
1645 | ||
1646 | begin | |
1647 | Sw := Switch.all; | |
1648 | ||
1649 | if Sw (1) = '-' then | |
1650 | if Sw'Length >= 3 | |
1651 | and then (Sw (2) = 'A' | |
74744c7b AC |
1652 | or else Sw (2) = 'I' |
1653 | or else (Including_L_Switch and then Sw (2) = 'L')) | |
8f9df7d8 VC |
1654 | then |
1655 | Start := 3; | |
1656 | ||
1657 | if Sw = "-I-" then | |
1658 | return; | |
1659 | end if; | |
1660 | ||
1661 | elsif Sw'Length >= 4 | |
1662 | and then (Sw (2 .. 3) = "aL" | |
74744c7b AC |
1663 | or else Sw (2 .. 3) = "aO" |
1664 | or else Sw (2 .. 3) = "aI") | |
8f9df7d8 VC |
1665 | then |
1666 | Start := 4; | |
1667 | ||
35debead EB |
1668 | elsif Including_RTS |
1669 | and then Sw'Length >= 7 | |
1670 | and then Sw (2 .. 6) = "-RTS=" | |
1671 | then | |
1672 | Start := 7; | |
1673 | ||
8f9df7d8 VC |
1674 | else |
1675 | return; | |
1676 | end if; | |
1677 | ||
2c1b72d7 AC |
1678 | -- Because relative path arguments to --RTS= may be relative to |
1679 | -- the search directory prefix, those relative path arguments | |
1680 | -- are converted only when they include directory information. | |
8f9df7d8 VC |
1681 | |
1682 | if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then | |
2324b3fd | 1683 | if Parent'Length = 0 then |
8f9df7d8 | 1684 | Do_Fail |
3dd9959c AC |
1685 | ("relative search path switches (""" |
1686 | & Sw | |
1687 | & """) are not allowed"); | |
8f9df7d8 | 1688 | |
35debead EB |
1689 | elsif Including_RTS then |
1690 | for J in Start .. Sw'Last loop | |
1691 | if Sw (J) = Directory_Separator then | |
1692 | Switch := | |
1693 | new String' | |
1694 | (Sw (1 .. Start - 1) & | |
1695 | Parent & | |
1696 | Directory_Separator & | |
1697 | Sw (Start .. Sw'Last)); | |
1698 | return; | |
1699 | end if; | |
1700 | end loop; | |
1701 | ||
8f9df7d8 VC |
1702 | else |
1703 | Switch := | |
1704 | new String' | |
1705 | (Sw (1 .. Start - 1) & | |
2324b3fd | 1706 | Parent & |
8f9df7d8 VC |
1707 | Directory_Separator & |
1708 | Sw (Start .. Sw'Last)); | |
1709 | end if; | |
1710 | end if; | |
1711 | ||
1086c39b | 1712 | elsif Including_Non_Switch then |
8f9df7d8 | 1713 | if not Is_Absolute_Path (Sw) then |
2324b3fd | 1714 | if Parent'Length = 0 then |
8f9df7d8 | 1715 | Do_Fail |
3dd9959c | 1716 | ("relative paths (""" & Sw & """) are not allowed"); |
8f9df7d8 | 1717 | else |
2324b3fd | 1718 | Switch := new String'(Parent & Directory_Separator & Sw); |
8f9df7d8 VC |
1719 | end if; |
1720 | end if; | |
1721 | end if; | |
1722 | end; | |
1723 | end if; | |
1724 | end Test_If_Relative_Path; | |
1725 | ||
aa720a54 AC |
1726 | ------------------- |
1727 | -- Unit_Index_Of -- | |
1728 | ------------------- | |
1729 | ||
1730 | function Unit_Index_Of (ALI_File : File_Name_Type) return Int is | |
1731 | Start : Natural; | |
1732 | Finish : Natural; | |
1733 | Result : Int := 0; | |
5950a3ac | 1734 | |
aa720a54 AC |
1735 | begin |
1736 | Get_Name_String (ALI_File); | |
1737 | ||
1738 | -- First, find the last dot | |
1739 | ||
1740 | Finish := Name_Len; | |
1741 | ||
1742 | while Finish >= 1 and then Name_Buffer (Finish) /= '.' loop | |
1743 | Finish := Finish - 1; | |
1744 | end loop; | |
1745 | ||
1746 | if Finish = 1 then | |
1747 | return 0; | |
1748 | end if; | |
1749 | ||
1750 | -- Now check that the dot is preceded by digits | |
1751 | ||
1752 | Start := Finish; | |
1753 | Finish := Finish - 1; | |
1754 | ||
1755 | while Start >= 1 and then Name_Buffer (Start - 1) in '0' .. '9' loop | |
1756 | Start := Start - 1; | |
1757 | end loop; | |
1758 | ||
74744c7b AC |
1759 | -- If there are no digits, or if the digits are not preceded by the |
1760 | -- character that precedes a unit index, this is not the ALI file of | |
1761 | -- a unit in a multi-unit source. | |
aa720a54 | 1762 | |
5950a3ac AC |
1763 | if Start > Finish |
1764 | or else Start = 1 | |
1765 | or else Name_Buffer (Start - 1) /= Multi_Unit_Index_Character | |
aa720a54 AC |
1766 | then |
1767 | return 0; | |
1768 | end if; | |
1769 | ||
1770 | -- Build the index from the digit(s) | |
1771 | ||
1772 | while Start <= Finish loop | |
5950a3ac AC |
1773 | Result := Result * 10 + |
1774 | Character'Pos (Name_Buffer (Start)) - Character'Pos ('0'); | |
aa720a54 AC |
1775 | Start := Start + 1; |
1776 | end loop; | |
1777 | ||
1778 | return Result; | |
1779 | end Unit_Index_Of; | |
1780 | ||
f7e71125 AC |
1781 | ----------------- |
1782 | -- Verbose_Msg -- | |
1783 | ----------------- | |
1784 | ||
1785 | procedure Verbose_Msg | |
1786 | (N1 : Name_Id; | |
1787 | S1 : String; | |
1788 | N2 : Name_Id := No_Name; | |
1789 | S2 : String := ""; | |
1790 | Prefix : String := " -> "; | |
1791 | Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low) | |
1792 | is | |
1793 | begin | |
1794 | if not Opt.Verbose_Mode | |
1795 | or else Minimum_Verbosity > Opt.Verbosity_Level | |
1796 | then | |
1797 | return; | |
1798 | end if; | |
1799 | ||
1800 | Write_Str (Prefix); | |
1801 | Write_Str (""""); | |
1802 | Write_Name (N1); | |
1803 | Write_Str (""" "); | |
1804 | Write_Str (S1); | |
1805 | ||
1806 | if N2 /= No_Name then | |
1807 | Write_Str (" """); | |
1808 | Write_Name (N2); | |
1809 | Write_Str (""" "); | |
1810 | end if; | |
1811 | ||
1812 | Write_Str (S2); | |
1813 | Write_Eol; | |
1814 | end Verbose_Msg; | |
1815 | ||
1816 | procedure Verbose_Msg | |
1817 | (N1 : File_Name_Type; | |
1818 | S1 : String; | |
1819 | N2 : File_Name_Type := No_File; | |
1820 | S2 : String := ""; | |
1821 | Prefix : String := " -> "; | |
1822 | Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low) | |
1823 | is | |
1824 | begin | |
1825 | Verbose_Msg | |
1826 | (Name_Id (N1), S1, Name_Id (N2), S2, Prefix, Minimum_Verbosity); | |
1827 | end Verbose_Msg; | |
1828 | ||
e280f981 AC |
1829 | ----------- |
1830 | -- Queue -- | |
1831 | ----------- | |
1832 | ||
1833 | package body Queue is | |
2c1b72d7 | 1834 | |
e280f981 AC |
1835 | type Q_Record is record |
1836 | Info : Source_Info; | |
1837 | Processed : Boolean; | |
1838 | end record; | |
1839 | ||
1840 | package Q is new Table.Table | |
1841 | (Table_Component_Type => Q_Record, | |
1842 | Table_Index_Type => Natural, | |
1843 | Table_Low_Bound => 1, | |
1844 | Table_Initial => 1000, | |
1845 | Table_Increment => 100, | |
1846 | Table_Name => "Makeutl.Queue.Q"); | |
1847 | -- This is the actual Queue | |
1848 | ||
1849 | package Busy_Obj_Dirs is new GNAT.HTable.Simple_HTable | |
1850 | (Header_Num => Prj.Header_Num, | |
1851 | Element => Boolean, | |
1852 | No_Element => False, | |
1853 | Key => Path_Name_Type, | |
1854 | Hash => Hash, | |
1855 | Equal => "="); | |
1856 | ||
1857 | type Mark_Key is record | |
1858 | File : File_Name_Type; | |
1859 | Index : Int; | |
1860 | end record; | |
1861 | -- Identify either a mono-unit source (when Index = 0) or a specific | |
1862 | -- unit (index = 1's origin index of unit) in a multi-unit source. | |
1863 | ||
1864 | Max_Mask_Num : constant := 2048; | |
1865 | subtype Mark_Num is Union_Id range 0 .. Max_Mask_Num - 1; | |
1866 | ||
1867 | function Hash (Key : Mark_Key) return Mark_Num; | |
1868 | ||
1869 | package Marks is new GNAT.HTable.Simple_HTable | |
1870 | (Header_Num => Mark_Num, | |
1871 | Element => Boolean, | |
1872 | No_Element => False, | |
1873 | Key => Mark_Key, | |
1874 | Hash => Hash, | |
1875 | Equal => "="); | |
1876 | -- A hash table to keep tracks of the marked units. | |
1877 | -- These are the units that have already been processed, when using the | |
1878 | -- gnatmake format. When using the gprbuild format, we can directly | |
1879 | -- store in the source_id whether the file has already been processed. | |
1880 | ||
1881 | procedure Mark (Source_File : File_Name_Type; Index : Int := 0); | |
1882 | -- Mark a unit, identified by its source file and, when Index is not 0, | |
1883 | -- the index of the unit in the source file. Marking is used to signal | |
1884 | -- that the unit has already been inserted in the Q. | |
1885 | ||
1886 | function Is_Marked | |
1887 | (Source_File : File_Name_Type; | |
1888 | Index : Int := 0) return Boolean; | |
1889 | -- Returns True if the unit was previously marked | |
1890 | ||
1891 | Q_Processed : Natural := 0; | |
1892 | Q_Initialized : Boolean := False; | |
1893 | ||
1894 | Q_First : Natural := 1; | |
1895 | -- Points to the first valid element in the queue | |
1896 | ||
1897 | One_Queue_Per_Obj_Dir : Boolean := False; | |
1898 | -- See parameter to Initialize | |
1899 | ||
1900 | function Available_Obj_Dir (S : Source_Info) return Boolean; | |
1901 | -- Whether the object directory for S is available for a build | |
1902 | ||
1903 | procedure Debug_Display (S : Source_Info); | |
1904 | -- A debug display for S | |
1905 | ||
1906 | function Was_Processed (S : Source_Info) return Boolean; | |
1907 | -- Whether S has already been processed. This marks the source as | |
1908 | -- processed, if it hasn't already been processed. | |
1909 | ||
41ba34db EB |
1910 | function Insert_No_Roots (Source : Source_Info) return Boolean; |
1911 | -- Insert Source, but do not look for its roots (see doc for Insert). | |
1912 | ||
e280f981 AC |
1913 | ------------------- |
1914 | -- Was_Processed -- | |
1915 | ------------------- | |
1916 | ||
1917 | function Was_Processed (S : Source_Info) return Boolean is | |
1918 | begin | |
1919 | case S.Format is | |
1920 | when Format_Gprbuild => | |
1921 | if S.Id.In_The_Queue then | |
1922 | return True; | |
1923 | end if; | |
1924 | S.Id.In_The_Queue := True; | |
1925 | ||
1926 | when Format_Gnatmake => | |
1927 | if Is_Marked (S.File, S.Index) then | |
1928 | return True; | |
1929 | end if; | |
1930 | Mark (S.File, Index => S.Index); | |
1931 | end case; | |
1932 | ||
1933 | return False; | |
1934 | end Was_Processed; | |
1935 | ||
1936 | ----------------------- | |
1937 | -- Available_Obj_Dir -- | |
1938 | ----------------------- | |
1939 | ||
1940 | function Available_Obj_Dir (S : Source_Info) return Boolean is | |
1941 | begin | |
1942 | case S.Format is | |
1943 | when Format_Gprbuild => | |
1944 | return not Busy_Obj_Dirs.Get | |
1945 | (S.Id.Project.Object_Directory.Name); | |
1946 | ||
1947 | when Format_Gnatmake => | |
1948 | return S.Project = No_Project | |
1949 | or else | |
1950 | not Busy_Obj_Dirs.Get (S.Project.Object_Directory.Name); | |
1951 | end case; | |
1952 | end Available_Obj_Dir; | |
1953 | ||
1954 | ------------------- | |
1955 | -- Debug_Display -- | |
1956 | ------------------- | |
1957 | ||
1958 | procedure Debug_Display (S : Source_Info) is | |
1959 | begin | |
1960 | case S.Format is | |
1961 | when Format_Gprbuild => | |
1962 | Write_Name (S.Id.File); | |
1963 | ||
1964 | if S.Id.Index /= 0 then | |
1965 | Write_Str (", "); | |
1966 | Write_Int (S.Id.Index); | |
1967 | end if; | |
1968 | ||
1969 | when Format_Gnatmake => | |
1970 | Write_Name (S.File); | |
1971 | ||
1972 | if S.Index /= 0 then | |
1973 | Write_Str (", "); | |
1974 | Write_Int (S.Index); | |
1975 | end if; | |
1976 | end case; | |
1977 | end Debug_Display; | |
1978 | ||
1979 | ---------- | |
1980 | -- Hash -- | |
1981 | ---------- | |
1982 | ||
1983 | function Hash (Key : Mark_Key) return Mark_Num is | |
1984 | begin | |
1985 | return Union_Id (Key.File) mod Max_Mask_Num; | |
1986 | end Hash; | |
1987 | ||
1988 | --------------- | |
1989 | -- Is_Marked -- | |
1990 | --------------- | |
1991 | ||
1992 | function Is_Marked | |
1993 | (Source_File : File_Name_Type; | |
1994 | Index : Int := 0) return Boolean is | |
1995 | begin | |
1996 | return Marks.Get (K => (File => Source_File, Index => Index)); | |
1997 | end Is_Marked; | |
1998 | ||
1999 | ---------- | |
2000 | -- Mark -- | |
2001 | ---------- | |
2002 | ||
2003 | procedure Mark (Source_File : File_Name_Type; Index : Int := 0) is | |
2004 | begin | |
2005 | Marks.Set (K => (File => Source_File, Index => Index), E => True); | |
2006 | end Mark; | |
2007 | ||
2008 | ------------- | |
2009 | -- Extract -- | |
2010 | ------------- | |
2011 | ||
2012 | procedure Extract | |
2013 | (Found : out Boolean; | |
f9ad6b62 AC |
2014 | Source : out Source_Info) |
2015 | is | |
e280f981 AC |
2016 | begin |
2017 | Found := False; | |
2018 | ||
2019 | if One_Queue_Per_Obj_Dir then | |
2020 | for J in Q_First .. Q.Last loop | |
2021 | if not Q.Table (J).Processed | |
2022 | and then Available_Obj_Dir (Q.Table (J).Info) | |
2023 | then | |
2024 | Found := True; | |
2025 | Source := Q.Table (J).Info; | |
2026 | Q.Table (J).Processed := True; | |
2027 | ||
2028 | if J = Q_First then | |
2029 | while Q_First <= Q.Last | |
2030 | and then Q.Table (Q_First).Processed | |
2031 | loop | |
2032 | Q_First := Q_First + 1; | |
2033 | end loop; | |
2034 | end if; | |
2035 | ||
2036 | exit; | |
2037 | end if; | |
2038 | end loop; | |
2039 | ||
2040 | elsif Q_First <= Q.Last then | |
2041 | Source := Q.Table (Q_First).Info; | |
2042 | Q.Table (Q_First).Processed := True; | |
2043 | Q_First := Q_First + 1; | |
2044 | Found := True; | |
2045 | end if; | |
2046 | ||
2047 | if Found then | |
2048 | Q_Processed := Q_Processed + 1; | |
2049 | end if; | |
2050 | ||
2051 | if Found and then Debug.Debug_Flag_Q then | |
2052 | Write_Str (" Q := Q - [ "); | |
2053 | Debug_Display (Source); | |
2054 | Write_Str (" ]"); | |
2055 | Write_Eol; | |
2056 | ||
2057 | Write_Str (" Q_First ="); | |
2058 | Write_Int (Int (Q_First)); | |
2059 | Write_Eol; | |
2060 | ||
2061 | Write_Str (" Q.Last ="); | |
2062 | Write_Int (Int (Q.Last)); | |
2063 | Write_Eol; | |
2064 | end if; | |
2065 | end Extract; | |
2066 | ||
2067 | --------------- | |
2068 | -- Processed -- | |
2069 | --------------- | |
2070 | ||
2071 | function Processed return Natural is | |
2072 | begin | |
2073 | return Q_Processed; | |
2074 | end Processed; | |
2075 | ||
2076 | ---------------- | |
2077 | -- Initialize -- | |
2078 | ---------------- | |
2079 | ||
2080 | procedure Initialize | |
2081 | (Queue_Per_Obj_Dir : Boolean; | |
f9ad6b62 AC |
2082 | Force : Boolean := False) |
2083 | is | |
e280f981 AC |
2084 | begin |
2085 | if Force or else not Q_Initialized then | |
2086 | Q_Initialized := True; | |
2087 | ||
2088 | for J in 1 .. Q.Last loop | |
2089 | case Q.Table (J).Info.Format is | |
2090 | when Format_Gprbuild => | |
2091 | Q.Table (J).Info.Id.In_The_Queue := False; | |
2092 | when Format_Gnatmake => | |
2093 | null; | |
2094 | end case; | |
2095 | end loop; | |
2096 | ||
2097 | Q.Init; | |
2098 | Q_Processed := 0; | |
2099 | Q_First := 1; | |
2100 | One_Queue_Per_Obj_Dir := Queue_Per_Obj_Dir; | |
2101 | end if; | |
2102 | end Initialize; | |
2103 | ||
41ba34db EB |
2104 | --------------------- |
2105 | -- Insert_No_Roots -- | |
2106 | --------------------- | |
e280f981 | 2107 | |
41ba34db | 2108 | function Insert_No_Roots (Source : Source_Info) return Boolean is |
e280f981 | 2109 | begin |
41ba34db EB |
2110 | pragma Assert |
2111 | (Source.Format = Format_Gnatmake | |
2112 | or else Source.Id /= No_Source); | |
2113 | ||
e280f981 AC |
2114 | -- Only insert in the Q if it is not already done, to avoid |
2115 | -- simultaneous compilations if -jnnn is used. | |
2116 | ||
2117 | if Was_Processed (Source) then | |
2118 | return False; | |
2119 | end if; | |
2120 | ||
2121 | if Current_Verbosity = High then | |
2122 | Write_Str ("Adding """); | |
2123 | Debug_Display (Source); | |
316d9d4f | 2124 | Write_Line (""" to the queue"); |
e280f981 AC |
2125 | end if; |
2126 | ||
2127 | Q.Append (New_Val => (Info => Source, Processed => False)); | |
2128 | ||
2129 | if Debug.Debug_Flag_Q then | |
2130 | Write_Str (" Q := Q + [ "); | |
2131 | Debug_Display (Source); | |
2132 | Write_Str (" ] "); | |
2133 | Write_Eol; | |
2134 | ||
2135 | Write_Str (" Q_First ="); | |
2136 | Write_Int (Int (Q_First)); | |
2137 | Write_Eol; | |
2138 | ||
2139 | Write_Str (" Q.Last ="); | |
2140 | Write_Int (Int (Q.Last)); | |
2141 | Write_Eol; | |
2142 | end if; | |
2143 | ||
41ba34db EB |
2144 | return True; |
2145 | end Insert_No_Roots; | |
2146 | ||
2147 | ------------ | |
2148 | -- Insert -- | |
2149 | ------------ | |
2150 | ||
2151 | function Insert | |
2152 | (Source : Source_Info; With_Roots : Boolean := False) return Boolean | |
2153 | is | |
2154 | Root_Arr : Array_Element_Id; | |
2155 | Roots : Variable_Value; | |
2156 | List : String_List_Id; | |
2157 | Elem : String_Element; | |
2158 | Unit_Name : Name_Id; | |
2159 | Pat_Root : Boolean; | |
2160 | Root_Pattern : Regexp; | |
2161 | Root_Found : Boolean; | |
2162 | Roots_Found : Boolean; | |
2163 | Dummy : Boolean; | |
2164 | Root_Source : Prj.Source_Id; | |
2165 | Iter : Source_Iterator; | |
2166 | pragma Unreferenced (Dummy); | |
2167 | ||
2168 | begin | |
2169 | if not Insert_No_Roots (Source) then | |
2170 | -- Was already in the queue | |
2171 | return False; | |
2172 | end if; | |
2173 | ||
2174 | if With_Roots and then Source.Format = Format_Gprbuild then | |
2175 | Debug_Output ("Looking for roots of", Name_Id (Source.Id.File)); | |
2176 | ||
2177 | Root_Arr := | |
2178 | Prj.Util.Value_Of | |
2179 | (Name => Name_Roots, | |
2180 | In_Arrays => Source.Id.Project.Decl.Arrays, | |
2181 | Shared => Source.Tree.Shared); | |
2182 | ||
2183 | Roots := | |
2184 | Prj.Util.Value_Of | |
2185 | (Index => Name_Id (Source.Id.File), | |
2186 | Src_Index => 0, | |
2187 | In_Array => Root_Arr, | |
2188 | Shared => Source.Tree.Shared); | |
2189 | ||
2190 | -- If there is no roots for the specific main, try the language | |
2191 | ||
2192 | if Roots = Nil_Variable_Value then | |
2193 | Roots := | |
2194 | Prj.Util.Value_Of | |
2195 | (Index => Source.Id.Language.Name, | |
2196 | Src_Index => 0, | |
2197 | In_Array => Root_Arr, | |
2198 | Shared => Source.Tree.Shared, | |
2199 | Force_Lower_Case_Index => True); | |
2200 | end if; | |
2201 | ||
2202 | -- Then try "*" | |
2203 | ||
2204 | if Roots = Nil_Variable_Value then | |
2205 | Name_Len := 1; | |
2206 | Name_Buffer (1) := '*'; | |
2207 | ||
2208 | Roots := | |
2209 | Prj.Util.Value_Of | |
2210 | (Index => Name_Find, | |
2211 | Src_Index => 0, | |
2212 | In_Array => Root_Arr, | |
2213 | Shared => Source.Tree.Shared, | |
2214 | Force_Lower_Case_Index => True); | |
2215 | end if; | |
2216 | ||
2217 | if Roots = Nil_Variable_Value then | |
2218 | Debug_Output (" -> no roots declared"); | |
2219 | else | |
2220 | List := Roots.Values; | |
2221 | ||
2222 | Pattern_Loop : | |
2223 | while List /= Nil_String loop | |
2224 | Elem := Source.Tree.Shared.String_Elements.Table (List); | |
2225 | Get_Name_String (Elem.Value); | |
2226 | To_Lower (Name_Buffer (1 .. Name_Len)); | |
2227 | Unit_Name := Name_Find; | |
2228 | ||
2229 | -- Check if it is a unit name or a pattern | |
2230 | ||
2231 | Pat_Root := False; | |
2232 | ||
2233 | for J in 1 .. Name_Len loop | |
2234 | if Name_Buffer (J) not in 'a' .. 'z' | |
2235 | and then Name_Buffer (J) not in '0' .. '9' | |
2236 | and then Name_Buffer (J) /= '_' | |
2237 | and then Name_Buffer (J) /= '.' | |
2238 | then | |
2239 | Pat_Root := True; | |
2240 | exit; | |
2241 | end if; | |
2242 | end loop; | |
2243 | ||
2244 | if Pat_Root then | |
2245 | begin | |
2246 | Root_Pattern := | |
2247 | Compile | |
2248 | (Pattern => Name_Buffer (1 .. Name_Len), | |
2249 | Glob => True); | |
2250 | ||
2251 | exception | |
2252 | when Error_In_Regexp => | |
2253 | Err_Vars.Error_Msg_Name_1 := Unit_Name; | |
2254 | Errutil.Error_Msg | |
2255 | ("invalid pattern %", Roots.Location); | |
2256 | exit Pattern_Loop; | |
2257 | end; | |
2258 | end if; | |
2259 | ||
2260 | Roots_Found := False; | |
2261 | Iter := For_Each_Source (Source.Tree); | |
2262 | ||
2263 | Source_Loop : | |
2264 | loop | |
2265 | Root_Source := Prj.Element (Iter); | |
2266 | exit Source_Loop when Root_Source = No_Source; | |
2267 | ||
2268 | Root_Found := False; | |
2269 | if Pat_Root then | |
2270 | Root_Found := Root_Source.Unit /= No_Unit_Index | |
2271 | and then Match | |
2272 | (Get_Name_String (Root_Source.Unit.Name), | |
2273 | Root_Pattern); | |
2274 | ||
2275 | else | |
2276 | Root_Found := | |
2277 | Root_Source.Unit /= No_Unit_Index | |
2278 | and then Root_Source.Unit.Name = Unit_Name; | |
2279 | end if; | |
2280 | ||
2281 | if Root_Found then | |
2282 | case Root_Source.Kind is | |
2283 | when Impl => | |
2284 | null; | |
2285 | ||
2286 | when Spec => | |
2287 | Root_Found := Other_Part (Root_Source) = No_Source; | |
2288 | ||
2289 | when Sep => | |
2290 | Root_Found := False; | |
2291 | end case; | |
2292 | end if; | |
2293 | ||
2294 | if Root_Found then | |
2295 | Roots_Found := True; | |
2296 | Debug_Output | |
2297 | (" -> ", Name_Id (Root_Source.Display_File)); | |
2298 | Dummy := Queue.Insert_No_Roots | |
2299 | (Source => (Format => Format_Gprbuild, | |
2300 | Tree => Source.Tree, | |
2301 | Id => Root_Source)); | |
2302 | ||
2303 | Initialize_Source_Record (Root_Source); | |
2304 | ||
2305 | if Other_Part (Root_Source) /= No_Source then | |
2306 | Initialize_Source_Record (Other_Part (Root_Source)); | |
2307 | end if; | |
2308 | ||
2309 | -- Save the root for the binder. | |
2310 | ||
2311 | Source.Id.Roots := new Source_Roots' | |
2312 | (Root => Root_Source, | |
2313 | Next => Source.Id.Roots); | |
2314 | ||
2315 | exit Source_Loop when not Pat_Root; | |
2316 | end if; | |
2317 | ||
2318 | Next (Iter); | |
2319 | end loop Source_Loop; | |
2320 | ||
2321 | if not Roots_Found then | |
2322 | if Pat_Root then | |
2323 | if not Quiet_Output then | |
2324 | Error_Msg_Name_1 := Unit_Name; | |
2325 | Errutil.Error_Msg | |
2326 | ("?no unit matches pattern %", Roots.Location); | |
2327 | end if; | |
2328 | ||
2329 | else | |
2330 | Errutil.Error_Msg | |
2331 | ("Unit " & Get_Name_String (Unit_Name) | |
2332 | & " does not exist", Roots.Location); | |
2333 | end if; | |
2334 | end if; | |
2335 | ||
2336 | List := Elem.Next; | |
2337 | end loop Pattern_Loop; | |
2338 | end if; | |
2339 | end if; | |
2340 | ||
e280f981 AC |
2341 | return True; |
2342 | end Insert; | |
2343 | ||
2344 | ------------ | |
2345 | -- Insert -- | |
2346 | ------------ | |
2347 | ||
41ba34db EB |
2348 | procedure Insert |
2349 | (Source : Source_Info; With_Roots : Boolean := False) | |
2350 | is | |
f9ad6b62 AC |
2351 | Discard : Boolean; |
2352 | pragma Unreferenced (Discard); | |
e280f981 | 2353 | begin |
41ba34db | 2354 | Discard := Insert (Source, With_Roots); |
e280f981 AC |
2355 | end Insert; |
2356 | ||
2357 | -------------- | |
2358 | -- Is_Empty -- | |
2359 | -------------- | |
2360 | ||
2361 | function Is_Empty return Boolean is | |
2362 | begin | |
2363 | return Q_Processed >= Q.Last; | |
2364 | end Is_Empty; | |
2365 | ||
2366 | ------------------------ | |
2367 | -- Is_Virtually_Empty -- | |
2368 | ------------------------ | |
2369 | ||
2370 | function Is_Virtually_Empty return Boolean is | |
2371 | begin | |
2372 | if One_Queue_Per_Obj_Dir then | |
2373 | for J in Q_First .. Q.Last loop | |
2374 | if not Q.Table (J).Processed | |
2375 | and then Available_Obj_Dir (Q.Table (J).Info) | |
2376 | then | |
2377 | return False; | |
2378 | end if; | |
2379 | end loop; | |
2380 | ||
2381 | return True; | |
2382 | ||
2383 | else | |
2384 | return Is_Empty; | |
2385 | end if; | |
2386 | end Is_Virtually_Empty; | |
2387 | ||
2388 | ---------------------- | |
2389 | -- Set_Obj_Dir_Busy -- | |
2390 | ---------------------- | |
2391 | ||
2392 | procedure Set_Obj_Dir_Busy (Obj_Dir : Path_Name_Type) is | |
2393 | begin | |
2394 | if One_Queue_Per_Obj_Dir then | |
2395 | Busy_Obj_Dirs.Set (Obj_Dir, True); | |
2396 | end if; | |
2397 | end Set_Obj_Dir_Busy; | |
2398 | ||
2399 | ---------------------- | |
2400 | -- Set_Obj_Dir_Free -- | |
2401 | ---------------------- | |
2402 | ||
2403 | procedure Set_Obj_Dir_Free (Obj_Dir : Path_Name_Type) is | |
2404 | begin | |
2405 | if One_Queue_Per_Obj_Dir then | |
2406 | Busy_Obj_Dirs.Set (Obj_Dir, False); | |
2407 | end if; | |
2408 | end Set_Obj_Dir_Free; | |
2409 | ||
2410 | ---------- | |
2411 | -- Size -- | |
2412 | ---------- | |
2413 | ||
2414 | function Size return Natural is | |
2415 | begin | |
2416 | return Q.Last; | |
2417 | end Size; | |
2418 | ||
2419 | ------------- | |
2420 | -- Element -- | |
2421 | ------------- | |
2422 | ||
2423 | function Element (Rank : Positive) return File_Name_Type is | |
2424 | begin | |
2425 | if Rank <= Q.Last then | |
2426 | case Q.Table (Rank).Info.Format is | |
2427 | when Format_Gprbuild => | |
2428 | return Q.Table (Rank).Info.Id.File; | |
2429 | when Format_Gnatmake => | |
2430 | return Q.Table (Rank).Info.File; | |
2431 | end case; | |
2432 | else | |
2433 | return No_File; | |
2434 | end if; | |
2435 | end Element; | |
2436 | ||
2437 | ------------------ | |
2438 | -- Remove_Marks -- | |
2439 | ------------------ | |
2440 | ||
2441 | procedure Remove_Marks is | |
2442 | begin | |
2443 | Marks.Reset; | |
2444 | end Remove_Marks; | |
2445 | ||
fccd42a9 AC |
2446 | ---------------------------- |
2447 | -- Insert_Project_Sources -- | |
2448 | ---------------------------- | |
2449 | ||
2450 | procedure Insert_Project_Sources | |
316d9d4f EB |
2451 | (Project : Project_Id; |
2452 | Project_Tree : Project_Tree_Ref; | |
2453 | All_Projects : Boolean; | |
2454 | Unique_Compile : Boolean) | |
fccd42a9 | 2455 | is |
316d9d4f EB |
2456 | procedure Do_Insert (Project : Project_Id; Tree : Project_Tree_Ref); |
2457 | procedure Do_Insert (Project : Project_Id; Tree : Project_Tree_Ref) is | |
2458 | Unit_Based : constant Boolean := | |
2459 | Unique_Compile | |
2460 | or else not Builder_Data (Tree).Closure_Needed; | |
2461 | -- When Unit_Based is True, put in the queue all compilable | |
2462 | -- sources including the unit based (Ada) one. When Unit_Based is | |
2463 | -- False, put the Ada sources only when they are in a library | |
2464 | -- project. | |
2465 | ||
2466 | Iter : Source_Iterator; | |
2467 | Source : Prj.Source_Id; | |
2468 | begin | |
2469 | -- Nothing to do when "-u" was specified and some files were | |
2470 | -- specified on the command line | |
2471 | ||
2472 | if Unique_Compile | |
2473 | and then Mains.Number_Of_Mains (Tree) > 0 | |
fccd42a9 | 2474 | then |
316d9d4f EB |
2475 | return; |
2476 | end if; | |
2477 | ||
2478 | Iter := For_Each_Source (Tree); | |
2479 | loop | |
2480 | Source := Prj.Element (Iter); | |
2481 | exit when Source = No_Source; | |
2482 | ||
2483 | if Is_Compilable (Source) | |
2484 | and then | |
2485 | (All_Projects | |
2486 | or else Is_Extending (Project, Source.Project)) | |
2487 | and then not Source.Locally_Removed | |
2488 | and then Source.Replaced_By = No_Source | |
2489 | and then | |
2490 | (not Source.Project.Externally_Built | |
2491 | or else | |
2492 | (Is_Extending (Project, Source.Project) | |
2493 | and then not Project.Externally_Built)) | |
2494 | and then Source.Kind /= Sep | |
2495 | and then Source.Path /= No_Path_Information | |
fccd42a9 | 2496 | then |
316d9d4f EB |
2497 | if Source.Kind = Impl |
2498 | or else (Source.Unit /= No_Unit_Index | |
2499 | and then Source.Kind = Spec | |
2500 | and then (Other_Part (Source) = No_Source | |
2501 | or else | |
2502 | Other_Part (Source).Locally_Removed)) | |
fccd42a9 | 2503 | then |
316d9d4f EB |
2504 | if (Unit_Based |
2505 | or else Source.Unit = No_Unit_Index | |
2506 | or else Source.Project.Library) | |
2507 | and then not Is_Subunit (Source) | |
2508 | then | |
2509 | Queue.Insert | |
2510 | (Source => (Format => Format_Gprbuild, | |
2511 | Tree => Tree, | |
2512 | Id => Source)); | |
2513 | end if; | |
fccd42a9 AC |
2514 | end if; |
2515 | end if; | |
fccd42a9 | 2516 | |
316d9d4f EB |
2517 | Next (Iter); |
2518 | end loop; | |
2519 | end Do_Insert; | |
2520 | ||
2521 | procedure Insert_All is new For_Project_And_Aggregated (Do_Insert); | |
2522 | ||
2523 | begin | |
2524 | Insert_All (Project, Project_Tree); | |
fccd42a9 AC |
2525 | end Insert_Project_Sources; |
2526 | ||
2527 | ------------------------------- | |
2528 | -- Insert_Withed_Sources_For -- | |
2529 | ------------------------------- | |
2530 | ||
2531 | procedure Insert_Withed_Sources_For | |
2532 | (The_ALI : ALI.ALI_Id; | |
2533 | Project_Tree : Project_Tree_Ref; | |
2534 | Excluding_Shared_SALs : Boolean := False) | |
2535 | is | |
2536 | Sfile : File_Name_Type; | |
2537 | Afile : File_Name_Type; | |
2538 | Src_Id : Prj.Source_Id; | |
2539 | ||
2540 | begin | |
2541 | -- Insert in the queue the unmarked source files (i.e. those which | |
2542 | -- have never been inserted in the queue and hence never considered). | |
2543 | ||
2544 | for J in ALI.ALIs.Table (The_ALI).First_Unit .. | |
2545 | ALI.ALIs.Table (The_ALI).Last_Unit | |
2546 | loop | |
2547 | for K in ALI.Units.Table (J).First_With .. | |
2548 | ALI.Units.Table (J).Last_With | |
2549 | loop | |
2550 | Sfile := ALI.Withs.Table (K).Sfile; | |
2551 | ||
2552 | -- Skip generics | |
2553 | ||
2554 | if Sfile /= No_File then | |
2555 | Afile := ALI.Withs.Table (K).Afile; | |
2556 | Src_Id := Source_Files_Htable.Get | |
2557 | (Project_Tree.Source_Files_HT, Sfile); | |
2558 | ||
2559 | while Src_Id /= No_Source loop | |
2560 | Initialize_Source_Record (Src_Id); | |
2561 | ||
2562 | if Is_Compilable (Src_Id) | |
2563 | and then Src_Id.Dep_Name = Afile | |
2564 | then | |
2565 | case Src_Id.Kind is | |
2566 | when Spec => | |
2567 | declare | |
2568 | Bdy : constant Prj.Source_Id := | |
2569 | Other_Part (Src_Id); | |
2570 | begin | |
2571 | if Bdy /= No_Source | |
2572 | and then not Bdy.Locally_Removed | |
2573 | then | |
2574 | Src_Id := Other_Part (Src_Id); | |
2575 | end if; | |
2576 | end; | |
2577 | ||
2578 | when Impl => | |
2579 | if Is_Subunit (Src_Id) then | |
2580 | Src_Id := No_Source; | |
2581 | end if; | |
2582 | ||
2583 | when Sep => | |
2584 | Src_Id := No_Source; | |
2585 | end case; | |
2586 | ||
2587 | exit; | |
2588 | end if; | |
2589 | ||
2590 | Src_Id := Src_Id.Next_With_File_Name; | |
2591 | end loop; | |
2592 | ||
2593 | -- If Excluding_Shared_SALs is True, do not insert in the | |
2594 | -- queue the sources of a shared Stand-Alone Library. | |
2595 | ||
2596 | if Src_Id /= No_Source and then | |
2597 | (not Excluding_Shared_SALs or else | |
2598 | not Src_Id.Project.Standalone_Library or else | |
2599 | Src_Id.Project.Library_Kind = Static) | |
2600 | then | |
2601 | Queue.Insert | |
2602 | (Source => (Format => Format_Gprbuild, | |
41ba34db | 2603 | Tree => Project_Tree, |
fccd42a9 AC |
2604 | Id => Src_Id)); |
2605 | end if; | |
2606 | end if; | |
2607 | end loop; | |
2608 | end loop; | |
2609 | end Insert_Withed_Sources_For; | |
e280f981 AC |
2610 | end Queue; |
2611 | ||
316d9d4f EB |
2612 | ---------- |
2613 | -- Free -- | |
2614 | ---------- | |
2615 | ||
2616 | procedure Free (Data : in out Builder_Project_Tree_Data) is | |
2617 | procedure Unchecked_Free is new Ada.Unchecked_Deallocation | |
2618 | (Binding_Data_Record, Binding_Data); | |
2619 | ||
2620 | TmpB, Binding : Binding_Data := Data.Binding; | |
2621 | begin | |
2622 | while Binding /= null loop | |
2623 | TmpB := Binding.Next; | |
2624 | Unchecked_Free (Binding); | |
2625 | Binding := TmpB; | |
2626 | end loop; | |
2627 | end Free; | |
2628 | ||
2629 | ------------------ | |
2630 | -- Builder_Data -- | |
2631 | ------------------ | |
2632 | ||
2633 | function Builder_Data | |
2634 | (Tree : Project_Tree_Ref) return Builder_Data_Access | |
2635 | is | |
2636 | begin | |
2637 | if Tree.Appdata = null then | |
2638 | Tree.Appdata := new Builder_Project_Tree_Data; | |
2639 | end if; | |
2640 | ||
2641 | return Builder_Data_Access (Tree.Appdata); | |
2642 | end Builder_Data; | |
2643 | ||
2644 | -------------------------------- | |
2645 | -- Compute_Compilation_Phases -- | |
2646 | -------------------------------- | |
2647 | ||
2648 | procedure Compute_Compilation_Phases | |
2649 | (Tree : Project_Tree_Ref; | |
2650 | Root_Project : Project_Id; | |
2651 | Option_Unique_Compile : Boolean := False; -- Was "-u" specified ? | |
2652 | Option_Compile_Only : Boolean := False; -- Was "-c" specified ? | |
2653 | Option_Bind_Only : Boolean := False; | |
2654 | Option_Link_Only : Boolean := False) | |
2655 | is | |
2656 | procedure Do_Compute (Project : Project_Id; Tree : Project_Tree_Ref); | |
2657 | ||
2658 | procedure Do_Compute (Project : Project_Id; Tree : Project_Tree_Ref) is | |
2659 | Data : constant Builder_Data_Access := Builder_Data (Tree); | |
2660 | All_Phases : constant Boolean := | |
2661 | not Option_Compile_Only | |
2662 | and then not Option_Bind_Only | |
2663 | and then not Option_Link_Only; | |
2664 | -- Whether the command line asked for all three phases. Depending on | |
2665 | -- the project settings, we might still disable some of the phases. | |
2666 | ||
2667 | Has_Mains : constant Boolean := Data.Number_Of_Mains > 0; | |
2668 | -- Whether there are some main units defined for this project tree | |
2669 | -- (either from one of the projects, or from the command line) | |
2670 | ||
2671 | begin | |
2672 | if Option_Unique_Compile then | |
2673 | -- If -u or -U is specified on the command line, disregard any -c, | |
2674 | -- -b or -l switch: only perform compilation. | |
2675 | ||
2676 | Data.Closure_Needed := False; | |
2677 | Data.Need_Compilation := True; | |
2678 | Data.Need_Binding := False; | |
2679 | Data.Need_Linking := False; | |
2680 | ||
2681 | else | |
2682 | Data.Closure_Needed := Has_Mains; | |
2683 | Data.Need_Compilation := All_Phases or Option_Compile_Only; | |
2684 | Data.Need_Binding := All_Phases or Option_Bind_Only; | |
2685 | Data.Need_Linking := (All_Phases or Option_Link_Only) | |
2686 | and then Has_Mains; | |
2687 | end if; | |
2688 | ||
2689 | if Current_Verbosity = High then | |
2690 | Debug_Output ("Compilation phases: " | |
2691 | & " compile=" & Data.Need_Compilation'Img | |
2692 | & " bind=" & Data.Need_Binding'Img | |
2693 | & " link=" & Data.Need_Linking'Img | |
2694 | & " closure=" & Data.Closure_Needed'Img | |
2695 | & " mains=" & Data.Number_Of_Mains'Img, | |
2696 | Project.Name); | |
2697 | end if; | |
2698 | end Do_Compute; | |
2699 | ||
2700 | procedure Compute_All is new For_Project_And_Aggregated (Do_Compute); | |
2701 | begin | |
2702 | Compute_All (Root_Project, Tree); | |
2703 | end Compute_Compilation_Phases; | |
2704 | ||
8f9df7d8 | 2705 | end Makeutl; |