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