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