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