File : makeutl.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- M A K E U T L --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with ALI; use ALI;
27 with Atree; use Atree;
28 with Debug;
29 with Err_Vars; use Err_Vars;
30 with Errutil;
31 with Fname;
32 with Osint; use Osint;
33 with Output; use Output;
34 with Opt; use Opt;
35 with Prj.Com;
36 with Prj.Err;
37 with Prj.Ext;
38 with Prj.Util; use Prj.Util;
39 with Sinput.P;
40 with Tempdir;
41
42 with Ada.Command_Line; use Ada.Command_Line;
43 with Ada.Unchecked_Deallocation;
44
45 with GNAT.Case_Util; use GNAT.Case_Util;
46 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
47 with GNAT.HTable;
48 with GNAT.Regexp; use GNAT.Regexp;
49
50 package body Makeutl is
51
52 type Linker_Options_Data is record
53 Project : Project_Id;
54 Options : String_List_Id;
55 end record;
56
57 Linker_Option_Initial_Count : constant := 20;
58
59 Linker_Options_Buffer : String_List_Access :=
60 new String_List (1 .. Linker_Option_Initial_Count);
61
62 Last_Linker_Option : Natural := 0;
63
64 package Linker_Opts is new Table.Table (
65 Table_Component_Type => Linker_Options_Data,
66 Table_Index_Type => Integer,
67 Table_Low_Bound => 1,
68 Table_Initial => 10,
69 Table_Increment => 100,
70 Table_Name => "Make.Linker_Opts");
71
72 procedure Add_Linker_Option (Option : String);
73
74 ---------
75 -- Add --
76 ---------
77
78 procedure Add
79 (Option : String_Access;
80 To : in out String_List_Access;
81 Last : in out Natural)
82 is
83 begin
84 if Last = To'Last then
85 declare
86 New_Options : constant String_List_Access :=
87 new String_List (1 .. To'Last * 2);
88
89 begin
90 New_Options (To'Range) := To.all;
91
92 -- Set all elements of the original options to null to avoid
93 -- deallocation of copies.
94
95 To.all := (others => null);
96
97 Free (To);
98 To := New_Options;
99 end;
100 end if;
101
102 Last := Last + 1;
103 To (Last) := Option;
104 end Add;
105
106 procedure Add
107 (Option : String;
108 To : in out String_List_Access;
109 Last : in out Natural)
110 is
111 begin
112 Add (Option => new String'(Option), To => To, Last => Last);
113 end Add;
114
115 -----------------------
116 -- Add_Linker_Option --
117 -----------------------
118
119 procedure Add_Linker_Option (Option : String) is
120 begin
121 if Option'Length > 0 then
122 if Last_Linker_Option = Linker_Options_Buffer'Last then
123 declare
124 New_Buffer : constant String_List_Access :=
125 new String_List
126 (1 .. Linker_Options_Buffer'Last +
127 Linker_Option_Initial_Count);
128 begin
129 New_Buffer (Linker_Options_Buffer'Range) :=
130 Linker_Options_Buffer.all;
131 Linker_Options_Buffer.all := (others => null);
132 Free (Linker_Options_Buffer);
133 Linker_Options_Buffer := New_Buffer;
134 end;
135 end if;
136
137 Last_Linker_Option := Last_Linker_Option + 1;
138 Linker_Options_Buffer (Last_Linker_Option) := new String'(Option);
139 end if;
140 end Add_Linker_Option;
141
142 -------------------
143 -- Absolute_Path --
144 -------------------
145
146 function Absolute_Path
147 (Path : Path_Name_Type;
148 Project : Project_Id) return String
149 is
150 begin
151 Get_Name_String (Path);
152
153 declare
154 Path_Name : constant String := Name_Buffer (1 .. Name_Len);
155
156 begin
157 if Is_Absolute_Path (Path_Name) then
158 return Path_Name;
159
160 else
161 declare
162 Parent_Directory : constant String :=
163 Get_Name_String
164 (Project.Directory.Display_Name);
165
166 begin
167 return Parent_Directory & Path_Name;
168 end;
169 end if;
170 end;
171 end Absolute_Path;
172
173 ----------------------------
174 -- Aggregate_Libraries_In --
175 ----------------------------
176
177 function Aggregate_Libraries_In (Tree : Project_Tree_Ref) return Boolean is
178 List : Project_List;
179
180 begin
181 List := Tree.Projects;
182 while List /= null loop
183 if List.Project.Qualifier = Aggregate_Library then
184 return True;
185 end if;
186
187 List := List.Next;
188 end loop;
189
190 return False;
191 end Aggregate_Libraries_In;
192
193 -------------------------
194 -- Base_Name_Index_For --
195 -------------------------
196
197 function Base_Name_Index_For
198 (Main : String;
199 Main_Index : Int;
200 Index_Separator : Character) return File_Name_Type
201 is
202 Result : File_Name_Type;
203
204 begin
205 Name_Len := 0;
206 Add_Str_To_Name_Buffer (Base_Name (Main));
207
208 -- Remove the extension, if any, that is the last part of the base name
209 -- starting with a dot and following some characters.
210
211 for J in reverse 2 .. Name_Len loop
212 if Name_Buffer (J) = '.' then
213 Name_Len := J - 1;
214 exit;
215 end if;
216 end loop;
217
218 -- Add the index info, if index is different from 0
219
220 if Main_Index > 0 then
221 Add_Char_To_Name_Buffer (Index_Separator);
222
223 declare
224 Img : constant String := Main_Index'Img;
225 begin
226 Add_Str_To_Name_Buffer (Img (2 .. Img'Last));
227 end;
228 end if;
229
230 Result := Name_Find;
231 return Result;
232 end Base_Name_Index_For;
233
234 ------------------------------
235 -- Check_Source_Info_In_ALI --
236 ------------------------------
237
238 function Check_Source_Info_In_ALI
239 (The_ALI : ALI_Id;
240 Tree : Project_Tree_Ref) return Name_Id
241 is
242 Result : Name_Id := No_Name;
243 Unit_Name : Name_Id;
244
245 begin
246 -- Loop through units
247
248 for U in ALIs.Table (The_ALI).First_Unit ..
249 ALIs.Table (The_ALI).Last_Unit
250 loop
251 -- Check if the file name is one of the source of the unit
252
253 Get_Name_String (Units.Table (U).Uname);
254 Name_Len := Name_Len - 2;
255 Unit_Name := Name_Find;
256
257 if File_Not_A_Source_Of (Tree, Unit_Name, Units.Table (U).Sfile) then
258 return No_Name;
259 end if;
260
261 if Result = No_Name then
262 Result := Unit_Name;
263 end if;
264
265 -- Loop to do same check for each of the withed units
266
267 for W in Units.Table (U).First_With .. Units.Table (U).Last_With loop
268 declare
269 WR : ALI.With_Record renames Withs.Table (W);
270
271 begin
272 if WR.Sfile /= No_File then
273 Get_Name_String (WR.Uname);
274 Name_Len := Name_Len - 2;
275 Unit_Name := Name_Find;
276
277 if File_Not_A_Source_Of (Tree, Unit_Name, WR.Sfile) then
278 return No_Name;
279 end if;
280 end if;
281 end;
282 end loop;
283 end loop;
284
285 -- Loop to check subunits and replaced sources
286
287 for D in ALIs.Table (The_ALI).First_Sdep ..
288 ALIs.Table (The_ALI).Last_Sdep
289 loop
290 declare
291 SD : Sdep_Record renames Sdep.Table (D);
292
293 begin
294 Unit_Name := SD.Subunit_Name;
295
296 if Unit_Name = No_Name then
297
298 -- Check if this source file has been replaced by a source with
299 -- a different file name.
300
301 if Tree /= null and then Tree.Replaced_Source_Number > 0 then
302 declare
303 Replacement : constant File_Name_Type :=
304 Replaced_Source_HTable.Get
305 (Tree.Replaced_Sources, SD.Sfile);
306
307 begin
308 if Replacement /= No_File then
309 if Verbose_Mode then
310 Write_Line
311 ("source file"
312 & Get_Name_String (SD.Sfile)
313 & " has been replaced by "
314 & Get_Name_String (Replacement));
315 end if;
316
317 return No_Name;
318 end if;
319 end;
320 end if;
321
322 -- Check that a dependent source for a unit that is from a
323 -- project is indeed a source of this unit.
324
325 Unit_Name := SD.Unit_Name;
326
327 if Unit_Name /= No_Name
328 and then not Fname.Is_Internal_File_Name (SD.Sfile)
329 and then File_Not_A_Source_Of (Tree, Unit_Name, SD.Sfile)
330 then
331 return No_Name;
332 end if;
333
334 else
335 -- For separates, the file is no longer associated with the
336 -- unit ("proc-sep.adb" is not associated with unit "proc.sep")
337 -- so we need to check whether the source file still exists in
338 -- the source tree: it will if it matches the naming scheme
339 -- (and then will be for the same unit).
340
341 if Find_Source
342 (In_Tree => Tree,
343 Project => No_Project,
344 Base_Name => SD.Sfile) = No_Source
345 then
346 -- If this is not a runtime file or if, when gnatmake switch
347 -- -a is used, we are not able to find this subunit in the
348 -- source directories, then recompilation is needed.
349
350 if not Fname.Is_Internal_File_Name (SD.Sfile)
351 or else
352 (Check_Readonly_Files
353 and then Full_Source_Name (SD.Sfile) = No_File)
354 then
355 if Verbose_Mode then
356 Write_Line
357 ("While parsing ALI file, file "
358 & Get_Name_String (SD.Sfile)
359 & " is indicated as containing subunit "
360 & Get_Name_String (Unit_Name)
361 & " but this does not match what was found while"
362 & " parsing the project. Will recompile");
363 end if;
364
365 return No_Name;
366 end if;
367 end if;
368 end if;
369 end;
370 end loop;
371
372 return Result;
373 end Check_Source_Info_In_ALI;
374
375 --------------------------------
376 -- Create_Binder_Mapping_File --
377 --------------------------------
378
379 function Create_Binder_Mapping_File
380 (Project_Tree : Project_Tree_Ref) return Path_Name_Type
381 is
382 Mapping_Path : Path_Name_Type := No_Path;
383
384 Mapping_FD : File_Descriptor := Invalid_FD;
385 -- A File Descriptor for an eventual mapping file
386
387 ALI_Unit : Unit_Name_Type := No_Unit_Name;
388 -- The unit name of an ALI file
389
390 ALI_Name : File_Name_Type := No_File;
391 -- The file name of the ALI file
392
393 ALI_Project : Project_Id := No_Project;
394 -- The project of the ALI file
395
396 Bytes : Integer;
397 OK : Boolean := False;
398 Unit : Unit_Index;
399
400 Status : Boolean;
401 -- For call to Close
402
403 Iter : Source_Iterator := For_Each_Source
404 (In_Tree => Project_Tree,
405 Language => Name_Ada,
406 Encapsulated_Libs => False,
407 Locally_Removed => False);
408
409 Source : Prj.Source_Id;
410
411 begin
412 Tempdir.Create_Temp_File (Mapping_FD, Mapping_Path);
413 Record_Temp_File (Project_Tree.Shared, Mapping_Path);
414
415 if Mapping_FD /= Invalid_FD then
416 OK := True;
417
418 loop
419 Source := Element (Iter);
420 exit when Source = No_Source;
421
422 Unit := Source.Unit;
423
424 if Source.Replaced_By /= No_Source
425 or else Unit = No_Unit_Index
426 or else Unit.Name = No_Name
427 then
428 ALI_Name := No_File;
429
430 -- If this is a body, put it in the mapping
431
432 elsif Source.Kind = Impl
433 and then Unit.File_Names (Impl) /= No_Source
434 and then Unit.File_Names (Impl).Project /= No_Project
435 then
436 Get_Name_String (Unit.Name);
437 Add_Str_To_Name_Buffer ("%b");
438 ALI_Unit := Name_Find;
439 ALI_Name :=
440 Lib_File_Name (Unit.File_Names (Impl).Display_File);
441 ALI_Project := Unit.File_Names (Impl).Project;
442
443 -- Otherwise, if this is a spec and there is no body, put it in
444 -- the mapping.
445
446 elsif Source.Kind = Spec
447 and then Unit.File_Names (Impl) = No_Source
448 and then Unit.File_Names (Spec) /= No_Source
449 and then Unit.File_Names (Spec).Project /= No_Project
450 then
451 Get_Name_String (Unit.Name);
452 Add_Str_To_Name_Buffer ("%s");
453 ALI_Unit := Name_Find;
454 ALI_Name :=
455 Lib_File_Name (Unit.File_Names (Spec).Display_File);
456 ALI_Project := Unit.File_Names (Spec).Project;
457
458 else
459 ALI_Name := No_File;
460 end if;
461
462 -- If we have something to put in the mapping then do it now. If
463 -- the project is extended, look for the ALI file in the project,
464 -- then in the extending projects in order, and use the last one
465 -- found.
466
467 if ALI_Name /= No_File then
468
469 -- Look in the project and the projects that are extending it
470 -- to find the real ALI file.
471
472 declare
473 ALI : constant String := Get_Name_String (ALI_Name);
474 ALI_Path : Name_Id := No_Name;
475
476 begin
477 loop
478 -- For library projects, use the library ALI directory,
479 -- for other projects, use the object directory.
480
481 if ALI_Project.Library then
482 Get_Name_String
483 (ALI_Project.Library_ALI_Dir.Display_Name);
484 else
485 Get_Name_String
486 (ALI_Project.Object_Directory.Display_Name);
487 end if;
488
489 Add_Str_To_Name_Buffer (ALI);
490
491 if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then
492 ALI_Path := Name_Find;
493 end if;
494
495 ALI_Project := ALI_Project.Extended_By;
496 exit when ALI_Project = No_Project;
497 end loop;
498
499 if ALI_Path /= No_Name then
500
501 -- First line is the unit name
502
503 Get_Name_String (ALI_Unit);
504 Add_Char_To_Name_Buffer (ASCII.LF);
505 Bytes :=
506 Write
507 (Mapping_FD,
508 Name_Buffer (1)'Address,
509 Name_Len);
510 OK := Bytes = Name_Len;
511
512 exit when not OK;
513
514 -- Second line is the ALI file name
515
516 Get_Name_String (ALI_Name);
517 Add_Char_To_Name_Buffer (ASCII.LF);
518 Bytes :=
519 Write
520 (Mapping_FD,
521 Name_Buffer (1)'Address,
522 Name_Len);
523 OK := (Bytes = Name_Len);
524
525 exit when not OK;
526
527 -- Third line is the ALI path name
528
529 Get_Name_String (ALI_Path);
530 Add_Char_To_Name_Buffer (ASCII.LF);
531 Bytes :=
532 Write
533 (Mapping_FD,
534 Name_Buffer (1)'Address,
535 Name_Len);
536 OK := (Bytes = Name_Len);
537
538 -- If OK is False, it means we were unable to write a
539 -- line. No point in continuing with the other units.
540
541 exit when not OK;
542 end if;
543 end;
544 end if;
545
546 Next (Iter);
547 end loop;
548
549 Close (Mapping_FD, Status);
550
551 OK := OK and Status;
552 end if;
553
554 -- If the creation of the mapping file was successful, we add the switch
555 -- to the arguments of gnatbind.
556
557 if OK then
558 return Mapping_Path;
559
560 else
561 return No_Path;
562 end if;
563 end Create_Binder_Mapping_File;
564
565 -----------------
566 -- Create_Name --
567 -----------------
568
569 function Create_Name (Name : String) return File_Name_Type is
570 begin
571 Name_Len := 0;
572 Add_Str_To_Name_Buffer (Name);
573 return Name_Find;
574 end Create_Name;
575
576 function Create_Name (Name : String) return Name_Id is
577 begin
578 Name_Len := 0;
579 Add_Str_To_Name_Buffer (Name);
580 return Name_Find;
581 end Create_Name;
582
583 function Create_Name (Name : String) return Path_Name_Type is
584 begin
585 Name_Len := 0;
586 Add_Str_To_Name_Buffer (Name);
587 return Name_Find;
588 end Create_Name;
589
590 ---------------------------
591 -- Ensure_Absolute_Path --
592 ---------------------------
593
594 procedure Ensure_Absolute_Path
595 (Switch : in out String_Access;
596 Parent : String;
597 Do_Fail : Fail_Proc;
598 For_Gnatbind : Boolean := False;
599 Including_Non_Switch : Boolean := True;
600 Including_RTS : Boolean := False)
601 is
602 begin
603 if Switch /= null then
604 declare
605 Sw : String (1 .. Switch'Length);
606 Start : Positive;
607
608 begin
609 Sw := Switch.all;
610
611 if Sw (1) = '-' then
612 if Sw'Length >= 3
613 and then (Sw (2) = 'I'
614 or else (not For_Gnatbind
615 and then (Sw (2) = 'L'
616 or else
617 Sw (2) = 'A')))
618 then
619 Start := 3;
620
621 if Sw = "-I-" then
622 return;
623 end if;
624
625 elsif Sw'Length >= 4
626 and then
627 (Sw (2 .. 3) = "aL" or else
628 Sw (2 .. 3) = "aO" or else
629 Sw (2 .. 3) = "aI"
630 or else (For_Gnatbind and then Sw (2 .. 3) = "A="))
631 then
632 Start := 4;
633
634 elsif Including_RTS
635 and then Sw'Length >= 7
636 and then Sw (2 .. 6) = "-RTS="
637 then
638 Start := 7;
639
640 else
641 return;
642 end if;
643
644 -- Because relative path arguments to --RTS= may be relative to
645 -- the search directory prefix, those relative path arguments
646 -- are converted only when they include directory information.
647
648 if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then
649 if Parent'Length = 0 then
650 Do_Fail
651 ("relative search path switches ("""
652 & Sw
653 & """) are not allowed");
654
655 elsif Including_RTS then
656 for J in Start .. Sw'Last loop
657 if Sw (J) = Directory_Separator then
658 Switch :=
659 new String'
660 (Sw (1 .. Start - 1)
661 & Parent
662 & Directory_Separator
663 & Sw (Start .. Sw'Last));
664 return;
665 end if;
666 end loop;
667
668 else
669 Switch :=
670 new String'
671 (Sw (1 .. Start - 1)
672 & Parent
673 & Directory_Separator
674 & Sw (Start .. Sw'Last));
675 end if;
676 end if;
677
678 elsif Including_Non_Switch then
679 if not Is_Absolute_Path (Sw) then
680 if Parent'Length = 0 then
681 Do_Fail
682 ("relative paths (""" & Sw & """) are not allowed");
683 else
684 Switch := new String'(Parent & Directory_Separator & Sw);
685 end if;
686 end if;
687 end if;
688 end;
689 end if;
690 end Ensure_Absolute_Path;
691
692 ----------------------------
693 -- Executable_Prefix_Path --
694 ----------------------------
695
696 function Executable_Prefix_Path return String is
697 Exec_Name : constant String := Command_Name;
698
699 function Get_Install_Dir (S : String) return String;
700 -- S is the executable name preceded by the absolute or relative path,
701 -- e.g. "c:\usr\bin\gcc.exe". Returns the absolute directory where "bin"
702 -- lies (in the example "C:\usr"). If the executable is not in a "bin"
703 -- directory, return "".
704
705 ---------------------
706 -- Get_Install_Dir --
707 ---------------------
708
709 function Get_Install_Dir (S : String) return String is
710 Exec : String := S;
711 Path_Last : Integer := 0;
712
713 begin
714 for J in reverse Exec'Range loop
715 if Exec (J) = Directory_Separator then
716 Path_Last := J - 1;
717 exit;
718 end if;
719 end loop;
720
721 if Path_Last >= Exec'First + 2 then
722 To_Lower (Exec (Path_Last - 2 .. Path_Last));
723 end if;
724
725 if Path_Last < Exec'First + 2
726 or else Exec (Path_Last - 2 .. Path_Last) /= "bin"
727 or else (Path_Last - 3 >= Exec'First
728 and then Exec (Path_Last - 3) /= Directory_Separator)
729 then
730 return "";
731 end if;
732
733 return Normalize_Pathname
734 (Exec (Exec'First .. Path_Last - 4),
735 Resolve_Links => Opt.Follow_Links_For_Dirs)
736 & Directory_Separator;
737 end Get_Install_Dir;
738
739 -- Beginning of Executable_Prefix_Path
740
741 begin
742 -- First determine if a path prefix was placed in front of the
743 -- executable name.
744
745 for J in reverse Exec_Name'Range loop
746 if Exec_Name (J) = Directory_Separator then
747 return Get_Install_Dir (Exec_Name);
748 end if;
749 end loop;
750
751 -- If we get here, the user has typed the executable name with no
752 -- directory prefix.
753
754 declare
755 Path : String_Access := Locate_Exec_On_Path (Exec_Name);
756 begin
757 if Path = null then
758 return "";
759 else
760 declare
761 Dir : constant String := Get_Install_Dir (Path.all);
762 begin
763 Free (Path);
764 return Dir;
765 end;
766 end if;
767 end;
768 end Executable_Prefix_Path;
769
770 ------------------
771 -- Fail_Program --
772 ------------------
773
774 procedure Fail_Program
775 (Project_Tree : Project_Tree_Ref;
776 S : String;
777 Flush_Messages : Boolean := True)
778 is
779 begin
780 if Flush_Messages and not No_Exit_Message then
781 if Total_Errors_Detected /= 0 or else Warnings_Detected /= 0 then
782 Errutil.Finalize;
783 end if;
784 end if;
785
786 Finish_Program (Project_Tree, E_Fatal, S => S);
787 end Fail_Program;
788
789 --------------------
790 -- Finish_Program --
791 --------------------
792
793 procedure Finish_Program
794 (Project_Tree : Project_Tree_Ref;
795 Exit_Code : Osint.Exit_Code_Type := Osint.E_Success;
796 S : String := "")
797 is
798 begin
799 if not Debug.Debug_Flag_N then
800 Delete_Temp_Config_Files (Project_Tree);
801
802 if Project_Tree /= null then
803 Delete_All_Temp_Files (Project_Tree.Shared);
804 end if;
805 end if;
806
807 if S'Length > 0 then
808 if Exit_Code /= E_Success then
809 if No_Exit_Message then
810 Osint.Exit_Program (E_Fatal);
811 else
812 Osint.Fail (S);
813 end if;
814
815 elsif not No_Exit_Message then
816 Write_Str (S);
817 end if;
818 end if;
819
820 -- Output Namet statistics
821
822 Namet.Finalize;
823
824 Exit_Program (Exit_Code);
825 end Finish_Program;
826
827 --------------------------
828 -- File_Not_A_Source_Of --
829 --------------------------
830
831 function File_Not_A_Source_Of
832 (Project_Tree : Project_Tree_Ref;
833 Uname : Name_Id;
834 Sfile : File_Name_Type) return Boolean
835 is
836 Unit : constant Unit_Index :=
837 Units_Htable.Get (Project_Tree.Units_HT, Uname);
838
839 At_Least_One_File : Boolean := False;
840
841 begin
842 if Unit /= No_Unit_Index then
843 for F in Unit.File_Names'Range loop
844 if Unit.File_Names (F) /= null then
845 At_Least_One_File := True;
846 if Unit.File_Names (F).File = Sfile then
847 return False;
848 end if;
849 end if;
850 end loop;
851
852 if not At_Least_One_File then
853
854 -- The unit was probably created initially for a separate unit
855 -- (which are initially created as IMPL when both suffixes are the
856 -- same). Later on, Override_Kind changed the type of the file,
857 -- and the unit is no longer valid in fact.
858
859 return False;
860 end if;
861
862 Verbose_Msg (Uname, "sources do not include ", Name_Id (Sfile));
863 return True;
864 end if;
865
866 return False;
867 end File_Not_A_Source_Of;
868
869 ---------------------
870 -- Get_Directories --
871 ---------------------
872
873 procedure Get_Directories
874 (Project_Tree : Project_Tree_Ref;
875 For_Project : Project_Id;
876 Activity : Activity_Type;
877 Languages : Name_Ids)
878 is
879
880 procedure Recursive_Add
881 (Project : Project_Id;
882 Tree : Project_Tree_Ref;
883 Extended : in out Boolean);
884 -- Add all the source directories of a project to the path only if
885 -- this project has not been visited. Calls itself recursively for
886 -- projects being extended, and imported projects.
887
888 procedure Add_Dir (Value : Path_Name_Type);
889 -- Add directory Value in table Directories, if it is defined and not
890 -- already there.
891
892 -------------
893 -- Add_Dir --
894 -------------
895
896 procedure Add_Dir (Value : Path_Name_Type) is
897 Add_It : Boolean := True;
898
899 begin
900 if Value /= No_Path
901 and then Is_Directory (Get_Name_String (Value))
902 then
903 for Index in 1 .. Directories.Last loop
904 if Directories.Table (Index) = Value then
905 Add_It := False;
906 exit;
907 end if;
908 end loop;
909
910 if Add_It then
911 Directories.Increment_Last;
912 Directories.Table (Directories.Last) := Value;
913 end if;
914 end if;
915 end Add_Dir;
916
917 -------------------
918 -- Recursive_Add --
919 -------------------
920
921 procedure Recursive_Add
922 (Project : Project_Id;
923 Tree : Project_Tree_Ref;
924 Extended : in out Boolean)
925 is
926 Current : String_List_Id;
927 Dir : String_Element;
928 OK : Boolean := False;
929 Lang_Proc : Language_Ptr := Project.Languages;
930
931 begin
932 -- Add to path all directories of this project
933
934 if Activity = Compilation then
935 Lang_Loop :
936 while Lang_Proc /= No_Language_Index loop
937 for J in Languages'Range loop
938 OK := Lang_Proc.Name = Languages (J);
939 exit Lang_Loop when OK;
940 end loop;
941
942 Lang_Proc := Lang_Proc.Next;
943 end loop Lang_Loop;
944
945 if OK then
946 Current := Project.Source_Dirs;
947
948 while Current /= Nil_String loop
949 Dir := Tree.Shared.String_Elements.Table (Current);
950 Add_Dir (Path_Name_Type (Dir.Value));
951 Current := Dir.Next;
952 end loop;
953 end if;
954
955 elsif Project.Library then
956 if Activity = SAL_Binding and then Extended then
957 Add_Dir (Project.Object_Directory.Display_Name);
958
959 else
960 Add_Dir (Project.Library_ALI_Dir.Display_Name);
961 end if;
962
963 else
964 Add_Dir (Project.Object_Directory.Display_Name);
965 end if;
966
967 if Project.Extends = No_Project then
968 Extended := False;
969 end if;
970 end Recursive_Add;
971
972 procedure For_All_Projects is
973 new For_Every_Project_Imported (Boolean, Recursive_Add);
974
975 Extended : Boolean := True;
976
977 -- Start of processing for Get_Directories
978
979 begin
980 Directories.Init;
981 For_All_Projects (For_Project, Project_Tree, Extended);
982 end Get_Directories;
983
984 ------------------
985 -- Get_Switches --
986 ------------------
987
988 procedure Get_Switches
989 (Source : Prj.Source_Id;
990 Pkg_Name : Name_Id;
991 Project_Tree : Project_Tree_Ref;
992 Value : out Variable_Value;
993 Is_Default : out Boolean)
994 is
995 begin
996 Get_Switches
997 (Source_File => Source.File,
998 Source_Lang => Source.Language.Name,
999 Source_Prj => Source.Project,
1000 Pkg_Name => Pkg_Name,
1001 Project_Tree => Project_Tree,
1002 Value => Value,
1003 Is_Default => Is_Default);
1004 end Get_Switches;
1005
1006 ------------------
1007 -- Get_Switches --
1008 ------------------
1009
1010 procedure Get_Switches
1011 (Source_File : File_Name_Type;
1012 Source_Lang : Name_Id;
1013 Source_Prj : Project_Id;
1014 Pkg_Name : Name_Id;
1015 Project_Tree : Project_Tree_Ref;
1016 Value : out Variable_Value;
1017 Is_Default : out Boolean;
1018 Test_Without_Suffix : Boolean := False;
1019 Check_ALI_Suffix : Boolean := False)
1020 is
1021 Project : constant Project_Id :=
1022 Ultimate_Extending_Project_Of (Source_Prj);
1023 Pkg : constant Package_Id :=
1024 Prj.Util.Value_Of
1025 (Name => Pkg_Name,
1026 In_Packages => Project.Decl.Packages,
1027 Shared => Project_Tree.Shared);
1028 Lang : Language_Ptr;
1029
1030 begin
1031 Is_Default := False;
1032
1033 if Source_File /= No_File then
1034 Value := Prj.Util.Value_Of
1035 (Name => Name_Id (Source_File),
1036 Attribute_Or_Array_Name => Name_Switches,
1037 In_Package => Pkg,
1038 Shared => Project_Tree.Shared,
1039 Allow_Wildcards => True);
1040 end if;
1041
1042 if Value = Nil_Variable_Value and then Test_Without_Suffix then
1043 Lang :=
1044 Get_Language_From_Name (Project, Get_Name_String (Source_Lang));
1045
1046 if Lang /= null then
1047 declare
1048 Naming : Lang_Naming_Data renames Lang.Config.Naming_Data;
1049 SF_Name : constant String := Get_Name_String (Source_File);
1050 Last : Positive := SF_Name'Length;
1051 Name : String (1 .. Last + 3);
1052 Spec_Suffix : String := Get_Name_String (Naming.Spec_Suffix);
1053 Body_Suffix : String := Get_Name_String (Naming.Body_Suffix);
1054 Truncated : Boolean := False;
1055
1056 begin
1057 Canonical_Case_File_Name (Spec_Suffix);
1058 Canonical_Case_File_Name (Body_Suffix);
1059 Name (1 .. Last) := SF_Name;
1060
1061 if Last > Body_Suffix'Length
1062 and then
1063 Name (Last - Body_Suffix'Length + 1 .. Last) = Body_Suffix
1064 then
1065 Truncated := True;
1066 Last := Last - Body_Suffix'Length;
1067 end if;
1068
1069 if not Truncated
1070 and then Last > Spec_Suffix'Length
1071 and then
1072 Name (Last - Spec_Suffix'Length + 1 .. Last) = Spec_Suffix
1073 then
1074 Truncated := True;
1075 Last := Last - Spec_Suffix'Length;
1076 end if;
1077
1078 if Truncated then
1079 Name_Len := 0;
1080 Add_Str_To_Name_Buffer (Name (1 .. Last));
1081
1082 Value := Prj.Util.Value_Of
1083 (Name => Name_Find,
1084 Attribute_Or_Array_Name => Name_Switches,
1085 In_Package => Pkg,
1086 Shared => Project_Tree.Shared,
1087 Allow_Wildcards => True);
1088 end if;
1089
1090 if Value = Nil_Variable_Value and then Check_ALI_Suffix then
1091 Last := SF_Name'Length;
1092 while Name (Last) /= '.' loop
1093 Last := Last - 1;
1094 end loop;
1095
1096 Name_Len := 0;
1097 Add_Str_To_Name_Buffer (Name (1 .. Last));
1098 Add_Str_To_Name_Buffer ("ali");
1099
1100 Value := Prj.Util.Value_Of
1101 (Name => Name_Find,
1102 Attribute_Or_Array_Name => Name_Switches,
1103 In_Package => Pkg,
1104 Shared => Project_Tree.Shared,
1105 Allow_Wildcards => True);
1106 end if;
1107 end;
1108 end if;
1109 end if;
1110
1111 if Value = Nil_Variable_Value then
1112 Is_Default := True;
1113 Value :=
1114 Prj.Util.Value_Of
1115 (Name => Source_Lang,
1116 Attribute_Or_Array_Name => Name_Switches,
1117 In_Package => Pkg,
1118 Shared => Project_Tree.Shared,
1119 Force_Lower_Case_Index => True);
1120 end if;
1121
1122 if Value = Nil_Variable_Value then
1123 Value :=
1124 Prj.Util.Value_Of
1125 (Name => All_Other_Names,
1126 Attribute_Or_Array_Name => Name_Switches,
1127 In_Package => Pkg,
1128 Shared => Project_Tree.Shared,
1129 Force_Lower_Case_Index => True);
1130 end if;
1131
1132 if Value = Nil_Variable_Value then
1133 Value :=
1134 Prj.Util.Value_Of
1135 (Name => Source_Lang,
1136 Attribute_Or_Array_Name => Name_Default_Switches,
1137 In_Package => Pkg,
1138 Shared => Project_Tree.Shared);
1139 end if;
1140 end Get_Switches;
1141
1142 ------------
1143 -- Inform --
1144 ------------
1145
1146 procedure Inform (N : File_Name_Type; Msg : String) is
1147 begin
1148 Inform (Name_Id (N), Msg);
1149 end Inform;
1150
1151 procedure Inform (N : Name_Id := No_Name; Msg : String) is
1152 begin
1153 Osint.Write_Program_Name;
1154
1155 Write_Str (": ");
1156
1157 if N /= No_Name then
1158 Write_Str ("""");
1159
1160 declare
1161 Name : constant String := Get_Name_String (N);
1162 begin
1163 if Debug.Debug_Flag_F and then Is_Absolute_Path (Name) then
1164 Write_Str (File_Name (Name));
1165 else
1166 Write_Str (Name);
1167 end if;
1168 end;
1169
1170 Write_Str (""" ");
1171 end if;
1172
1173 Write_Str (Msg);
1174 Write_Eol;
1175 end Inform;
1176
1177 ------------------------------
1178 -- Initialize_Source_Record --
1179 ------------------------------
1180
1181 procedure Initialize_Source_Record (Source : Prj.Source_Id) is
1182
1183 procedure Set_Object_Project
1184 (Obj_Dir : String;
1185 Obj_Proj : Project_Id;
1186 Obj_Path : Path_Name_Type;
1187 Stamp : Time_Stamp_Type);
1188 -- Update information about object file, switches file,...
1189
1190 ------------------------
1191 -- Set_Object_Project --
1192 ------------------------
1193
1194 procedure Set_Object_Project
1195 (Obj_Dir : String;
1196 Obj_Proj : Project_Id;
1197 Obj_Path : Path_Name_Type;
1198 Stamp : Time_Stamp_Type) is
1199 begin
1200 Source.Object_Project := Obj_Proj;
1201 Source.Object_Path := Obj_Path;
1202 Source.Object_TS := Stamp;
1203
1204 if Source.Language.Config.Dependency_Kind /= None then
1205 declare
1206 Dep_Path : constant String :=
1207 Normalize_Pathname
1208 (Name =>
1209 Get_Name_String (Source.Dep_Name),
1210 Resolve_Links => Opt.Follow_Links_For_Files,
1211 Directory => Obj_Dir);
1212 begin
1213 Source.Dep_Path := Create_Name (Dep_Path);
1214 Source.Dep_TS := Osint.Unknown_Attributes;
1215 end;
1216 end if;
1217
1218 -- Get the path of the switches file, even if Opt.Check_Switches is
1219 -- not set, as switch -s may be in the Builder switches that have not
1220 -- been scanned yet.
1221
1222 declare
1223 Switches_Path : constant String :=
1224 Normalize_Pathname
1225 (Name =>
1226 Get_Name_String (Source.Switches),
1227 Resolve_Links => Opt.Follow_Links_For_Files,
1228 Directory => Obj_Dir);
1229 begin
1230 Source.Switches_Path := Create_Name (Switches_Path);
1231
1232 if Stamp /= Empty_Time_Stamp then
1233 Source.Switches_TS := File_Stamp (Source.Switches_Path);
1234 end if;
1235 end;
1236 end Set_Object_Project;
1237
1238 Obj_Proj : Project_Id;
1239
1240 begin
1241 -- Nothing to do if source record has already been fully initialized
1242
1243 if Source.Initialized then
1244 return;
1245 end if;
1246
1247 -- Systematically recompute the time stamp
1248
1249 Source.Source_TS := File_Stamp (Source.Path.Display_Name);
1250
1251 -- Parse the source file to check whether we have a subunit
1252
1253 if Source.Language.Config.Kind = Unit_Based
1254 and then Source.Kind = Impl
1255 and then Is_Subunit (Source)
1256 then
1257 Source.Kind := Sep;
1258 end if;
1259
1260 if Source.Language.Config.Object_Generated
1261 and then Is_Compilable (Source)
1262 then
1263 -- First, get the correct object file name and dependency file name
1264 -- if the source is in a multi-unit file.
1265
1266 if Source.Index /= 0 then
1267 Source.Object :=
1268 Object_Name
1269 (Source_File_Name => Source.File,
1270 Source_Index => Source.Index,
1271 Index_Separator =>
1272 Source.Language.Config.Multi_Unit_Object_Separator,
1273 Object_File_Suffix =>
1274 Source.Language.Config.Object_File_Suffix);
1275
1276 Source.Dep_Name :=
1277 Dependency_Name
1278 (Source.Object, Source.Language.Config.Dependency_Kind);
1279 end if;
1280
1281 -- Find the object file for that source. It could be either in the
1282 -- current project or in an extended project (it might actually not
1283 -- exist yet in the ultimate extending project, but if not found
1284 -- elsewhere that's where we'll expect to find it).
1285
1286 Obj_Proj := Source.Project;
1287
1288 while Obj_Proj /= No_Project loop
1289 if Obj_Proj.Object_Directory /= No_Path_Information then
1290 declare
1291 Dir : constant String :=
1292 Get_Name_String (Obj_Proj.Object_Directory.Display_Name);
1293
1294 Object_Path : constant String :=
1295 Normalize_Pathname
1296 (Name => Get_Name_String (Source.Object),
1297 Resolve_Links => Opt.Follow_Links_For_Files,
1298 Directory => Dir);
1299
1300 Obj_Path : constant Path_Name_Type :=
1301 Create_Name (Object_Path);
1302
1303 Stamp : Time_Stamp_Type := Empty_Time_Stamp;
1304
1305 begin
1306 -- For specs, we do not check object files if there is a
1307 -- body. This saves a system call. On the other hand, we do
1308 -- need to know the object_path, in case the user has passed
1309 -- the .ads on the command line to compile the spec only.
1310
1311 if Source.Kind /= Spec
1312 or else Source.Unit = No_Unit_Index
1313 or else Source.Unit.File_Names (Impl) = No_Source
1314 then
1315 Stamp := File_Stamp (Obj_Path);
1316 end if;
1317
1318 if Stamp /= Empty_Time_Stamp
1319 or else (Obj_Proj.Extended_By = No_Project
1320 and then Source.Object_Project = No_Project)
1321 then
1322 Set_Object_Project (Dir, Obj_Proj, Obj_Path, Stamp);
1323 end if;
1324 end;
1325 end if;
1326
1327 Obj_Proj := Obj_Proj.Extended_By;
1328 end loop;
1329
1330 elsif Source.Language.Config.Dependency_Kind = Makefile then
1331 declare
1332 Object_Dir : constant String :=
1333 Get_Name_String (Source.Project.Object_Directory.Display_Name);
1334 Dep_Path : constant String :=
1335 Normalize_Pathname
1336 (Name => Get_Name_String (Source.Dep_Name),
1337 Resolve_Links => Opt.Follow_Links_For_Files,
1338 Directory => Object_Dir);
1339 begin
1340 Source.Dep_Path := Create_Name (Dep_Path);
1341 Source.Dep_TS := Osint.Unknown_Attributes;
1342 end;
1343 end if;
1344
1345 Source.Initialized := True;
1346 end Initialize_Source_Record;
1347
1348 ----------------------------
1349 -- Is_External_Assignment --
1350 ----------------------------
1351
1352 function Is_External_Assignment
1353 (Env : Prj.Tree.Environment;
1354 Argv : String) return Boolean
1355 is
1356 Start : Positive := 3;
1357 Finish : Natural := Argv'Last;
1358
1359 pragma Assert (Argv'First = 1);
1360 pragma Assert (Argv (1 .. 2) = "-X");
1361
1362 begin
1363 if Argv'Last < 5 then
1364 return False;
1365
1366 elsif Argv (3) = '"' then
1367 if Argv (Argv'Last) /= '"' or else Argv'Last < 7 then
1368 return False;
1369 else
1370 Start := 4;
1371 Finish := Argv'Last - 1;
1372 end if;
1373 end if;
1374
1375 return Prj.Ext.Check
1376 (Self => Env.External,
1377 Declaration => Argv (Start .. Finish));
1378 end Is_External_Assignment;
1379
1380 ----------------
1381 -- Is_Subunit --
1382 ----------------
1383
1384 function Is_Subunit (Source : Prj.Source_Id) return Boolean is
1385 Src_Ind : Source_File_Index;
1386
1387 begin
1388 if Source.Kind = Sep then
1389 return True;
1390
1391 -- A Spec, a file based language source or a body with a spec cannot be
1392 -- a subunit.
1393
1394 elsif Source.Kind = Spec
1395 or else Source.Unit = No_Unit_Index
1396 or else Other_Part (Source) /= No_Source
1397 then
1398 return False;
1399 end if;
1400
1401 -- Here, we are assuming that the language is Ada, as it is the only
1402 -- unit based language that we know.
1403
1404 Src_Ind :=
1405 Sinput.P.Load_Project_File
1406 (Get_Name_String (Source.Path.Display_Name));
1407
1408 return Sinput.P.Source_File_Is_Subunit (Src_Ind);
1409 end Is_Subunit;
1410
1411 -----------------------------
1412 -- Linker_Options_Switches --
1413 -----------------------------
1414
1415 function Linker_Options_Switches
1416 (Project : Project_Id;
1417 Do_Fail : Fail_Proc;
1418 In_Tree : Project_Tree_Ref) return String_List
1419 is
1420 procedure Recursive_Add
1421 (Proj : Project_Id;
1422 In_Tree : Project_Tree_Ref;
1423 Dummy : in out Boolean);
1424 -- The recursive routine used to add linker options
1425
1426 -------------------
1427 -- Recursive_Add --
1428 -------------------
1429
1430 procedure Recursive_Add
1431 (Proj : Project_Id;
1432 In_Tree : Project_Tree_Ref;
1433 Dummy : in out Boolean)
1434 is
1435 Linker_Package : Package_Id;
1436 Options : Variable_Value;
1437
1438 begin
1439 Linker_Package :=
1440 Prj.Util.Value_Of
1441 (Name => Name_Linker,
1442 In_Packages => Proj.Decl.Packages,
1443 Shared => In_Tree.Shared);
1444
1445 Options :=
1446 Prj.Util.Value_Of
1447 (Name => Name_Ada,
1448 Index => 0,
1449 Attribute_Or_Array_Name => Name_Linker_Options,
1450 In_Package => Linker_Package,
1451 Shared => In_Tree.Shared);
1452
1453 -- If attribute is present, add the project with the attribute to
1454 -- table Linker_Opts.
1455
1456 if Options /= Nil_Variable_Value then
1457 Linker_Opts.Increment_Last;
1458 Linker_Opts.Table (Linker_Opts.Last) :=
1459 (Project => Proj, Options => Options.Values);
1460 end if;
1461 end Recursive_Add;
1462
1463 procedure For_All_Projects is
1464 new For_Every_Project_Imported (Boolean, Recursive_Add);
1465
1466 Dummy : Boolean := False;
1467
1468 -- Start of processing for Linker_Options_Switches
1469
1470 begin
1471 Linker_Opts.Init;
1472
1473 For_All_Projects (Project, In_Tree, Dummy, Imported_First => True);
1474
1475 Last_Linker_Option := 0;
1476
1477 for Index in reverse 1 .. Linker_Opts.Last loop
1478 declare
1479 Options : String_List_Id;
1480 Proj : constant Project_Id :=
1481 Linker_Opts.Table (Index).Project;
1482 Option : Name_Id;
1483 Dir_Path : constant String :=
1484 Get_Name_String (Proj.Directory.Name);
1485
1486 begin
1487 Options := Linker_Opts.Table (Index).Options;
1488 while Options /= Nil_String loop
1489 Option := In_Tree.Shared.String_Elements.Table (Options).Value;
1490 Get_Name_String (Option);
1491
1492 -- Do not consider empty linker options
1493
1494 if Name_Len /= 0 then
1495 Add_Linker_Option (Name_Buffer (1 .. Name_Len));
1496
1497 -- Object files and -L switches specified with relative
1498 -- paths must be converted to absolute paths.
1499
1500 Ensure_Absolute_Path
1501 (Switch =>
1502 Linker_Options_Buffer (Last_Linker_Option),
1503 Parent => Dir_Path,
1504 Do_Fail => Do_Fail,
1505 For_Gnatbind => False);
1506 end if;
1507
1508 Options := In_Tree.Shared.String_Elements.Table (Options).Next;
1509 end loop;
1510 end;
1511 end loop;
1512
1513 return Linker_Options_Buffer (1 .. Last_Linker_Option);
1514 end Linker_Options_Switches;
1515
1516 -----------
1517 -- Mains --
1518 -----------
1519
1520 package body Mains is
1521
1522 package Names is new Table.Table
1523 (Table_Component_Type => Main_Info,
1524 Table_Index_Type => Integer,
1525 Table_Low_Bound => 1,
1526 Table_Initial => 10,
1527 Table_Increment => 100,
1528 Table_Name => "Makeutl.Mains.Names");
1529 -- The table that stores the mains
1530
1531 Current : Natural := 0;
1532 -- The index of the last main retrieved from the table
1533
1534 Count_Of_Mains_With_No_Tree : Natural := 0;
1535 -- Number of main units for which we do not know the project tree
1536
1537 --------------
1538 -- Add_Main --
1539 --------------
1540
1541 procedure Add_Main
1542 (Name : String;
1543 Index : Int := 0;
1544 Location : Source_Ptr := No_Location;
1545 Project : Project_Id := No_Project;
1546 Tree : Project_Tree_Ref := null)
1547 is
1548 begin
1549 if Current_Verbosity = High then
1550 Debug_Output ("Add_Main """ & Name & """ " & Index'Img
1551 & " with_tree? "
1552 & Boolean'Image (Tree /= null));
1553 end if;
1554
1555 Name_Len := 0;
1556 Add_Str_To_Name_Buffer (Name);
1557 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
1558
1559 Names.Increment_Last;
1560 Names.Table (Names.Last) :=
1561 (Name_Find, Index, Location, No_Source, Project, Tree);
1562
1563 if Tree /= null then
1564 Builder_Data (Tree).Number_Of_Mains :=
1565 Builder_Data (Tree).Number_Of_Mains + 1;
1566
1567 else
1568 Mains.Count_Of_Mains_With_No_Tree :=
1569 Mains.Count_Of_Mains_With_No_Tree + 1;
1570 end if;
1571 end Add_Main;
1572
1573 --------------------
1574 -- Complete_Mains --
1575 --------------------
1576
1577 procedure Complete_Mains
1578 (Flags : Processing_Flags;
1579 Root_Project : Project_Id;
1580 Project_Tree : Project_Tree_Ref)
1581 is
1582 procedure Do_Complete (Project : Project_Id; Tree : Project_Tree_Ref);
1583 -- Check the mains for this specific project
1584
1585 procedure Complete_All is new For_Project_And_Aggregated
1586 (Do_Complete);
1587
1588 procedure Add_Multi_Unit_Sources
1589 (Tree : Project_Tree_Ref;
1590 Source : Prj.Source_Id);
1591 -- Add all units from the same file as the multi-unit Source
1592
1593 function Find_File_Add_Extension
1594 (Tree : Project_Tree_Ref;
1595 Base_Main : String) return Prj.Source_Id;
1596 -- Search for Main in the project, adding body or spec extensions
1597
1598 ----------------------------
1599 -- Add_Multi_Unit_Sources --
1600 ----------------------------
1601
1602 procedure Add_Multi_Unit_Sources
1603 (Tree : Project_Tree_Ref;
1604 Source : Prj.Source_Id)
1605 is
1606 Iter : Source_Iterator;
1607 Src : Prj.Source_Id;
1608
1609 begin
1610 Debug_Output
1611 ("found multi-unit source file in project", Source.Project.Name);
1612
1613 Iter := For_Each_Source
1614 (In_Tree => Tree, Project => Source.Project);
1615
1616 while Element (Iter) /= No_Source loop
1617 Src := Element (Iter);
1618
1619 if Src.File = Source.File
1620 and then Src.Index /= Source.Index
1621 then
1622 if Src.File = Source.File then
1623 Debug_Output
1624 ("add main in project, index=" & Src.Index'Img);
1625 end if;
1626
1627 Names.Increment_Last;
1628 Names.Table (Names.Last) :=
1629 (File => Src.File,
1630 Index => Src.Index,
1631 Location => No_Location,
1632 Source => Src,
1633 Project => Src.Project,
1634 Tree => Tree);
1635
1636 Builder_Data (Tree).Number_Of_Mains :=
1637 Builder_Data (Tree).Number_Of_Mains + 1;
1638 end if;
1639
1640 Next (Iter);
1641 end loop;
1642 end Add_Multi_Unit_Sources;
1643
1644 -----------------------------
1645 -- Find_File_Add_Extension --
1646 -----------------------------
1647
1648 function Find_File_Add_Extension
1649 (Tree : Project_Tree_Ref;
1650 Base_Main : String) return Prj.Source_Id
1651 is
1652 Spec_Source : Prj.Source_Id := No_Source;
1653 Source : Prj.Source_Id;
1654 Iter : Source_Iterator;
1655 Suffix : File_Name_Type;
1656
1657 begin
1658 Source := No_Source;
1659 Iter := For_Each_Source (Tree); -- In all projects
1660 loop
1661 Source := Prj.Element (Iter);
1662 exit when Source = No_Source;
1663
1664 if Source.Kind = Impl then
1665 Get_Name_String (Source.File);
1666
1667 if Name_Len > Base_Main'Length
1668 and then Name_Buffer (1 .. Base_Main'Length) = Base_Main
1669 then
1670 Suffix :=
1671 Source.Language.Config.Naming_Data.Body_Suffix;
1672
1673 if Suffix /= No_File then
1674 declare
1675 Suffix_Str : String := Get_Name_String (Suffix);
1676 begin
1677 Canonical_Case_File_Name (Suffix_Str);
1678 exit when
1679 Name_Buffer (Base_Main'Length + 1 .. Name_Len) =
1680 Suffix_Str;
1681 end;
1682 end if;
1683 end if;
1684
1685 elsif Source.Kind = Spec
1686 and then Source.Language.Config.Kind = Unit_Based
1687 then
1688 -- An Ada spec needs to be taken into account unless there
1689 -- is also a body. So we delay the decision for them.
1690
1691 Get_Name_String (Source.File);
1692
1693 if Name_Len > Base_Main'Length
1694 and then Name_Buffer (1 .. Base_Main'Length) = Base_Main
1695 then
1696 Suffix := Source.Language.Config.Naming_Data.Spec_Suffix;
1697
1698 if Suffix /= No_File then
1699 declare
1700 Suffix_Str : String := Get_Name_String (Suffix);
1701
1702 begin
1703 Canonical_Case_File_Name (Suffix_Str);
1704
1705 if Name_Buffer (Base_Main'Length + 1 .. Name_Len) =
1706 Suffix_Str
1707 then
1708 Spec_Source := Source;
1709 end if;
1710 end;
1711 end if;
1712 end if;
1713 end if;
1714
1715 Next (Iter);
1716 end loop;
1717
1718 if Source = No_Source then
1719 Source := Spec_Source;
1720 end if;
1721
1722 return Source;
1723 end Find_File_Add_Extension;
1724
1725 -----------------
1726 -- Do_Complete --
1727 -----------------
1728
1729 procedure Do_Complete
1730 (Project : Project_Id; Tree : Project_Tree_Ref)
1731 is
1732 J : Integer;
1733
1734 begin
1735 if Mains.Number_Of_Mains (Tree) > 0
1736 or else Mains.Count_Of_Mains_With_No_Tree > 0
1737 then
1738 -- Traverse in reverse order, since in the case of multi-unit
1739 -- files we will be adding extra files at the end, and there's
1740 -- no need to process them in turn.
1741
1742 J := Names.Last;
1743 Main_Loop : loop
1744 declare
1745 File : Main_Info := Names.Table (J);
1746 Main_Id : File_Name_Type := File.File;
1747 Main : constant String :=
1748 Get_Name_String (Main_Id);
1749 Base : constant String := Base_Name (Main);
1750 Source : Prj.Source_Id := No_Source;
1751 Is_Absolute : Boolean := False;
1752
1753 begin
1754 if Base /= Main then
1755 Is_Absolute := True;
1756
1757 if Is_Absolute_Path (Main) then
1758 Main_Id := Create_Name (Base);
1759
1760 -- Not an absolute path
1761
1762 else
1763 -- Always resolve links here, so that users can be
1764 -- specify any name on the command line. If the
1765 -- project itself uses links, the user will be
1766 -- using -eL anyway, and thus files are also stored
1767 -- with resolved names.
1768
1769 declare
1770 Absolute : constant String :=
1771 Normalize_Pathname
1772 (Name => Main,
1773 Directory => "",
1774 Resolve_Links => True,
1775 Case_Sensitive => False);
1776 begin
1777 File.File := Create_Name (Absolute);
1778 Main_Id := Create_Name (Base);
1779 end;
1780 end if;
1781 end if;
1782
1783 -- If no project or tree was specified for the main, it
1784 -- came from the command line.
1785 -- Note that the assignments below will not modify inside
1786 -- the table itself.
1787
1788 if File.Project = null then
1789 File.Project := Project;
1790 end if;
1791
1792 if File.Tree = null then
1793 File.Tree := Tree;
1794 end if;
1795
1796 if File.Source = null then
1797 if Current_Verbosity = High then
1798 Debug_Output
1799 ("search for main """ & Main
1800 & '"' & File.Index'Img & " in "
1801 & Get_Name_String (Debug_Name (File.Tree))
1802 & ", project", Project.Name);
1803 end if;
1804
1805 -- First, look for the main as specified. We need to
1806 -- search for the base name though, and if needed
1807 -- check later that we found the correct file.
1808
1809 declare
1810 Sources : constant Source_Ids :=
1811 Find_All_Sources
1812 (In_Tree => File.Tree,
1813 Project => File.Project,
1814 Base_Name => Main_Id,
1815 Index => File.Index,
1816 In_Imported_Only => True);
1817
1818 begin
1819 if Is_Absolute then
1820 for J in Sources'Range loop
1821 if File_Name_Type (Sources (J).Path.Name) =
1822 File.File
1823 then
1824 Source := Sources (J);
1825 exit;
1826 end if;
1827 end loop;
1828
1829 elsif Sources'Length > 1 then
1830
1831 -- This is only allowed if the units are from
1832 -- the same multi-unit source file.
1833
1834 Source := Sources (1);
1835
1836 for J in 2 .. Sources'Last loop
1837 if Sources (J).Path /= Source.Path
1838 or else Sources (J).Index = Source.Index
1839 then
1840 Error_Msg_File_1 := Main_Id;
1841 Prj.Err.Error_Msg
1842 (Flags, "several main sources {",
1843 No_Location, File.Project);
1844 exit Main_Loop;
1845 end if;
1846 end loop;
1847
1848 elsif Sources'Length = 1 then
1849 Source := Sources (Sources'First);
1850 end if;
1851 end;
1852
1853 if Source = No_Source then
1854 Source := Find_File_Add_Extension
1855 (File.Tree, Get_Name_String (Main_Id));
1856 end if;
1857
1858 if Is_Absolute
1859 and then Source /= No_Source
1860 and then
1861 File_Name_Type (Source.Path.Name) /= File.File
1862 then
1863 Debug_Output
1864 ("Found a non-matching file",
1865 Name_Id (Source.Path.Display_Name));
1866 Source := No_Source;
1867 end if;
1868
1869 if Source /= No_Source then
1870 if not Is_Allowed_Language
1871 (Source.Language.Name)
1872 then
1873 -- Remove any main that is not in the list of
1874 -- restricted languages.
1875
1876 Names.Table (J .. Names.Last - 1) :=
1877 Names.Table (J + 1 .. Names.Last);
1878 Names.Set_Last (Names.Last - 1);
1879
1880 else
1881 -- If we have found a multi-unit source file but
1882 -- did not specify an index initially, we'll
1883 -- need to compile all the units from the same
1884 -- source file.
1885
1886 if Source.Index /= 0 and then File.Index = 0 then
1887 Add_Multi_Unit_Sources (File.Tree, Source);
1888 end if;
1889
1890 -- Now update the original Main, otherwise it
1891 -- will be reported as not found.
1892
1893 Debug_Output
1894 ("found main in project", Source.Project.Name);
1895 Names.Table (J).File := Source.File;
1896 Names.Table (J).Project := Source.Project;
1897
1898 if Names.Table (J).Tree = null then
1899 Names.Table (J).Tree := File.Tree;
1900
1901 Builder_Data (File.Tree).Number_Of_Mains :=
1902 Builder_Data (File.Tree).Number_Of_Mains
1903 + 1;
1904 Mains.Count_Of_Mains_With_No_Tree :=
1905 Mains.Count_Of_Mains_With_No_Tree - 1;
1906 end if;
1907
1908 Names.Table (J).Source := Source;
1909 Names.Table (J).Index := Source.Index;
1910 end if;
1911
1912 elsif File.Location /= No_Location then
1913
1914 -- If the main is declared in package Builder of
1915 -- the main project, report an error. If the main
1916 -- is on the command line, it may be a main from
1917 -- another project, so do nothing: if the main does
1918 -- not exist in another project, an error will be
1919 -- reported later.
1920
1921 Error_Msg_File_1 := Main_Id;
1922 Error_Msg_Name_1 := File.Project.Name;
1923 Prj.Err.Error_Msg
1924 (Flags, "{ is not a source of project %%",
1925 File.Location, File.Project);
1926 end if;
1927 end if;
1928 end;
1929
1930 J := J - 1;
1931 exit Main_Loop when J < Names.First;
1932 end loop Main_Loop;
1933 end if;
1934
1935 if Total_Errors_Detected > 0 then
1936 Fail_Program (Tree, "problems with main sources");
1937 end if;
1938 end Do_Complete;
1939
1940 -- Start of processing for Complete_Mains
1941
1942 begin
1943 Complete_All (Root_Project, Project_Tree);
1944
1945 if Mains.Count_Of_Mains_With_No_Tree > 0 then
1946 for J in Names.First .. Names.Last loop
1947 if Names.Table (J).Source = No_Source then
1948 Fail_Program
1949 (Project_Tree, '"' & Get_Name_String (Names.Table (J).File)
1950 & """ is not a source of any project");
1951 end if;
1952 end loop;
1953 end if;
1954 end Complete_Mains;
1955
1956 ------------
1957 -- Delete --
1958 ------------
1959
1960 procedure Delete is
1961 begin
1962 Names.Set_Last (0);
1963 Mains.Reset;
1964 end Delete;
1965
1966 -----------------------
1967 -- Fill_From_Project --
1968 -----------------------
1969
1970 procedure Fill_From_Project
1971 (Root_Project : Project_Id;
1972 Project_Tree : Project_Tree_Ref)
1973 is
1974 procedure Add_Mains_From_Project
1975 (Project : Project_Id;
1976 Tree : Project_Tree_Ref);
1977 -- Add the main units from this project into Mains.
1978 -- This takes into account the aggregated projects
1979
1980 ----------------------------
1981 -- Add_Mains_From_Project --
1982 ----------------------------
1983
1984 procedure Add_Mains_From_Project
1985 (Project : Project_Id;
1986 Tree : Project_Tree_Ref)
1987 is
1988 List : String_List_Id;
1989 Element : String_Element;
1990
1991 begin
1992 if Number_Of_Mains (Tree) = 0
1993 and then Mains.Count_Of_Mains_With_No_Tree = 0
1994 then
1995 Debug_Output ("Add_Mains_From_Project", Project.Name);
1996 List := Project.Mains;
1997
1998 if List /= Prj.Nil_String then
1999
2000 -- The attribute Main is not an empty list. Get the mains in
2001 -- the list.
2002
2003 while List /= Prj.Nil_String loop
2004 Element := Tree.Shared.String_Elements.Table (List);
2005 Debug_Output ("Add_Main", Element.Value);
2006
2007 if Project.Library then
2008 Fail_Program
2009 (Tree,
2010 "cannot specify a main program "
2011 & "for a library project file");
2012 end if;
2013
2014 Add_Main (Name => Get_Name_String (Element.Value),
2015 Index => Element.Index,
2016 Location => Element.Location,
2017 Project => Project,
2018 Tree => Tree);
2019 List := Element.Next;
2020 end loop;
2021 end if;
2022 end if;
2023
2024 if Total_Errors_Detected > 0 then
2025 Fail_Program (Tree, "problems with main sources");
2026 end if;
2027 end Add_Mains_From_Project;
2028
2029 procedure Fill_All is new For_Project_And_Aggregated
2030 (Add_Mains_From_Project);
2031
2032 -- Start of processing for Fill_From_Project
2033
2034 begin
2035 Fill_All (Root_Project, Project_Tree);
2036 end Fill_From_Project;
2037
2038 ---------------
2039 -- Next_Main --
2040 ---------------
2041
2042 function Next_Main return String is
2043 Info : constant Main_Info := Next_Main;
2044 begin
2045 if Info = No_Main_Info then
2046 return "";
2047 else
2048 return Get_Name_String (Info.File);
2049 end if;
2050 end Next_Main;
2051
2052 function Next_Main return Main_Info is
2053 begin
2054 if Current >= Names.Last then
2055 return No_Main_Info;
2056 else
2057 Current := Current + 1;
2058
2059 -- If not using projects, and in the gnatmake case, the main file
2060 -- may have not have the extension. Try ".adb" first then ".ads"
2061
2062 if Names.Table (Current).Project = No_Project then
2063 declare
2064 Orig_Main : constant File_Name_Type :=
2065 Names.Table (Current).File;
2066 Current_Main : File_Name_Type;
2067
2068 begin
2069 if Strip_Suffix (Orig_Main) = Orig_Main then
2070 Get_Name_String (Orig_Main);
2071 Add_Str_To_Name_Buffer (".adb");
2072 Current_Main := Name_Find;
2073
2074 if Full_Source_Name (Current_Main) = No_File then
2075 Get_Name_String (Orig_Main);
2076 Add_Str_To_Name_Buffer (".ads");
2077 Current_Main := Name_Find;
2078
2079 if Full_Source_Name (Current_Main) /= No_File then
2080 Names.Table (Current).File := Current_Main;
2081 end if;
2082
2083 else
2084 Names.Table (Current).File := Current_Main;
2085 end if;
2086 end if;
2087 end;
2088 end if;
2089
2090 return Names.Table (Current);
2091 end if;
2092 end Next_Main;
2093
2094 ---------------------
2095 -- Number_Of_Mains --
2096 ---------------------
2097
2098 function Number_Of_Mains (Tree : Project_Tree_Ref) return Natural is
2099 begin
2100 if Tree = null then
2101 return Names.Last;
2102 else
2103 return Builder_Data (Tree).Number_Of_Mains;
2104 end if;
2105 end Number_Of_Mains;
2106
2107 -----------
2108 -- Reset --
2109 -----------
2110
2111 procedure Reset is
2112 begin
2113 Current := 0;
2114 end Reset;
2115
2116 --------------------------
2117 -- Set_Multi_Unit_Index --
2118 --------------------------
2119
2120 procedure Set_Multi_Unit_Index
2121 (Project_Tree : Project_Tree_Ref := null;
2122 Index : Int := 0)
2123 is
2124 begin
2125 if Index /= 0 then
2126 if Names.Last = 0 then
2127 Fail_Program
2128 (Project_Tree,
2129 "cannot specify a multi-unit index but no main "
2130 & "on the command line");
2131
2132 elsif Names.Last > 1 then
2133 Fail_Program
2134 (Project_Tree,
2135 "cannot specify several mains with a multi-unit index");
2136
2137 else
2138 Names.Table (Names.Last).Index := Index;
2139 end if;
2140 end if;
2141 end Set_Multi_Unit_Index;
2142
2143 end Mains;
2144
2145 -----------------------
2146 -- Path_Or_File_Name --
2147 -----------------------
2148
2149 function Path_Or_File_Name (Path : Path_Name_Type) return String is
2150 Path_Name : constant String := Get_Name_String (Path);
2151 begin
2152 if Debug.Debug_Flag_F then
2153 return File_Name (Path_Name);
2154 else
2155 return Path_Name;
2156 end if;
2157 end Path_Or_File_Name;
2158
2159 -------------------
2160 -- Unit_Index_Of --
2161 -------------------
2162
2163 function Unit_Index_Of (ALI_File : File_Name_Type) return Int is
2164 Start : Natural;
2165 Finish : Natural;
2166 Result : Int := 0;
2167
2168 begin
2169 Get_Name_String (ALI_File);
2170
2171 -- First, find the last dot
2172
2173 Finish := Name_Len;
2174
2175 while Finish >= 1 and then Name_Buffer (Finish) /= '.' loop
2176 Finish := Finish - 1;
2177 end loop;
2178
2179 if Finish = 1 then
2180 return 0;
2181 end if;
2182
2183 -- Now check that the dot is preceded by digits
2184
2185 Start := Finish;
2186 Finish := Finish - 1;
2187 while Start >= 1 and then Name_Buffer (Start - 1) in '0' .. '9' loop
2188 Start := Start - 1;
2189 end loop;
2190
2191 -- If there are no digits, or if the digits are not preceded by the
2192 -- character that precedes a unit index, this is not the ALI file of
2193 -- a unit in a multi-unit source.
2194
2195 if Start > Finish
2196 or else Start = 1
2197 or else Name_Buffer (Start - 1) /= Multi_Unit_Index_Character
2198 then
2199 return 0;
2200 end if;
2201
2202 -- Build the index from the digit(s)
2203
2204 while Start <= Finish loop
2205 Result := Result * 10 +
2206 Character'Pos (Name_Buffer (Start)) - Character'Pos ('0');
2207 Start := Start + 1;
2208 end loop;
2209
2210 return Result;
2211 end Unit_Index_Of;
2212
2213 -----------------
2214 -- Verbose_Msg --
2215 -----------------
2216
2217 procedure Verbose_Msg
2218 (N1 : Name_Id;
2219 S1 : String;
2220 N2 : Name_Id := No_Name;
2221 S2 : String := "";
2222 Prefix : String := " -> ";
2223 Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low)
2224 is
2225 begin
2226 if not Opt.Verbose_Mode
2227 or else Minimum_Verbosity > Opt.Verbosity_Level
2228 then
2229 return;
2230 end if;
2231
2232 Write_Str (Prefix);
2233 Write_Str ("""");
2234 Write_Name (N1);
2235 Write_Str (""" ");
2236 Write_Str (S1);
2237
2238 if N2 /= No_Name then
2239 Write_Str (" """);
2240 Write_Name (N2);
2241 Write_Str (""" ");
2242 end if;
2243
2244 Write_Str (S2);
2245 Write_Eol;
2246 end Verbose_Msg;
2247
2248 procedure Verbose_Msg
2249 (N1 : File_Name_Type;
2250 S1 : String;
2251 N2 : File_Name_Type := No_File;
2252 S2 : String := "";
2253 Prefix : String := " -> ";
2254 Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low)
2255 is
2256 begin
2257 Verbose_Msg
2258 (Name_Id (N1), S1, Name_Id (N2), S2, Prefix, Minimum_Verbosity);
2259 end Verbose_Msg;
2260
2261 -----------
2262 -- Queue --
2263 -----------
2264
2265 package body Queue is
2266
2267 type Q_Record is record
2268 Info : Source_Info;
2269 Processed : Boolean;
2270 end record;
2271
2272 package Q is new Table.Table
2273 (Table_Component_Type => Q_Record,
2274 Table_Index_Type => Natural,
2275 Table_Low_Bound => 1,
2276 Table_Initial => 1000,
2277 Table_Increment => 100,
2278 Table_Name => "Makeutl.Queue.Q");
2279 -- This is the actual Queue
2280
2281 package Busy_Obj_Dirs is new GNAT.HTable.Simple_HTable
2282 (Header_Num => Prj.Header_Num,
2283 Element => Boolean,
2284 No_Element => False,
2285 Key => Path_Name_Type,
2286 Hash => Hash,
2287 Equal => "=");
2288
2289 type Mark_Key is record
2290 File : File_Name_Type;
2291 Index : Int;
2292 end record;
2293 -- Identify either a mono-unit source (when Index = 0) or a specific
2294 -- unit (index = 1's origin index of unit) in a multi-unit source.
2295
2296 Max_Mask_Num : constant := 2048;
2297 subtype Mark_Num is Union_Id range 0 .. Max_Mask_Num - 1;
2298
2299 function Hash (Key : Mark_Key) return Mark_Num;
2300
2301 package Marks is new GNAT.HTable.Simple_HTable
2302 (Header_Num => Mark_Num,
2303 Element => Boolean,
2304 No_Element => False,
2305 Key => Mark_Key,
2306 Hash => Hash,
2307 Equal => "=");
2308 -- A hash table to keep tracks of the marked units.
2309 -- These are the units that have already been processed, when using the
2310 -- gnatmake format. When using the gprbuild format, we can directly
2311 -- store in the source_id whether the file has already been processed.
2312
2313 procedure Mark (Source_File : File_Name_Type; Index : Int := 0);
2314 -- Mark a unit, identified by its source file and, when Index is not 0,
2315 -- the index of the unit in the source file. Marking is used to signal
2316 -- that the unit has already been inserted in the Q.
2317
2318 function Is_Marked
2319 (Source_File : File_Name_Type;
2320 Index : Int := 0) return Boolean;
2321 -- Returns True if the unit was previously marked
2322
2323 Q_Processed : Natural := 0;
2324 Q_Initialized : Boolean := False;
2325
2326 Q_First : Natural := 1;
2327 -- Points to the first valid element in the queue
2328
2329 One_Queue_Per_Obj_Dir : Boolean := False;
2330 -- See parameter to Initialize
2331
2332 function Available_Obj_Dir (S : Source_Info) return Boolean;
2333 -- Whether the object directory for S is available for a build
2334
2335 procedure Debug_Display (S : Source_Info);
2336 -- A debug display for S
2337
2338 function Was_Processed (S : Source_Info) return Boolean;
2339 -- Whether S has already been processed. This marks the source as
2340 -- processed, if it hasn't already been processed.
2341
2342 function Insert_No_Roots (Source : Source_Info) return Boolean;
2343 -- Insert Source, but do not look for its roots (see doc for Insert)
2344
2345 -------------------
2346 -- Was_Processed --
2347 -------------------
2348
2349 function Was_Processed (S : Source_Info) return Boolean is
2350 begin
2351 case S.Format is
2352 when Format_Gprbuild =>
2353 if S.Id.In_The_Queue then
2354 return True;
2355 end if;
2356
2357 S.Id.In_The_Queue := True;
2358
2359 when Format_Gnatmake =>
2360 if Is_Marked (S.File, S.Index) then
2361 return True;
2362 end if;
2363
2364 Mark (S.File, Index => S.Index);
2365 end case;
2366
2367 return False;
2368 end Was_Processed;
2369
2370 -----------------------
2371 -- Available_Obj_Dir --
2372 -----------------------
2373
2374 function Available_Obj_Dir (S : Source_Info) return Boolean is
2375 begin
2376 case S.Format is
2377 when Format_Gprbuild =>
2378 return not Busy_Obj_Dirs.Get
2379 (S.Id.Project.Object_Directory.Name);
2380
2381 when Format_Gnatmake =>
2382 return S.Project = No_Project
2383 or else
2384 not Busy_Obj_Dirs.Get (S.Project.Object_Directory.Name);
2385 end case;
2386 end Available_Obj_Dir;
2387
2388 -------------------
2389 -- Debug_Display --
2390 -------------------
2391
2392 procedure Debug_Display (S : Source_Info) is
2393 begin
2394 case S.Format is
2395 when Format_Gprbuild =>
2396 Write_Name (S.Id.File);
2397
2398 if S.Id.Index /= 0 then
2399 Write_Str (", ");
2400 Write_Int (S.Id.Index);
2401 end if;
2402
2403 when Format_Gnatmake =>
2404 Write_Name (S.File);
2405
2406 if S.Index /= 0 then
2407 Write_Str (", ");
2408 Write_Int (S.Index);
2409 end if;
2410 end case;
2411 end Debug_Display;
2412
2413 ----------
2414 -- Hash --
2415 ----------
2416
2417 function Hash (Key : Mark_Key) return Mark_Num is
2418 begin
2419 return Union_Id (Key.File) mod Max_Mask_Num;
2420 end Hash;
2421
2422 ---------------
2423 -- Is_Marked --
2424 ---------------
2425
2426 function Is_Marked
2427 (Source_File : File_Name_Type;
2428 Index : Int := 0) return Boolean
2429 is
2430 begin
2431 return Marks.Get (K => (File => Source_File, Index => Index));
2432 end Is_Marked;
2433
2434 ----------
2435 -- Mark --
2436 ----------
2437
2438 procedure Mark (Source_File : File_Name_Type; Index : Int := 0) is
2439 begin
2440 Marks.Set (K => (File => Source_File, Index => Index), E => True);
2441 end Mark;
2442
2443 -------------
2444 -- Extract --
2445 -------------
2446
2447 procedure Extract
2448 (Found : out Boolean;
2449 Source : out Source_Info)
2450 is
2451 begin
2452 Found := False;
2453
2454 if One_Queue_Per_Obj_Dir then
2455 for J in Q_First .. Q.Last loop
2456 if not Q.Table (J).Processed
2457 and then Available_Obj_Dir (Q.Table (J).Info)
2458 then
2459 Found := True;
2460 Source := Q.Table (J).Info;
2461 Q.Table (J).Processed := True;
2462
2463 if J = Q_First then
2464 while Q_First <= Q.Last
2465 and then Q.Table (Q_First).Processed
2466 loop
2467 Q_First := Q_First + 1;
2468 end loop;
2469 end if;
2470
2471 exit;
2472 end if;
2473 end loop;
2474
2475 elsif Q_First <= Q.Last then
2476 Source := Q.Table (Q_First).Info;
2477 Q.Table (Q_First).Processed := True;
2478 Q_First := Q_First + 1;
2479 Found := True;
2480 end if;
2481
2482 if Found then
2483 Q_Processed := Q_Processed + 1;
2484 end if;
2485
2486 if Found and then Debug.Debug_Flag_Q then
2487 Write_Str (" Q := Q - [ ");
2488 Debug_Display (Source);
2489 Write_Str (" ]");
2490 Write_Eol;
2491
2492 Write_Str (" Q_First =");
2493 Write_Int (Int (Q_First));
2494 Write_Eol;
2495
2496 Write_Str (" Q.Last =");
2497 Write_Int (Int (Q.Last));
2498 Write_Eol;
2499 end if;
2500 end Extract;
2501
2502 ---------------
2503 -- Processed --
2504 ---------------
2505
2506 function Processed return Natural is
2507 begin
2508 return Q_Processed;
2509 end Processed;
2510
2511 ----------------
2512 -- Initialize --
2513 ----------------
2514
2515 procedure Initialize
2516 (Queue_Per_Obj_Dir : Boolean;
2517 Force : Boolean := False)
2518 is
2519 begin
2520 if Force or else not Q_Initialized then
2521 Q_Initialized := True;
2522
2523 for J in 1 .. Q.Last loop
2524 case Q.Table (J).Info.Format is
2525 when Format_Gprbuild =>
2526 Q.Table (J).Info.Id.In_The_Queue := False;
2527 when Format_Gnatmake =>
2528 null;
2529 end case;
2530 end loop;
2531
2532 Q.Init;
2533 Q_Processed := 0;
2534 Q_First := 1;
2535 One_Queue_Per_Obj_Dir := Queue_Per_Obj_Dir;
2536 end if;
2537 end Initialize;
2538
2539 ---------------------
2540 -- Insert_No_Roots --
2541 ---------------------
2542
2543 function Insert_No_Roots (Source : Source_Info) return Boolean is
2544 begin
2545 pragma Assert
2546 (Source.Format = Format_Gnatmake or else Source.Id /= No_Source);
2547
2548 -- Only insert in the Q if it is not already done, to avoid
2549 -- simultaneous compilations if -jnnn is used.
2550
2551 if Was_Processed (Source) then
2552 return False;
2553 end if;
2554
2555 -- For gprbuild, check if a source has already been inserted in the
2556 -- queue from the same project in a different project tree.
2557
2558 if Source.Format = Format_Gprbuild then
2559 for J in 1 .. Q.Last loop
2560 if Source.Id.Path.Name = Q.Table (J).Info.Id.Path.Name
2561 and then Source.Id.Index = Q.Table (J).Info.Id.Index
2562 and then
2563 Ultimate_Extending_Project_Of (Source.Id.Project).Path.Name
2564 =
2565 Ultimate_Extending_Project_Of (Q.Table (J).Info.Id.Project).
2566 Path.Name
2567 then
2568 -- No need to insert this source in the queue, but still
2569 -- return True as we may need to insert its roots.
2570
2571 return True;
2572 end if;
2573 end loop;
2574 end if;
2575
2576 if Current_Verbosity = High then
2577 Write_Str ("Adding """);
2578 Debug_Display (Source);
2579 Write_Line (""" to the queue");
2580 end if;
2581
2582 Q.Append (New_Val => (Info => Source, Processed => False));
2583
2584 if Debug.Debug_Flag_Q then
2585 Write_Str (" Q := Q + [ ");
2586 Debug_Display (Source);
2587 Write_Str (" ] ");
2588 Write_Eol;
2589
2590 Write_Str (" Q_First =");
2591 Write_Int (Int (Q_First));
2592 Write_Eol;
2593
2594 Write_Str (" Q.Last =");
2595 Write_Int (Int (Q.Last));
2596 Write_Eol;
2597 end if;
2598
2599 return True;
2600 end Insert_No_Roots;
2601
2602 ------------
2603 -- Insert --
2604 ------------
2605
2606 function Insert
2607 (Source : Source_Info;
2608 With_Roots : Boolean := False) return Boolean
2609 is
2610 Root_Arr : Array_Element_Id;
2611 Roots : Variable_Value;
2612 List : String_List_Id;
2613 Elem : String_Element;
2614 Unit_Name : Name_Id;
2615 Pat_Root : Boolean;
2616 Root_Pattern : Regexp;
2617 Root_Found : Boolean;
2618 Roots_Found : Boolean;
2619 Root_Source : Prj.Source_Id;
2620 Iter : Source_Iterator;
2621
2622 Dummy : Boolean;
2623
2624 begin
2625 if not Insert_No_Roots (Source) then
2626
2627 -- Was already in the queue
2628
2629 return False;
2630 end if;
2631
2632 if With_Roots and then Source.Format = Format_Gprbuild then
2633 Debug_Output ("looking for roots of", Name_Id (Source.Id.File));
2634
2635 Root_Arr :=
2636 Prj.Util.Value_Of
2637 (Name => Name_Roots,
2638 In_Arrays => Source.Id.Project.Decl.Arrays,
2639 Shared => Source.Tree.Shared);
2640
2641 Roots :=
2642 Prj.Util.Value_Of
2643 (Index => Name_Id (Source.Id.File),
2644 Src_Index => 0,
2645 In_Array => Root_Arr,
2646 Shared => Source.Tree.Shared);
2647
2648 -- If there is no roots for the specific main, try the language
2649
2650 if Roots = Nil_Variable_Value then
2651 Roots :=
2652 Prj.Util.Value_Of
2653 (Index => Source.Id.Language.Name,
2654 Src_Index => 0,
2655 In_Array => Root_Arr,
2656 Shared => Source.Tree.Shared,
2657 Force_Lower_Case_Index => True);
2658 end if;
2659
2660 -- Then try "*"
2661
2662 if Roots = Nil_Variable_Value then
2663 Name_Len := 1;
2664 Name_Buffer (1) := '*';
2665
2666 Roots :=
2667 Prj.Util.Value_Of
2668 (Index => Name_Find,
2669 Src_Index => 0,
2670 In_Array => Root_Arr,
2671 Shared => Source.Tree.Shared,
2672 Force_Lower_Case_Index => True);
2673 end if;
2674
2675 if Roots = Nil_Variable_Value then
2676 Debug_Output (" -> no roots declared");
2677
2678 else
2679 List := Roots.Values;
2680
2681 Pattern_Loop :
2682 while List /= Nil_String loop
2683 Elem := Source.Tree.Shared.String_Elements.Table (List);
2684 Get_Name_String (Elem.Value);
2685 To_Lower (Name_Buffer (1 .. Name_Len));
2686 Unit_Name := Name_Find;
2687
2688 -- Check if it is a unit name or a pattern
2689
2690 Pat_Root := False;
2691
2692 for J in 1 .. Name_Len loop
2693 if Name_Buffer (J) not in 'a' .. 'z' and then
2694 Name_Buffer (J) not in '0' .. '9' and then
2695 Name_Buffer (J) /= '_' and then
2696 Name_Buffer (J) /= '.'
2697 then
2698 Pat_Root := True;
2699 exit;
2700 end if;
2701 end loop;
2702
2703 if Pat_Root then
2704 begin
2705 Root_Pattern :=
2706 Compile
2707 (Pattern => Name_Buffer (1 .. Name_Len),
2708 Glob => True);
2709
2710 exception
2711 when Error_In_Regexp =>
2712 Err_Vars.Error_Msg_Name_1 := Unit_Name;
2713 Errutil.Error_Msg
2714 ("invalid pattern %", Roots.Location);
2715 exit Pattern_Loop;
2716 end;
2717 end if;
2718
2719 Roots_Found := False;
2720 Iter := For_Each_Source (Source.Tree);
2721
2722 Source_Loop :
2723 loop
2724 Root_Source := Prj.Element (Iter);
2725 exit Source_Loop when Root_Source = No_Source;
2726
2727 Root_Found := False;
2728 if Pat_Root then
2729 Root_Found := Root_Source.Unit /= No_Unit_Index
2730 and then Match
2731 (Get_Name_String (Root_Source.Unit.Name),
2732 Root_Pattern);
2733
2734 else
2735 Root_Found :=
2736 Root_Source.Unit /= No_Unit_Index
2737 and then Root_Source.Unit.Name = Unit_Name;
2738 end if;
2739
2740 if Root_Found then
2741 case Root_Source.Kind is
2742 when Impl =>
2743 null;
2744
2745 when Spec =>
2746 Root_Found := Other_Part (Root_Source) = No_Source;
2747
2748 when Sep =>
2749 Root_Found := False;
2750 end case;
2751 end if;
2752
2753 if Root_Found then
2754 Roots_Found := True;
2755 Debug_Output
2756 (" -> ", Name_Id (Root_Source.Display_File));
2757 Dummy := Queue.Insert_No_Roots
2758 (Source => (Format => Format_Gprbuild,
2759 Tree => Source.Tree,
2760 Id => Root_Source,
2761 Closure => False));
2762
2763 Initialize_Source_Record (Root_Source);
2764
2765 if Other_Part (Root_Source) /= No_Source then
2766 Initialize_Source_Record (Other_Part (Root_Source));
2767 end if;
2768
2769 -- Save the root for the binder
2770
2771 Source.Id.Roots := new Source_Roots'
2772 (Root => Root_Source,
2773 Next => Source.Id.Roots);
2774
2775 exit Source_Loop when not Pat_Root;
2776 end if;
2777
2778 Next (Iter);
2779 end loop Source_Loop;
2780
2781 if not Roots_Found then
2782 if Pat_Root then
2783 if not Quiet_Output then
2784 Error_Msg_Name_1 := Unit_Name;
2785 Errutil.Error_Msg
2786 ("?no unit matches pattern %", Roots.Location);
2787 end if;
2788
2789 else
2790 Errutil.Error_Msg
2791 ("Unit " & Get_Name_String (Unit_Name)
2792 & " does not exist", Roots.Location);
2793 end if;
2794 end if;
2795
2796 List := Elem.Next;
2797 end loop Pattern_Loop;
2798 end if;
2799 end if;
2800
2801 return True;
2802 end Insert;
2803
2804 ------------
2805 -- Insert --
2806 ------------
2807
2808 procedure Insert
2809 (Source : Source_Info;
2810 With_Roots : Boolean := False)
2811 is
2812 Discard : Boolean;
2813 begin
2814 Discard := Insert (Source, With_Roots);
2815 end Insert;
2816
2817 --------------
2818 -- Is_Empty --
2819 --------------
2820
2821 function Is_Empty return Boolean is
2822 begin
2823 return Q_Processed >= Q.Last;
2824 end Is_Empty;
2825
2826 ------------------------
2827 -- Is_Virtually_Empty --
2828 ------------------------
2829
2830 function Is_Virtually_Empty return Boolean is
2831 begin
2832 if One_Queue_Per_Obj_Dir then
2833 for J in Q_First .. Q.Last loop
2834 if not Q.Table (J).Processed
2835 and then Available_Obj_Dir (Q.Table (J).Info)
2836 then
2837 return False;
2838 end if;
2839 end loop;
2840
2841 return True;
2842
2843 else
2844 return Is_Empty;
2845 end if;
2846 end Is_Virtually_Empty;
2847
2848 ----------------------
2849 -- Set_Obj_Dir_Busy --
2850 ----------------------
2851
2852 procedure Set_Obj_Dir_Busy (Obj_Dir : Path_Name_Type) is
2853 begin
2854 if One_Queue_Per_Obj_Dir then
2855 Busy_Obj_Dirs.Set (Obj_Dir, True);
2856 end if;
2857 end Set_Obj_Dir_Busy;
2858
2859 ----------------------
2860 -- Set_Obj_Dir_Free --
2861 ----------------------
2862
2863 procedure Set_Obj_Dir_Free (Obj_Dir : Path_Name_Type) is
2864 begin
2865 if One_Queue_Per_Obj_Dir then
2866 Busy_Obj_Dirs.Set (Obj_Dir, False);
2867 end if;
2868 end Set_Obj_Dir_Free;
2869
2870 ----------
2871 -- Size --
2872 ----------
2873
2874 function Size return Natural is
2875 begin
2876 return Q.Last;
2877 end Size;
2878
2879 -------------
2880 -- Element --
2881 -------------
2882
2883 function Element (Rank : Positive) return File_Name_Type is
2884 begin
2885 if Rank <= Q.Last then
2886 case Q.Table (Rank).Info.Format is
2887 when Format_Gprbuild =>
2888 return Q.Table (Rank).Info.Id.File;
2889 when Format_Gnatmake =>
2890 return Q.Table (Rank).Info.File;
2891 end case;
2892 else
2893 return No_File;
2894 end if;
2895 end Element;
2896
2897 ------------------
2898 -- Remove_Marks --
2899 ------------------
2900
2901 procedure Remove_Marks is
2902 begin
2903 Marks.Reset;
2904 end Remove_Marks;
2905
2906 ----------------------------
2907 -- Insert_Project_Sources --
2908 ----------------------------
2909
2910 procedure Insert_Project_Sources
2911 (Project : Project_Id;
2912 Project_Tree : Project_Tree_Ref;
2913 All_Projects : Boolean;
2914 Unique_Compile : Boolean)
2915 is
2916
2917 procedure Do_Insert
2918 (Project : Project_Id;
2919 Tree : Project_Tree_Ref;
2920 Context : Project_Context);
2921 -- Local procedures must be commented ???
2922
2923 ---------------
2924 -- Do_Insert --
2925 ---------------
2926
2927 procedure Do_Insert
2928 (Project : Project_Id;
2929 Tree : Project_Tree_Ref;
2930 Context : Project_Context)
2931 is
2932 Unit_Based : constant Boolean :=
2933 Unique_Compile
2934 or else not Builder_Data (Tree).Closure_Needed;
2935 -- When Unit_Based is True, we enqueue all compilable sources
2936 -- including the unit based (Ada) one. When Unit_Based is False,
2937 -- put the Ada sources only when they are in a library project.
2938
2939 Iter : Source_Iterator;
2940 Source : Prj.Source_Id;
2941 OK : Boolean;
2942 Closure : Boolean;
2943
2944 begin
2945 -- Nothing to do when "-u" was specified and some files were
2946 -- specified on the command line
2947
2948 if Unique_Compile and then Mains.Number_Of_Mains (Tree) > 0 then
2949 return;
2950 end if;
2951
2952 Iter := For_Each_Source (Tree);
2953 loop
2954 Source := Prj.Element (Iter);
2955 exit when Source = No_Source;
2956
2957 if Is_Allowed_Language (Source.Language.Name)
2958 and then Is_Compilable (Source)
2959 and then (All_Projects
2960 or else Is_Extending (Project, Source.Project))
2961 and then not Source.Locally_Removed
2962 and then Source.Replaced_By = No_Source
2963 and then (not Source.Project.Externally_Built
2964 or else (Is_Extending (Project, Source.Project)
2965 and then not Project.Externally_Built))
2966 and then Source.Kind /= Sep
2967 and then Source.Path /= No_Path_Information
2968 then
2969 if Source.Kind = Impl
2970 or else (Source.Unit /= No_Unit_Index
2971 and then Source.Kind = Spec
2972 and then (Other_Part (Source) = No_Source
2973 or else
2974 Other_Part (Source).Locally_Removed))
2975 then
2976 if (Unit_Based
2977 or else Source.Unit = No_Unit_Index
2978 or else Source.Project.Library
2979 or else Context.In_Aggregate_Lib
2980 or else Project.Qualifier = Aggregate_Library)
2981 and then not Is_Subunit (Source)
2982 then
2983 OK := True;
2984 Closure := False;
2985
2986 if Source.Unit /= No_Unit_Index
2987 and then
2988 (Source.Project.Library
2989 or else Project.Qualifier = Aggregate_Library
2990 or else Context.In_Aggregate_Lib)
2991 and then Source.Project.Standalone_Library /= No
2992 then
2993 -- Check if the unit is in the interface
2994
2995 OK := False;
2996
2997 declare
2998 List : String_List_Id;
2999 Element : String_Element;
3000
3001 begin
3002 List := Source.Project.Lib_Interface_ALIs;
3003 while List /= Nil_String loop
3004 Element :=
3005 Project_Tree.Shared.String_Elements.Table
3006 (List);
3007
3008 if Element.Value = Name_Id (Source.Dep_Name)
3009 then
3010 OK := True;
3011 Closure := True;
3012 exit;
3013 end if;
3014
3015 List := Element.Next;
3016 end loop;
3017 end;
3018 end if;
3019
3020 if OK then
3021 Queue.Insert
3022 (Source => (Format => Format_Gprbuild,
3023 Tree => Tree,
3024 Id => Source,
3025 Closure => Closure));
3026 end if;
3027 end if;
3028 end if;
3029 end if;
3030
3031 Next (Iter);
3032 end loop;
3033 end Do_Insert;
3034
3035 procedure Insert_All is
3036 new For_Project_And_Aggregated_Context (Do_Insert);
3037
3038 begin
3039 Insert_All (Project, Project_Tree);
3040 end Insert_Project_Sources;
3041
3042 -------------------------------
3043 -- Insert_Withed_Sources_For --
3044 -------------------------------
3045
3046 procedure Insert_Withed_Sources_For
3047 (The_ALI : ALI.ALI_Id;
3048 Project_Tree : Project_Tree_Ref;
3049 Excluding_Shared_SALs : Boolean := False)
3050 is
3051 Sfile : File_Name_Type;
3052 Afile : File_Name_Type;
3053 Src_Id : Prj.Source_Id;
3054
3055 begin
3056 -- Insert in the queue the unmarked source files (i.e. those which
3057 -- have never been inserted in the queue and hence never considered).
3058
3059 for J in ALI.ALIs.Table (The_ALI).First_Unit ..
3060 ALI.ALIs.Table (The_ALI).Last_Unit
3061 loop
3062 for K in ALI.Units.Table (J).First_With ..
3063 ALI.Units.Table (J).Last_With
3064 loop
3065 Sfile := ALI.Withs.Table (K).Sfile;
3066
3067 -- Skip generics
3068
3069 if Sfile /= No_File then
3070 Afile := ALI.Withs.Table (K).Afile;
3071
3072 Src_Id := Source_Files_Htable.Get
3073 (Project_Tree.Source_Files_HT, Sfile);
3074 while Src_Id /= No_Source loop
3075 Initialize_Source_Record (Src_Id);
3076
3077 if Is_Compilable (Src_Id)
3078 and then Src_Id.Dep_Name = Afile
3079 then
3080 case Src_Id.Kind is
3081 when Spec =>
3082 declare
3083 Bdy : constant Prj.Source_Id :=
3084 Other_Part (Src_Id);
3085 begin
3086 if Bdy /= No_Source
3087 and then not Bdy.Locally_Removed
3088 then
3089 Src_Id := Other_Part (Src_Id);
3090 end if;
3091 end;
3092
3093 when Impl =>
3094 if Is_Subunit (Src_Id) then
3095 Src_Id := No_Source;
3096 end if;
3097
3098 when Sep =>
3099 Src_Id := No_Source;
3100 end case;
3101
3102 exit;
3103 end if;
3104
3105 Src_Id := Src_Id.Next_With_File_Name;
3106 end loop;
3107
3108 -- If Excluding_Shared_SALs is True, do not insert in the
3109 -- queue the sources of a shared Stand-Alone Library.
3110
3111 if Src_Id /= No_Source
3112 and then (not Excluding_Shared_SALs
3113 or else Src_Id.Project.Standalone_Library = No
3114 or else Src_Id.Project.Library_Kind = Static)
3115 then
3116 Queue.Insert
3117 (Source => (Format => Format_Gprbuild,
3118 Tree => Project_Tree,
3119 Id => Src_Id,
3120 Closure => True));
3121 end if;
3122 end if;
3123 end loop;
3124 end loop;
3125 end Insert_Withed_Sources_For;
3126
3127 end Queue;
3128
3129 ----------
3130 -- Free --
3131 ----------
3132
3133 procedure Free (Data : in out Builder_Project_Tree_Data) is
3134 procedure Unchecked_Free is new Ada.Unchecked_Deallocation
3135 (Binding_Data_Record, Binding_Data);
3136
3137 TmpB, Binding : Binding_Data := Data.Binding;
3138
3139 begin
3140 while Binding /= null loop
3141 TmpB := Binding.Next;
3142 Unchecked_Free (Binding);
3143 Binding := TmpB;
3144 end loop;
3145 end Free;
3146
3147 ------------------
3148 -- Builder_Data --
3149 ------------------
3150
3151 function Builder_Data
3152 (Tree : Project_Tree_Ref) return Builder_Data_Access
3153 is
3154 begin
3155 if Tree.Appdata = null then
3156 Tree.Appdata := new Builder_Project_Tree_Data;
3157 end if;
3158
3159 return Builder_Data_Access (Tree.Appdata);
3160 end Builder_Data;
3161
3162 --------------------------------
3163 -- Compute_Compilation_Phases --
3164 --------------------------------
3165
3166 procedure Compute_Compilation_Phases
3167 (Tree : Project_Tree_Ref;
3168 Root_Project : Project_Id;
3169 Option_Unique_Compile : Boolean := False; -- Was "-u" specified ?
3170 Option_Compile_Only : Boolean := False; -- Was "-c" specified ?
3171 Option_Bind_Only : Boolean := False;
3172 Option_Link_Only : Boolean := False)
3173 is
3174 procedure Do_Compute (Project : Project_Id; Tree : Project_Tree_Ref);
3175
3176 ----------------
3177 -- Do_Compute --
3178 ----------------
3179
3180 procedure Do_Compute (Project : Project_Id; Tree : Project_Tree_Ref) is
3181 Data : constant Builder_Data_Access := Builder_Data (Tree);
3182 All_Phases : constant Boolean :=
3183 not Option_Compile_Only
3184 and then not Option_Bind_Only
3185 and then not Option_Link_Only;
3186 -- Whether the command line asked for all three phases. Depending on
3187 -- the project settings, we might still disable some of the phases.
3188
3189 Has_Mains : constant Boolean := Data.Number_Of_Mains > 0;
3190 -- Whether there are some main units defined for this project tree
3191 -- (either from one of the projects, or from the command line)
3192
3193 begin
3194 if Option_Unique_Compile then
3195
3196 -- If -u or -U is specified on the command line, disregard any -c,
3197 -- -b or -l switch: only perform compilation.
3198
3199 Data.Closure_Needed := False;
3200 Data.Need_Compilation := True;
3201 Data.Need_Binding := False;
3202 Data.Need_Linking := False;
3203
3204 else
3205 Data.Closure_Needed :=
3206 Has_Mains
3207 or else (Root_Project.Library
3208 and then Root_Project.Standalone_Library /= No);
3209 Data.Need_Compilation := All_Phases or Option_Compile_Only;
3210 Data.Need_Binding := All_Phases or Option_Bind_Only;
3211 Data.Need_Linking := (All_Phases or Option_Link_Only)
3212 and Has_Mains;
3213 end if;
3214
3215 if Current_Verbosity = High then
3216 Debug_Output ("compilation phases: "
3217 & " compile=" & Data.Need_Compilation'Img
3218 & " bind=" & Data.Need_Binding'Img
3219 & " link=" & Data.Need_Linking'Img
3220 & " closure=" & Data.Closure_Needed'Img
3221 & " mains=" & Data.Number_Of_Mains'Img,
3222 Project.Name);
3223 end if;
3224 end Do_Compute;
3225
3226 procedure Compute_All is new For_Project_And_Aggregated (Do_Compute);
3227
3228 begin
3229 Compute_All (Root_Project, Tree);
3230 end Compute_Compilation_Phases;
3231
3232 ------------------------------
3233 -- Compute_Builder_Switches --
3234 ------------------------------
3235
3236 procedure Compute_Builder_Switches
3237 (Project_Tree : Project_Tree_Ref;
3238 Env : in out Prj.Tree.Environment;
3239 Main_Project : Project_Id;
3240 Only_For_Lang : Name_Id := No_Name)
3241 is
3242 Builder_Package : constant Package_Id :=
3243 Value_Of (Name_Builder, Main_Project.Decl.Packages,
3244 Project_Tree.Shared);
3245
3246 Global_Compilation_Array : Array_Element_Id;
3247 Global_Compilation_Elem : Array_Element;
3248 Global_Compilation_Switches : Variable_Value;
3249
3250 Default_Switches_Array : Array_Id;
3251
3252 Builder_Switches_Lang : Name_Id := No_Name;
3253
3254 List : String_List_Id;
3255 Element : String_Element;
3256
3257 Index : Name_Id;
3258 Source : Prj.Source_Id;
3259
3260 Lang : Name_Id := No_Name; -- language index for Switches
3261 Switches_For_Lang : Variable_Value := Nil_Variable_Value;
3262 -- Value of Builder'Default_Switches(lang)
3263
3264 Name : Name_Id := No_Name; -- main file index for Switches
3265 Switches_For_Main : Variable_Value := Nil_Variable_Value;
3266 -- Switches for a specific main. When there are several mains, Name is
3267 -- set to No_Name, and Switches_For_Main might be left with an actual
3268 -- value (so that we can display a warning that it was ignored).
3269
3270 Other_Switches : Variable_Value := Nil_Variable_Value;
3271 -- Value of Builder'Switches(others)
3272
3273 Defaults : Variable_Value := Nil_Variable_Value;
3274
3275 Switches : Variable_Value := Nil_Variable_Value;
3276 -- The computed builder switches
3277
3278 Success : Boolean := False;
3279 begin
3280 if Builder_Package /= No_Package then
3281 Mains.Reset;
3282
3283 -- If there is no main, and there is only one compilable language,
3284 -- use this language as the switches index.
3285
3286 if Mains.Number_Of_Mains (Project_Tree) = 0 then
3287 if Only_For_Lang = No_Name then
3288 declare
3289 Language : Language_Ptr := Main_Project.Languages;
3290
3291 begin
3292 while Language /= No_Language_Index loop
3293 if Language.Config.Compiler_Driver /= No_File
3294 and then Language.Config.Compiler_Driver /= Empty_File
3295 then
3296 if Lang /= No_Name then
3297 Lang := No_Name;
3298 exit;
3299 else
3300 Lang := Language.Name;
3301 end if;
3302 end if;
3303 Language := Language.Next;
3304 end loop;
3305 end;
3306 else
3307 Lang := Only_For_Lang;
3308 end if;
3309
3310 else
3311 for Index in 1 .. Mains.Number_Of_Mains (Project_Tree) loop
3312 Source := Mains.Next_Main.Source;
3313
3314 if Source /= No_Source then
3315 if Switches_For_Main = Nil_Variable_Value then
3316 Switches_For_Main := Value_Of
3317 (Name => Name_Id (Source.File),
3318 Attribute_Or_Array_Name => Name_Switches,
3319 In_Package => Builder_Package,
3320 Shared => Project_Tree.Shared,
3321 Force_Lower_Case_Index => False,
3322 Allow_Wildcards => True);
3323
3324 -- If not found, try without extension.
3325 -- That's because gnatmake accepts truncated file names
3326 -- in Builder'Switches
3327
3328 if Switches_For_Main = Nil_Variable_Value
3329 and then Source.Unit /= null
3330 then
3331 Switches_For_Main := Value_Of
3332 (Name => Source.Unit.Name,
3333 Attribute_Or_Array_Name => Name_Switches,
3334 In_Package => Builder_Package,
3335 Shared => Project_Tree.Shared,
3336 Force_Lower_Case_Index => False,
3337 Allow_Wildcards => True);
3338 end if;
3339 end if;
3340
3341 if Index = 1 then
3342 Lang := Source.Language.Name;
3343 Name := Name_Id (Source.File);
3344 else
3345 Name := No_Name; -- Can't use main specific switches
3346
3347 if Lang /= Source.Language.Name then
3348 Lang := No_Name;
3349 end if;
3350 end if;
3351 end if;
3352 end loop;
3353 end if;
3354
3355 Global_Compilation_Array := Value_Of
3356 (Name => Name_Global_Compilation_Switches,
3357 In_Arrays => Project_Tree.Shared.Packages.Table
3358 (Builder_Package).Decl.Arrays,
3359 Shared => Project_Tree.Shared);
3360
3361 Default_Switches_Array :=
3362 Project_Tree.Shared.Packages.Table (Builder_Package).Decl.Arrays;
3363
3364 while Default_Switches_Array /= No_Array
3365 and then
3366 Project_Tree.Shared.Arrays.Table (Default_Switches_Array).Name /=
3367 Name_Default_Switches
3368 loop
3369 Default_Switches_Array :=
3370 Project_Tree.Shared.Arrays.Table (Default_Switches_Array).Next;
3371 end loop;
3372
3373 if Global_Compilation_Array /= No_Array_Element
3374 and then Default_Switches_Array /= No_Array
3375 then
3376 Prj.Err.Error_Msg
3377 (Env.Flags,
3378 "Default_Switches forbidden in presence of "
3379 & "Global_Compilation_Switches. Use Switches instead.",
3380 Project_Tree.Shared.Arrays.Table
3381 (Default_Switches_Array).Location);
3382 Fail_Program
3383 (Project_Tree, "*** illegal combination of Builder attributes");
3384 end if;
3385
3386 if Lang /= No_Name then
3387 Switches_For_Lang := Prj.Util.Value_Of
3388 (Name => Lang,
3389 Index => 0,
3390 Attribute_Or_Array_Name => Name_Switches,
3391 In_Package => Builder_Package,
3392 Shared => Project_Tree.Shared,
3393 Force_Lower_Case_Index => True);
3394
3395 Defaults := Prj.Util.Value_Of
3396 (Name => Lang,
3397 Index => 0,
3398 Attribute_Or_Array_Name => Name_Default_Switches,
3399 In_Package => Builder_Package,
3400 Shared => Project_Tree.Shared,
3401 Force_Lower_Case_Index => True);
3402 end if;
3403
3404 Other_Switches := Prj.Util.Value_Of
3405 (Name => All_Other_Names,
3406 Index => 0,
3407 Attribute_Or_Array_Name => Name_Switches,
3408 In_Package => Builder_Package,
3409 Shared => Project_Tree.Shared);
3410
3411 if not Quiet_Output
3412 and then Mains.Number_Of_Mains (Project_Tree) > 1
3413 and then Switches_For_Main /= Nil_Variable_Value
3414 then
3415 -- More than one main, but we had main-specific switches that
3416 -- are ignored.
3417
3418 if Switches_For_Lang /= Nil_Variable_Value then
3419 Write_Line
3420 ("Warning: using Builder'Switches("""
3421 & Get_Name_String (Lang)
3422 & """), as there are several mains");
3423
3424 elsif Other_Switches /= Nil_Variable_Value then
3425 Write_Line
3426 ("Warning: using Builder'Switches(others), "
3427 & "as there are several mains");
3428
3429 elsif Defaults /= Nil_Variable_Value then
3430 Write_Line
3431 ("Warning: using Builder'Default_Switches("""
3432 & Get_Name_String (Lang)
3433 & """), as there are several mains");
3434 else
3435 Write_Line
3436 ("Warning: using no switches from package "
3437 & "Builder, as there are several mains");
3438 end if;
3439 end if;
3440
3441 Builder_Switches_Lang := Lang;
3442
3443 if Name /= No_Name then
3444 -- Get the switches for the single main
3445 Switches := Switches_For_Main;
3446 end if;
3447
3448 if Switches = Nil_Variable_Value or else Switches.Default then
3449 -- Get the switches for the common language of the mains
3450 Switches := Switches_For_Lang;
3451 end if;
3452
3453 if Switches = Nil_Variable_Value or else Switches.Default then
3454 Switches := Other_Switches;
3455 end if;
3456
3457 -- For backward compatibility with gnatmake, if no Switches
3458 -- are declared, check for Default_Switches (<language>).
3459
3460 if Switches = Nil_Variable_Value or else Switches.Default then
3461 Switches := Defaults;
3462 end if;
3463
3464 -- If switches have been found, scan them
3465
3466 if Switches /= Nil_Variable_Value and then not Switches.Default then
3467 List := Switches.Values;
3468
3469 while List /= Nil_String loop
3470 Element := Project_Tree.Shared.String_Elements.Table (List);
3471 Get_Name_String (Element.Value);
3472
3473 if Name_Len /= 0 then
3474 declare
3475 -- Add_Switch might itself be using the name_buffer, so
3476 -- we make a temporary here.
3477 Switch : constant String := Name_Buffer (1 .. Name_Len);
3478 begin
3479 Success := Add_Switch
3480 (Switch => Switch,
3481 For_Lang => Builder_Switches_Lang,
3482 For_Builder => True,
3483 Has_Global_Compilation_Switches =>
3484 Global_Compilation_Array /= No_Array_Element);
3485 end;
3486
3487 if not Success then
3488 for J in reverse 1 .. Name_Len loop
3489 Name_Buffer (J + J) := Name_Buffer (J);
3490 Name_Buffer (J + J - 1) := ''';
3491 end loop;
3492
3493 Name_Len := Name_Len + Name_Len;
3494
3495 Prj.Err.Error_Msg
3496 (Env.Flags,
3497 '"' & Name_Buffer (1 .. Name_Len)
3498 & """ is not a builder switch. Consider moving "
3499 & "it to Global_Compilation_Switches.",
3500 Element.Location);
3501 Fail_Program
3502 (Project_Tree,
3503 "*** illegal switch """
3504 & Get_Name_String (Element.Value) & '"');
3505 end if;
3506 end if;
3507
3508 List := Element.Next;
3509 end loop;
3510 end if;
3511
3512 -- Reset the Builder Switches language
3513
3514 Builder_Switches_Lang := No_Name;
3515
3516 -- Take into account attributes Global_Compilation_Switches
3517
3518 while Global_Compilation_Array /= No_Array_Element loop
3519 Global_Compilation_Elem :=
3520 Project_Tree.Shared.Array_Elements.Table
3521 (Global_Compilation_Array);
3522
3523 Get_Name_String (Global_Compilation_Elem.Index);
3524 To_Lower (Name_Buffer (1 .. Name_Len));
3525 Index := Name_Find;
3526
3527 if Only_For_Lang = No_Name or else Index = Only_For_Lang then
3528 Global_Compilation_Switches := Global_Compilation_Elem.Value;
3529
3530 if Global_Compilation_Switches /= Nil_Variable_Value
3531 and then not Global_Compilation_Switches.Default
3532 then
3533 -- We have found an attribute
3534 -- Global_Compilation_Switches for a language: put the
3535 -- switches in the appropriate table.
3536
3537 List := Global_Compilation_Switches.Values;
3538 while List /= Nil_String loop
3539 Element :=
3540 Project_Tree.Shared.String_Elements.Table (List);
3541
3542 if Element.Value /= No_Name then
3543 Success := Add_Switch
3544 (Switch => Get_Name_String (Element.Value),
3545 For_Lang => Index,
3546 For_Builder => False,
3547 Has_Global_Compilation_Switches =>
3548 Global_Compilation_Array /= No_Array_Element);
3549 end if;
3550
3551 List := Element.Next;
3552 end loop;
3553 end if;
3554 end if;
3555
3556 Global_Compilation_Array := Global_Compilation_Elem.Next;
3557 end loop;
3558 end if;
3559 end Compute_Builder_Switches;
3560
3561 ---------------------
3562 -- Write_Path_File --
3563 ---------------------
3564
3565 procedure Write_Path_File (FD : File_Descriptor) is
3566 Last : Natural;
3567 Status : Boolean;
3568
3569 begin
3570 Name_Len := 0;
3571
3572 for Index in Directories.First .. Directories.Last loop
3573 Add_Str_To_Name_Buffer (Get_Name_String (Directories.Table (Index)));
3574 Add_Char_To_Name_Buffer (ASCII.LF);
3575 end loop;
3576
3577 Last := Write (FD, Name_Buffer (1)'Address, Name_Len);
3578
3579 if Last = Name_Len then
3580 Close (FD, Status);
3581 else
3582 Status := False;
3583 end if;
3584
3585 if not Status then
3586 Prj.Com.Fail ("could not write temporary file");
3587 end if;
3588 end Write_Path_File;
3589
3590 end Makeutl;