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-2003 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 2, 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 COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27with Err_Vars; use Err_Vars; 28with Namet; use Namet; 29with Opt; 30with Osint; use Osint; 31with Output; use Output; 32with Prj.Attr; use Prj.Attr; 33with Prj.Com; use Prj.Com; 34with Prj.Err; use Prj.Err; 35with Prj.Ext; use Prj.Ext; 36with Prj.Nmsc; use Prj.Nmsc; 37 38with GNAT.Case_Util; use GNAT.Case_Util; 39with GNAT.HTable; 40 41package body Prj.Proc is 42 43 Error_Report : Put_Line_Access := null; 44 45 package Processed_Projects is new GNAT.HTable.Simple_HTable 46 (Header_Num => Header_Num, 47 Element => Project_Id, 48 No_Element => No_Project, 49 Key => Name_Id, 50 Hash => Hash, 51 Equal => "="); 52 -- This hash table contains all processed projects 53 54 procedure Add (To_Exp : in out Name_Id; Str : Name_Id); 55 -- Concatenate two strings and returns another string if both 56 -- arguments are not null string. 57 58 procedure Add_Attributes 59 (Project : Project_Id; 60 Decl : in out Declarations; 61 First : Attribute_Node_Id); 62 -- Add all attributes, starting with First, with their default 63 -- values to the package or project with declarations Decl. 64 65 function Expression 66 (Project : Project_Id; 67 From_Project_Node : Project_Node_Id; 68 Pkg : Package_Id; 69 First_Term : Project_Node_Id; 70 Kind : Variable_Kind) return Variable_Value; 71 -- From N_Expression project node From_Project_Node, compute the value 72 -- of an expression and return it as a Variable_Value. 73 74 function Imported_Or_Extended_Project_From 75 (Project : Project_Id; 76 With_Name : Name_Id) return Project_Id; 77 -- Find an imported or extended project of Project whose name is With_Name 78 79 function Package_From 80 (Project : Project_Id; 81 With_Name : Name_Id) return Package_Id; 82 -- Find the package of Project whose name is With_Name 83 84 procedure Process_Declarative_Items 85 (Project : Project_Id; 86 From_Project_Node : Project_Node_Id; 87 Pkg : Package_Id; 88 Item : Project_Node_Id); 89 -- Process declarative items starting with From_Project_Node, and put them 90 -- in declarations Decl. This is a recursive procedure; it calls itself for 91 -- a package declaration or a case construction. 92 93 procedure Recursive_Process 94 (Project : out Project_Id; 95 From_Project_Node : Project_Node_Id; 96 Extended_By : Project_Id); 97 -- Process project with node From_Project_Node in the tree. 98 -- Do nothing if From_Project_Node is Empty_Node. 99 -- If project has already been processed, simply return its project id. 100 -- Otherwise create a new project id, mark it as processed, call itself 101 -- recursively for all imported projects and a extended project, if any. 102 -- Then process the declarative items of the project. 103 104 procedure Check (Project : in out Project_Id); 105 -- Set all projects to not checked, then call Recursive_Check for the 106 -- main project Project. Project is set to No_Project if errors occurred. 107 108 procedure Recursive_Check (Project : Project_Id); 109 -- If Project is not marked as checked, mark it as checked, call 110 -- Check_Naming_Scheme for the project, then call itself for a 111 -- possible extended project and all the imported projects of Project. 112 113 --------- 114 -- Add -- 115 --------- 116 117 procedure Add (To_Exp : in out Name_Id; Str : Name_Id) is 118 begin 119 if To_Exp = Types.No_Name or else To_Exp = Empty_String then 120 121 -- To_Exp is nil or empty. The result is Str. 122 123 To_Exp := Str; 124 125 -- If Str is nil, then do not change To_Ext 126 127 elsif Str /= No_Name and then Str /= Empty_String then 128 declare 129 S : constant String := Get_Name_String (Str); 130 131 begin 132 Get_Name_String (To_Exp); 133 Add_Str_To_Name_Buffer (S); 134 To_Exp := Name_Find; 135 end; 136 end if; 137 end Add; 138 139 -------------------- 140 -- Add_Attributes -- 141 -------------------- 142 143 procedure Add_Attributes 144 (Project : Project_Id; 145 Decl : in out Declarations; 146 First : Attribute_Node_Id) 147 is 148 The_Attribute : Attribute_Node_Id := First; 149 Attribute_Data : Attribute_Record; 150 151 begin 152 while The_Attribute /= Empty_Attribute loop 153 Attribute_Data := Attributes.Table (The_Attribute); 154 155 if Attribute_Data.Kind_2 = Single then 156 declare 157 New_Attribute : Variable_Value; 158 159 begin 160 case Attribute_Data.Kind_1 is 161 162 -- Undefined should not happen 163 164 when Undefined => 165 pragma Assert 166 (False, "attribute with an undefined kind"); 167 raise Program_Error; 168 169 -- Single attributes have a default value of empty string 170 171 when Single => 172 New_Attribute := 173 (Project => Project, 174 Kind => Single, 175 Location => No_Location, 176 Default => True, 177 Value => Empty_String); 178 179 -- List attributes have a default value of nil list 180 181 when List => 182 New_Attribute := 183 (Project => Project, 184 Kind => List, 185 Location => No_Location, 186 Default => True, 187 Values => Nil_String); 188 189 end case; 190 191 Variable_Elements.Increment_Last; 192 Variable_Elements.Table (Variable_Elements.Last) := 193 (Next => Decl.Attributes, 194 Name => Attribute_Data.Name, 195 Value => New_Attribute); 196 Decl.Attributes := Variable_Elements.Last; 197 end; 198 end if; 199 200 The_Attribute := Attributes.Table (The_Attribute).Next; 201 end loop; 202 end Add_Attributes; 203 204 ----------- 205 -- Check -- 206 ----------- 207 208 procedure Check (Project : in out Project_Id) is 209 begin 210 -- Make sure that all projects are marked as not checked 211 212 for Index in 1 .. Projects.Last loop 213 Projects.Table (Index).Checked := False; 214 end loop; 215 216 Recursive_Check (Project); 217 218 end Check; 219 220 ---------------- 221 -- Expression -- 222 ---------------- 223 224 function Expression 225 (Project : Project_Id; 226 From_Project_Node : Project_Node_Id; 227 Pkg : Package_Id; 228 First_Term : Project_Node_Id; 229 Kind : Variable_Kind) return Variable_Value 230 is 231 The_Term : Project_Node_Id := First_Term; 232 -- The term in the expression list 233 234 The_Current_Term : Project_Node_Id := Empty_Node; 235 -- The current term node id 236 237 Result : Variable_Value (Kind => Kind); 238 -- The returned result 239 240 Last : String_List_Id := Nil_String; 241 -- Reference to the last string elements in Result, when Kind is List. 242 243 begin 244 Result.Project := Project; 245 Result.Location := Location_Of (First_Term); 246 247 -- Process each term of the expression, starting with First_Term 248 249 while The_Term /= Empty_Node loop 250 The_Current_Term := Current_Term (The_Term); 251 252 case Kind_Of (The_Current_Term) is 253 254 when N_Literal_String => 255 256 case Kind is 257 258 when Undefined => 259 260 -- Should never happen 261 262 pragma Assert (False, "Undefined expression kind"); 263 raise Program_Error; 264 265 when Single => 266 Add (Result.Value, String_Value_Of (The_Current_Term)); 267 268 when List => 269 270 String_Elements.Increment_Last; 271 272 if Last = Nil_String then 273 274 -- This can happen in an expression such as 275 -- () & "toto" 276 277 Result.Values := String_Elements.Last; 278 279 else 280 String_Elements.Table (Last).Next := 281 String_Elements.Last; 282 end if; 283 284 Last := String_Elements.Last; 285 String_Elements.Table (Last) := 286 (Value => String_Value_Of (The_Current_Term), 287 Display_Value => No_Name, 288 Location => Location_Of (The_Current_Term), 289 Flag => False, 290 Next => Nil_String); 291 292 end case; 293 294 when N_Literal_String_List => 295 296 declare 297 String_Node : Project_Node_Id := 298 First_Expression_In_List (The_Current_Term); 299 300 Value : Variable_Value; 301 302 begin 303 if String_Node /= Empty_Node then 304 305 -- If String_Node is nil, it is an empty list, 306 -- there is nothing to do 307 308 Value := Expression 309 (Project => Project, 310 From_Project_Node => From_Project_Node, 311 Pkg => Pkg, 312 First_Term => Tree.First_Term (String_Node), 313 Kind => Single); 314 String_Elements.Increment_Last; 315 316 if Result.Values = Nil_String then 317 318 -- This literal string list is the first term 319 -- in a string list expression 320 321 Result.Values := String_Elements.Last; 322 323 else 324 String_Elements.Table (Last).Next := 325 String_Elements.Last; 326 end if; 327 328 Last := String_Elements.Last; 329 String_Elements.Table (Last) := 330 (Value => Value.Value, 331 Display_Value => No_Name, 332 Location => Value.Location, 333 Flag => False, 334 Next => Nil_String); 335 336 loop 337 -- Add the other element of the literal string list 338 -- one after the other 339 340 String_Node := 341 Next_Expression_In_List (String_Node); 342 343 exit when String_Node = Empty_Node; 344 345 Value := 346 Expression 347 (Project => Project, 348 From_Project_Node => From_Project_Node, 349 Pkg => Pkg, 350 First_Term => Tree.First_Term (String_Node), 351 Kind => Single); 352 353 String_Elements.Increment_Last; 354 String_Elements.Table (Last).Next := 355 String_Elements.Last; 356 Last := String_Elements.Last; 357 String_Elements.Table (Last) := 358 (Value => Value.Value, 359 Display_Value => No_Name, 360 Location => Value.Location, 361 Flag => False, 362 Next => Nil_String); 363 end loop; 364 365 end if; 366 367 end; 368 369 when N_Variable_Reference | N_Attribute_Reference => 370 371 declare 372 The_Project : Project_Id := Project; 373 The_Package : Package_Id := Pkg; 374 The_Name : Name_Id := No_Name; 375 The_Variable_Id : Variable_Id := No_Variable; 376 The_Variable : Variable_Value; 377 Term_Project : constant Project_Node_Id := 378 Project_Node_Of (The_Current_Term); 379 Term_Package : constant Project_Node_Id := 380 Package_Node_Of (The_Current_Term); 381 Index : Name_Id := No_Name; 382 383 begin 384 if Term_Project /= Empty_Node and then 385 Term_Project /= From_Project_Node 386 then 387 -- This variable or attribute comes from another project 388 389 The_Name := Name_Of (Term_Project); 390 The_Project := Imported_Or_Extended_Project_From 391 (Project => Project, 392 With_Name => The_Name); 393 end if; 394 395 if Term_Package /= Empty_Node then 396 397 -- This is an attribute of a package 398 399 The_Name := Name_Of (Term_Package); 400 The_Package := Projects.Table (The_Project).Decl.Packages; 401 402 while The_Package /= No_Package 403 and then Packages.Table (The_Package).Name /= The_Name 404 loop 405 The_Package := Packages.Table (The_Package).Next; 406 end loop; 407 408 pragma Assert 409 (The_Package /= No_Package, 410 "package not found."); 411 412 elsif Kind_Of (The_Current_Term) = N_Attribute_Reference then 413 The_Package := No_Package; 414 end if; 415 416 The_Name := Name_Of (The_Current_Term); 417 418 if Kind_Of (The_Current_Term) = N_Attribute_Reference then 419 Index := Associative_Array_Index_Of (The_Current_Term); 420 end if; 421 422 -- If it is not an associative array attribute 423 424 if Index = No_Name then 425 426 -- It is not an associative array attribute 427 428 if The_Package /= No_Package then 429 430 -- First, if there is a package, look into the package 431 432 if 433 Kind_Of (The_Current_Term) = N_Variable_Reference 434 then 435 The_Variable_Id := 436 Packages.Table (The_Package).Decl.Variables; 437 438 else 439 The_Variable_Id := 440 Packages.Table (The_Package).Decl.Attributes; 441 end if; 442 443 while The_Variable_Id /= No_Variable 444 and then 445 Variable_Elements.Table (The_Variable_Id).Name /= 446 The_Name 447 loop 448 The_Variable_Id := 449 Variable_Elements.Table (The_Variable_Id).Next; 450 end loop; 451 452 end if; 453 454 if The_Variable_Id = No_Variable then 455 456 -- If we have not found it, look into the project 457 458 if 459 Kind_Of (The_Current_Term) = N_Variable_Reference 460 then 461 The_Variable_Id := 462 Projects.Table (The_Project).Decl.Variables; 463 464 else 465 The_Variable_Id := 466 Projects.Table (The_Project).Decl.Attributes; 467 end if; 468 469 while The_Variable_Id /= No_Variable 470 and then 471 Variable_Elements.Table (The_Variable_Id).Name /= 472 The_Name 473 loop 474 The_Variable_Id := 475 Variable_Elements.Table (The_Variable_Id).Next; 476 end loop; 477 478 end if; 479 480 pragma Assert (The_Variable_Id /= No_Variable, 481 "variable or attribute not found"); 482 483 The_Variable := Variable_Elements.Table 484 (The_Variable_Id).Value; 485 486 else 487 488 -- It is an associative array attribute 489 490 declare 491 The_Array : Array_Id := No_Array; 492 The_Element : Array_Element_Id := No_Array_Element; 493 Array_Index : Name_Id := No_Name; 494 begin 495 if The_Package /= No_Package then 496 The_Array := 497 Packages.Table (The_Package).Decl.Arrays; 498 499 else 500 The_Array := 501 Projects.Table (The_Project).Decl.Arrays; 502 end if; 503 504 while The_Array /= No_Array 505 and then Arrays.Table (The_Array).Name /= The_Name 506 loop 507 The_Array := Arrays.Table (The_Array).Next; 508 end loop; 509 510 if The_Array /= No_Array then 511 The_Element := Arrays.Table (The_Array).Value; 512 513 Get_Name_String (Index); 514 515 if Case_Insensitive (The_Current_Term) then 516 To_Lower (Name_Buffer (1 .. Name_Len)); 517 end if; 518 519 Array_Index := Name_Find; 520 521 while The_Element /= No_Array_Element 522 and then Array_Elements.Table (The_Element).Index 523 /= Array_Index 524 loop 525 The_Element := 526 Array_Elements.Table (The_Element).Next; 527 end loop; 528 529 end if; 530 531 if The_Element /= No_Array_Element then 532 The_Variable := 533 Array_Elements.Table (The_Element).Value; 534 535 else 536 if 537 Expression_Kind_Of (The_Current_Term) = List 538 then 539 The_Variable := 540 (Project => Project, 541 Kind => List, 542 Location => No_Location, 543 Default => True, 544 Values => Nil_String); 545 546 else 547 The_Variable := 548 (Project => Project, 549 Kind => Single, 550 Location => No_Location, 551 Default => True, 552 Value => Empty_String); 553 end if; 554 end if; 555 end; 556 end if; 557 558 case Kind is 559 560 when Undefined => 561 562 -- Should never happen 563 564 pragma Assert (False, "undefined expression kind"); 565 null; 566 567 when Single => 568 569 case The_Variable.Kind is 570 571 when Undefined => 572 null; 573 574 when Single => 575 Add (Result.Value, The_Variable.Value); 576 577 when List => 578 579 -- Should never happen 580 581 pragma Assert 582 (False, 583 "list cannot appear in single " & 584 "string expression"); 585 null; 586 end case; 587 588 when List => 589 case The_Variable.Kind is 590 591 when Undefined => 592 null; 593 594 when Single => 595 String_Elements.Increment_Last; 596 597 if Last = Nil_String then 598 599 -- This can happen in an expression such as 600 -- () & Var 601 602 Result.Values := String_Elements.Last; 603 604 else 605 String_Elements.Table (Last).Next := 606 String_Elements.Last; 607 end if; 608 609 Last := String_Elements.Last; 610 String_Elements.Table (Last) := 611 (Value => The_Variable.Value, 612 Display_Value => No_Name, 613 Location => Location_Of (The_Current_Term), 614 Flag => False, 615 Next => Nil_String); 616 617 when List => 618 619 declare 620 The_List : String_List_Id := 621 The_Variable.Values; 622 623 begin 624 while The_List /= Nil_String loop 625 String_Elements.Increment_Last; 626 627 if Last = Nil_String then 628 Result.Values := String_Elements.Last; 629 630 else 631 String_Elements.Table (Last).Next := 632 String_Elements.Last; 633 634 end if; 635 636 Last := String_Elements.Last; 637 String_Elements.Table (Last) := 638 (Value => 639 String_Elements.Table 640 (The_List).Value, 641 Display_Value => No_Name, 642 Location => Location_Of 643 (The_Current_Term), 644 Flag => False, 645 Next => Nil_String); 646 The_List := 647 String_Elements.Table (The_List).Next; 648 end loop; 649 end; 650 end case; 651 end case; 652 end; 653 654 when N_External_Value => 655 Get_Name_String 656 (String_Value_Of (External_Reference_Of (The_Current_Term))); 657 658 declare 659 Name : constant Name_Id := Name_Find; 660 Default : Name_Id := No_Name; 661 Value : Name_Id := No_Name; 662 663 Default_Node : constant Project_Node_Id := 664 External_Default_Of (The_Current_Term); 665 666 begin 667 if Default_Node /= Empty_Node then 668 Default := String_Value_Of (Default_Node); 669 end if; 670 671 Value := Prj.Ext.Value_Of (Name, Default); 672 673 if Value = No_Name then 674 if not Opt.Quiet_Output then 675 if Error_Report = null then 676 Error_Msg 677 ("?undefined external reference", 678 Location_Of (The_Current_Term)); 679 680 else 681 Error_Report 682 ("warning: """ & Get_Name_String (Name) & 683 """ is an undefined external reference", 684 Project); 685 end if; 686 end if; 687 688 Value := Empty_String; 689 690 end if; 691 692 case Kind is 693 694 when Undefined => 695 null; 696 697 when Single => 698 Add (Result.Value, Value); 699 700 when List => 701 String_Elements.Increment_Last; 702 703 if Last = Nil_String then 704 Result.Values := String_Elements.Last; 705 706 else 707 String_Elements.Table (Last).Next := 708 String_Elements.Last; 709 end if; 710 711 Last := String_Elements.Last; 712 String_Elements.Table (Last) := 713 (Value => Value, 714 Display_Value => No_Name, 715 Location => Location_Of (The_Current_Term), 716 Flag => False, 717 Next => Nil_String); 718 719 end case; 720 end; 721 722 when others => 723 724 -- Should never happen 725 726 pragma Assert 727 (False, 728 "illegal node kind in an expression"); 729 raise Program_Error; 730 731 end case; 732 733 The_Term := Next_Term (The_Term); 734 end loop; 735 736 return Result; 737 end Expression; 738 739 --------------------------------------- 740 -- Imported_Or_Extended_Project_From -- 741 --------------------------------------- 742 743 function Imported_Or_Extended_Project_From 744 (Project : Project_Id; 745 With_Name : Name_Id) return Project_Id 746 is 747 Data : constant Project_Data := Projects.Table (Project); 748 List : Project_List := Data.Imported_Projects; 749 750 begin 751 -- First check if it is the name of a extended project 752 753 if Data.Extends /= No_Project 754 and then Projects.Table (Data.Extends).Name = With_Name 755 then 756 return Data.Extends; 757 758 else 759 -- Then check the name of each imported project 760 761 while List /= Empty_Project_List 762 and then 763 Projects.Table 764 (Project_Lists.Table (List).Project).Name /= With_Name 765 766 loop 767 List := Project_Lists.Table (List).Next; 768 end loop; 769 770 pragma Assert 771 (List /= Empty_Project_List, 772 "project not found"); 773 774 return Project_Lists.Table (List).Project; 775 end if; 776 end Imported_Or_Extended_Project_From; 777 778 ------------------ 779 -- Package_From -- 780 ------------------ 781 782 function Package_From 783 (Project : Project_Id; 784 With_Name : Name_Id) return Package_Id 785 is 786 Data : constant Project_Data := Projects.Table (Project); 787 Result : Package_Id := Data.Decl.Packages; 788 789 begin 790 -- Check the name of each existing package of Project 791 792 while Result /= No_Package 793 and then 794 Packages.Table (Result).Name /= With_Name 795 loop 796 Result := Packages.Table (Result).Next; 797 end loop; 798 799 if Result = No_Package then 800 -- Should never happen 801 Write_Line ("package """ & Get_Name_String (With_Name) & 802 """ not found"); 803 raise Program_Error; 804 805 else 806 return Result; 807 end if; 808 end Package_From; 809 810 ------------- 811 -- Process -- 812 ------------- 813 814 procedure Process 815 (Project : out Project_Id; 816 Success : out Boolean; 817 From_Project_Node : Project_Node_Id; 818 Report_Error : Put_Line_Access) 819 is 820 Obj_Dir : Name_Id; 821 Extending : Project_Id; 822 823 begin 824 Error_Report := Report_Error; 825 Success := True; 826 827 -- Make sure there is no projects in the data structure 828 829 Projects.Set_Last (No_Project); 830 Processed_Projects.Reset; 831 832 -- And process the main project and all of the projects it depends on, 833 -- recursively 834 835 Recursive_Process 836 (Project => Project, 837 From_Project_Node => From_Project_Node, 838 Extended_By => No_Project); 839 840 if Project /= No_Project then 841 Check (Project); 842 end if; 843 844 -- If main project is an extending all project, set the object 845 -- directory of all virtual extending projects to the object directory 846 -- of the main project. 847 848 if Project /= No_Project 849 and then Is_Extending_All (From_Project_Node) 850 then 851 declare 852 Object_Dir : constant Name_Id := 853 Projects.Table (Project).Object_Directory; 854 begin 855 for Index in Projects.First .. Projects.Last loop 856 if Projects.Table (Index).Virtual then 857 Projects.Table (Index).Object_Directory := Object_Dir; 858 end if; 859 end loop; 860 end; 861 end if; 862 863 -- Check that no extended project shares its object directory with 864 -- another project. 865 866 if Project /= No_Project then 867 for Extended in 1 .. Projects.Last loop 868 Extending := Projects.Table (Extended).Extended_By; 869 870 if Extending /= No_Project then 871 Obj_Dir := Projects.Table (Extended).Object_Directory; 872 873 for Prj in 1 .. Projects.Last loop 874 if Prj /= Extended 875 and then Projects.Table (Prj).Sources_Present 876 and then Projects.Table (Prj).Object_Directory = Obj_Dir 877 then 878 if Projects.Table (Extending).Virtual then 879 Error_Msg_Name_1 := Projects.Table (Extended).Name; 880 881 if Error_Report = null then 882 Error_Msg 883 ("project % cannot be extended by " & 884 "a virtual project", 885 Projects.Table (Extending).Location); 886 887 else 888 Error_Report 889 ("project """ & 890 Get_Name_String (Error_Msg_Name_1) & 891 """ cannot be extended by a virtual project", 892 Project); 893 end if; 894 895 else 896 Error_Msg_Name_1 := Projects.Table (Extending).Name; 897 Error_Msg_Name_2 := Projects.Table (Extended).Name; 898 899 if Error_Report = null then 900 Error_Msg ("project % cannot extend project %", 901 Projects.Table (Extending).Location); 902 903 else 904 Error_Report 905 ("project """ & 906 Get_Name_String (Error_Msg_Name_1) & 907 """ cannot extend project """ & 908 Get_Name_String (Error_Msg_Name_2) & '"', 909 Project); 910 end if; 911 end if; 912 913 Error_Msg_Name_1 := Projects.Table (Extended).Name; 914 Error_Msg_Name_2 := Projects.Table (Prj).Name; 915 916 if Error_Report = null then 917 Error_Msg 918 ("\project % has the same object directory " & 919 "as project %", 920 Projects.Table (Extending).Location); 921 922 else 923 Error_Report 924 ("project """ & 925 Get_Name_String (Error_Msg_Name_1) & 926 """ has the same object directory as project """ & 927 Get_Name_String (Error_Msg_Name_2) & '"', 928 Project); 929 end if; 930 931 Project := No_Project; 932 exit; 933 end if; 934 end loop; 935 end if; 936 end loop; 937 end if; 938 939 Success := Total_Errors_Detected <= 0; 940 end Process; 941 942 ------------------------------- 943 -- Process_Declarative_Items -- 944 ------------------------------- 945 946 procedure Process_Declarative_Items 947 (Project : Project_Id; 948 From_Project_Node : Project_Node_Id; 949 Pkg : Package_Id; 950 Item : Project_Node_Id) 951 is 952 Current_Declarative_Item : Project_Node_Id := Item; 953 Current_Item : Project_Node_Id := Empty_Node; 954 955 begin 956 -- For each declarative item 957 958 while Current_Declarative_Item /= Empty_Node loop 959 960 -- Get its data 961 962 Current_Item := Current_Item_Node (Current_Declarative_Item); 963 964 -- And set Current_Declarative_Item to the next declarative item 965 -- ready for the next iteration. 966 967 Current_Declarative_Item := Next_Declarative_Item 968 (Current_Declarative_Item); 969 970 case Kind_Of (Current_Item) is 971 972 when N_Package_Declaration => 973 -- Do not process a package declaration that should be ignored 974 975 if Expression_Kind_Of (Current_Item) /= Ignored then 976 -- Create the new package 977 978 Packages.Increment_Last; 979 980 declare 981 New_Pkg : constant Package_Id := Packages.Last; 982 The_New_Package : Package_Element; 983 984 Project_Of_Renamed_Package : constant Project_Node_Id := 985 Project_Of_Renamed_Package_Of 986 (Current_Item); 987 988 begin 989 -- Set the name of the new package 990 991 The_New_Package.Name := Name_Of (Current_Item); 992 993 -- Insert the new package in the appropriate list 994 995 if Pkg /= No_Package then 996 The_New_Package.Next := 997 Packages.Table (Pkg).Decl.Packages; 998 Packages.Table (Pkg).Decl.Packages := New_Pkg; 999 else 1000 The_New_Package.Next := 1001 Projects.Table (Project).Decl.Packages; 1002 Projects.Table (Project).Decl.Packages := New_Pkg; 1003 end if; 1004 1005 Packages.Table (New_Pkg) := The_New_Package; 1006 1007 if Project_Of_Renamed_Package /= Empty_Node then 1008 1009 -- Renamed package 1010 1011 declare 1012 Project_Name : constant Name_Id := 1013 Name_Of 1014 (Project_Of_Renamed_Package); 1015 1016 Renamed_Project : constant Project_Id := 1017 Imported_Or_Extended_Project_From 1018 (Project, Project_Name); 1019 1020 Renamed_Package : constant Package_Id := 1021 Package_From 1022 (Renamed_Project, 1023 Name_Of (Current_Item)); 1024 1025 begin 1026 -- For a renamed package, set declarations to 1027 -- the declarations of the renamed package. 1028 1029 Packages.Table (New_Pkg).Decl := 1030 Packages.Table (Renamed_Package).Decl; 1031 end; 1032 1033 -- Standard package declaration, not renaming 1034 1035 else 1036 -- Set the default values of the attributes 1037 1038 Add_Attributes 1039 (Project, 1040 Packages.Table (New_Pkg).Decl, 1041 Package_Attributes.Table 1042 (Package_Id_Of (Current_Item)).First_Attribute); 1043 1044 -- And process declarative items of the new package 1045 1046 Process_Declarative_Items 1047 (Project => Project, 1048 From_Project_Node => From_Project_Node, 1049 Pkg => New_Pkg, 1050 Item => First_Declarative_Item_Of 1051 (Current_Item)); 1052 end if; 1053 end; 1054 end if; 1055 1056 when N_String_Type_Declaration => 1057 1058 -- There is nothing to process 1059 1060 null; 1061 1062 when N_Attribute_Declaration | 1063 N_Typed_Variable_Declaration | 1064 N_Variable_Declaration => 1065 1066 if Expression_Of (Current_Item) = Empty_Node then 1067 1068 -- It must be a full associative array attribute declaration 1069 1070 declare 1071 Current_Item_Name : constant Name_Id := 1072 Name_Of (Current_Item); 1073 -- The name of the attribute 1074 1075 New_Array : Array_Id; 1076 -- The new associative array created 1077 1078 Orig_Array : Array_Id; 1079 -- The associative array value 1080 1081 Orig_Project_Name : Name_Id := No_Name; 1082 -- The name of the project where the associative array 1083 -- value is. 1084 1085 Orig_Project : Project_Id := No_Project; 1086 -- The id of the project where the associative array 1087 -- value is. 1088 1089 Orig_Package_Name : Name_Id := No_Name; 1090 -- The name of the package, if any, where the associative 1091 -- array value is. 1092 1093 Orig_Package : Package_Id := No_Package; 1094 -- The id of the package, if any, where the associative 1095 -- array value is. 1096 1097 New_Element : Array_Element_Id := No_Array_Element; 1098 -- Id of a new array element created 1099 1100 Prev_Element : Array_Element_Id := No_Array_Element; 1101 -- Last new element id created 1102 1103 Orig_Element : Array_Element_Id := No_Array_Element; 1104 -- Current array element in the original associative 1105 -- array. 1106 1107 Next_Element : Array_Element_Id := No_Array_Element; 1108 -- Id of the array element that follows the new element. 1109 -- This is not always nil, because values for the 1110 -- associative array attribute may already have been 1111 -- declared, and the array elements declared are reused. 1112 1113 begin 1114 -- First, find if the associative array attribute already 1115 -- has elements declared. 1116 1117 if Pkg /= No_Package then 1118 New_Array := Packages.Table (Pkg).Decl.Arrays; 1119 1120 else 1121 New_Array := Projects.Table (Project).Decl.Arrays; 1122 end if; 1123 1124 while New_Array /= No_Array and then 1125 Arrays.Table (New_Array).Name /= Current_Item_Name 1126 loop 1127 New_Array := Arrays.Table (New_Array).Next; 1128 end loop; 1129 1130 -- If the attribute has never been declared add new entry 1131 -- in the arrays of the project/package and link it. 1132 1133 if New_Array = No_Array then 1134 Arrays.Increment_Last; 1135 New_Array := Arrays.Last; 1136 1137 if Pkg /= No_Package then 1138 Arrays.Table (New_Array) := 1139 (Name => Current_Item_Name, 1140 Value => No_Array_Element, 1141 Next => Packages.Table (Pkg).Decl.Arrays); 1142 Packages.Table (Pkg).Decl.Arrays := New_Array; 1143 1144 else 1145 Arrays.Table (New_Array) := 1146 (Name => Current_Item_Name, 1147 Value => No_Array_Element, 1148 Next => Projects.Table (Project).Decl.Arrays); 1149 Projects.Table (Project).Decl.Arrays := New_Array; 1150 end if; 1151 end if; 1152 1153 -- Find the project where the value is declared 1154 1155 Orig_Project_Name := 1156 Name_Of (Associative_Project_Of (Current_Item)); 1157 1158 for Index in Projects.First .. Projects.Last loop 1159 if Projects.Table (Index).Name = Orig_Project_Name then 1160 Orig_Project := Index; 1161 exit; 1162 end if; 1163 end loop; 1164 1165 pragma Assert (Orig_Project /= No_Project, 1166 "original project not found"); 1167 1168 if Associative_Package_Of (Current_Item) = Empty_Node then 1169 Orig_Array := 1170 Projects.Table (Orig_Project).Decl.Arrays; 1171 1172 else 1173 -- If in a package, find the package where the 1174 -- value is declared. 1175 1176 Orig_Package_Name := 1177 Name_Of (Associative_Package_Of (Current_Item)); 1178 Orig_Package := 1179 Projects.Table (Orig_Project).Decl.Packages; 1180 pragma Assert (Orig_Package /= No_Package, 1181 "original package not found"); 1182 1183 while Packages.Table (Orig_Package).Name /= 1184 Orig_Package_Name 1185 loop 1186 Orig_Package := Packages.Table (Orig_Package).Next; 1187 pragma Assert (Orig_Package /= No_Package, 1188 "original package not found"); 1189 end loop; 1190 1191 Orig_Array := 1192 Packages.Table (Orig_Package).Decl.Arrays; 1193 end if; 1194 1195 -- Now look for the array 1196 1197 while Orig_Array /= No_Array and then 1198 Arrays.Table (Orig_Array).Name /= Current_Item_Name 1199 loop 1200 Orig_Array := Arrays.Table (Orig_Array).Next; 1201 end loop; 1202 1203 if Orig_Array = No_Array then 1204 if Error_Report = null then 1205 Error_Msg 1206 ("associative array value cannot be found", 1207 Location_Of (Current_Item)); 1208 1209 else 1210 Error_Report 1211 ("associative array value cannot be found", 1212 Project); 1213 end if; 1214 1215 else 1216 Orig_Element := Arrays.Table (Orig_Array).Value; 1217 1218 -- Copy each array element 1219 1220 while Orig_Element /= No_Array_Element loop 1221 -- If it is the first element ... 1222 1223 if Prev_Element = No_Array_Element then 1224 -- And there is no array element declared yet, 1225 -- create a new first array element. 1226 1227 if Arrays.Table (New_Array).Value = 1228 No_Array_Element 1229 then 1230 Array_Elements.Increment_Last; 1231 New_Element := Array_Elements.Last; 1232 Arrays.Table (New_Array).Value := New_Element; 1233 Next_Element := No_Array_Element; 1234 1235 -- Otherwise, the new element is the first 1236 1237 else 1238 New_Element := Arrays.Table (New_Array).Value; 1239 Next_Element := 1240 Array_Elements.Table (New_Element).Next; 1241 end if; 1242 1243 -- Otherwise, reuse an existing element, or create 1244 -- one if necessary. 1245 1246 else 1247 Next_Element := 1248 Array_Elements.Table (Prev_Element).Next; 1249 1250 if Next_Element = No_Array_Element then 1251 Array_Elements.Increment_Last; 1252 New_Element := Array_Elements.Last; 1253 1254 else 1255 New_Element := Next_Element; 1256 Next_Element := 1257 Array_Elements.Table (New_Element).Next; 1258 end if; 1259 end if; 1260 1261 -- Copy the value of the element 1262 1263 Array_Elements.Table (New_Element) := 1264 Array_Elements.Table (Orig_Element); 1265 Array_Elements.Table (New_Element).Value.Project := 1266 Project; 1267 1268 -- Adjust the Next link 1269 1270 Array_Elements.Table (New_Element).Next := 1271 Next_Element; 1272 1273 -- Adjust the previous id for the next element 1274 1275 Prev_Element := New_Element; 1276 1277 -- Go to the next element in the original array 1278 Orig_Element := 1279 Array_Elements.Table (Orig_Element).Next; 1280 end loop; 1281 1282 -- Make sure that the array ends here, in case there 1283 -- previously a greater number of elements. 1284 1285 Array_Elements.Table (New_Element).Next := 1286 No_Array_Element; 1287 end if; 1288 end; 1289 1290 -- Declarations other that full associative arrays 1291 1292 else 1293 declare 1294 New_Value : constant Variable_Value := 1295 Expression 1296 (Project => Project, 1297 From_Project_Node => From_Project_Node, 1298 Pkg => Pkg, 1299 First_Term => 1300 Tree.First_Term (Expression_Of 1301 (Current_Item)), 1302 Kind => 1303 Expression_Kind_Of (Current_Item)); 1304 -- The expression value 1305 1306 The_Variable : Variable_Id := No_Variable; 1307 1308 Current_Item_Name : constant Name_Id := 1309 Name_Of (Current_Item); 1310 1311 begin 1312 -- Process a typed variable declaration 1313 1314 if 1315 Kind_Of (Current_Item) = N_Typed_Variable_Declaration 1316 then 1317 -- Report an error for an empty string 1318 1319 if New_Value.Value = Empty_String then 1320 Error_Msg_Name_1 := Name_Of (Current_Item); 1321 1322 if Error_Report = null then 1323 Error_Msg 1324 ("no value defined for %", 1325 Location_Of (Current_Item)); 1326 1327 else 1328 Error_Report 1329 ("no value defined for " & 1330 Get_Name_String (Error_Msg_Name_1), 1331 Project); 1332 end if; 1333 1334 else 1335 declare 1336 Current_String : Project_Node_Id := 1337 First_Literal_String 1338 (String_Type_Of 1339 (Current_Item)); 1340 1341 begin 1342 -- Loop through all the valid strings for 1343 -- the string type and compare to the string 1344 -- value. 1345 1346 while Current_String /= Empty_Node 1347 and then String_Value_Of (Current_String) /= 1348 New_Value.Value 1349 loop 1350 Current_String := 1351 Next_Literal_String (Current_String); 1352 end loop; 1353 1354 -- Report an error if the string value is not 1355 -- one for the string type. 1356 1357 if Current_String = Empty_Node then 1358 Error_Msg_Name_1 := New_Value.Value; 1359 Error_Msg_Name_2 := Name_Of (Current_Item); 1360 1361 if Error_Report = null then 1362 Error_Msg 1363 ("value { is illegal for typed string %", 1364 Location_Of (Current_Item)); 1365 1366 else 1367 Error_Report 1368 ("value """ & 1369 Get_Name_String (Error_Msg_Name_1) & 1370 """ is illegal for typed string """ & 1371 Get_Name_String (Error_Msg_Name_2) & 1372 """", 1373 Project); 1374 end if; 1375 end if; 1376 end; 1377 end if; 1378 end if; 1379 1380 if Kind_Of (Current_Item) /= N_Attribute_Declaration 1381 or else 1382 Associative_Array_Index_Of (Current_Item) = No_Name 1383 then 1384 -- Case of a variable declaration or of a not 1385 -- associative array attribute. 1386 1387 -- First, find the list where to find the variable 1388 -- or attribute. 1389 1390 if 1391 Kind_Of (Current_Item) = N_Attribute_Declaration 1392 then 1393 if Pkg /= No_Package then 1394 The_Variable := 1395 Packages.Table (Pkg).Decl.Attributes; 1396 1397 else 1398 The_Variable := 1399 Projects.Table (Project).Decl.Attributes; 1400 end if; 1401 1402 else 1403 if Pkg /= No_Package then 1404 The_Variable := 1405 Packages.Table (Pkg).Decl.Variables; 1406 1407 else 1408 The_Variable := 1409 Projects.Table (Project).Decl.Variables; 1410 end if; 1411 1412 end if; 1413 1414 -- Loop through the list, to find if it has already 1415 -- been declared. 1416 1417 while 1418 The_Variable /= No_Variable 1419 and then 1420 Variable_Elements.Table (The_Variable).Name /= 1421 Current_Item_Name 1422 loop 1423 The_Variable := 1424 Variable_Elements.Table (The_Variable).Next; 1425 end loop; 1426 1427 -- If it has not been declared, create a new entry 1428 -- in the list. 1429 1430 if The_Variable = No_Variable then 1431 -- All single string attribute should already have 1432 -- been declared with a default empty string value. 1433 1434 pragma Assert 1435 (Kind_Of (Current_Item) /= 1436 N_Attribute_Declaration, 1437 "illegal attribute declaration"); 1438 1439 Variable_Elements.Increment_Last; 1440 The_Variable := Variable_Elements.Last; 1441 1442 -- Put the new variable in the appropriate list 1443 1444 if Pkg /= No_Package then 1445 Variable_Elements.Table (The_Variable) := 1446 (Next => 1447 Packages.Table (Pkg).Decl.Variables, 1448 Name => Current_Item_Name, 1449 Value => New_Value); 1450 Packages.Table (Pkg).Decl.Variables := 1451 The_Variable; 1452 1453 else 1454 Variable_Elements.Table (The_Variable) := 1455 (Next => 1456 Projects.Table (Project).Decl.Variables, 1457 Name => Current_Item_Name, 1458 Value => New_Value); 1459 Projects.Table (Project).Decl.Variables := 1460 The_Variable; 1461 end if; 1462 1463 -- If the variable/attribute has already been 1464 -- declared, just change the value. 1465 1466 else 1467 Variable_Elements.Table (The_Variable).Value := 1468 New_Value; 1469 1470 end if; 1471 1472 else 1473 -- Associative array attribute 1474 1475 -- Get the string index 1476 1477 Get_Name_String 1478 (Associative_Array_Index_Of (Current_Item)); 1479 1480 -- Put in lower case, if necessary 1481 1482 if Case_Insensitive (Current_Item) then 1483 GNAT.Case_Util.To_Lower 1484 (Name_Buffer (1 .. Name_Len)); 1485 end if; 1486 1487 declare 1488 The_Array : Array_Id; 1489 1490 The_Array_Element : Array_Element_Id := 1491 No_Array_Element; 1492 1493 Index_Name : constant Name_Id := Name_Find; 1494 -- The name id of the index 1495 1496 begin 1497 -- Look for the array in the appropriate list 1498 1499 if Pkg /= No_Package then 1500 The_Array := Packages.Table (Pkg).Decl.Arrays; 1501 1502 else 1503 The_Array := Projects.Table 1504 (Project).Decl.Arrays; 1505 end if; 1506 1507 while 1508 The_Array /= No_Array 1509 and then Arrays.Table (The_Array).Name /= 1510 Current_Item_Name 1511 loop 1512 The_Array := Arrays.Table (The_Array).Next; 1513 end loop; 1514 1515 -- If the array cannot be found, create a new 1516 -- entry in the list. As The_Array_Element is 1517 -- initialized to No_Array_Element, a new element 1518 -- will be created automatically later. 1519 1520 if The_Array = No_Array then 1521 Arrays.Increment_Last; 1522 The_Array := Arrays.Last; 1523 1524 if Pkg /= No_Package then 1525 Arrays.Table (The_Array) := 1526 (Name => Current_Item_Name, 1527 Value => No_Array_Element, 1528 Next => Packages.Table (Pkg).Decl.Arrays); 1529 Packages.Table (Pkg).Decl.Arrays := The_Array; 1530 1531 else 1532 Arrays.Table (The_Array) := 1533 (Name => Current_Item_Name, 1534 Value => No_Array_Element, 1535 Next => 1536 Projects.Table (Project).Decl.Arrays); 1537 Projects.Table (Project).Decl.Arrays := 1538 The_Array; 1539 end if; 1540 1541 -- Otherwise, initialize The_Array_Element as the 1542 -- head of the element list. 1543 1544 else 1545 The_Array_Element := 1546 Arrays.Table (The_Array).Value; 1547 end if; 1548 1549 -- Look in the list, if any, to find an element 1550 -- with the same index. 1551 1552 while The_Array_Element /= No_Array_Element 1553 and then 1554 Array_Elements.Table (The_Array_Element).Index /= 1555 Index_Name 1556 loop 1557 The_Array_Element := 1558 Array_Elements.Table (The_Array_Element).Next; 1559 end loop; 1560 1561 -- If no such element were found, create a new 1562 -- one and insert it in the element list, with 1563 -- the propoer value. 1564 1565 if The_Array_Element = No_Array_Element then 1566 Array_Elements.Increment_Last; 1567 The_Array_Element := Array_Elements.Last; 1568 1569 Array_Elements.Table (The_Array_Element) := 1570 (Index => Index_Name, 1571 Index_Case_Sensitive => 1572 not Case_Insensitive (Current_Item), 1573 Value => New_Value, 1574 Next => Arrays.Table (The_Array).Value); 1575 Arrays.Table (The_Array).Value := 1576 The_Array_Element; 1577 1578 -- An element with the same index already exists, 1579 -- just replace its value with the new one. 1580 1581 else 1582 Array_Elements.Table (The_Array_Element).Value := 1583 New_Value; 1584 end if; 1585 end; 1586 end if; 1587 end; 1588 end if; 1589 1590 when N_Case_Construction => 1591 declare 1592 The_Project : Project_Id := Project; 1593 -- The id of the project of the case variable 1594 1595 The_Package : Package_Id := Pkg; 1596 -- The id of the package, if any, of the case variable 1597 1598 The_Variable : Variable_Value := Nil_Variable_Value; 1599 -- The case variable 1600 1601 Case_Value : Name_Id := No_Name; 1602 -- The case variable value 1603 1604 Case_Item : Project_Node_Id := Empty_Node; 1605 Choice_String : Project_Node_Id := Empty_Node; 1606 Decl_Item : Project_Node_Id := Empty_Node; 1607 1608 begin 1609 declare 1610 Variable_Node : constant Project_Node_Id := 1611 Case_Variable_Reference_Of 1612 (Current_Item); 1613 1614 Var_Id : Variable_Id := No_Variable; 1615 Name : Name_Id := No_Name; 1616 1617 begin 1618 -- If a project were specified for the case variable, 1619 -- get its id. 1620 1621 if Project_Node_Of (Variable_Node) /= Empty_Node then 1622 Name := Name_Of (Project_Node_Of (Variable_Node)); 1623 The_Project := 1624 Imported_Or_Extended_Project_From (Project, Name); 1625 end if; 1626 1627 -- If a package were specified for the case variable, 1628 -- get its id. 1629 1630 if Package_Node_Of (Variable_Node) /= Empty_Node then 1631 Name := Name_Of (Package_Node_Of (Variable_Node)); 1632 The_Package := Package_From (The_Project, Name); 1633 end if; 1634 1635 Name := Name_Of (Variable_Node); 1636 1637 -- First, look for the case variable into the package, 1638 -- if any. 1639 1640 if The_Package /= No_Package then 1641 Var_Id := Packages.Table (The_Package).Decl.Variables; 1642 Name := Name_Of (Variable_Node); 1643 while Var_Id /= No_Variable 1644 and then 1645 Variable_Elements.Table (Var_Id).Name /= Name 1646 loop 1647 Var_Id := Variable_Elements.Table (Var_Id).Next; 1648 end loop; 1649 end if; 1650 1651 -- If not found in the package, or if there is no 1652 -- package, look at the project level. 1653 1654 if Var_Id = No_Variable 1655 and then Package_Node_Of (Variable_Node) = Empty_Node 1656 then 1657 Var_Id := Projects.Table (The_Project).Decl.Variables; 1658 while Var_Id /= No_Variable 1659 and then 1660 Variable_Elements.Table (Var_Id).Name /= Name 1661 loop 1662 Var_Id := Variable_Elements.Table (Var_Id).Next; 1663 end loop; 1664 end if; 1665 1666 if Var_Id = No_Variable then 1667 1668 -- Should never happen, because this has already been 1669 -- checked during parsing. 1670 1671 Write_Line ("variable """ & 1672 Get_Name_String (Name) & 1673 """ not found"); 1674 raise Program_Error; 1675 end if; 1676 1677 -- Get the case variable 1678 1679 The_Variable := Variable_Elements.Table (Var_Id).Value; 1680 1681 if The_Variable.Kind /= Single then 1682 1683 -- Should never happen, because this has already been 1684 -- checked during parsing. 1685 1686 Write_Line ("variable""" & 1687 Get_Name_String (Name) & 1688 """ is not a single string variable"); 1689 raise Program_Error; 1690 end if; 1691 1692 -- Get the case variable value 1693 Case_Value := The_Variable.Value; 1694 end; 1695 1696 -- Now look into all the case items of the case construction 1697 1698 Case_Item := First_Case_Item_Of (Current_Item); 1699 Case_Item_Loop : 1700 while Case_Item /= Empty_Node loop 1701 Choice_String := First_Choice_Of (Case_Item); 1702 1703 -- When Choice_String is nil, it means that it is 1704 -- the "when others =>" alternative. 1705 1706 if Choice_String = Empty_Node then 1707 Decl_Item := First_Declarative_Item_Of (Case_Item); 1708 exit Case_Item_Loop; 1709 end if; 1710 1711 -- Look into all the alternative of this case item 1712 1713 Choice_Loop : 1714 while Choice_String /= Empty_Node loop 1715 if 1716 Case_Value = String_Value_Of (Choice_String) 1717 then 1718 Decl_Item := 1719 First_Declarative_Item_Of (Case_Item); 1720 exit Case_Item_Loop; 1721 end if; 1722 1723 Choice_String := 1724 Next_Literal_String (Choice_String); 1725 end loop Choice_Loop; 1726 Case_Item := Next_Case_Item (Case_Item); 1727 end loop Case_Item_Loop; 1728 1729 -- If there is an alternative, then we process it 1730 1731 if Decl_Item /= Empty_Node then 1732 Process_Declarative_Items 1733 (Project => Project, 1734 From_Project_Node => From_Project_Node, 1735 Pkg => Pkg, 1736 Item => Decl_Item); 1737 end if; 1738 end; 1739 1740 when others => 1741 1742 -- Should never happen 1743 1744 Write_Line ("Illegal declarative item: " & 1745 Project_Node_Kind'Image (Kind_Of (Current_Item))); 1746 raise Program_Error; 1747 end case; 1748 end loop; 1749 end Process_Declarative_Items; 1750 1751 --------------------- 1752 -- Recursive_Check -- 1753 --------------------- 1754 1755 procedure Recursive_Check (Project : Project_Id) is 1756 Data : Project_Data; 1757 Imported_Project_List : Project_List := Empty_Project_List; 1758 1759 begin 1760 -- Do nothing if Project is No_Project, or Project has already 1761 -- been marked as checked. 1762 1763 if Project /= No_Project 1764 and then not Projects.Table (Project).Checked 1765 then 1766 -- Mark project as checked, to avoid infinite recursion in 1767 -- ill-formed trees, where a project imports itself. 1768 1769 Projects.Table (Project).Checked := True; 1770 1771 Data := Projects.Table (Project); 1772 1773 -- Call itself for a possible extended project. 1774 -- (if there is no extended project, then nothing happens). 1775 1776 Recursive_Check (Data.Extends); 1777 1778 -- Call itself for all imported projects 1779 1780 Imported_Project_List := Data.Imported_Projects; 1781 while Imported_Project_List /= Empty_Project_List loop 1782 Recursive_Check 1783 (Project_Lists.Table (Imported_Project_List).Project); 1784 Imported_Project_List := 1785 Project_Lists.Table (Imported_Project_List).Next; 1786 end loop; 1787 1788 if Opt.Verbose_Mode then 1789 Write_Str ("Checking project file """); 1790 Write_Str (Get_Name_String (Data.Name)); 1791 Write_Line (""""); 1792 end if; 1793 1794 Prj.Nmsc.Ada_Check (Project, Error_Report); 1795 end if; 1796 end Recursive_Check; 1797 1798 ----------------------- 1799 -- Recursive_Process -- 1800 ----------------------- 1801 1802 procedure Recursive_Process 1803 (Project : out Project_Id; 1804 From_Project_Node : Project_Node_Id; 1805 Extended_By : Project_Id) 1806 is 1807 With_Clause : Project_Node_Id; 1808 1809 begin 1810 if From_Project_Node = Empty_Node then 1811 Project := No_Project; 1812 1813 else 1814 declare 1815 Processed_Data : Project_Data := Empty_Project; 1816 Imported : Project_List := Empty_Project_List; 1817 Declaration_Node : Project_Node_Id := Empty_Node; 1818 Name : constant Name_Id := 1819 Name_Of (From_Project_Node); 1820 1821 begin 1822 Project := Processed_Projects.Get (Name); 1823 1824 if Project /= No_Project then 1825 return; 1826 end if; 1827 1828 Projects.Increment_Last; 1829 Project := Projects.Last; 1830 Processed_Projects.Set (Name, Project); 1831 1832 Processed_Data.Name := Name; 1833 1834 Get_Name_String (Name); 1835 1836 -- If name starts with the virtual prefix, flag the project as 1837 -- being a virtual extending project. 1838 1839 if Name_Len > Virtual_Prefix'Length 1840 and then Name_Buffer (1 .. Virtual_Prefix'Length) = 1841 Virtual_Prefix 1842 then 1843 Processed_Data.Virtual := True; 1844 end if; 1845 1846 Processed_Data.Display_Path_Name := 1847 Path_Name_Of (From_Project_Node); 1848 Get_Name_String (Processed_Data.Display_Path_Name); 1849 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); 1850 Processed_Data.Path_Name := Name_Find; 1851 1852 Processed_Data.Location := Location_Of (From_Project_Node); 1853 1854 Processed_Data.Display_Directory := 1855 Directory_Of (From_Project_Node); 1856 Get_Name_String (Processed_Data.Display_Directory); 1857 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); 1858 Processed_Data.Directory := Name_Find; 1859 1860 Processed_Data.Extended_By := Extended_By; 1861 Processed_Data.Naming := Standard_Naming_Data; 1862 1863 Add_Attributes (Project, Processed_Data.Decl, Attribute_First); 1864 With_Clause := First_With_Clause_Of (From_Project_Node); 1865 1866 while With_Clause /= Empty_Node loop 1867 declare 1868 New_Project : Project_Id; 1869 New_Data : Project_Data; 1870 1871 begin 1872 Recursive_Process 1873 (Project => New_Project, 1874 From_Project_Node => Project_Node_Of (With_Clause), 1875 Extended_By => No_Project); 1876 New_Data := Projects.Table (New_Project); 1877 1878 -- If we were the first project to import it, 1879 -- set First_Referred_By to us. 1880 1881 if New_Data.First_Referred_By = No_Project then 1882 New_Data.First_Referred_By := Project; 1883 Projects.Table (New_Project) := New_Data; 1884 end if; 1885 1886 -- Add this project to our list of imported projects 1887 1888 Project_Lists.Increment_Last; 1889 Project_Lists.Table (Project_Lists.Last) := 1890 (Project => New_Project, Next => Empty_Project_List); 1891 1892 -- Imported is the id of the last imported project. 1893 -- If it is nil, then this imported project is our first. 1894 1895 if Imported = Empty_Project_List then 1896 Processed_Data.Imported_Projects := Project_Lists.Last; 1897 1898 else 1899 Project_Lists.Table (Imported).Next := Project_Lists.Last; 1900 end if; 1901 1902 Imported := Project_Lists.Last; 1903 1904 With_Clause := Next_With_Clause_Of (With_Clause); 1905 end; 1906 end loop; 1907 1908 Declaration_Node := Project_Declaration_Of (From_Project_Node); 1909 1910 Recursive_Process 1911 (Project => Processed_Data.Extends, 1912 From_Project_Node => Extended_Project_Of (Declaration_Node), 1913 Extended_By => Project); 1914 1915 Projects.Table (Project) := Processed_Data; 1916 1917 Process_Declarative_Items 1918 (Project => Project, 1919 From_Project_Node => From_Project_Node, 1920 Pkg => No_Package, 1921 Item => First_Declarative_Item_Of 1922 (Declaration_Node)); 1923 1924 -- If it is an extending project, inherit all packages 1925 -- from the extended project that are not explicitely defined 1926 -- or renamed. 1927 1928 if Processed_Data.Extends /= No_Project then 1929 Processed_Data := Projects.Table (Project); 1930 1931 declare 1932 Extended_Pkg : Package_Id := 1933 Projects.Table 1934 (Processed_Data.Extends).Decl.Packages; 1935 Current_Pkg : Package_Id; 1936 Element : Package_Element; 1937 First : constant Package_Id := 1938 Processed_Data.Decl.Packages; 1939 1940 begin 1941 while Extended_Pkg /= No_Package loop 1942 Element := Packages.Table (Extended_Pkg); 1943 1944 Current_Pkg := First; 1945 1946 loop 1947 exit when Current_Pkg = No_Package 1948 or else Packages.Table (Current_Pkg).Name 1949 = Element.Name; 1950 Current_Pkg := Packages.Table (Current_Pkg).Next; 1951 end loop; 1952 1953 if Current_Pkg = No_Package then 1954 Packages.Increment_Last; 1955 Current_Pkg := Packages.Last; 1956 Packages.Table (Current_Pkg) := 1957 (Name => Element.Name, 1958 Decl => Element.Decl, 1959 Parent => No_Package, 1960 Next => Processed_Data.Decl.Packages); 1961 Processed_Data.Decl.Packages := Current_Pkg; 1962 end if; 1963 1964 Extended_Pkg := Element.Next; 1965 end loop; 1966 end; 1967 1968 Projects.Table (Project) := Processed_Data; 1969 end if; 1970 end; 1971 end if; 1972 end Recursive_Process; 1973 1974end Prj.Proc; 1975