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 26with ALI; use ALI; 27with Atree; use Atree; 28with Debug; 29with Err_Vars; use Err_Vars; 30with Errutil; 31with Fname; 32with Osint; use Osint; 33with Output; use Output; 34with Opt; use Opt; 35with Prj.Com; 36with Prj.Err; 37with Prj.Ext; 38with Prj.Util; use Prj.Util; 39with Sinput.P; 40with Tempdir; 41 42with Ada.Command_Line; use Ada.Command_Line; 43with Ada.Unchecked_Deallocation; 44 45with GNAT.Case_Util; use GNAT.Case_Util; 46with GNAT.Directory_Operations; use GNAT.Directory_Operations; 47with GNAT.HTable; 48with GNAT.Regexp; use GNAT.Regexp; 49 50package 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 3590end Makeutl; 3591