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