1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- P R J . P R O C -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2001-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 Atree; use Atree; 27with Err_Vars; use Err_Vars; 28with Opt; use Opt; 29with Osint; use Osint; 30with Output; use Output; 31with Prj.Attr; use Prj.Attr; 32with Prj.Env; 33with Prj.Err; use Prj.Err; 34with Prj.Ext; use Prj.Ext; 35with Prj.Nmsc; use Prj.Nmsc; 36with Prj.Part; 37with Prj.Util; 38with Snames; 39 40with Ada.Containers.Vectors; 41with Ada.Strings.Fixed; use Ada.Strings.Fixed; 42 43with GNAT.Case_Util; use GNAT.Case_Util; 44with GNAT.HTable; 45 46package body Prj.Proc is 47 48 package Processed_Projects is new GNAT.HTable.Simple_HTable 49 (Header_Num => Header_Num, 50 Element => Project_Id, 51 No_Element => No_Project, 52 Key => Name_Id, 53 Hash => Hash, 54 Equal => "="); 55 -- This hash table contains all processed projects 56 57 package Unit_Htable is new GNAT.HTable.Simple_HTable 58 (Header_Num => Header_Num, 59 Element => Source_Id, 60 No_Element => No_Source, 61 Key => Name_Id, 62 Hash => Hash, 63 Equal => "="); 64 -- This hash table contains all processed projects 65 66 procedure Add (To_Exp : in out Name_Id; Str : Name_Id); 67 -- Concatenate two strings and returns another string if both 68 -- arguments are not null string. 69 70 -- In the following procedures, we are expected to guess the meaning of 71 -- the parameters from their names, this is never a good idea, comments 72 -- should be added precisely defining every formal ??? 73 74 procedure Add_Attributes 75 (Project : Project_Id; 76 Project_Name : Name_Id; 77 Project_Dir : Name_Id; 78 Shared : Shared_Project_Tree_Data_Access; 79 Decl : in out Declarations; 80 First : Attribute_Node_Id; 81 Project_Level : Boolean); 82 -- Add all attributes, starting with First, with their default values to 83 -- the package or project with declarations Decl. 84 85 procedure Check 86 (In_Tree : Project_Tree_Ref; 87 Project : Project_Id; 88 Node_Tree : Prj.Tree.Project_Node_Tree_Ref; 89 Flags : Processing_Flags); 90 -- Set all projects to not checked, then call Recursive_Check for the 91 -- main project Project. Project is set to No_Project if errors occurred. 92 -- Current_Dir is for optimization purposes, avoiding extra system calls. 93 -- If Allow_Duplicate_Basenames, then files with the same base names are 94 -- authorized within a project for source-based languages (never for unit 95 -- based languages) 96 97 procedure Copy_Package_Declarations 98 (From : Declarations; 99 To : in out Declarations; 100 New_Loc : Source_Ptr; 101 Restricted : Boolean; 102 Shared : Shared_Project_Tree_Data_Access); 103 -- Copy a package declaration From to To for a renamed package. Change the 104 -- locations of all the attributes to New_Loc. When Restricted is 105 -- True, do not copy attributes Body, Spec, Implementation, Specification 106 -- and Linker_Options. 107 108 function Expression 109 (Project : Project_Id; 110 Shared : Shared_Project_Tree_Data_Access; 111 From_Project_Node : Project_Node_Id; 112 From_Project_Node_Tree : Project_Node_Tree_Ref; 113 Env : Prj.Tree.Environment; 114 Pkg : Package_Id; 115 First_Term : Project_Node_Id; 116 Kind : Variable_Kind) return Variable_Value; 117 -- From N_Expression project node From_Project_Node, compute the value 118 -- of an expression and return it as a Variable_Value. 119 120 function Imported_Or_Extended_Project_From 121 (Project : Project_Id; 122 With_Name : Name_Id) return Project_Id; 123 -- Find an imported or extended project of Project whose name is With_Name 124 125 function Package_From 126 (Project : Project_Id; 127 Shared : Shared_Project_Tree_Data_Access; 128 With_Name : Name_Id) return Package_Id; 129 -- Find the package of Project whose name is With_Name 130 131 procedure Process_Declarative_Items 132 (Project : Project_Id; 133 In_Tree : Project_Tree_Ref; 134 From_Project_Node : Project_Node_Id; 135 Node_Tree : Project_Node_Tree_Ref; 136 Env : Prj.Tree.Environment; 137 Pkg : Package_Id; 138 Item : Project_Node_Id; 139 Child_Env : in out Prj.Tree.Environment); 140 -- Process declarative items starting with From_Project_Node, and put them 141 -- in declarations Decl. This is a recursive procedure; it calls itself for 142 -- a package declaration or a case construction. 143 -- 144 -- Child_Env is the modified environment after seeing declarations like 145 -- "for External(...) use" or "for Project_Path use" in aggregate projects. 146 -- It should have been initialized first. 147 148 procedure Recursive_Process 149 (In_Tree : Project_Tree_Ref; 150 Project : out Project_Id; 151 Packages_To_Check : String_List_Access; 152 From_Project_Node : Project_Node_Id; 153 From_Project_Node_Tree : Project_Node_Tree_Ref; 154 Env : in out Prj.Tree.Environment; 155 Extended_By : Project_Id; 156 From_Encapsulated_Lib : Boolean; 157 On_New_Tree_Loaded : Tree_Loaded_Callback := null); 158 -- Process project with node From_Project_Node in the tree. Do nothing if 159 -- From_Project_Node is Empty_Node. If project has already been processed, 160 -- simply return its project id. Otherwise create a new project id, mark it 161 -- as processed, call itself recursively for all imported projects and a 162 -- extended project, if any. Then process the declarative items of the 163 -- project. 164 -- 165 -- Is_Root_Project should be true only for the project that the user 166 -- explicitly loaded. In the context of aggregate projects, only that 167 -- project is allowed to modify the environment that will be used to load 168 -- projects (Child_Env). 169 -- 170 -- From_Encapsulated_Lib is true if we are parsing a project from 171 -- encapsulated library dependencies. 172 -- 173 -- If specified, On_New_Tree_Loaded is called after each aggregated project 174 -- has been processed succesfully. 175 176 function Get_Attribute_Index 177 (Tree : Project_Node_Tree_Ref; 178 Attr : Project_Node_Id; 179 Index : Name_Id) return Name_Id; 180 -- Copy the index of the attribute into Name_Buffer, converting to lower 181 -- case if the attribute is case-insensitive. 182 183 --------- 184 -- Add -- 185 --------- 186 187 procedure Add (To_Exp : in out Name_Id; Str : Name_Id) is 188 begin 189 if To_Exp = No_Name or else To_Exp = Empty_String then 190 191 -- To_Exp is nil or empty. The result is Str 192 193 To_Exp := Str; 194 195 -- If Str is nil, then do not change To_Ext 196 197 elsif Str /= No_Name and then Str /= Empty_String then 198 declare 199 S : constant String := Get_Name_String (Str); 200 begin 201 Get_Name_String (To_Exp); 202 Add_Str_To_Name_Buffer (S); 203 To_Exp := Name_Find; 204 end; 205 end if; 206 end Add; 207 208 -------------------- 209 -- Add_Attributes -- 210 -------------------- 211 212 procedure Add_Attributes 213 (Project : Project_Id; 214 Project_Name : Name_Id; 215 Project_Dir : Name_Id; 216 Shared : Shared_Project_Tree_Data_Access; 217 Decl : in out Declarations; 218 First : Attribute_Node_Id; 219 Project_Level : Boolean) 220 is 221 The_Attribute : Attribute_Node_Id := First; 222 223 begin 224 while The_Attribute /= Empty_Attribute loop 225 if Attribute_Kind_Of (The_Attribute) = Single then 226 declare 227 New_Attribute : Variable_Value; 228 229 begin 230 case Variable_Kind_Of (The_Attribute) is 231 232 -- Undefined should not happen 233 234 when Undefined => 235 pragma Assert 236 (False, "attribute with an undefined kind"); 237 raise Program_Error; 238 239 -- Single attributes have a default value of empty string 240 241 when Single => 242 New_Attribute := 243 (Project => Project, 244 Kind => Single, 245 Location => No_Location, 246 Default => True, 247 Value => Empty_String, 248 Index => 0); 249 250 -- Special cases of <project>'Name and 251 -- <project>'Project_Dir. 252 253 if Project_Level then 254 if Attribute_Name_Of (The_Attribute) = 255 Snames.Name_Name 256 then 257 New_Attribute.Value := Project_Name; 258 259 elsif Attribute_Name_Of (The_Attribute) = 260 Snames.Name_Project_Dir 261 then 262 New_Attribute.Value := Project_Dir; 263 end if; 264 end if; 265 266 -- List attributes have a default value of nil list 267 268 when List => 269 New_Attribute := 270 (Project => Project, 271 Kind => List, 272 Location => No_Location, 273 Default => True, 274 Values => Nil_String); 275 276 end case; 277 278 Variable_Element_Table.Increment_Last 279 (Shared.Variable_Elements); 280 Shared.Variable_Elements.Table 281 (Variable_Element_Table.Last (Shared.Variable_Elements)) := 282 (Next => Decl.Attributes, 283 Name => Attribute_Name_Of (The_Attribute), 284 Value => New_Attribute); 285 Decl.Attributes := 286 Variable_Element_Table.Last 287 (Shared.Variable_Elements); 288 end; 289 end if; 290 291 The_Attribute := Next_Attribute (After => The_Attribute); 292 end loop; 293 end Add_Attributes; 294 295 ----------- 296 -- Check -- 297 ----------- 298 299 procedure Check 300 (In_Tree : Project_Tree_Ref; 301 Project : Project_Id; 302 Node_Tree : Prj.Tree.Project_Node_Tree_Ref; 303 Flags : Processing_Flags) 304 is 305 begin 306 Process_Naming_Scheme (In_Tree, Project, Node_Tree, Flags); 307 308 -- Set the Other_Part field for the units 309 310 declare 311 Source1 : Source_Id; 312 Name : Name_Id; 313 Source2 : Source_Id; 314 Iter : Source_Iterator; 315 316 begin 317 Unit_Htable.Reset; 318 319 Iter := For_Each_Source (In_Tree); 320 loop 321 Source1 := Prj.Element (Iter); 322 exit when Source1 = No_Source; 323 324 if Source1.Unit /= No_Unit_Index then 325 Name := Source1.Unit.Name; 326 Source2 := Unit_Htable.Get (Name); 327 328 if Source2 = No_Source then 329 Unit_Htable.Set (K => Name, E => Source1); 330 else 331 Unit_Htable.Remove (Name); 332 end if; 333 end if; 334 335 Next (Iter); 336 end loop; 337 end; 338 end Check; 339 340 ------------------------------- 341 -- Copy_Package_Declarations -- 342 ------------------------------- 343 344 procedure Copy_Package_Declarations 345 (From : Declarations; 346 To : in out Declarations; 347 New_Loc : Source_Ptr; 348 Restricted : Boolean; 349 Shared : Shared_Project_Tree_Data_Access) 350 is 351 V1 : Variable_Id; 352 V2 : Variable_Id := No_Variable; 353 Var : Variable; 354 A1 : Array_Id; 355 A2 : Array_Id := No_Array; 356 Arr : Array_Data; 357 E1 : Array_Element_Id; 358 E2 : Array_Element_Id := No_Array_Element; 359 Elm : Array_Element; 360 361 begin 362 -- To avoid references in error messages to attribute declarations in 363 -- an original package that has been renamed, copy all the attribute 364 -- declarations of the package and change all locations to New_Loc, 365 -- the location of the renamed package. 366 367 -- First single attributes 368 369 V1 := From.Attributes; 370 while V1 /= No_Variable loop 371 372 -- Copy the attribute 373 374 Var := Shared.Variable_Elements.Table (V1); 375 V1 := Var.Next; 376 377 -- Do not copy the value of attribute Linker_Options if Restricted 378 379 if Restricted and then Var.Name = Snames.Name_Linker_Options then 380 Var.Value.Values := Nil_String; 381 end if; 382 383 -- Remove the Next component 384 385 Var.Next := No_Variable; 386 387 -- Change the location to New_Loc 388 389 Var.Value.Location := New_Loc; 390 Variable_Element_Table.Increment_Last (Shared.Variable_Elements); 391 392 -- Put in new declaration 393 394 if To.Attributes = No_Variable then 395 To.Attributes := 396 Variable_Element_Table.Last (Shared.Variable_Elements); 397 else 398 Shared.Variable_Elements.Table (V2).Next := 399 Variable_Element_Table.Last (Shared.Variable_Elements); 400 end if; 401 402 V2 := Variable_Element_Table.Last (Shared.Variable_Elements); 403 Shared.Variable_Elements.Table (V2) := Var; 404 end loop; 405 406 -- Then the associated array attributes 407 408 A1 := From.Arrays; 409 while A1 /= No_Array loop 410 Arr := Shared.Arrays.Table (A1); 411 A1 := Arr.Next; 412 413 -- Remove the Next component 414 415 Arr.Next := No_Array; 416 Array_Table.Increment_Last (Shared.Arrays); 417 418 -- Create new Array declaration 419 420 if To.Arrays = No_Array then 421 To.Arrays := Array_Table.Last (Shared.Arrays); 422 else 423 Shared.Arrays.Table (A2).Next := 424 Array_Table.Last (Shared.Arrays); 425 end if; 426 427 A2 := Array_Table.Last (Shared.Arrays); 428 429 -- Don't store the array as its first element has not been set yet 430 431 -- Copy the array elements of the array 432 433 E1 := Arr.Value; 434 Arr.Value := No_Array_Element; 435 while E1 /= No_Array_Element loop 436 437 -- Copy the array element 438 439 Elm := Shared.Array_Elements.Table (E1); 440 E1 := Elm.Next; 441 442 -- Remove the Next component 443 444 Elm.Next := No_Array_Element; 445 446 Elm.Restricted := Restricted; 447 448 -- Change the location 449 450 Elm.Value.Location := New_Loc; 451 Array_Element_Table.Increment_Last (Shared.Array_Elements); 452 453 -- Create new array element 454 455 if Arr.Value = No_Array_Element then 456 Arr.Value := Array_Element_Table.Last (Shared.Array_Elements); 457 else 458 Shared.Array_Elements.Table (E2).Next := 459 Array_Element_Table.Last (Shared.Array_Elements); 460 end if; 461 462 E2 := Array_Element_Table.Last (Shared.Array_Elements); 463 Shared.Array_Elements.Table (E2) := Elm; 464 end loop; 465 466 -- Finally, store the new array 467 468 Shared.Arrays.Table (A2) := Arr; 469 end loop; 470 end Copy_Package_Declarations; 471 472 ------------------------- 473 -- Get_Attribute_Index -- 474 ------------------------- 475 476 function Get_Attribute_Index 477 (Tree : Project_Node_Tree_Ref; 478 Attr : Project_Node_Id; 479 Index : Name_Id) return Name_Id 480 is 481 begin 482 if Index = All_Other_Names 483 or else not Case_Insensitive (Attr, Tree) 484 then 485 return Index; 486 end if; 487 488 Get_Name_String (Index); 489 To_Lower (Name_Buffer (1 .. Name_Len)); 490 return Name_Find; 491 end Get_Attribute_Index; 492 493 ---------------- 494 -- Expression -- 495 ---------------- 496 497 function Expression 498 (Project : Project_Id; 499 Shared : Shared_Project_Tree_Data_Access; 500 From_Project_Node : Project_Node_Id; 501 From_Project_Node_Tree : Project_Node_Tree_Ref; 502 Env : Prj.Tree.Environment; 503 Pkg : Package_Id; 504 First_Term : Project_Node_Id; 505 Kind : Variable_Kind) return Variable_Value 506 is 507 The_Term : Project_Node_Id; 508 -- The term in the expression list 509 510 The_Current_Term : Project_Node_Id := Empty_Node; 511 -- The current term node id 512 513 Result : Variable_Value (Kind => Kind); 514 -- The returned result 515 516 Last : String_List_Id := Nil_String; 517 -- Reference to the last string elements in Result, when Kind is List 518 519 begin 520 Result.Project := Project; 521 Result.Location := Location_Of (First_Term, From_Project_Node_Tree); 522 523 -- Process each term of the expression, starting with First_Term 524 525 The_Term := First_Term; 526 while Present (The_Term) loop 527 The_Current_Term := Current_Term (The_Term, From_Project_Node_Tree); 528 529 case Kind_Of (The_Current_Term, From_Project_Node_Tree) is 530 531 when N_Literal_String => 532 533 case Kind is 534 535 when Undefined => 536 537 -- Should never happen 538 539 pragma Assert (False, "Undefined expression kind"); 540 raise Program_Error; 541 542 when Single => 543 Add (Result.Value, 544 String_Value_Of 545 (The_Current_Term, From_Project_Node_Tree)); 546 Result.Index := 547 Source_Index_Of 548 (The_Current_Term, From_Project_Node_Tree); 549 550 when List => 551 552 String_Element_Table.Increment_Last 553 (Shared.String_Elements); 554 555 if Last = Nil_String then 556 557 -- This can happen in an expression like () & "toto" 558 559 Result.Values := String_Element_Table.Last 560 (Shared.String_Elements); 561 562 else 563 Shared.String_Elements.Table 564 (Last).Next := String_Element_Table.Last 565 (Shared.String_Elements); 566 end if; 567 568 Last := String_Element_Table.Last 569 (Shared.String_Elements); 570 571 Shared.String_Elements.Table (Last) := 572 (Value => String_Value_Of 573 (The_Current_Term, 574 From_Project_Node_Tree), 575 Index => Source_Index_Of 576 (The_Current_Term, 577 From_Project_Node_Tree), 578 Display_Value => No_Name, 579 Location => Location_Of 580 (The_Current_Term, 581 From_Project_Node_Tree), 582 Flag => False, 583 Next => Nil_String); 584 end case; 585 586 when N_Literal_String_List => 587 588 declare 589 String_Node : Project_Node_Id := 590 First_Expression_In_List 591 (The_Current_Term, 592 From_Project_Node_Tree); 593 594 Value : Variable_Value; 595 596 begin 597 if Present (String_Node) then 598 599 -- If String_Node is nil, it is an empty list, there is 600 -- nothing to do. 601 602 Value := Expression 603 (Project => Project, 604 Shared => Shared, 605 From_Project_Node => From_Project_Node, 606 From_Project_Node_Tree => From_Project_Node_Tree, 607 Env => Env, 608 Pkg => Pkg, 609 First_Term => 610 Tree.First_Term 611 (String_Node, From_Project_Node_Tree), 612 Kind => Single); 613 String_Element_Table.Increment_Last 614 (Shared.String_Elements); 615 616 if Result.Values = Nil_String then 617 618 -- This literal string list is the first term in a 619 -- string list expression 620 621 Result.Values := 622 String_Element_Table.Last 623 (Shared.String_Elements); 624 625 else 626 Shared.String_Elements.Table (Last).Next := 627 String_Element_Table.Last (Shared.String_Elements); 628 end if; 629 630 Last := 631 String_Element_Table.Last (Shared.String_Elements); 632 633 Shared.String_Elements.Table (Last) := 634 (Value => Value.Value, 635 Display_Value => No_Name, 636 Location => Value.Location, 637 Flag => False, 638 Next => Nil_String, 639 Index => Value.Index); 640 641 loop 642 -- Add the other element of the literal string list 643 -- one after the other. 644 645 String_Node := 646 Next_Expression_In_List 647 (String_Node, From_Project_Node_Tree); 648 649 exit when No (String_Node); 650 651 Value := 652 Expression 653 (Project => Project, 654 Shared => Shared, 655 From_Project_Node => From_Project_Node, 656 From_Project_Node_Tree => From_Project_Node_Tree, 657 Env => Env, 658 Pkg => Pkg, 659 First_Term => 660 Tree.First_Term 661 (String_Node, From_Project_Node_Tree), 662 Kind => Single); 663 664 String_Element_Table.Increment_Last 665 (Shared.String_Elements); 666 Shared.String_Elements.Table (Last).Next := 667 String_Element_Table.Last (Shared.String_Elements); 668 Last := String_Element_Table.Last 669 (Shared.String_Elements); 670 Shared.String_Elements.Table (Last) := 671 (Value => Value.Value, 672 Display_Value => No_Name, 673 Location => Value.Location, 674 Flag => False, 675 Next => Nil_String, 676 Index => Value.Index); 677 end loop; 678 end if; 679 end; 680 681 when N_Variable_Reference | N_Attribute_Reference => 682 683 declare 684 The_Project : Project_Id := Project; 685 The_Package : Package_Id := Pkg; 686 The_Name : Name_Id := No_Name; 687 The_Variable_Id : Variable_Id := No_Variable; 688 The_Variable : Variable_Value; 689 Term_Project : constant Project_Node_Id := 690 Project_Node_Of 691 (The_Current_Term, 692 From_Project_Node_Tree); 693 Term_Package : constant Project_Node_Id := 694 Package_Node_Of 695 (The_Current_Term, 696 From_Project_Node_Tree); 697 Index : Name_Id := No_Name; 698 699 begin 700 if Present (Term_Project) 701 and then Term_Project /= From_Project_Node 702 then 703 -- This variable or attribute comes from another project 704 705 The_Name := 706 Name_Of (Term_Project, From_Project_Node_Tree); 707 The_Project := Imported_Or_Extended_Project_From 708 (Project => Project, 709 With_Name => The_Name); 710 end if; 711 712 if Present (Term_Package) then 713 714 -- This is an attribute of a package 715 716 The_Name := 717 Name_Of (Term_Package, From_Project_Node_Tree); 718 719 The_Package := The_Project.Decl.Packages; 720 while The_Package /= No_Package 721 and then Shared.Packages.Table (The_Package).Name /= 722 The_Name 723 loop 724 The_Package := 725 Shared.Packages.Table (The_Package).Next; 726 end loop; 727 728 pragma Assert 729 (The_Package /= No_Package, "package not found."); 730 731 elsif Kind_Of (The_Current_Term, From_Project_Node_Tree) = 732 N_Attribute_Reference 733 then 734 The_Package := No_Package; 735 end if; 736 737 The_Name := 738 Name_Of (The_Current_Term, From_Project_Node_Tree); 739 740 if Kind_Of (The_Current_Term, From_Project_Node_Tree) = 741 N_Attribute_Reference 742 then 743 Index := 744 Associative_Array_Index_Of 745 (The_Current_Term, From_Project_Node_Tree); 746 end if; 747 748 -- If it is not an associative array attribute 749 750 if Index = No_Name then 751 752 -- It is not an associative array attribute 753 754 if The_Package /= No_Package then 755 756 -- First, if there is a package, look into the package 757 758 if Kind_Of (The_Current_Term, From_Project_Node_Tree) = 759 N_Variable_Reference 760 then 761 The_Variable_Id := 762 Shared.Packages.Table 763 (The_Package).Decl.Variables; 764 else 765 The_Variable_Id := 766 Shared.Packages.Table 767 (The_Package).Decl.Attributes; 768 end if; 769 770 while The_Variable_Id /= No_Variable 771 and then Shared.Variable_Elements.Table 772 (The_Variable_Id).Name /= The_Name 773 loop 774 The_Variable_Id := 775 Shared.Variable_Elements.Table 776 (The_Variable_Id).Next; 777 end loop; 778 779 end if; 780 781 if The_Variable_Id = No_Variable then 782 783 -- If we have not found it, look into the project 784 785 if Kind_Of (The_Current_Term, From_Project_Node_Tree) = 786 N_Variable_Reference 787 then 788 The_Variable_Id := The_Project.Decl.Variables; 789 else 790 The_Variable_Id := The_Project.Decl.Attributes; 791 end if; 792 793 while The_Variable_Id /= No_Variable 794 and then Shared.Variable_Elements.Table 795 (The_Variable_Id).Name /= The_Name 796 loop 797 The_Variable_Id := 798 Shared.Variable_Elements.Table 799 (The_Variable_Id).Next; 800 end loop; 801 802 end if; 803 804 pragma Assert (The_Variable_Id /= No_Variable, 805 "variable or attribute not found"); 806 807 The_Variable := 808 Shared.Variable_Elements.Table (The_Variable_Id).Value; 809 810 else 811 812 -- It is an associative array attribute 813 814 declare 815 The_Array : Array_Id := No_Array; 816 The_Element : Array_Element_Id := No_Array_Element; 817 Array_Index : Name_Id := No_Name; 818 819 begin 820 if The_Package /= No_Package then 821 The_Array := 822 Shared.Packages.Table (The_Package).Decl.Arrays; 823 else 824 The_Array := The_Project.Decl.Arrays; 825 end if; 826 827 while The_Array /= No_Array 828 and then Shared.Arrays.Table (The_Array).Name /= 829 The_Name 830 loop 831 The_Array := Shared.Arrays.Table (The_Array).Next; 832 end loop; 833 834 if The_Array /= No_Array then 835 The_Element := 836 Shared.Arrays.Table (The_Array).Value; 837 Array_Index := 838 Get_Attribute_Index 839 (From_Project_Node_Tree, 840 The_Current_Term, 841 Index); 842 843 while The_Element /= No_Array_Element 844 and then Shared.Array_Elements.Table 845 (The_Element).Index /= Array_Index 846 loop 847 The_Element := 848 Shared.Array_Elements.Table (The_Element).Next; 849 end loop; 850 851 end if; 852 853 if The_Element /= No_Array_Element then 854 The_Variable := 855 Shared.Array_Elements.Table (The_Element).Value; 856 857 else 858 if Expression_Kind_Of 859 (The_Current_Term, From_Project_Node_Tree) = 860 List 861 then 862 The_Variable := 863 (Project => Project, 864 Kind => List, 865 Location => No_Location, 866 Default => True, 867 Values => Nil_String); 868 else 869 The_Variable := 870 (Project => Project, 871 Kind => Single, 872 Location => No_Location, 873 Default => True, 874 Value => Empty_String, 875 Index => 0); 876 end if; 877 end if; 878 end; 879 end if; 880 881 case Kind is 882 883 when Undefined => 884 885 -- Should never happen 886 887 pragma Assert (False, "undefined expression kind"); 888 null; 889 890 when Single => 891 892 case The_Variable.Kind is 893 894 when Undefined => 895 null; 896 897 when Single => 898 Add (Result.Value, The_Variable.Value); 899 900 when List => 901 902 -- Should never happen 903 904 pragma Assert 905 (False, 906 "list cannot appear in single " & 907 "string expression"); 908 null; 909 end case; 910 911 when List => 912 case The_Variable.Kind is 913 914 when Undefined => 915 null; 916 917 when Single => 918 String_Element_Table.Increment_Last 919 (Shared.String_Elements); 920 921 if Last = Nil_String then 922 923 -- This can happen in an expression such as 924 -- () & Var 925 926 Result.Values := 927 String_Element_Table.Last 928 (Shared.String_Elements); 929 930 else 931 Shared.String_Elements.Table (Last).Next := 932 String_Element_Table.Last 933 (Shared.String_Elements); 934 end if; 935 936 Last := 937 String_Element_Table.Last 938 (Shared.String_Elements); 939 940 Shared.String_Elements.Table (Last) := 941 (Value => The_Variable.Value, 942 Display_Value => No_Name, 943 Location => Location_Of 944 (The_Current_Term, 945 From_Project_Node_Tree), 946 Flag => False, 947 Next => Nil_String, 948 Index => 0); 949 950 when List => 951 952 declare 953 The_List : String_List_Id := 954 The_Variable.Values; 955 956 begin 957 while The_List /= Nil_String loop 958 String_Element_Table.Increment_Last 959 (Shared.String_Elements); 960 961 if Last = Nil_String then 962 Result.Values := 963 String_Element_Table.Last 964 (Shared.String_Elements); 965 966 else 967 Shared. 968 String_Elements.Table (Last).Next := 969 String_Element_Table.Last 970 (Shared.String_Elements); 971 972 end if; 973 974 Last := 975 String_Element_Table.Last 976 (Shared.String_Elements); 977 978 Shared.String_Elements.Table 979 (Last) := 980 (Value => 981 Shared.String_Elements.Table 982 (The_List).Value, 983 Display_Value => No_Name, 984 Location => 985 Location_Of 986 (The_Current_Term, 987 From_Project_Node_Tree), 988 Flag => False, 989 Next => Nil_String, 990 Index => 0); 991 992 The_List := Shared.String_Elements.Table 993 (The_List).Next; 994 end loop; 995 end; 996 end case; 997 end case; 998 end; 999 1000 when N_External_Value => 1001 Get_Name_String 1002 (String_Value_Of 1003 (External_Reference_Of 1004 (The_Current_Term, From_Project_Node_Tree), 1005 From_Project_Node_Tree)); 1006 1007 declare 1008 Name : constant Name_Id := Name_Find; 1009 Default : Name_Id := No_Name; 1010 Value : Name_Id := No_Name; 1011 Ext_List : Boolean := False; 1012 Str_List : String_List_Access := null; 1013 Def_Var : Variable_Value; 1014 1015 Default_Node : constant Project_Node_Id := 1016 External_Default_Of 1017 (The_Current_Term, 1018 From_Project_Node_Tree); 1019 1020 begin 1021 -- If there is a default value for the external reference, 1022 -- get its value. 1023 1024 if Present (Default_Node) then 1025 Def_Var := Expression 1026 (Project => Project, 1027 Shared => Shared, 1028 From_Project_Node => From_Project_Node, 1029 From_Project_Node_Tree => From_Project_Node_Tree, 1030 Env => Env, 1031 Pkg => Pkg, 1032 First_Term => 1033 Tree.First_Term 1034 (Default_Node, From_Project_Node_Tree), 1035 Kind => Single); 1036 1037 if Def_Var /= Nil_Variable_Value then 1038 Default := Def_Var.Value; 1039 end if; 1040 end if; 1041 1042 Ext_List := Expression_Kind_Of 1043 (The_Current_Term, 1044 From_Project_Node_Tree) = List; 1045 1046 if Ext_List then 1047 Value := Prj.Ext.Value_Of (Env.External, Name, No_Name); 1048 1049 if Value /= No_Name then 1050 declare 1051 Sep : constant String := 1052 Get_Name_String (Default); 1053 First : Positive := 1; 1054 Lst : Natural; 1055 Done : Boolean := False; 1056 Nmb : Natural; 1057 1058 begin 1059 Get_Name_String (Value); 1060 1061 if Name_Len = 0 1062 or else Sep'Length = 0 1063 or else Name_Buffer (1 .. Name_Len) = Sep 1064 then 1065 Done := True; 1066 end if; 1067 1068 if not Done and then Name_Len < Sep'Length then 1069 Str_List := 1070 new String_List' 1071 (1 => new String' 1072 (Name_Buffer (1 .. Name_Len))); 1073 Done := True; 1074 end if; 1075 1076 if not Done then 1077 if Name_Buffer (1 .. Sep'Length) = Sep then 1078 First := Sep'Length + 1; 1079 end if; 1080 1081 if Name_Len - First + 1 >= Sep'Length 1082 and then 1083 Name_Buffer (Name_Len - Sep'Length + 1 .. 1084 Name_Len) = Sep 1085 then 1086 Name_Len := Name_Len - Sep'Length; 1087 end if; 1088 1089 if Name_Len = 0 then 1090 Str_List := 1091 new String_List'(1 => new String'("")); 1092 Done := True; 1093 end if; 1094 end if; 1095 1096 if not Done then 1097 1098 -- Count the number of strings 1099 1100 declare 1101 Saved : constant Positive := First; 1102 1103 begin 1104 Nmb := 1; 1105 loop 1106 Lst := 1107 Index 1108 (Source => 1109 Name_Buffer (First .. Name_Len), 1110 Pattern => Sep); 1111 exit when Lst = 0; 1112 Nmb := Nmb + 1; 1113 First := Lst + Sep'Length; 1114 end loop; 1115 1116 First := Saved; 1117 end; 1118 1119 Str_List := new String_List (1 .. Nmb); 1120 1121 -- Populate the string list 1122 1123 Nmb := 1; 1124 loop 1125 Lst := 1126 Index 1127 (Source => 1128 Name_Buffer (First .. Name_Len), 1129 Pattern => Sep); 1130 1131 if Lst = 0 then 1132 Str_List (Nmb) := 1133 new String' 1134 (Name_Buffer (First .. Name_Len)); 1135 exit; 1136 1137 else 1138 Str_List (Nmb) := 1139 new String' 1140 (Name_Buffer (First .. Lst - 1)); 1141 Nmb := Nmb + 1; 1142 First := Lst + Sep'Length; 1143 end if; 1144 end loop; 1145 end if; 1146 end; 1147 end if; 1148 1149 else 1150 -- Get the value 1151 1152 Value := Prj.Ext.Value_Of (Env.External, Name, Default); 1153 1154 if Value = No_Name then 1155 if not Quiet_Output then 1156 Error_Msg 1157 (Env.Flags, "?undefined external reference", 1158 Location_Of 1159 (The_Current_Term, From_Project_Node_Tree), 1160 Project); 1161 end if; 1162 1163 Value := Empty_String; 1164 end if; 1165 end if; 1166 1167 case Kind is 1168 1169 when Undefined => 1170 null; 1171 1172 when Single => 1173 if Ext_List then 1174 null; -- error 1175 1176 else 1177 Add (Result.Value, Value); 1178 end if; 1179 1180 when List => 1181 if not Ext_List or else Str_List /= null then 1182 String_Element_Table.Increment_Last 1183 (Shared.String_Elements); 1184 1185 if Last = Nil_String then 1186 Result.Values := 1187 String_Element_Table.Last 1188 (Shared.String_Elements); 1189 1190 else 1191 Shared.String_Elements.Table (Last).Next 1192 := String_Element_Table.Last 1193 (Shared.String_Elements); 1194 end if; 1195 1196 Last := String_Element_Table.Last 1197 (Shared.String_Elements); 1198 1199 if Ext_List then 1200 for Ind in Str_List'Range loop 1201 Name_Len := 0; 1202 Add_Str_To_Name_Buffer (Str_List (Ind).all); 1203 Value := Name_Find; 1204 Shared.String_Elements.Table (Last) := 1205 (Value => Value, 1206 Display_Value => No_Name, 1207 Location => 1208 Location_Of 1209 (The_Current_Term, 1210 From_Project_Node_Tree), 1211 Flag => False, 1212 Next => Nil_String, 1213 Index => 0); 1214 1215 if Ind /= Str_List'Last then 1216 String_Element_Table.Increment_Last 1217 (Shared.String_Elements); 1218 Shared.String_Elements.Table (Last).Next := 1219 String_Element_Table.Last 1220 (Shared.String_Elements); 1221 Last := String_Element_Table.Last 1222 (Shared.String_Elements); 1223 end if; 1224 end loop; 1225 1226 else 1227 Shared.String_Elements.Table (Last) := 1228 (Value => Value, 1229 Display_Value => No_Name, 1230 Location => 1231 Location_Of 1232 (The_Current_Term, 1233 From_Project_Node_Tree), 1234 Flag => False, 1235 Next => Nil_String, 1236 Index => 0); 1237 end if; 1238 end if; 1239 end case; 1240 end; 1241 1242 when others => 1243 1244 -- Should never happen 1245 1246 pragma Assert 1247 (False, 1248 "illegal node kind in an expression"); 1249 raise Program_Error; 1250 1251 end case; 1252 1253 The_Term := Next_Term (The_Term, From_Project_Node_Tree); 1254 end loop; 1255 1256 return Result; 1257 end Expression; 1258 1259 --------------------------------------- 1260 -- Imported_Or_Extended_Project_From -- 1261 --------------------------------------- 1262 1263 function Imported_Or_Extended_Project_From 1264 (Project : Project_Id; 1265 With_Name : Name_Id) return Project_Id 1266 is 1267 List : Project_List; 1268 Result : Project_Id; 1269 Temp_Result : Project_Id; 1270 1271 begin 1272 -- First check if it is the name of an extended project 1273 1274 Result := Project.Extends; 1275 while Result /= No_Project loop 1276 if Result.Name = With_Name then 1277 return Result; 1278 else 1279 Result := Result.Extends; 1280 end if; 1281 end loop; 1282 1283 -- Then check the name of each imported project 1284 1285 Temp_Result := No_Project; 1286 List := Project.Imported_Projects; 1287 while List /= null loop 1288 Result := List.Project; 1289 1290 -- If the project is directly imported, then returns its ID 1291 1292 if Result.Name = With_Name then 1293 return Result; 1294 end if; 1295 1296 -- If a project extending the project is imported, then keep this 1297 -- extending project as a possibility. It will be the returned ID 1298 -- if the project is not imported directly. 1299 1300 declare 1301 Proj : Project_Id; 1302 1303 begin 1304 Proj := Result.Extends; 1305 while Proj /= No_Project loop 1306 if Proj.Name = With_Name then 1307 Temp_Result := Result; 1308 exit; 1309 end if; 1310 1311 Proj := Proj.Extends; 1312 end loop; 1313 end; 1314 1315 List := List.Next; 1316 end loop; 1317 1318 pragma Assert (Temp_Result /= No_Project, "project not found"); 1319 return Temp_Result; 1320 end Imported_Or_Extended_Project_From; 1321 1322 ------------------ 1323 -- Package_From -- 1324 ------------------ 1325 1326 function Package_From 1327 (Project : Project_Id; 1328 Shared : Shared_Project_Tree_Data_Access; 1329 With_Name : Name_Id) return Package_Id 1330 is 1331 Result : Package_Id := Project.Decl.Packages; 1332 1333 begin 1334 -- Check the name of each existing package of Project 1335 1336 while Result /= No_Package 1337 and then Shared.Packages.Table (Result).Name /= With_Name 1338 loop 1339 Result := Shared.Packages.Table (Result).Next; 1340 end loop; 1341 1342 if Result = No_Package then 1343 1344 -- Should never happen 1345 1346 Write_Line 1347 ("package """ & Get_Name_String (With_Name) & """ not found"); 1348 raise Program_Error; 1349 1350 else 1351 return Result; 1352 end if; 1353 end Package_From; 1354 1355 ------------- 1356 -- Process -- 1357 ------------- 1358 1359 procedure Process 1360 (In_Tree : Project_Tree_Ref; 1361 Project : out Project_Id; 1362 Packages_To_Check : String_List_Access; 1363 Success : out Boolean; 1364 From_Project_Node : Project_Node_Id; 1365 From_Project_Node_Tree : Project_Node_Tree_Ref; 1366 Env : in out Prj.Tree.Environment; 1367 Reset_Tree : Boolean := True; 1368 On_New_Tree_Loaded : Tree_Loaded_Callback := null) 1369 is 1370 begin 1371 Process_Project_Tree_Phase_1 1372 (In_Tree => In_Tree, 1373 Project => Project, 1374 Success => Success, 1375 From_Project_Node => From_Project_Node, 1376 From_Project_Node_Tree => From_Project_Node_Tree, 1377 Env => Env, 1378 Packages_To_Check => Packages_To_Check, 1379 Reset_Tree => Reset_Tree, 1380 On_New_Tree_Loaded => On_New_Tree_Loaded); 1381 1382 if Project_Qualifier_Of 1383 (From_Project_Node, From_Project_Node_Tree) /= Configuration 1384 then 1385 Process_Project_Tree_Phase_2 1386 (In_Tree => In_Tree, 1387 Project => Project, 1388 Success => Success, 1389 From_Project_Node => From_Project_Node, 1390 From_Project_Node_Tree => From_Project_Node_Tree, 1391 Env => Env); 1392 end if; 1393 end Process; 1394 1395 ------------------------------- 1396 -- Process_Declarative_Items -- 1397 ------------------------------- 1398 1399 procedure Process_Declarative_Items 1400 (Project : Project_Id; 1401 In_Tree : Project_Tree_Ref; 1402 From_Project_Node : Project_Node_Id; 1403 Node_Tree : Project_Node_Tree_Ref; 1404 Env : Prj.Tree.Environment; 1405 Pkg : Package_Id; 1406 Item : Project_Node_Id; 1407 Child_Env : in out Prj.Tree.Environment) 1408 is 1409 Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared; 1410 1411 procedure Check_Or_Set_Typed_Variable 1412 (Value : in out Variable_Value; 1413 Declaration : Project_Node_Id); 1414 -- Check whether Value is valid for this typed variable declaration. If 1415 -- it is an error, the behavior depends on the flags: either an error is 1416 -- reported, or a warning, or nothing. In the last two cases, the value 1417 -- of the variable is set to a valid value, replacing Value. 1418 1419 procedure Process_Package_Declaration 1420 (Current_Item : Project_Node_Id); 1421 procedure Process_Attribute_Declaration 1422 (Current : Project_Node_Id); 1423 procedure Process_Case_Construction 1424 (Current_Item : Project_Node_Id); 1425 procedure Process_Associative_Array 1426 (Current_Item : Project_Node_Id); 1427 procedure Process_Expression 1428 (Current : Project_Node_Id); 1429 procedure Process_Expression_For_Associative_Array 1430 (Current : Project_Node_Id; 1431 New_Value : Variable_Value); 1432 procedure Process_Expression_Variable_Decl 1433 (Current_Item : Project_Node_Id; 1434 New_Value : Variable_Value); 1435 -- Process the various declarative items 1436 1437 --------------------------------- 1438 -- Check_Or_Set_Typed_Variable -- 1439 --------------------------------- 1440 1441 procedure Check_Or_Set_Typed_Variable 1442 (Value : in out Variable_Value; 1443 Declaration : Project_Node_Id) 1444 is 1445 Loc : constant Source_Ptr := Location_Of (Declaration, Node_Tree); 1446 1447 Reset_Value : Boolean := False; 1448 Current_String : Project_Node_Id; 1449 1450 begin 1451 -- Report an error for an empty string 1452 1453 if Value.Value = Empty_String then 1454 Error_Msg_Name_1 := Name_Of (Declaration, Node_Tree); 1455 1456 case Env.Flags.Allow_Invalid_External is 1457 when Error => 1458 Error_Msg 1459 (Env.Flags, "no value defined for %%", Loc, Project); 1460 when Warning => 1461 Reset_Value := True; 1462 Error_Msg 1463 (Env.Flags, "?no value defined for %%", Loc, Project); 1464 when Silent => 1465 Reset_Value := True; 1466 end case; 1467 1468 else 1469 -- Loop through all the valid strings for the 1470 -- string type and compare to the string value. 1471 1472 Current_String := 1473 First_Literal_String 1474 (String_Type_Of (Declaration, Node_Tree), Node_Tree); 1475 1476 while Present (Current_String) 1477 and then 1478 String_Value_Of (Current_String, Node_Tree) /= Value.Value 1479 loop 1480 Current_String := 1481 Next_Literal_String (Current_String, Node_Tree); 1482 end loop; 1483 1484 -- Report error if string value is not one for the string type 1485 1486 if No (Current_String) then 1487 Error_Msg_Name_1 := Value.Value; 1488 Error_Msg_Name_2 := Name_Of (Declaration, Node_Tree); 1489 1490 case Env.Flags.Allow_Invalid_External is 1491 when Error => 1492 Error_Msg 1493 (Env.Flags, "value %% is illegal for typed string %%", 1494 Loc, Project); 1495 1496 when Warning => 1497 Error_Msg 1498 (Env.Flags, "?value %% is illegal for typed string %%", 1499 Loc, Project); 1500 Reset_Value := True; 1501 1502 when Silent => 1503 Reset_Value := True; 1504 end case; 1505 end if; 1506 end if; 1507 1508 if Reset_Value then 1509 Current_String := 1510 First_Literal_String 1511 (String_Type_Of (Declaration, Node_Tree), Node_Tree); 1512 Value.Value := String_Value_Of (Current_String, Node_Tree); 1513 end if; 1514 end Check_Or_Set_Typed_Variable; 1515 1516 --------------------------------- 1517 -- Process_Package_Declaration -- 1518 --------------------------------- 1519 1520 procedure Process_Package_Declaration 1521 (Current_Item : Project_Node_Id) 1522 is 1523 begin 1524 -- Do not process a package declaration that should be ignored 1525 1526 if Expression_Kind_Of (Current_Item, Node_Tree) /= Ignored then 1527 1528 -- Create the new package 1529 1530 Package_Table.Increment_Last (Shared.Packages); 1531 1532 declare 1533 New_Pkg : constant Package_Id := 1534 Package_Table.Last (Shared.Packages); 1535 The_New_Package : Package_Element; 1536 1537 Project_Of_Renamed_Package : constant Project_Node_Id := 1538 Project_Of_Renamed_Package_Of 1539 (Current_Item, Node_Tree); 1540 1541 begin 1542 -- Set the name of the new package 1543 1544 The_New_Package.Name := Name_Of (Current_Item, Node_Tree); 1545 1546 -- Insert the new package in the appropriate list 1547 1548 if Pkg /= No_Package then 1549 The_New_Package.Next := 1550 Shared.Packages.Table (Pkg).Decl.Packages; 1551 Shared.Packages.Table (Pkg).Decl.Packages := New_Pkg; 1552 1553 else 1554 The_New_Package.Next := Project.Decl.Packages; 1555 Project.Decl.Packages := New_Pkg; 1556 end if; 1557 1558 Shared.Packages.Table (New_Pkg) := The_New_Package; 1559 1560 if Present (Project_Of_Renamed_Package) then 1561 1562 -- Renamed or extending package 1563 1564 declare 1565 Project_Name : constant Name_Id := 1566 Name_Of (Project_Of_Renamed_Package, 1567 Node_Tree); 1568 1569 Renamed_Project : constant Project_Id := 1570 Imported_Or_Extended_Project_From 1571 (Project, Project_Name); 1572 1573 Renamed_Package : constant Package_Id := 1574 Package_From 1575 (Renamed_Project, Shared, 1576 Name_Of (Current_Item, Node_Tree)); 1577 1578 begin 1579 -- For a renamed package, copy the declarations of the 1580 -- renamed package, but set all the locations to the 1581 -- location of the package name in the renaming 1582 -- declaration. 1583 1584 Copy_Package_Declarations 1585 (From => Shared.Packages.Table 1586 (Renamed_Package).Decl, 1587 To => Shared.Packages.Table (New_Pkg).Decl, 1588 New_Loc => Location_Of (Current_Item, Node_Tree), 1589 Restricted => False, 1590 Shared => Shared); 1591 end; 1592 1593 else 1594 -- Set the default values of the attributes 1595 1596 Add_Attributes 1597 (Project, 1598 Project.Name, 1599 Name_Id (Project.Directory.Display_Name), 1600 Shared, 1601 Shared.Packages.Table (New_Pkg).Decl, 1602 First_Attribute_Of 1603 (Package_Id_Of (Current_Item, Node_Tree)), 1604 Project_Level => False); 1605 end if; 1606 1607 -- Process declarative items (nothing to do when the package is 1608 -- renaming, as the first declarative item is null). 1609 1610 Process_Declarative_Items 1611 (Project => Project, 1612 In_Tree => In_Tree, 1613 From_Project_Node => From_Project_Node, 1614 Node_Tree => Node_Tree, 1615 Env => Env, 1616 Pkg => New_Pkg, 1617 Item => 1618 First_Declarative_Item_Of (Current_Item, Node_Tree), 1619 Child_Env => Child_Env); 1620 end; 1621 end if; 1622 end Process_Package_Declaration; 1623 1624 ------------------------------- 1625 -- Process_Associative_Array -- 1626 ------------------------------- 1627 1628 procedure Process_Associative_Array 1629 (Current_Item : Project_Node_Id) 1630 is 1631 Current_Item_Name : constant Name_Id := 1632 Name_Of (Current_Item, Node_Tree); 1633 -- The name of the attribute 1634 1635 Current_Location : constant Source_Ptr := 1636 Location_Of (Current_Item, Node_Tree); 1637 1638 New_Array : Array_Id; 1639 -- The new associative array created 1640 1641 Orig_Array : Array_Id; 1642 -- The associative array value 1643 1644 Orig_Project_Name : Name_Id := No_Name; 1645 -- The name of the project where the associative array 1646 -- value is. 1647 1648 Orig_Project : Project_Id := No_Project; 1649 -- The id of the project where the associative array 1650 -- value is. 1651 1652 Orig_Package_Name : Name_Id := No_Name; 1653 -- The name of the package, if any, where the associative array value 1654 -- is located. 1655 1656 Orig_Package : Package_Id := No_Package; 1657 -- The id of the package, if any, where the associative array value 1658 -- is located. 1659 1660 New_Element : Array_Element_Id := No_Array_Element; 1661 -- Id of a new array element created 1662 1663 Prev_Element : Array_Element_Id := No_Array_Element; 1664 -- Last new element id created 1665 1666 Orig_Element : Array_Element_Id := No_Array_Element; 1667 -- Current array element in original associative array 1668 1669 Next_Element : Array_Element_Id := No_Array_Element; 1670 -- Id of the array element that follows the new element. This is not 1671 -- always nil, because values for the associative array attribute may 1672 -- already have been declared, and the array elements declared are 1673 -- reused. 1674 1675 Prj : Project_List; 1676 1677 begin 1678 -- First find if the associative array attribute already has elements 1679 -- declared. 1680 1681 if Pkg /= No_Package then 1682 New_Array := Shared.Packages.Table (Pkg).Decl.Arrays; 1683 else 1684 New_Array := Project.Decl.Arrays; 1685 end if; 1686 1687 while New_Array /= No_Array 1688 and then Shared.Arrays.Table (New_Array).Name /= Current_Item_Name 1689 loop 1690 New_Array := Shared.Arrays.Table (New_Array).Next; 1691 end loop; 1692 1693 -- If the attribute has never been declared add new entry in the 1694 -- arrays of the project/package and link it. 1695 1696 if New_Array = No_Array then 1697 Array_Table.Increment_Last (Shared.Arrays); 1698 New_Array := Array_Table.Last (Shared.Arrays); 1699 1700 if Pkg /= No_Package then 1701 Shared.Arrays.Table (New_Array) := 1702 (Name => Current_Item_Name, 1703 Location => Current_Location, 1704 Value => No_Array_Element, 1705 Next => Shared.Packages.Table (Pkg).Decl.Arrays); 1706 1707 Shared.Packages.Table (Pkg).Decl.Arrays := New_Array; 1708 1709 else 1710 Shared.Arrays.Table (New_Array) := 1711 (Name => Current_Item_Name, 1712 Location => Current_Location, 1713 Value => No_Array_Element, 1714 Next => Project.Decl.Arrays); 1715 1716 Project.Decl.Arrays := New_Array; 1717 end if; 1718 end if; 1719 1720 -- Find the project where the value is declared 1721 1722 Orig_Project_Name := 1723 Name_Of 1724 (Associative_Project_Of (Current_Item, Node_Tree), Node_Tree); 1725 1726 Prj := In_Tree.Projects; 1727 while Prj /= null loop 1728 if Prj.Project.Name = Orig_Project_Name then 1729 Orig_Project := Prj.Project; 1730 exit; 1731 end if; 1732 Prj := Prj.Next; 1733 end loop; 1734 1735 pragma Assert (Orig_Project /= No_Project, 1736 "original project not found"); 1737 1738 if No (Associative_Package_Of (Current_Item, Node_Tree)) then 1739 Orig_Array := Orig_Project.Decl.Arrays; 1740 1741 else 1742 -- If in a package, find the package where the value is declared 1743 1744 Orig_Package_Name := 1745 Name_Of 1746 (Associative_Package_Of (Current_Item, Node_Tree), Node_Tree); 1747 1748 Orig_Package := Orig_Project.Decl.Packages; 1749 pragma Assert (Orig_Package /= No_Package, 1750 "original package not found"); 1751 1752 while Shared.Packages.Table 1753 (Orig_Package).Name /= Orig_Package_Name 1754 loop 1755 Orig_Package := Shared.Packages.Table (Orig_Package).Next; 1756 pragma Assert (Orig_Package /= No_Package, 1757 "original package not found"); 1758 end loop; 1759 1760 Orig_Array := Shared.Packages.Table (Orig_Package).Decl.Arrays; 1761 end if; 1762 1763 -- Now look for the array 1764 1765 while Orig_Array /= No_Array 1766 and then Shared.Arrays.Table (Orig_Array).Name /= Current_Item_Name 1767 loop 1768 Orig_Array := Shared.Arrays.Table (Orig_Array).Next; 1769 end loop; 1770 1771 if Orig_Array = No_Array then 1772 Error_Msg 1773 (Env.Flags, 1774 "associative array value not found", 1775 Location_Of (Current_Item, Node_Tree), 1776 Project); 1777 1778 else 1779 Orig_Element := Shared.Arrays.Table (Orig_Array).Value; 1780 1781 -- Copy each array element 1782 1783 while Orig_Element /= No_Array_Element loop 1784 1785 -- Case of first element 1786 1787 if Prev_Element = No_Array_Element then 1788 1789 -- And there is no array element declared yet, create a new 1790 -- first array element. 1791 1792 if Shared.Arrays.Table (New_Array).Value = 1793 No_Array_Element 1794 then 1795 Array_Element_Table.Increment_Last 1796 (Shared.Array_Elements); 1797 New_Element := Array_Element_Table.Last 1798 (Shared.Array_Elements); 1799 Shared.Arrays.Table (New_Array).Value := New_Element; 1800 Next_Element := No_Array_Element; 1801 1802 -- Otherwise, the new element is the first 1803 1804 else 1805 New_Element := Shared.Arrays.Table (New_Array).Value; 1806 Next_Element := 1807 Shared.Array_Elements.Table (New_Element).Next; 1808 end if; 1809 1810 -- Otherwise, reuse an existing element, or create 1811 -- one if necessary. 1812 1813 else 1814 Next_Element := 1815 Shared.Array_Elements.Table (Prev_Element).Next; 1816 1817 if Next_Element = No_Array_Element then 1818 Array_Element_Table.Increment_Last 1819 (Shared.Array_Elements); 1820 New_Element := Array_Element_Table.Last 1821 (Shared.Array_Elements); 1822 Shared.Array_Elements.Table (Prev_Element).Next := 1823 New_Element; 1824 1825 else 1826 New_Element := Next_Element; 1827 Next_Element := 1828 Shared.Array_Elements.Table (New_Element).Next; 1829 end if; 1830 end if; 1831 1832 -- Copy the value of the element 1833 1834 Shared.Array_Elements.Table (New_Element) := 1835 Shared.Array_Elements.Table (Orig_Element); 1836 Shared.Array_Elements.Table (New_Element).Value.Project 1837 := Project; 1838 1839 -- Adjust the Next link 1840 1841 Shared.Array_Elements.Table (New_Element).Next := Next_Element; 1842 1843 -- Adjust the previous id for the next element 1844 1845 Prev_Element := New_Element; 1846 1847 -- Go to the next element in the original array 1848 1849 Orig_Element := Shared.Array_Elements.Table (Orig_Element).Next; 1850 end loop; 1851 1852 -- Make sure that the array ends here, in case there previously a 1853 -- greater number of elements. 1854 1855 Shared.Array_Elements.Table (New_Element).Next := No_Array_Element; 1856 end if; 1857 end Process_Associative_Array; 1858 1859 ---------------------------------------------- 1860 -- Process_Expression_For_Associative_Array -- 1861 ---------------------------------------------- 1862 1863 procedure Process_Expression_For_Associative_Array 1864 (Current : Project_Node_Id; 1865 New_Value : Variable_Value) 1866 is 1867 Name : constant Name_Id := Name_Of (Current, Node_Tree); 1868 Current_Location : constant Source_Ptr := 1869 Location_Of (Current, Node_Tree); 1870 1871 Index_Name : Name_Id := 1872 Associative_Array_Index_Of (Current, Node_Tree); 1873 1874 Source_Index : constant Int := 1875 Source_Index_Of (Current, Node_Tree); 1876 1877 The_Array : Array_Id; 1878 Elem : Array_Element_Id := No_Array_Element; 1879 1880 begin 1881 if Index_Name /= All_Other_Names then 1882 Index_Name := Get_Attribute_Index (Node_Tree, Current, Index_Name); 1883 end if; 1884 1885 -- Look for the array in the appropriate list 1886 1887 if Pkg /= No_Package then 1888 The_Array := Shared.Packages.Table (Pkg).Decl.Arrays; 1889 else 1890 The_Array := Project.Decl.Arrays; 1891 end if; 1892 1893 while The_Array /= No_Array 1894 and then Shared.Arrays.Table (The_Array).Name /= Name 1895 loop 1896 The_Array := Shared.Arrays.Table (The_Array).Next; 1897 end loop; 1898 1899 -- If the array cannot be found, create a new entry in the list. 1900 -- As The_Array_Element is initialized to No_Array_Element, a new 1901 -- element will be created automatically later 1902 1903 if The_Array = No_Array then 1904 Array_Table.Increment_Last (Shared.Arrays); 1905 The_Array := Array_Table.Last (Shared.Arrays); 1906 1907 if Pkg /= No_Package then 1908 Shared.Arrays.Table (The_Array) := 1909 (Name => Name, 1910 Location => Current_Location, 1911 Value => No_Array_Element, 1912 Next => Shared.Packages.Table (Pkg).Decl.Arrays); 1913 1914 Shared.Packages.Table (Pkg).Decl.Arrays := The_Array; 1915 1916 else 1917 Shared.Arrays.Table (The_Array) := 1918 (Name => Name, 1919 Location => Current_Location, 1920 Value => No_Array_Element, 1921 Next => Project.Decl.Arrays); 1922 1923 Project.Decl.Arrays := The_Array; 1924 end if; 1925 1926 else 1927 Elem := Shared.Arrays.Table (The_Array).Value; 1928 end if; 1929 1930 -- Look in the list, if any, to find an element with the same index 1931 -- and same source index. 1932 1933 while Elem /= No_Array_Element 1934 and then 1935 (Shared.Array_Elements.Table (Elem).Index /= Index_Name 1936 or else 1937 Shared.Array_Elements.Table (Elem).Src_Index /= Source_Index) 1938 loop 1939 Elem := Shared.Array_Elements.Table (Elem).Next; 1940 end loop; 1941 1942 -- If no such element were found, create a new one 1943 -- and insert it in the element list, with the 1944 -- proper value. 1945 1946 if Elem = No_Array_Element then 1947 Array_Element_Table.Increment_Last (Shared.Array_Elements); 1948 Elem := Array_Element_Table.Last (Shared.Array_Elements); 1949 1950 Shared.Array_Elements.Table 1951 (Elem) := 1952 (Index => Index_Name, 1953 Restricted => False, 1954 Src_Index => Source_Index, 1955 Index_Case_Sensitive => 1956 not Case_Insensitive (Current, Node_Tree), 1957 Value => New_Value, 1958 Next => Shared.Arrays.Table (The_Array).Value); 1959 1960 Shared.Arrays.Table (The_Array).Value := Elem; 1961 1962 else 1963 -- An element with the same index already exists, just replace its 1964 -- value with the new one. 1965 1966 Shared.Array_Elements.Table (Elem).Value := New_Value; 1967 end if; 1968 1969 if Name = Snames.Name_External then 1970 if In_Tree.Is_Root_Tree then 1971 Add (Child_Env.External, 1972 External_Name => Get_Name_String (Index_Name), 1973 Value => Get_Name_String (New_Value.Value), 1974 Source => From_External_Attribute); 1975 Add (Env.External, 1976 External_Name => Get_Name_String (Index_Name), 1977 Value => Get_Name_String (New_Value.Value), 1978 Source => From_External_Attribute, 1979 Silent => True); 1980 else 1981 if Current_Verbosity = High then 1982 Debug_Output 1983 ("'for External' has no effect except in root aggregate (" 1984 & Get_Name_String (Index_Name) & ")", New_Value.Value); 1985 end if; 1986 end if; 1987 end if; 1988 end Process_Expression_For_Associative_Array; 1989 1990 -------------------------------------- 1991 -- Process_Expression_Variable_Decl -- 1992 -------------------------------------- 1993 1994 procedure Process_Expression_Variable_Decl 1995 (Current_Item : Project_Node_Id; 1996 New_Value : Variable_Value) 1997 is 1998 Name : constant Name_Id := Name_Of (Current_Item, Node_Tree); 1999 2000 Is_Attribute : constant Boolean := 2001 Kind_Of (Current_Item, Node_Tree) = 2002 N_Attribute_Declaration; 2003 2004 Var : Variable_Id := No_Variable; 2005 2006 begin 2007 -- First, find the list where to find the variable or attribute 2008 2009 if Is_Attribute then 2010 if Pkg /= No_Package then 2011 Var := Shared.Packages.Table (Pkg).Decl.Attributes; 2012 else 2013 Var := Project.Decl.Attributes; 2014 end if; 2015 2016 else 2017 if Pkg /= No_Package then 2018 Var := Shared.Packages.Table (Pkg).Decl.Variables; 2019 else 2020 Var := Project.Decl.Variables; 2021 end if; 2022 end if; 2023 2024 -- Loop through the list, to find if it has already been declared 2025 2026 while Var /= No_Variable 2027 and then Shared.Variable_Elements.Table (Var).Name /= Name 2028 loop 2029 Var := Shared.Variable_Elements.Table (Var).Next; 2030 end loop; 2031 2032 -- If it has not been declared, create a new entry in the list 2033 2034 if Var = No_Variable then 2035 2036 -- All single string attribute should already have been declared 2037 -- with a default empty string value. 2038 2039 pragma Assert 2040 (not Is_Attribute, 2041 "illegal attribute declaration for " & Get_Name_String (Name)); 2042 2043 Variable_Element_Table.Increment_Last (Shared.Variable_Elements); 2044 Var := Variable_Element_Table.Last (Shared.Variable_Elements); 2045 2046 -- Put the new variable in the appropriate list 2047 2048 if Pkg /= No_Package then 2049 Shared.Variable_Elements.Table (Var) := 2050 (Next => Shared.Packages.Table (Pkg).Decl.Variables, 2051 Name => Name, 2052 Value => New_Value); 2053 Shared.Packages.Table (Pkg).Decl.Variables := Var; 2054 2055 else 2056 Shared.Variable_Elements.Table (Var) := 2057 (Next => Project.Decl.Variables, 2058 Name => Name, 2059 Value => New_Value); 2060 Project.Decl.Variables := Var; 2061 end if; 2062 2063 -- If the variable/attribute has already been declared, just 2064 -- change the value. 2065 2066 else 2067 Shared.Variable_Elements.Table (Var).Value := New_Value; 2068 end if; 2069 2070 if Is_Attribute and then Name = Snames.Name_Project_Path then 2071 if In_Tree.Is_Root_Tree then 2072 declare 2073 package Name_Ids is 2074 new Ada.Containers.Vectors (Positive, Name_Id); 2075 Val : String_List_Id := New_Value.Values; 2076 List : Name_Ids.Vector; 2077 begin 2078 -- Get all values 2079 2080 while Val /= Nil_String loop 2081 List.Prepend 2082 (Shared.String_Elements.Table (Val).Value); 2083 Val := Shared.String_Elements.Table (Val).Next; 2084 end loop; 2085 2086 -- Prepend them in the order found in the attribute 2087 2088 for K in Positive range 1 .. Positive (List.Length) loop 2089 Prj.Env.Add_Directories 2090 (Child_Env.Project_Path, 2091 Normalize_Pathname 2092 (Name => Get_Name_String 2093 (List.Element (K)), 2094 Directory => Get_Name_String 2095 (Project.Directory.Display_Name)), 2096 Prepend => True); 2097 end loop; 2098 end; 2099 2100 else 2101 if Current_Verbosity = High then 2102 Debug_Output 2103 ("'for Project_Path' has no effect except in" 2104 & " root aggregate"); 2105 end if; 2106 end if; 2107 end if; 2108 end Process_Expression_Variable_Decl; 2109 2110 ------------------------ 2111 -- Process_Expression -- 2112 ------------------------ 2113 2114 procedure Process_Expression (Current : Project_Node_Id) is 2115 New_Value : Variable_Value := 2116 Expression 2117 (Project => Project, 2118 Shared => Shared, 2119 From_Project_Node => From_Project_Node, 2120 From_Project_Node_Tree => Node_Tree, 2121 Env => Env, 2122 Pkg => Pkg, 2123 First_Term => 2124 Tree.First_Term 2125 (Expression_Of (Current, Node_Tree), Node_Tree), 2126 Kind => 2127 Expression_Kind_Of (Current, Node_Tree)); 2128 2129 begin 2130 -- Process a typed variable declaration 2131 2132 if Kind_Of (Current, Node_Tree) = N_Typed_Variable_Declaration then 2133 Check_Or_Set_Typed_Variable (New_Value, Current); 2134 end if; 2135 2136 if Kind_Of (Current, Node_Tree) /= N_Attribute_Declaration 2137 or else Associative_Array_Index_Of (Current, Node_Tree) = No_Name 2138 then 2139 Process_Expression_Variable_Decl (Current, New_Value); 2140 else 2141 Process_Expression_For_Associative_Array (Current, New_Value); 2142 end if; 2143 end Process_Expression; 2144 2145 ----------------------------------- 2146 -- Process_Attribute_Declaration -- 2147 ----------------------------------- 2148 2149 procedure Process_Attribute_Declaration (Current : Project_Node_Id) is 2150 begin 2151 if Expression_Of (Current, Node_Tree) = Empty_Node then 2152 Process_Associative_Array (Current); 2153 else 2154 Process_Expression (Current); 2155 end if; 2156 end Process_Attribute_Declaration; 2157 2158 ------------------------------- 2159 -- Process_Case_Construction -- 2160 ------------------------------- 2161 2162 procedure Process_Case_Construction 2163 (Current_Item : Project_Node_Id) 2164 is 2165 The_Project : Project_Id := Project; 2166 -- The id of the project of the case variable 2167 2168 The_Package : Package_Id := Pkg; 2169 -- The id of the package, if any, of the case variable 2170 2171 The_Variable : Variable_Value := Nil_Variable_Value; 2172 -- The case variable 2173 2174 Case_Value : Name_Id := No_Name; 2175 -- The case variable value 2176 2177 Case_Item : Project_Node_Id := Empty_Node; 2178 Choice_String : Project_Node_Id := Empty_Node; 2179 Decl_Item : Project_Node_Id := Empty_Node; 2180 2181 begin 2182 declare 2183 Variable_Node : constant Project_Node_Id := 2184 Case_Variable_Reference_Of 2185 (Current_Item, 2186 Node_Tree); 2187 2188 Var_Id : Variable_Id := No_Variable; 2189 Name : Name_Id := No_Name; 2190 2191 begin 2192 -- If a project was specified for the case variable, get its id 2193 2194 if Present (Project_Node_Of (Variable_Node, Node_Tree)) then 2195 Name := 2196 Name_Of 2197 (Project_Node_Of (Variable_Node, Node_Tree), Node_Tree); 2198 The_Project := 2199 Imported_Or_Extended_Project_From (Project, Name); 2200 end if; 2201 2202 -- If a package was specified for the case variable, get its id 2203 2204 if Present (Package_Node_Of (Variable_Node, Node_Tree)) then 2205 Name := 2206 Name_Of 2207 (Package_Node_Of (Variable_Node, Node_Tree), Node_Tree); 2208 The_Package := Package_From (The_Project, Shared, Name); 2209 end if; 2210 2211 Name := Name_Of (Variable_Node, Node_Tree); 2212 2213 -- First, look for the case variable into the package, if any 2214 2215 if The_Package /= No_Package then 2216 Name := Name_Of (Variable_Node, Node_Tree); 2217 2218 Var_Id := Shared.Packages.Table (The_Package).Decl.Variables; 2219 while Var_Id /= No_Variable 2220 and then Shared.Variable_Elements.Table (Var_Id).Name /= Name 2221 loop 2222 Var_Id := Shared.Variable_Elements.Table (Var_Id).Next; 2223 end loop; 2224 end if; 2225 2226 -- If not found in the package, or if there is no package, look at 2227 -- the project level. 2228 2229 if Var_Id = No_Variable 2230 and then No (Package_Node_Of (Variable_Node, Node_Tree)) 2231 then 2232 Var_Id := The_Project.Decl.Variables; 2233 while Var_Id /= No_Variable 2234 and then Shared.Variable_Elements.Table (Var_Id).Name /= Name 2235 loop 2236 Var_Id := Shared.Variable_Elements.Table (Var_Id).Next; 2237 end loop; 2238 end if; 2239 2240 if Var_Id = No_Variable then 2241 2242 -- Should never happen, because this has already been checked 2243 -- during parsing. 2244 2245 Write_Line 2246 ("variable """ & Get_Name_String (Name) & """ not found"); 2247 raise Program_Error; 2248 end if; 2249 2250 -- Get the case variable 2251 2252 The_Variable := Shared.Variable_Elements. Table (Var_Id).Value; 2253 2254 if The_Variable.Kind /= Single then 2255 2256 -- Should never happen, because this has already been checked 2257 -- during parsing. 2258 2259 Write_Line ("variable""" & Get_Name_String (Name) & 2260 """ is not a single string variable"); 2261 raise Program_Error; 2262 end if; 2263 2264 -- Get the case variable value 2265 2266 Case_Value := The_Variable.Value; 2267 end; 2268 2269 -- Now look into all the case items of the case construction 2270 2271 Case_Item := First_Case_Item_Of (Current_Item, Node_Tree); 2272 2273 Case_Item_Loop : 2274 while Present (Case_Item) loop 2275 Choice_String := First_Choice_Of (Case_Item, Node_Tree); 2276 2277 -- When Choice_String is nil, it means that it is the 2278 -- "when others =>" alternative. 2279 2280 if No (Choice_String) then 2281 Decl_Item := First_Declarative_Item_Of (Case_Item, Node_Tree); 2282 exit Case_Item_Loop; 2283 end if; 2284 2285 -- Look into all the alternative of this case item 2286 2287 Choice_Loop : 2288 while Present (Choice_String) loop 2289 if Case_Value = String_Value_Of (Choice_String, Node_Tree) then 2290 Decl_Item := 2291 First_Declarative_Item_Of (Case_Item, Node_Tree); 2292 exit Case_Item_Loop; 2293 end if; 2294 2295 Choice_String := Next_Literal_String (Choice_String, Node_Tree); 2296 end loop Choice_Loop; 2297 2298 Case_Item := Next_Case_Item (Case_Item, Node_Tree); 2299 end loop Case_Item_Loop; 2300 2301 -- If there is an alternative, then we process it 2302 2303 if Present (Decl_Item) then 2304 Process_Declarative_Items 2305 (Project => Project, 2306 In_Tree => In_Tree, 2307 From_Project_Node => From_Project_Node, 2308 Node_Tree => Node_Tree, 2309 Env => Env, 2310 Pkg => Pkg, 2311 Item => Decl_Item, 2312 Child_Env => Child_Env); 2313 end if; 2314 end Process_Case_Construction; 2315 2316 -- Local variables 2317 2318 Current, Decl : Project_Node_Id; 2319 Kind : Project_Node_Kind; 2320 2321 -- Start of processing for Process_Declarative_Items 2322 2323 begin 2324 Decl := Item; 2325 while Present (Decl) loop 2326 Current := Current_Item_Node (Decl, Node_Tree); 2327 Decl := Next_Declarative_Item (Decl, Node_Tree); 2328 Kind := Kind_Of (Current, Node_Tree); 2329 2330 case Kind is 2331 when N_Package_Declaration => 2332 Process_Package_Declaration (Current); 2333 2334 -- Nothing to process for string type declaration 2335 2336 when N_String_Type_Declaration => 2337 null; 2338 2339 when N_Attribute_Declaration | 2340 N_Typed_Variable_Declaration | 2341 N_Variable_Declaration => 2342 Process_Attribute_Declaration (Current); 2343 2344 when N_Case_Construction => 2345 Process_Case_Construction (Current); 2346 2347 when others => 2348 Write_Line ("Illegal declarative item: " & Kind'Img); 2349 raise Program_Error; 2350 end case; 2351 end loop; 2352 end Process_Declarative_Items; 2353 2354 ---------------------------------- 2355 -- Process_Project_Tree_Phase_1 -- 2356 ---------------------------------- 2357 2358 procedure Process_Project_Tree_Phase_1 2359 (In_Tree : Project_Tree_Ref; 2360 Project : out Project_Id; 2361 Packages_To_Check : String_List_Access; 2362 Success : out Boolean; 2363 From_Project_Node : Project_Node_Id; 2364 From_Project_Node_Tree : Project_Node_Tree_Ref; 2365 Env : in out Prj.Tree.Environment; 2366 Reset_Tree : Boolean := True; 2367 On_New_Tree_Loaded : Tree_Loaded_Callback := null) 2368 is 2369 begin 2370 if Reset_Tree then 2371 2372 -- Make sure there are no projects in the data structure 2373 2374 Free_List (In_Tree.Projects, Free_Project => True); 2375 end if; 2376 2377 Processed_Projects.Reset; 2378 2379 -- And process the main project and all of the projects it depends on, 2380 -- recursively. 2381 2382 Debug_Increase_Indent ("Process tree, phase 1"); 2383 2384 Recursive_Process 2385 (Project => Project, 2386 In_Tree => In_Tree, 2387 Packages_To_Check => Packages_To_Check, 2388 From_Project_Node => From_Project_Node, 2389 From_Project_Node_Tree => From_Project_Node_Tree, 2390 Env => Env, 2391 Extended_By => No_Project, 2392 From_Encapsulated_Lib => False, 2393 On_New_Tree_Loaded => On_New_Tree_Loaded); 2394 2395 Success := 2396 Total_Errors_Detected = 0 2397 and then 2398 (Warning_Mode /= Treat_As_Error or else Warnings_Detected = 0); 2399 2400 if Current_Verbosity = High then 2401 Debug_Decrease_Indent 2402 ("Done Process tree, phase 1, Success=" & Success'Img); 2403 end if; 2404 end Process_Project_Tree_Phase_1; 2405 2406 ---------------------------------- 2407 -- Process_Project_Tree_Phase_2 -- 2408 ---------------------------------- 2409 2410 procedure Process_Project_Tree_Phase_2 2411 (In_Tree : Project_Tree_Ref; 2412 Project : Project_Id; 2413 Success : out Boolean; 2414 From_Project_Node : Project_Node_Id; 2415 From_Project_Node_Tree : Project_Node_Tree_Ref; 2416 Env : Environment) 2417 is 2418 Obj_Dir : Path_Name_Type; 2419 Extending : Project_Id; 2420 Extending2 : Project_Id; 2421 Prj : Project_List; 2422 2423 -- Start of processing for Process_Project_Tree_Phase_2 2424 2425 begin 2426 Success := True; 2427 2428 Debug_Increase_Indent ("Process tree, phase 2", Project.Name); 2429 2430 if Project /= No_Project then 2431 Check (In_Tree, Project, From_Project_Node_Tree, Env.Flags); 2432 end if; 2433 2434 -- If main project is an extending all project, set object directory of 2435 -- all virtual extending projects to object directory of main project. 2436 2437 if Project /= No_Project 2438 and then Is_Extending_All (From_Project_Node, From_Project_Node_Tree) 2439 then 2440 declare 2441 Object_Dir : constant Path_Information := Project.Object_Directory; 2442 2443 begin 2444 Prj := In_Tree.Projects; 2445 while Prj /= null loop 2446 if Prj.Project.Virtual then 2447 Prj.Project.Object_Directory := Object_Dir; 2448 end if; 2449 2450 Prj := Prj.Next; 2451 end loop; 2452 end; 2453 end if; 2454 2455 -- Check that no extending project shares its object directory with 2456 -- the project(s) it extends. 2457 2458 if Project /= No_Project then 2459 Prj := In_Tree.Projects; 2460 while Prj /= null loop 2461 Extending := Prj.Project.Extended_By; 2462 2463 if Extending /= No_Project then 2464 Obj_Dir := Prj.Project.Object_Directory.Name; 2465 2466 -- Check that a project being extended does not share its 2467 -- object directory with any project that extends it, directly 2468 -- or indirectly, including a virtual extending project. 2469 2470 -- Start with the project directly extending it 2471 2472 Extending2 := Extending; 2473 while Extending2 /= No_Project loop 2474 if Has_Ada_Sources (Extending2) 2475 and then Extending2.Object_Directory.Name = Obj_Dir 2476 then 2477 if Extending2.Virtual then 2478 Error_Msg_Name_1 := Prj.Project.Display_Name; 2479 Error_Msg 2480 (Env.Flags, 2481 "project %% cannot be extended by a virtual" & 2482 " project with the same object directory", 2483 Prj.Project.Location, Project); 2484 2485 else 2486 Error_Msg_Name_1 := Extending2.Display_Name; 2487 Error_Msg_Name_2 := Prj.Project.Display_Name; 2488 Error_Msg 2489 (Env.Flags, 2490 "project %% cannot extend project %%", 2491 Extending2.Location, Project); 2492 Error_Msg 2493 (Env.Flags, 2494 "\they share the same object directory", 2495 Extending2.Location, Project); 2496 end if; 2497 end if; 2498 2499 -- Continue with the next extending project, if any 2500 2501 Extending2 := Extending2.Extended_By; 2502 end loop; 2503 end if; 2504 2505 Prj := Prj.Next; 2506 end loop; 2507 end if; 2508 2509 Debug_Decrease_Indent ("Done Process tree, phase 2"); 2510 2511 Success := Total_Errors_Detected = 0 2512 and then 2513 (Warning_Mode /= Treat_As_Error or else Warnings_Detected = 0); 2514 end Process_Project_Tree_Phase_2; 2515 2516 ----------------------- 2517 -- Recursive_Process -- 2518 ----------------------- 2519 2520 procedure Recursive_Process 2521 (In_Tree : Project_Tree_Ref; 2522 Project : out Project_Id; 2523 Packages_To_Check : String_List_Access; 2524 From_Project_Node : Project_Node_Id; 2525 From_Project_Node_Tree : Project_Node_Tree_Ref; 2526 Env : in out Prj.Tree.Environment; 2527 Extended_By : Project_Id; 2528 From_Encapsulated_Lib : Boolean; 2529 On_New_Tree_Loaded : Tree_Loaded_Callback := null) 2530 is 2531 Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared; 2532 2533 Child_Env : Prj.Tree.Environment; 2534 -- Only used for the root aggregate project (if any). This is left 2535 -- uninitialized otherwise. 2536 2537 procedure Process_Imported_Projects 2538 (Imported : in out Project_List; 2539 Limited_With : Boolean); 2540 -- Process imported projects. If Limited_With is True, then only 2541 -- projects processed through a "limited with" are processed, otherwise 2542 -- only projects imported through a standard "with" are processed. 2543 -- Imported is the id of the last imported project. 2544 2545 procedure Process_Aggregated_Projects; 2546 -- Process all the projects aggregated in List. This does nothing if the 2547 -- project is not an aggregate project. 2548 2549 procedure Process_Extended_Project; 2550 -- Process the extended project: inherit all packages from the extended 2551 -- project that are not explicitly defined or renamed. Also inherit the 2552 -- languages, if attribute Languages is not explicitly defined. 2553 2554 ------------------------------- 2555 -- Process_Imported_Projects -- 2556 ------------------------------- 2557 2558 procedure Process_Imported_Projects 2559 (Imported : in out Project_List; 2560 Limited_With : Boolean) 2561 is 2562 With_Clause : Project_Node_Id; 2563 New_Project : Project_Id; 2564 Proj_Node : Project_Node_Id; 2565 2566 begin 2567 With_Clause := 2568 First_With_Clause_Of 2569 (From_Project_Node, From_Project_Node_Tree); 2570 2571 while Present (With_Clause) loop 2572 Proj_Node := 2573 Non_Limited_Project_Node_Of 2574 (With_Clause, From_Project_Node_Tree); 2575 New_Project := No_Project; 2576 2577 if (Limited_With and then No (Proj_Node)) 2578 or else (not Limited_With and then Present (Proj_Node)) 2579 then 2580 Recursive_Process 2581 (In_Tree => In_Tree, 2582 Project => New_Project, 2583 Packages_To_Check => Packages_To_Check, 2584 From_Project_Node => 2585 Project_Node_Of (With_Clause, From_Project_Node_Tree), 2586 From_Project_Node_Tree => From_Project_Node_Tree, 2587 Env => Env, 2588 Extended_By => No_Project, 2589 From_Encapsulated_Lib => From_Encapsulated_Lib, 2590 On_New_Tree_Loaded => On_New_Tree_Loaded); 2591 2592 if Imported = null then 2593 Project.Imported_Projects := new Project_List_Element' 2594 (Project => New_Project, 2595 From_Encapsulated_Lib => False, 2596 Next => null); 2597 Imported := Project.Imported_Projects; 2598 else 2599 Imported.Next := new Project_List_Element' 2600 (Project => New_Project, 2601 From_Encapsulated_Lib => False, 2602 Next => null); 2603 Imported := Imported.Next; 2604 end if; 2605 end if; 2606 2607 With_Clause := 2608 Next_With_Clause_Of (With_Clause, From_Project_Node_Tree); 2609 end loop; 2610 end Process_Imported_Projects; 2611 2612 --------------------------------- 2613 -- Process_Aggregated_Projects -- 2614 --------------------------------- 2615 2616 procedure Process_Aggregated_Projects is 2617 List : Aggregated_Project_List; 2618 Loaded_Project : Prj.Tree.Project_Node_Id; 2619 Success : Boolean := True; 2620 Tree : Project_Tree_Ref; 2621 Node_Tree : Project_Node_Tree_Ref; 2622 2623 begin 2624 if Project.Qualifier not in Aggregate_Project then 2625 return; 2626 end if; 2627 2628 Debug_Increase_Indent ("Process_Aggregated_Projects", Project.Name); 2629 2630 Prj.Nmsc.Process_Aggregated_Projects 2631 (Tree => In_Tree, 2632 Project => Project, 2633 Node_Tree => From_Project_Node_Tree, 2634 Flags => Env.Flags); 2635 2636 List := Project.Aggregated_Projects; 2637 while Success and then List /= null loop 2638 Node_Tree := new Project_Node_Tree_Data; 2639 Initialize (Node_Tree); 2640 2641 Prj.Part.Parse 2642 (In_Tree => Node_Tree, 2643 Project => Loaded_Project, 2644 Packages_To_Check => Packages_To_Check, 2645 Project_File_Name => Get_Name_String (List.Path), 2646 Errout_Handling => Prj.Part.Never_Finalize, 2647 Current_Directory => Get_Name_String (Project.Directory.Name), 2648 Is_Config_File => False, 2649 Env => Child_Env); 2650 2651 Success := not Prj.Tree.No (Loaded_Project); 2652 2653 if Success then 2654 List.Tree := new Project_Tree_Data (Is_Root_Tree => False); 2655 Prj.Initialize (List.Tree); 2656 List.Tree.Shared := In_Tree.Shared; 2657 2658 -- In aggregate library, aggregated projects are parsed using 2659 -- the aggregate library tree. 2660 2661 if Project.Qualifier = Aggregate_Library then 2662 Tree := In_Tree; 2663 else 2664 Tree := List.Tree; 2665 end if; 2666 2667 -- We can only do the phase 1 of the processing, since we do 2668 -- not have access to the configuration file yet (this is 2669 -- called when doing phase 1 of the processing for the root 2670 -- aggregate project). 2671 2672 if In_Tree.Is_Root_Tree then 2673 Process_Project_Tree_Phase_1 2674 (In_Tree => Tree, 2675 Project => List.Project, 2676 Packages_To_Check => Packages_To_Check, 2677 Success => Success, 2678 From_Project_Node => Loaded_Project, 2679 From_Project_Node_Tree => Node_Tree, 2680 Env => Child_Env, 2681 Reset_Tree => False, 2682 On_New_Tree_Loaded => On_New_Tree_Loaded); 2683 else 2684 -- use the same environment as the rest of the aggregated 2685 -- projects, ie the one that was setup by the root aggregate 2686 Process_Project_Tree_Phase_1 2687 (In_Tree => Tree, 2688 Project => List.Project, 2689 Packages_To_Check => Packages_To_Check, 2690 Success => Success, 2691 From_Project_Node => Loaded_Project, 2692 From_Project_Node_Tree => Node_Tree, 2693 Env => Env, 2694 Reset_Tree => False, 2695 On_New_Tree_Loaded => On_New_Tree_Loaded); 2696 end if; 2697 2698 if On_New_Tree_Loaded /= null then 2699 On_New_Tree_Loaded 2700 (Node_Tree, Tree, Loaded_Project, List.Project); 2701 end if; 2702 2703 else 2704 Debug_Output ("Failed to parse", Name_Id (List.Path)); 2705 end if; 2706 2707 List := List.Next; 2708 end loop; 2709 2710 Debug_Decrease_Indent ("Done Process_Aggregated_Projects"); 2711 end Process_Aggregated_Projects; 2712 2713 ------------------------------ 2714 -- Process_Extended_Project -- 2715 ------------------------------ 2716 2717 procedure Process_Extended_Project is 2718 Extended_Pkg : Package_Id; 2719 Current_Pkg : Package_Id; 2720 Element : Package_Element; 2721 First : constant Package_Id := Project.Decl.Packages; 2722 Attribute1 : Variable_Id; 2723 Attribute2 : Variable_Id; 2724 Attr_Value1 : Variable; 2725 Attr_Value2 : Variable; 2726 2727 begin 2728 Extended_Pkg := Project.Extends.Decl.Packages; 2729 while Extended_Pkg /= No_Package loop 2730 Element := Shared.Packages.Table (Extended_Pkg); 2731 2732 Current_Pkg := First; 2733 while Current_Pkg /= No_Package 2734 and then 2735 Shared.Packages.Table (Current_Pkg).Name /= Element.Name 2736 loop 2737 Current_Pkg := Shared.Packages.Table (Current_Pkg).Next; 2738 end loop; 2739 2740 if Current_Pkg = No_Package then 2741 Package_Table.Increment_Last (Shared.Packages); 2742 Current_Pkg := Package_Table.Last (Shared.Packages); 2743 Shared.Packages.Table (Current_Pkg) := 2744 (Name => Element.Name, 2745 Decl => No_Declarations, 2746 Parent => No_Package, 2747 Next => Project.Decl.Packages); 2748 Project.Decl.Packages := Current_Pkg; 2749 Copy_Package_Declarations 2750 (From => Element.Decl, 2751 To => Shared.Packages.Table (Current_Pkg).Decl, 2752 New_Loc => No_Location, 2753 Restricted => True, 2754 Shared => Shared); 2755 end if; 2756 2757 Extended_Pkg := Element.Next; 2758 end loop; 2759 2760 -- Check if attribute Languages is declared in the extending project 2761 2762 Attribute1 := Project.Decl.Attributes; 2763 while Attribute1 /= No_Variable loop 2764 Attr_Value1 := Shared.Variable_Elements. Table (Attribute1); 2765 exit when Attr_Value1.Name = Snames.Name_Languages; 2766 Attribute1 := Attr_Value1.Next; 2767 end loop; 2768 2769 if Attribute1 = No_Variable or else Attr_Value1.Value.Default then 2770 2771 -- Attribute Languages is not declared in the extending project. 2772 -- Check if it is declared in the project being extended. 2773 2774 Attribute2 := Project.Extends.Decl.Attributes; 2775 while Attribute2 /= No_Variable loop 2776 Attr_Value2 := Shared.Variable_Elements.Table (Attribute2); 2777 exit when Attr_Value2.Name = Snames.Name_Languages; 2778 Attribute2 := Attr_Value2.Next; 2779 end loop; 2780 2781 if Attribute2 /= No_Variable 2782 and then not Attr_Value2.Value.Default 2783 then 2784 -- As attribute Languages is declared in the project being 2785 -- extended, copy its value for the extending project. 2786 2787 if Attribute1 = No_Variable then 2788 Variable_Element_Table.Increment_Last 2789 (Shared.Variable_Elements); 2790 Attribute1 := Variable_Element_Table.Last 2791 (Shared.Variable_Elements); 2792 Attr_Value1.Next := Project.Decl.Attributes; 2793 Project.Decl.Attributes := Attribute1; 2794 end if; 2795 2796 Attr_Value1.Name := Snames.Name_Languages; 2797 Attr_Value1.Value := Attr_Value2.Value; 2798 Shared.Variable_Elements.Table (Attribute1) := Attr_Value1; 2799 end if; 2800 end if; 2801 end Process_Extended_Project; 2802 2803 -- Start of processing for Recursive_Process 2804 2805 begin 2806 if No (From_Project_Node) then 2807 Project := No_Project; 2808 2809 else 2810 declare 2811 Imported, Mark : Project_List; 2812 Declaration_Node : Project_Node_Id := Empty_Node; 2813 2814 Name : constant Name_Id := 2815 Name_Of (From_Project_Node, From_Project_Node_Tree); 2816 2817 Name_Node : constant Tree_Private_Part.Project_Name_And_Node := 2818 Tree_Private_Part.Projects_Htable.Get 2819 (From_Project_Node_Tree.Projects_HT, Name); 2820 2821 begin 2822 Project := Processed_Projects.Get (Name); 2823 2824 if Project /= No_Project then 2825 2826 -- Make sure that, when a project is extended, the project id 2827 -- of the project extending it is recorded in its data, even 2828 -- when it has already been processed as an imported project. 2829 -- This is for virtually extended projects. 2830 2831 if Extended_By /= No_Project then 2832 Project.Extended_By := Extended_By; 2833 end if; 2834 2835 return; 2836 end if; 2837 2838 Project := 2839 new Project_Data' 2840 (Empty_Project 2841 (Project_Qualifier_Of 2842 (From_Project_Node, From_Project_Node_Tree))); 2843 2844 -- Note that at this point we do not know yet if the project has 2845 -- been withed from an encapsulated library or not. 2846 2847 In_Tree.Projects := 2848 new Project_List_Element' 2849 (Project => Project, 2850 From_Encapsulated_Lib => False, 2851 Next => In_Tree.Projects); 2852 2853 -- Keep track of this point 2854 2855 Mark := In_Tree.Projects; 2856 2857 Processed_Projects.Set (Name, Project); 2858 2859 Project.Name := Name; 2860 Project.Display_Name := Name_Node.Display_Name; 2861 Get_Name_String (Name); 2862 2863 -- If name starts with the virtual prefix, flag the project as 2864 -- being a virtual extending project. 2865 2866 if Name_Len > Virtual_Prefix'Length 2867 and then 2868 Name_Buffer (1 .. Virtual_Prefix'Length) = Virtual_Prefix 2869 then 2870 Project.Virtual := True; 2871 end if; 2872 2873 Project.Path.Display_Name := 2874 Path_Name_Of (From_Project_Node, From_Project_Node_Tree); 2875 Get_Name_String (Project.Path.Display_Name); 2876 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); 2877 Project.Path.Name := Name_Find; 2878 2879 Project.Location := 2880 Location_Of (From_Project_Node, From_Project_Node_Tree); 2881 2882 Project.Directory.Display_Name := 2883 Directory_Of (From_Project_Node, From_Project_Node_Tree); 2884 Get_Name_String (Project.Directory.Display_Name); 2885 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); 2886 Project.Directory.Name := Name_Find; 2887 2888 Project.Extended_By := Extended_By; 2889 2890 Add_Attributes 2891 (Project, 2892 Name, 2893 Name_Id (Project.Directory.Display_Name), 2894 In_Tree.Shared, 2895 Project.Decl, 2896 Prj.Attr.Attribute_First, 2897 Project_Level => True); 2898 2899 Process_Imported_Projects (Imported, Limited_With => False); 2900 2901 if Project.Qualifier = Aggregate and then In_Tree.Is_Root_Tree then 2902 Initialize_And_Copy (Child_Env, Copy_From => Env); 2903 2904 elsif Project.Qualifier = Aggregate_Library then 2905 2906 -- The child environment is the same as the current one 2907 2908 Child_Env := Env; 2909 2910 else 2911 -- No need to initialize Child_Env, since it will not be 2912 -- used anyway by Process_Declarative_Items (only the root 2913 -- aggregate can modify it, and it is never read anyway). 2914 2915 null; 2916 end if; 2917 2918 Declaration_Node := 2919 Project_Declaration_Of 2920 (From_Project_Node, From_Project_Node_Tree); 2921 2922 Recursive_Process 2923 (In_Tree => In_Tree, 2924 Project => Project.Extends, 2925 Packages_To_Check => Packages_To_Check, 2926 From_Project_Node => 2927 Extended_Project_Of 2928 (Declaration_Node, From_Project_Node_Tree), 2929 From_Project_Node_Tree => From_Project_Node_Tree, 2930 Env => Env, 2931 Extended_By => Project, 2932 From_Encapsulated_Lib => From_Encapsulated_Lib, 2933 On_New_Tree_Loaded => On_New_Tree_Loaded); 2934 2935 Process_Declarative_Items 2936 (Project => Project, 2937 In_Tree => In_Tree, 2938 From_Project_Node => From_Project_Node, 2939 Node_Tree => From_Project_Node_Tree, 2940 Env => Env, 2941 Pkg => No_Package, 2942 Item => First_Declarative_Item_Of 2943 (Declaration_Node, From_Project_Node_Tree), 2944 Child_Env => Child_Env); 2945 2946 if Project.Extends /= No_Project then 2947 Process_Extended_Project; 2948 end if; 2949 2950 Process_Imported_Projects (Imported, Limited_With => True); 2951 2952 if Total_Errors_Detected = 0 then 2953 Process_Aggregated_Projects; 2954 end if; 2955 2956 -- At this point (after Process_Declarative_Items) we have the 2957 -- attribute values set, we can backtrace In_Tree.Project and 2958 -- set the From_Encapsulated_Library status. 2959 2960 declare 2961 Lib_Standalone : constant Prj.Variable_Value := 2962 Prj.Util.Value_Of 2963 (Snames.Name_Library_Standalone, 2964 Project.Decl.Attributes, 2965 Shared); 2966 List : Project_List := In_Tree.Projects; 2967 Is_Encapsulated : Boolean; 2968 2969 begin 2970 Get_Name_String (Lib_Standalone.Value); 2971 To_Lower (Name_Buffer (1 .. Name_Len)); 2972 2973 Is_Encapsulated := Name_Buffer (1 .. Name_Len) = "encapsulated"; 2974 2975 if Is_Encapsulated then 2976 while List /= null and then List /= Mark loop 2977 List.From_Encapsulated_Lib := Is_Encapsulated; 2978 List := List.Next; 2979 end loop; 2980 end if; 2981 2982 if Total_Errors_Detected = 0 then 2983 2984 -- For an aggregate library we add the aggregated projects 2985 -- as imported ones. This is necessary to give visibility 2986 -- to all sources from the aggregates from the aggregated 2987 -- library projects. 2988 2989 if Project.Qualifier = Aggregate_Library then 2990 declare 2991 L : Aggregated_Project_List; 2992 begin 2993 L := Project.Aggregated_Projects; 2994 while L /= null loop 2995 Project.Imported_Projects := 2996 new Project_List_Element' 2997 (Project => L.Project, 2998 From_Encapsulated_Lib => Is_Encapsulated, 2999 Next => 3000 Project.Imported_Projects); 3001 L := L.Next; 3002 end loop; 3003 end; 3004 end if; 3005 end if; 3006 end; 3007 3008 if Project.Qualifier = Aggregate and then In_Tree.Is_Root_Tree then 3009 Free (Child_Env); 3010 end if; 3011 end; 3012 end if; 3013 end Recursive_Process; 3014 3015end Prj.Proc; 3016