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    -- Locate_Config_File --
 320    ------------------------
 321
 322    function Locate_Config_File (Name : String) return String_Access is
 323       Prefix_Path : constant String := Executable_Prefix_Path;
 324    begin
 325       if Prefix_Path'Length /= 0 then
 326          return Locate_Regular_File
 327            (Name,
 328             "." & Path_Separator &
 329             Prefix_Path & "share" & Directory_Separator & "gpr");
 330       else
 331          return Locate_Regular_File (Name, ".");
 332       end if;
 333    end Locate_Config_File;
 334
 335    ------------------
 336    -- Check_Target --
 337    ------------------
 338
 339    function Check_Target
 340      (Config_File  : Project_Id;
 341       Autoconf_Specified : Boolean;
 342       Project_Tree : Prj.Project_Tree_Ref;
 343       Target       : String := "") return Boolean
 344    is
 345       Variable : constant Variable_Value :=
 346                    Value_Of
 347                      (Name_Target, Config_File.Decl.Attributes, Project_Tree);
 348       Tgt_Name : Name_Id := No_Name;
 349       OK       : Boolean;
 350
 351    begin
 352       if Variable /= Nil_Variable_Value and then not Variable.Default then
 353          Tgt_Name := Variable.Value;
 354       end if;
 355
 356       if Target = "" then
 357          OK := not Autoconf_Specified or else Tgt_Name = No_Name;
 358       else
 359          OK := Tgt_Name /= No_Name
 360                  and then Target = Get_Name_String (Tgt_Name);
 361       end if;
 362
 363       if not OK then
 364          if Autoconf_Specified then
 365             if Verbose_Mode then
 366                Write_Line ("inconsistent targets, performing autoconf");
 367             end if;
 368
 369             return False;
 370
 371          else
 372             if Tgt_Name /= No_Name then
 373                raise Invalid_Config
 374                  with "invalid target name """
 375                    & Get_Name_String (Tgt_Name) & """ in configuration";
 376
 377             else
 378                raise Invalid_Config
 379                  with "no target specified in configuration file";
 380             end if;
 381          end if;
 382       end if;
 383
 384       return True;
 385    end Check_Target;
 386
 387    --------------------------------------
 388    -- Get_Or_Create_Configuration_File --
 389    --------------------------------------
 390
 391    procedure Get_Or_Create_Configuration_File
 392      (Project                    : Project_Id;
 393       Project_Tree               : Project_Tree_Ref;
 394       Project_Node_Tree          : Prj.Tree.Project_Node_Tree_Ref;
 395       Allow_Automatic_Generation : Boolean;
 396       Config_File_Name           : String := "";
 397       Autoconf_Specified         : Boolean;
 398       Target_Name                : String := "";
 399       Normalized_Hostname        : String;
 400       Packages_To_Check          : String_List_Access := null;
 401       Config                     : out Prj.Project_Id;
 402       Config_File_Path           : out String_Access;
 403       Automatically_Generated    : out Boolean;
 404       Flags                      : Processing_Flags;
 405       On_Load_Config             : Config_File_Hook := null)
 406    is
 407       function Default_File_Name return String;
 408       --  Return the name of the default config file that should be tested
 409
 410       procedure Do_Autoconf;
 411       --  Generate a new config file through gprconfig.
 412       --  In case of error, this raises the Invalid_Config exception with an
 413       --  appropriate message
 414
 415       function Get_Config_Switches return Argument_List_Access;
 416       --  Return the --config switches to use for gprconfig
 417
 418       function Might_Have_Sources (Project : Project_Id) return Boolean;
 419       --  True if the specified project might have sources (ie the user has not
 420       --  explicitly specified it. We haven't checked the file system, nor do
 421       --  we need to at this stage.
 422
 423       -----------------------
 424       -- Default_File_Name --
 425       -----------------------
 426
 427       function Default_File_Name return String is
 428          Ada_RTS : constant String := Runtime_Name_For (Name_Ada);
 429          Tmp     : String_Access;
 430
 431       begin
 432          if Target_Name /= "" then
 433             if Ada_RTS /= "" then
 434                return Target_Name & '-' & Ada_RTS
 435                  & Config_Project_File_Extension;
 436             else
 437                return Target_Name & Config_Project_File_Extension;
 438             end if;
 439
 440          elsif Ada_RTS /= "" then
 441             return Ada_RTS & Config_Project_File_Extension;
 442
 443          else
 444             Tmp := Getenv (Config_Project_Env_Var);
 445
 446             declare
 447                T : constant String := Tmp.all;
 448             begin
 449                Free (Tmp);
 450
 451                if T'Length = 0 then
 452                   return Default_Name;
 453                else
 454                   return T;
 455                end if;
 456             end;
 457          end if;
 458       end Default_File_Name;
 459
 460       ------------------------
 461       -- Might_Have_Sources --
 462       ------------------------
 463
 464       function Might_Have_Sources (Project : Project_Id) return Boolean is
 465          Variable : Variable_Value;
 466
 467       begin
 468          Variable :=
 469            Value_Of
 470              (Name_Source_Dirs,
 471               Project.Decl.Attributes,
 472               Project_Tree);
 473
 474          if Variable = Nil_Variable_Value
 475            or else Variable.Default
 476            or else Variable.Values /= Nil_String
 477          then
 478             Variable :=
 479               Value_Of
 480                 (Name_Source_Files,
 481                  Project.Decl.Attributes,
 482                  Project_Tree);
 483             return Variable = Nil_Variable_Value
 484               or else Variable.Default
 485               or else Variable.Values /= Nil_String;
 486
 487          else
 488             return False;
 489          end if;
 490       end Might_Have_Sources;
 491
 492       -------------------------
 493       -- Get_Config_Switches --
 494       -------------------------
 495
 496       function Get_Config_Switches return Argument_List_Access is
 497          package Language_Htable is new GNAT.HTable.Simple_HTable
 498            (Header_Num => Prj.Header_Num,
 499             Element    => Name_Id,
 500             No_Element => No_Name,
 501             Key        => Name_Id,
 502             Hash       => Prj.Hash,
 503             Equal      => "=");
 504          --  Hash table to keep the languages used in the project tree
 505
 506          IDE : constant Package_Id :=
 507                  Value_Of
 508                    (Name_Ide,
 509                     Project.Decl.Packages,
 510                     Project_Tree);
 511
 512          Prj_Iter : Project_List;
 513          List     : String_List_Id;
 514          Elem     : String_Element;
 515          Lang     : Name_Id;
 516          Variable : Variable_Value;
 517          Name     : Name_Id;
 518          Count    : Natural;
 519          Result   : Argument_List_Access;
 520
 521          Check_Default : Boolean;
 522
 523       begin
 524          Prj_Iter := Project_Tree.Projects;
 525          while Prj_Iter /= null loop
 526             if Might_Have_Sources (Prj_Iter.Project) then
 527                Variable :=
 528                  Value_Of
 529                    (Name_Languages,
 530                     Prj_Iter.Project.Decl.Attributes,
 531                     Project_Tree);
 532
 533                if Variable = Nil_Variable_Value
 534                  or else Variable.Default
 535                then
 536                   --  Languages is not declared. If it is not an extending
 537                   --  project, or if it extends a project with no Languages,
 538                   --  check for Default_Language.
 539
 540                   Check_Default := Prj_Iter.Project.Extends = No_Project;
 541
 542                   if not Check_Default then
 543                      Variable :=
 544                        Value_Of
 545                          (Name_Languages,
 546                           Prj_Iter.Project.Extends.Decl.Attributes,
 547                           Project_Tree);
 548                      Check_Default :=
 549                        Variable /= Nil_Variable_Value
 550                          and then Variable.Values = Nil_String;
 551                   end if;
 552
 553                   if Check_Default then
 554                      Variable :=
 555                        Value_Of
 556                          (Name_Default_Language,
 557                           Prj_Iter.Project.Decl.Attributes,
 558                           Project_Tree);
 559
 560                      if Variable /= Nil_Variable_Value
 561                        and then not Variable.Default
 562                      then
 563                         Get_Name_String (Variable.Value);
 564                         To_Lower (Name_Buffer (1 .. Name_Len));
 565                         Lang := Name_Find;
 566                         Language_Htable.Set (Lang, Lang);
 567
 568                      else
 569                         --  If no default language is declared, default to Ada
 570
 571                         Language_Htable.Set (Name_Ada, Name_Ada);
 572                      end if;
 573                   end if;
 574
 575                elsif Variable.Values /= Nil_String then
 576
 577                   --  Attribute Languages is declared with a non empty
 578                   --  list: put all the languages in Language_HTable.
 579
 580                   List := Variable.Values;
 581                   while List /= Nil_String loop
 582                      Elem := Project_Tree.String_Elements.Table (List);
 583
 584                      Get_Name_String (Elem.Value);
 585                      To_Lower (Name_Buffer (1 .. Name_Len));
 586                      Lang := Name_Find;
 587                      Language_Htable.Set (Lang, Lang);
 588
 589                      List := Elem.Next;
 590                   end loop;
 591                end if;
 592             end if;
 593
 594             Prj_Iter := Prj_Iter.Next;
 595          end loop;
 596
 597          Name  := Language_Htable.Get_First;
 598          Count := 0;
 599          while Name /= No_Name loop
 600             Count := Count + 1;
 601             Name := Language_Htable.Get_Next;
 602          end loop;
 603
 604          Result := new String_List (1 .. Count);
 605
 606          Count := 1;
 607          Name  := Language_Htable.Get_First;
 608          while Name /= No_Name loop
 609             --  Check if IDE'Compiler_Command is declared for the language.
 610             --  If it is, use its value to invoke gprconfig.
 611
 612             Variable :=
 613               Value_Of
 614                 (Name,
 615                  Attribute_Or_Array_Name => Name_Compiler_Command,
 616                  In_Package              => IDE,
 617                  In_Tree                 => Project_Tree,
 618                  Force_Lower_Case_Index  => True);
 619
 620             declare
 621                Config_Command : constant String :=
 622                  "--config=" & Get_Name_String (Name);
 623
 624                Runtime_Name   : constant String :=
 625                  Runtime_Name_For (Name);
 626
 627             begin
 628                if Variable = Nil_Variable_Value
 629                  or else Length_Of_Name (Variable.Value) = 0
 630                then
 631                   Result (Count) :=
 632                     new String'(Config_Command & ",," & Runtime_Name);
 633
 634                else
 635                   declare
 636                      Compiler_Command : constant String :=
 637                        Get_Name_String (Variable.Value);
 638
 639                   begin
 640                      if Is_Absolute_Path (Compiler_Command) then
 641                         Result (Count) :=
 642                           new String'
 643                             (Config_Command & ",," & Runtime_Name & "," &
 644                              Containing_Directory (Compiler_Command) & "," &
 645                              Simple_Name (Compiler_Command));
 646                      else
 647                         Result (Count) :=
 648                           new String'
 649                             (Config_Command & ",," & Runtime_Name & ",," &
 650                              Compiler_Command);
 651                      end if;
 652                   end;
 653                end if;
 654             end;
 655
 656             Count := Count + 1;
 657             Name  := Language_Htable.Get_Next;
 658          end loop;
 659
 660          return Result;
 661       end Get_Config_Switches;
 662
 663       -----------------
 664       -- Do_Autoconf --
 665       -----------------
 666
 667       procedure Do_Autoconf is
 668          Obj_Dir : constant Variable_Value :=
 669                      Value_Of
 670                        (Name_Object_Dir,
 671                         Project.Decl.Attributes,
 672                         Project_Tree);
 673
 674          Gprconfig_Path  : String_Access;
 675          Success         : Boolean;
 676
 677       begin
 678          Gprconfig_Path := Locate_Exec_On_Path (Gprconfig_Name);
 679
 680          if Gprconfig_Path = null then
 681             raise Invalid_Config
 682               with "could not locate gprconfig for auto-configuration";
 683          end if;
 684
 685          --  First, find the object directory of the user's project
 686
 687          if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then
 688             Get_Name_String (Project.Directory.Name);
 689
 690          else
 691             if Is_Absolute_Path (Get_Name_String (Obj_Dir.Value)) then
 692                Get_Name_String (Obj_Dir.Value);
 693
 694             else
 695                Name_Len := 0;
 696                Add_Str_To_Name_Buffer
 697                  (Get_Name_String (Project.Directory.Name));
 698                Add_Str_To_Name_Buffer (Get_Name_String (Obj_Dir.Value));
 699             end if;
 700          end if;
 701
 702          if Subdirs /= null then
 703             Add_Char_To_Name_Buffer (Directory_Separator);
 704             Add_Str_To_Name_Buffer (Subdirs.all);
 705          end if;
 706
 707          for J in 1 .. Name_Len loop
 708             if Name_Buffer (J) = '/' then
 709                Name_Buffer (J) := Directory_Separator;
 710             end if;
 711          end loop;
 712
 713          declare
 714             Obj_Dir  : constant String := Name_Buffer (1 .. Name_Len);
 715             Switches : Argument_List_Access := Get_Config_Switches;
 716             Args     : Argument_List (1 .. 5);
 717             Arg_Last : Positive;
 718
 719             Obj_Dir_Exists : Boolean := True;
 720
 721          begin
 722             --  Check if the object directory exists. If Setup_Projects is True
 723             --  (-p) and directory does not exist, attempt to create it.
 724             --  Otherwise, if directory does not exist, fail without calling
 725             --  gprconfig.
 726
 727             if not Is_Directory (Obj_Dir)
 728               and then (Setup_Projects or else Subdirs /= null)
 729             then
 730                begin
 731                   Create_Path (Obj_Dir);
 732
 733                   if not Quiet_Output then
 734                      Write_Str ("object directory """);
 735                      Write_Str (Obj_Dir);
 736                      Write_Line (""" created");
 737                   end if;
 738
 739                exception
 740                   when others =>
 741                      raise Invalid_Config
 742                        with "could not create object directory " & Obj_Dir;
 743                end;
 744             end if;
 745
 746             if not Is_Directory (Obj_Dir) then
 747                case Flags.Require_Obj_Dirs is
 748                   when Error =>
 749                      raise Invalid_Config
 750                        with "object directory " & Obj_Dir & " does not exist";
 751                   when Warning =>
 752                      Prj.Err.Error_Msg
 753                        (Flags,
 754                         "?object directory " & Obj_Dir & " does not exist");
 755                      Obj_Dir_Exists := False;
 756                   when Silent =>
 757                      null;
 758                end case;
 759             end if;
 760
 761             --  Invoke gprconfig
 762
 763             Args (1) := new String'("--batch");
 764             Args (2) := new String'("-o");
 765
 766             --  If no config file was specified, set the auto.cgpr one
 767
 768             if Config_File_Name = "" then
 769                if Obj_Dir_Exists then
 770                   Args (3) :=
 771                     new String'(Obj_Dir & Directory_Separator & Auto_Cgpr);
 772
 773                else
 774                   declare
 775                      Path_FD   : File_Descriptor;
 776                      Path_Name : Path_Name_Type;
 777
 778                   begin
 779                      Prj.Env.Create_Temp_File
 780                        (In_Tree   => Project_Tree,
 781                         Path_FD   => Path_FD,
 782                         Path_Name => Path_Name,
 783                         File_Use  => "configuration file");
 784
 785                      if Path_FD /= Invalid_FD then
 786                         Args (3) := new String'(Get_Name_String (Path_Name));
 787                         GNAT.OS_Lib.Close (Path_FD);
 788
 789                      else
 790                         --  We'll have an error message later on
 791
 792                         Args (3) :=
 793                           new String'
 794                             (Obj_Dir & Directory_Separator & Auto_Cgpr);
 795                      end if;
 796                   end;
 797                end if;
 798             else
 799                Args (3) := new String'(Config_File_Name);
 800             end if;
 801
 802             if Normalized_Hostname = "" then
 803                Arg_Last := 3;
 804             else
 805                if Target_Name = "" then
 806                   Args (4) := new String'("--target=" & Normalized_Hostname);
 807                else
 808                   Args (4) := new String'("--target=" & Target_Name);
 809                end if;
 810
 811                Arg_Last := 4;
 812             end if;
 813
 814             if not Verbose_Mode then
 815                Arg_Last := Arg_Last + 1;
 816                Args (Arg_Last) := new String'("-q");
 817             end if;
 818
 819             if Verbose_Mode then
 820                Write_Str (Gprconfig_Name);
 821
 822                for J in 1 .. Arg_Last loop
 823                   Write_Char (' ');
 824                   Write_Str (Args (J).all);
 825                end loop;
 826
 827                for J in Switches'Range loop
 828                   Write_Char (' ');
 829                   Write_Str (Switches (J).all);
 830                end loop;
 831
 832                Write_Eol;
 833
 834             elsif not Quiet_Output then
 835                --  Display no message if we are creating auto.cgpr, unless in
 836                --  verbose mode
 837
 838                if Config_File_Name /= ""
 839                  or else Verbose_Mode
 840                then
 841                   Write_Str ("creating ");
 842                   Write_Str (Simple_Name (Args (3).all));
 843                   Write_Eol;
 844                end if;
 845             end if;
 846
 847             Spawn (Gprconfig_Path.all, Args (1 .. Arg_Last) & Switches.all,
 848                    Success);
 849
 850             Free (Switches);
 851
 852             Config_File_Path := Locate_Config_File (Args (3).all);
 853
 854             if Config_File_Path = null then
 855                raise Invalid_Config
 856                  with "could not create " & Args (3).all;
 857             end if;
 858
 859             for F in Args'Range loop
 860                Free (Args (F));
 861             end loop;
 862          end;
 863       end Do_Autoconf;
 864
 865       Success             : Boolean;
 866       Config_Project_Node : Project_Node_Id := Empty_Node;
 867
 868    begin
 869       Free (Config_File_Path);
 870       Config := No_Project;
 871
 872       if Config_File_Name /= "" then
 873          Config_File_Path := Locate_Config_File (Config_File_Name);
 874       else
 875          Config_File_Path := Locate_Config_File (Default_File_Name);
 876       end if;
 877
 878       if Config_File_Path = null then
 879          if (not Allow_Automatic_Generation) and then
 880             Config_File_Name /= ""
 881          then
 882             raise Invalid_Config
 883               with "could not locate main configuration project "
 884                 & Config_File_Name;
 885          end if;
 886       end if;
 887
 888       Automatically_Generated :=
 889         Allow_Automatic_Generation and then Config_File_Path = null;
 890
 891       <<Process_Config_File>>
 892
 893       if Automatically_Generated then
 894          if Hostparm.OpenVMS then
 895
 896             --  There is no gprconfig on VMS
 897
 898             raise Invalid_Config
 899               with "could not locate any configuration project file";
 900
 901          else
 902             --  This might raise an Invalid_Config exception
 903
 904             Do_Autoconf;
 905          end if;
 906       end if;
 907
 908       --  Parse the configuration file
 909
 910       if Verbose_Mode and then Config_File_Path /= null then
 911          Write_Str  ("Checking configuration ");
 912          Write_Line (Config_File_Path.all);
 913       end if;
 914
 915       if Config_File_Path /= null then
 916          Prj.Part.Parse
 917            (In_Tree                => Project_Node_Tree,
 918             Project                => Config_Project_Node,
 919             Project_File_Name      => Config_File_Path.all,
 920             Always_Errout_Finalize => False,
 921             Packages_To_Check      => Packages_To_Check,
 922             Current_Directory      => Current_Directory,
 923             Is_Config_File         => True,
 924             Flags                  => Flags);
 925       else
 926          --  Maybe the user will want to create his own configuration file
 927          Config_Project_Node := Empty_Node;
 928       end if;
 929
 930       if On_Load_Config /= null then
 931          On_Load_Config
 932            (Config_File       => Config_Project_Node,
 933             Project_Node_Tree => Project_Node_Tree);
 934       end if;
 935
 936       if Config_Project_Node /= Empty_Node then
 937          Prj.Proc.Process_Project_Tree_Phase_1
 938            (In_Tree                => Project_Tree,
 939             Project                => Config,
 940             Success                => Success,
 941             From_Project_Node      => Config_Project_Node,
 942             From_Project_Node_Tree => Project_Node_Tree,
 943             Flags                  => Flags,
 944             Reset_Tree             => False);
 945       end if;
 946
 947       if Config_Project_Node = Empty_Node
 948         or else Config = No_Project
 949       then
 950          raise Invalid_Config
 951            with "processing of configuration project """
 952              & Config_File_Path.all & """ failed";
 953       end if;
 954
 955       --  Check that the target of the configuration file is the one the user
 956       --  specified on the command line. We do not need to check that when in
 957       --  auto-conf mode, since the appropriate target was passed to gprconfig.
 958
 959       if not Automatically_Generated
 960         and then not
 961           Check_Target (Config, Autoconf_Specified, Project_Tree, Target_Name)
 962       then
 963          Automatically_Generated := True;
 964          goto Process_Config_File;
 965       end if;
 966    end Get_Or_Create_Configuration_File;
 967
 968    --------------------------------------
 969    -- Process_Project_And_Apply_Config --
 970    --------------------------------------
 971
 972    procedure Process_Project_And_Apply_Config
 973      (Main_Project               : out Prj.Project_Id;
 974       User_Project_Node          : Prj.Tree.Project_Node_Id;
 975       Config_File_Name           : String := "";
 976       Autoconf_Specified         : Boolean;
 977       Project_Tree               : Prj.Project_Tree_Ref;
 978       Project_Node_Tree          : Prj.Tree.Project_Node_Tree_Ref;
 979       Packages_To_Check          : String_List_Access;
 980       Allow_Automatic_Generation : Boolean := True;
 981       Automatically_Generated    : out Boolean;
 982       Config_File_Path           : out String_Access;
 983       Target_Name                : String := "";
 984       Normalized_Hostname        : String;
 985       Flags                      : Processing_Flags;
 986       On_Load_Config             : Config_File_Hook := null;
 987       Reset_Tree                 : Boolean := True)
 988    is
 989       Main_Config_Project : Project_Id;
 990       Success : Boolean;
 991
 992    begin
 993       Main_Project := No_Project;
 994       Automatically_Generated := False;
 995
 996       Process_Project_Tree_Phase_1
 997         (In_Tree                => Project_Tree,
 998          Project                => Main_Project,
 999          Success                => Success,
1000          From_Project_Node      => User_Project_Node,
1001          From_Project_Node_Tree => Project_Node_Tree,
1002          Flags                  => Flags,
1003          Reset_Tree             => Reset_Tree);
1004
1005       if not Success then
1006          Main_Project := No_Project;
1007          return;
1008       end if;
1009
1010       --  Find configuration file
1011
1012       Get_Or_Create_Configuration_File
1013         (Config                     => Main_Config_Project,
1014          Project                    => Main_Project,
1015          Project_Tree               => Project_Tree,
1016          Project_Node_Tree          => Project_Node_Tree,
1017          Allow_Automatic_Generation => Allow_Automatic_Generation,
1018          Config_File_Name           => Config_File_Name,
1019          Autoconf_Specified         => Autoconf_Specified,
1020          Target_Name                => Target_Name,
1021          Normalized_Hostname        => Normalized_Hostname,
1022          Packages_To_Check          => Packages_To_Check,
1023          Config_File_Path           => Config_File_Path,
1024          Automatically_Generated    => Automatically_Generated,
1025          Flags                      => Flags,
1026          On_Load_Config             => On_Load_Config);
1027
1028       Apply_Config_File (Main_Config_Project, Project_Tree);
1029
1030       --  Finish processing the user's project
1031
1032       Prj.Proc.Process_Project_Tree_Phase_2
1033         (In_Tree                    => Project_Tree,
1034          Project                    => Main_Project,
1035          Success                    => Success,
1036          From_Project_Node          => User_Project_Node,
1037          From_Project_Node_Tree     => Project_Node_Tree,
1038          Flags                      => Flags);
1039
1040       if not Success then
1041          Main_Project := No_Project;
1042       end if;
1043    end Process_Project_And_Apply_Config;
1044
1045    ------------------------------------
1046    -- Parse_Project_And_Apply_Config --
1047    ------------------------------------
1048
1049    procedure Parse_Project_And_Apply_Config
1050      (Main_Project               : out Prj.Project_Id;
1051       User_Project_Node          : out Prj.Tree.Project_Node_Id;
1052       Config_File_Name           : String := "";
1053       Autoconf_Specified         : Boolean;
1054       Project_File_Name          : String;
1055       Project_Tree               : Prj.Project_Tree_Ref;
1056       Project_Node_Tree          : Prj.Tree.Project_Node_Tree_Ref;
1057       Packages_To_Check          : String_List_Access;
1058       Allow_Automatic_Generation : Boolean := True;
1059       Automatically_Generated    : out Boolean;
1060       Config_File_Path           : out String_Access;
1061       Target_Name                : String := "";
1062       Normalized_Hostname        : String;
1063       Flags                      : Processing_Flags;
1064       On_Load_Config             : Config_File_Hook := null)
1065    is
1066    begin
1067       --  Parse the user project tree
1068
1069       Prj.Initialize (Project_Tree);
1070
1071       Main_Project      := No_Project;
1072       Automatically_Generated := False;
1073
1074       Prj.Part.Parse
1075         (In_Tree                => Project_Node_Tree,
1076          Project                => User_Project_Node,
1077          Project_File_Name      => Project_File_Name,
1078          Always_Errout_Finalize => False,
1079          Packages_To_Check      => Packages_To_Check,
1080          Current_Directory      => Current_Directory,
1081          Is_Config_File         => False,
1082          Flags                  => Flags);
1083
1084       if User_Project_Node = Empty_Node then
1085          User_Project_Node := Empty_Node;
1086          return;
1087       end if;
1088
1089       Process_Project_And_Apply_Config
1090         (Main_Project               => Main_Project,
1091          User_Project_Node          => User_Project_Node,
1092          Config_File_Name           => Config_File_Name,
1093          Autoconf_Specified         => Autoconf_Specified,
1094          Project_Tree               => Project_Tree,
1095          Project_Node_Tree          => Project_Node_Tree,
1096          Packages_To_Check          => Packages_To_Check,
1097          Allow_Automatic_Generation => Allow_Automatic_Generation,
1098          Automatically_Generated    => Automatically_Generated,
1099          Config_File_Path           => Config_File_Path,
1100          Target_Name                => Target_Name,
1101          Normalized_Hostname        => Normalized_Hostname,
1102          Flags                      => Flags,
1103          On_Load_Config             => On_Load_Config);
1104    end Parse_Project_And_Apply_Config;
1105
1106    -----------------------
1107    -- Apply_Config_File --
1108    -----------------------
1109
1110    procedure Apply_Config_File
1111      (Config_File  : Prj.Project_Id;
1112       Project_Tree : Prj.Project_Tree_Ref)
1113    is
1114       Conf_Decl    : constant Declarations := Config_File.Decl;
1115       Conf_Pack_Id : Package_Id;
1116       Conf_Pack    : Package_Element;
1117
1118       User_Decl    : Declarations;
1119       User_Pack_Id : Package_Id;
1120       User_Pack    : Package_Element;
1121       Proj         : Project_List;
1122
1123    begin
1124       Proj := Project_Tree.Projects;
1125       while Proj /= null loop
1126          if Proj.Project /= Config_File then
1127             User_Decl := Proj.Project.Decl;
1128             Add_Attributes
1129               (Project_Tree => Project_Tree,
1130                Conf_Decl    => Conf_Decl,
1131                User_Decl    => User_Decl);
1132
1133             Conf_Pack_Id := Conf_Decl.Packages;
1134             while Conf_Pack_Id /= No_Package loop
1135                Conf_Pack := Project_Tree.Packages.Table (Conf_Pack_Id);
1136
1137                User_Pack_Id := User_Decl.Packages;
1138                while User_Pack_Id /= No_Package loop
1139                   User_Pack := Project_Tree.Packages.Table (User_Pack_Id);
1140                   exit when User_Pack.Name = Conf_Pack.Name;
1141                   User_Pack_Id := User_Pack.Next;
1142                end loop;
1143
1144                if User_Pack_Id = No_Package then
1145                   Package_Table.Increment_Last (Project_Tree.Packages);
1146                   User_Pack := Conf_Pack;
1147                   User_Pack.Next := User_Decl.Packages;
1148                   User_Decl.Packages :=
1149                     Package_Table.Last (Project_Tree.Packages);
1150                   Project_Tree.Packages.Table (User_Decl.Packages) :=
1151                     User_Pack;
1152
1153                else
1154                   Add_Attributes
1155                     (Project_Tree => Project_Tree,
1156                      Conf_Decl    => Conf_Pack.Decl,
1157                      User_Decl    => Project_Tree.Packages.Table
1158                        (User_Pack_Id).Decl);
1159                end if;
1160
1161                Conf_Pack_Id := Conf_Pack.Next;
1162             end loop;
1163
1164             Proj.Project.Decl := User_Decl;
1165          end if;
1166
1167          Proj := Proj.Next;
1168       end loop;
1169    end Apply_Config_File;
1170
1171    ---------------------
1172    -- Set_Runtime_For --
1173    ---------------------
1174
1175    procedure Set_Runtime_For (Language : Name_Id; RTS_Name : String) is
1176    begin
1177       Name_Len := RTS_Name'Length;
1178       Name_Buffer (1 .. Name_Len) := RTS_Name;
1179       RTS_Languages.Set (Language, Name_Find);
1180    end Set_Runtime_For;
1181
1182    ----------------------
1183    -- Runtime_Name_For --
1184    ----------------------
1185
1186    function Runtime_Name_For (Language : Name_Id) return String is
1187    begin
1188       if RTS_Languages.Get (Language) /= No_Name then
1189          return Get_Name_String (RTS_Languages.Get (Language));
1190       else
1191          return "";
1192       end if;
1193    end Runtime_Name_For;
1194
1195    ------------------------------------
1196    -- Add_Default_GNAT_Naming_Scheme --
1197    ------------------------------------
1198
1199    procedure Add_Default_GNAT_Naming_Scheme
1200      (Config_File  : in out Project_Node_Id;
1201       Project_Tree : Project_Node_Tree_Ref)
1202    is
1203       procedure Create_Attribute
1204         (Name  : Name_Id;
1205          Value : String;
1206          Index : String := "";
1207          Pkg   : Project_Node_Id := Empty_Node);
1208
1209       ----------------------
1210       -- Create_Attribute --
1211       ----------------------
1212
1213       procedure Create_Attribute
1214         (Name  : Name_Id;
1215          Value : String;
1216          Index : String := "";
1217          Pkg   : Project_Node_Id := Empty_Node)
1218       is
1219          Attr       : Project_Node_Id;
1220          pragma Unreferenced (Attr);
1221
1222          Expr   : Name_Id         := No_Name;
1223          Val    : Name_Id         := No_Name;
1224          Parent : Project_Node_Id := Config_File;
1225       begin
1226          if Index /= "" then
1227             Name_Len := Index'Length;
1228             Name_Buffer (1 .. Name_Len) := Index;
1229             Val := Name_Find;
1230          end if;
1231
1232          if Pkg /= Empty_Node then
1233             Parent := Pkg;
1234          end if;
1235
1236          Name_Len := Value'Length;
1237          Name_Buffer (1 .. Name_Len) := Value;
1238          Expr := Name_Find;
1239
1240          Attr := Create_Attribute
1241            (Tree       => Project_Tree,
1242             Prj_Or_Pkg => Parent,
1243             Name       => Name,
1244             Index_Name => Val,
1245             Kind       => Prj.Single,
1246             Value      => Create_Literal_String (Expr, Project_Tree));
1247       end Create_Attribute;
1248
1249       --  Local variables
1250
1251       Name   : Name_Id;
1252       Naming : Project_Node_Id;
1253
1254    --  Start of processing for Add_Default_GNAT_Naming_Scheme
1255
1256    begin
1257       if Config_File = Empty_Node then
1258
1259          --  Create a dummy config file is none was found
1260
1261          Name_Len := Auto_Cgpr'Length;
1262          Name_Buffer (1 .. Name_Len) := Auto_Cgpr;
1263          Name := Name_Find;
1264
1265          --  An invalid project name to avoid conflicts with user-created ones
1266
1267          Name_Len := 5;
1268          Name_Buffer (1 .. Name_Len) := "_auto";
1269
1270          Config_File :=
1271            Create_Project
1272              (In_Tree        => Project_Tree,
1273               Name           => Name_Find,
1274               Full_Path      => Path_Name_Type (Name),
1275               Is_Config_File => True);
1276
1277          --  Setup library support
1278
1279          case MLib.Tgt.Support_For_Libraries is
1280             when None =>
1281                null;
1282
1283             when Static_Only =>
1284                Create_Attribute (Name_Library_Support, "static_only");
1285
1286             when Full =>
1287                Create_Attribute (Name_Library_Support, "full");
1288          end case;
1289
1290          if MLib.Tgt.Standalone_Library_Auto_Init_Is_Supported then
1291             Create_Attribute (Name_Library_Auto_Init_Supported, "true");
1292          else
1293             Create_Attribute (Name_Library_Auto_Init_Supported, "false");
1294          end if;
1295
1296          --  Setup Ada support (Ada is the default language here, since this
1297          --  is only called when no config file existed initially, ie for
1298          --  gnatmake).
1299
1300          Create_Attribute (Name_Default_Language, "ada");
1301
1302          Naming := Create_Package (Project_Tree, Config_File, "naming");
1303          Create_Attribute (Name_Spec_Suffix, ".ads", "ada",     Pkg => Naming);
1304          Create_Attribute (Name_Separate_Suffix, ".adb", "ada", Pkg => Naming);
1305          Create_Attribute (Name_Body_Suffix, ".adb", "ada",     Pkg => Naming);
1306          Create_Attribute (Name_Dot_Replacement, "-",           Pkg => Naming);
1307          Create_Attribute (Name_Casing,          "lowercase",   Pkg => Naming);
1308
1309          if Current_Verbosity = High then
1310             Write_Line ("Automatically generated (in-memory) config file");
1311             Prj.PP.Pretty_Print
1312               (Project                => Config_File,
1313                In_Tree                => Project_Tree,
1314                Backward_Compatibility => False);
1315          end if;
1316       end if;
1317    end Add_Default_GNAT_Naming_Scheme;
1318
1319 end Prj.Conf;