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