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-2013, 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 26with Hostparm; 27with Makeutl; use Makeutl; 28with MLib.Tgt; 29with Opt; use Opt; 30with Output; use Output; 31with Prj.Env; 32with Prj.Err; 33with Prj.Part; 34with Prj.PP; 35with Prj.Proc; use Prj.Proc; 36with Prj.Tree; use Prj.Tree; 37with Prj.Util; use Prj.Util; 38with Prj; use Prj; 39with Snames; use Snames; 40 41with Ada.Directories; use Ada.Directories; 42with Ada.Exceptions; use Ada.Exceptions; 43 44with GNAT.Case_Util; use GNAT.Case_Util; 45with GNAT.HTable; use GNAT.HTable; 46 47package body Prj.Conf is 48 49 Auto_Cgpr : constant String := "auto.cgpr"; 50 51 Config_Project_Env_Var : constant String := "GPR_CONFIG"; 52 -- Name of the environment variable that provides the name of the 53 -- configuration file to use. 54 55 Gprconfig_Name : constant String := "gprconfig"; 56 57 package RTS_Languages is new GNAT.HTable.Simple_HTable 58 (Header_Num => Prj.Header_Num, 59 Element => Name_Id, 60 No_Element => No_Name, 61 Key => Name_Id, 62 Hash => Prj.Hash, 63 Equal => "="); 64 -- Stores the runtime names for the various languages. This is in general 65 -- set from a --RTS command line option. 66 67 ----------------------- 68 -- Local_Subprograms -- 69 ----------------------- 70 71 function Check_Target 72 (Config_File : Prj.Project_Id; 73 Autoconf_Specified : Boolean; 74 Project_Tree : Prj.Project_Tree_Ref; 75 Target : String := "") return Boolean; 76 -- Check that the config file's target matches Target. 77 -- Target should be set to the empty string when the user did not specify 78 -- a target. If the target in the configuration file is invalid, this 79 -- function will raise Invalid_Config with an appropriate message. 80 -- Autoconf_Specified should be set to True if the user has used 81 -- autoconf. 82 83 function Locate_Config_File (Name : String) return String_Access; 84 -- Search for Name in the config files directory. Return full path if 85 -- found, or null otherwise. 86 87 procedure Raise_Invalid_Config (Msg : String); 88 pragma No_Return (Raise_Invalid_Config); 89 -- Raises exception Invalid_Config with given message 90 91 procedure Apply_Config_File 92 (Config_File : Prj.Project_Id; 93 Project_Tree : Prj.Project_Tree_Ref); 94 -- Apply the configuration file settings to all the projects in the 95 -- project tree. The Project_Tree must have been parsed first, and 96 -- processed through the first phase so that all its projects are known. 97 -- 98 -- Currently, this will add new attributes and packages in the various 99 -- projects, so that when the second phase of the processing is performed 100 -- these attributes are automatically taken into account. 101 102 ------------------------------------ 103 -- Add_Default_GNAT_Naming_Scheme -- 104 ------------------------------------ 105 106 procedure Add_Default_GNAT_Naming_Scheme 107 (Config_File : in out Project_Node_Id; 108 Project_Tree : Project_Node_Tree_Ref) 109 is 110 procedure Create_Attribute 111 (Name : Name_Id; 112 Value : String; 113 Index : String := ""; 114 Pkg : Project_Node_Id := Empty_Node); 115 116 ---------------------- 117 -- Create_Attribute -- 118 ---------------------- 119 120 procedure Create_Attribute 121 (Name : Name_Id; 122 Value : String; 123 Index : String := ""; 124 Pkg : Project_Node_Id := Empty_Node) 125 is 126 Attr : Project_Node_Id; 127 pragma Unreferenced (Attr); 128 129 Expr : Name_Id := No_Name; 130 Val : Name_Id := No_Name; 131 Parent : Project_Node_Id := Config_File; 132 133 begin 134 if Index /= "" then 135 Name_Len := Index'Length; 136 Name_Buffer (1 .. Name_Len) := Index; 137 Val := Name_Find; 138 end if; 139 140 if Pkg /= Empty_Node then 141 Parent := Pkg; 142 end if; 143 144 Name_Len := Value'Length; 145 Name_Buffer (1 .. Name_Len) := Value; 146 Expr := Name_Find; 147 148 Attr := Create_Attribute 149 (Tree => Project_Tree, 150 Prj_Or_Pkg => Parent, 151 Name => Name, 152 Index_Name => Val, 153 Kind => Prj.Single, 154 Value => Create_Literal_String (Expr, Project_Tree)); 155 end Create_Attribute; 156 157 -- Local variables 158 159 Name : Name_Id; 160 Naming : Project_Node_Id; 161 Compiler : Project_Node_Id; 162 163 -- Start of processing for Add_Default_GNAT_Naming_Scheme 164 165 begin 166 if Config_File = Empty_Node then 167 168 -- Create a dummy config file is none was found 169 170 Name_Len := Auto_Cgpr'Length; 171 Name_Buffer (1 .. Name_Len) := Auto_Cgpr; 172 Name := Name_Find; 173 174 -- An invalid project name to avoid conflicts with user-created ones 175 176 Name_Len := 5; 177 Name_Buffer (1 .. Name_Len) := "_auto"; 178 179 Config_File := 180 Create_Project 181 (In_Tree => Project_Tree, 182 Name => Name_Find, 183 Full_Path => Path_Name_Type (Name), 184 Is_Config_File => True); 185 186 -- Setup library support 187 188 case MLib.Tgt.Support_For_Libraries is 189 when None => 190 null; 191 192 when Static_Only => 193 Create_Attribute (Name_Library_Support, "static_only"); 194 195 when Full => 196 Create_Attribute (Name_Library_Support, "full"); 197 end case; 198 199 if MLib.Tgt.Standalone_Library_Auto_Init_Is_Supported then 200 Create_Attribute (Name_Library_Auto_Init_Supported, "true"); 201 else 202 Create_Attribute (Name_Library_Auto_Init_Supported, "false"); 203 end if; 204 205 -- Declare an empty target 206 207 Create_Attribute (Name_Target, ""); 208 209 -- Setup Ada support (Ada is the default language here, since this 210 -- is only called when no config file existed initially, ie for 211 -- gnatmake). 212 213 Create_Attribute (Name_Default_Language, "ada"); 214 215 Compiler := Create_Package (Project_Tree, Config_File, "compiler"); 216 Create_Attribute 217 (Name_Driver, "gcc", "ada", Pkg => Compiler); 218 Create_Attribute 219 (Name_Language_Kind, "unit_based", "ada", Pkg => Compiler); 220 Create_Attribute 221 (Name_Dependency_Kind, "ALI_File", "ada", Pkg => Compiler); 222 223 Naming := Create_Package (Project_Tree, Config_File, "naming"); 224 Create_Attribute (Name_Spec_Suffix, ".ads", "ada", Pkg => Naming); 225 Create_Attribute (Name_Separate_Suffix, ".adb", "ada", Pkg => Naming); 226 Create_Attribute (Name_Body_Suffix, ".adb", "ada", Pkg => Naming); 227 Create_Attribute (Name_Dot_Replacement, "-", Pkg => Naming); 228 Create_Attribute (Name_Casing, "lowercase", Pkg => Naming); 229 230 if Current_Verbosity = High then 231 Write_Line ("Automatically generated (in-memory) config file"); 232 Prj.PP.Pretty_Print 233 (Project => Config_File, 234 In_Tree => Project_Tree, 235 Backward_Compatibility => False); 236 end if; 237 end if; 238 end Add_Default_GNAT_Naming_Scheme; 239 240 ----------------------- 241 -- Apply_Config_File -- 242 ----------------------- 243 244 procedure Apply_Config_File 245 (Config_File : Prj.Project_Id; 246 Project_Tree : Prj.Project_Tree_Ref) 247 is 248 procedure Add_Attributes 249 (Project_Tree : Project_Tree_Ref; 250 Conf_Decl : Declarations; 251 User_Decl : in out Declarations); 252 -- Process the attributes in the config declarations. For 253 -- single string values, if the attribute is not declared in 254 -- the user declarations, declare it with the value in the 255 -- config declarations. For string list values, prepend the 256 -- value in the user declarations with the value in the config 257 -- declarations. 258 259 -------------------- 260 -- Add_Attributes -- 261 -------------------- 262 263 procedure Add_Attributes 264 (Project_Tree : Project_Tree_Ref; 265 Conf_Decl : Declarations; 266 User_Decl : in out Declarations) 267 is 268 Shared : constant Shared_Project_Tree_Data_Access := 269 Project_Tree.Shared; 270 Conf_Attr_Id : Variable_Id; 271 Conf_Attr : Variable; 272 Conf_Array_Id : Array_Id; 273 Conf_Array : Array_Data; 274 Conf_Array_Elem_Id : Array_Element_Id; 275 Conf_Array_Elem : Array_Element; 276 Conf_List : String_List_Id; 277 Conf_List_Elem : String_Element; 278 279 User_Attr_Id : Variable_Id; 280 User_Attr : Variable; 281 User_Array_Id : Array_Id; 282 User_Array : Array_Data; 283 User_Array_Elem_Id : Array_Element_Id; 284 User_Array_Elem : Array_Element; 285 286 begin 287 Conf_Attr_Id := Conf_Decl.Attributes; 288 User_Attr_Id := User_Decl.Attributes; 289 290 while Conf_Attr_Id /= No_Variable loop 291 Conf_Attr := Shared.Variable_Elements.Table (Conf_Attr_Id); 292 User_Attr := Shared.Variable_Elements.Table (User_Attr_Id); 293 294 if not Conf_Attr.Value.Default then 295 if User_Attr.Value.Default then 296 297 -- No attribute declared in user project file: just copy 298 -- the value of the configuration attribute. 299 300 User_Attr.Value := Conf_Attr.Value; 301 Shared.Variable_Elements.Table (User_Attr_Id) := User_Attr; 302 303 elsif User_Attr.Value.Kind = List 304 and then Conf_Attr.Value.Values /= Nil_String 305 then 306 -- List attribute declared in both the user project and the 307 -- configuration project: prepend the user list with the 308 -- configuration list. 309 310 declare 311 User_List : constant String_List_Id := 312 User_Attr.Value.Values; 313 Conf_List : String_List_Id := Conf_Attr.Value.Values; 314 Conf_Elem : String_Element; 315 New_List : String_List_Id; 316 New_Elem : String_Element; 317 318 begin 319 -- Create new list 320 321 String_Element_Table.Increment_Last 322 (Shared.String_Elements); 323 New_List := 324 String_Element_Table.Last (Shared.String_Elements); 325 326 -- Value of attribute is new list 327 328 User_Attr.Value.Values := New_List; 329 Shared.Variable_Elements.Table (User_Attr_Id) := 330 User_Attr; 331 332 loop 333 -- Get each element of configuration list 334 335 Conf_Elem := Shared.String_Elements.Table (Conf_List); 336 New_Elem := Conf_Elem; 337 Conf_List := Conf_Elem.Next; 338 339 if Conf_List = Nil_String then 340 341 -- If it is the last element in the list, connect 342 -- to first element of user list, and we are done. 343 344 New_Elem.Next := User_List; 345 Shared.String_Elements.Table (New_List) := New_Elem; 346 exit; 347 348 else 349 -- If it is not the last element in the list, add 350 -- to new list. 351 352 String_Element_Table.Increment_Last 353 (Shared.String_Elements); 354 New_Elem.Next := String_Element_Table.Last 355 (Shared.String_Elements); 356 Shared.String_Elements.Table (New_List) := New_Elem; 357 New_List := New_Elem.Next; 358 end if; 359 end loop; 360 end; 361 end if; 362 end if; 363 364 Conf_Attr_Id := Conf_Attr.Next; 365 User_Attr_Id := User_Attr.Next; 366 end loop; 367 368 Conf_Array_Id := Conf_Decl.Arrays; 369 while Conf_Array_Id /= No_Array loop 370 Conf_Array := Shared.Arrays.Table (Conf_Array_Id); 371 372 User_Array_Id := User_Decl.Arrays; 373 while User_Array_Id /= No_Array loop 374 User_Array := Shared.Arrays.Table (User_Array_Id); 375 exit when User_Array.Name = Conf_Array.Name; 376 User_Array_Id := User_Array.Next; 377 end loop; 378 379 -- If this associative array does not exist in the user project 380 -- file, do a shallow copy of the full associative array. 381 382 if User_Array_Id = No_Array then 383 Array_Table.Increment_Last (Shared.Arrays); 384 User_Array := Conf_Array; 385 User_Array.Next := User_Decl.Arrays; 386 User_Decl.Arrays := Array_Table.Last (Shared.Arrays); 387 Shared.Arrays.Table (User_Decl.Arrays) := User_Array; 388 389 -- Otherwise, check each array element 390 391 else 392 Conf_Array_Elem_Id := Conf_Array.Value; 393 while Conf_Array_Elem_Id /= No_Array_Element loop 394 Conf_Array_Elem := 395 Shared.Array_Elements.Table (Conf_Array_Elem_Id); 396 397 User_Array_Elem_Id := User_Array.Value; 398 while User_Array_Elem_Id /= No_Array_Element loop 399 User_Array_Elem := 400 Shared.Array_Elements.Table (User_Array_Elem_Id); 401 exit when User_Array_Elem.Index = Conf_Array_Elem.Index; 402 User_Array_Elem_Id := User_Array_Elem.Next; 403 end loop; 404 405 -- If the array element doesn't exist in the user array, 406 -- insert a shallow copy of the conf array element in the 407 -- user array. 408 409 if User_Array_Elem_Id = No_Array_Element then 410 Array_Element_Table.Increment_Last 411 (Shared.Array_Elements); 412 User_Array_Elem := Conf_Array_Elem; 413 User_Array_Elem.Next := User_Array.Value; 414 User_Array.Value := 415 Array_Element_Table.Last (Shared.Array_Elements); 416 Shared.Array_Elements.Table (User_Array.Value) := 417 User_Array_Elem; 418 Shared.Arrays.Table (User_Array_Id) := User_Array; 419 420 -- Otherwise, if the value is a string list, prepend the 421 -- conf array element value to the array element. 422 423 elsif Conf_Array_Elem.Value.Kind = List then 424 Conf_List := Conf_Array_Elem.Value.Values; 425 426 if Conf_List /= Nil_String then 427 declare 428 Link : constant String_List_Id := 429 User_Array_Elem.Value.Values; 430 Previous : String_List_Id := Nil_String; 431 Next : String_List_Id; 432 433 begin 434 loop 435 Conf_List_Elem := 436 Shared.String_Elements.Table (Conf_List); 437 String_Element_Table.Increment_Last 438 (Shared.String_Elements); 439 Next := 440 String_Element_Table.Last 441 (Shared.String_Elements); 442 Shared.String_Elements.Table (Next) := 443 Conf_List_Elem; 444 445 if Previous = Nil_String then 446 User_Array_Elem.Value.Values := Next; 447 Shared.Array_Elements.Table 448 (User_Array_Elem_Id) := User_Array_Elem; 449 450 else 451 Shared.String_Elements.Table 452 (Previous).Next := Next; 453 end if; 454 455 Previous := Next; 456 457 Conf_List := Conf_List_Elem.Next; 458 459 if Conf_List = Nil_String then 460 Shared.String_Elements.Table 461 (Previous).Next := Link; 462 exit; 463 end if; 464 end loop; 465 end; 466 end if; 467 end if; 468 469 Conf_Array_Elem_Id := Conf_Array_Elem.Next; 470 end loop; 471 end if; 472 473 Conf_Array_Id := Conf_Array.Next; 474 end loop; 475 end Add_Attributes; 476 477 Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared; 478 479 Conf_Decl : constant Declarations := Config_File.Decl; 480 Conf_Pack_Id : Package_Id; 481 Conf_Pack : Package_Element; 482 483 User_Decl : Declarations; 484 User_Pack_Id : Package_Id; 485 User_Pack : Package_Element; 486 Proj : Project_List; 487 488 begin 489 Debug_Output ("Applying config file to a project tree"); 490 491 Proj := Project_Tree.Projects; 492 while Proj /= null loop 493 if Proj.Project /= Config_File then 494 User_Decl := Proj.Project.Decl; 495 Add_Attributes 496 (Project_Tree => Project_Tree, 497 Conf_Decl => Conf_Decl, 498 User_Decl => User_Decl); 499 500 Conf_Pack_Id := Conf_Decl.Packages; 501 while Conf_Pack_Id /= No_Package loop 502 Conf_Pack := Shared.Packages.Table (Conf_Pack_Id); 503 504 User_Pack_Id := User_Decl.Packages; 505 while User_Pack_Id /= No_Package loop 506 User_Pack := Shared.Packages.Table (User_Pack_Id); 507 exit when User_Pack.Name = Conf_Pack.Name; 508 User_Pack_Id := User_Pack.Next; 509 end loop; 510 511 if User_Pack_Id = No_Package then 512 Package_Table.Increment_Last (Shared.Packages); 513 User_Pack := Conf_Pack; 514 User_Pack.Next := User_Decl.Packages; 515 User_Decl.Packages := Package_Table.Last (Shared.Packages); 516 Shared.Packages.Table (User_Decl.Packages) := User_Pack; 517 518 else 519 Add_Attributes 520 (Project_Tree => Project_Tree, 521 Conf_Decl => Conf_Pack.Decl, 522 User_Decl => Shared.Packages.Table 523 (User_Pack_Id).Decl); 524 end if; 525 526 Conf_Pack_Id := Conf_Pack.Next; 527 end loop; 528 529 Proj.Project.Decl := User_Decl; 530 531 -- For aggregate projects, we need to apply the config to all 532 -- their aggregated trees as well. 533 534 if Proj.Project.Qualifier in Aggregate_Project then 535 declare 536 List : Aggregated_Project_List; 537 begin 538 List := Proj.Project.Aggregated_Projects; 539 while List /= null loop 540 Debug_Output 541 ("Recursively apply config to aggregated tree", 542 List.Project.Name); 543 Apply_Config_File 544 (Config_File, Project_Tree => List.Tree); 545 List := List.Next; 546 end loop; 547 end; 548 end if; 549 end if; 550 551 Proj := Proj.Next; 552 end loop; 553 end Apply_Config_File; 554 555 ------------------ 556 -- Check_Target -- 557 ------------------ 558 559 function Check_Target 560 (Config_File : Project_Id; 561 Autoconf_Specified : Boolean; 562 Project_Tree : Prj.Project_Tree_Ref; 563 Target : String := "") return Boolean 564 is 565 Shared : constant Shared_Project_Tree_Data_Access := 566 Project_Tree.Shared; 567 Variable : constant Variable_Value := 568 Value_Of 569 (Name_Target, Config_File.Decl.Attributes, Shared); 570 Tgt_Name : Name_Id := No_Name; 571 OK : Boolean; 572 573 begin 574 if Variable /= Nil_Variable_Value and then not Variable.Default then 575 Tgt_Name := Variable.Value; 576 end if; 577 578 OK := 579 Target = "" 580 or else 581 (Tgt_Name /= No_Name 582 and then (Length_Of_Name (Tgt_Name) = 0 583 or else Target = Get_Name_String (Tgt_Name))); 584 585 if not OK then 586 if Autoconf_Specified then 587 if Verbose_Mode then 588 Write_Line ("inconsistent targets, performing autoconf"); 589 end if; 590 591 return False; 592 593 else 594 if Tgt_Name /= No_Name then 595 Raise_Invalid_Config 596 ("invalid target name """ 597 & Get_Name_String (Tgt_Name) & """ in configuration"); 598 else 599 Raise_Invalid_Config 600 ("no target specified in configuration file"); 601 end if; 602 end if; 603 end if; 604 605 return True; 606 end Check_Target; 607 608 -------------------------------------- 609 -- Get_Or_Create_Configuration_File -- 610 -------------------------------------- 611 612 procedure Get_Or_Create_Configuration_File 613 (Project : Project_Id; 614 Conf_Project : Project_Id; 615 Project_Tree : Project_Tree_Ref; 616 Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref; 617 Env : in out Prj.Tree.Environment; 618 Allow_Automatic_Generation : Boolean; 619 Config_File_Name : String := ""; 620 Autoconf_Specified : Boolean; 621 Target_Name : String := ""; 622 Normalized_Hostname : String; 623 Packages_To_Check : String_List_Access := null; 624 Config : out Prj.Project_Id; 625 Config_File_Path : out String_Access; 626 Automatically_Generated : out Boolean; 627 On_Load_Config : Config_File_Hook := null) 628 is 629 Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared; 630 631 At_Least_One_Compiler_Command : Boolean := False; 632 -- Set to True if at least one attribute Ide'Compiler_Command is 633 -- specified for one language of the system. 634 635 Conf_File_Name : String_Access := new String'(Config_File_Name); 636 -- The configuration project file name. May be modified if there are 637 -- switches --config= in the Builder package of the main project. 638 639 Selected_Target : String_Access := new String'(Target_Name); 640 641 function Default_File_Name return String; 642 -- Return the name of the default config file that should be tested 643 644 procedure Do_Autoconf; 645 -- Generate a new config file through gprconfig. In case of error, this 646 -- raises the Invalid_Config exception with an appropriate message 647 648 procedure Check_Builder_Switches; 649 -- Check for switches --config and --RTS in package Builder 650 651 procedure Get_Project_Target; 652 -- If Target_Name is empty, get the specified target in the project 653 -- file, if any. 654 655 function Get_Config_Switches return Argument_List_Access; 656 -- Return the --config switches to use for gprconfig 657 658 function Get_Db_Switches return Argument_List_Access; 659 -- Return the --db switches to use for gprconfig 660 661 function Might_Have_Sources (Project : Project_Id) return Boolean; 662 -- True if the specified project might have sources (ie the user has not 663 -- explicitly specified it. We haven't checked the file system, nor do 664 -- we need to at this stage. 665 666 ---------------------------- 667 -- Check_Builder_Switches -- 668 ---------------------------- 669 670 procedure Check_Builder_Switches is 671 Get_RTS_Switches : constant Boolean := 672 RTS_Languages.Get_First = No_Name; 673 -- If no switch --RTS have been specified on the command line, look 674 -- for --RTS switches in the Builder switches. 675 676 Builder : constant Package_Id := 677 Value_Of (Name_Builder, Project.Decl.Packages, Shared); 678 679 Switch_Array_Id : Array_Element_Id; 680 -- The Switches to be checked 681 682 procedure Check_Switches; 683 -- Check the switches in Switch_Array_Id 684 685 -------------------- 686 -- Check_Switches -- 687 -------------------- 688 689 procedure Check_Switches is 690 Switch_Array : Array_Element; 691 Switch_List : String_List_Id := Nil_String; 692 Switch : String_Element; 693 Lang : Name_Id; 694 Lang_Last : Positive; 695 696 begin 697 while Switch_Array_Id /= No_Array_Element loop 698 Switch_Array := 699 Shared.Array_Elements.Table (Switch_Array_Id); 700 701 Switch_List := Switch_Array.Value.Values; 702 List_Loop : while Switch_List /= Nil_String loop 703 Switch := Shared.String_Elements.Table (Switch_List); 704 705 if Switch.Value /= No_Name then 706 Get_Name_String (Switch.Value); 707 708 if Conf_File_Name'Length = 0 709 and then Name_Len > 9 710 and then Name_Buffer (1 .. 9) = "--config=" 711 then 712 Conf_File_Name := 713 new String'(Name_Buffer (10 .. Name_Len)); 714 715 elsif Get_RTS_Switches 716 and then Name_Len >= 7 717 and then Name_Buffer (1 .. 5) = "--RTS" 718 then 719 if Name_Buffer (6) = '=' then 720 if not Runtime_Name_Set_For (Name_Ada) then 721 Set_Runtime_For 722 (Name_Ada, 723 Name_Buffer (7 .. Name_Len)); 724 Locate_Runtime (Name_Ada, Project_Tree); 725 end if; 726 727 elsif Name_Len > 7 728 and then Name_Buffer (6) = ':' 729 and then Name_Buffer (7) /= '=' 730 then 731 Lang_Last := 7; 732 while Lang_Last < Name_Len 733 and then Name_Buffer (Lang_Last + 1) /= '=' 734 loop 735 Lang_Last := Lang_Last + 1; 736 end loop; 737 738 if Name_Buffer (Lang_Last + 1) = '=' then 739 declare 740 RTS : constant String := 741 Name_Buffer (Lang_Last + 2 .. Name_Len); 742 begin 743 Name_Buffer (1 .. Lang_Last - 6) := 744 Name_Buffer (7 .. Lang_Last); 745 Name_Len := Lang_Last - 6; 746 To_Lower (Name_Buffer (1 .. Name_Len)); 747 Lang := Name_Find; 748 749 if not Runtime_Name_Set_For (Lang) then 750 Set_Runtime_For (Lang, RTS); 751 Locate_Runtime (Lang, Project_Tree); 752 end if; 753 end; 754 end if; 755 end if; 756 end if; 757 end if; 758 759 Switch_List := Switch.Next; 760 end loop List_Loop; 761 762 Switch_Array_Id := Switch_Array.Next; 763 end loop; 764 end Check_Switches; 765 766 -- Start of processing for Check_Builder_Switches 767 768 begin 769 if Builder /= No_Package then 770 Switch_Array_Id := 771 Value_Of 772 (Name => Name_Switches, 773 In_Arrays => Shared.Packages.Table (Builder).Decl.Arrays, 774 Shared => Shared); 775 Check_Switches; 776 777 Switch_Array_Id := 778 Value_Of 779 (Name => Name_Default_Switches, 780 In_Arrays => Shared.Packages.Table (Builder).Decl.Arrays, 781 Shared => Shared); 782 Check_Switches; 783 end if; 784 end Check_Builder_Switches; 785 786 ------------------------ 787 -- Get_Project_Target -- 788 ------------------------ 789 790 procedure Get_Project_Target is 791 begin 792 if Selected_Target'Length = 0 then 793 794 -- Check if attribute Target is specified in the main 795 -- project, or in a project it extends. If it is, use this 796 -- target to invoke gprconfig. 797 798 declare 799 Variable : Variable_Value; 800 Proj : Project_Id; 801 Tgt_Name : Name_Id := No_Name; 802 803 begin 804 Proj := Project; 805 Project_Loop : 806 while Proj /= No_Project loop 807 Variable := 808 Value_Of (Name_Target, Proj.Decl.Attributes, Shared); 809 810 if Variable /= Nil_Variable_Value 811 and then not Variable.Default 812 and then Variable.Value /= No_Name 813 then 814 Tgt_Name := Variable.Value; 815 exit Project_Loop; 816 end if; 817 818 Proj := Proj.Extends; 819 end loop Project_Loop; 820 821 if Tgt_Name /= No_Name then 822 Selected_Target := new String'(Get_Name_String (Tgt_Name)); 823 end if; 824 end; 825 end if; 826 end Get_Project_Target; 827 828 ----------------------- 829 -- Default_File_Name -- 830 ----------------------- 831 832 function Default_File_Name return String is 833 Ada_RTS : constant String := Runtime_Name_For (Name_Ada); 834 Tmp : String_Access; 835 836 begin 837 if Selected_Target'Length /= 0 then 838 if Ada_RTS /= "" then 839 return 840 Selected_Target.all & '-' & 841 Ada_RTS & Config_Project_File_Extension; 842 else 843 return 844 Selected_Target.all & Config_Project_File_Extension; 845 end if; 846 847 elsif Ada_RTS /= "" then 848 return Ada_RTS & Config_Project_File_Extension; 849 850 else 851 Tmp := Getenv (Config_Project_Env_Var); 852 853 declare 854 T : constant String := Tmp.all; 855 856 begin 857 Free (Tmp); 858 859 if T'Length = 0 then 860 return Default_Config_Name; 861 else 862 return T; 863 end if; 864 end; 865 end if; 866 end Default_File_Name; 867 868 ----------------- 869 -- Do_Autoconf -- 870 ----------------- 871 872 procedure Do_Autoconf is 873 Obj_Dir : constant Variable_Value := 874 Value_Of 875 (Name_Object_Dir, 876 Conf_Project.Decl.Attributes, 877 Shared); 878 879 Gprconfig_Path : String_Access; 880 Success : Boolean; 881 882 begin 883 Gprconfig_Path := Locate_Exec_On_Path (Gprconfig_Name); 884 885 if Gprconfig_Path = null then 886 Raise_Invalid_Config 887 ("could not locate gprconfig for auto-configuration"); 888 end if; 889 890 -- First, find the object directory of the Conf_Project 891 892 if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then 893 Get_Name_String (Conf_Project.Directory.Display_Name); 894 895 else 896 if Is_Absolute_Path (Get_Name_String (Obj_Dir.Value)) then 897 Get_Name_String (Obj_Dir.Value); 898 899 else 900 Name_Len := 0; 901 Add_Str_To_Name_Buffer 902 (Get_Name_String (Conf_Project.Directory.Display_Name)); 903 Add_Str_To_Name_Buffer (Get_Name_String (Obj_Dir.Value)); 904 end if; 905 end if; 906 907 if Subdirs /= null then 908 Add_Char_To_Name_Buffer (Directory_Separator); 909 Add_Str_To_Name_Buffer (Subdirs.all); 910 end if; 911 912 for J in 1 .. Name_Len loop 913 if Name_Buffer (J) = '/' then 914 Name_Buffer (J) := Directory_Separator; 915 end if; 916 end loop; 917 918 -- Make sure that Obj_Dir ends with a directory separator 919 920 if Name_Buffer (Name_Len) /= Directory_Separator then 921 Name_Len := Name_Len + 1; 922 Name_Buffer (Name_Len) := Directory_Separator; 923 end if; 924 925 declare 926 Obj_Dir : constant String := Name_Buffer (1 .. Name_Len); 927 Config_Switches : Argument_List_Access; 928 Db_Switches : Argument_List_Access; 929 Args : Argument_List (1 .. 5); 930 Arg_Last : Positive; 931 Obj_Dir_Exists : Boolean := True; 932 933 begin 934 -- Check if the object directory exists. If Setup_Projects is True 935 -- (-p) and directory does not exist, attempt to create it. 936 -- Otherwise, if directory does not exist, fail without calling 937 -- gprconfig. 938 939 if not Is_Directory (Obj_Dir) 940 and then (Setup_Projects or else Subdirs /= null) 941 then 942 begin 943 Create_Path (Obj_Dir); 944 945 if not Quiet_Output then 946 Write_Str ("object directory """); 947 Write_Str (Obj_Dir); 948 Write_Line (""" created"); 949 end if; 950 951 exception 952 when others => 953 Raise_Invalid_Config 954 ("could not create object directory " & Obj_Dir); 955 end; 956 end if; 957 958 if not Is_Directory (Obj_Dir) then 959 case Env.Flags.Require_Obj_Dirs is 960 when Error => 961 Raise_Invalid_Config 962 ("object directory " & Obj_Dir & " does not exist"); 963 964 when Warning => 965 Prj.Err.Error_Msg 966 (Env.Flags, 967 "?object directory " & Obj_Dir & " does not exist"); 968 Obj_Dir_Exists := False; 969 970 when Silent => 971 null; 972 end case; 973 end if; 974 975 -- Get the config switches. This should be done only now, as some 976 -- runtimes may have been found if the Builder switches. 977 978 Config_Switches := Get_Config_Switches; 979 980 -- Get eventual --db switches 981 982 Db_Switches := Get_Db_Switches; 983 984 -- Invoke gprconfig 985 986 Args (1) := new String'("--batch"); 987 Args (2) := new String'("-o"); 988 989 -- If no config file was specified, set the auto.cgpr one 990 991 if Conf_File_Name'Length = 0 then 992 if Obj_Dir_Exists then 993 Args (3) := new String'(Obj_Dir & Auto_Cgpr); 994 995 else 996 declare 997 Path_FD : File_Descriptor; 998 Path_Name : Path_Name_Type; 999 1000 begin 1001 Prj.Env.Create_Temp_File 1002 (Shared => Project_Tree.Shared, 1003 Path_FD => Path_FD, 1004 Path_Name => Path_Name, 1005 File_Use => "configuration file"); 1006 1007 if Path_FD /= Invalid_FD then 1008 declare 1009 Temp_Dir : constant String := 1010 Containing_Directory 1011 (Get_Name_String (Path_Name)); 1012 begin 1013 GNAT.OS_Lib.Close (Path_FD); 1014 Args (3) := 1015 new String'(Temp_Dir & 1016 Directory_Separator & 1017 Auto_Cgpr); 1018 Delete_File (Get_Name_String (Path_Name)); 1019 end; 1020 1021 else 1022 -- We'll have an error message later on 1023 1024 Args (3) := new String'(Obj_Dir & Auto_Cgpr); 1025 end if; 1026 end; 1027 end if; 1028 else 1029 Args (3) := Conf_File_Name; 1030 end if; 1031 1032 if Normalized_Hostname = "" then 1033 Arg_Last := 3; 1034 else 1035 if Selected_Target'Length = 0 then 1036 if At_Least_One_Compiler_Command then 1037 Args (4) := 1038 new String'("--target=all"); 1039 else 1040 Args (4) := 1041 new String'("--target=" & Normalized_Hostname); 1042 end if; 1043 1044 else 1045 Args (4) := 1046 new String'("--target=" & Selected_Target.all); 1047 end if; 1048 1049 Arg_Last := 4; 1050 end if; 1051 1052 if not Verbose_Mode then 1053 Arg_Last := Arg_Last + 1; 1054 Args (Arg_Last) := new String'("-q"); 1055 end if; 1056 1057 if Verbose_Mode then 1058 Write_Str (Gprconfig_Name); 1059 1060 for J in 1 .. Arg_Last loop 1061 Write_Char (' '); 1062 Write_Str (Args (J).all); 1063 end loop; 1064 1065 for J in Config_Switches'Range loop 1066 Write_Char (' '); 1067 Write_Str (Config_Switches (J).all); 1068 end loop; 1069 1070 for J in Db_Switches'Range loop 1071 Write_Char (' '); 1072 Write_Str (Db_Switches (J).all); 1073 end loop; 1074 1075 Write_Eol; 1076 1077 elsif not Quiet_Output then 1078 -- Display no message if we are creating auto.cgpr, unless in 1079 -- verbose mode 1080 1081 if Config_File_Name'Length > 0 1082 or else Verbose_Mode 1083 then 1084 Write_Str ("creating "); 1085 Write_Str (Simple_Name (Args (3).all)); 1086 Write_Eol; 1087 end if; 1088 end if; 1089 1090 Spawn (Gprconfig_Path.all, Args (1 .. Arg_Last) & 1091 Config_Switches.all & Db_Switches.all, 1092 Success); 1093 1094 Free (Config_Switches); 1095 1096 Config_File_Path := Locate_Config_File (Args (3).all); 1097 1098 if Config_File_Path = null then 1099 Raise_Invalid_Config 1100 ("could not create " & Args (3).all); 1101 end if; 1102 1103 for F in Args'Range loop 1104 Free (Args (F)); 1105 end loop; 1106 end; 1107 end Do_Autoconf; 1108 1109 --------------------- 1110 -- Get_Db_Switches -- 1111 --------------------- 1112 1113 function Get_Db_Switches return Argument_List_Access is 1114 Result : Argument_List_Access; 1115 Nmb_Arg : Natural; 1116 begin 1117 Nmb_Arg := 1118 (2 * Db_Switch_Args.Last) + Boolean'Pos (not Load_Standard_Base); 1119 Result := new Argument_List (1 .. Nmb_Arg); 1120 1121 if Nmb_Arg /= 0 then 1122 for J in 1 .. Db_Switch_Args.Last loop 1123 Result (2 * J - 1) := 1124 new String'("--db"); 1125 Result (2 * J) := 1126 new String'(Get_Name_String (Db_Switch_Args.Table (J))); 1127 end loop; 1128 1129 if not Load_Standard_Base then 1130 Result (Result'Last) := new String'("--db-"); 1131 end if; 1132 end if; 1133 1134 return Result; 1135 end Get_Db_Switches; 1136 1137 ------------------------- 1138 -- Get_Config_Switches -- 1139 ------------------------- 1140 1141 function Get_Config_Switches return Argument_List_Access is 1142 1143 package Language_Htable is new GNAT.HTable.Simple_HTable 1144 (Header_Num => Prj.Header_Num, 1145 Element => Name_Id, 1146 No_Element => No_Name, 1147 Key => Name_Id, 1148 Hash => Prj.Hash, 1149 Equal => "="); 1150 -- Hash table to keep the languages used in the project tree 1151 1152 IDE : constant Package_Id := 1153 Value_Of (Name_Ide, Project.Decl.Packages, Shared); 1154 1155 procedure Add_Config_Switches_For_Project 1156 (Project : Project_Id; 1157 Tree : Project_Tree_Ref; 1158 With_State : in out Integer); 1159 -- Add all --config switches for this project. This is also called 1160 -- for aggregate projects. 1161 1162 ------------------------------------- 1163 -- Add_Config_Switches_For_Project -- 1164 ------------------------------------- 1165 1166 procedure Add_Config_Switches_For_Project 1167 (Project : Project_Id; 1168 Tree : Project_Tree_Ref; 1169 With_State : in out Integer) 1170 is 1171 pragma Unreferenced (With_State); 1172 1173 Shared : constant Shared_Project_Tree_Data_Access := Tree.Shared; 1174 1175 Variable : Variable_Value; 1176 Check_Default : Boolean; 1177 Lang : Name_Id; 1178 List : String_List_Id; 1179 Elem : String_Element; 1180 1181 begin 1182 if Might_Have_Sources (Project) then 1183 Variable := 1184 Value_Of (Name_Languages, Project.Decl.Attributes, Shared); 1185 1186 if Variable = Nil_Variable_Value or else Variable.Default then 1187 1188 -- Languages is not declared. If it is not an extending 1189 -- project, or if it extends a project with no Languages, 1190 -- check for Default_Language. 1191 1192 Check_Default := Project.Extends = No_Project; 1193 1194 if not Check_Default then 1195 Variable := 1196 Value_Of 1197 (Name_Languages, 1198 Project.Extends.Decl.Attributes, 1199 Shared); 1200 Check_Default := 1201 Variable /= Nil_Variable_Value 1202 and then Variable.Values = Nil_String; 1203 end if; 1204 1205 if Check_Default then 1206 Variable := 1207 Value_Of 1208 (Name_Default_Language, 1209 Project.Decl.Attributes, 1210 Shared); 1211 1212 if Variable /= Nil_Variable_Value 1213 and then not Variable.Default 1214 then 1215 Get_Name_String (Variable.Value); 1216 To_Lower (Name_Buffer (1 .. Name_Len)); 1217 Lang := Name_Find; 1218 Language_Htable.Set (Lang, Lang); 1219 1220 -- If no default language is declared, default to Ada 1221 1222 else 1223 Language_Htable.Set (Name_Ada, Name_Ada); 1224 end if; 1225 end if; 1226 1227 elsif Variable.Values /= Nil_String then 1228 1229 -- Attribute Languages is declared with a non empty list: 1230 -- put all the languages in Language_HTable. 1231 1232 List := Variable.Values; 1233 while List /= Nil_String loop 1234 Elem := Shared.String_Elements.Table (List); 1235 1236 Get_Name_String (Elem.Value); 1237 To_Lower (Name_Buffer (1 .. Name_Len)); 1238 Lang := Name_Find; 1239 Language_Htable.Set (Lang, Lang); 1240 1241 List := Elem.Next; 1242 end loop; 1243 end if; 1244 end if; 1245 end Add_Config_Switches_For_Project; 1246 1247 procedure For_Every_Imported_Project is new For_Every_Project_Imported 1248 (State => Integer, Action => Add_Config_Switches_For_Project); 1249 -- Document this procedure ??? 1250 1251 -- Local variables 1252 1253 Name : Name_Id; 1254 Count : Natural; 1255 Result : Argument_List_Access; 1256 Variable : Variable_Value; 1257 Dummy : Integer := 0; 1258 1259 -- Start of processing for Get_Config_Switches 1260 1261 begin 1262 For_Every_Imported_Project 1263 (By => Project, 1264 Tree => Project_Tree, 1265 With_State => Dummy, 1266 Include_Aggregated => True); 1267 1268 Name := Language_Htable.Get_First; 1269 Count := 0; 1270 while Name /= No_Name loop 1271 Count := Count + 1; 1272 Name := Language_Htable.Get_Next; 1273 end loop; 1274 1275 Result := new String_List (1 .. Count); 1276 1277 Count := 1; 1278 Name := Language_Htable.Get_First; 1279 while Name /= No_Name loop 1280 1281 -- Check if IDE'Compiler_Command is declared for the language. 1282 -- If it is, use its value to invoke gprconfig. 1283 1284 Variable := 1285 Value_Of 1286 (Name, 1287 Attribute_Or_Array_Name => Name_Compiler_Command, 1288 In_Package => IDE, 1289 Shared => Shared, 1290 Force_Lower_Case_Index => True); 1291 1292 declare 1293 Config_Command : constant String := 1294 "--config=" & Get_Name_String (Name); 1295 1296 Runtime_Name : constant String := 1297 Runtime_Name_For (Name); 1298 1299 begin 1300 if Variable = Nil_Variable_Value 1301 or else Length_Of_Name (Variable.Value) = 0 1302 then 1303 Result (Count) := 1304 new String'(Config_Command & ",," & Runtime_Name); 1305 1306 else 1307 At_Least_One_Compiler_Command := True; 1308 1309 declare 1310 Compiler_Command : constant String := 1311 Get_Name_String (Variable.Value); 1312 1313 begin 1314 if Is_Absolute_Path (Compiler_Command) then 1315 Result (Count) := 1316 new String' 1317 (Config_Command & ",," & Runtime_Name & "," & 1318 Containing_Directory (Compiler_Command) & "," & 1319 Simple_Name (Compiler_Command)); 1320 else 1321 Result (Count) := 1322 new String' 1323 (Config_Command & ",," & Runtime_Name & ",," & 1324 Compiler_Command); 1325 end if; 1326 end; 1327 end if; 1328 end; 1329 1330 Count := Count + 1; 1331 Name := Language_Htable.Get_Next; 1332 end loop; 1333 1334 return Result; 1335 end Get_Config_Switches; 1336 1337 ------------------------ 1338 -- Might_Have_Sources -- 1339 ------------------------ 1340 1341 function Might_Have_Sources (Project : Project_Id) return Boolean is 1342 Variable : Variable_Value; 1343 1344 begin 1345 Variable := 1346 Value_Of 1347 (Name_Source_Dirs, 1348 Project.Decl.Attributes, 1349 Shared); 1350 1351 if Variable = Nil_Variable_Value 1352 or else Variable.Default 1353 or else Variable.Values /= Nil_String 1354 then 1355 Variable := 1356 Value_Of 1357 (Name_Source_Files, 1358 Project.Decl.Attributes, 1359 Shared); 1360 return Variable = Nil_Variable_Value 1361 or else Variable.Default 1362 or else Variable.Values /= Nil_String; 1363 1364 else 1365 return False; 1366 end if; 1367 end Might_Have_Sources; 1368 1369 Success : Boolean; 1370 Config_Project_Node : Project_Node_Id := Empty_Node; 1371 1372 begin 1373 pragma Assert (Prj.Env.Is_Initialized (Env.Project_Path)); 1374 1375 Free (Config_File_Path); 1376 Config := No_Project; 1377 1378 Get_Project_Target; 1379 Check_Builder_Switches; 1380 1381 -- Do not attempt to find a configuration project file when 1382 -- Config_File_Name is No_Configuration_File. 1383 1384 if Config_File_Name = No_Configuration_File then 1385 Config_File_Path := null; 1386 1387 else 1388 if Conf_File_Name'Length > 0 then 1389 Config_File_Path := Locate_Config_File (Conf_File_Name.all); 1390 else 1391 Config_File_Path := Locate_Config_File (Default_File_Name); 1392 end if; 1393 1394 if Config_File_Path = null then 1395 if not Allow_Automatic_Generation 1396 and then Conf_File_Name'Length > 0 1397 then 1398 Raise_Invalid_Config 1399 ("could not locate main configuration project " 1400 & Conf_File_Name.all); 1401 end if; 1402 end if; 1403 end if; 1404 1405 Automatically_Generated := 1406 Allow_Automatic_Generation and then Config_File_Path = null; 1407 1408 <<Process_Config_File>> 1409 1410 if Automatically_Generated then 1411 if Hostparm.OpenVMS then 1412 1413 -- There is no gprconfig on VMS 1414 1415 Raise_Invalid_Config 1416 ("could not locate any configuration project file"); 1417 1418 else 1419 -- This might raise an Invalid_Config exception 1420 1421 Do_Autoconf; 1422 end if; 1423 1424 -- If the config file is not auto-generated, warn if there is any --RTS 1425 -- switch, but not when the config file is generated in memory. 1426 1427 elsif RTS_Languages.Get_First /= No_Name 1428 and then Opt.Warning_Mode /= Opt.Suppress 1429 and then On_Load_Config = null 1430 then 1431 Write_Line 1432 ("warning: " & 1433 "--RTS is taken into account only in auto-configuration"); 1434 end if; 1435 1436 -- Parse the configuration file 1437 1438 if Verbose_Mode and then Config_File_Path /= null then 1439 Write_Str ("Checking configuration "); 1440 Write_Line (Config_File_Path.all); 1441 end if; 1442 1443 if Config_File_Path /= null then 1444 Prj.Part.Parse 1445 (In_Tree => Project_Node_Tree, 1446 Project => Config_Project_Node, 1447 Project_File_Name => Config_File_Path.all, 1448 Errout_Handling => Prj.Part.Finalize_If_Error, 1449 Packages_To_Check => Packages_To_Check, 1450 Current_Directory => Current_Directory, 1451 Is_Config_File => True, 1452 Env => Env); 1453 else 1454 Config_Project_Node := Empty_Node; 1455 end if; 1456 1457 if On_Load_Config /= null then 1458 On_Load_Config 1459 (Config_File => Config_Project_Node, 1460 Project_Node_Tree => Project_Node_Tree); 1461 end if; 1462 1463 if Config_Project_Node /= Empty_Node then 1464 Prj.Proc.Process_Project_Tree_Phase_1 1465 (In_Tree => Project_Tree, 1466 Project => Config, 1467 Packages_To_Check => Packages_To_Check, 1468 Success => Success, 1469 From_Project_Node => Config_Project_Node, 1470 From_Project_Node_Tree => Project_Node_Tree, 1471 Env => Env, 1472 Reset_Tree => False, 1473 On_New_Tree_Loaded => null); 1474 end if; 1475 1476 if Config_Project_Node = Empty_Node 1477 or else Config = No_Project 1478 then 1479 Raise_Invalid_Config 1480 ("processing of configuration project """ 1481 & Config_File_Path.all & """ failed"); 1482 end if; 1483 1484 -- Check that the target of the configuration file is the one the user 1485 -- specified on the command line. We do not need to check that when in 1486 -- auto-conf mode, since the appropriate target was passed to gprconfig. 1487 1488 if not Automatically_Generated 1489 and then not 1490 Check_Target 1491 (Config, Autoconf_Specified, Project_Tree, Selected_Target.all) 1492 then 1493 Automatically_Generated := True; 1494 goto Process_Config_File; 1495 end if; 1496 end Get_Or_Create_Configuration_File; 1497 1498 ------------------------ 1499 -- Locate_Config_File -- 1500 ------------------------ 1501 1502 function Locate_Config_File (Name : String) return String_Access is 1503 Prefix_Path : constant String := Executable_Prefix_Path; 1504 begin 1505 if Prefix_Path'Length /= 0 then 1506 return Locate_Regular_File 1507 (Name, 1508 "." & Path_Separator & 1509 Prefix_Path & "share" & Directory_Separator & "gpr"); 1510 else 1511 return Locate_Regular_File (Name, "."); 1512 end if; 1513 end Locate_Config_File; 1514 1515 -------------------- 1516 -- Locate_Runtime -- 1517 -------------------- 1518 1519 procedure Locate_Runtime 1520 (Language : Name_Id; 1521 Project_Tree : Prj.Project_Tree_Ref) 1522 is 1523 function Is_Base_Name (Path : String) return Boolean; 1524 -- Returns True if Path has no directory separator 1525 1526 ------------------ 1527 -- Is_Base_Name -- 1528 ------------------ 1529 1530 function Is_Base_Name (Path : String) return Boolean is 1531 begin 1532 for I in Path'Range loop 1533 if Path (I) = Directory_Separator or else Path (I) = '/' then 1534 return False; 1535 end if; 1536 end loop; 1537 return True; 1538 end Is_Base_Name; 1539 1540 -- Local declarations 1541 1542 function Find_Rts_In_Path is new Prj.Env.Find_Name_In_Path 1543 (Check_Filename => Is_Directory); 1544 1545 RTS_Name : constant String := Runtime_Name_For (Language); 1546 1547 Full_Path : String_Access; 1548 1549 -- Start of processing for Locate_Runtime 1550 1551 begin 1552 if not Is_Base_Name (RTS_Name) then 1553 Full_Path := 1554 Find_Rts_In_Path (Root_Environment.Project_Path, RTS_Name); 1555 1556 if Full_Path = null then 1557 Fail_Program (Project_Tree, "cannot find RTS " & RTS_Name); 1558 end if; 1559 1560 Set_Runtime_For (Language, Normalize_Pathname (Full_Path.all)); 1561 Free (Full_Path); 1562 end if; 1563 end Locate_Runtime; 1564 1565 ------------------------------------ 1566 -- Parse_Project_And_Apply_Config -- 1567 ------------------------------------ 1568 1569 procedure Parse_Project_And_Apply_Config 1570 (Main_Project : out Prj.Project_Id; 1571 User_Project_Node : out Prj.Tree.Project_Node_Id; 1572 Config_File_Name : String := ""; 1573 Autoconf_Specified : Boolean; 1574 Project_File_Name : String; 1575 Project_Tree : Prj.Project_Tree_Ref; 1576 Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref; 1577 Env : in out Prj.Tree.Environment; 1578 Packages_To_Check : String_List_Access; 1579 Allow_Automatic_Generation : Boolean := True; 1580 Automatically_Generated : out Boolean; 1581 Config_File_Path : out String_Access; 1582 Target_Name : String := ""; 1583 Normalized_Hostname : String; 1584 On_Load_Config : Config_File_Hook := null; 1585 Implicit_Project : Boolean := False; 1586 On_New_Tree_Loaded : Prj.Proc.Tree_Loaded_Callback := null) 1587 is 1588 begin 1589 pragma Assert (Prj.Env.Is_Initialized (Env.Project_Path)); 1590 1591 -- Parse the user project tree 1592 1593 Prj.Initialize (Project_Tree); 1594 1595 Main_Project := No_Project; 1596 Automatically_Generated := False; 1597 1598 Prj.Part.Parse 1599 (In_Tree => Project_Node_Tree, 1600 Project => User_Project_Node, 1601 Project_File_Name => Project_File_Name, 1602 Errout_Handling => Prj.Part.Finalize_If_Error, 1603 Packages_To_Check => Packages_To_Check, 1604 Current_Directory => Current_Directory, 1605 Is_Config_File => False, 1606 Env => Env, 1607 Implicit_Project => Implicit_Project); 1608 1609 if User_Project_Node = Empty_Node then 1610 User_Project_Node := Empty_Node; 1611 return; 1612 end if; 1613 1614 Process_Project_And_Apply_Config 1615 (Main_Project => Main_Project, 1616 User_Project_Node => User_Project_Node, 1617 Config_File_Name => Config_File_Name, 1618 Autoconf_Specified => Autoconf_Specified, 1619 Project_Tree => Project_Tree, 1620 Project_Node_Tree => Project_Node_Tree, 1621 Env => Env, 1622 Packages_To_Check => Packages_To_Check, 1623 Allow_Automatic_Generation => Allow_Automatic_Generation, 1624 Automatically_Generated => Automatically_Generated, 1625 Config_File_Path => Config_File_Path, 1626 Target_Name => Target_Name, 1627 Normalized_Hostname => Normalized_Hostname, 1628 On_Load_Config => On_Load_Config, 1629 On_New_Tree_Loaded => On_New_Tree_Loaded); 1630 end Parse_Project_And_Apply_Config; 1631 1632 -------------------------------------- 1633 -- Process_Project_And_Apply_Config -- 1634 -------------------------------------- 1635 1636 procedure Process_Project_And_Apply_Config 1637 (Main_Project : out Prj.Project_Id; 1638 User_Project_Node : Prj.Tree.Project_Node_Id; 1639 Config_File_Name : String := ""; 1640 Autoconf_Specified : Boolean; 1641 Project_Tree : Prj.Project_Tree_Ref; 1642 Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref; 1643 Env : in out Prj.Tree.Environment; 1644 Packages_To_Check : String_List_Access; 1645 Allow_Automatic_Generation : Boolean := True; 1646 Automatically_Generated : out Boolean; 1647 Config_File_Path : out String_Access; 1648 Target_Name : String := ""; 1649 Normalized_Hostname : String; 1650 On_Load_Config : Config_File_Hook := null; 1651 Reset_Tree : Boolean := True; 1652 On_New_Tree_Loaded : Prj.Proc.Tree_Loaded_Callback := null) 1653 is 1654 Shared : constant Shared_Project_Tree_Data_Access := 1655 Project_Tree.Shared; 1656 Main_Config_Project : Project_Id; 1657 Success : Boolean; 1658 1659 Conf_Project : Project_Id := No_Project; 1660 -- The object directory of this project is used to store the config 1661 -- project file in auto-configuration. Set by Check_Project below. 1662 1663 procedure Check_Project (Project : Project_Id); 1664 -- Look for a non aggregate project. If one is found, put its project Id 1665 -- in Conf_Project. 1666 1667 ------------------- 1668 -- Check_Project -- 1669 ------------------- 1670 1671 procedure Check_Project (Project : Project_Id) is 1672 begin 1673 if Project.Qualifier = Aggregate 1674 or else 1675 Project.Qualifier = Aggregate_Library 1676 then 1677 declare 1678 List : Aggregated_Project_List := Project.Aggregated_Projects; 1679 1680 begin 1681 -- Look for a non aggregate project until one is found 1682 1683 while Conf_Project = No_Project and then List /= null loop 1684 Check_Project (List.Project); 1685 List := List.Next; 1686 end loop; 1687 end; 1688 1689 else 1690 Conf_Project := Project; 1691 end if; 1692 end Check_Project; 1693 1694 -- Start of processing for Process_Project_And_Apply_Config 1695 1696 begin 1697 Main_Project := No_Project; 1698 Automatically_Generated := False; 1699 1700 Process_Project_Tree_Phase_1 1701 (In_Tree => Project_Tree, 1702 Project => Main_Project, 1703 Packages_To_Check => Packages_To_Check, 1704 Success => Success, 1705 From_Project_Node => User_Project_Node, 1706 From_Project_Node_Tree => Project_Node_Tree, 1707 Env => Env, 1708 Reset_Tree => Reset_Tree, 1709 On_New_Tree_Loaded => On_New_Tree_Loaded); 1710 1711 if not Success then 1712 Main_Project := No_Project; 1713 return; 1714 end if; 1715 1716 if Project_Tree.Source_Info_File_Name /= null then 1717 if not Is_Absolute_Path (Project_Tree.Source_Info_File_Name.all) then 1718 declare 1719 Obj_Dir : constant Variable_Value := 1720 Value_Of 1721 (Name_Object_Dir, 1722 Main_Project.Decl.Attributes, 1723 Shared); 1724 1725 begin 1726 if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then 1727 Get_Name_String (Main_Project.Directory.Display_Name); 1728 1729 else 1730 if Is_Absolute_Path (Get_Name_String (Obj_Dir.Value)) then 1731 Get_Name_String (Obj_Dir.Value); 1732 1733 else 1734 Name_Len := 0; 1735 Add_Str_To_Name_Buffer 1736 (Get_Name_String (Main_Project.Directory.Display_Name)); 1737 Add_Str_To_Name_Buffer (Get_Name_String (Obj_Dir.Value)); 1738 end if; 1739 end if; 1740 1741 Add_Char_To_Name_Buffer (Directory_Separator); 1742 Add_Str_To_Name_Buffer (Project_Tree.Source_Info_File_Name.all); 1743 Free (Project_Tree.Source_Info_File_Name); 1744 Project_Tree.Source_Info_File_Name := 1745 new String'(Name_Buffer (1 .. Name_Len)); 1746 end; 1747 end if; 1748 1749 Read_Source_Info_File (Project_Tree); 1750 end if; 1751 1752 -- Get the first project that is not an aggregate project or an 1753 -- aggregate library project. The object directory of this project will 1754 -- be used to store the config project file in auto-configuration. 1755 1756 Check_Project (Main_Project); 1757 1758 -- Fail if there is only aggregate projects and aggregate library 1759 -- projects in the project tree. 1760 1761 if Conf_Project = No_Project then 1762 Raise_Invalid_Config ("there are no non-aggregate projects"); 1763 end if; 1764 1765 -- Find configuration file 1766 1767 Get_Or_Create_Configuration_File 1768 (Config => Main_Config_Project, 1769 Project => Main_Project, 1770 Conf_Project => Conf_Project, 1771 Project_Tree => Project_Tree, 1772 Project_Node_Tree => Project_Node_Tree, 1773 Env => Env, 1774 Allow_Automatic_Generation => Allow_Automatic_Generation, 1775 Config_File_Name => Config_File_Name, 1776 Autoconf_Specified => Autoconf_Specified, 1777 Target_Name => Target_Name, 1778 Normalized_Hostname => Normalized_Hostname, 1779 Packages_To_Check => Packages_To_Check, 1780 Config_File_Path => Config_File_Path, 1781 Automatically_Generated => Automatically_Generated, 1782 On_Load_Config => On_Load_Config); 1783 1784 Apply_Config_File (Main_Config_Project, Project_Tree); 1785 1786 -- Finish processing the user's project 1787 1788 Prj.Proc.Process_Project_Tree_Phase_2 1789 (In_Tree => Project_Tree, 1790 Project => Main_Project, 1791 Success => Success, 1792 From_Project_Node => User_Project_Node, 1793 From_Project_Node_Tree => Project_Node_Tree, 1794 Env => Env); 1795 1796 if Success then 1797 if Project_Tree.Source_Info_File_Name /= null 1798 and then not Project_Tree.Source_Info_File_Exists 1799 then 1800 Write_Source_Info_File (Project_Tree); 1801 end if; 1802 1803 else 1804 Main_Project := No_Project; 1805 end if; 1806 end Process_Project_And_Apply_Config; 1807 1808 -------------------------- 1809 -- Raise_Invalid_Config -- 1810 -------------------------- 1811 1812 procedure Raise_Invalid_Config (Msg : String) is 1813 begin 1814 Raise_Exception (Invalid_Config'Identity, Msg); 1815 end Raise_Invalid_Config; 1816 1817 ---------------------- 1818 -- Runtime_Name_For -- 1819 ---------------------- 1820 1821 function Runtime_Name_For (Language : Name_Id) return String is 1822 begin 1823 if RTS_Languages.Get (Language) /= No_Name then 1824 return Get_Name_String (RTS_Languages.Get (Language)); 1825 else 1826 return ""; 1827 end if; 1828 end Runtime_Name_For; 1829 1830 -------------------------- 1831 -- Runtime_Name_Set_For -- 1832 -------------------------- 1833 1834 function Runtime_Name_Set_For (Language : Name_Id) return Boolean is 1835 begin 1836 return RTS_Languages.Get (Language) /= No_Name; 1837 end Runtime_Name_Set_For; 1838 1839 --------------------- 1840 -- Set_Runtime_For -- 1841 --------------------- 1842 1843 procedure Set_Runtime_For (Language : Name_Id; RTS_Name : String) is 1844 begin 1845 Name_Len := RTS_Name'Length; 1846 Name_Buffer (1 .. Name_Len) := RTS_Name; 1847 RTS_Languages.Set (Language, Name_Find); 1848 end Set_Runtime_For; 1849 1850end Prj.Conf; 1851