gcc/ada/prj-conf.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             P R J . C O N F                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --            Copyright (C) 2006-2013, Free Software Foundation, Inc.       --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Hostparm;
  27 with Makeutl;  use Makeutl;
  28 with MLib.Tgt;
  29 with Opt;      use Opt;
  30 with Output;   use Output;
  31 with Prj.Env;
  32 with Prj.Err;
  33 with Prj.Part;
  34 with Prj.PP;
  35 with Prj.Proc; use Prj.Proc;
  36 with Prj.Tree; use Prj.Tree;
  37 with Prj.Util; use Prj.Util;
  38 with Prj;      use Prj;
  39 with Snames;   use Snames;
  40
  41 with Ada.Directories; use Ada.Directories;
  42 with Ada.Exceptions;  use Ada.Exceptions;
  43
  44 with GNAT.Case_Util; use GNAT.Case_Util;
  45 with GNAT.HTable;    use GNAT.HTable;
  46
  47 package body Prj.Conf is
  48
  49    Auto_Cgpr : constant String := "auto.cgpr";
  50
  51    Config_Project_Env_Var : constant String := "GPR_CONFIG";
  52    --  Name of the environment variable that provides the name of the
  53    --  configuration file to use.
  54
  55    Gprconfig_Name : constant String := "gprconfig";
  56
  57    package RTS_Languages is new GNAT.HTable.Simple_HTable
  58      (Header_Num => Prj.Header_Num,
  59       Element    => Name_Id,
  60       No_Element => No_Name,
  61       Key        => Name_Id,
  62       Hash       => Prj.Hash,
  63       Equal      => "=");
  64    --  Stores the runtime names for the various languages. This is in general
  65    --  set from a --RTS command line option.
  66
  67    -----------------------
  68    -- Local_Subprograms --
  69    -----------------------
  70
  71    procedure Add_Attributes
  72      (Project_Tree : Project_Tree_Ref;
  73       Conf_Decl    : Declarations;
  74       User_Decl    : in out Declarations);
  75    --  Process the attributes in the config declarations.
  76    --  For single string values, if the attribute is not declared in the user
  77    --  declarations, declare it with the value in the config declarations.
  78    --  For string list values, prepend the value in the user declarations with
  79    --  the value in the config declarations.
  80
  81    function Check_Target
  82      (Config_File        : Prj.Project_Id;
  83       Autoconf_Specified : Boolean;
  84       Project_Tree       : Prj.Project_Tree_Ref;
  85       Target             : String := "") return Boolean;
  86    --  Check that the config file's target matches Target.
  87    --  Target should be set to the empty string when the user did not specify
  88    --  a target. If the target in the configuration file is invalid, this
  89    --  function will raise Invalid_Config with an appropriate message.
  90    --  Autoconf_Specified should be set to True if the user has used
  91    --  autoconf.
  92
  93    function Locate_Config_File (Name : String) return String_Access;
  94    --  Search for Name in the config files directory. Return full path if
  95    --  found, or null otherwise.
  96
  97    procedure Raise_Invalid_Config (Msg : String);
  98    pragma No_Return (Raise_Invalid_Config);
  99    --  Raises exception Invalid_Config with given message
 100
 101    procedure Apply_Config_File
 102      (Config_File  : Prj.Project_Id;
 103       Project_Tree : Prj.Project_Tree_Ref);
 104    --  Apply the configuration file settings to all the projects in the
 105    --  project tree. The Project_Tree must have been parsed first, and
 106    --  processed through the first phase so that all its projects are known.
 107    --
 108    --  Currently, this will add new attributes and packages in the various
 109    --  projects, so that when the second phase of the processing is performed
 110    --  these attributes are automatically taken into account.
 111
 112    --------------------
 113    -- Add_Attributes --
 114    --------------------
 115
 116    procedure Add_Attributes
 117      (Project_Tree : Project_Tree_Ref;
 118       Conf_Decl    : Declarations;
 119       User_Decl    : in out Declarations)
 120    is
 121       Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared;
 122       Conf_Attr_Id       : Variable_Id;
 123       Conf_Attr          : Variable;
 124       Conf_Array_Id      : Array_Id;
 125       Conf_Array         : Array_Data;
 126       Conf_Array_Elem_Id : Array_Element_Id;
 127       Conf_Array_Elem    : Array_Element;
 128       Conf_List          : String_List_Id;
 129       Conf_List_Elem     : String_Element;
 130
 131       User_Attr_Id       : Variable_Id;
 132       User_Attr          : Variable;
 133       User_Array_Id      : Array_Id;
 134       User_Array         : Array_Data;
 135       User_Array_Elem_Id : Array_Element_Id;
 136       User_Array_Elem    : Array_Element;
 137
 138    begin
 139       Conf_Attr_Id := Conf_Decl.Attributes;
 140       User_Attr_Id := User_Decl.Attributes;
 141       while Conf_Attr_Id /= No_Variable loop
 142          Conf_Attr := Shared.Variable_Elements.Table (Conf_Attr_Id);
 143          User_Attr := Shared.Variable_Elements.Table (User_Attr_Id);
 144
 145          if not Conf_Attr.Value.Default then
 146             if User_Attr.Value.Default then
 147
 148                --  No attribute declared in user project file: just copy the
 149                --  value of the configuration attribute.
 150
 151                User_Attr.Value := Conf_Attr.Value;
 152                Shared.Variable_Elements.Table (User_Attr_Id) := User_Attr;
 153
 154             elsif User_Attr.Value.Kind = List
 155               and then Conf_Attr.Value.Values /= Nil_String
 156             then
 157                --  List attribute declared in both the user project and the
 158                --  configuration project: prepend the user list with the
 159                --  configuration list.
 160
 161                declare
 162                   User_List : constant String_List_Id :=
 163                                 User_Attr.Value.Values;
 164                   Conf_List : String_List_Id := Conf_Attr.Value.Values;
 165                   Conf_Elem : String_Element;
 166                   New_List  : String_List_Id;
 167                   New_Elem  : String_Element;
 168
 169                begin
 170                   --  Create new list
 171
 172                   String_Element_Table.Increment_Last
 173                     (Shared.String_Elements);
 174                   New_List :=
 175                     String_Element_Table.Last (Shared.String_Elements);
 176
 177                   --  Value of attribute is new list
 178
 179                   User_Attr.Value.Values := New_List;
 180                   Shared.Variable_Elements.Table (User_Attr_Id) := User_Attr;
 181
 182                   loop
 183                      --  Get each element of configuration list
 184
 185                      Conf_Elem := Shared.String_Elements.Table (Conf_List);
 186                      New_Elem  := Conf_Elem;
 187                      Conf_List := Conf_Elem.Next;
 188
 189                      if Conf_List = Nil_String then
 190
 191                         --  If it is the last element in the list, connect to
 192                         --  first element of user list, and we are done.
 193
 194                         New_Elem.Next := User_List;
 195                         Shared.String_Elements.Table (New_List) := New_Elem;
 196                         exit;
 197
 198                      else
 199                         --  If it is not the last element in the list, add to
 200                         --  new list.
 201
 202                         String_Element_Table.Increment_Last
 203                           (Shared.String_Elements);
 204                         New_Elem.Next :=
 205                           String_Element_Table.Last (Shared.String_Elements);
 206                         Shared.String_Elements.Table (New_List) := New_Elem;
 207                         New_List := New_Elem.Next;
 208                      end if;
 209                   end loop;
 210                end;
 211             end if;
 212          end if;
 213
 214          Conf_Attr_Id := Conf_Attr.Next;
 215          User_Attr_Id := User_Attr.Next;
 216       end loop;
 217
 218       Conf_Array_Id := Conf_Decl.Arrays;
 219       while Conf_Array_Id /= No_Array loop
 220          Conf_Array := Shared.Arrays.Table (Conf_Array_Id);
 221
 222          User_Array_Id := User_Decl.Arrays;
 223          while User_Array_Id /= No_Array loop
 224             User_Array := Shared.Arrays.Table (User_Array_Id);
 225             exit when User_Array.Name = Conf_Array.Name;
 226             User_Array_Id := User_Array.Next;
 227          end loop;
 228
 229          --  If this associative array does not exist in the user project file,
 230          --  do a shallow copy of the full associative array.
 231
 232          if User_Array_Id = No_Array then
 233             Array_Table.Increment_Last (Shared.Arrays);
 234             User_Array := Conf_Array;
 235             User_Array.Next := User_Decl.Arrays;
 236             User_Decl.Arrays := Array_Table.Last (Shared.Arrays);
 237             Shared.Arrays.Table (User_Decl.Arrays) := User_Array;
 238
 239          --  Otherwise, check each array element
 240
 241          else
 242             Conf_Array_Elem_Id := Conf_Array.Value;
 243             while Conf_Array_Elem_Id /= No_Array_Element loop
 244                Conf_Array_Elem :=
 245                  Shared.Array_Elements.Table (Conf_Array_Elem_Id);
 246
 247                User_Array_Elem_Id := User_Array.Value;
 248                while User_Array_Elem_Id /= No_Array_Element loop
 249                   User_Array_Elem :=
 250                     Shared.Array_Elements.Table (User_Array_Elem_Id);
 251                   exit when User_Array_Elem.Index = Conf_Array_Elem.Index;
 252                   User_Array_Elem_Id := User_Array_Elem.Next;
 253                end loop;
 254
 255                --  If the array element doesn't exist in the user array, insert
 256                --  a shallow copy of the conf array element in the user array.
 257
 258                if User_Array_Elem_Id = No_Array_Element then
 259                   Array_Element_Table.Increment_Last (Shared.Array_Elements);
 260                   User_Array_Elem := Conf_Array_Elem;
 261                   User_Array_Elem.Next := User_Array.Value;
 262                   User_Array.Value :=
 263                     Array_Element_Table.Last (Shared.Array_Elements);
 264                   Shared.Array_Elements.Table (User_Array.Value) :=
 265                     User_Array_Elem;
 266                   Shared.Arrays.Table (User_Array_Id) := User_Array;
 267
 268                --  Otherwise, if the value is a string list, prepend the conf
 269                --  array element value to the array element.
 270
 271                elsif Conf_Array_Elem.Value.Kind = List then
 272                   Conf_List := Conf_Array_Elem.Value.Values;
 273
 274                   if Conf_List /= Nil_String then
 275                      declare
 276                         Link     : constant String_List_Id :=
 277                                      User_Array_Elem.Value.Values;
 278                         Previous : String_List_Id := Nil_String;
 279                         Next     : String_List_Id;
 280
 281                      begin
 282                         loop
 283                            Conf_List_Elem :=
 284                              Shared.String_Elements.Table (Conf_List);
 285                            String_Element_Table.Increment_Last
 286                              (Shared.String_Elements);
 287                            Next :=
 288                              String_Element_Table.Last
 289                                (Shared.String_Elements);
 290                            Shared.String_Elements.Table (Next) :=
 291                              Conf_List_Elem;
 292
 293                            if Previous = Nil_String then
 294                               User_Array_Elem.Value.Values := Next;
 295                               Shared.Array_Elements.Table
 296                                 (User_Array_Elem_Id) := User_Array_Elem;
 297
 298                            else
 299                               Shared.String_Elements.Table
 300                                 (Previous).Next := Next;
 301                            end if;
 302
 303                            Previous := Next;
 304
 305                            Conf_List := Conf_List_Elem.Next;
 306
 307                            if Conf_List = Nil_String then
 308                               Shared.String_Elements.Table (Previous).Next :=
 309                                 Link;
 310                               exit;
 311                            end if;
 312                         end loop;
 313                      end;
 314                   end if;
 315                end if;
 316
 317                Conf_Array_Elem_Id := Conf_Array_Elem.Next;
 318             end loop;
 319          end if;
 320
 321          Conf_Array_Id := Conf_Array.Next;
 322       end loop;
 323    end Add_Attributes;
 324
 325    ------------------------------------
 326    -- Add_Default_GNAT_Naming_Scheme --
 327    ------------------------------------
 328
 329    procedure Add_Default_GNAT_Naming_Scheme
 330      (Config_File  : in out Project_Node_Id;
 331       Project_Tree : Project_Node_Tree_Ref)
 332    is
 333       procedure Create_Attribute
 334         (Name  : Name_Id;
 335          Value : String;
 336          Index : String := "";
 337          Pkg   : Project_Node_Id := Empty_Node);
 338
 339       ----------------------
 340       -- Create_Attribute --
 341       ----------------------
 342
 343       procedure Create_Attribute
 344         (Name  : Name_Id;
 345          Value : String;
 346          Index : String := "";
 347          Pkg   : Project_Node_Id := Empty_Node)
 348       is
 349          Attr : Project_Node_Id;
 350          pragma Unreferenced (Attr);
 351
 352          Expr   : Name_Id         := No_Name;
 353          Val    : Name_Id         := No_Name;
 354          Parent : Project_Node_Id := Config_File;
 355
 356       begin
 357          if Index /= "" then
 358             Name_Len := Index'Length;
 359             Name_Buffer (1 .. Name_Len) := Index;
 360             Val := Name_Find;
 361          end if;
 362
 363          if Pkg /= Empty_Node then
 364             Parent := Pkg;
 365          end if;
 366
 367          Name_Len := Value'Length;
 368          Name_Buffer (1 .. Name_Len) := Value;
 369          Expr := Name_Find;
 370
 371          Attr := Create_Attribute
 372            (Tree       => Project_Tree,
 373             Prj_Or_Pkg => Parent,
 374             Name       => Name,
 375             Index_Name => Val,
 376             Kind       => Prj.Single,
 377             Value      => Create_Literal_String (Expr, Project_Tree));
 378       end Create_Attribute;
 379
 380       --  Local variables
 381
 382       Name     : Name_Id;
 383       Naming   : Project_Node_Id;
 384       Compiler : Project_Node_Id;
 385
 386    --  Start of processing for Add_Default_GNAT_Naming_Scheme
 387
 388    begin
 389       if Config_File = Empty_Node then
 390
 391          --  Create a dummy config file is none was found
 392
 393          Name_Len := Auto_Cgpr'Length;
 394          Name_Buffer (1 .. Name_Len) := Auto_Cgpr;
 395          Name := Name_Find;
 396
 397          --  An invalid project name to avoid conflicts with user-created ones
 398
 399          Name_Len := 5;
 400          Name_Buffer (1 .. Name_Len) := "_auto";
 401
 402          Config_File :=
 403            Create_Project
 404              (In_Tree        => Project_Tree,
 405               Name           => Name_Find,
 406               Full_Path      => Path_Name_Type (Name),
 407               Is_Config_File => True);
 408
 409          --  Setup library support
 410
 411          case MLib.Tgt.Support_For_Libraries is
 412             when None =>
 413                null;
 414
 415             when Static_Only =>
 416                Create_Attribute (Name_Library_Support, "static_only");
 417
 418             when Full =>
 419                Create_Attribute (Name_Library_Support, "full");
 420          end case;
 421
 422          if MLib.Tgt.Standalone_Library_Auto_Init_Is_Supported then
 423             Create_Attribute (Name_Library_Auto_Init_Supported, "true");
 424          else
 425             Create_Attribute (Name_Library_Auto_Init_Supported, "false");
 426          end if;
 427
 428          --  Setup Ada support (Ada is the default language here, since this
 429          --  is only called when no config file existed initially, ie for
 430          --  gnatmake).
 431
 432          Create_Attribute (Name_Default_Language, "ada");
 433
 434          Compiler := Create_Package (Project_Tree, Config_File, "compiler");
 435          Create_Attribute
 436            (Name_Driver, "gcc", "ada", Pkg => Compiler);
 437          Create_Attribute
 438            (Name_Language_Kind, "unit_based", "ada", Pkg => Compiler);
 439          Create_Attribute
 440            (Name_Dependency_Kind, "ALI_File", "ada", Pkg => Compiler);
 441
 442          Naming := Create_Package (Project_Tree, Config_File, "naming");
 443          Create_Attribute (Name_Spec_Suffix, ".ads", "ada",     Pkg => Naming);
 444          Create_Attribute (Name_Separate_Suffix, ".adb", "ada", Pkg => Naming);
 445          Create_Attribute (Name_Body_Suffix, ".adb", "ada",     Pkg => Naming);
 446          Create_Attribute (Name_Dot_Replacement, "-",           Pkg => Naming);
 447          Create_Attribute (Name_Casing,          "lowercase",   Pkg => Naming);
 448
 449          if Current_Verbosity = High then
 450             Write_Line ("Automatically generated (in-memory) config file");
 451             Prj.PP.Pretty_Print
 452               (Project                => Config_File,
 453                In_Tree                => Project_Tree,
 454                Backward_Compatibility => False);
 455          end if;
 456       end if;
 457    end Add_Default_GNAT_Naming_Scheme;
 458
 459    -----------------------
 460    -- Apply_Config_File --
 461    -----------------------
 462
 463    procedure Apply_Config_File
 464      (Config_File  : Prj.Project_Id;
 465       Project_Tree : Prj.Project_Tree_Ref)
 466    is
 467       Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared;
 468
 469       Conf_Decl    : constant Declarations := Config_File.Decl;
 470       Conf_Pack_Id : Package_Id;
 471       Conf_Pack    : Package_Element;
 472
 473       User_Decl    : Declarations;
 474       User_Pack_Id : Package_Id;
 475       User_Pack    : Package_Element;
 476       Proj         : Project_List;
 477
 478    begin
 479       Debug_Output ("Applying config file to a project tree");
 480
 481       Proj := Project_Tree.Projects;
 482       while Proj /= null loop
 483          if Proj.Project /= Config_File then
 484             User_Decl := Proj.Project.Decl;
 485             Add_Attributes
 486               (Project_Tree      => Project_Tree,
 487                Conf_Decl         => Conf_Decl,
 488                User_Decl         => User_Decl);
 489
 490             Conf_Pack_Id := Conf_Decl.Packages;
 491             while Conf_Pack_Id /= No_Package loop
 492                Conf_Pack := Shared.Packages.Table (Conf_Pack_Id);
 493
 494                User_Pack_Id := User_Decl.Packages;
 495                while User_Pack_Id /= No_Package loop
 496                   User_Pack := Shared.Packages.Table (User_Pack_Id);
 497                   exit when User_Pack.Name = Conf_Pack.Name;
 498                   User_Pack_Id := User_Pack.Next;
 499                end loop;
 500
 501                if User_Pack_Id = No_Package then
 502                   Package_Table.Increment_Last (Shared.Packages);
 503                   User_Pack := Conf_Pack;
 504                   User_Pack.Next := User_Decl.Packages;
 505                   User_Decl.Packages := Package_Table.Last (Shared.Packages);
 506                   Shared.Packages.Table (User_Decl.Packages) := User_Pack;
 507
 508                else
 509                   Add_Attributes
 510                     (Project_Tree => Project_Tree,
 511                      Conf_Decl    => Conf_Pack.Decl,
 512                      User_Decl    => Shared.Packages.Table
 513                                        (User_Pack_Id).Decl);
 514                end if;
 515
 516                Conf_Pack_Id := Conf_Pack.Next;
 517             end loop;
 518
 519             Proj.Project.Decl := User_Decl;
 520
 521             --  For aggregate projects, we need to apply the config to all
 522             --  their aggregated trees as well.
 523
 524             if Proj.Project.Qualifier in Aggregate_Project then
 525                declare
 526                   List : Aggregated_Project_List;
 527                begin
 528                   List := Proj.Project.Aggregated_Projects;
 529                   while List /= null loop
 530                      Debug_Output
 531                        ("Recursively apply config to aggregated tree",
 532                         List.Project.Name);
 533                      Apply_Config_File
 534                        (Config_File, Project_Tree => List.Tree);
 535                      List := List.Next;
 536                   end loop;
 537                end;
 538             end if;
 539          end if;
 540
 541          Proj := Proj.Next;
 542       end loop;
 543    end Apply_Config_File;
 544
 545    ------------------
 546    -- Check_Target --
 547    ------------------
 548
 549    function Check_Target
 550      (Config_File        : Project_Id;
 551       Autoconf_Specified : Boolean;
 552       Project_Tree       : Prj.Project_Tree_Ref;
 553       Target             : String := "") return Boolean
 554    is
 555       Shared   : constant Shared_Project_Tree_Data_Access :=
 556                    Project_Tree.Shared;
 557       Variable : constant Variable_Value :=
 558                    Value_Of
 559                      (Name_Target, Config_File.Decl.Attributes, Shared);
 560       Tgt_Name : Name_Id := No_Name;
 561       OK       : Boolean;
 562
 563    begin
 564       if Variable /= Nil_Variable_Value and then not Variable.Default then
 565          Tgt_Name := Variable.Value;
 566       end if;
 567
 568       OK :=
 569         Target = ""
 570           or else (Tgt_Name /= No_Name
 571                     and then Target = Get_Name_String (Tgt_Name));
 572
 573       if not OK then
 574          if Autoconf_Specified then
 575             if Verbose_Mode then
 576                Write_Line ("inconsistent targets, performing autoconf");
 577             end if;
 578
 579             return False;
 580
 581          else
 582             if Tgt_Name /= No_Name then
 583                Raise_Invalid_Config
 584                  ("invalid target name """
 585                   & Get_Name_String (Tgt_Name) & """ in configuration");
 586             else
 587                Raise_Invalid_Config
 588                  ("no target specified in configuration file");
 589             end if;
 590          end if;
 591       end if;
 592
 593       return True;
 594    end Check_Target;
 595
 596    --------------------------------------
 597    -- Get_Or_Create_Configuration_File --
 598    --------------------------------------
 599
 600    procedure Get_Or_Create_Configuration_File
 601      (Project                    : Project_Id;
 602       Conf_Project               : Project_Id;
 603       Project_Tree               : Project_Tree_Ref;
 604       Project_Node_Tree          : Prj.Tree.Project_Node_Tree_Ref;
 605       Env                        : in out Prj.Tree.Environment;
 606       Allow_Automatic_Generation : Boolean;
 607       Config_File_Name           : String := "";
 608       Autoconf_Specified         : Boolean;
 609       Target_Name                : String := "";
 610       Normalized_Hostname        : String;
 611       Packages_To_Check          : String_List_Access := null;
 612       Config                     : out Prj.Project_Id;
 613       Config_File_Path           : out String_Access;
 614       Automatically_Generated    : out Boolean;
 615       On_Load_Config             : Config_File_Hook := null)
 616    is
 617       Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared;
 618
 619       At_Least_One_Compiler_Command : Boolean := False;
 620       --  Set to True if at least one attribute Ide'Compiler_Command is
 621       --  specified for one language of the system.
 622
 623       Conf_File_Name : String_Access := new String'(Config_File_Name);
 624       --  The configuration project file name. May be modified if there are
 625       --  switches --config= in the Builder package of the main project.
 626
 627       Selected_Target : String_Access := new String'(Target_Name);
 628
 629       function Default_File_Name return String;
 630       --  Return the name of the default config file that should be tested
 631
 632       procedure Do_Autoconf;
 633       --  Generate a new config file through gprconfig. In case of error, this
 634       --  raises the Invalid_Config exception with an appropriate message
 635
 636       procedure Check_Builder_Switches;
 637       --  Check for switches --config and --RTS in package Builder
 638
 639       procedure Get_Project_Target;
 640       --  Target_Name is empty, get the specifiedtarget in the project file,
 641       --  if any.
 642
 643       function Get_Config_Switches return Argument_List_Access;
 644       --  Return the --config switches to use for gprconfig
 645
 646       function Get_Db_Switches return Argument_List_Access;
 647       --  Return the --db switches to use for gprconfig
 648
 649       function Might_Have_Sources (Project : Project_Id) return Boolean;
 650       --  True if the specified project might have sources (ie the user has not
 651       --  explicitly specified it. We haven't checked the file system, nor do
 652       --  we need to at this stage.
 653
 654       ----------------------------
 655       -- Check_Builder_Switches --
 656       ----------------------------
 657
 658       procedure Check_Builder_Switches is
 659          Get_RTS_Switches : constant Boolean :=
 660                               RTS_Languages.Get_First = No_Name;
 661          --  If no switch --RTS have been specified on the command line, look
 662          --  for --RTS switches in the Builder switches.
 663
 664          Builder : constant Package_Id :=
 665                      Value_Of (Name_Builder, Project.Decl.Packages, Shared);
 666
 667          Switch_Array_Id : Array_Element_Id;
 668          --  The Switches to be checked
 669
 670          procedure Check_Switches;
 671          --  Check the switches in Switch_Array_Id
 672
 673          --------------------
 674          -- Check_Switches --
 675          --------------------
 676
 677          procedure Check_Switches is
 678             Switch_Array    : Array_Element;
 679             Switch_List     : String_List_Id := Nil_String;
 680             Switch          : String_Element;
 681             Lang            : Name_Id;
 682             Lang_Last       : Positive;
 683
 684          begin
 685             while Switch_Array_Id /= No_Array_Element loop
 686                Switch_Array :=
 687                  Shared.Array_Elements.Table (Switch_Array_Id);
 688
 689                Switch_List := Switch_Array.Value.Values;
 690                List_Loop : while Switch_List /= Nil_String loop
 691                   Switch := Shared.String_Elements.Table (Switch_List);
 692
 693                   if Switch.Value /= No_Name then
 694                      Get_Name_String (Switch.Value);
 695
 696                      if Conf_File_Name'Length = 0
 697                        and then Name_Len > 9
 698                        and then Name_Buffer (1 .. 9) = "--config="
 699                      then
 700                         Conf_File_Name :=
 701                           new String'(Name_Buffer (10 .. Name_Len));
 702
 703                      elsif Get_RTS_Switches
 704                        and then Name_Len >= 7
 705                        and then Name_Buffer (1 .. 5) = "--RTS"
 706                      then
 707                         if Name_Buffer (6) = '=' then
 708                            if not Runtime_Name_Set_For (Name_Ada) then
 709                               Set_Runtime_For
 710                                 (Name_Ada,
 711                                  Name_Buffer (7 .. Name_Len));
 712                               Locate_Runtime (Name_Ada, Project_Tree);
 713                            end if;
 714
 715                         elsif Name_Len > 7
 716                           and then Name_Buffer (6) = ':'
 717                           and then Name_Buffer (7) /= '='
 718                         then
 719                            Lang_Last := 7;
 720                            while Lang_Last < Name_Len
 721                              and then Name_Buffer (Lang_Last + 1) /= '='
 722                            loop
 723                               Lang_Last := Lang_Last + 1;
 724                            end loop;
 725
 726                            if Name_Buffer (Lang_Last + 1) = '=' then
 727                               declare
 728                                  RTS : constant String :=
 729                                    Name_Buffer (Lang_Last + 2 .. Name_Len);
 730                               begin
 731                                  Name_Buffer (1 .. Lang_Last - 6) :=
 732                                    Name_Buffer (7 .. Lang_Last);
 733                                  Name_Len := Lang_Last - 6;
 734                                  To_Lower (Name_Buffer (1 .. Name_Len));
 735                                  Lang := Name_Find;
 736
 737                                  if not Runtime_Name_Set_For (Lang) then
 738                                     Set_Runtime_For (Lang, RTS);
 739                                     Locate_Runtime (Lang, Project_Tree);
 740                                  end if;
 741                               end;
 742                            end if;
 743                         end if;
 744                      end if;
 745                   end if;
 746
 747                   Switch_List := Switch.Next;
 748                end loop List_Loop;
 749
 750                Switch_Array_Id := Switch_Array.Next;
 751             end loop;
 752          end Check_Switches;
 753
 754       --  Start of processing for Check_Builder_Switches
 755
 756       begin
 757          if Builder /= No_Package then
 758             Switch_Array_Id :=
 759               Value_Of
 760                 (Name      => Name_Switches,
 761                  In_Arrays => Shared.Packages.Table (Builder).Decl.Arrays,
 762                  Shared    => Shared);
 763             Check_Switches;
 764
 765             Switch_Array_Id :=
 766               Value_Of
 767                 (Name      => Name_Default_Switches,
 768                  In_Arrays => Shared.Packages.Table (Builder).Decl.Arrays,
 769                  Shared    => Shared);
 770             Check_Switches;
 771          end if;
 772       end Check_Builder_Switches;
 773
 774       ------------------------
 775       -- Get_Project_Target --
 776       ------------------------
 777
 778       procedure Get_Project_Target is
 779       begin
 780          if Selected_Target'Length = 0 then
 781
 782             --  Check if attribute Target is specified in the main
 783             --  project, or in a project it extends. If it is, use this
 784             --  target to invoke gprconfig.
 785
 786             declare
 787                Variable : Variable_Value;
 788                Proj     : Project_Id;
 789                Tgt_Name : Name_Id := No_Name;
 790
 791             begin
 792                Proj := Project;
 793                Project_Loop :
 794                while Proj /= No_Project loop
 795                   Variable :=
 796                     Value_Of (Name_Target, Proj.Decl.Attributes, Shared);
 797
 798                   if Variable /= Nil_Variable_Value
 799                     and then not Variable.Default
 800                     and then Variable.Value /= No_Name
 801                   then
 802                      Tgt_Name := Variable.Value;
 803                      exit Project_Loop;
 804                   end if;
 805
 806                   Proj := Proj.Extends;
 807                end loop Project_Loop;
 808
 809                if Tgt_Name /= No_Name then
 810                   Selected_Target := new String'(Get_Name_String (Tgt_Name));
 811                end if;
 812             end;
 813          end if;
 814       end Get_Project_Target;
 815
 816       -----------------------
 817       -- Default_File_Name --
 818       -----------------------
 819
 820       function Default_File_Name return String is
 821          Ada_RTS : constant String := Runtime_Name_For (Name_Ada);
 822          Tmp     : String_Access;
 823
 824       begin
 825          if Selected_Target'Length /= 0 then
 826             if Ada_RTS /= "" then
 827                return
 828                  Selected_Target.all & '-' &
 829                  Ada_RTS & Config_Project_File_Extension;
 830             else
 831                return
 832                  Selected_Target.all & Config_Project_File_Extension;
 833             end if;
 834
 835          elsif Ada_RTS /= "" then
 836             return Ada_RTS & Config_Project_File_Extension;
 837
 838          else
 839             Tmp := Getenv (Config_Project_Env_Var);
 840
 841             declare
 842                T : constant String := Tmp.all;
 843
 844             begin
 845                Free (Tmp);
 846
 847                if T'Length = 0 then
 848                   return Default_Config_Name;
 849                else
 850                   return T;
 851                end if;
 852             end;
 853          end if;
 854       end Default_File_Name;
 855
 856       -----------------
 857       -- Do_Autoconf --
 858       -----------------
 859
 860       procedure Do_Autoconf is
 861          Obj_Dir : constant Variable_Value :=
 862                      Value_Of
 863                        (Name_Object_Dir,
 864                         Conf_Project.Decl.Attributes,
 865                         Shared);
 866
 867          Gprconfig_Path  : String_Access;
 868          Success         : Boolean;
 869
 870       begin
 871          Gprconfig_Path := Locate_Exec_On_Path (Gprconfig_Name);
 872
 873          if Gprconfig_Path = null then
 874             Raise_Invalid_Config
 875               ("could not locate gprconfig for auto-configuration");
 876          end if;
 877
 878          --  First, find the object directory of the Conf_Project
 879
 880          if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then
 881             Get_Name_String (Conf_Project.Directory.Display_Name);
 882
 883          else
 884             if Is_Absolute_Path (Get_Name_String (Obj_Dir.Value)) then
 885                Get_Name_String (Obj_Dir.Value);
 886
 887             else
 888                Name_Len := 0;
 889                Add_Str_To_Name_Buffer
 890                  (Get_Name_String (Conf_Project.Directory.Display_Name));
 891                Add_Str_To_Name_Buffer (Get_Name_String (Obj_Dir.Value));
 892             end if;
 893          end if;
 894
 895          if Subdirs /= null then
 896             Add_Char_To_Name_Buffer (Directory_Separator);
 897             Add_Str_To_Name_Buffer (Subdirs.all);
 898          end if;
 899
 900          for J in 1 .. Name_Len loop
 901             if Name_Buffer (J) = '/' then
 902                Name_Buffer (J) := Directory_Separator;
 903             end if;
 904          end loop;
 905
 906          --  Make sure that Obj_Dir ends with a directory separator
 907
 908          if Name_Buffer (Name_Len) /= Directory_Separator then
 909             Name_Len := Name_Len + 1;
 910             Name_Buffer (Name_Len) := Directory_Separator;
 911          end if;
 912
 913          declare
 914             Obj_Dir         : constant String := Name_Buffer (1 .. Name_Len);
 915             Config_Switches : Argument_List_Access;
 916             Db_Switches     : Argument_List_Access;
 917             Args            : Argument_List (1 .. 5);
 918             Arg_Last        : Positive;
 919             Obj_Dir_Exists  : Boolean := True;
 920
 921          begin
 922             --  Check if the object directory exists. If Setup_Projects is True
 923             --  (-p) and directory does not exist, attempt to create it.
 924             --  Otherwise, if directory does not exist, fail without calling
 925             --  gprconfig.
 926
 927             if not Is_Directory (Obj_Dir)
 928               and then (Setup_Projects or else Subdirs /= null)
 929             then
 930                begin
 931                   Create_Path (Obj_Dir);
 932
 933                   if not Quiet_Output then
 934                      Write_Str ("object directory """);
 935                      Write_Str (Obj_Dir);
 936                      Write_Line (""" created");
 937                   end if;
 938
 939                exception
 940                   when others =>
 941                      Raise_Invalid_Config
 942                        ("could not create object directory " & Obj_Dir);
 943                end;
 944             end if;
 945
 946             if not Is_Directory (Obj_Dir) then
 947                case Env.Flags.Require_Obj_Dirs is
 948                   when Error =>
 949                      Raise_Invalid_Config
 950                        ("object directory " & Obj_Dir & " does not exist");
 951
 952                   when Warning =>
 953                      Prj.Err.Error_Msg
 954                        (Env.Flags,
 955                         "?object directory " & Obj_Dir & " does not exist");
 956                      Obj_Dir_Exists := False;
 957
 958                   when Silent =>
 959                      null;
 960                end case;
 961             end if;
 962
 963             --  Get the config switches. This should be done only now, as some
 964             --  runtimes may have been found if the Builder switches.
 965
 966             Config_Switches := Get_Config_Switches;
 967
 968             --  Get eventual --db switches
 969
 970             Db_Switches := Get_Db_Switches;
 971
 972             --  Invoke gprconfig
 973
 974             Args (1) := new String'("--batch");
 975             Args (2) := new String'("-o");
 976
 977             --  If no config file was specified, set the auto.cgpr one
 978
 979             if Conf_File_Name'Length = 0 then
 980                if Obj_Dir_Exists then
 981                   Args (3) := new String'(Obj_Dir & Auto_Cgpr);
 982
 983                else
 984                   declare
 985                      Path_FD   : File_Descriptor;
 986                      Path_Name : Path_Name_Type;
 987
 988                   begin
 989                      Prj.Env.Create_Temp_File
 990                        (Shared    => Project_Tree.Shared,
 991                         Path_FD   => Path_FD,
 992                         Path_Name => Path_Name,
 993                         File_Use  => "configuration file");
 994
 995                      if Path_FD /= Invalid_FD then
 996                         declare
 997                            Temp_Dir : constant String :=
 998                                         Containing_Directory
 999                                           (Get_Name_String (Path_Name));
1000                         begin
1001                            GNAT.OS_Lib.Close (Path_FD);
1002                            Args (3) :=
1003                              new String'(Temp_Dir &
1004                                          Directory_Separator &
1005                                          Auto_Cgpr);
1006                            Delete_File (Get_Name_String (Path_Name));
1007                         end;
1008
1009                      else
1010                         --  We'll have an error message later on
1011
1012                         Args (3) := new String'(Obj_Dir & Auto_Cgpr);
1013                      end if;
1014                   end;
1015                end if;
1016             else
1017                Args (3) := Conf_File_Name;
1018             end if;
1019
1020             if Normalized_Hostname = "" then
1021                Arg_Last := 3;
1022             else
1023                if Selected_Target'Length = 0 then
1024                   if At_Least_One_Compiler_Command then
1025                      Args (4) :=
1026                        new String'("--target=all");
1027                   else
1028                      Args (4) :=
1029                        new String'("--target=" & Normalized_Hostname);
1030                   end if;
1031
1032                else
1033                   Args (4) :=
1034                     new String'("--target=" & Selected_Target.all);
1035                end if;
1036
1037                Arg_Last := 4;
1038             end if;
1039
1040             if not Verbose_Mode then
1041                Arg_Last := Arg_Last + 1;
1042                Args (Arg_Last) := new String'("-q");
1043             end if;
1044
1045             if Verbose_Mode then
1046                Write_Str (Gprconfig_Name);
1047
1048                for J in 1 .. Arg_Last loop
1049                   Write_Char (' ');
1050                   Write_Str (Args (J).all);
1051                end loop;
1052
1053                for J in Config_Switches'Range loop
1054                   Write_Char (' ');
1055                   Write_Str (Config_Switches (J).all);
1056                end loop;
1057
1058                for J in Db_Switches'Range loop
1059                   Write_Char (' ');
1060                   Write_Str (Db_Switches (J).all);
1061                end loop;
1062
1063                Write_Eol;
1064
1065             elsif not Quiet_Output then
1066                --  Display no message if we are creating auto.cgpr, unless in
1067                --  verbose mode
1068
1069                if Config_File_Name'Length > 0
1070                  or else Verbose_Mode
1071                then
1072                   Write_Str ("creating ");
1073                   Write_Str (Simple_Name (Args (3).all));
1074                   Write_Eol;
1075                end if;
1076             end if;
1077
1078             Spawn (Gprconfig_Path.all, Args (1 .. Arg_Last) &
1079                    Config_Switches.all & Db_Switches.all,
1080                    Success);
1081
1082             Free (Config_Switches);
1083
1084             Config_File_Path := Locate_Config_File (Args (3).all);
1085
1086             if Config_File_Path = null then
1087                Raise_Invalid_Config
1088                  ("could not create " & Args (3).all);
1089             end if;
1090
1091             for F in Args'Range loop
1092                Free (Args (F));
1093             end loop;
1094          end;
1095       end Do_Autoconf;
1096
1097       ---------------------
1098       -- Get_Db_Switches --
1099       ---------------------
1100
1101       function Get_Db_Switches return Argument_List_Access is
1102          Result : Argument_List_Access;
1103          Nmb_Arg : Natural;
1104       begin
1105          Nmb_Arg :=
1106            (2 * Db_Switch_Args.Last) + Boolean'Pos (not Load_Standard_Base);
1107          Result := new Argument_List (1 .. Nmb_Arg);
1108
1109          if Nmb_Arg /= 0 then
1110             for J in 1 .. Db_Switch_Args.Last loop
1111                Result (2 * J - 1) :=
1112                  new String'("--db");
1113                Result (2 * J) :=
1114                  new String'(Get_Name_String (Db_Switch_Args.Table (J)));
1115             end loop;
1116
1117             if not Load_Standard_Base then
1118                Result (Result'Last) := new String'("--db-");
1119             end if;
1120          end if;
1121
1122          return Result;
1123       end Get_Db_Switches;
1124
1125       -------------------------
1126       -- Get_Config_Switches --
1127       -------------------------
1128
1129       function Get_Config_Switches return Argument_List_Access is
1130
1131          package Language_Htable is new GNAT.HTable.Simple_HTable
1132            (Header_Num => Prj.Header_Num,
1133             Element    => Name_Id,
1134             No_Element => No_Name,
1135             Key        => Name_Id,
1136             Hash       => Prj.Hash,
1137             Equal      => "=");
1138          --  Hash table to keep the languages used in the project tree
1139
1140          IDE : constant Package_Id :=
1141                  Value_Of (Name_Ide, Project.Decl.Packages, Shared);
1142
1143          procedure Add_Config_Switches_For_Project
1144            (Project    : Project_Id;
1145             Tree       : Project_Tree_Ref;
1146             With_State : in out Integer);
1147          --  Add all --config switches for this project. This is also called
1148          --  for aggregate projects.
1149
1150          -------------------------------------
1151          -- Add_Config_Switches_For_Project --
1152          -------------------------------------
1153
1154          procedure Add_Config_Switches_For_Project
1155            (Project    : Project_Id;
1156             Tree       : Project_Tree_Ref;
1157             With_State : in out Integer)
1158          is
1159             pragma Unreferenced (With_State);
1160
1161             Shared : constant Shared_Project_Tree_Data_Access := Tree.Shared;
1162
1163             Variable      : Variable_Value;
1164             Check_Default : Boolean;
1165             Lang          : Name_Id;
1166             List          : String_List_Id;
1167             Elem          : String_Element;
1168
1169          begin
1170             if Might_Have_Sources (Project) then
1171                Variable :=
1172                  Value_Of (Name_Languages, Project.Decl.Attributes, Shared);
1173
1174                if Variable = Nil_Variable_Value or else Variable.Default then
1175
1176                   --  Languages is not declared. If it is not an extending
1177                   --  project, or if it extends a project with no Languages,
1178                   --  check for Default_Language.
1179
1180                   Check_Default := Project.Extends = No_Project;
1181
1182                   if not Check_Default then
1183                      Variable :=
1184                        Value_Of
1185                          (Name_Languages,
1186                           Project.Extends.Decl.Attributes,
1187                           Shared);
1188                      Check_Default :=
1189                        Variable /= Nil_Variable_Value
1190                          and then Variable.Values = Nil_String;
1191                   end if;
1192
1193                   if Check_Default then
1194                      Variable :=
1195                        Value_Of
1196                          (Name_Default_Language,
1197                           Project.Decl.Attributes,
1198                           Shared);
1199
1200                      if Variable /= Nil_Variable_Value
1201                        and then not Variable.Default
1202                      then
1203                         Get_Name_String (Variable.Value);
1204                         To_Lower (Name_Buffer (1 .. Name_Len));
1205                         Lang := Name_Find;
1206                         Language_Htable.Set (Lang, Lang);
1207
1208                      --  If no default language is declared, default to Ada
1209
1210                      else
1211                         Language_Htable.Set (Name_Ada, Name_Ada);
1212                      end if;
1213                   end if;
1214
1215                elsif Variable.Values /= Nil_String then
1216
1217                   --  Attribute Languages is declared with a non empty list:
1218                   --  put all the languages in Language_HTable.
1219
1220                   List := Variable.Values;
1221                   while List /= Nil_String loop
1222                      Elem := Shared.String_Elements.Table (List);
1223
1224                      Get_Name_String (Elem.Value);
1225                      To_Lower (Name_Buffer (1 .. Name_Len));
1226                      Lang := Name_Find;
1227                      Language_Htable.Set (Lang, Lang);
1228
1229                      List := Elem.Next;
1230                   end loop;
1231                end if;
1232             end if;
1233          end Add_Config_Switches_For_Project;
1234
1235          procedure For_Every_Imported_Project is new For_Every_Project_Imported
1236            (State => Integer, Action => Add_Config_Switches_For_Project);
1237          --  Document this procedure ???
1238
1239          --  Local variables
1240
1241          Name     : Name_Id;
1242          Count    : Natural;
1243          Result   : Argument_List_Access;
1244          Variable : Variable_Value;
1245          Dummy    : Integer := 0;
1246
1247       --  Start of processing for Get_Config_Switches
1248
1249       begin
1250          For_Every_Imported_Project
1251            (By                 => Project,
1252             Tree               => Project_Tree,
1253             With_State         => Dummy,
1254             Include_Aggregated => True);
1255
1256          Name  := Language_Htable.Get_First;
1257          Count := 0;
1258          while Name /= No_Name loop
1259             Count := Count + 1;
1260             Name := Language_Htable.Get_Next;
1261          end loop;
1262
1263          Result := new String_List (1 .. Count);
1264
1265          Count := 1;
1266          Name  := Language_Htable.Get_First;
1267          while Name /= No_Name loop
1268
1269             --  Check if IDE'Compiler_Command is declared for the language.
1270             --  If it is, use its value to invoke gprconfig.
1271
1272             Variable :=
1273               Value_Of
1274                 (Name,
1275                  Attribute_Or_Array_Name => Name_Compiler_Command,
1276                  In_Package              => IDE,
1277                  Shared                  => Shared,
1278                  Force_Lower_Case_Index  => True);
1279
1280             declare
1281                Config_Command : constant String :=
1282                                   "--config=" & Get_Name_String (Name);
1283
1284                Runtime_Name   : constant String :=
1285                                   Runtime_Name_For (Name);
1286
1287             begin
1288                if Variable = Nil_Variable_Value
1289                  or else Length_Of_Name (Variable.Value) = 0
1290                then
1291                   Result (Count) :=
1292                     new String'(Config_Command & ",," & Runtime_Name);
1293
1294                else
1295                   At_Least_One_Compiler_Command := True;
1296
1297                   declare
1298                      Compiler_Command : constant String :=
1299                                           Get_Name_String (Variable.Value);
1300
1301                   begin
1302                      if Is_Absolute_Path (Compiler_Command) then
1303                         Result (Count) :=
1304                           new String'
1305                             (Config_Command & ",," & Runtime_Name & "," &
1306                              Containing_Directory (Compiler_Command) & "," &
1307                              Simple_Name (Compiler_Command));
1308                      else
1309                         Result (Count) :=
1310                           new String'
1311                             (Config_Command & ",," & Runtime_Name & ",," &
1312                              Compiler_Command);
1313                      end if;
1314                   end;
1315                end if;
1316             end;
1317
1318             Count := Count + 1;
1319             Name  := Language_Htable.Get_Next;
1320          end loop;
1321
1322          return Result;
1323       end Get_Config_Switches;
1324
1325       ------------------------
1326       -- Might_Have_Sources --
1327       ------------------------
1328
1329       function Might_Have_Sources (Project : Project_Id) return Boolean is
1330          Variable : Variable_Value;
1331
1332       begin
1333          Variable :=
1334            Value_Of
1335              (Name_Source_Dirs,
1336               Project.Decl.Attributes,
1337               Shared);
1338
1339          if Variable = Nil_Variable_Value
1340            or else Variable.Default
1341            or else Variable.Values /= Nil_String
1342          then
1343             Variable :=
1344               Value_Of
1345                 (Name_Source_Files,
1346                  Project.Decl.Attributes,
1347                  Shared);
1348             return Variable = Nil_Variable_Value
1349               or else Variable.Default
1350               or else Variable.Values /= Nil_String;
1351
1352          else
1353             return False;
1354          end if;
1355       end Might_Have_Sources;
1356
1357       Success             : Boolean;
1358       Config_Project_Node : Project_Node_Id := Empty_Node;
1359
1360    begin
1361       pragma Assert (Prj.Env.Is_Initialized (Env.Project_Path));
1362
1363       Free (Config_File_Path);
1364       Config := No_Project;
1365
1366       Get_Project_Target;
1367       Check_Builder_Switches;
1368
1369       if Conf_File_Name'Length > 0 then
1370          Config_File_Path := Locate_Config_File (Conf_File_Name.all);
1371       else
1372          Config_File_Path := Locate_Config_File (Default_File_Name);
1373       end if;
1374
1375       if Config_File_Path = null then
1376          if not Allow_Automatic_Generation
1377            and then Conf_File_Name'Length > 0
1378          then
1379             Raise_Invalid_Config
1380               ("could not locate main configuration project "
1381                & Conf_File_Name.all);
1382          end if;
1383       end if;
1384
1385       Automatically_Generated :=
1386         Allow_Automatic_Generation and then Config_File_Path = null;
1387
1388       <<Process_Config_File>>
1389
1390       if Automatically_Generated then
1391          if Hostparm.OpenVMS then
1392
1393             --  There is no gprconfig on VMS
1394
1395             Raise_Invalid_Config
1396               ("could not locate any configuration project file");
1397
1398          else
1399             --  This might raise an Invalid_Config exception
1400
1401             Do_Autoconf;
1402          end if;
1403
1404       --  If the config file is not auto-generated, warn if there is any --RTS
1405       --  switch, but not when the config file is generated in memory.
1406
1407       elsif RTS_Languages.Get_First /= No_Name
1408         and then Opt.Warning_Mode /= Opt.Suppress
1409         and then On_Load_Config = null
1410       then
1411          Write_Line
1412            ("warning: --RTS is taken into account only in auto-configuration");
1413       end if;
1414
1415       --  Parse the configuration file
1416
1417       if Verbose_Mode and then Config_File_Path /= null then
1418          Write_Str  ("Checking configuration ");
1419          Write_Line (Config_File_Path.all);
1420       end if;
1421
1422       if On_Load_Config /= null then
1423          On_Load_Config
1424            (Config_File       => Config_Project_Node,
1425             Project_Node_Tree => Project_Node_Tree);
1426
1427       elsif Config_File_Path /= null then
1428          Prj.Part.Parse
1429            (In_Tree           => Project_Node_Tree,
1430             Project           => Config_Project_Node,
1431             Project_File_Name => Config_File_Path.all,
1432             Errout_Handling   => Prj.Part.Finalize_If_Error,
1433             Packages_To_Check => Packages_To_Check,
1434             Current_Directory => Current_Directory,
1435             Is_Config_File    => True,
1436             Env               => Env);
1437       else
1438          Config_Project_Node := Empty_Node;
1439       end if;
1440
1441       if Config_Project_Node /= Empty_Node then
1442          Prj.Proc.Process_Project_Tree_Phase_1
1443            (In_Tree                => Project_Tree,
1444             Project                => Config,
1445             Packages_To_Check      => Packages_To_Check,
1446             Success                => Success,
1447             From_Project_Node      => Config_Project_Node,
1448             From_Project_Node_Tree => Project_Node_Tree,
1449             Env                    => Env,
1450             Reset_Tree             => False);
1451       end if;
1452
1453       if Config_Project_Node = Empty_Node
1454         or else Config = No_Project
1455       then
1456          Raise_Invalid_Config
1457            ("processing of configuration project """
1458             & Config_File_Path.all & """ failed");
1459       end if;
1460
1461       --  Check that the target of the configuration file is the one the user
1462       --  specified on the command line. We do not need to check that when in
1463       --  auto-conf mode, since the appropriate target was passed to gprconfig.
1464
1465       if not Automatically_Generated
1466         and then not
1467           Check_Target
1468             (Config, Autoconf_Specified, Project_Tree, Selected_Target.all)
1469       then
1470          Automatically_Generated := True;
1471          goto Process_Config_File;
1472       end if;
1473    end Get_Or_Create_Configuration_File;
1474
1475    ------------------------
1476    -- Locate_Config_File --
1477    ------------------------
1478
1479    function Locate_Config_File (Name : String) return String_Access is
1480       Prefix_Path : constant String := Executable_Prefix_Path;
1481    begin
1482       if Prefix_Path'Length /= 0 then
1483          return Locate_Regular_File
1484            (Name,
1485             "." & Path_Separator &
1486             Prefix_Path & "share" & Directory_Separator & "gpr");
1487       else
1488          return Locate_Regular_File (Name, ".");
1489       end if;
1490    end Locate_Config_File;
1491
1492    --------------------
1493    -- Locate_Runtime --
1494    --------------------
1495
1496    procedure Locate_Runtime
1497      (Language     : Name_Id;
1498       Project_Tree : Prj.Project_Tree_Ref)
1499    is
1500       function Is_Base_Name (Path : String) return Boolean;
1501       --  Returns True if Path has no directory separator
1502
1503       ------------------
1504       -- Is_Base_Name --
1505       ------------------
1506
1507       function Is_Base_Name (Path : String) return Boolean is
1508       begin
1509          for I in Path'Range loop
1510             if Path (I) = Directory_Separator or else Path (I) = '/' then
1511                return False;
1512             end if;
1513          end loop;
1514          return True;
1515       end Is_Base_Name;
1516
1517       --  Local declarations
1518
1519       function Find_Rts_In_Path is new Prj.Env.Find_Name_In_Path
1520         (Check_Filename => Is_Directory);
1521
1522       RTS_Name : constant String := Runtime_Name_For (Language);
1523
1524       Full_Path : String_Access;
1525
1526    --  Start of processing for Locate_Runtime
1527
1528    begin
1529       if not Is_Base_Name (RTS_Name) then
1530          Full_Path :=
1531            Find_Rts_In_Path (Root_Environment.Project_Path, RTS_Name);
1532
1533          if Full_Path = null then
1534             Fail_Program (Project_Tree, "cannot find RTS " & RTS_Name);
1535          end if;
1536
1537          Set_Runtime_For (Language, Normalize_Pathname (Full_Path.all));
1538          Free (Full_Path);
1539       end if;
1540    end Locate_Runtime;
1541
1542    ------------------------------------
1543    -- Parse_Project_And_Apply_Config --
1544    ------------------------------------
1545
1546    procedure Parse_Project_And_Apply_Config
1547      (Main_Project               : out Prj.Project_Id;
1548       User_Project_Node          : out Prj.Tree.Project_Node_Id;
1549       Config_File_Name           : String := "";
1550       Autoconf_Specified         : Boolean;
1551       Project_File_Name          : String;
1552       Project_Tree               : Prj.Project_Tree_Ref;
1553       Project_Node_Tree          : Prj.Tree.Project_Node_Tree_Ref;
1554       Env                        : in out Prj.Tree.Environment;
1555       Packages_To_Check          : String_List_Access;
1556       Allow_Automatic_Generation : Boolean := True;
1557       Automatically_Generated    : out Boolean;
1558       Config_File_Path           : out String_Access;
1559       Target_Name                : String := "";
1560       Normalized_Hostname        : String;
1561       On_Load_Config             : Config_File_Hook := null)
1562    is
1563    begin
1564       pragma Assert (Prj.Env.Is_Initialized (Env.Project_Path));
1565
1566       --  Parse the user project tree
1567
1568       Prj.Initialize (Project_Tree);
1569
1570       Main_Project := No_Project;
1571       Automatically_Generated := False;
1572
1573       Prj.Part.Parse
1574         (In_Tree           => Project_Node_Tree,
1575          Project           => User_Project_Node,
1576          Project_File_Name => Project_File_Name,
1577          Errout_Handling   => Prj.Part.Finalize_If_Error,
1578          Packages_To_Check => Packages_To_Check,
1579          Current_Directory => Current_Directory,
1580          Is_Config_File    => False,
1581          Env               => Env);
1582
1583       if User_Project_Node = Empty_Node then
1584          User_Project_Node := Empty_Node;
1585          return;
1586       end if;
1587
1588       Process_Project_And_Apply_Config
1589         (Main_Project               => Main_Project,
1590          User_Project_Node          => User_Project_Node,
1591          Config_File_Name           => Config_File_Name,
1592          Autoconf_Specified         => Autoconf_Specified,
1593          Project_Tree               => Project_Tree,
1594          Project_Node_Tree          => Project_Node_Tree,
1595          Env                        => Env,
1596          Packages_To_Check          => Packages_To_Check,
1597          Allow_Automatic_Generation => Allow_Automatic_Generation,
1598          Automatically_Generated    => Automatically_Generated,
1599          Config_File_Path           => Config_File_Path,
1600          Target_Name                => Target_Name,
1601          Normalized_Hostname        => Normalized_Hostname,
1602          On_Load_Config             => On_Load_Config);
1603    end Parse_Project_And_Apply_Config;
1604
1605    --------------------------------------
1606    -- Process_Project_And_Apply_Config --
1607    --------------------------------------
1608
1609    procedure Process_Project_And_Apply_Config
1610      (Main_Project               : out Prj.Project_Id;
1611       User_Project_Node          : Prj.Tree.Project_Node_Id;
1612       Config_File_Name           : String := "";
1613       Autoconf_Specified         : Boolean;
1614       Project_Tree               : Prj.Project_Tree_Ref;
1615       Project_Node_Tree          : Prj.Tree.Project_Node_Tree_Ref;
1616       Env                        : in out Prj.Tree.Environment;
1617       Packages_To_Check          : String_List_Access;
1618       Allow_Automatic_Generation : Boolean := True;
1619       Automatically_Generated    : out Boolean;
1620       Config_File_Path           : out String_Access;
1621       Target_Name                : String := "";
1622       Normalized_Hostname        : String;
1623       On_Load_Config             : Config_File_Hook := null;
1624       Reset_Tree                 : Boolean := True)
1625    is
1626       Shared              : constant Shared_Project_Tree_Data_Access :=
1627                               Project_Tree.Shared;
1628       Main_Config_Project : Project_Id;
1629       Success             : Boolean;
1630
1631       Conf_Project : Project_Id := No_Project;
1632       --  The object directory of this project is used to store the config
1633       --  project file in auto-configuration. Set by Check_Project below.
1634
1635       procedure Check_Project (Project : Project_Id);
1636       --  Look for a non aggregate project. If one is found, put its project Id
1637       --  in Conf_Project.
1638
1639       -------------------
1640       -- Check_Project --
1641       -------------------
1642
1643       procedure Check_Project (Project : Project_Id) is
1644       begin
1645          if Project.Qualifier = Aggregate
1646               or else
1647             Project.Qualifier = Aggregate_Library
1648          then
1649             declare
1650                List : Aggregated_Project_List := Project.Aggregated_Projects;
1651
1652             begin
1653                --  Look for a non aggregate project until one is found
1654
1655                while Conf_Project = No_Project and then List /= null loop
1656                   Check_Project (List.Project);
1657                   List := List.Next;
1658                end loop;
1659             end;
1660
1661          else
1662             Conf_Project := Project;
1663          end if;
1664       end Check_Project;
1665
1666    --  Start of processing for Process_Project_And_Apply_Config
1667
1668    begin
1669       Main_Project := No_Project;
1670       Automatically_Generated := False;
1671
1672       Process_Project_Tree_Phase_1
1673         (In_Tree                => Project_Tree,
1674          Project                => Main_Project,
1675          Packages_To_Check      => Packages_To_Check,
1676          Success                => Success,
1677          From_Project_Node      => User_Project_Node,
1678          From_Project_Node_Tree => Project_Node_Tree,
1679          Env                    => Env,
1680          Reset_Tree             => Reset_Tree);
1681
1682       if not Success then
1683          Main_Project := No_Project;
1684          return;
1685       end if;
1686
1687       if Project_Tree.Source_Info_File_Name /= null then
1688          if not Is_Absolute_Path (Project_Tree.Source_Info_File_Name.all) then
1689             declare
1690                Obj_Dir : constant Variable_Value :=
1691                            Value_Of
1692                              (Name_Object_Dir,
1693                               Main_Project.Decl.Attributes,
1694                               Shared);
1695
1696             begin
1697                if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then
1698                   Get_Name_String (Main_Project.Directory.Display_Name);
1699
1700                else
1701                   if Is_Absolute_Path (Get_Name_String (Obj_Dir.Value)) then
1702                      Get_Name_String (Obj_Dir.Value);
1703
1704                   else
1705                      Name_Len := 0;
1706                      Add_Str_To_Name_Buffer
1707                        (Get_Name_String (Main_Project.Directory.Display_Name));
1708                      Add_Str_To_Name_Buffer (Get_Name_String (Obj_Dir.Value));
1709                   end if;
1710                end if;
1711
1712                Add_Char_To_Name_Buffer (Directory_Separator);
1713                Add_Str_To_Name_Buffer (Project_Tree.Source_Info_File_Name.all);
1714                Free (Project_Tree.Source_Info_File_Name);
1715                Project_Tree.Source_Info_File_Name :=
1716                  new String'(Name_Buffer (1 .. Name_Len));
1717             end;
1718          end if;
1719
1720          Read_Source_Info_File (Project_Tree);
1721       end if;
1722
1723       --  Get the first project that is not an aggregate project or an
1724       --  aggregate library project. The object directory of this project will
1725       --  be used to store the config project file in auto-configuration.
1726
1727       Check_Project (Main_Project);
1728
1729       --  Fail if there is only aggregate projects and aggregate library
1730       --  projects in the project tree.
1731
1732       if Conf_Project = No_Project then
1733          Raise_Invalid_Config ("there are no non-aggregate projects");
1734       end if;
1735
1736       --  Find configuration file
1737
1738       Get_Or_Create_Configuration_File
1739         (Config                     => Main_Config_Project,
1740          Project                    => Main_Project,
1741          Conf_Project               => Conf_Project,
1742          Project_Tree               => Project_Tree,
1743          Project_Node_Tree          => Project_Node_Tree,
1744          Env                        => Env,
1745          Allow_Automatic_Generation => Allow_Automatic_Generation,
1746          Config_File_Name           => Config_File_Name,
1747          Autoconf_Specified         => Autoconf_Specified,
1748          Target_Name                => Target_Name,
1749          Normalized_Hostname        => Normalized_Hostname,
1750          Packages_To_Check          => Packages_To_Check,
1751          Config_File_Path           => Config_File_Path,
1752          Automatically_Generated    => Automatically_Generated,
1753          On_Load_Config             => On_Load_Config);
1754
1755       Apply_Config_File (Main_Config_Project, Project_Tree);
1756
1757       --  Finish processing the user's project
1758
1759       Prj.Proc.Process_Project_Tree_Phase_2
1760         (In_Tree                => Project_Tree,
1761          Project                => Main_Project,
1762          Success                => Success,
1763          From_Project_Node      => User_Project_Node,
1764          From_Project_Node_Tree => Project_Node_Tree,
1765          Env                    => Env);
1766
1767       if Success then
1768          if Project_Tree.Source_Info_File_Name /= null
1769            and then not Project_Tree.Source_Info_File_Exists
1770          then
1771             Write_Source_Info_File (Project_Tree);
1772          end if;
1773
1774       else
1775          Main_Project := No_Project;
1776       end if;
1777    end Process_Project_And_Apply_Config;
1778
1779    --------------------------
1780    -- Raise_Invalid_Config --
1781    --------------------------
1782
1783    procedure Raise_Invalid_Config (Msg : String) is
1784    begin
1785       Raise_Exception (Invalid_Config'Identity, Msg);
1786    end Raise_Invalid_Config;
1787
1788    ----------------------
1789    -- Runtime_Name_For --
1790    ----------------------
1791
1792    function Runtime_Name_For (Language : Name_Id) return String is
1793    begin
1794       if RTS_Languages.Get (Language) /= No_Name then
1795          return Get_Name_String (RTS_Languages.Get (Language));
1796       else
1797          return "";
1798       end if;
1799    end Runtime_Name_For;
1800
1801    --------------------------
1802    -- Runtime_Name_Set_For --
1803    --------------------------
1804
1805    function Runtime_Name_Set_For (Language : Name_Id) return Boolean is
1806    begin
1807       return RTS_Languages.Get (Language) /= No_Name;
1808    end Runtime_Name_Set_For;
1809
1810    ---------------------
1811    -- Set_Runtime_For --
1812    ---------------------
1813
1814    procedure Set_Runtime_For (Language : Name_Id; RTS_Name : String) is
1815    begin
1816       Name_Len := RTS_Name'Length;
1817       Name_Buffer (1 .. Name_Len) := RTS_Name;
1818       RTS_Languages.Set (Language, Name_Find);
1819    end Set_Runtime_For;
1820
1821 end Prj.Conf;