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-2010, 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    Default_Name : constant String := "default.cgpr";
  52    --  Default configuration file that will be used if found
  53
  54    Config_Project_Env_Var : constant String := "GPR_CONFIG";
  55    --  Name of the environment variable that provides the name of the
  56    --  configuration file to use.
  57
  58    Gprconfig_Name : constant String := "gprconfig";
  59
  60    package RTS_Languages is new GNAT.HTable.Simple_HTable
  61      (Header_Num => Prj.Header_Num,
  62       Element    => Name_Id,
  63       No_Element => No_Name,
  64       Key        => Name_Id,
  65       Hash       => Prj.Hash,
  66       Equal      => "=");
  67    --  Stores the runtime names for the various languages. This is in general
  68    --  set from a --RTS command line option.
  69
  70    -----------------------
  71    -- Local_Subprograms --
  72    -----------------------
  73
  74    procedure Add_Attributes
  75      (Project_Tree : Project_Tree_Ref;
  76       Conf_Decl    : Declarations;
  77       User_Decl    : in out Declarations);
  78    --  Process the attributes in the config declarations.
  79    --  For single string values, if the attribute is not declared in the user
  80    --  declarations, declare it with the value in the config declarations.
  81    --  For string list values, prepend the value in the user declarations with
  82    --  the value in the config declarations.
  83
  84    function Check_Target
  85      (Config_File        : Prj.Project_Id;
  86       Autoconf_Specified : Boolean;
  87       Project_Tree       : Prj.Project_Tree_Ref;
  88       Target             : String := "") return Boolean;
  89    --  Check that the config file's target matches Target.
  90    --  Target should be set to the empty string when the user did not specify
  91    --  a target. If the target in the configuration file is invalid, this
  92    --  function will raise Invalid_Config with an appropriate message.
  93    --  Autoconf_Specified should be set to True if the user has used
  94    --  autoconf.
  95
  96    function Locate_Config_File (Name : String) return String_Access;
  97    --  Search for Name in the config files directory. Return full path if
  98    --  found, or null otherwise.
  99
 100    procedure Raise_Invalid_Config (Msg : String);
 101    pragma No_Return (Raise_Invalid_Config);
 102    --  Raises exception Invalid_Config with given message
 103
 104    --------------------
 105    -- Add_Attributes --
 106    --------------------
 107
 108    procedure Add_Attributes
 109      (Project_Tree : Project_Tree_Ref;
 110       Conf_Decl    : Declarations;
 111       User_Decl    : in out Declarations)
 112    is
 113       Conf_Attr_Id       : Variable_Id;
 114       Conf_Attr          : Variable;
 115       Conf_Array_Id      : Array_Id;
 116       Conf_Array         : Array_Data;
 117       Conf_Array_Elem_Id : Array_Element_Id;
 118       Conf_Array_Elem    : Array_Element;
 119       Conf_List          : String_List_Id;
 120       Conf_List_Elem     : String_Element;
 121
 122       User_Attr_Id       : Variable_Id;
 123       User_Attr          : Variable;
 124       User_Array_Id      : Array_Id;
 125       User_Array         : Array_Data;
 126       User_Array_Elem_Id : Array_Element_Id;
 127       User_Array_Elem    : Array_Element;
 128
 129    begin
 130       Conf_Attr_Id := Conf_Decl.Attributes;
 131       User_Attr_Id := User_Decl.Attributes;
 132       while Conf_Attr_Id /= No_Variable loop
 133          Conf_Attr :=
 134            Project_Tree.Variable_Elements.Table (Conf_Attr_Id);
 135          User_Attr :=
 136            Project_Tree.Variable_Elements.Table (User_Attr_Id);
 137
 138          if not Conf_Attr.Value.Default then
 139             if User_Attr.Value.Default then
 140
 141                --  No attribute declared in user project file: just copy the
 142                --  value of the configuration attribute.
 143
 144                User_Attr.Value := Conf_Attr.Value;
 145                Project_Tree.Variable_Elements.Table (User_Attr_Id) :=
 146                  User_Attr;
 147
 148             elsif User_Attr.Value.Kind = List
 149               and then Conf_Attr.Value.Values /= Nil_String
 150             then
 151                --  List attribute declared in both the user project and the
 152                --  configuration project: prepend the user list with the
 153                --  configuration list.
 154
 155                declare
 156                   Conf_List : String_List_Id := Conf_Attr.Value.Values;
 157                   Conf_Elem : String_Element;
 158                   User_List : constant String_List_Id :=
 159                                 User_Attr.Value.Values;
 160                   New_List : String_List_Id;
 161                   New_Elem : String_Element;
 162
 163                begin
 164                   --  Create new list
 165
 166                   String_Element_Table.Increment_Last
 167                     (Project_Tree.String_Elements);
 168                   New_List := String_Element_Table.Last
 169                     (Project_Tree.String_Elements);
 170
 171                   --  Value of attribute is new list
 172
 173                   User_Attr.Value.Values := New_List;
 174                   Project_Tree.Variable_Elements.Table (User_Attr_Id) :=
 175                     User_Attr;
 176
 177                   loop
 178
 179                      --  Get each element of configuration list
 180
 181                      Conf_Elem :=
 182                        Project_Tree.String_Elements.Table (Conf_List);
 183                      New_Elem := Conf_Elem;
 184                      Conf_List := Conf_Elem.Next;
 185
 186                      if Conf_List = Nil_String then
 187
 188                         --  If it is the last element in the list, connect to
 189                         --  first element of user list, and we are done.
 190
 191                         New_Elem.Next := User_List;
 192                         Project_Tree.String_Elements.Table
 193                           (New_List) := New_Elem;
 194                         exit;
 195
 196                      else
 197                         --  If it is not the last element in the list, add to
 198                         --  new list.
 199
 200                         String_Element_Table.Increment_Last
 201                           (Project_Tree.String_Elements);
 202                         New_Elem.Next :=
 203                           String_Element_Table.Last
 204                             (Project_Tree.String_Elements);
 205                         Project_Tree.String_Elements.Table
 206                           (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 := Project_Tree.Arrays.Table (Conf_Array_Id);
 221
 222          User_Array_Id := User_Decl.Arrays;
 223          while User_Array_Id /= No_Array loop
 224             User_Array := Project_Tree.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 (Project_Tree.Arrays);
 234             User_Array := Conf_Array;
 235             User_Array.Next := User_Decl.Arrays;
 236             User_Decl.Arrays := Array_Table.Last (Project_Tree.Arrays);
 237             Project_Tree.Arrays.Table (User_Decl.Arrays) := User_Array;
 238
 239          else
 240             --  Otherwise, check each array element
 241
 242             Conf_Array_Elem_Id := Conf_Array.Value;
 243             while Conf_Array_Elem_Id /= No_Array_Element loop
 244                Conf_Array_Elem :=
 245                  Project_Tree.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                     Project_Tree.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 does not exist in the user array,
 256                --  insert a shallow copy of the conf array element in the
 257                --  user array.
 258
 259                if User_Array_Elem_Id = No_Array_Element then
 260                   Array_Element_Table.Increment_Last
 261                     (Project_Tree.Array_Elements);
 262                   User_Array_Elem := Conf_Array_Elem;
 263                   User_Array_Elem.Next := User_Array.Value;
 264                   User_Array.Value :=
 265                     Array_Element_Table.Last (Project_Tree.Array_Elements);
 266                   Project_Tree.Array_Elements.Table (User_Array.Value) :=
 267                     User_Array_Elem;
 268                   Project_Tree.Arrays.Table (User_Array_Id) := User_Array;
 269
 270                --  Otherwise, if the value is a string list, prepend the
 271                --  user array element with the conf array element value.
 272
 273                elsif Conf_Array_Elem.Value.Kind = List then
 274                   Conf_List := Conf_Array_Elem.Value.Values;
 275
 276                   if Conf_List /= Nil_String then
 277                      declare
 278                         Link     : constant String_List_Id :=
 279                                      User_Array_Elem.Value.Values;
 280                         Previous : String_List_Id := Nil_String;
 281                         Next     : String_List_Id;
 282
 283                      begin
 284                         loop
 285                            Conf_List_Elem :=
 286                              Project_Tree.String_Elements.Table
 287                                (Conf_List);
 288                            String_Element_Table.Increment_Last
 289                              (Project_Tree.String_Elements);
 290                            Next :=
 291                              String_Element_Table.Last
 292                                (Project_Tree.String_Elements);
 293                            Project_Tree.String_Elements.Table (Next) :=
 294                              Conf_List_Elem;
 295
 296                            if Previous = Nil_String then
 297                               User_Array_Elem.Value.Values := Next;
 298                               Project_Tree.Array_Elements.Table
 299                                 (User_Array_Elem_Id) := User_Array_Elem;
 300
 301                            else
 302                               Project_Tree.String_Elements.Table
 303                                 (Previous).Next := Next;
 304                            end if;
 305
 306                            Previous := Next;
 307
 308                            Conf_List := Conf_List_Elem.Next;
 309
 310                            if Conf_List = Nil_String then
 311                               Project_Tree.String_Elements.Table
 312                                 (Previous).Next := Link;
 313                               exit;
 314                            end if;
 315                         end loop;
 316                      end;
 317                   end if;
 318                end if;
 319
 320                Conf_Array_Elem_Id := Conf_Array_Elem.Next;
 321             end loop;
 322          end if;
 323
 324          Conf_Array_Id := Conf_Array.Next;
 325       end loop;
 326    end Add_Attributes;
 327
 328    ------------------------------------
 329    -- Add_Default_GNAT_Naming_Scheme --
 330    ------------------------------------
 331
 332    procedure Add_Default_GNAT_Naming_Scheme
 333      (Config_File  : in out Project_Node_Id;
 334       Project_Tree : Project_Node_Tree_Ref)
 335    is
 336       procedure Create_Attribute
 337         (Name  : Name_Id;
 338          Value : String;
 339          Index : String := "";
 340          Pkg   : Project_Node_Id := Empty_Node);
 341
 342       ----------------------
 343       -- Create_Attribute --
 344       ----------------------
 345
 346       procedure Create_Attribute
 347         (Name  : Name_Id;
 348          Value : String;
 349          Index : String := "";
 350          Pkg   : Project_Node_Id := Empty_Node)
 351       is
 352          Attr       : Project_Node_Id;
 353          pragma Unreferenced (Attr);
 354
 355          Expr   : Name_Id         := No_Name;
 356          Val    : Name_Id         := No_Name;
 357          Parent : Project_Node_Id := Config_File;
 358       begin
 359          if Index /= "" then
 360             Name_Len := Index'Length;
 361             Name_Buffer (1 .. Name_Len) := Index;
 362             Val := Name_Find;
 363          end if;
 364
 365          if Pkg /= Empty_Node then
 366             Parent := Pkg;
 367          end if;
 368
 369          Name_Len := Value'Length;
 370          Name_Buffer (1 .. Name_Len) := Value;
 371          Expr := Name_Find;
 372
 373          Attr := Create_Attribute
 374            (Tree       => Project_Tree,
 375             Prj_Or_Pkg => Parent,
 376             Name       => Name,
 377             Index_Name => Val,
 378             Kind       => Prj.Single,
 379             Value      => Create_Literal_String (Expr, Project_Tree));
 380       end Create_Attribute;
 381
 382       --  Local variables
 383
 384       Name   : Name_Id;
 385       Naming : Project_Node_Id;
 386
 387    --  Start of processing for Add_Default_GNAT_Naming_Scheme
 388
 389    begin
 390       if Config_File = Empty_Node then
 391
 392          --  Create a dummy config file is none was found
 393
 394          Name_Len := Auto_Cgpr'Length;
 395          Name_Buffer (1 .. Name_Len) := Auto_Cgpr;
 396          Name := Name_Find;
 397
 398          --  An invalid project name to avoid conflicts with user-created ones
 399
 400          Name_Len := 5;
 401          Name_Buffer (1 .. Name_Len) := "_auto";
 402
 403          Config_File :=
 404            Create_Project
 405              (In_Tree        => Project_Tree,
 406               Name           => Name_Find,
 407               Full_Path      => Path_Name_Type (Name),
 408               Is_Config_File => True);
 409
 410          --  Setup library support
 411
 412          case MLib.Tgt.Support_For_Libraries is
 413             when None =>
 414                null;
 415
 416             when Static_Only =>
 417                Create_Attribute (Name_Library_Support, "static_only");
 418
 419             when Full =>
 420                Create_Attribute (Name_Library_Support, "full");
 421          end case;
 422
 423          if MLib.Tgt.Standalone_Library_Auto_Init_Is_Supported then
 424             Create_Attribute (Name_Library_Auto_Init_Supported, "true");
 425          else
 426             Create_Attribute (Name_Library_Auto_Init_Supported, "false");
 427          end if;
 428
 429          --  Setup Ada support (Ada is the default language here, since this
 430          --  is only called when no config file existed initially, ie for
 431          --  gnatmake).
 432
 433          Create_Attribute (Name_Default_Language, "ada");
 434
 435          Naming := Create_Package (Project_Tree, Config_File, "naming");
 436          Create_Attribute (Name_Spec_Suffix, ".ads", "ada",     Pkg => Naming);
 437          Create_Attribute (Name_Separate_Suffix, ".adb", "ada", Pkg => Naming);
 438          Create_Attribute (Name_Body_Suffix, ".adb", "ada",     Pkg => Naming);
 439          Create_Attribute (Name_Dot_Replacement, "-",           Pkg => Naming);
 440          Create_Attribute (Name_Casing,          "lowercase",   Pkg => Naming);
 441
 442          if Current_Verbosity = High then
 443             Write_Line ("Automatically generated (in-memory) config file");
 444             Prj.PP.Pretty_Print
 445               (Project                => Config_File,
 446                In_Tree                => Project_Tree,
 447                Backward_Compatibility => False);
 448          end if;
 449       end if;
 450    end Add_Default_GNAT_Naming_Scheme;
 451
 452    -----------------------
 453    -- Apply_Config_File --
 454    -----------------------
 455
 456    procedure Apply_Config_File
 457      (Config_File  : Prj.Project_Id;
 458       Project_Tree : Prj.Project_Tree_Ref)
 459    is
 460       Conf_Decl    : constant Declarations := Config_File.Decl;
 461       Conf_Pack_Id : Package_Id;
 462       Conf_Pack    : Package_Element;
 463
 464       User_Decl    : Declarations;
 465       User_Pack_Id : Package_Id;
 466       User_Pack    : Package_Element;
 467       Proj         : Project_List;
 468
 469    begin
 470       Proj := Project_Tree.Projects;
 471       while Proj /= null loop
 472          if Proj.Project /= Config_File then
 473             User_Decl := Proj.Project.Decl;
 474             Add_Attributes
 475               (Project_Tree => Project_Tree,
 476                Conf_Decl    => Conf_Decl,
 477                User_Decl    => User_Decl);
 478
 479             Conf_Pack_Id := Conf_Decl.Packages;
 480             while Conf_Pack_Id /= No_Package loop
 481                Conf_Pack := Project_Tree.Packages.Table (Conf_Pack_Id);
 482
 483                User_Pack_Id := User_Decl.Packages;
 484                while User_Pack_Id /= No_Package loop
 485                   User_Pack := Project_Tree.Packages.Table (User_Pack_Id);
 486                   exit when User_Pack.Name = Conf_Pack.Name;
 487                   User_Pack_Id := User_Pack.Next;
 488                end loop;
 489
 490                if User_Pack_Id = No_Package then
 491                   Package_Table.Increment_Last (Project_Tree.Packages);
 492                   User_Pack := Conf_Pack;
 493                   User_Pack.Next := User_Decl.Packages;
 494                   User_Decl.Packages :=
 495                     Package_Table.Last (Project_Tree.Packages);
 496                   Project_Tree.Packages.Table (User_Decl.Packages) :=
 497                     User_Pack;
 498
 499                else
 500                   Add_Attributes
 501                     (Project_Tree => Project_Tree,
 502                      Conf_Decl    => Conf_Pack.Decl,
 503                      User_Decl    => Project_Tree.Packages.Table
 504                        (User_Pack_Id).Decl);
 505                end if;
 506
 507                Conf_Pack_Id := Conf_Pack.Next;
 508             end loop;
 509
 510             Proj.Project.Decl := User_Decl;
 511          end if;
 512
 513          Proj := Proj.Next;
 514       end loop;
 515    end Apply_Config_File;
 516
 517    ------------------
 518    -- Check_Target --
 519    ------------------
 520
 521    function Check_Target
 522      (Config_File  : Project_Id;
 523       Autoconf_Specified : Boolean;
 524       Project_Tree : Prj.Project_Tree_Ref;
 525       Target       : String := "") return Boolean
 526    is
 527       Variable : constant Variable_Value :=
 528                    Value_Of
 529                      (Name_Target, Config_File.Decl.Attributes, Project_Tree);
 530       Tgt_Name : Name_Id := No_Name;
 531       OK       : Boolean;
 532
 533    begin
 534       if Variable /= Nil_Variable_Value and then not Variable.Default then
 535          Tgt_Name := Variable.Value;
 536       end if;
 537
 538       if Target = "" then
 539          OK := not Autoconf_Specified or else Tgt_Name = No_Name;
 540       else
 541          OK := Tgt_Name /= No_Name
 542                  and then Target = Get_Name_String (Tgt_Name);
 543       end if;
 544
 545       if not OK then
 546          if Autoconf_Specified then
 547             if Verbose_Mode then
 548                Write_Line ("inconsistent targets, performing autoconf");
 549             end if;
 550
 551             return False;
 552
 553          else
 554             if Tgt_Name /= No_Name then
 555                Raise_Invalid_Config
 556                  ("invalid target name """
 557                   & Get_Name_String (Tgt_Name) & """ in configuration");
 558             else
 559                Raise_Invalid_Config
 560                  ("no target specified in configuration file");
 561             end if;
 562          end if;
 563       end if;
 564
 565       return True;
 566    end Check_Target;
 567
 568    --------------------------------------
 569    -- Get_Or_Create_Configuration_File --
 570    --------------------------------------
 571
 572    procedure Get_Or_Create_Configuration_File
 573      (Project                    : Project_Id;
 574       Project_Tree               : Project_Tree_Ref;
 575       Project_Node_Tree          : Prj.Tree.Project_Node_Tree_Ref;
 576       Allow_Automatic_Generation : Boolean;
 577       Config_File_Name           : String := "";
 578       Autoconf_Specified         : Boolean;
 579       Target_Name                : String := "";
 580       Normalized_Hostname        : String;
 581       Packages_To_Check          : String_List_Access := null;
 582       Config                     : out Prj.Project_Id;
 583       Config_File_Path           : out String_Access;
 584       Automatically_Generated    : out Boolean;
 585       Flags                      : Processing_Flags;
 586       On_Load_Config             : Config_File_Hook := null)
 587    is
 588
 589       At_Least_One_Compiler_Command : Boolean := False;
 590       --  Set to True if at least one attribute Ide'Compiler_Command is
 591       --  specified for one language of the system.
 592
 593       function Default_File_Name return String;
 594       --  Return the name of the default config file that should be tested
 595
 596       procedure Do_Autoconf;
 597       --  Generate a new config file through gprconfig. In case of error, this
 598       --  raises the Invalid_Config exception with an appropriate message
 599
 600       function Get_Config_Switches return Argument_List_Access;
 601       --  Return the --config switches to use for gprconfig
 602
 603       function Might_Have_Sources (Project : Project_Id) return Boolean;
 604       --  True if the specified project might have sources (ie the user has not
 605       --  explicitly specified it. We haven't checked the file system, nor do
 606       --  we need to at this stage.
 607
 608       -----------------------
 609       -- Default_File_Name --
 610       -----------------------
 611
 612       function Default_File_Name return String is
 613          Ada_RTS : constant String := Runtime_Name_For (Name_Ada);
 614          Tmp     : String_Access;
 615
 616       begin
 617          if Target_Name /= "" then
 618             if Ada_RTS /= "" then
 619                return Target_Name & '-' & Ada_RTS
 620                  & Config_Project_File_Extension;
 621             else
 622                return Target_Name & Config_Project_File_Extension;
 623             end if;
 624
 625          elsif Ada_RTS /= "" then
 626             return Ada_RTS & Config_Project_File_Extension;
 627
 628          else
 629             Tmp := Getenv (Config_Project_Env_Var);
 630
 631             declare
 632                T : constant String := Tmp.all;
 633
 634             begin
 635                Free (Tmp);
 636
 637                if T'Length = 0 then
 638                   return Default_Name;
 639                else
 640                   return T;
 641                end if;
 642             end;
 643          end if;
 644       end Default_File_Name;
 645
 646       ------------------------
 647       -- Might_Have_Sources --
 648       ------------------------
 649
 650       function Might_Have_Sources (Project : Project_Id) return Boolean is
 651          Variable : Variable_Value;
 652
 653       begin
 654          Variable :=
 655            Value_Of
 656              (Name_Source_Dirs,
 657               Project.Decl.Attributes,
 658               Project_Tree);
 659
 660          if Variable = Nil_Variable_Value
 661            or else Variable.Default
 662            or else Variable.Values /= Nil_String
 663          then
 664             Variable :=
 665               Value_Of
 666                 (Name_Source_Files,
 667                  Project.Decl.Attributes,
 668                  Project_Tree);
 669             return Variable = Nil_Variable_Value
 670               or else Variable.Default
 671               or else Variable.Values /= Nil_String;
 672
 673          else
 674             return False;
 675          end if;
 676       end Might_Have_Sources;
 677
 678       -------------------------
 679       -- Get_Config_Switches --
 680       -------------------------
 681
 682       function Get_Config_Switches return Argument_List_Access is
 683          package Language_Htable is new GNAT.HTable.Simple_HTable
 684            (Header_Num => Prj.Header_Num,
 685             Element    => Name_Id,
 686             No_Element => No_Name,
 687             Key        => Name_Id,
 688             Hash       => Prj.Hash,
 689             Equal      => "=");
 690          --  Hash table to keep the languages used in the project tree
 691
 692          IDE : constant Package_Id :=
 693                  Value_Of
 694                    (Name_Ide,
 695                     Project.Decl.Packages,
 696                     Project_Tree);
 697
 698          Prj_Iter : Project_List;
 699          List     : String_List_Id;
 700          Elem     : String_Element;
 701          Lang     : Name_Id;
 702          Variable : Variable_Value;
 703          Name     : Name_Id;
 704          Count    : Natural;
 705          Result   : Argument_List_Access;
 706
 707          Check_Default : Boolean;
 708
 709       begin
 710          Prj_Iter := Project_Tree.Projects;
 711          while Prj_Iter /= null loop
 712             if Might_Have_Sources (Prj_Iter.Project) then
 713                Variable :=
 714                  Value_Of
 715                    (Name_Languages,
 716                     Prj_Iter.Project.Decl.Attributes,
 717                     Project_Tree);
 718
 719                if Variable = Nil_Variable_Value
 720                  or else Variable.Default
 721                then
 722                   --  Languages is not declared. If it is not an extending
 723                   --  project, or if it extends a project with no Languages,
 724                   --  check for Default_Language.
 725
 726                   Check_Default := Prj_Iter.Project.Extends = No_Project;
 727
 728                   if not Check_Default then
 729                      Variable :=
 730                        Value_Of
 731                          (Name_Languages,
 732                           Prj_Iter.Project.Extends.Decl.Attributes,
 733                           Project_Tree);
 734                      Check_Default :=
 735                        Variable /= Nil_Variable_Value
 736                          and then Variable.Values = Nil_String;
 737                   end if;
 738
 739                   if Check_Default then
 740                      Variable :=
 741                        Value_Of
 742                          (Name_Default_Language,
 743                           Prj_Iter.Project.Decl.Attributes,
 744                           Project_Tree);
 745
 746                      if Variable /= Nil_Variable_Value
 747                        and then not Variable.Default
 748                      then
 749                         Get_Name_String (Variable.Value);
 750                         To_Lower (Name_Buffer (1 .. Name_Len));
 751                         Lang := Name_Find;
 752                         Language_Htable.Set (Lang, Lang);
 753
 754                      else
 755                         --  If no default language is declared, default to Ada
 756
 757                         Language_Htable.Set (Name_Ada, Name_Ada);
 758                      end if;
 759                   end if;
 760
 761                elsif Variable.Values /= Nil_String then
 762
 763                   --  Attribute Languages is declared with a non empty
 764                   --  list: put all the languages in Language_HTable.
 765
 766                   List := Variable.Values;
 767                   while List /= Nil_String loop
 768                      Elem := Project_Tree.String_Elements.Table (List);
 769
 770                      Get_Name_String (Elem.Value);
 771                      To_Lower (Name_Buffer (1 .. Name_Len));
 772                      Lang := Name_Find;
 773                      Language_Htable.Set (Lang, Lang);
 774
 775                      List := Elem.Next;
 776                   end loop;
 777                end if;
 778             end if;
 779
 780             Prj_Iter := Prj_Iter.Next;
 781          end loop;
 782
 783          Name  := Language_Htable.Get_First;
 784          Count := 0;
 785          while Name /= No_Name loop
 786             Count := Count + 1;
 787             Name := Language_Htable.Get_Next;
 788          end loop;
 789
 790          Result := new String_List (1 .. Count);
 791
 792          Count := 1;
 793          Name  := Language_Htable.Get_First;
 794          while Name /= No_Name loop
 795             --  Check if IDE'Compiler_Command is declared for the language.
 796             --  If it is, use its value to invoke gprconfig.
 797
 798             Variable :=
 799               Value_Of
 800                 (Name,
 801                  Attribute_Or_Array_Name => Name_Compiler_Command,
 802                  In_Package              => IDE,
 803                  In_Tree                 => Project_Tree,
 804                  Force_Lower_Case_Index  => True);
 805
 806             declare
 807                Config_Command : constant String :=
 808                  "--config=" & Get_Name_String (Name);
 809
 810                Runtime_Name   : constant String :=
 811                  Runtime_Name_For (Name);
 812
 813             begin
 814                if Variable = Nil_Variable_Value
 815                  or else Length_Of_Name (Variable.Value) = 0
 816                then
 817                   Result (Count) :=
 818                     new String'(Config_Command & ",," & Runtime_Name);
 819
 820                else
 821                   At_Least_One_Compiler_Command := True;
 822
 823                   declare
 824                      Compiler_Command : constant String :=
 825                        Get_Name_String (Variable.Value);
 826
 827                   begin
 828                      if Is_Absolute_Path (Compiler_Command) then
 829                         Result (Count) :=
 830                           new String'
 831                             (Config_Command & ",," & Runtime_Name & "," &
 832                              Containing_Directory (Compiler_Command) & "," &
 833                              Simple_Name (Compiler_Command));
 834                      else
 835                         Result (Count) :=
 836                           new String'
 837                             (Config_Command & ",," & Runtime_Name & ",," &
 838                              Compiler_Command);
 839                      end if;
 840                   end;
 841                end if;
 842             end;
 843
 844             Count := Count + 1;
 845             Name  := Language_Htable.Get_Next;
 846          end loop;
 847
 848          return Result;
 849       end Get_Config_Switches;
 850
 851       -----------------
 852       -- Do_Autoconf --
 853       -----------------
 854
 855       procedure Do_Autoconf is
 856          Obj_Dir : constant Variable_Value :=
 857                      Value_Of
 858                        (Name_Object_Dir,
 859                         Project.Decl.Attributes,
 860                         Project_Tree);
 861
 862          Gprconfig_Path  : String_Access;
 863          Success         : Boolean;
 864
 865       begin
 866          Gprconfig_Path := Locate_Exec_On_Path (Gprconfig_Name);
 867
 868          if Gprconfig_Path = null then
 869             Raise_Invalid_Config
 870               ("could not locate gprconfig for auto-configuration");
 871          end if;
 872
 873          --  First, find the object directory of the user's project
 874
 875          if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then
 876             Get_Name_String (Project.Directory.Display_Name);
 877
 878          else
 879             if Is_Absolute_Path (Get_Name_String (Obj_Dir.Value)) then
 880                Get_Name_String (Obj_Dir.Value);
 881
 882             else
 883                Name_Len := 0;
 884                Add_Str_To_Name_Buffer
 885                  (Get_Name_String (Project.Directory.Display_Name));
 886                Add_Str_To_Name_Buffer (Get_Name_String (Obj_Dir.Value));
 887             end if;
 888          end if;
 889
 890          if Subdirs /= null then
 891             Add_Char_To_Name_Buffer (Directory_Separator);
 892             Add_Str_To_Name_Buffer (Subdirs.all);
 893          end if;
 894
 895          for J in 1 .. Name_Len loop
 896             if Name_Buffer (J) = '/' then
 897                Name_Buffer (J) := Directory_Separator;
 898             end if;
 899          end loop;
 900
 901          declare
 902             Obj_Dir  : constant String := Name_Buffer (1 .. Name_Len);
 903             Switches : Argument_List_Access := Get_Config_Switches;
 904             Args     : Argument_List (1 .. 5);
 905             Arg_Last : Positive;
 906
 907             Obj_Dir_Exists : Boolean := True;
 908
 909          begin
 910             --  Check if the object directory exists. If Setup_Projects is True
 911             --  (-p) and directory does not exist, attempt to create it.
 912             --  Otherwise, if directory does not exist, fail without calling
 913             --  gprconfig.
 914
 915             if not Is_Directory (Obj_Dir)
 916               and then (Setup_Projects or else Subdirs /= null)
 917             then
 918                begin
 919                   Create_Path (Obj_Dir);
 920
 921                   if not Quiet_Output then
 922                      Write_Str ("object directory """);
 923                      Write_Str (Obj_Dir);
 924                      Write_Line (""" created");
 925                   end if;
 926
 927                exception
 928                   when others =>
 929                      Raise_Invalid_Config
 930                        ("could not create object directory " & Obj_Dir);
 931                end;
 932             end if;
 933
 934             if not Is_Directory (Obj_Dir) then
 935                case Flags.Require_Obj_Dirs is
 936                   when Error =>
 937                      Raise_Invalid_Config
 938                        ("object directory " & Obj_Dir & " does not exist");
 939                   when Warning =>
 940                      Prj.Err.Error_Msg
 941                        (Flags,
 942                         "?object directory " & Obj_Dir & " does not exist");
 943                      Obj_Dir_Exists := False;
 944                   when Silent =>
 945                      null;
 946                end case;
 947             end if;
 948
 949             --  Invoke gprconfig
 950
 951             Args (1) := new String'("--batch");
 952             Args (2) := new String'("-o");
 953
 954             --  If no config file was specified, set the auto.cgpr one
 955
 956             if Config_File_Name = "" then
 957                if Obj_Dir_Exists then
 958                   Args (3) :=
 959                     new String'(Obj_Dir & Directory_Separator & Auto_Cgpr);
 960
 961                else
 962                   declare
 963                      Path_FD   : File_Descriptor;
 964                      Path_Name : Path_Name_Type;
 965
 966                   begin
 967                      Prj.Env.Create_Temp_File
 968                        (In_Tree   => Project_Tree,
 969                         Path_FD   => Path_FD,
 970                         Path_Name => Path_Name,
 971                         File_Use  => "configuration file");
 972
 973                      if Path_FD /= Invalid_FD then
 974                         Args (3) := new String'(Get_Name_String (Path_Name));
 975                         GNAT.OS_Lib.Close (Path_FD);
 976
 977                      else
 978                         --  We'll have an error message later on
 979
 980                         Args (3) :=
 981                           new String'
 982                             (Obj_Dir & Directory_Separator & Auto_Cgpr);
 983                      end if;
 984                   end;
 985                end if;
 986             else
 987                Args (3) := new String'(Config_File_Name);
 988             end if;
 989
 990             if Normalized_Hostname = "" then
 991                Arg_Last := 3;
 992             else
 993                if Target_Name = "" then
 994                   if At_Least_One_Compiler_Command then
 995                      Args (4) := new String'("--target=all");
 996
 997                   else
 998                      Args (4) :=
 999                        new String'("--target=" & Normalized_Hostname);
1000                   end if;
1001
1002                else
1003                   Args (4) := new String'("--target=" & Target_Name);
1004                end if;
1005
1006                Arg_Last := 4;
1007             end if;
1008
1009             if not Verbose_Mode then
1010                Arg_Last := Arg_Last + 1;
1011                Args (Arg_Last) := new String'("-q");
1012             end if;
1013
1014             if Verbose_Mode then
1015                Write_Str (Gprconfig_Name);
1016
1017                for J in 1 .. Arg_Last loop
1018                   Write_Char (' ');
1019                   Write_Str (Args (J).all);
1020                end loop;
1021
1022                for J in Switches'Range loop
1023                   Write_Char (' ');
1024                   Write_Str (Switches (J).all);
1025                end loop;
1026
1027                Write_Eol;
1028
1029             elsif not Quiet_Output then
1030                --  Display no message if we are creating auto.cgpr, unless in
1031                --  verbose mode
1032
1033                if Config_File_Name /= ""
1034                  or else Verbose_Mode
1035                then
1036                   Write_Str ("creating ");
1037                   Write_Str (Simple_Name (Args (3).all));
1038                   Write_Eol;
1039                end if;
1040             end if;
1041
1042             Spawn (Gprconfig_Path.all, Args (1 .. Arg_Last) & Switches.all,
1043                    Success);
1044
1045             Free (Switches);
1046
1047             Config_File_Path := Locate_Config_File (Args (3).all);
1048
1049             if Config_File_Path = null then
1050                Raise_Invalid_Config
1051                  ("could not create " & Args (3).all);
1052             end if;
1053
1054             for F in Args'Range loop
1055                Free (Args (F));
1056             end loop;
1057          end;
1058       end Do_Autoconf;
1059
1060       Success             : Boolean;
1061       Config_Project_Node : Project_Node_Id := Empty_Node;
1062
1063    begin
1064       Free (Config_File_Path);
1065       Config := No_Project;
1066
1067       if Config_File_Name /= "" then
1068          Config_File_Path := Locate_Config_File (Config_File_Name);
1069       else
1070          Config_File_Path := Locate_Config_File (Default_File_Name);
1071       end if;
1072
1073       if Config_File_Path = null then
1074          if (not Allow_Automatic_Generation) and then
1075             Config_File_Name /= ""
1076          then
1077             Raise_Invalid_Config
1078               ("could not locate main configuration project "
1079                & Config_File_Name);
1080          end if;
1081       end if;
1082
1083       Automatically_Generated :=
1084         Allow_Automatic_Generation and then Config_File_Path = null;
1085
1086       <<Process_Config_File>>
1087
1088       if Automatically_Generated then
1089          if Hostparm.OpenVMS then
1090
1091             --  There is no gprconfig on VMS
1092
1093             Raise_Invalid_Config
1094               ("could not locate any configuration project file");
1095
1096          else
1097             --  This might raise an Invalid_Config exception
1098
1099             Do_Autoconf;
1100          end if;
1101       end if;
1102
1103       --  Parse the configuration file
1104
1105       if Verbose_Mode and then Config_File_Path /= null then
1106          Write_Str  ("Checking configuration ");
1107          Write_Line (Config_File_Path.all);
1108       end if;
1109
1110       if Config_File_Path /= null then
1111          Prj.Part.Parse
1112            (In_Tree                => Project_Node_Tree,
1113             Project                => Config_Project_Node,
1114             Project_File_Name      => Config_File_Path.all,
1115             Always_Errout_Finalize => False,
1116             Packages_To_Check      => Packages_To_Check,
1117             Current_Directory      => Current_Directory,
1118             Is_Config_File         => True,
1119             Flags                  => Flags);
1120       else
1121          --  Maybe the user will want to create his own configuration file
1122          Config_Project_Node := Empty_Node;
1123       end if;
1124
1125       if On_Load_Config /= null then
1126          On_Load_Config
1127            (Config_File       => Config_Project_Node,
1128             Project_Node_Tree => Project_Node_Tree);
1129       end if;
1130
1131       if Config_Project_Node /= Empty_Node then
1132          Prj.Proc.Process_Project_Tree_Phase_1
1133            (In_Tree                => Project_Tree,
1134             Project                => Config,
1135             Success                => Success,
1136             From_Project_Node      => Config_Project_Node,
1137             From_Project_Node_Tree => Project_Node_Tree,
1138             Flags                  => Flags,
1139             Reset_Tree             => False);
1140       end if;
1141
1142       if Config_Project_Node = Empty_Node
1143         or else Config = No_Project
1144       then
1145          Raise_Invalid_Config
1146            ("processing of configuration project """
1147             & Config_File_Path.all & """ failed");
1148       end if;
1149
1150       --  Check that the target of the configuration file is the one the user
1151       --  specified on the command line. We do not need to check that when in
1152       --  auto-conf mode, since the appropriate target was passed to gprconfig.
1153
1154       if not Automatically_Generated
1155         and then not
1156           Check_Target (Config, Autoconf_Specified, Project_Tree, Target_Name)
1157       then
1158          Automatically_Generated := True;
1159          goto Process_Config_File;
1160       end if;
1161    end Get_Or_Create_Configuration_File;
1162
1163    ------------------------
1164    -- Locate_Config_File --
1165    ------------------------
1166
1167    function Locate_Config_File (Name : String) return String_Access is
1168       Prefix_Path : constant String := Executable_Prefix_Path;
1169    begin
1170       if Prefix_Path'Length /= 0 then
1171          return Locate_Regular_File
1172            (Name,
1173             "." & Path_Separator &
1174             Prefix_Path & "share" & Directory_Separator & "gpr");
1175       else
1176          return Locate_Regular_File (Name, ".");
1177       end if;
1178    end Locate_Config_File;
1179
1180    ------------------------------------
1181    -- Parse_Project_And_Apply_Config --
1182    ------------------------------------
1183
1184    procedure Parse_Project_And_Apply_Config
1185      (Main_Project               : out Prj.Project_Id;
1186       User_Project_Node          : out Prj.Tree.Project_Node_Id;
1187       Config_File_Name           : String := "";
1188       Autoconf_Specified         : Boolean;
1189       Project_File_Name          : String;
1190       Project_Tree               : Prj.Project_Tree_Ref;
1191       Project_Node_Tree          : Prj.Tree.Project_Node_Tree_Ref;
1192       Packages_To_Check          : String_List_Access;
1193       Allow_Automatic_Generation : Boolean := True;
1194       Automatically_Generated    : out Boolean;
1195       Config_File_Path           : out String_Access;
1196       Target_Name                : String := "";
1197       Normalized_Hostname        : String;
1198       Flags                      : Processing_Flags;
1199       On_Load_Config             : Config_File_Hook := null)
1200    is
1201    begin
1202       --  Parse the user project tree
1203
1204       Prj.Initialize (Project_Tree);
1205
1206       Main_Project      := No_Project;
1207       Automatically_Generated := False;
1208
1209       Prj.Part.Parse
1210         (In_Tree                => Project_Node_Tree,
1211          Project                => User_Project_Node,
1212          Project_File_Name      => Project_File_Name,
1213          Always_Errout_Finalize => False,
1214          Packages_To_Check      => Packages_To_Check,
1215          Current_Directory      => Current_Directory,
1216          Is_Config_File         => False,
1217          Flags                  => Flags);
1218
1219       if User_Project_Node = Empty_Node then
1220          User_Project_Node := Empty_Node;
1221          return;
1222       end if;
1223
1224       Process_Project_And_Apply_Config
1225         (Main_Project               => Main_Project,
1226          User_Project_Node          => User_Project_Node,
1227          Config_File_Name           => Config_File_Name,
1228          Autoconf_Specified         => Autoconf_Specified,
1229          Project_Tree               => Project_Tree,
1230          Project_Node_Tree          => Project_Node_Tree,
1231          Packages_To_Check          => Packages_To_Check,
1232          Allow_Automatic_Generation => Allow_Automatic_Generation,
1233          Automatically_Generated    => Automatically_Generated,
1234          Config_File_Path           => Config_File_Path,
1235          Target_Name                => Target_Name,
1236          Normalized_Hostname        => Normalized_Hostname,
1237          Flags                      => Flags,
1238          On_Load_Config             => On_Load_Config);
1239    end Parse_Project_And_Apply_Config;
1240
1241    --------------------------------------
1242    -- Process_Project_And_Apply_Config --
1243    --------------------------------------
1244
1245    procedure Process_Project_And_Apply_Config
1246      (Main_Project               : out Prj.Project_Id;
1247       User_Project_Node          : Prj.Tree.Project_Node_Id;
1248       Config_File_Name           : String := "";
1249       Autoconf_Specified         : Boolean;
1250       Project_Tree               : Prj.Project_Tree_Ref;
1251       Project_Node_Tree          : Prj.Tree.Project_Node_Tree_Ref;
1252       Packages_To_Check          : String_List_Access;
1253       Allow_Automatic_Generation : Boolean := True;
1254       Automatically_Generated    : out Boolean;
1255       Config_File_Path           : out String_Access;
1256       Target_Name                : String := "";
1257       Normalized_Hostname        : String;
1258       Flags                      : Processing_Flags;
1259       On_Load_Config             : Config_File_Hook := null;
1260       Reset_Tree                 : Boolean := True)
1261    is
1262       Main_Config_Project : Project_Id;
1263       Success : Boolean;
1264
1265    begin
1266       Main_Project := No_Project;
1267       Automatically_Generated := False;
1268
1269       Process_Project_Tree_Phase_1
1270         (In_Tree                => Project_Tree,
1271          Project                => Main_Project,
1272          Success                => Success,
1273          From_Project_Node      => User_Project_Node,
1274          From_Project_Node_Tree => Project_Node_Tree,
1275          Flags                  => Flags,
1276          Reset_Tree             => Reset_Tree);
1277
1278       if not Success then
1279          Main_Project := No_Project;
1280          return;
1281       end if;
1282
1283       if Project_Tree.Source_Info_File_Name /= null then
1284          if not Is_Absolute_Path (Project_Tree.Source_Info_File_Name.all) then
1285             declare
1286                Obj_Dir : constant Variable_Value :=
1287                  Value_Of
1288                    (Name_Object_Dir,
1289                     Main_Project.Decl.Attributes,
1290                     Project_Tree);
1291
1292             begin
1293                if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then
1294                   Get_Name_String (Main_Project.Directory.Display_Name);
1295
1296                else
1297                   if Is_Absolute_Path (Get_Name_String (Obj_Dir.Value)) then
1298                      Get_Name_String (Obj_Dir.Value);
1299
1300                   else
1301                      Name_Len := 0;
1302                      Add_Str_To_Name_Buffer
1303                        (Get_Name_String (Main_Project.Directory.Display_Name));
1304                      Add_Str_To_Name_Buffer (Get_Name_String (Obj_Dir.Value));
1305                   end if;
1306                end if;
1307
1308                Add_Char_To_Name_Buffer (Directory_Separator);
1309                Add_Str_To_Name_Buffer (Project_Tree.Source_Info_File_Name.all);
1310                Free (Project_Tree.Source_Info_File_Name);
1311                Project_Tree.Source_Info_File_Name :=
1312                  new String'(Name_Buffer (1 .. Name_Len));
1313             end;
1314          end if;
1315
1316          Read_Source_Info_File (Project_Tree);
1317       end if;
1318
1319       --  Find configuration file
1320
1321       Get_Or_Create_Configuration_File
1322         (Config                     => Main_Config_Project,
1323          Project                    => Main_Project,
1324          Project_Tree               => Project_Tree,
1325          Project_Node_Tree          => Project_Node_Tree,
1326          Allow_Automatic_Generation => Allow_Automatic_Generation,
1327          Config_File_Name           => Config_File_Name,
1328          Autoconf_Specified         => Autoconf_Specified,
1329          Target_Name                => Target_Name,
1330          Normalized_Hostname        => Normalized_Hostname,
1331          Packages_To_Check          => Packages_To_Check,
1332          Config_File_Path           => Config_File_Path,
1333          Automatically_Generated    => Automatically_Generated,
1334          Flags                      => Flags,
1335          On_Load_Config             => On_Load_Config);
1336
1337       Apply_Config_File (Main_Config_Project, Project_Tree);
1338
1339       --  Finish processing the user's project
1340
1341       Prj.Proc.Process_Project_Tree_Phase_2
1342         (In_Tree                    => Project_Tree,
1343          Project                    => Main_Project,
1344          Success                    => Success,
1345          From_Project_Node          => User_Project_Node,
1346          From_Project_Node_Tree     => Project_Node_Tree,
1347          Flags                      => Flags);
1348
1349       if Success then
1350          if Project_Tree.Source_Info_File_Name /= null and then
1351             not Project_Tree.Source_Info_File_Exists
1352          then
1353             Write_Source_Info_File (Project_Tree);
1354          end if;
1355
1356       else
1357          Main_Project := No_Project;
1358       end if;
1359    end Process_Project_And_Apply_Config;
1360
1361    --------------------------
1362    -- Raise_Invalid_Config --
1363    --------------------------
1364
1365    procedure Raise_Invalid_Config (Msg : String) is
1366    begin
1367       Raise_Exception (Invalid_Config'Identity, Msg);
1368    end Raise_Invalid_Config;
1369
1370    ----------------------
1371    -- Runtime_Name_For --
1372    ----------------------
1373
1374    function Runtime_Name_For (Language : Name_Id) return String is
1375    begin
1376       if RTS_Languages.Get (Language) /= No_Name then
1377          return Get_Name_String (RTS_Languages.Get (Language));
1378       else
1379          return "";
1380       end if;
1381    end Runtime_Name_For;
1382
1383    ---------------------
1384    -- Set_Runtime_For --
1385    ---------------------
1386
1387    procedure Set_Runtime_For (Language : Name_Id; RTS_Name : String) is
1388    begin
1389       Name_Len := RTS_Name'Length;
1390       Name_Buffer (1 .. Name_Len) := RTS_Name;
1391       RTS_Languages.Set (Language, Name_Find);
1392    end Set_Runtime_For;
1393
1394 end Prj.Conf;