gcc/ada/makeutl.adb

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