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