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