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