1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- P R J . S T R T -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2001-2010, 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 Err_Vars; use Err_Vars; 27with Prj.Attr; use Prj.Attr; 28with Prj.Err; use Prj.Err; 29with Snames; 30with Table; 31with Uintp; use Uintp; 32 33package body Prj.Strt is 34 35 Buffer : String_Access; 36 Buffer_Last : Natural := 0; 37 38 type Choice_String is record 39 The_String : Name_Id; 40 Already_Used : Boolean := False; 41 end record; 42 -- The string of a case label, and an indication that it has already 43 -- been used (to avoid duplicate case labels). 44 45 Choices_Initial : constant := 10; 46 Choices_Increment : constant := 100; 47 -- These should be in alloc.ads 48 49 Choice_Node_Low_Bound : constant := 0; 50 Choice_Node_High_Bound : constant := 099_999_999; 51 -- In practice, infinite 52 53 type Choice_Node_Id is 54 range Choice_Node_Low_Bound .. Choice_Node_High_Bound; 55 56 First_Choice_Node_Id : constant Choice_Node_Id := 57 Choice_Node_Low_Bound; 58 59 package Choices is 60 new Table.Table 61 (Table_Component_Type => Choice_String, 62 Table_Index_Type => Choice_Node_Id'Base, 63 Table_Low_Bound => First_Choice_Node_Id, 64 Table_Initial => Choices_Initial, 65 Table_Increment => Choices_Increment, 66 Table_Name => "Prj.Strt.Choices"); 67 -- Used to store the case labels and check that there is no duplicate 68 69 package Choice_Lasts is 70 new Table.Table 71 (Table_Component_Type => Choice_Node_Id, 72 Table_Index_Type => Nat, 73 Table_Low_Bound => 1, 74 Table_Initial => 10, 75 Table_Increment => 100, 76 Table_Name => "Prj.Strt.Choice_Lasts"); 77 -- Used to store the indexes of the choices in table Choices, to 78 -- distinguish nested case constructions. 79 80 Choice_First : Choice_Node_Id := 0; 81 -- Index in table Choices of the first case label of the current 82 -- case construction. Zero means no current case construction. 83 84 type Name_Location is record 85 Name : Name_Id := No_Name; 86 Location : Source_Ptr := No_Location; 87 end record; 88 -- Store the identifier and the location of a simple name 89 90 package Names is 91 new Table.Table 92 (Table_Component_Type => Name_Location, 93 Table_Index_Type => Nat, 94 Table_Low_Bound => 1, 95 Table_Initial => 10, 96 Table_Increment => 100, 97 Table_Name => "Prj.Strt.Names"); 98 -- Used to accumulate the single names of a name 99 100 procedure Add (This_String : Name_Id); 101 -- Add a string to the case label list, indicating that it has not 102 -- yet been used. 103 104 procedure Add_To_Names (NL : Name_Location); 105 -- Add one single names to table Names 106 107 procedure External_Reference 108 (In_Tree : Project_Node_Tree_Ref; 109 Current_Project : Project_Node_Id; 110 Current_Package : Project_Node_Id; 111 External_Value : out Project_Node_Id; 112 Expr_Kind : in out Variable_Kind; 113 Flags : Processing_Flags); 114 -- Parse an external reference. Current token is "external" 115 116 procedure Attribute_Reference 117 (In_Tree : Project_Node_Tree_Ref; 118 Reference : out Project_Node_Id; 119 First_Attribute : Attribute_Node_Id; 120 Current_Project : Project_Node_Id; 121 Current_Package : Project_Node_Id; 122 Flags : Processing_Flags); 123 -- Parse an attribute reference. Current token is an apostrophe 124 125 procedure Terms 126 (In_Tree : Project_Node_Tree_Ref; 127 Term : out Project_Node_Id; 128 Expr_Kind : in out Variable_Kind; 129 Current_Project : Project_Node_Id; 130 Current_Package : Project_Node_Id; 131 Optional_Index : Boolean; 132 Flags : Processing_Flags); 133 -- Recursive procedure to parse one term or several terms concatenated 134 -- using "&". 135 136 --------- 137 -- Add -- 138 --------- 139 140 procedure Add (This_String : Name_Id) is 141 begin 142 Choices.Increment_Last; 143 Choices.Table (Choices.Last) := 144 (The_String => This_String, 145 Already_Used => False); 146 end Add; 147 148 ------------------ 149 -- Add_To_Names -- 150 ------------------ 151 152 procedure Add_To_Names (NL : Name_Location) is 153 begin 154 Names.Increment_Last; 155 Names.Table (Names.Last) := NL; 156 end Add_To_Names; 157 158 ------------------------- 159 -- Attribute_Reference -- 160 ------------------------- 161 162 procedure Attribute_Reference 163 (In_Tree : Project_Node_Tree_Ref; 164 Reference : out Project_Node_Id; 165 First_Attribute : Attribute_Node_Id; 166 Current_Project : Project_Node_Id; 167 Current_Package : Project_Node_Id; 168 Flags : Processing_Flags) 169 is 170 Current_Attribute : Attribute_Node_Id := First_Attribute; 171 172 begin 173 -- Declare the node of the attribute reference 174 175 Reference := 176 Default_Project_Node 177 (Of_Kind => N_Attribute_Reference, In_Tree => In_Tree); 178 Set_Location_Of (Reference, In_Tree, To => Token_Ptr); 179 Scan (In_Tree); -- past apostrophe 180 181 -- Body may be an attribute name 182 183 if Token = Tok_Body then 184 Token := Tok_Identifier; 185 Token_Name := Snames.Name_Body; 186 end if; 187 188 Expect (Tok_Identifier, "identifier"); 189 190 if Token = Tok_Identifier then 191 Set_Name_Of (Reference, In_Tree, To => Token_Name); 192 193 -- Check if the identifier is one of the attribute identifiers in the 194 -- context (package or project level attributes). 195 196 Current_Attribute := 197 Attribute_Node_Id_Of (Token_Name, Starting_At => First_Attribute); 198 199 -- If the identifier is not allowed, report an error 200 201 if Current_Attribute = Empty_Attribute then 202 Error_Msg_Name_1 := Token_Name; 203 Error_Msg (Flags, "unknown attribute %%", Token_Ptr); 204 Reference := Empty_Node; 205 206 -- Scan past the attribute name 207 208 Scan (In_Tree); 209 210 else 211 -- Give its characteristics to this attribute reference 212 213 Set_Project_Node_Of (Reference, In_Tree, To => Current_Project); 214 Set_Package_Node_Of (Reference, In_Tree, To => Current_Package); 215 Set_Expression_Kind_Of 216 (Reference, In_Tree, To => Variable_Kind_Of (Current_Attribute)); 217 Set_Case_Insensitive 218 (Reference, In_Tree, 219 To => Attribute_Kind_Of (Current_Attribute) in 220 All_Case_Insensitive_Associative_Array); 221 222 -- Scan past the attribute name 223 224 Scan (In_Tree); 225 226 -- If the attribute is an associative array, get the index 227 228 if Attribute_Kind_Of (Current_Attribute) /= Single then 229 Expect (Tok_Left_Paren, "`(`"); 230 231 if Token = Tok_Left_Paren then 232 Scan (In_Tree); 233 234 if Others_Allowed_For (Current_Attribute) 235 and then Token = Tok_Others 236 then 237 Set_Associative_Array_Index_Of 238 (Reference, In_Tree, To => All_Other_Names); 239 Scan (In_Tree); 240 241 else 242 if Others_Allowed_For (Current_Attribute) then 243 Expect 244 (Tok_String_Literal, "literal string or others"); 245 else 246 Expect (Tok_String_Literal, "literal string"); 247 end if; 248 249 if Token = Tok_String_Literal then 250 Set_Associative_Array_Index_Of 251 (Reference, In_Tree, To => Token_Name); 252 Scan (In_Tree); 253 end if; 254 end if; 255 end if; 256 257 Expect (Tok_Right_Paren, "`)`"); 258 259 if Token = Tok_Right_Paren then 260 Scan (In_Tree); 261 end if; 262 end if; 263 end if; 264 265 -- Change name of obsolete attributes 266 267 if Present (Reference) then 268 case Name_Of (Reference, In_Tree) is 269 when Snames.Name_Specification => 270 Set_Name_Of (Reference, In_Tree, To => Snames.Name_Spec); 271 272 when Snames.Name_Specification_Suffix => 273 Set_Name_Of 274 (Reference, In_Tree, To => Snames.Name_Spec_Suffix); 275 276 when Snames.Name_Implementation => 277 Set_Name_Of (Reference, In_Tree, To => Snames.Name_Body); 278 279 when Snames.Name_Implementation_Suffix => 280 Set_Name_Of 281 (Reference, In_Tree, To => Snames.Name_Body_Suffix); 282 283 when others => 284 null; 285 end case; 286 end if; 287 end if; 288 end Attribute_Reference; 289 290 --------------------------- 291 -- End_Case_Construction -- 292 --------------------------- 293 294 procedure End_Case_Construction 295 (Check_All_Labels : Boolean; 296 Case_Location : Source_Ptr; 297 Flags : Processing_Flags) 298 is 299 Non_Used : Natural := 0; 300 First_Non_Used : Choice_Node_Id := First_Choice_Node_Id; 301 begin 302 -- First, if Check_All_Labels is True, check if all values 303 -- of the string type have been used. 304 305 if Check_All_Labels then 306 for Choice in Choice_First .. Choices.Last loop 307 if not Choices.Table (Choice).Already_Used then 308 Non_Used := Non_Used + 1; 309 310 if Non_Used = 1 then 311 First_Non_Used := Choice; 312 end if; 313 end if; 314 end loop; 315 316 -- If only one is not used, report a single warning for this value 317 318 if Non_Used = 1 then 319 Error_Msg_Name_1 := Choices.Table (First_Non_Used).The_String; 320 Error_Msg (Flags, "?value %% is not used as label", Case_Location); 321 322 -- If several are not used, report a warning for each one of them 323 324 elsif Non_Used > 1 then 325 Error_Msg 326 (Flags, "?the following values are not used as labels:", 327 Case_Location); 328 329 for Choice in First_Non_Used .. Choices.Last loop 330 if not Choices.Table (Choice).Already_Used then 331 Error_Msg_Name_1 := Choices.Table (Choice).The_String; 332 Error_Msg (Flags, "\?%%", Case_Location); 333 end if; 334 end loop; 335 end if; 336 end if; 337 338 -- If this is the only case construction, empty the tables 339 340 if Choice_Lasts.Last = 1 then 341 Choice_Lasts.Set_Last (0); 342 Choices.Set_Last (First_Choice_Node_Id); 343 Choice_First := 0; 344 345 elsif Choice_Lasts.Last = 2 then 346 347 -- This is the second case construction, set the tables to the first 348 349 Choice_Lasts.Set_Last (1); 350 Choices.Set_Last (Choice_Lasts.Table (1)); 351 Choice_First := 1; 352 353 else 354 -- This is the 3rd or more case construction, set the tables to the 355 -- previous one. 356 357 Choice_Lasts.Decrement_Last; 358 Choices.Set_Last (Choice_Lasts.Table (Choice_Lasts.Last)); 359 Choice_First := Choice_Lasts.Table (Choice_Lasts.Last - 1) + 1; 360 end if; 361 end End_Case_Construction; 362 363 ------------------------ 364 -- External_Reference -- 365 ------------------------ 366 367 procedure External_Reference 368 (In_Tree : Project_Node_Tree_Ref; 369 Current_Project : Project_Node_Id; 370 Current_Package : Project_Node_Id; 371 External_Value : out Project_Node_Id; 372 Expr_Kind : in out Variable_Kind; 373 Flags : Processing_Flags) 374 is 375 Field_Id : Project_Node_Id := Empty_Node; 376 Ext_List : Boolean := False; 377 378 begin 379 External_Value := 380 Default_Project_Node 381 (Of_Kind => N_External_Value, 382 In_Tree => In_Tree); 383 Set_Location_Of (External_Value, In_Tree, To => Token_Ptr); 384 385 -- The current token is either external or external_as_list 386 387 Ext_List := Token = Tok_External_As_List; 388 Scan (In_Tree); 389 390 if Ext_List then 391 Set_Expression_Kind_Of (External_Value, In_Tree, To => List); 392 else 393 Set_Expression_Kind_Of (External_Value, In_Tree, To => Single); 394 end if; 395 396 if Expr_Kind = Undefined then 397 if Ext_List then 398 Expr_Kind := List; 399 else 400 Expr_Kind := Single; 401 end if; 402 end if; 403 404 Expect (Tok_Left_Paren, "`(`"); 405 406 -- Scan past the left parenthesis 407 408 if Token = Tok_Left_Paren then 409 Scan (In_Tree); 410 end if; 411 412 -- Get the name of the external reference 413 414 Expect (Tok_String_Literal, "literal string"); 415 416 if Token = Tok_String_Literal then 417 Field_Id := 418 Default_Project_Node 419 (Of_Kind => N_Literal_String, 420 In_Tree => In_Tree, 421 And_Expr_Kind => Single); 422 Set_String_Value_Of (Field_Id, In_Tree, To => Token_Name); 423 Set_External_Reference_Of (External_Value, In_Tree, To => Field_Id); 424 425 -- Scan past the first argument 426 427 Scan (In_Tree); 428 429 case Token is 430 431 when Tok_Right_Paren => 432 if Ext_List then 433 Error_Msg (Flags, "`,` expected", Token_Ptr); 434 end if; 435 436 Scan (In_Tree); -- scan past right paren 437 438 when Tok_Comma => 439 Scan (In_Tree); -- scan past comma 440 441 -- Get the string expression for the default 442 443 declare 444 Loc : constant Source_Ptr := Token_Ptr; 445 446 begin 447 Parse_Expression 448 (In_Tree => In_Tree, 449 Expression => Field_Id, 450 Flags => Flags, 451 Current_Project => Current_Project, 452 Current_Package => Current_Package, 453 Optional_Index => False); 454 455 if Expression_Kind_Of (Field_Id, In_Tree) = List then 456 Error_Msg 457 (Flags, "expression must be a single string", Loc); 458 else 459 Set_External_Default_Of 460 (External_Value, In_Tree, To => Field_Id); 461 end if; 462 end; 463 464 Expect (Tok_Right_Paren, "`)`"); 465 466 if Token = Tok_Right_Paren then 467 Scan (In_Tree); -- scan past right paren 468 end if; 469 470 when others => 471 if Ext_List then 472 Error_Msg (Flags, "`,` expected", Token_Ptr); 473 else 474 Error_Msg (Flags, "`,` or `)` expected", Token_Ptr); 475 end if; 476 end case; 477 end if; 478 end External_Reference; 479 480 ----------------------- 481 -- Parse_Choice_List -- 482 ----------------------- 483 484 procedure Parse_Choice_List 485 (In_Tree : Project_Node_Tree_Ref; 486 First_Choice : out Project_Node_Id; 487 Flags : Processing_Flags) 488 is 489 Current_Choice : Project_Node_Id := Empty_Node; 490 Next_Choice : Project_Node_Id := Empty_Node; 491 Choice_String : Name_Id := No_Name; 492 Found : Boolean := False; 493 494 begin 495 -- Declare the node of the first choice 496 497 First_Choice := 498 Default_Project_Node 499 (Of_Kind => N_Literal_String, 500 In_Tree => In_Tree, 501 And_Expr_Kind => Single); 502 503 -- Initially Current_Choice is the same as First_Choice 504 505 Current_Choice := First_Choice; 506 507 loop 508 Expect (Tok_String_Literal, "literal string"); 509 exit when Token /= Tok_String_Literal; 510 Set_Location_Of (Current_Choice, In_Tree, To => Token_Ptr); 511 Choice_String := Token_Name; 512 513 -- Give the string value to the current choice 514 515 Set_String_Value_Of (Current_Choice, In_Tree, To => Choice_String); 516 517 -- Check if the label is part of the string type and if it has not 518 -- been already used. 519 520 Found := False; 521 for Choice in Choice_First .. Choices.Last loop 522 if Choices.Table (Choice).The_String = Choice_String then 523 524 -- This label is part of the string type 525 526 Found := True; 527 528 if Choices.Table (Choice).Already_Used then 529 530 -- But it has already appeared in a choice list for this 531 -- case construction so report an error. 532 533 Error_Msg_Name_1 := Choice_String; 534 Error_Msg (Flags, "duplicate case label %%", Token_Ptr); 535 536 else 537 Choices.Table (Choice).Already_Used := True; 538 end if; 539 540 exit; 541 end if; 542 end loop; 543 544 -- If the label is not part of the string list, report an error 545 546 if not Found then 547 Error_Msg_Name_1 := Choice_String; 548 Error_Msg (Flags, "illegal case label %%", Token_Ptr); 549 end if; 550 551 -- Scan past the label 552 553 Scan (In_Tree); 554 555 -- If there is no '|', we are done 556 557 if Token = Tok_Vertical_Bar then 558 559 -- Otherwise, declare the node of the next choice, link it to 560 -- Current_Choice and set Current_Choice to this new node. 561 562 Next_Choice := 563 Default_Project_Node 564 (Of_Kind => N_Literal_String, 565 In_Tree => In_Tree, 566 And_Expr_Kind => Single); 567 Set_Next_Literal_String 568 (Current_Choice, In_Tree, To => Next_Choice); 569 Current_Choice := Next_Choice; 570 Scan (In_Tree); 571 else 572 exit; 573 end if; 574 end loop; 575 end Parse_Choice_List; 576 577 ---------------------- 578 -- Parse_Expression -- 579 ---------------------- 580 581 procedure Parse_Expression 582 (In_Tree : Project_Node_Tree_Ref; 583 Expression : out Project_Node_Id; 584 Current_Project : Project_Node_Id; 585 Current_Package : Project_Node_Id; 586 Optional_Index : Boolean; 587 Flags : Processing_Flags) 588 is 589 First_Term : Project_Node_Id := Empty_Node; 590 Expression_Kind : Variable_Kind := Undefined; 591 592 begin 593 -- Declare the node of the expression 594 595 Expression := 596 Default_Project_Node (Of_Kind => N_Expression, In_Tree => In_Tree); 597 Set_Location_Of (Expression, In_Tree, To => Token_Ptr); 598 599 -- Parse the term or terms of the expression 600 601 Terms (In_Tree => In_Tree, 602 Term => First_Term, 603 Expr_Kind => Expression_Kind, 604 Flags => Flags, 605 Current_Project => Current_Project, 606 Current_Package => Current_Package, 607 Optional_Index => Optional_Index); 608 609 -- Set the first term and the expression kind 610 611 Set_First_Term (Expression, In_Tree, To => First_Term); 612 Set_Expression_Kind_Of (Expression, In_Tree, To => Expression_Kind); 613 end Parse_Expression; 614 615 ---------------------------- 616 -- Parse_String_Type_List -- 617 ---------------------------- 618 619 procedure Parse_String_Type_List 620 (In_Tree : Project_Node_Tree_Ref; 621 First_String : out Project_Node_Id; 622 Flags : Processing_Flags) 623 is 624 Last_String : Project_Node_Id := Empty_Node; 625 Next_String : Project_Node_Id := Empty_Node; 626 String_Value : Name_Id := No_Name; 627 628 begin 629 -- Declare the node of the first string 630 631 First_String := 632 Default_Project_Node 633 (Of_Kind => N_Literal_String, 634 In_Tree => In_Tree, 635 And_Expr_Kind => Single); 636 637 -- Initially, Last_String is the same as First_String 638 639 Last_String := First_String; 640 641 loop 642 Expect (Tok_String_Literal, "literal string"); 643 exit when Token /= Tok_String_Literal; 644 String_Value := Token_Name; 645 646 -- Give its string value to Last_String 647 648 Set_String_Value_Of (Last_String, In_Tree, To => String_Value); 649 Set_Location_Of (Last_String, In_Tree, To => Token_Ptr); 650 651 -- Now, check if the string is already part of the string type 652 653 declare 654 Current : Project_Node_Id := First_String; 655 656 begin 657 while Current /= Last_String loop 658 if String_Value_Of (Current, In_Tree) = String_Value then 659 660 -- This is a repetition, report an error 661 662 Error_Msg_Name_1 := String_Value; 663 Error_Msg (Flags, "duplicate value %% in type", Token_Ptr); 664 exit; 665 end if; 666 667 Current := Next_Literal_String (Current, In_Tree); 668 end loop; 669 end; 670 671 -- Scan past the literal string 672 673 Scan (In_Tree); 674 675 -- If there is no comma following the literal string, we are done 676 677 if Token /= Tok_Comma then 678 exit; 679 680 else 681 -- Declare the next string, link it to Last_String and set 682 -- Last_String to its node. 683 684 Next_String := 685 Default_Project_Node 686 (Of_Kind => N_Literal_String, 687 In_Tree => In_Tree, 688 And_Expr_Kind => Single); 689 Set_Next_Literal_String (Last_String, In_Tree, To => Next_String); 690 Last_String := Next_String; 691 Scan (In_Tree); 692 end if; 693 end loop; 694 end Parse_String_Type_List; 695 696 ------------------------------ 697 -- Parse_Variable_Reference -- 698 ------------------------------ 699 700 procedure Parse_Variable_Reference 701 (In_Tree : Project_Node_Tree_Ref; 702 Variable : out Project_Node_Id; 703 Current_Project : Project_Node_Id; 704 Current_Package : Project_Node_Id; 705 Flags : Processing_Flags) 706 is 707 Current_Variable : Project_Node_Id := Empty_Node; 708 709 The_Package : Project_Node_Id := Current_Package; 710 The_Project : Project_Node_Id := Current_Project; 711 712 Specified_Project : Project_Node_Id := Empty_Node; 713 Specified_Package : Project_Node_Id := Empty_Node; 714 Look_For_Variable : Boolean := True; 715 First_Attribute : Attribute_Node_Id := Empty_Attribute; 716 Variable_Name : Name_Id; 717 718 begin 719 Names.Init; 720 721 loop 722 Expect (Tok_Identifier, "identifier"); 723 724 if Token /= Tok_Identifier then 725 Look_For_Variable := False; 726 exit; 727 end if; 728 729 Add_To_Names (NL => (Name => Token_Name, Location => Token_Ptr)); 730 Scan (In_Tree); 731 exit when Token /= Tok_Dot; 732 Scan (In_Tree); 733 end loop; 734 735 if Look_For_Variable then 736 737 if Token = Tok_Apostrophe then 738 739 -- Attribute reference 740 741 case Names.Last is 742 when 0 => 743 744 -- Cannot happen 745 746 null; 747 748 when 1 => 749 -- This may be a project name or a package name. 750 -- Project name have precedence. 751 752 -- First, look if it can be a package name 753 754 First_Attribute := 755 First_Attribute_Of 756 (Package_Node_Id_Of (Names.Table (1).Name)); 757 758 -- Now, look if it can be a project name 759 760 if Names.Table (1).Name = 761 Name_Of (Current_Project, In_Tree) 762 then 763 The_Project := Current_Project; 764 765 else 766 The_Project := 767 Imported_Or_Extended_Project_Of 768 (Current_Project, In_Tree, Names.Table (1).Name); 769 end if; 770 771 if No (The_Project) then 772 773 -- If it is neither a project name nor a package name, 774 -- report an error. 775 776 if First_Attribute = Empty_Attribute then 777 Error_Msg_Name_1 := Names.Table (1).Name; 778 Error_Msg (Flags, "unknown project %", 779 Names.Table (1).Location); 780 First_Attribute := Attribute_First; 781 782 else 783 -- If it is a package name, check if the package has 784 -- already been declared in the current project. 785 786 The_Package := 787 First_Package_Of (Current_Project, In_Tree); 788 789 while Present (The_Package) 790 and then Name_Of (The_Package, In_Tree) /= 791 Names.Table (1).Name 792 loop 793 The_Package := 794 Next_Package_In_Project (The_Package, In_Tree); 795 end loop; 796 797 -- If it has not been already declared, report an 798 -- error. 799 800 if No (The_Package) then 801 Error_Msg_Name_1 := Names.Table (1).Name; 802 Error_Msg (Flags, "package % not yet defined", 803 Names.Table (1).Location); 804 end if; 805 end if; 806 807 else 808 -- It is a project name 809 810 First_Attribute := Attribute_First; 811 The_Package := Empty_Node; 812 end if; 813 814 when others => 815 816 -- We have either a project name made of several simple 817 -- names (long project), or a project name (short project) 818 -- followed by a package name. The long project name has 819 -- precedence. 820 821 declare 822 Short_Project : Name_Id; 823 Long_Project : Name_Id; 824 825 begin 826 -- Clear the Buffer 827 828 Buffer_Last := 0; 829 830 -- Get the name of the short project 831 832 for Index in 1 .. Names.Last - 1 loop 833 Add_To_Buffer 834 (Get_Name_String (Names.Table (Index).Name), 835 Buffer, Buffer_Last); 836 837 if Index /= Names.Last - 1 then 838 Add_To_Buffer (".", Buffer, Buffer_Last); 839 end if; 840 end loop; 841 842 Name_Len := Buffer_Last; 843 Name_Buffer (1 .. Buffer_Last) := 844 Buffer (1 .. Buffer_Last); 845 Short_Project := Name_Find; 846 847 -- Now, add the last simple name to get the name of the 848 -- long project. 849 850 Add_To_Buffer (".", Buffer, Buffer_Last); 851 Add_To_Buffer 852 (Get_Name_String (Names.Table (Names.Last).Name), 853 Buffer, Buffer_Last); 854 Name_Len := Buffer_Last; 855 Name_Buffer (1 .. Buffer_Last) := 856 Buffer (1 .. Buffer_Last); 857 Long_Project := Name_Find; 858 859 -- Check if the long project is imported or extended 860 861 if Long_Project = Name_Of (Current_Project, In_Tree) then 862 The_Project := Current_Project; 863 864 else 865 The_Project := 866 Imported_Or_Extended_Project_Of 867 (Current_Project, 868 In_Tree, 869 Long_Project); 870 end if; 871 872 -- If the long project exists, then this is the prefix 873 -- of the attribute. 874 875 if Present (The_Project) then 876 First_Attribute := Attribute_First; 877 The_Package := Empty_Node; 878 879 else 880 -- Otherwise, check if the short project is imported 881 -- or extended. 882 883 if Short_Project = 884 Name_Of (Current_Project, In_Tree) 885 then 886 The_Project := Current_Project; 887 888 else 889 The_Project := Imported_Or_Extended_Project_Of 890 (Current_Project, In_Tree, 891 Short_Project); 892 end if; 893 894 -- If short project does not exist, report an error 895 896 if No (The_Project) then 897 Error_Msg_Name_1 := Long_Project; 898 Error_Msg_Name_2 := Short_Project; 899 Error_Msg (Flags, "unknown projects % or %", 900 Names.Table (1).Location); 901 The_Package := Empty_Node; 902 First_Attribute := Attribute_First; 903 904 else 905 -- Now, we check if the package has been declared 906 -- in this project. 907 908 The_Package := 909 First_Package_Of (The_Project, In_Tree); 910 while Present (The_Package) 911 and then Name_Of (The_Package, In_Tree) /= 912 Names.Table (Names.Last).Name 913 loop 914 The_Package := 915 Next_Package_In_Project (The_Package, In_Tree); 916 end loop; 917 918 -- If it has not, then we report an error 919 920 if No (The_Package) then 921 Error_Msg_Name_1 := 922 Names.Table (Names.Last).Name; 923 Error_Msg_Name_2 := Short_Project; 924 Error_Msg (Flags, 925 "package % not declared in project %", 926 Names.Table (Names.Last).Location); 927 First_Attribute := Attribute_First; 928 929 else 930 -- Otherwise, we have the correct project and 931 -- package. 932 933 First_Attribute := 934 First_Attribute_Of 935 (Package_Id_Of (The_Package, In_Tree)); 936 end if; 937 end if; 938 end if; 939 end; 940 end case; 941 942 Attribute_Reference 943 (In_Tree, 944 Variable, 945 Flags => Flags, 946 Current_Project => The_Project, 947 Current_Package => The_Package, 948 First_Attribute => First_Attribute); 949 return; 950 end if; 951 end if; 952 953 Variable := 954 Default_Project_Node 955 (Of_Kind => N_Variable_Reference, In_Tree => In_Tree); 956 957 if Look_For_Variable then 958 case Names.Last is 959 when 0 => 960 961 -- Cannot happen (so why null instead of raise PE???) 962 963 null; 964 965 when 1 => 966 967 -- Simple variable name 968 969 Set_Name_Of (Variable, In_Tree, To => Names.Table (1).Name); 970 971 when 2 => 972 973 -- Variable name with a simple name prefix that can be 974 -- a project name or a package name. Project names have 975 -- priority over package names. 976 977 Set_Name_Of (Variable, In_Tree, To => Names.Table (2).Name); 978 979 -- Check if it can be a package name 980 981 The_Package := First_Package_Of (Current_Project, In_Tree); 982 983 while Present (The_Package) 984 and then Name_Of (The_Package, In_Tree) /= 985 Names.Table (1).Name 986 loop 987 The_Package := 988 Next_Package_In_Project (The_Package, In_Tree); 989 end loop; 990 991 -- Now look for a possible project name 992 993 The_Project := Imported_Or_Extended_Project_Of 994 (Current_Project, In_Tree, Names.Table (1).Name); 995 996 if Present (The_Project) then 997 Specified_Project := The_Project; 998 999 elsif No (The_Package) then 1000 Error_Msg_Name_1 := Names.Table (1).Name; 1001 Error_Msg (Flags, "unknown package or project %", 1002 Names.Table (1).Location); 1003 Look_For_Variable := False; 1004 1005 else 1006 Specified_Package := The_Package; 1007 end if; 1008 1009 when others => 1010 1011 -- Variable name with a prefix that is either a project name 1012 -- made of several simple names, or a project name followed 1013 -- by a package name. 1014 1015 Set_Name_Of 1016 (Variable, In_Tree, To => Names.Table (Names.Last).Name); 1017 1018 declare 1019 Short_Project : Name_Id; 1020 Long_Project : Name_Id; 1021 1022 begin 1023 -- First, we get the two possible project names 1024 1025 -- Clear the buffer 1026 1027 Buffer_Last := 0; 1028 1029 -- Add all the simple names, except the last two 1030 1031 for Index in 1 .. Names.Last - 2 loop 1032 Add_To_Buffer 1033 (Get_Name_String (Names.Table (Index).Name), 1034 Buffer, Buffer_Last); 1035 1036 if Index /= Names.Last - 2 then 1037 Add_To_Buffer (".", Buffer, Buffer_Last); 1038 end if; 1039 end loop; 1040 1041 Name_Len := Buffer_Last; 1042 Name_Buffer (1 .. Name_Len) := Buffer (1 .. Buffer_Last); 1043 Short_Project := Name_Find; 1044 1045 -- Add the simple name before the name of the variable 1046 1047 Add_To_Buffer (".", Buffer, Buffer_Last); 1048 Add_To_Buffer 1049 (Get_Name_String (Names.Table (Names.Last - 1).Name), 1050 Buffer, Buffer_Last); 1051 Name_Len := Buffer_Last; 1052 Name_Buffer (1 .. Name_Len) := Buffer (1 .. Buffer_Last); 1053 Long_Project := Name_Find; 1054 1055 -- Check if the prefix is the name of an imported or 1056 -- extended project. 1057 1058 The_Project := Imported_Or_Extended_Project_Of 1059 (Current_Project, In_Tree, Long_Project); 1060 1061 if Present (The_Project) then 1062 Specified_Project := The_Project; 1063 1064 else 1065 -- Now check if the prefix may be a project name followed 1066 -- by a package name. 1067 1068 -- First check for a possible project name 1069 1070 The_Project := 1071 Imported_Or_Extended_Project_Of 1072 (Current_Project, In_Tree, Short_Project); 1073 1074 if No (The_Project) then 1075 -- Unknown prefix, report an error 1076 1077 Error_Msg_Name_1 := Long_Project; 1078 Error_Msg_Name_2 := Short_Project; 1079 Error_Msg 1080 (Flags, "unknown projects % or %", 1081 Names.Table (1).Location); 1082 Look_For_Variable := False; 1083 1084 else 1085 Specified_Project := The_Project; 1086 1087 -- Now look for the package in this project 1088 1089 The_Package := First_Package_Of (The_Project, In_Tree); 1090 1091 while Present (The_Package) 1092 and then Name_Of (The_Package, In_Tree) /= 1093 Names.Table (Names.Last - 1).Name 1094 loop 1095 The_Package := 1096 Next_Package_In_Project (The_Package, In_Tree); 1097 end loop; 1098 1099 if No (The_Package) then 1100 1101 -- The package does not exist, report an error 1102 1103 Error_Msg_Name_1 := Names.Table (2).Name; 1104 Error_Msg (Flags, "unknown package %", 1105 Names.Table (Names.Last - 1).Location); 1106 Look_For_Variable := False; 1107 1108 else 1109 Specified_Package := The_Package; 1110 end if; 1111 end if; 1112 end if; 1113 end; 1114 end case; 1115 end if; 1116 1117 if Look_For_Variable then 1118 Variable_Name := Name_Of (Variable, In_Tree); 1119 Set_Project_Node_Of (Variable, In_Tree, To => Specified_Project); 1120 Set_Package_Node_Of (Variable, In_Tree, To => Specified_Package); 1121 1122 if Present (Specified_Project) then 1123 The_Project := Specified_Project; 1124 else 1125 The_Project := Current_Project; 1126 end if; 1127 1128 Current_Variable := Empty_Node; 1129 1130 -- Look for this variable 1131 1132 -- If a package was specified, check if the variable has been 1133 -- declared in this package. 1134 1135 if Present (Specified_Package) then 1136 Current_Variable := 1137 First_Variable_Of (Specified_Package, In_Tree); 1138 while Present (Current_Variable) 1139 and then 1140 Name_Of (Current_Variable, In_Tree) /= Variable_Name 1141 loop 1142 Current_Variable := Next_Variable (Current_Variable, In_Tree); 1143 end loop; 1144 1145 else 1146 -- Otherwise, if no project has been specified and we are in 1147 -- a package, first check if the variable has been declared in 1148 -- the package. 1149 1150 if No (Specified_Project) 1151 and then Present (Current_Package) 1152 then 1153 Current_Variable := 1154 First_Variable_Of (Current_Package, In_Tree); 1155 while Present (Current_Variable) 1156 and then Name_Of (Current_Variable, In_Tree) /= Variable_Name 1157 loop 1158 Current_Variable := 1159 Next_Variable (Current_Variable, In_Tree); 1160 end loop; 1161 end if; 1162 1163 -- If we have not found the variable in the package, check if the 1164 -- variable has been declared in the project, or in any of its 1165 -- ancestors. 1166 1167 if No (Current_Variable) then 1168 declare 1169 Proj : Project_Node_Id := The_Project; 1170 1171 begin 1172 loop 1173 Current_Variable := First_Variable_Of (Proj, In_Tree); 1174 while 1175 Present (Current_Variable) 1176 and then 1177 Name_Of (Current_Variable, In_Tree) /= Variable_Name 1178 loop 1179 Current_Variable := 1180 Next_Variable (Current_Variable, In_Tree); 1181 end loop; 1182 1183 exit when Present (Current_Variable); 1184 1185 Proj := Parent_Project_Of (Proj, In_Tree); 1186 1187 Set_Project_Node_Of (Variable, In_Tree, To => Proj); 1188 1189 exit when No (Proj); 1190 end loop; 1191 end; 1192 end if; 1193 end if; 1194 1195 -- If the variable was not found, report an error 1196 1197 if No (Current_Variable) then 1198 Error_Msg_Name_1 := Variable_Name; 1199 Error_Msg 1200 (Flags, "unknown variable %", Names.Table (Names.Last).Location); 1201 end if; 1202 end if; 1203 1204 if Present (Current_Variable) then 1205 Set_Expression_Kind_Of 1206 (Variable, In_Tree, 1207 To => Expression_Kind_Of (Current_Variable, In_Tree)); 1208 1209 if Kind_Of (Current_Variable, In_Tree) = 1210 N_Typed_Variable_Declaration 1211 then 1212 Set_String_Type_Of 1213 (Variable, In_Tree, 1214 To => String_Type_Of (Current_Variable, In_Tree)); 1215 end if; 1216 end if; 1217 1218 -- If the variable is followed by a left parenthesis, report an error 1219 -- but attempt to scan the index. 1220 1221 if Token = Tok_Left_Paren then 1222 Error_Msg 1223 (Flags, "\variables cannot be associative arrays", Token_Ptr); 1224 Scan (In_Tree); 1225 Expect (Tok_String_Literal, "literal string"); 1226 1227 if Token = Tok_String_Literal then 1228 Scan (In_Tree); 1229 Expect (Tok_Right_Paren, "`)`"); 1230 1231 if Token = Tok_Right_Paren then 1232 Scan (In_Tree); 1233 end if; 1234 end if; 1235 end if; 1236 end Parse_Variable_Reference; 1237 1238 --------------------------------- 1239 -- Start_New_Case_Construction -- 1240 --------------------------------- 1241 1242 procedure Start_New_Case_Construction 1243 (In_Tree : Project_Node_Tree_Ref; 1244 String_Type : Project_Node_Id) 1245 is 1246 Current_String : Project_Node_Id; 1247 1248 begin 1249 -- Set Choice_First, depending on whether this is the first case 1250 -- construction or not. 1251 1252 if Choice_First = 0 then 1253 Choice_First := 1; 1254 Choices.Set_Last (First_Choice_Node_Id); 1255 else 1256 Choice_First := Choices.Last + 1; 1257 end if; 1258 1259 -- Add the literal of the string type to the Choices table 1260 1261 if Present (String_Type) then 1262 Current_String := First_Literal_String (String_Type, In_Tree); 1263 while Present (Current_String) loop 1264 Add (This_String => String_Value_Of (Current_String, In_Tree)); 1265 Current_String := Next_Literal_String (Current_String, In_Tree); 1266 end loop; 1267 end if; 1268 1269 -- Set the value of the last choice in table Choice_Lasts 1270 1271 Choice_Lasts.Increment_Last; 1272 Choice_Lasts.Table (Choice_Lasts.Last) := Choices.Last; 1273 end Start_New_Case_Construction; 1274 1275 ----------- 1276 -- Terms -- 1277 ----------- 1278 1279 procedure Terms 1280 (In_Tree : Project_Node_Tree_Ref; 1281 Term : out Project_Node_Id; 1282 Expr_Kind : in out Variable_Kind; 1283 Current_Project : Project_Node_Id; 1284 Current_Package : Project_Node_Id; 1285 Optional_Index : Boolean; 1286 Flags : Processing_Flags) 1287 is 1288 Next_Term : Project_Node_Id := Empty_Node; 1289 Term_Id : Project_Node_Id := Empty_Node; 1290 Current_Expression : Project_Node_Id := Empty_Node; 1291 Next_Expression : Project_Node_Id := Empty_Node; 1292 Current_Location : Source_Ptr := No_Location; 1293 Reference : Project_Node_Id := Empty_Node; 1294 1295 begin 1296 -- Declare a new node for the term 1297 1298 Term := Default_Project_Node (Of_Kind => N_Term, In_Tree => In_Tree); 1299 Set_Location_Of (Term, In_Tree, To => Token_Ptr); 1300 1301 case Token is 1302 when Tok_Left_Paren => 1303 1304 -- If we have a left parenthesis and we don't know the expression 1305 -- kind, then this is a string list. 1306 1307 case Expr_Kind is 1308 when Undefined => 1309 Expr_Kind := List; 1310 1311 when List => 1312 null; 1313 1314 when Single => 1315 1316 -- If we already know that this is a single string, report 1317 -- an error, but set the expression kind to string list to 1318 -- avoid several errors. 1319 1320 Expr_Kind := List; 1321 Error_Msg 1322 (Flags, "literal string list cannot appear in a string", 1323 Token_Ptr); 1324 end case; 1325 1326 -- Declare a new node for this literal string list 1327 1328 Term_Id := Default_Project_Node 1329 (Of_Kind => N_Literal_String_List, 1330 In_Tree => In_Tree, 1331 And_Expr_Kind => List); 1332 Set_Current_Term (Term, In_Tree, To => Term_Id); 1333 Set_Location_Of (Term, In_Tree, To => Token_Ptr); 1334 1335 -- Scan past the left parenthesis 1336 1337 Scan (In_Tree); 1338 1339 -- If the left parenthesis is immediately followed by a right 1340 -- parenthesis, the literal string list is empty. 1341 1342 if Token = Tok_Right_Paren then 1343 Scan (In_Tree); 1344 1345 else 1346 -- Otherwise parse the expression(s) in the literal string list 1347 1348 loop 1349 Current_Location := Token_Ptr; 1350 Parse_Expression 1351 (In_Tree => In_Tree, 1352 Expression => Next_Expression, 1353 Flags => Flags, 1354 Current_Project => Current_Project, 1355 Current_Package => Current_Package, 1356 Optional_Index => Optional_Index); 1357 1358 -- The expression kind is String list, report an error 1359 1360 if Expression_Kind_Of (Next_Expression, In_Tree) = List then 1361 Error_Msg (Flags, "single expression expected", 1362 Current_Location); 1363 end if; 1364 1365 -- If Current_Expression is empty, it means that the 1366 -- expression is the first in the string list. 1367 1368 if No (Current_Expression) then 1369 Set_First_Expression_In_List 1370 (Term_Id, In_Tree, To => Next_Expression); 1371 else 1372 Set_Next_Expression_In_List 1373 (Current_Expression, In_Tree, To => Next_Expression); 1374 end if; 1375 1376 Current_Expression := Next_Expression; 1377 1378 -- If there is a comma, continue with the next expression 1379 1380 exit when Token /= Tok_Comma; 1381 Scan (In_Tree); -- past the comma 1382 end loop; 1383 1384 -- We expect a closing right parenthesis 1385 1386 Expect (Tok_Right_Paren, "`)`"); 1387 1388 if Token = Tok_Right_Paren then 1389 Scan (In_Tree); 1390 end if; 1391 end if; 1392 1393 when Tok_String_Literal => 1394 1395 -- If we don't know the expression kind (first term), then it is 1396 -- a simple string. 1397 1398 if Expr_Kind = Undefined then 1399 Expr_Kind := Single; 1400 end if; 1401 1402 -- Declare a new node for the string literal 1403 1404 Term_Id := 1405 Default_Project_Node 1406 (Of_Kind => N_Literal_String, In_Tree => In_Tree); 1407 Set_Current_Term (Term, In_Tree, To => Term_Id); 1408 Set_String_Value_Of (Term_Id, In_Tree, To => Token_Name); 1409 1410 -- Scan past the string literal 1411 1412 Scan (In_Tree); 1413 1414 -- Check for possible index expression 1415 1416 if Token = Tok_At then 1417 if not Optional_Index then 1418 Error_Msg (Flags, "index not allowed here", Token_Ptr); 1419 Scan (In_Tree); 1420 1421 if Token = Tok_Integer_Literal then 1422 Scan (In_Tree); 1423 end if; 1424 1425 -- Set the index value 1426 1427 else 1428 Scan (In_Tree); 1429 Expect (Tok_Integer_Literal, "integer literal"); 1430 1431 if Token = Tok_Integer_Literal then 1432 declare 1433 Index : constant Int := UI_To_Int (Int_Literal_Value); 1434 begin 1435 if Index = 0 then 1436 Error_Msg 1437 (Flags, "index cannot be zero", Token_Ptr); 1438 else 1439 Set_Source_Index_Of 1440 (Term_Id, In_Tree, To => Index); 1441 end if; 1442 end; 1443 1444 Scan (In_Tree); 1445 end if; 1446 end if; 1447 end if; 1448 1449 when Tok_Identifier => 1450 Current_Location := Token_Ptr; 1451 1452 -- Get the variable or attribute reference 1453 1454 Parse_Variable_Reference 1455 (In_Tree => In_Tree, 1456 Variable => Reference, 1457 Flags => Flags, 1458 Current_Project => Current_Project, 1459 Current_Package => Current_Package); 1460 Set_Current_Term (Term, In_Tree, To => Reference); 1461 1462 if Present (Reference) then 1463 1464 -- If we don't know the expression kind (first term), then it 1465 -- has the kind of the variable or attribute reference. 1466 1467 if Expr_Kind = Undefined then 1468 Expr_Kind := Expression_Kind_Of (Reference, In_Tree); 1469 1470 elsif Expr_Kind = Single 1471 and then Expression_Kind_Of (Reference, In_Tree) = List 1472 then 1473 -- If the expression is a single list, and the reference is 1474 -- a string list, report an error, and set the expression 1475 -- kind to string list to avoid multiple errors. 1476 1477 Expr_Kind := List; 1478 Error_Msg 1479 (Flags, 1480 "list variable cannot appear in single string expression", 1481 Current_Location); 1482 end if; 1483 end if; 1484 1485 when Tok_Project => 1486 1487 -- Project can appear in an expression as the prefix of an 1488 -- attribute reference of the current project. 1489 1490 Current_Location := Token_Ptr; 1491 Scan (In_Tree); 1492 Expect (Tok_Apostrophe, "`'`"); 1493 1494 if Token = Tok_Apostrophe then 1495 Attribute_Reference 1496 (In_Tree => In_Tree, 1497 Reference => Reference, 1498 Flags => Flags, 1499 First_Attribute => Prj.Attr.Attribute_First, 1500 Current_Project => Current_Project, 1501 Current_Package => Empty_Node); 1502 Set_Current_Term (Term, In_Tree, To => Reference); 1503 end if; 1504 1505 -- Same checks as above for the expression kind 1506 1507 if Present (Reference) then 1508 if Expr_Kind = Undefined then 1509 Expr_Kind := Expression_Kind_Of (Reference, In_Tree); 1510 1511 elsif Expr_Kind = Single 1512 and then Expression_Kind_Of (Reference, In_Tree) = List 1513 then 1514 Error_Msg 1515 (Flags, "lists cannot appear in single string expression", 1516 Current_Location); 1517 end if; 1518 end if; 1519 1520 when Tok_External | Tok_External_As_List => 1521 External_Reference 1522 (In_Tree => In_Tree, 1523 Flags => Flags, 1524 Current_Project => Current_Project, 1525 Current_Package => Current_Package, 1526 Expr_Kind => Expr_Kind, 1527 External_Value => Reference); 1528 Set_Current_Term (Term, In_Tree, To => Reference); 1529 1530 when others => 1531 Error_Msg (Flags, "cannot be part of an expression", Token_Ptr); 1532 Term := Empty_Node; 1533 return; 1534 end case; 1535 1536 -- If there is an '&', call Terms recursively 1537 1538 if Token = Tok_Ampersand then 1539 Scan (In_Tree); -- scan past ampersand 1540 1541 Terms 1542 (In_Tree => In_Tree, 1543 Term => Next_Term, 1544 Expr_Kind => Expr_Kind, 1545 Flags => Flags, 1546 Current_Project => Current_Project, 1547 Current_Package => Current_Package, 1548 Optional_Index => Optional_Index); 1549 1550 -- And link the next term to this term 1551 1552 Set_Next_Term (Term, In_Tree, To => Next_Term); 1553 end if; 1554 end Terms; 1555 1556end Prj.Strt; 1557