1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- P R J . D E C T -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2001-2011, 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 Opt; use Opt; 28with Prj.Attr; use Prj.Attr; 29with Prj.Attr.PM; use Prj.Attr.PM; 30with Prj.Err; use Prj.Err; 31with Prj.Strt; use Prj.Strt; 32with Prj.Tree; use Prj.Tree; 33with Snames; 34with Uintp; use Uintp; 35 36with GNAT; use GNAT; 37with GNAT.Case_Util; use GNAT.Case_Util; 38with GNAT.Spelling_Checker; use GNAT.Spelling_Checker; 39with GNAT.Strings; 40 41package body Prj.Dect is 42 43 type Zone is (In_Project, In_Package, In_Case_Construction); 44 -- Used to indicate if we are parsing a package (In_Package), a case 45 -- construction (In_Case_Construction) or none of those two (In_Project). 46 47 procedure Rename_Obsolescent_Attributes 48 (In_Tree : Project_Node_Tree_Ref; 49 Attribute : Project_Node_Id; 50 Current_Package : Project_Node_Id); 51 -- Rename obsolescent attributes in the tree. When the attribute has been 52 -- renamed since its initial introduction in the design of projects, we 53 -- replace the old name in the tree with the new name, so that the code 54 -- does not have to check both names forever. 55 56 procedure Check_Attribute_Allowed 57 (In_Tree : Project_Node_Tree_Ref; 58 Project : Project_Node_Id; 59 Attribute : Project_Node_Id; 60 Flags : Processing_Flags); 61 -- Check whether the attribute is valid in this project. In particular, 62 -- depending on the type of project (qualifier), some attributes might 63 -- be disabled. 64 65 procedure Check_Package_Allowed 66 (In_Tree : Project_Node_Tree_Ref; 67 Project : Project_Node_Id; 68 Current_Package : Project_Node_Id; 69 Flags : Processing_Flags); 70 -- Check whether the package is valid in this project 71 72 procedure Parse_Attribute_Declaration 73 (In_Tree : Project_Node_Tree_Ref; 74 Attribute : out Project_Node_Id; 75 First_Attribute : Attribute_Node_Id; 76 Current_Project : Project_Node_Id; 77 Current_Package : Project_Node_Id; 78 Packages_To_Check : String_List_Access; 79 Flags : Processing_Flags); 80 -- Parse an attribute declaration 81 82 procedure Parse_Case_Construction 83 (In_Tree : Project_Node_Tree_Ref; 84 Case_Construction : out Project_Node_Id; 85 First_Attribute : Attribute_Node_Id; 86 Current_Project : Project_Node_Id; 87 Current_Package : Project_Node_Id; 88 Packages_To_Check : String_List_Access; 89 Is_Config_File : Boolean; 90 Flags : Processing_Flags); 91 -- Parse a case construction 92 93 procedure Parse_Declarative_Items 94 (In_Tree : Project_Node_Tree_Ref; 95 Declarations : out Project_Node_Id; 96 In_Zone : Zone; 97 First_Attribute : Attribute_Node_Id; 98 Current_Project : Project_Node_Id; 99 Current_Package : Project_Node_Id; 100 Packages_To_Check : String_List_Access; 101 Is_Config_File : Boolean; 102 Flags : Processing_Flags); 103 -- Parse declarative items. Depending on In_Zone, some declarative items 104 -- may be forbidden. Is_Config_File should be set to True if the project 105 -- represents a config file (.cgpr) since some specific checks apply. 106 107 procedure Parse_Package_Declaration 108 (In_Tree : Project_Node_Tree_Ref; 109 Package_Declaration : out Project_Node_Id; 110 Current_Project : Project_Node_Id; 111 Packages_To_Check : String_List_Access; 112 Is_Config_File : Boolean; 113 Flags : Processing_Flags); 114 -- Parse a package declaration. 115 -- Is_Config_File should be set to True if the project represents a config 116 -- file (.cgpr) since some specific checks apply. 117 118 procedure Parse_String_Type_Declaration 119 (In_Tree : Project_Node_Tree_Ref; 120 String_Type : out Project_Node_Id; 121 Current_Project : Project_Node_Id; 122 Flags : Processing_Flags); 123 -- type <name> is ( <literal_string> { , <literal_string> } ) ; 124 125 procedure Parse_Variable_Declaration 126 (In_Tree : Project_Node_Tree_Ref; 127 Variable : out Project_Node_Id; 128 Current_Project : Project_Node_Id; 129 Current_Package : Project_Node_Id; 130 Flags : Processing_Flags); 131 -- Parse a variable assignment 132 -- <variable_Name> := <expression>; OR 133 -- <variable_Name> : <string_type_Name> := <string_expression>; 134 135 ----------- 136 -- Parse -- 137 ----------- 138 139 procedure Parse 140 (In_Tree : Project_Node_Tree_Ref; 141 Declarations : out Project_Node_Id; 142 Current_Project : Project_Node_Id; 143 Extends : Project_Node_Id; 144 Packages_To_Check : String_List_Access; 145 Is_Config_File : Boolean; 146 Flags : Processing_Flags) 147 is 148 First_Declarative_Item : Project_Node_Id := Empty_Node; 149 150 begin 151 Declarations := 152 Default_Project_Node 153 (Of_Kind => N_Project_Declaration, In_Tree => In_Tree); 154 Set_Location_Of (Declarations, In_Tree, To => Token_Ptr); 155 Set_Extended_Project_Of (Declarations, In_Tree, To => Extends); 156 Set_Project_Declaration_Of (Current_Project, In_Tree, Declarations); 157 Parse_Declarative_Items 158 (Declarations => First_Declarative_Item, 159 In_Tree => In_Tree, 160 In_Zone => In_Project, 161 First_Attribute => Prj.Attr.Attribute_First, 162 Current_Project => Current_Project, 163 Current_Package => Empty_Node, 164 Packages_To_Check => Packages_To_Check, 165 Is_Config_File => Is_Config_File, 166 Flags => Flags); 167 Set_First_Declarative_Item_Of 168 (Declarations, In_Tree, To => First_Declarative_Item); 169 end Parse; 170 171 ----------------------------------- 172 -- Rename_Obsolescent_Attributes -- 173 ----------------------------------- 174 175 procedure Rename_Obsolescent_Attributes 176 (In_Tree : Project_Node_Tree_Ref; 177 Attribute : Project_Node_Id; 178 Current_Package : Project_Node_Id) 179 is 180 begin 181 if Present (Current_Package) 182 and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored 183 then 184 case Name_Of (Attribute, In_Tree) is 185 when Snames.Name_Specification => 186 Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec); 187 188 when Snames.Name_Specification_Suffix => 189 Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec_Suffix); 190 191 when Snames.Name_Implementation => 192 Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body); 193 194 when Snames.Name_Implementation_Suffix => 195 Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body_Suffix); 196 197 when others => 198 null; 199 end case; 200 end if; 201 end Rename_Obsolescent_Attributes; 202 203 --------------------------- 204 -- Check_Package_Allowed -- 205 --------------------------- 206 207 procedure Check_Package_Allowed 208 (In_Tree : Project_Node_Tree_Ref; 209 Project : Project_Node_Id; 210 Current_Package : Project_Node_Id; 211 Flags : Processing_Flags) 212 is 213 Qualif : constant Project_Qualifier := 214 Project_Qualifier_Of (Project, In_Tree); 215 Name : constant Name_Id := Name_Of (Current_Package, In_Tree); 216 begin 217 if Qualif in Aggregate_Project 218 and then Name /= Snames.Name_Builder 219 then 220 Error_Msg_Name_1 := Name; 221 Error_Msg 222 (Flags, 223 "package %% is forbidden in aggregate projects", 224 Location_Of (Current_Package, In_Tree)); 225 end if; 226 end Check_Package_Allowed; 227 228 ----------------------------- 229 -- Check_Attribute_Allowed -- 230 ----------------------------- 231 232 procedure Check_Attribute_Allowed 233 (In_Tree : Project_Node_Tree_Ref; 234 Project : Project_Node_Id; 235 Attribute : Project_Node_Id; 236 Flags : Processing_Flags) 237 is 238 Qualif : constant Project_Qualifier := 239 Project_Qualifier_Of (Project, In_Tree); 240 Name : constant Name_Id := Name_Of (Attribute, In_Tree); 241 242 begin 243 case Qualif is 244 when Aggregate | Aggregate_Library => 245 if Name = Snames.Name_Languages 246 or else Name = Snames.Name_Source_Files 247 or else Name = Snames.Name_Source_List_File 248 or else Name = Snames.Name_Locally_Removed_Files 249 or else Name = Snames.Name_Excluded_Source_Files 250 or else Name = Snames.Name_Excluded_Source_List_File 251 or else Name = Snames.Name_Interfaces 252 or else Name = Snames.Name_Object_Dir 253 or else Name = Snames.Name_Exec_Dir 254 or else Name = Snames.Name_Source_Dirs 255 or else Name = Snames.Name_Inherit_Source_Path 256 then 257 Error_Msg_Name_1 := Name; 258 Error_Msg 259 (Flags, 260 "%% is not valid in aggregate projects", 261 Location_Of (Attribute, In_Tree)); 262 end if; 263 264 when others => 265 if Name = Snames.Name_Project_Files 266 or else Name = Snames.Name_Project_Path 267 or else Name = Snames.Name_External 268 then 269 Error_Msg_Name_1 := Name; 270 Error_Msg 271 (Flags, 272 "%% is only valid in aggregate projects", 273 Location_Of (Attribute, In_Tree)); 274 end if; 275 end case; 276 end Check_Attribute_Allowed; 277 278 --------------------------------- 279 -- Parse_Attribute_Declaration -- 280 --------------------------------- 281 282 procedure Parse_Attribute_Declaration 283 (In_Tree : Project_Node_Tree_Ref; 284 Attribute : out Project_Node_Id; 285 First_Attribute : Attribute_Node_Id; 286 Current_Project : Project_Node_Id; 287 Current_Package : Project_Node_Id; 288 Packages_To_Check : String_List_Access; 289 Flags : Processing_Flags) 290 is 291 Current_Attribute : Attribute_Node_Id := First_Attribute; 292 Full_Associative_Array : Boolean := False; 293 Attribute_Name : Name_Id := No_Name; 294 Optional_Index : Boolean := False; 295 Pkg_Id : Package_Node_Id := Empty_Package; 296 297 procedure Process_Attribute_Name; 298 -- Read the name of the attribute, and check its type 299 300 procedure Process_Associative_Array_Index; 301 -- Read the index of the associative array and check its validity 302 303 ---------------------------- 304 -- Process_Attribute_Name -- 305 ---------------------------- 306 307 procedure Process_Attribute_Name is 308 Ignore : Boolean; 309 310 begin 311 Attribute_Name := Token_Name; 312 Set_Name_Of (Attribute, In_Tree, To => Attribute_Name); 313 Set_Location_Of (Attribute, In_Tree, To => Token_Ptr); 314 315 -- Find the attribute 316 317 Current_Attribute := 318 Attribute_Node_Id_Of (Attribute_Name, First_Attribute); 319 320 -- If the attribute cannot be found, create the attribute if inside 321 -- an unknown package. 322 323 if Current_Attribute = Empty_Attribute then 324 if Present (Current_Package) 325 and then Expression_Kind_Of (Current_Package, In_Tree) = Ignored 326 then 327 Pkg_Id := Package_Id_Of (Current_Package, In_Tree); 328 Add_Attribute (Pkg_Id, Token_Name, Current_Attribute); 329 330 else 331 -- If not a valid attribute name, issue an error if inside 332 -- a package that need to be checked. 333 334 Ignore := Present (Current_Package) and then 335 Packages_To_Check /= All_Packages; 336 337 if Ignore then 338 339 -- Check that we are not in a package to check 340 341 Get_Name_String (Name_Of (Current_Package, In_Tree)); 342 343 for Index in Packages_To_Check'Range loop 344 if Name_Buffer (1 .. Name_Len) = 345 Packages_To_Check (Index).all 346 then 347 Ignore := False; 348 exit; 349 end if; 350 end loop; 351 end if; 352 353 if not Ignore then 354 Error_Msg_Name_1 := Token_Name; 355 Error_Msg (Flags, "undefined attribute %%", Token_Ptr); 356 end if; 357 end if; 358 359 -- Set, if appropriate the index case insensitivity flag 360 361 else 362 if Is_Read_Only (Current_Attribute) then 363 Error_Msg_Name_1 := Token_Name; 364 Error_Msg 365 (Flags, "read-only attribute %% cannot be given a value", 366 Token_Ptr); 367 end if; 368 369 if Attribute_Kind_Of (Current_Attribute) in 370 All_Case_Insensitive_Associative_Array 371 then 372 Set_Case_Insensitive (Attribute, In_Tree, To => True); 373 end if; 374 end if; 375 376 Scan (In_Tree); -- past the attribute name 377 378 -- Set the expression kind of the attribute 379 380 if Current_Attribute /= Empty_Attribute then 381 Set_Expression_Kind_Of 382 (Attribute, In_Tree, To => Variable_Kind_Of (Current_Attribute)); 383 Optional_Index := Optional_Index_Of (Current_Attribute); 384 end if; 385 end Process_Attribute_Name; 386 387 ------------------------------------- 388 -- Process_Associative_Array_Index -- 389 ------------------------------------- 390 391 procedure Process_Associative_Array_Index is 392 begin 393 -- If the attribute is not an associative array attribute, report 394 -- an error. If this information is still unknown, set the kind 395 -- to Associative_Array. 396 397 if Current_Attribute /= Empty_Attribute 398 and then Attribute_Kind_Of (Current_Attribute) = Single 399 then 400 Error_Msg (Flags, 401 "the attribute """ & 402 Get_Name_String (Attribute_Name_Of (Current_Attribute)) 403 & """ cannot be an associative array", 404 Location_Of (Attribute, In_Tree)); 405 406 elsif Attribute_Kind_Of (Current_Attribute) = Unknown then 407 Set_Attribute_Kind_Of (Current_Attribute, To => Associative_Array); 408 end if; 409 410 Scan (In_Tree); -- past the left parenthesis 411 412 if Others_Allowed_For (Current_Attribute) 413 and then Token = Tok_Others 414 then 415 Set_Associative_Array_Index_Of 416 (Attribute, In_Tree, All_Other_Names); 417 Scan (In_Tree); -- past others 418 419 else 420 if Others_Allowed_For (Current_Attribute) then 421 Expect (Tok_String_Literal, "literal string or others"); 422 else 423 Expect (Tok_String_Literal, "literal string"); 424 end if; 425 426 if Token = Tok_String_Literal then 427 Get_Name_String (Token_Name); 428 429 if Case_Insensitive (Attribute, In_Tree) then 430 To_Lower (Name_Buffer (1 .. Name_Len)); 431 end if; 432 433 Set_Associative_Array_Index_Of (Attribute, In_Tree, Name_Find); 434 Scan (In_Tree); -- past the literal string index 435 436 if Token = Tok_At then 437 case Attribute_Kind_Of (Current_Attribute) is 438 when Optional_Index_Associative_Array | 439 Optional_Index_Case_Insensitive_Associative_Array => 440 Scan (In_Tree); 441 Expect (Tok_Integer_Literal, "integer literal"); 442 443 if Token = Tok_Integer_Literal then 444 445 -- Set the source index value from given literal 446 447 declare 448 Index : constant Int := 449 UI_To_Int (Int_Literal_Value); 450 begin 451 if Index = 0 then 452 Error_Msg 453 (Flags, "index cannot be zero", Token_Ptr); 454 else 455 Set_Source_Index_Of 456 (Attribute, In_Tree, To => Index); 457 end if; 458 end; 459 460 Scan (In_Tree); 461 end if; 462 463 when others => 464 Error_Msg (Flags, "index not allowed here", Token_Ptr); 465 Scan (In_Tree); 466 467 if Token = Tok_Integer_Literal then 468 Scan (In_Tree); 469 end if; 470 end case; 471 end if; 472 end if; 473 end if; 474 475 Expect (Tok_Right_Paren, "`)`"); 476 477 if Token = Tok_Right_Paren then 478 Scan (In_Tree); -- past the right parenthesis 479 end if; 480 end Process_Associative_Array_Index; 481 482 begin 483 Attribute := 484 Default_Project_Node 485 (Of_Kind => N_Attribute_Declaration, In_Tree => In_Tree); 486 Set_Location_Of (Attribute, In_Tree, To => Token_Ptr); 487 Set_Previous_Line_Node (Attribute); 488 489 -- Scan past "for" 490 491 Scan (In_Tree); 492 493 -- Body or External may be an attribute name 494 495 if Token = Tok_Body then 496 Token := Tok_Identifier; 497 Token_Name := Snames.Name_Body; 498 end if; 499 500 if Token = Tok_External then 501 Token := Tok_Identifier; 502 Token_Name := Snames.Name_External; 503 end if; 504 505 Expect (Tok_Identifier, "identifier"); 506 Process_Attribute_Name; 507 Rename_Obsolescent_Attributes (In_Tree, Attribute, Current_Package); 508 Check_Attribute_Allowed (In_Tree, Current_Project, Attribute, Flags); 509 510 -- Associative array attributes 511 512 if Token = Tok_Left_Paren then 513 Process_Associative_Array_Index; 514 515 else 516 -- If it is an associative array attribute and there are no left 517 -- parenthesis, then this is a full associative array declaration. 518 -- Flag it as such for later processing of its value. 519 520 if Current_Attribute /= Empty_Attribute 521 and then 522 Attribute_Kind_Of (Current_Attribute) /= Single 523 then 524 if Attribute_Kind_Of (Current_Attribute) = Unknown then 525 Set_Attribute_Kind_Of (Current_Attribute, To => Single); 526 527 else 528 Full_Associative_Array := True; 529 end if; 530 end if; 531 end if; 532 533 Expect (Tok_Use, "USE"); 534 535 if Token = Tok_Use then 536 Scan (In_Tree); 537 538 if Full_Associative_Array then 539 540 -- Expect <project>'<same_attribute_name>, or 541 -- <project>.<same_package_name>'<same_attribute_name> 542 543 declare 544 The_Project : Project_Node_Id := Empty_Node; 545 -- The node of the project where the associative array is 546 -- declared. 547 548 The_Package : Project_Node_Id := Empty_Node; 549 -- The node of the package where the associative array is 550 -- declared, if any. 551 552 Project_Name : Name_Id := No_Name; 553 -- The name of the project where the associative array is 554 -- declared. 555 556 Location : Source_Ptr := No_Location; 557 -- The location of the project name 558 559 begin 560 Expect (Tok_Identifier, "identifier"); 561 562 if Token = Tok_Identifier then 563 Location := Token_Ptr; 564 565 -- Find the project node in the imported project or 566 -- in the project being extended. 567 568 The_Project := Imported_Or_Extended_Project_Of 569 (Current_Project, In_Tree, Token_Name); 570 571 if No (The_Project) then 572 Error_Msg (Flags, "unknown project", Location); 573 Scan (In_Tree); -- past the project name 574 575 else 576 Project_Name := Token_Name; 577 Scan (In_Tree); -- past the project name 578 579 -- If this is inside a package, a dot followed by the 580 -- name of the package must followed the project name. 581 582 if Present (Current_Package) then 583 Expect (Tok_Dot, "`.`"); 584 585 if Token /= Tok_Dot then 586 The_Project := Empty_Node; 587 588 else 589 Scan (In_Tree); -- past the dot 590 Expect (Tok_Identifier, "identifier"); 591 592 if Token /= Tok_Identifier then 593 The_Project := Empty_Node; 594 595 -- If it is not the same package name, issue error 596 597 elsif 598 Token_Name /= Name_Of (Current_Package, In_Tree) 599 then 600 The_Project := Empty_Node; 601 Error_Msg 602 (Flags, "not the same package as " & 603 Get_Name_String 604 (Name_Of (Current_Package, In_Tree)), 605 Token_Ptr); 606 607 else 608 The_Package := 609 First_Package_Of (The_Project, In_Tree); 610 611 -- Look for the package node 612 613 while Present (The_Package) 614 and then 615 Name_Of (The_Package, In_Tree) /= Token_Name 616 loop 617 The_Package := 618 Next_Package_In_Project 619 (The_Package, In_Tree); 620 end loop; 621 622 -- If the package cannot be found in the 623 -- project, issue an error. 624 625 if No (The_Package) then 626 The_Project := Empty_Node; 627 Error_Msg_Name_2 := Project_Name; 628 Error_Msg_Name_1 := Token_Name; 629 Error_Msg 630 (Flags, 631 "package % not declared in project %", 632 Token_Ptr); 633 end if; 634 635 Scan (In_Tree); -- past the package name 636 end if; 637 end if; 638 end if; 639 end if; 640 end if; 641 642 if Present (The_Project) then 643 644 -- Looking for '<same attribute name> 645 646 Expect (Tok_Apostrophe, "`''`"); 647 648 if Token /= Tok_Apostrophe then 649 The_Project := Empty_Node; 650 651 else 652 Scan (In_Tree); -- past the apostrophe 653 Expect (Tok_Identifier, "identifier"); 654 655 if Token /= Tok_Identifier then 656 The_Project := Empty_Node; 657 658 else 659 -- If it is not the same attribute name, issue error 660 661 if Token_Name /= Attribute_Name then 662 The_Project := Empty_Node; 663 Error_Msg_Name_1 := Attribute_Name; 664 Error_Msg 665 (Flags, "invalid name, should be %", Token_Ptr); 666 end if; 667 668 Scan (In_Tree); -- past the attribute name 669 end if; 670 end if; 671 end if; 672 673 if No (The_Project) then 674 675 -- If there were any problem, set the attribute id to null, 676 -- so that the node will not be recorded. 677 678 Current_Attribute := Empty_Attribute; 679 680 else 681 -- Set the appropriate field in the node. 682 -- Note that the index and the expression are nil. This 683 -- characterizes full associative array attribute 684 -- declarations. 685 686 Set_Associative_Project_Of (Attribute, In_Tree, The_Project); 687 Set_Associative_Package_Of (Attribute, In_Tree, The_Package); 688 end if; 689 end; 690 691 -- Other attribute declarations (not full associative array) 692 693 else 694 declare 695 Expression_Location : constant Source_Ptr := Token_Ptr; 696 -- The location of the first token of the expression 697 698 Expression : Project_Node_Id := Empty_Node; 699 -- The expression, value for the attribute declaration 700 701 begin 702 -- Get the expression value and set it in the attribute node 703 704 Parse_Expression 705 (In_Tree => In_Tree, 706 Expression => Expression, 707 Flags => Flags, 708 Current_Project => Current_Project, 709 Current_Package => Current_Package, 710 Optional_Index => Optional_Index); 711 Set_Expression_Of (Attribute, In_Tree, To => Expression); 712 713 -- If the expression is legal, but not of the right kind 714 -- for the attribute, issue an error. 715 716 if Current_Attribute /= Empty_Attribute 717 and then Present (Expression) 718 and then Variable_Kind_Of (Current_Attribute) /= 719 Expression_Kind_Of (Expression, In_Tree) 720 then 721 if Variable_Kind_Of (Current_Attribute) = Undefined then 722 Set_Variable_Kind_Of 723 (Current_Attribute, 724 To => Expression_Kind_Of (Expression, In_Tree)); 725 726 else 727 Error_Msg 728 (Flags, "wrong expression kind for attribute """ & 729 Get_Name_String 730 (Attribute_Name_Of (Current_Attribute)) & 731 """", 732 Expression_Location); 733 end if; 734 end if; 735 end; 736 end if; 737 end if; 738 739 -- If the attribute was not recognized, return an empty node. 740 -- It may be that it is not in a package to check, and the node will 741 -- not be added to the tree. 742 743 if Current_Attribute = Empty_Attribute then 744 Attribute := Empty_Node; 745 end if; 746 747 Set_End_Of_Line (Attribute); 748 Set_Previous_Line_Node (Attribute); 749 end Parse_Attribute_Declaration; 750 751 ----------------------------- 752 -- Parse_Case_Construction -- 753 ----------------------------- 754 755 procedure Parse_Case_Construction 756 (In_Tree : Project_Node_Tree_Ref; 757 Case_Construction : out Project_Node_Id; 758 First_Attribute : Attribute_Node_Id; 759 Current_Project : Project_Node_Id; 760 Current_Package : Project_Node_Id; 761 Packages_To_Check : String_List_Access; 762 Is_Config_File : Boolean; 763 Flags : Processing_Flags) 764 is 765 Current_Item : Project_Node_Id := Empty_Node; 766 Next_Item : Project_Node_Id := Empty_Node; 767 First_Case_Item : Boolean := True; 768 769 Variable_Location : Source_Ptr := No_Location; 770 771 String_Type : Project_Node_Id := Empty_Node; 772 773 Case_Variable : Project_Node_Id := Empty_Node; 774 775 First_Declarative_Item : Project_Node_Id := Empty_Node; 776 777 First_Choice : Project_Node_Id := Empty_Node; 778 779 When_Others : Boolean := False; 780 -- Set to True when there is a "when others =>" clause 781 782 begin 783 Case_Construction := 784 Default_Project_Node 785 (Of_Kind => N_Case_Construction, In_Tree => In_Tree); 786 Set_Location_Of (Case_Construction, In_Tree, To => Token_Ptr); 787 788 -- Scan past "case" 789 790 Scan (In_Tree); 791 792 -- Get the switch variable 793 794 Expect (Tok_Identifier, "identifier"); 795 796 if Token = Tok_Identifier then 797 Variable_Location := Token_Ptr; 798 Parse_Variable_Reference 799 (In_Tree => In_Tree, 800 Variable => Case_Variable, 801 Flags => Flags, 802 Current_Project => Current_Project, 803 Current_Package => Current_Package); 804 Set_Case_Variable_Reference_Of 805 (Case_Construction, In_Tree, To => Case_Variable); 806 807 else 808 if Token /= Tok_Is then 809 Scan (In_Tree); 810 end if; 811 end if; 812 813 if Present (Case_Variable) then 814 String_Type := String_Type_Of (Case_Variable, In_Tree); 815 816 if No (String_Type) then 817 Error_Msg (Flags, 818 "variable """ & 819 Get_Name_String (Name_Of (Case_Variable, In_Tree)) & 820 """ is not typed", 821 Variable_Location); 822 end if; 823 end if; 824 825 Expect (Tok_Is, "IS"); 826 827 if Token = Tok_Is then 828 Set_End_Of_Line (Case_Construction); 829 Set_Previous_Line_Node (Case_Construction); 830 Set_Next_End_Node (Case_Construction); 831 832 -- Scan past "is" 833 834 Scan (In_Tree); 835 end if; 836 837 Start_New_Case_Construction (In_Tree, String_Type); 838 839 When_Loop : 840 841 while Token = Tok_When loop 842 843 if First_Case_Item then 844 Current_Item := 845 Default_Project_Node 846 (Of_Kind => N_Case_Item, In_Tree => In_Tree); 847 Set_First_Case_Item_Of 848 (Case_Construction, In_Tree, To => Current_Item); 849 First_Case_Item := False; 850 851 else 852 Next_Item := 853 Default_Project_Node 854 (Of_Kind => N_Case_Item, In_Tree => In_Tree); 855 Set_Next_Case_Item (Current_Item, In_Tree, To => Next_Item); 856 Current_Item := Next_Item; 857 end if; 858 859 Set_Location_Of (Current_Item, In_Tree, To => Token_Ptr); 860 861 -- Scan past "when" 862 863 Scan (In_Tree); 864 865 if Token = Tok_Others then 866 When_Others := True; 867 868 -- Scan past "others" 869 870 Scan (In_Tree); 871 872 Expect (Tok_Arrow, "`=>`"); 873 Set_End_Of_Line (Current_Item); 874 Set_Previous_Line_Node (Current_Item); 875 876 -- Empty_Node in Field1 of a Case_Item indicates 877 -- the "when others =>" branch. 878 879 Set_First_Choice_Of (Current_Item, In_Tree, To => Empty_Node); 880 881 Parse_Declarative_Items 882 (In_Tree => In_Tree, 883 Declarations => First_Declarative_Item, 884 In_Zone => In_Case_Construction, 885 First_Attribute => First_Attribute, 886 Current_Project => Current_Project, 887 Current_Package => Current_Package, 888 Packages_To_Check => Packages_To_Check, 889 Is_Config_File => Is_Config_File, 890 Flags => Flags); 891 892 -- "when others =>" must be the last branch, so save the 893 -- Case_Item and exit 894 895 Set_First_Declarative_Item_Of 896 (Current_Item, In_Tree, To => First_Declarative_Item); 897 exit When_Loop; 898 899 else 900 Parse_Choice_List 901 (In_Tree => In_Tree, 902 First_Choice => First_Choice, 903 Flags => Flags); 904 Set_First_Choice_Of (Current_Item, In_Tree, To => First_Choice); 905 906 Expect (Tok_Arrow, "`=>`"); 907 Set_End_Of_Line (Current_Item); 908 Set_Previous_Line_Node (Current_Item); 909 910 Parse_Declarative_Items 911 (In_Tree => In_Tree, 912 Declarations => First_Declarative_Item, 913 In_Zone => In_Case_Construction, 914 First_Attribute => First_Attribute, 915 Current_Project => Current_Project, 916 Current_Package => Current_Package, 917 Packages_To_Check => Packages_To_Check, 918 Is_Config_File => Is_Config_File, 919 Flags => Flags); 920 921 Set_First_Declarative_Item_Of 922 (Current_Item, In_Tree, To => First_Declarative_Item); 923 924 end if; 925 end loop When_Loop; 926 927 End_Case_Construction 928 (Check_All_Labels => not When_Others and not Quiet_Output, 929 Case_Location => Location_Of (Case_Construction, In_Tree), 930 Flags => Flags); 931 932 Expect (Tok_End, "`END CASE`"); 933 Remove_Next_End_Node; 934 935 if Token = Tok_End then 936 937 -- Scan past "end" 938 939 Scan (In_Tree); 940 941 Expect (Tok_Case, "CASE"); 942 943 end if; 944 945 -- Scan past "case" 946 947 Scan (In_Tree); 948 949 Expect (Tok_Semicolon, "`;`"); 950 Set_Previous_End_Node (Case_Construction); 951 952 end Parse_Case_Construction; 953 954 ----------------------------- 955 -- Parse_Declarative_Items -- 956 ----------------------------- 957 958 procedure Parse_Declarative_Items 959 (In_Tree : Project_Node_Tree_Ref; 960 Declarations : out Project_Node_Id; 961 In_Zone : Zone; 962 First_Attribute : Attribute_Node_Id; 963 Current_Project : Project_Node_Id; 964 Current_Package : Project_Node_Id; 965 Packages_To_Check : String_List_Access; 966 Is_Config_File : Boolean; 967 Flags : Processing_Flags) 968 is 969 Current_Declarative_Item : Project_Node_Id := Empty_Node; 970 Next_Declarative_Item : Project_Node_Id := Empty_Node; 971 Current_Declaration : Project_Node_Id := Empty_Node; 972 Item_Location : Source_Ptr := No_Location; 973 974 begin 975 Declarations := Empty_Node; 976 977 loop 978 -- We are always positioned at the token that precedes the first 979 -- token of the declarative element. Scan past it. 980 981 Scan (In_Tree); 982 983 Item_Location := Token_Ptr; 984 985 case Token is 986 when Tok_Identifier => 987 988 if In_Zone = In_Case_Construction then 989 990 -- Check if the variable has already been declared 991 992 declare 993 The_Variable : Project_Node_Id := Empty_Node; 994 995 begin 996 if Present (Current_Package) then 997 The_Variable := 998 First_Variable_Of (Current_Package, In_Tree); 999 elsif Present (Current_Project) then 1000 The_Variable := 1001 First_Variable_Of (Current_Project, In_Tree); 1002 end if; 1003 1004 while Present (The_Variable) 1005 and then Name_Of (The_Variable, In_Tree) /= 1006 Token_Name 1007 loop 1008 The_Variable := Next_Variable (The_Variable, In_Tree); 1009 end loop; 1010 1011 -- It is an error to declare a variable in a case 1012 -- construction for the first time. 1013 1014 if No (The_Variable) then 1015 Error_Msg 1016 (Flags, 1017 "a variable cannot be declared " & 1018 "for the first time here", 1019 Token_Ptr); 1020 end if; 1021 end; 1022 end if; 1023 1024 Parse_Variable_Declaration 1025 (In_Tree, 1026 Current_Declaration, 1027 Current_Project => Current_Project, 1028 Current_Package => Current_Package, 1029 Flags => Flags); 1030 1031 Set_End_Of_Line (Current_Declaration); 1032 Set_Previous_Line_Node (Current_Declaration); 1033 1034 when Tok_For => 1035 1036 Parse_Attribute_Declaration 1037 (In_Tree => In_Tree, 1038 Attribute => Current_Declaration, 1039 First_Attribute => First_Attribute, 1040 Current_Project => Current_Project, 1041 Current_Package => Current_Package, 1042 Packages_To_Check => Packages_To_Check, 1043 Flags => Flags); 1044 1045 Set_End_Of_Line (Current_Declaration); 1046 Set_Previous_Line_Node (Current_Declaration); 1047 1048 when Tok_Null => 1049 1050 Scan (In_Tree); -- past "null" 1051 1052 when Tok_Package => 1053 1054 -- Package declaration 1055 1056 if In_Zone /= In_Project then 1057 Error_Msg 1058 (Flags, "a package cannot be declared here", Token_Ptr); 1059 end if; 1060 1061 Parse_Package_Declaration 1062 (In_Tree => In_Tree, 1063 Package_Declaration => Current_Declaration, 1064 Current_Project => Current_Project, 1065 Packages_To_Check => Packages_To_Check, 1066 Is_Config_File => Is_Config_File, 1067 Flags => Flags); 1068 1069 Set_Previous_End_Node (Current_Declaration); 1070 1071 when Tok_Type => 1072 1073 -- Type String Declaration 1074 1075 if In_Zone /= In_Project then 1076 Error_Msg (Flags, 1077 "a string type cannot be declared here", 1078 Token_Ptr); 1079 end if; 1080 1081 Parse_String_Type_Declaration 1082 (In_Tree => In_Tree, 1083 String_Type => Current_Declaration, 1084 Current_Project => Current_Project, 1085 Flags => Flags); 1086 1087 Set_End_Of_Line (Current_Declaration); 1088 Set_Previous_Line_Node (Current_Declaration); 1089 1090 when Tok_Case => 1091 1092 -- Case construction 1093 1094 Parse_Case_Construction 1095 (In_Tree => In_Tree, 1096 Case_Construction => Current_Declaration, 1097 First_Attribute => First_Attribute, 1098 Current_Project => Current_Project, 1099 Current_Package => Current_Package, 1100 Packages_To_Check => Packages_To_Check, 1101 Is_Config_File => Is_Config_File, 1102 Flags => Flags); 1103 1104 Set_Previous_End_Node (Current_Declaration); 1105 1106 when others => 1107 exit; 1108 1109 -- We are leaving Parse_Declarative_Items positioned 1110 -- at the first token after the list of declarative items. 1111 -- It could be "end" (for a project, a package declaration or 1112 -- a case construction) or "when" (for a case construction) 1113 1114 end case; 1115 1116 Expect (Tok_Semicolon, "`;` after declarative items"); 1117 1118 -- Insert an N_Declarative_Item in the tree, but only if 1119 -- Current_Declaration is not an empty node. 1120 1121 if Present (Current_Declaration) then 1122 if No (Current_Declarative_Item) then 1123 Current_Declarative_Item := 1124 Default_Project_Node 1125 (Of_Kind => N_Declarative_Item, In_Tree => In_Tree); 1126 Declarations := Current_Declarative_Item; 1127 1128 else 1129 Next_Declarative_Item := 1130 Default_Project_Node 1131 (Of_Kind => N_Declarative_Item, In_Tree => In_Tree); 1132 Set_Next_Declarative_Item 1133 (Current_Declarative_Item, In_Tree, 1134 To => Next_Declarative_Item); 1135 Current_Declarative_Item := Next_Declarative_Item; 1136 end if; 1137 1138 Set_Current_Item_Node 1139 (Current_Declarative_Item, In_Tree, 1140 To => Current_Declaration); 1141 Set_Location_Of 1142 (Current_Declarative_Item, In_Tree, To => Item_Location); 1143 end if; 1144 end loop; 1145 end Parse_Declarative_Items; 1146 1147 ------------------------------- 1148 -- Parse_Package_Declaration -- 1149 ------------------------------- 1150 1151 procedure Parse_Package_Declaration 1152 (In_Tree : Project_Node_Tree_Ref; 1153 Package_Declaration : out Project_Node_Id; 1154 Current_Project : Project_Node_Id; 1155 Packages_To_Check : String_List_Access; 1156 Is_Config_File : Boolean; 1157 Flags : Processing_Flags) 1158 is 1159 First_Attribute : Attribute_Node_Id := Empty_Attribute; 1160 Current_Package : Package_Node_Id := Empty_Package; 1161 First_Declarative_Item : Project_Node_Id := Empty_Node; 1162 Package_Location : constant Source_Ptr := Token_Ptr; 1163 Renaming : Boolean := False; 1164 Extending : Boolean := False; 1165 1166 begin 1167 Package_Declaration := 1168 Default_Project_Node 1169 (Of_Kind => N_Package_Declaration, In_Tree => In_Tree); 1170 Set_Location_Of (Package_Declaration, In_Tree, To => Package_Location); 1171 1172 -- Scan past "package" 1173 1174 Scan (In_Tree); 1175 Expect (Tok_Identifier, "identifier"); 1176 1177 if Token = Tok_Identifier then 1178 Set_Name_Of (Package_Declaration, In_Tree, To => Token_Name); 1179 1180 Current_Package := Package_Node_Id_Of (Token_Name); 1181 1182 if Current_Package = Empty_Package then 1183 if not Quiet_Output then 1184 declare 1185 List : constant Strings.String_List := Package_Name_List; 1186 Index : Natural; 1187 Name : constant String := Get_Name_String (Token_Name); 1188 1189 begin 1190 -- Check for possible misspelling of a known package name 1191 1192 Index := 0; 1193 loop 1194 if Index >= List'Last then 1195 Index := 0; 1196 exit; 1197 end if; 1198 1199 Index := Index + 1; 1200 exit when 1201 GNAT.Spelling_Checker.Is_Bad_Spelling_Of 1202 (Name, List (Index).all); 1203 end loop; 1204 1205 -- Issue warning(s) in verbose mode or when a possible 1206 -- misspelling has been found. 1207 1208 if Verbose_Mode or else Index /= 0 then 1209 Error_Msg (Flags, 1210 "?""" & 1211 Get_Name_String 1212 (Name_Of (Package_Declaration, In_Tree)) & 1213 """ is not a known package name", 1214 Token_Ptr); 1215 end if; 1216 1217 if Index /= 0 then 1218 Error_Msg -- CODEFIX 1219 (Flags, 1220 "\?possible misspelling of """ & 1221 List (Index).all & """", Token_Ptr); 1222 end if; 1223 end; 1224 end if; 1225 1226 -- Set the package declaration to "ignored" so that it is not 1227 -- processed by Prj.Proc.Process. 1228 1229 Set_Expression_Kind_Of (Package_Declaration, In_Tree, Ignored); 1230 1231 -- Add the unknown package in the list of packages 1232 1233 Add_Unknown_Package (Token_Name, Current_Package); 1234 1235 elsif Current_Package = Unknown_Package then 1236 1237 -- Set the package declaration to "ignored" so that it is not 1238 -- processed by Prj.Proc.Process. 1239 1240 Set_Expression_Kind_Of (Package_Declaration, In_Tree, Ignored); 1241 1242 else 1243 First_Attribute := First_Attribute_Of (Current_Package); 1244 end if; 1245 1246 Set_Package_Id_Of 1247 (Package_Declaration, In_Tree, To => Current_Package); 1248 1249 declare 1250 Current : Project_Node_Id := 1251 First_Package_Of (Current_Project, In_Tree); 1252 1253 begin 1254 while Present (Current) 1255 and then Name_Of (Current, In_Tree) /= Token_Name 1256 loop 1257 Current := Next_Package_In_Project (Current, In_Tree); 1258 end loop; 1259 1260 if Present (Current) then 1261 Error_Msg 1262 (Flags, 1263 "package """ & 1264 Get_Name_String (Name_Of (Package_Declaration, In_Tree)) & 1265 """ is declared twice in the same project", 1266 Token_Ptr); 1267 1268 else 1269 -- Add the package to the project list 1270 1271 Set_Next_Package_In_Project 1272 (Package_Declaration, In_Tree, 1273 To => First_Package_Of (Current_Project, In_Tree)); 1274 Set_First_Package_Of 1275 (Current_Project, In_Tree, To => Package_Declaration); 1276 end if; 1277 end; 1278 1279 -- Scan past the package name 1280 1281 Scan (In_Tree); 1282 end if; 1283 1284 Check_Package_Allowed 1285 (In_Tree, Current_Project, Package_Declaration, Flags); 1286 1287 if Token = Tok_Renames then 1288 Renaming := True; 1289 elsif Token = Tok_Extends then 1290 Extending := True; 1291 end if; 1292 1293 if Renaming or else Extending then 1294 if Is_Config_File then 1295 Error_Msg 1296 (Flags, 1297 "no package rename or extension in configuration projects", 1298 Token_Ptr); 1299 end if; 1300 1301 -- Scan past "renames" or "extends" 1302 1303 Scan (In_Tree); 1304 1305 Expect (Tok_Identifier, "identifier"); 1306 1307 if Token = Tok_Identifier then 1308 declare 1309 Project_Name : constant Name_Id := Token_Name; 1310 1311 Clause : Project_Node_Id := 1312 First_With_Clause_Of (Current_Project, In_Tree); 1313 The_Project : Project_Node_Id := Empty_Node; 1314 Extended : constant Project_Node_Id := 1315 Extended_Project_Of 1316 (Project_Declaration_Of 1317 (Current_Project, In_Tree), 1318 In_Tree); 1319 begin 1320 while Present (Clause) loop 1321 -- Only non limited imported projects may be used in a 1322 -- renames declaration. 1323 1324 The_Project := 1325 Non_Limited_Project_Node_Of (Clause, In_Tree); 1326 exit when Present (The_Project) 1327 and then Name_Of (The_Project, In_Tree) = Project_Name; 1328 Clause := Next_With_Clause_Of (Clause, In_Tree); 1329 end loop; 1330 1331 if No (Clause) then 1332 -- As we have not found the project in the imports, we check 1333 -- if it's the name of an eventual extended project. 1334 1335 if Present (Extended) 1336 and then Name_Of (Extended, In_Tree) = Project_Name 1337 then 1338 Set_Project_Of_Renamed_Package_Of 1339 (Package_Declaration, In_Tree, To => Extended); 1340 else 1341 Error_Msg_Name_1 := Project_Name; 1342 Error_Msg 1343 (Flags, 1344 "% is not an imported or extended project", Token_Ptr); 1345 end if; 1346 else 1347 Set_Project_Of_Renamed_Package_Of 1348 (Package_Declaration, In_Tree, To => The_Project); 1349 end if; 1350 end; 1351 1352 Scan (In_Tree); 1353 Expect (Tok_Dot, "`.`"); 1354 1355 if Token = Tok_Dot then 1356 Scan (In_Tree); 1357 Expect (Tok_Identifier, "identifier"); 1358 1359 if Token = Tok_Identifier then 1360 if Name_Of (Package_Declaration, In_Tree) /= Token_Name then 1361 Error_Msg (Flags, "not the same package name", Token_Ptr); 1362 elsif 1363 Present (Project_Of_Renamed_Package_Of 1364 (Package_Declaration, In_Tree)) 1365 then 1366 declare 1367 Current : Project_Node_Id := 1368 First_Package_Of 1369 (Project_Of_Renamed_Package_Of 1370 (Package_Declaration, In_Tree), 1371 In_Tree); 1372 1373 begin 1374 while Present (Current) 1375 and then Name_Of (Current, In_Tree) /= Token_Name 1376 loop 1377 Current := 1378 Next_Package_In_Project (Current, In_Tree); 1379 end loop; 1380 1381 if No (Current) then 1382 Error_Msg 1383 (Flags, """" & 1384 Get_Name_String (Token_Name) & 1385 """ is not a package declared by the project", 1386 Token_Ptr); 1387 end if; 1388 end; 1389 end if; 1390 1391 Scan (In_Tree); 1392 end if; 1393 end if; 1394 end if; 1395 end if; 1396 1397 if Renaming then 1398 Expect (Tok_Semicolon, "`;`"); 1399 Set_End_Of_Line (Package_Declaration); 1400 Set_Previous_Line_Node (Package_Declaration); 1401 1402 elsif Token = Tok_Is then 1403 Set_End_Of_Line (Package_Declaration); 1404 Set_Previous_Line_Node (Package_Declaration); 1405 Set_Next_End_Node (Package_Declaration); 1406 1407 Parse_Declarative_Items 1408 (In_Tree => In_Tree, 1409 Declarations => First_Declarative_Item, 1410 In_Zone => In_Package, 1411 First_Attribute => First_Attribute, 1412 Current_Project => Current_Project, 1413 Current_Package => Package_Declaration, 1414 Packages_To_Check => Packages_To_Check, 1415 Is_Config_File => Is_Config_File, 1416 Flags => Flags); 1417 1418 Set_First_Declarative_Item_Of 1419 (Package_Declaration, In_Tree, To => First_Declarative_Item); 1420 1421 Expect (Tok_End, "END"); 1422 1423 if Token = Tok_End then 1424 1425 -- Scan past "end" 1426 1427 Scan (In_Tree); 1428 end if; 1429 1430 -- We should have the name of the package after "end" 1431 1432 Expect (Tok_Identifier, "identifier"); 1433 1434 if Token = Tok_Identifier 1435 and then Name_Of (Package_Declaration, In_Tree) /= No_Name 1436 and then Token_Name /= Name_Of (Package_Declaration, In_Tree) 1437 then 1438 Error_Msg_Name_1 := Name_Of (Package_Declaration, In_Tree); 1439 Error_Msg (Flags, "expected %%", Token_Ptr); 1440 end if; 1441 1442 if Token /= Tok_Semicolon then 1443 1444 -- Scan past the package name 1445 1446 Scan (In_Tree); 1447 end if; 1448 1449 Expect (Tok_Semicolon, "`;`"); 1450 Remove_Next_End_Node; 1451 1452 else 1453 Error_Msg (Flags, "expected IS", Token_Ptr); 1454 end if; 1455 1456 end Parse_Package_Declaration; 1457 1458 ----------------------------------- 1459 -- Parse_String_Type_Declaration -- 1460 ----------------------------------- 1461 1462 procedure Parse_String_Type_Declaration 1463 (In_Tree : Project_Node_Tree_Ref; 1464 String_Type : out Project_Node_Id; 1465 Current_Project : Project_Node_Id; 1466 Flags : Processing_Flags) 1467 is 1468 Current : Project_Node_Id := Empty_Node; 1469 First_String : Project_Node_Id := Empty_Node; 1470 1471 begin 1472 String_Type := 1473 Default_Project_Node 1474 (Of_Kind => N_String_Type_Declaration, In_Tree => In_Tree); 1475 1476 Set_Location_Of (String_Type, In_Tree, To => Token_Ptr); 1477 1478 -- Scan past "type" 1479 1480 Scan (In_Tree); 1481 1482 Expect (Tok_Identifier, "identifier"); 1483 1484 if Token = Tok_Identifier then 1485 Set_Name_Of (String_Type, In_Tree, To => Token_Name); 1486 1487 Current := First_String_Type_Of (Current_Project, In_Tree); 1488 while Present (Current) 1489 and then 1490 Name_Of (Current, In_Tree) /= Token_Name 1491 loop 1492 Current := Next_String_Type (Current, In_Tree); 1493 end loop; 1494 1495 if Present (Current) then 1496 Error_Msg (Flags, 1497 "duplicate string type name """ & 1498 Get_Name_String (Token_Name) & 1499 """", 1500 Token_Ptr); 1501 else 1502 Current := First_Variable_Of (Current_Project, In_Tree); 1503 while Present (Current) 1504 and then Name_Of (Current, In_Tree) /= Token_Name 1505 loop 1506 Current := Next_Variable (Current, In_Tree); 1507 end loop; 1508 1509 if Present (Current) then 1510 Error_Msg (Flags, 1511 """" & 1512 Get_Name_String (Token_Name) & 1513 """ is already a variable name", Token_Ptr); 1514 else 1515 Set_Next_String_Type 1516 (String_Type, In_Tree, 1517 To => First_String_Type_Of (Current_Project, In_Tree)); 1518 Set_First_String_Type_Of 1519 (Current_Project, In_Tree, To => String_Type); 1520 end if; 1521 end if; 1522 1523 -- Scan past the name 1524 1525 Scan (In_Tree); 1526 end if; 1527 1528 Expect (Tok_Is, "IS"); 1529 1530 if Token = Tok_Is then 1531 Scan (In_Tree); 1532 end if; 1533 1534 Expect (Tok_Left_Paren, "`(`"); 1535 1536 if Token = Tok_Left_Paren then 1537 Scan (In_Tree); 1538 end if; 1539 1540 Parse_String_Type_List 1541 (In_Tree => In_Tree, First_String => First_String, Flags => Flags); 1542 Set_First_Literal_String (String_Type, In_Tree, To => First_String); 1543 1544 Expect (Tok_Right_Paren, "`)`"); 1545 1546 if Token = Tok_Right_Paren then 1547 Scan (In_Tree); 1548 end if; 1549 1550 end Parse_String_Type_Declaration; 1551 1552 -------------------------------- 1553 -- Parse_Variable_Declaration -- 1554 -------------------------------- 1555 1556 procedure Parse_Variable_Declaration 1557 (In_Tree : Project_Node_Tree_Ref; 1558 Variable : out Project_Node_Id; 1559 Current_Project : Project_Node_Id; 1560 Current_Package : Project_Node_Id; 1561 Flags : Processing_Flags) 1562 is 1563 Expression_Location : Source_Ptr; 1564 String_Type_Name : Name_Id := No_Name; 1565 Project_String_Type_Name : Name_Id := No_Name; 1566 Type_Location : Source_Ptr := No_Location; 1567 Project_Location : Source_Ptr := No_Location; 1568 Expression : Project_Node_Id := Empty_Node; 1569 Variable_Name : constant Name_Id := Token_Name; 1570 OK : Boolean := True; 1571 1572 begin 1573 Variable := 1574 Default_Project_Node 1575 (Of_Kind => N_Variable_Declaration, In_Tree => In_Tree); 1576 Set_Name_Of (Variable, In_Tree, To => Variable_Name); 1577 Set_Location_Of (Variable, In_Tree, To => Token_Ptr); 1578 1579 -- Scan past the variable name 1580 1581 Scan (In_Tree); 1582 1583 if Token = Tok_Colon then 1584 1585 -- Typed string variable declaration 1586 1587 Scan (In_Tree); 1588 Set_Kind_Of (Variable, In_Tree, N_Typed_Variable_Declaration); 1589 Expect (Tok_Identifier, "identifier"); 1590 1591 OK := Token = Tok_Identifier; 1592 1593 if OK then 1594 String_Type_Name := Token_Name; 1595 Type_Location := Token_Ptr; 1596 Scan (In_Tree); 1597 1598 if Token = Tok_Dot then 1599 Project_String_Type_Name := String_Type_Name; 1600 Project_Location := Type_Location; 1601 1602 -- Scan past the dot 1603 1604 Scan (In_Tree); 1605 Expect (Tok_Identifier, "identifier"); 1606 1607 if Token = Tok_Identifier then 1608 String_Type_Name := Token_Name; 1609 Type_Location := Token_Ptr; 1610 Scan (In_Tree); 1611 else 1612 OK := False; 1613 end if; 1614 end if; 1615 1616 if OK then 1617 declare 1618 Proj : Project_Node_Id := Current_Project; 1619 Current : Project_Node_Id := Empty_Node; 1620 1621 begin 1622 if Project_String_Type_Name /= No_Name then 1623 declare 1624 The_Project_Name_And_Node : constant 1625 Tree_Private_Part.Project_Name_And_Node := 1626 Tree_Private_Part.Projects_Htable.Get 1627 (In_Tree.Projects_HT, Project_String_Type_Name); 1628 1629 use Tree_Private_Part; 1630 1631 begin 1632 if The_Project_Name_And_Node = 1633 Tree_Private_Part.No_Project_Name_And_Node 1634 then 1635 Error_Msg (Flags, 1636 "unknown project """ & 1637 Get_Name_String 1638 (Project_String_Type_Name) & 1639 """", 1640 Project_Location); 1641 Current := Empty_Node; 1642 else 1643 Current := 1644 First_String_Type_Of 1645 (The_Project_Name_And_Node.Node, In_Tree); 1646 while 1647 Present (Current) 1648 and then 1649 Name_Of (Current, In_Tree) /= String_Type_Name 1650 loop 1651 Current := Next_String_Type (Current, In_Tree); 1652 end loop; 1653 end if; 1654 end; 1655 1656 else 1657 -- Look for a string type with the correct name in this 1658 -- project or in any of its ancestors. 1659 1660 loop 1661 Current := 1662 First_String_Type_Of (Proj, In_Tree); 1663 while 1664 Present (Current) 1665 and then 1666 Name_Of (Current, In_Tree) /= String_Type_Name 1667 loop 1668 Current := Next_String_Type (Current, In_Tree); 1669 end loop; 1670 1671 exit when Present (Current); 1672 1673 Proj := Parent_Project_Of (Proj, In_Tree); 1674 exit when No (Proj); 1675 end loop; 1676 end if; 1677 1678 if No (Current) then 1679 Error_Msg (Flags, 1680 "unknown string type """ & 1681 Get_Name_String (String_Type_Name) & 1682 """", 1683 Type_Location); 1684 OK := False; 1685 1686 else 1687 Set_String_Type_Of 1688 (Variable, In_Tree, To => Current); 1689 end if; 1690 end; 1691 end if; 1692 end if; 1693 end if; 1694 1695 Expect (Tok_Colon_Equal, "`:=`"); 1696 1697 OK := OK and then Token = Tok_Colon_Equal; 1698 1699 if Token = Tok_Colon_Equal then 1700 Scan (In_Tree); 1701 end if; 1702 1703 -- Get the single string or string list value 1704 1705 Expression_Location := Token_Ptr; 1706 1707 Parse_Expression 1708 (In_Tree => In_Tree, 1709 Expression => Expression, 1710 Flags => Flags, 1711 Current_Project => Current_Project, 1712 Current_Package => Current_Package, 1713 Optional_Index => False); 1714 Set_Expression_Of (Variable, In_Tree, To => Expression); 1715 1716 if Present (Expression) then 1717 -- A typed string must have a single string value, not a list 1718 1719 if Kind_Of (Variable, In_Tree) = N_Typed_Variable_Declaration 1720 and then Expression_Kind_Of (Expression, In_Tree) = List 1721 then 1722 Error_Msg 1723 (Flags, 1724 "expression must be a single string", Expression_Location); 1725 end if; 1726 1727 Set_Expression_Kind_Of 1728 (Variable, In_Tree, 1729 To => Expression_Kind_Of (Expression, In_Tree)); 1730 end if; 1731 1732 if OK then 1733 declare 1734 The_Variable : Project_Node_Id := Empty_Node; 1735 1736 begin 1737 if Present (Current_Package) then 1738 The_Variable := First_Variable_Of (Current_Package, In_Tree); 1739 elsif Present (Current_Project) then 1740 The_Variable := First_Variable_Of (Current_Project, In_Tree); 1741 end if; 1742 1743 while Present (The_Variable) 1744 and then Name_Of (The_Variable, In_Tree) /= Variable_Name 1745 loop 1746 The_Variable := Next_Variable (The_Variable, In_Tree); 1747 end loop; 1748 1749 if No (The_Variable) then 1750 if Present (Current_Package) then 1751 Set_Next_Variable 1752 (Variable, In_Tree, 1753 To => First_Variable_Of (Current_Package, In_Tree)); 1754 Set_First_Variable_Of 1755 (Current_Package, In_Tree, To => Variable); 1756 1757 elsif Present (Current_Project) then 1758 Set_Next_Variable 1759 (Variable, In_Tree, 1760 To => First_Variable_Of (Current_Project, In_Tree)); 1761 Set_First_Variable_Of 1762 (Current_Project, In_Tree, To => Variable); 1763 end if; 1764 1765 else 1766 if Expression_Kind_Of (Variable, In_Tree) /= Undefined then 1767 if Expression_Kind_Of (The_Variable, In_Tree) = 1768 Undefined 1769 then 1770 Set_Expression_Kind_Of 1771 (The_Variable, In_Tree, 1772 To => Expression_Kind_Of (Variable, In_Tree)); 1773 1774 else 1775 if Expression_Kind_Of (The_Variable, In_Tree) /= 1776 Expression_Kind_Of (Variable, In_Tree) 1777 then 1778 Error_Msg (Flags, 1779 "wrong expression kind for variable """ & 1780 Get_Name_String 1781 (Name_Of (The_Variable, In_Tree)) & 1782 """", 1783 Expression_Location); 1784 end if; 1785 end if; 1786 end if; 1787 end if; 1788 end; 1789 end if; 1790 end Parse_Variable_Declaration; 1791 1792end Prj.Dect; 1793