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