gcc/ada/makeutl.adb

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