gcc/ada/makeutl.adb

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