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