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