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