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