1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- P A R . C H 3 -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2004, 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 2, 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 COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27pragma Style_Checks (All_Checks); 28-- Turn off subprogram body ordering check. Subprograms are in order 29-- by RM section rather than alphabetical 30 31with Sinfo.CN; use Sinfo.CN; 32 33separate (Par) 34 35package body Ch3 is 36 37 ----------------------- 38 -- Local Subprograms -- 39 ----------------------- 40 41 function P_Component_List return Node_Id; 42 function P_Defining_Character_Literal return Node_Id; 43 function P_Delta_Constraint return Node_Id; 44 function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id; 45 function P_Digits_Constraint return Node_Id; 46 function P_Discriminant_Association return Node_Id; 47 function P_Enumeration_Literal_Specification return Node_Id; 48 function P_Enumeration_Type_Definition return Node_Id; 49 function P_Fixed_Point_Definition return Node_Id; 50 function P_Floating_Point_Definition return Node_Id; 51 function P_Index_Or_Discriminant_Constraint return Node_Id; 52 function P_Real_Range_Specification_Opt return Node_Id; 53 function P_Subtype_Declaration return Node_Id; 54 function P_Type_Declaration return Node_Id; 55 function P_Modular_Type_Definition return Node_Id; 56 function P_Variant return Node_Id; 57 function P_Variant_Part return Node_Id; 58 59 procedure P_Declarative_Items 60 (Decls : List_Id; 61 Done : out Boolean; 62 In_Spec : Boolean); 63 -- Scans out a single declarative item, or, in the case of a declaration 64 -- with a list of identifiers, a list of declarations, one for each of 65 -- the identifiers in the list. The declaration or declarations scanned 66 -- are appended to the given list. Done indicates whether or not there 67 -- may be additional declarative items to scan. If Done is True, then 68 -- a decision has been made that there are no more items to scan. If 69 -- Done is False, then there may be additional declarations to scan. 70 -- In_Spec is true if we are scanning a package declaration, and is used 71 -- to generate an appropriate message if a statement is encountered in 72 -- such a context. 73 74 procedure P_Identifier_Declarations 75 (Decls : List_Id; 76 Done : out Boolean; 77 In_Spec : Boolean); 78 -- Scans out a set of declarations for an identifier or list of 79 -- identifiers, and appends them to the given list. The parameters have 80 -- the same significance as for P_Declarative_Items. 81 82 procedure Statement_When_Declaration_Expected 83 (Decls : List_Id; 84 Done : out Boolean; 85 In_Spec : Boolean); 86 -- Called when a statement is found at a point where a declaration was 87 -- expected. The parameters are as described for P_Declarative_Items. 88 89 procedure Set_Declaration_Expected; 90 -- Posts a "declaration expected" error messages at the start of the 91 -- current token, and if this is the first such message issued, saves 92 -- the message id in Missing_Begin_Msg, for possible later replacement. 93 94 ------------------- 95 -- Init_Expr_Opt -- 96 ------------------- 97 98 function Init_Expr_Opt (P : Boolean := False) return Node_Id is 99 begin 100 -- For colon, assume it means := unless it is at the end of 101 -- a line, in which case guess that it means a semicolon. 102 103 if Token = Tok_Colon then 104 if Token_Is_At_End_Of_Line then 105 T_Semicolon; 106 return Empty; 107 end if; 108 109 -- Here if := or something that we will take as equivalent 110 111 elsif Token = Tok_Colon_Equal 112 or else Token = Tok_Equal 113 or else Token = Tok_Is 114 then 115 null; 116 117 -- Another possibility. If we have a literal followed by a semicolon, 118 -- we assume that we have a missing colon-equal. 119 120 elsif Token in Token_Class_Literal then 121 declare 122 Scan_State : Saved_Scan_State; 123 124 begin 125 Save_Scan_State (Scan_State); 126 Scan; -- past literal or identifier 127 128 if Token = Tok_Semicolon then 129 Restore_Scan_State (Scan_State); 130 else 131 Restore_Scan_State (Scan_State); 132 return Empty; 133 end if; 134 end; 135 136 -- Otherwise we definitely have no initialization expression 137 138 else 139 return Empty; 140 end if; 141 142 -- Merge here if we have an initialization expression 143 144 T_Colon_Equal; 145 146 if P then 147 return P_Expression; 148 else 149 return P_Expression_No_Right_Paren; 150 end if; 151 end Init_Expr_Opt; 152 153 ---------------------------- 154 -- 3.1 Basic Declaration -- 155 ---------------------------- 156 157 -- Parsed by P_Basic_Declarative_Items (3.9) 158 159 ------------------------------ 160 -- 3.1 Defining Identifier -- 161 ------------------------------ 162 163 -- DEFINING_IDENTIFIER ::= IDENTIFIER 164 165 -- Error recovery: can raise Error_Resync 166 167 function P_Defining_Identifier (C : Id_Check := None) return Node_Id is 168 Ident_Node : Node_Id; 169 170 begin 171 -- Scan out the identifier. Note that this code is essentially identical 172 -- to P_Identifier, except that in the call to Scan_Reserved_Identifier 173 -- we set Force_Msg to True, since we want at least one message for each 174 -- separate declaration (but not use) of a reserved identifier. 175 176 if Token = Tok_Identifier then 177 null; 178 179 -- If we have a reserved identifier, manufacture an identifier with 180 -- a corresponding name after posting an appropriate error message 181 182 elsif Is_Reserved_Identifier (C) then 183 Scan_Reserved_Identifier (Force_Msg => True); 184 185 -- Otherwise we have junk that cannot be interpreted as an identifier 186 187 else 188 T_Identifier; -- to give message 189 raise Error_Resync; 190 end if; 191 192 Ident_Node := Token_Node; 193 Scan; -- past the reserved identifier 194 195 if Ident_Node /= Error then 196 Change_Identifier_To_Defining_Identifier (Ident_Node); 197 end if; 198 199 return Ident_Node; 200 end P_Defining_Identifier; 201 202 ----------------------------- 203 -- 3.2.1 Type Declaration -- 204 ----------------------------- 205 206 -- TYPE_DECLARATION ::= 207 -- FULL_TYPE_DECLARATION 208 -- | INCOMPLETE_TYPE_DECLARATION 209 -- | PRIVATE_TYPE_DECLARATION 210 -- | PRIVATE_EXTENSION_DECLARATION 211 212 -- FULL_TYPE_DECLARATION ::= 213 -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION; 214 -- | CONCURRENT_TYPE_DECLARATION 215 216 -- INCOMPLETE_TYPE_DECLARATION ::= 217 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART]; 218 219 -- PRIVATE_TYPE_DECLARATION ::= 220 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] 221 -- is [abstract] [tagged] [limited] private; 222 223 -- PRIVATE_EXTENSION_DECLARATION ::= 224 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is 225 -- [abstract] new ancestor_SUBTYPE_INDICATION with private; 226 227 -- TYPE_DEFINITION ::= 228 -- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION 229 -- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION 230 -- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION 231 -- | DERIVED_TYPE_DEFINITION 232 233 -- INTEGER_TYPE_DEFINITION ::= 234 -- SIGNED_INTEGER_TYPE_DEFINITION 235 -- MODULAR_TYPE_DEFINITION 236 237 -- Error recovery: can raise Error_Resync 238 239 -- Note: The processing for full type declaration, incomplete type 240 -- declaration, private type declaration and type definition is 241 -- included in this function. The processing for concurrent type 242 -- declarations is NOT here, but rather in chapter 9 (i.e. this 243 -- function handles only declarations starting with TYPE). 244 245 function P_Type_Declaration return Node_Id is 246 Type_Loc : Source_Ptr; 247 Type_Start_Col : Column_Number; 248 Ident_Node : Node_Id; 249 Decl_Node : Node_Id; 250 Discr_List : List_Id; 251 Unknown_Dis : Boolean; 252 Discr_Sloc : Source_Ptr; 253 Abstract_Present : Boolean; 254 Abstract_Loc : Source_Ptr; 255 End_Labl : Node_Id; 256 257 Typedef_Node : Node_Id; 258 -- Normally holds type definition, except in the case of a private 259 -- extension declaration, in which case it holds the declaration itself 260 261 begin 262 Type_Loc := Token_Ptr; 263 Type_Start_Col := Start_Column; 264 T_Type; 265 Ident_Node := P_Defining_Identifier (C_Is); 266 Discr_Sloc := Token_Ptr; 267 268 if P_Unknown_Discriminant_Part_Opt then 269 Unknown_Dis := True; 270 Discr_List := No_List; 271 else 272 Unknown_Dis := False; 273 Discr_List := P_Known_Discriminant_Part_Opt; 274 end if; 275 276 -- Incomplete type declaration. We complete the processing for this 277 -- case here and return the resulting incomplete type declaration node 278 279 if Token = Tok_Semicolon then 280 Scan; -- past ; 281 Decl_Node := New_Node (N_Incomplete_Type_Declaration, Type_Loc); 282 Set_Defining_Identifier (Decl_Node, Ident_Node); 283 Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis); 284 Set_Discriminant_Specifications (Decl_Node, Discr_List); 285 return Decl_Node; 286 287 else 288 Decl_Node := Empty; 289 end if; 290 291 -- Full type declaration or private type declaration, must have IS 292 293 if Token = Tok_Equal then 294 TF_Is; 295 Scan; -- past = used in place of IS 296 297 elsif Token = Tok_Renames then 298 Error_Msg_SC ("RENAMES should be IS"); 299 Scan; -- past RENAMES used in place of IS 300 301 else 302 TF_Is; 303 end if; 304 305 -- First an error check, if we have two identifiers in a row, a likely 306 -- possibility is that the first of the identifiers is an incorrectly 307 -- spelled keyword. 308 309 if Token = Tok_Identifier then 310 declare 311 SS : Saved_Scan_State; 312 I2 : Boolean; 313 314 begin 315 Save_Scan_State (SS); 316 Scan; -- past initial identifier 317 I2 := (Token = Tok_Identifier); 318 Restore_Scan_State (SS); 319 320 if I2 321 and then 322 (Bad_Spelling_Of (Tok_Abstract) or else 323 Bad_Spelling_Of (Tok_Access) or else 324 Bad_Spelling_Of (Tok_Aliased) or else 325 Bad_Spelling_Of (Tok_Constant)) 326 then 327 null; 328 end if; 329 end; 330 end if; 331 332 -- Check for misuse of Ada 95 keyword abstract in Ada 83 mode 333 334 if Token_Name = Name_Abstract then 335 Check_95_Keyword (Tok_Abstract, Tok_Tagged); 336 Check_95_Keyword (Tok_Abstract, Tok_New); 337 end if; 338 339 -- Check cases of misuse of ABSTRACT 340 341 if Token = Tok_Abstract then 342 Abstract_Present := True; 343 Abstract_Loc := Token_Ptr; 344 Scan; -- past ABSTRACT 345 346 if Token = Tok_Limited 347 or else Token = Tok_Private 348 or else Token = Tok_Record 349 or else Token = Tok_Null 350 then 351 Error_Msg_AP ("TAGGED expected"); 352 end if; 353 354 else 355 Abstract_Present := False; 356 Abstract_Loc := No_Location; 357 end if; 358 359 -- Check for misuse of Ada 95 keyword Tagged 360 361 if Token_Name = Name_Tagged then 362 Check_95_Keyword (Tok_Tagged, Tok_Private); 363 Check_95_Keyword (Tok_Tagged, Tok_Limited); 364 Check_95_Keyword (Tok_Tagged, Tok_Record); 365 end if; 366 367 -- Special check for misuse of Aliased 368 369 if Token = Tok_Aliased or else Token_Name = Name_Aliased then 370 Error_Msg_SC ("ALIASED not allowed in type definition"); 371 Scan; -- past ALIASED 372 end if; 373 374 -- The following procesing deals with either a private type declaration 375 -- or a full type declaration. In the private type case, we build the 376 -- N_Private_Type_Declaration node, setting its Tagged_Present and 377 -- Limited_Present flags, on encountering the Private keyword, and 378 -- leave Typedef_Node set to Empty. For the full type declaration 379 -- case, Typedef_Node gets set to the type definition. 380 381 Typedef_Node := Empty; 382 383 -- Switch on token following the IS. The loop normally runs once. It 384 -- only runs more than once if an error is detected, to try again after 385 -- detecting and fixing up the error. 386 387 loop 388 case Token is 389 390 when Tok_Access => 391 Typedef_Node := P_Access_Type_Definition; 392 TF_Semicolon; 393 exit; 394 395 when Tok_Array => 396 Typedef_Node := P_Array_Type_Definition; 397 TF_Semicolon; 398 exit; 399 400 when Tok_Delta => 401 Typedef_Node := P_Fixed_Point_Definition; 402 TF_Semicolon; 403 exit; 404 405 when Tok_Digits => 406 Typedef_Node := P_Floating_Point_Definition; 407 TF_Semicolon; 408 exit; 409 410 when Tok_In => 411 Ignore (Tok_In); 412 413 when Tok_Integer_Literal => 414 T_Range; 415 Typedef_Node := P_Signed_Integer_Type_Definition; 416 TF_Semicolon; 417 exit; 418 419 when Tok_Null => 420 Typedef_Node := P_Record_Definition; 421 TF_Semicolon; 422 exit; 423 424 when Tok_Left_Paren => 425 Typedef_Node := P_Enumeration_Type_Definition; 426 427 End_Labl := 428 Make_Identifier (Token_Ptr, 429 Chars => Chars (Ident_Node)); 430 Set_Comes_From_Source (End_Labl, False); 431 432 Set_End_Label (Typedef_Node, End_Labl); 433 TF_Semicolon; 434 exit; 435 436 when Tok_Mod => 437 Typedef_Node := P_Modular_Type_Definition; 438 TF_Semicolon; 439 exit; 440 441 when Tok_New => 442 Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl; 443 444 if Nkind (Typedef_Node) = N_Derived_Type_Definition 445 and then Present (Record_Extension_Part (Typedef_Node)) 446 then 447 End_Labl := 448 Make_Identifier (Token_Ptr, 449 Chars => Chars (Ident_Node)); 450 Set_Comes_From_Source (End_Labl, False); 451 452 Set_End_Label 453 (Record_Extension_Part (Typedef_Node), End_Labl); 454 end if; 455 456 TF_Semicolon; 457 exit; 458 459 when Tok_Range => 460 Typedef_Node := P_Signed_Integer_Type_Definition; 461 TF_Semicolon; 462 exit; 463 464 when Tok_Record => 465 Typedef_Node := P_Record_Definition; 466 467 End_Labl := 468 Make_Identifier (Token_Ptr, 469 Chars => Chars (Ident_Node)); 470 Set_Comes_From_Source (End_Labl, False); 471 472 Set_End_Label (Typedef_Node, End_Labl); 473 TF_Semicolon; 474 exit; 475 476 when Tok_Tagged => 477 Scan; -- past TAGGED 478 479 if Token = Tok_Abstract then 480 Error_Msg_SC ("ABSTRACT must come before TAGGED"); 481 Abstract_Present := True; 482 Abstract_Loc := Token_Ptr; 483 Scan; -- past ABSTRACT 484 end if; 485 486 if Token = Tok_Limited then 487 Scan; -- past LIMITED 488 489 -- TAGGED LIMITED PRIVATE case 490 491 if Token = Tok_Private then 492 Decl_Node := 493 New_Node (N_Private_Type_Declaration, Type_Loc); 494 Set_Tagged_Present (Decl_Node, True); 495 Set_Limited_Present (Decl_Node, True); 496 Scan; -- past PRIVATE 497 498 -- TAGGED LIMITED RECORD 499 500 else 501 Typedef_Node := P_Record_Definition; 502 Set_Tagged_Present (Typedef_Node, True); 503 Set_Limited_Present (Typedef_Node, True); 504 505 End_Labl := 506 Make_Identifier (Token_Ptr, 507 Chars => Chars (Ident_Node)); 508 Set_Comes_From_Source (End_Labl, False); 509 510 Set_End_Label (Typedef_Node, End_Labl); 511 end if; 512 513 else 514 -- TAGGED PRIVATE 515 516 if Token = Tok_Private then 517 Decl_Node := 518 New_Node (N_Private_Type_Declaration, Type_Loc); 519 Set_Tagged_Present (Decl_Node, True); 520 Scan; -- past PRIVATE 521 522 -- TAGGED RECORD 523 524 else 525 Typedef_Node := P_Record_Definition; 526 Set_Tagged_Present (Typedef_Node, True); 527 528 End_Labl := 529 Make_Identifier (Token_Ptr, 530 Chars => Chars (Ident_Node)); 531 Set_Comes_From_Source (End_Labl, False); 532 533 Set_End_Label (Typedef_Node, End_Labl); 534 end if; 535 end if; 536 537 TF_Semicolon; 538 exit; 539 540 when Tok_Private => 541 Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc); 542 Scan; -- past PRIVATE 543 TF_Semicolon; 544 exit; 545 546 when Tok_Limited => 547 Scan; -- past LIMITED 548 549 loop 550 if Token = Tok_Tagged then 551 Error_Msg_SC ("TAGGED must come before LIMITED"); 552 Scan; -- past TAGGED 553 554 elsif Token = Tok_Abstract then 555 Error_Msg_SC ("ABSTRACT must come before LIMITED"); 556 Scan; -- past ABSTRACT 557 558 else 559 exit; 560 end if; 561 end loop; 562 563 -- LIMITED RECORD or LIMITED NULL RECORD 564 565 if Token = Tok_Record or else Token = Tok_Null then 566 if Ada_83 then 567 Error_Msg_SP 568 ("(Ada 83) limited record declaration not allowed!"); 569 end if; 570 571 Typedef_Node := P_Record_Definition; 572 Set_Limited_Present (Typedef_Node, True); 573 574 -- LIMITED PRIVATE is the only remaining possibility here 575 576 else 577 Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc); 578 Set_Limited_Present (Decl_Node, True); 579 T_Private; -- past PRIVATE (or complain if not there!) 580 end if; 581 582 TF_Semicolon; 583 exit; 584 585 -- Here we have an identifier after the IS, which is certainly 586 -- wrong and which might be one of several different mistakes. 587 588 when Tok_Identifier => 589 590 -- First case, if identifier is on same line, then probably we 591 -- have something like "type X is Integer .." and the best 592 -- diagnosis is a missing NEW. Note: the missing new message 593 -- will be posted by P_Derived_Type_Def_Or_Private_Ext_Decl. 594 595 if not Token_Is_At_Start_Of_Line then 596 Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl; 597 TF_Semicolon; 598 599 -- If the identifier is at the start of the line, and is in the 600 -- same column as the type declaration itself then we consider 601 -- that we had a missing type definition on the previous line 602 603 elsif Start_Column <= Type_Start_Col then 604 Error_Msg_AP ("type definition expected"); 605 Typedef_Node := Error; 606 607 -- If the identifier is at the start of the line, and is in 608 -- a column to the right of the type declaration line, then we 609 -- may have something like: 610 611 -- type x is 612 -- r : integer 613 614 -- and the best diagnosis is a missing record keyword 615 616 else 617 Typedef_Node := P_Record_Definition; 618 TF_Semicolon; 619 end if; 620 621 exit; 622 623 -- Anything else is an error 624 625 when others => 626 if Bad_Spelling_Of (Tok_Access) 627 or else 628 Bad_Spelling_Of (Tok_Array) 629 or else 630 Bad_Spelling_Of (Tok_Delta) 631 or else 632 Bad_Spelling_Of (Tok_Digits) 633 or else 634 Bad_Spelling_Of (Tok_Limited) 635 or else 636 Bad_Spelling_Of (Tok_Private) 637 or else 638 Bad_Spelling_Of (Tok_Range) 639 or else 640 Bad_Spelling_Of (Tok_Record) 641 or else 642 Bad_Spelling_Of (Tok_Tagged) 643 then 644 null; 645 646 else 647 Error_Msg_AP ("type definition expected"); 648 raise Error_Resync; 649 end if; 650 651 end case; 652 end loop; 653 654 -- For the private type declaration case, the private type declaration 655 -- node has been built, with the Tagged_Present and Limited_Present 656 -- flags set as needed, and Typedef_Node is left set to Empty. 657 658 if No (Typedef_Node) then 659 Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis); 660 Set_Abstract_Present (Decl_Node, Abstract_Present); 661 662 -- For a private extension declaration, Typedef_Node contains the 663 -- N_Private_Extension_Declaration node, which we now complete. Note 664 -- that the private extension declaration, unlike a full type 665 -- declaration, does permit unknown discriminants. 666 667 elsif Nkind (Typedef_Node) = N_Private_Extension_Declaration then 668 Decl_Node := Typedef_Node; 669 Set_Sloc (Decl_Node, Type_Loc); 670 Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis); 671 Set_Abstract_Present (Typedef_Node, Abstract_Present); 672 673 -- In the full type declaration case, Typedef_Node has the type 674 -- definition and here is where we build the full type declaration 675 -- node. This is also where we check for improper use of an unknown 676 -- discriminant part (not allowed for full type declaration). 677 678 else 679 if Nkind (Typedef_Node) = N_Record_Definition 680 or else (Nkind (Typedef_Node) = N_Derived_Type_Definition 681 and then Present (Record_Extension_Part (Typedef_Node))) 682 then 683 Set_Abstract_Present (Typedef_Node, Abstract_Present); 684 685 elsif Abstract_Present then 686 Error_Msg ("ABSTRACT not allowed here, ignored", Abstract_Loc); 687 end if; 688 689 Decl_Node := New_Node (N_Full_Type_Declaration, Type_Loc); 690 Set_Type_Definition (Decl_Node, Typedef_Node); 691 692 if Unknown_Dis then 693 Error_Msg 694 ("Full type declaration cannot have unknown discriminants", 695 Discr_Sloc); 696 end if; 697 end if; 698 699 -- Remaining processing is common for all three cases 700 701 Set_Defining_Identifier (Decl_Node, Ident_Node); 702 Set_Discriminant_Specifications (Decl_Node, Discr_List); 703 return Decl_Node; 704 end P_Type_Declaration; 705 706 ---------------------------------- 707 -- 3.2.1 Full Type Declaration -- 708 ---------------------------------- 709 710 -- Parsed by P_Type_Declaration (3.2.1) 711 712 ---------------------------- 713 -- 3.2.1 Type Definition -- 714 ---------------------------- 715 716 -- Parsed by P_Type_Declaration (3.2.1) 717 718 -------------------------------- 719 -- 3.2.2 Subtype Declaration -- 720 -------------------------------- 721 722 -- SUBTYPE_DECLARATION ::= 723 -- subtype DEFINING_IDENTIFIER is SUBTYPE_INDICATION; 724 725 -- The caller has checked that the initial token is SUBTYPE 726 727 -- Error recovery: can raise Error_Resync 728 729 function P_Subtype_Declaration return Node_Id is 730 Decl_Node : Node_Id; 731 732 begin 733 Decl_Node := New_Node (N_Subtype_Declaration, Token_Ptr); 734 Scan; -- past SUBTYPE 735 Set_Defining_Identifier (Decl_Node, P_Defining_Identifier (C_Is)); 736 TF_Is; 737 738 if Token = Tok_New then 739 Error_Msg_SC ("NEW ignored (only allowed in type declaration)"); 740 Scan; -- past NEW 741 end if; 742 743 Set_Subtype_Indication (Decl_Node, P_Subtype_Indication); 744 TF_Semicolon; 745 return Decl_Node; 746 end P_Subtype_Declaration; 747 748 ------------------------------- 749 -- 3.2.2 Subtype Indication -- 750 ------------------------------- 751 752 -- SUBTYPE_INDICATION ::= SUBTYPE_MARK [CONSTRAINT] 753 754 -- Error recovery: can raise Error_Resync 755 756 function P_Subtype_Indication return Node_Id is 757 Type_Node : Node_Id; 758 759 begin 760 if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then 761 Type_Node := P_Subtype_Mark; 762 return P_Subtype_Indication (Type_Node); 763 764 else 765 -- Check for error of using record definition and treat it nicely, 766 -- otherwise things are really messed up, so resynchronize. 767 768 if Token = Tok_Record then 769 Error_Msg_SC ("anonymous record definitions are not permitted"); 770 Discard_Junk_Node (P_Record_Definition); 771 return Error; 772 773 else 774 Error_Msg_AP ("subtype indication expected"); 775 raise Error_Resync; 776 end if; 777 end if; 778 end P_Subtype_Indication; 779 780 -- The following function is identical except that it is called with 781 -- the subtype mark already scanned out, and it scans out the constraint 782 783 -- Error recovery: can raise Error_Resync 784 785 function P_Subtype_Indication (Subtype_Mark : Node_Id) return Node_Id is 786 Indic_Node : Node_Id; 787 Constr_Node : Node_Id; 788 789 begin 790 Constr_Node := P_Constraint_Opt; 791 792 if No (Constr_Node) then 793 return Subtype_Mark; 794 else 795 Indic_Node := New_Node (N_Subtype_Indication, Sloc (Subtype_Mark)); 796 Set_Subtype_Mark (Indic_Node, Check_Subtype_Mark (Subtype_Mark)); 797 Set_Constraint (Indic_Node, Constr_Node); 798 return Indic_Node; 799 end if; 800 end P_Subtype_Indication; 801 802 ------------------------- 803 -- 3.2.2 Subtype Mark -- 804 ------------------------- 805 806 -- SUBTYPE_MARK ::= subtype_NAME; 807 808 -- Note: The subtype mark which appears after an IN or NOT IN 809 -- operator is parsed by P_Range_Or_Subtype_Mark (3.5) 810 811 -- Error recovery: cannot raise Error_Resync 812 813 function P_Subtype_Mark return Node_Id is 814 begin 815 return P_Subtype_Mark_Resync; 816 817 exception 818 when Error_Resync => 819 return Error; 820 end P_Subtype_Mark; 821 822 -- This routine differs from P_Subtype_Mark in that it insists that an 823 -- identifier be present, and if it is not, it raises Error_Resync. 824 825 -- Error recovery: can raise Error_Resync 826 827 function P_Subtype_Mark_Resync return Node_Id is 828 Type_Node : Node_Id; 829 830 begin 831 if Token = Tok_Access then 832 Error_Msg_SC ("anonymous access type definition not allowed here"); 833 Scan; -- past ACCESS 834 end if; 835 836 if Token = Tok_Array then 837 Error_Msg_SC ("anonymous array definition not allowed here"); 838 Discard_Junk_Node (P_Array_Type_Definition); 839 return Error; 840 841 else 842 Type_Node := P_Qualified_Simple_Name_Resync; 843 844 -- Check for a subtype mark attribute. The only valid possibilities 845 -- are 'CLASS and 'BASE. Anything else is a definite error. We may 846 -- as well catch it here. 847 848 if Token = Tok_Apostrophe then 849 return P_Subtype_Mark_Attribute (Type_Node); 850 else 851 return Type_Node; 852 end if; 853 end if; 854 end P_Subtype_Mark_Resync; 855 856 -- The following function is called to scan out a subtype mark attribute. 857 -- The caller has already scanned out the subtype mark, which is passed in 858 -- as the argument, and has checked that the current token is apostrophe. 859 860 -- Only a special subclass of attributes, called type attributes 861 -- (see Snames package) are allowed in this syntactic position. 862 863 -- Note: if the apostrophe is followed by other than an identifier, then 864 -- the input expression is returned unchanged, and the scan pointer is 865 -- left pointing to the apostrophe. 866 867 -- Error recovery: can raise Error_Resync 868 869 function P_Subtype_Mark_Attribute (Type_Node : Node_Id) return Node_Id is 870 Attr_Node : Node_Id := Empty; 871 Scan_State : Saved_Scan_State; 872 Prefix : Node_Id; 873 874 begin 875 Prefix := Check_Subtype_Mark (Type_Node); 876 877 if Prefix = Error then 878 raise Error_Resync; 879 end if; 880 881 -- Loop through attributes appearing (more than one can appear as for 882 -- for example in X'Base'Class). We are at an apostrophe on entry to 883 -- this loop, and it runs once for each attribute parsed, with 884 -- Prefix being the current possible prefix if it is an attribute. 885 886 loop 887 Save_Scan_State (Scan_State); -- at Apostrophe 888 Scan; -- past apostrophe 889 890 if Token /= Tok_Identifier then 891 Restore_Scan_State (Scan_State); -- to apostrophe 892 return Prefix; -- no attribute after all 893 894 elsif not Is_Type_Attribute_Name (Token_Name) then 895 Error_Msg_N 896 ("attribute & may not be used in a subtype mark", Token_Node); 897 raise Error_Resync; 898 899 else 900 Attr_Node := 901 Make_Attribute_Reference (Prev_Token_Ptr, 902 Prefix => Prefix, 903 Attribute_Name => Token_Name); 904 Delete_Node (Token_Node); 905 Scan; -- past type attribute identifier 906 end if; 907 908 exit when Token /= Tok_Apostrophe; 909 Prefix := Attr_Node; 910 end loop; 911 912 -- Fall through here after scanning type attribute 913 914 return Attr_Node; 915 end P_Subtype_Mark_Attribute; 916 917 ----------------------- 918 -- 3.2.2 Constraint -- 919 ----------------------- 920 921 -- CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT 922 923 -- SCALAR_CONSTRAINT ::= 924 -- RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT 925 926 -- COMPOSITE_CONSTRAINT ::= 927 -- INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT 928 929 -- If no constraint is present, this function returns Empty 930 931 -- Error recovery: can raise Error_Resync 932 933 function P_Constraint_Opt return Node_Id is 934 begin 935 if Token = Tok_Range 936 or else Bad_Spelling_Of (Tok_Range) 937 then 938 return P_Range_Constraint; 939 940 elsif Token = Tok_Digits 941 or else Bad_Spelling_Of (Tok_Digits) 942 then 943 return P_Digits_Constraint; 944 945 elsif Token = Tok_Delta 946 or else Bad_Spelling_Of (Tok_Delta) 947 then 948 return P_Delta_Constraint; 949 950 elsif Token = Tok_Left_Paren then 951 return P_Index_Or_Discriminant_Constraint; 952 953 elsif Token = Tok_In then 954 Ignore (Tok_In); 955 return P_Constraint_Opt; 956 957 else 958 return Empty; 959 end if; 960 end P_Constraint_Opt; 961 962 ------------------------------ 963 -- 3.2.2 Scalar Constraint -- 964 ------------------------------ 965 966 -- Parsed by P_Constraint_Opt (3.2.2) 967 968 --------------------------------- 969 -- 3.2.2 Composite Constraint -- 970 --------------------------------- 971 972 -- Parsed by P_Constraint_Opt (3.2.2) 973 974 -------------------------------------------------------- 975 -- 3.3 Identifier Declarations (Also 7.4, 8.5, 11.1) -- 976 -------------------------------------------------------- 977 978 -- This routine scans out a declaration starting with an identifier: 979 980 -- OBJECT_DECLARATION ::= 981 -- DEFINING_IDENTIFIER_LIST : [constant] [aliased] 982 -- SUBTYPE_INDICATION [:= EXPRESSION]; 983 -- | DEFINING_IDENTIFIER_LIST : [constant] [aliased] 984 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION]; 985 986 -- NUMBER_DECLARATION ::= 987 -- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION; 988 989 -- OBJECT_RENAMING_DECLARATION ::= 990 -- DEFINING_IDENTIFIER : SUBTYPE_MARK renames object_NAME; 991 992 -- EXCEPTION_RENAMING_DECLARATION ::= 993 -- DEFINING_IDENTIFIER : exception renames exception_NAME; 994 995 -- EXCEPTION_DECLARATION ::= 996 -- DEFINING_IDENTIFIER_LIST : exception; 997 998 -- Note that the ALIASED indication in an object declaration is 999 -- marked by a flag in the parent node. 1000 1001 -- The caller has checked that the initial token is an identifier 1002 1003 -- The value returned is a list of declarations, one for each identifier 1004 -- in the list (as described in Sinfo, we always split up multiple 1005 -- declarations into the equivalent sequence of single declarations 1006 -- using the More_Ids and Prev_Ids flags to preserve the source). 1007 1008 -- If the identifier turns out to be a probable statement rather than 1009 -- an identifier, then the scan is left pointing to the identifier and 1010 -- No_List is returned. 1011 1012 -- Error recovery: can raise Error_Resync 1013 1014 procedure P_Identifier_Declarations 1015 (Decls : List_Id; 1016 Done : out Boolean; 1017 In_Spec : Boolean) 1018 is 1019 Decl_Node : Node_Id; 1020 Type_Node : Node_Id; 1021 Ident_Sloc : Source_Ptr; 1022 Scan_State : Saved_Scan_State; 1023 List_OK : Boolean := True; 1024 Ident : Nat; 1025 Init_Expr : Node_Id; 1026 Init_Loc : Source_Ptr; 1027 Con_Loc : Source_Ptr; 1028 1029 Idents : array (Int range 1 .. 4096) of Entity_Id; 1030 -- Used to save identifiers in the identifier list. The upper bound 1031 -- of 4096 is expected to be infinite in practice, and we do not even 1032 -- bother to check if this upper bound is exceeded. 1033 1034 Num_Idents : Nat := 1; 1035 -- Number of identifiers stored in Idents 1036 1037 procedure No_List; 1038 -- This procedure is called in renames cases to make sure that we do 1039 -- not have more than one identifier. If we do have more than one 1040 -- then an error message is issued (and the declaration is split into 1041 -- multiple declarations) 1042 1043 function Token_Is_Renames return Boolean; 1044 -- Checks if current token is RENAMES, and if so, scans past it and 1045 -- returns True, otherwise returns False. Includes checking for some 1046 -- common error cases. 1047 1048 procedure No_List is 1049 begin 1050 if Num_Idents > 1 then 1051 Error_Msg ("identifier list not allowed for RENAMES", 1052 Sloc (Idents (2))); 1053 end if; 1054 1055 List_OK := False; 1056 end No_List; 1057 1058 function Token_Is_Renames return Boolean is 1059 At_Colon : Saved_Scan_State; 1060 1061 begin 1062 if Token = Tok_Colon then 1063 Save_Scan_State (At_Colon); 1064 Scan; -- past colon 1065 Check_Misspelling_Of (Tok_Renames); 1066 1067 if Token = Tok_Renames then 1068 Error_Msg_SP ("extra "":"" ignored"); 1069 Scan; -- past RENAMES 1070 return True; 1071 else 1072 Restore_Scan_State (At_Colon); 1073 return False; 1074 end if; 1075 1076 else 1077 Check_Misspelling_Of (Tok_Renames); 1078 1079 if Token = Tok_Renames then 1080 Scan; -- past RENAMES 1081 return True; 1082 else 1083 return False; 1084 end if; 1085 end if; 1086 end Token_Is_Renames; 1087 1088 -- Start of processing for P_Identifier_Declarations 1089 1090 begin 1091 Ident_Sloc := Token_Ptr; 1092 Save_Scan_State (Scan_State); -- at first identifier 1093 Idents (1) := P_Defining_Identifier (C_Comma_Colon); 1094 1095 -- If we have a colon after the identifier, then we can assume that 1096 -- this is in fact a valid identifier declaration and can steam ahead. 1097 1098 if Token = Tok_Colon then 1099 Scan; -- past colon 1100 1101 -- If we have a comma, then scan out the list of identifiers 1102 1103 elsif Token = Tok_Comma then 1104 1105 while Comma_Present loop 1106 Num_Idents := Num_Idents + 1; 1107 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon); 1108 end loop; 1109 1110 Save_Scan_State (Scan_State); -- at colon 1111 T_Colon; 1112 1113 -- If we have identifier followed by := then we assume that what is 1114 -- really meant is an assignment statement. The assignment statement 1115 -- is scanned out and added to the list of declarations. An exception 1116 -- occurs if the := is followed by the keyword constant, in which case 1117 -- we assume it was meant to be a colon. 1118 1119 elsif Token = Tok_Colon_Equal then 1120 Scan; -- past := 1121 1122 if Token = Tok_Constant then 1123 Error_Msg_SP ("colon expected"); 1124 1125 else 1126 Restore_Scan_State (Scan_State); 1127 Statement_When_Declaration_Expected (Decls, Done, In_Spec); 1128 return; 1129 end if; 1130 1131 -- If we have an IS keyword, then assume the TYPE keyword was missing 1132 1133 elsif Token = Tok_Is then 1134 Restore_Scan_State (Scan_State); 1135 Append_To (Decls, P_Type_Declaration); 1136 Done := False; 1137 return; 1138 1139 -- Otherwise we have an error situation 1140 1141 else 1142 Restore_Scan_State (Scan_State); 1143 1144 -- First case is possible misuse of PROTECTED in Ada 83 mode. If 1145 -- so, fix the keyword and return to scan the protected declaration. 1146 1147 if Token_Name = Name_Protected then 1148 Check_95_Keyword (Tok_Protected, Tok_Identifier); 1149 Check_95_Keyword (Tok_Protected, Tok_Type); 1150 Check_95_Keyword (Tok_Protected, Tok_Body); 1151 1152 if Token = Tok_Protected then 1153 Done := False; 1154 return; 1155 end if; 1156 1157 -- Check misspelling possibilities. If so, correct the misspelling 1158 -- and return to scan out the resulting declaration. 1159 1160 elsif Bad_Spelling_Of (Tok_Function) 1161 or else Bad_Spelling_Of (Tok_Procedure) 1162 or else Bad_Spelling_Of (Tok_Package) 1163 or else Bad_Spelling_Of (Tok_Pragma) 1164 or else Bad_Spelling_Of (Tok_Protected) 1165 or else Bad_Spelling_Of (Tok_Generic) 1166 or else Bad_Spelling_Of (Tok_Subtype) 1167 or else Bad_Spelling_Of (Tok_Type) 1168 or else Bad_Spelling_Of (Tok_Task) 1169 or else Bad_Spelling_Of (Tok_Use) 1170 or else Bad_Spelling_Of (Tok_For) 1171 then 1172 Done := False; 1173 return; 1174 1175 -- Otherwise we definitely have an ordinary identifier with a junk 1176 -- token after it. Just complain that we expect a declaration, and 1177 -- skip to a semicolon 1178 1179 else 1180 Set_Declaration_Expected; 1181 Resync_Past_Semicolon; 1182 Done := False; 1183 return; 1184 end if; 1185 end if; 1186 1187 -- Come here with an identifier list and colon scanned out. We now 1188 -- build the nodes for the declarative items. One node is built for 1189 -- each identifier in the list, with the type information being 1190 -- repeated by rescanning the appropriate section of source. 1191 1192 -- First an error check, if we have two identifiers in a row, a likely 1193 -- possibility is that the first of the identifiers is an incorrectly 1194 -- spelled keyword. 1195 1196 if Token = Tok_Identifier then 1197 declare 1198 SS : Saved_Scan_State; 1199 I2 : Boolean; 1200 1201 begin 1202 Save_Scan_State (SS); 1203 Scan; -- past initial identifier 1204 I2 := (Token = Tok_Identifier); 1205 Restore_Scan_State (SS); 1206 1207 if I2 1208 and then 1209 (Bad_Spelling_Of (Tok_Access) or else 1210 Bad_Spelling_Of (Tok_Aliased) or else 1211 Bad_Spelling_Of (Tok_Constant)) 1212 then 1213 null; 1214 end if; 1215 end; 1216 end if; 1217 1218 -- Loop through identifiers 1219 1220 Ident := 1; 1221 Ident_Loop : loop 1222 1223 -- Check for some cases of misused Ada 95 keywords 1224 1225 if Token_Name = Name_Aliased then 1226 Check_95_Keyword (Tok_Aliased, Tok_Array); 1227 Check_95_Keyword (Tok_Aliased, Tok_Identifier); 1228 Check_95_Keyword (Tok_Aliased, Tok_Constant); 1229 end if; 1230 1231 -- Constant cases 1232 1233 if Token = Tok_Constant then 1234 Con_Loc := Token_Ptr; 1235 Scan; -- past CONSTANT 1236 1237 -- Number declaration, initialization required 1238 1239 Init_Expr := Init_Expr_Opt; 1240 1241 if Present (Init_Expr) then 1242 Decl_Node := New_Node (N_Number_Declaration, Ident_Sloc); 1243 Set_Expression (Decl_Node, Init_Expr); 1244 1245 -- Constant object declaration 1246 1247 else 1248 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); 1249 Set_Constant_Present (Decl_Node, True); 1250 1251 if Token_Name = Name_Aliased then 1252 Check_95_Keyword (Tok_Aliased, Tok_Array); 1253 Check_95_Keyword (Tok_Aliased, Tok_Identifier); 1254 end if; 1255 1256 if Token = Tok_Aliased then 1257 Error_Msg_SC ("ALIASED should be before CONSTANT"); 1258 Scan; -- past ALIASED 1259 Set_Aliased_Present (Decl_Node, True); 1260 end if; 1261 1262 if Token = Tok_Array then 1263 Set_Object_Definition 1264 (Decl_Node, P_Array_Type_Definition); 1265 else 1266 Set_Object_Definition (Decl_Node, P_Subtype_Indication); 1267 end if; 1268 1269 if Token = Tok_Renames then 1270 Error_Msg 1271 ("CONSTANT not permitted in renaming declaration", 1272 Con_Loc); 1273 Scan; -- Past renames 1274 Discard_Junk_Node (P_Name); 1275 end if; 1276 end if; 1277 1278 -- Exception cases 1279 1280 elsif Token = Tok_Exception then 1281 Scan; -- past EXCEPTION 1282 1283 if Token_Is_Renames then 1284 No_List; 1285 Decl_Node := 1286 New_Node (N_Exception_Renaming_Declaration, Ident_Sloc); 1287 Set_Name (Decl_Node, P_Qualified_Simple_Name_Resync); 1288 No_Constraint; 1289 else 1290 Decl_Node := New_Node (N_Exception_Declaration, Prev_Token_Ptr); 1291 end if; 1292 1293 -- Aliased case (note that an object definition is required) 1294 1295 elsif Token = Tok_Aliased then 1296 Scan; -- past ALIASED 1297 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); 1298 Set_Aliased_Present (Decl_Node, True); 1299 1300 if Token = Tok_Constant then 1301 Scan; -- past CONSTANT 1302 Set_Constant_Present (Decl_Node, True); 1303 end if; 1304 1305 if Token = Tok_Array then 1306 Set_Object_Definition 1307 (Decl_Node, P_Array_Type_Definition); 1308 else 1309 Set_Object_Definition (Decl_Node, P_Subtype_Indication); 1310 end if; 1311 1312 -- Array case 1313 1314 elsif Token = Tok_Array then 1315 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); 1316 Set_Object_Definition (Decl_Node, P_Array_Type_Definition); 1317 1318 -- Subtype indication case 1319 1320 else 1321 Type_Node := P_Subtype_Mark; 1322 1323 -- Object renaming declaration 1324 1325 if Token_Is_Renames then 1326 No_List; 1327 Decl_Node := 1328 New_Node (N_Object_Renaming_Declaration, Ident_Sloc); 1329 Set_Subtype_Mark (Decl_Node, Type_Node); 1330 Set_Name (Decl_Node, P_Name); 1331 1332 -- Object declaration 1333 1334 else 1335 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); 1336 Set_Object_Definition 1337 (Decl_Node, P_Subtype_Indication (Type_Node)); 1338 1339 -- RENAMES at this point means that we had the combination of 1340 -- a constraint on the Type_Node and renames, which is illegal 1341 1342 if Token_Is_Renames then 1343 Error_Msg_N 1344 ("constraint not allowed in object renaming declaration", 1345 Constraint (Object_Definition (Decl_Node))); 1346 raise Error_Resync; 1347 end if; 1348 end if; 1349 end if; 1350 1351 -- Scan out initialization, allowed only for object declaration 1352 1353 Init_Loc := Token_Ptr; 1354 Init_Expr := Init_Expr_Opt; 1355 1356 if Present (Init_Expr) then 1357 if Nkind (Decl_Node) = N_Object_Declaration then 1358 Set_Expression (Decl_Node, Init_Expr); 1359 else 1360 Error_Msg ("initialization not allowed here", Init_Loc); 1361 end if; 1362 end if; 1363 1364 TF_Semicolon; 1365 Set_Defining_Identifier (Decl_Node, Idents (Ident)); 1366 1367 if List_OK then 1368 if Ident < Num_Idents then 1369 Set_More_Ids (Decl_Node, True); 1370 end if; 1371 1372 if Ident > 1 then 1373 Set_Prev_Ids (Decl_Node, True); 1374 end if; 1375 end if; 1376 1377 Append (Decl_Node, Decls); 1378 exit Ident_Loop when Ident = Num_Idents; 1379 Restore_Scan_State (Scan_State); 1380 T_Colon; 1381 Ident := Ident + 1; 1382 end loop Ident_Loop; 1383 1384 Done := False; 1385 end P_Identifier_Declarations; 1386 1387 ------------------------------- 1388 -- 3.3.1 Object Declaration -- 1389 ------------------------------- 1390 1391 -- OBJECT DECLARATION ::= 1392 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant] 1393 -- SUBTYPE_INDICATION [:= EXPRESSION]; 1394 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] 1395 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION]; 1396 -- | SINGLE_TASK_DECLARATION 1397 -- | SINGLE_PROTECTED_DECLARATION 1398 1399 -- Cases starting with TASK are parsed by P_Task (9.1) 1400 -- Cases starting with PROTECTED are parsed by P_Protected (9.4) 1401 -- All other cases are parsed by P_Identifier_Declarations (3.3) 1402 1403 ------------------------------------- 1404 -- 3.3.1 Defining Identifier List -- 1405 ------------------------------------- 1406 1407 -- DEFINING_IDENTIFIER_LIST ::= 1408 -- DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER} 1409 1410 -- Always parsed by the construct in which it appears. See special 1411 -- section on "Handling of Defining Identifier Lists" in this unit. 1412 1413 ------------------------------- 1414 -- 3.3.2 Number Declaration -- 1415 ------------------------------- 1416 1417 -- Parsed by P_Identifier_Declarations (3.3) 1418 1419 ------------------------------------------------------------------------- 1420 -- 3.4 Derived Type Definition or Private Extension Declaration (7.3) -- 1421 ------------------------------------------------------------------------- 1422 1423 -- DERIVED_TYPE_DEFINITION ::= 1424 -- [abstract] new parent_SUBTYPE_INDICATION [RECORD_EXTENSION_PART] 1425 1426 -- PRIVATE_EXTENSION_DECLARATION ::= 1427 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is 1428 -- [abstract] new ancestor_SUBTYPE_INDICATION with PRIVATE; 1429 1430 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION 1431 1432 -- The caller has already scanned out the part up to the NEW, and Token 1433 -- either contains Tok_New (or ought to, if it doesn't this procedure 1434 -- will post an appropriate "NEW expected" message). 1435 1436 -- Note: the caller is responsible for filling in the Sloc field of 1437 -- the returned node in the private extension declaration case as 1438 -- well as the stuff relating to the discriminant part. 1439 1440 -- Error recovery: can raise Error_Resync; 1441 1442 function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id is 1443 Typedef_Node : Node_Id; 1444 Typedecl_Node : Node_Id; 1445 1446 begin 1447 Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr); 1448 T_New; 1449 1450 if Token = Tok_Abstract then 1451 Error_Msg_SC ("ABSTRACT must come before NEW, not after"); 1452 Scan; 1453 end if; 1454 1455 Set_Subtype_Indication (Typedef_Node, P_Subtype_Indication); 1456 1457 -- Deal with record extension, note that we assume that a WITH is 1458 -- missing in the case of "type X is new Y record ..." or in the 1459 -- case of "type X is new Y null record". 1460 1461 if Token = Tok_With 1462 or else Token = Tok_Record 1463 or else Token = Tok_Null 1464 then 1465 T_With; -- past WITH or give error message 1466 1467 if Token = Tok_Limited then 1468 Error_Msg_SC 1469 ("LIMITED keyword not allowed in private extension"); 1470 Scan; -- ignore LIMITED 1471 end if; 1472 1473 -- Private extension declaration 1474 1475 if Token = Tok_Private then 1476 Scan; -- past PRIVATE 1477 1478 -- Throw away the type definition node and build the type 1479 -- declaration node. Note the caller must set the Sloc, 1480 -- Discriminant_Specifications, Unknown_Discriminants_Present, 1481 -- and Defined_Identifier fields in the returned node. 1482 1483 Typedecl_Node := 1484 Make_Private_Extension_Declaration (No_Location, 1485 Defining_Identifier => Empty, 1486 Subtype_Indication => Subtype_Indication (Typedef_Node), 1487 Abstract_Present => Abstract_Present (Typedef_Node)); 1488 1489 Delete_Node (Typedef_Node); 1490 return Typedecl_Node; 1491 1492 -- Derived type definition with record extension part 1493 1494 else 1495 Set_Record_Extension_Part (Typedef_Node, P_Record_Definition); 1496 return Typedef_Node; 1497 end if; 1498 1499 -- Derived type definition with no record extension part 1500 1501 else 1502 return Typedef_Node; 1503 end if; 1504 end P_Derived_Type_Def_Or_Private_Ext_Decl; 1505 1506 --------------------------- 1507 -- 3.5 Range Constraint -- 1508 --------------------------- 1509 1510 -- RANGE_CONSTRAINT ::= range RANGE 1511 1512 -- The caller has checked that the initial token is RANGE 1513 1514 -- Error recovery: cannot raise Error_Resync 1515 1516 function P_Range_Constraint return Node_Id is 1517 Range_Node : Node_Id; 1518 1519 begin 1520 Range_Node := New_Node (N_Range_Constraint, Token_Ptr); 1521 Scan; -- past RANGE 1522 Set_Range_Expression (Range_Node, P_Range); 1523 return Range_Node; 1524 end P_Range_Constraint; 1525 1526 ---------------- 1527 -- 3.5 Range -- 1528 ---------------- 1529 1530 -- RANGE ::= 1531 -- RANGE_ATTRIBUTE_REFERENCE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION 1532 1533 -- Note: the range that appears in a membership test is parsed by 1534 -- P_Range_Or_Subtype_Mark (3.5). 1535 1536 -- Error recovery: cannot raise Error_Resync 1537 1538 function P_Range return Node_Id is 1539 Expr_Node : Node_Id; 1540 Range_Node : Node_Id; 1541 1542 begin 1543 Expr_Node := P_Simple_Expression_Or_Range_Attribute; 1544 1545 if Expr_Form = EF_Range_Attr then 1546 return Expr_Node; 1547 1548 elsif Token = Tok_Dot_Dot then 1549 Range_Node := New_Node (N_Range, Token_Ptr); 1550 Set_Low_Bound (Range_Node, Expr_Node); 1551 Scan; -- past .. 1552 Expr_Node := P_Expression; 1553 Check_Simple_Expression (Expr_Node); 1554 Set_High_Bound (Range_Node, Expr_Node); 1555 return Range_Node; 1556 1557 -- Anything else is an error 1558 1559 else 1560 T_Dot_Dot; -- force missing .. message 1561 return Error; 1562 end if; 1563 end P_Range; 1564 1565 ---------------------------------- 1566 -- 3.5 P_Range_Or_Subtype_Mark -- 1567 ---------------------------------- 1568 1569 -- RANGE ::= 1570 -- RANGE_ATTRIBUTE_REFERENCE 1571 -- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION 1572 1573 -- This routine scans out the range or subtype mark that forms the right 1574 -- operand of a membership test. 1575 1576 -- Note: as documented in the Sinfo interface, although the syntax only 1577 -- allows a subtype mark, we in fact allow any simple expression to be 1578 -- returned from this routine. The semantics is responsible for issuing 1579 -- an appropriate message complaining if the argument is not a name. 1580 -- This simplifies the coding and error recovery processing in the 1581 -- parser, and in any case it is preferable not to consider this a 1582 -- syntax error and to continue with the semantic analysis. 1583 1584 -- Error recovery: cannot raise Error_Resync 1585 1586 function P_Range_Or_Subtype_Mark return Node_Id is 1587 Expr_Node : Node_Id; 1588 Range_Node : Node_Id; 1589 1590 begin 1591 Expr_Node := P_Simple_Expression_Or_Range_Attribute; 1592 1593 if Expr_Form = EF_Range_Attr then 1594 return Expr_Node; 1595 1596 -- Simple_Expression .. Simple_Expression 1597 1598 elsif Token = Tok_Dot_Dot then 1599 Check_Simple_Expression (Expr_Node); 1600 Range_Node := New_Node (N_Range, Token_Ptr); 1601 Set_Low_Bound (Range_Node, Expr_Node); 1602 Scan; -- past .. 1603 Set_High_Bound (Range_Node, P_Simple_Expression); 1604 return Range_Node; 1605 1606 -- Case of subtype mark (optionally qualified simple name or an 1607 -- attribute whose prefix is an optionally qualifed simple name) 1608 1609 elsif Expr_Form = EF_Simple_Name 1610 or else Nkind (Expr_Node) = N_Attribute_Reference 1611 then 1612 -- Check for error of range constraint after a subtype mark 1613 1614 if Token = Tok_Range then 1615 Error_Msg_SC 1616 ("range constraint not allowed in membership test"); 1617 Scan; -- past RANGE 1618 raise Error_Resync; 1619 1620 -- Check for error of DIGITS or DELTA after a subtype mark 1621 1622 elsif Token = Tok_Digits or else Token = Tok_Delta then 1623 Error_Msg_SC 1624 ("accuracy definition not allowed in membership test"); 1625 Scan; -- past DIGITS or DELTA 1626 raise Error_Resync; 1627 1628 elsif Token = Tok_Apostrophe then 1629 return P_Subtype_Mark_Attribute (Expr_Node); 1630 1631 else 1632 return Expr_Node; 1633 end if; 1634 1635 -- At this stage, we have some junk following the expression. We 1636 -- really can't tell what is wrong, might be a missing semicolon, 1637 -- or a missing THEN, or whatever. Our caller will figure it out! 1638 1639 else 1640 return Expr_Node; 1641 end if; 1642 end P_Range_Or_Subtype_Mark; 1643 1644 ---------------------------------------- 1645 -- 3.5.1 Enumeration Type Definition -- 1646 ---------------------------------------- 1647 1648 -- ENUMERATION_TYPE_DEFINITION ::= 1649 -- (ENUMERATION_LITERAL_SPECIFICATION 1650 -- {, ENUMERATION_LITERAL_SPECIFICATION}) 1651 1652 -- The caller has already scanned out the TYPE keyword 1653 1654 -- Error recovery: can raise Error_Resync; 1655 1656 function P_Enumeration_Type_Definition return Node_Id is 1657 Typedef_Node : Node_Id; 1658 1659 begin 1660 Typedef_Node := New_Node (N_Enumeration_Type_Definition, Token_Ptr); 1661 Set_Literals (Typedef_Node, New_List); 1662 1663 T_Left_Paren; 1664 1665 loop 1666 Append (P_Enumeration_Literal_Specification, Literals (Typedef_Node)); 1667 exit when not Comma_Present; 1668 end loop; 1669 1670 T_Right_Paren; 1671 return Typedef_Node; 1672 end P_Enumeration_Type_Definition; 1673 1674 ---------------------------------------------- 1675 -- 3.5.1 Enumeration Literal Specification -- 1676 ---------------------------------------------- 1677 1678 -- ENUMERATION_LITERAL_SPECIFICATION ::= 1679 -- DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL 1680 1681 -- Error recovery: can raise Error_Resync 1682 1683 function P_Enumeration_Literal_Specification return Node_Id is 1684 begin 1685 if Token = Tok_Char_Literal then 1686 return P_Defining_Character_Literal; 1687 else 1688 return P_Defining_Identifier (C_Comma_Right_Paren); 1689 end if; 1690 end P_Enumeration_Literal_Specification; 1691 1692 --------------------------------------- 1693 -- 3.5.1 Defining_Character_Literal -- 1694 --------------------------------------- 1695 1696 -- DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL 1697 1698 -- Error recovery: cannot raise Error_Resync 1699 1700 -- The caller has checked that the current token is a character literal 1701 1702 function P_Defining_Character_Literal return Node_Id is 1703 Literal_Node : Node_Id; 1704 1705 begin 1706 Literal_Node := Token_Node; 1707 Change_Character_Literal_To_Defining_Character_Literal (Literal_Node); 1708 Scan; -- past character literal 1709 return Literal_Node; 1710 end P_Defining_Character_Literal; 1711 1712 ------------------------------------ 1713 -- 3.5.4 Integer Type Definition -- 1714 ------------------------------------ 1715 1716 -- Parsed by P_Type_Declaration (3.2.1) 1717 1718 ------------------------------------------- 1719 -- 3.5.4 Signed Integer Type Definition -- 1720 ------------------------------------------- 1721 1722 -- SIGNED_INTEGER_TYPE_DEFINITION ::= 1723 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION 1724 1725 -- Normally the initial token on entry is RANGE, but in some 1726 -- error conditions, the range token was missing and control is 1727 -- passed with Token pointing to first token of the first expression. 1728 1729 -- Error recovery: cannot raise Error_Resync 1730 1731 function P_Signed_Integer_Type_Definition return Node_Id is 1732 Typedef_Node : Node_Id; 1733 Expr_Node : Node_Id; 1734 1735 begin 1736 Typedef_Node := New_Node (N_Signed_Integer_Type_Definition, Token_Ptr); 1737 1738 if Token = Tok_Range then 1739 Scan; -- past RANGE 1740 end if; 1741 1742 Expr_Node := P_Expression; 1743 Check_Simple_Expression (Expr_Node); 1744 Set_Low_Bound (Typedef_Node, Expr_Node); 1745 T_Dot_Dot; 1746 Expr_Node := P_Expression; 1747 Check_Simple_Expression (Expr_Node); 1748 Set_High_Bound (Typedef_Node, Expr_Node); 1749 return Typedef_Node; 1750 end P_Signed_Integer_Type_Definition; 1751 1752 ------------------------------------ 1753 -- 3.5.4 Modular Type Definition -- 1754 ------------------------------------ 1755 1756 -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION 1757 1758 -- The caller has checked that the initial token is MOD 1759 1760 -- Error recovery: cannot raise Error_Resync 1761 1762 function P_Modular_Type_Definition return Node_Id is 1763 Typedef_Node : Node_Id; 1764 1765 begin 1766 if Ada_83 then 1767 Error_Msg_SC ("(Ada 83): modular types not allowed"); 1768 end if; 1769 1770 Typedef_Node := New_Node (N_Modular_Type_Definition, Token_Ptr); 1771 Scan; -- past MOD 1772 Set_Expression (Typedef_Node, P_Expression_No_Right_Paren); 1773 1774 -- Handle mod L..R cleanly 1775 1776 if Token = Tok_Dot_Dot then 1777 Error_Msg_SC ("range not allowed for modular type"); 1778 Scan; -- past .. 1779 Set_Expression (Typedef_Node, P_Expression_No_Right_Paren); 1780 end if; 1781 1782 return Typedef_Node; 1783 end P_Modular_Type_Definition; 1784 1785 --------------------------------- 1786 -- 3.5.6 Real Type Definition -- 1787 --------------------------------- 1788 1789 -- Parsed by P_Type_Declaration (3.2.1) 1790 1791 -------------------------------------- 1792 -- 3.5.7 Floating Point Definition -- 1793 -------------------------------------- 1794 1795 -- FLOATING_POINT_DEFINITION ::= 1796 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION] 1797 1798 -- Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION 1799 1800 -- The caller has checked that the initial token is DIGITS 1801 1802 -- Error recovery: cannot raise Error_Resync 1803 1804 function P_Floating_Point_Definition return Node_Id is 1805 Digits_Loc : constant Source_Ptr := Token_Ptr; 1806 Def_Node : Node_Id; 1807 Expr_Node : Node_Id; 1808 1809 begin 1810 Scan; -- past DIGITS 1811 Expr_Node := P_Expression_No_Right_Paren; 1812 Check_Simple_Expression_In_Ada_83 (Expr_Node); 1813 1814 -- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order 1815 1816 if Token = Tok_Delta then 1817 Error_Msg_SC ("DELTA must come before DIGITS"); 1818 Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Digits_Loc); 1819 Scan; -- past DELTA 1820 Set_Delta_Expression (Def_Node, P_Expression_No_Right_Paren); 1821 1822 -- OK floating-point definition 1823 1824 else 1825 Def_Node := New_Node (N_Floating_Point_Definition, Digits_Loc); 1826 end if; 1827 1828 Set_Digits_Expression (Def_Node, Expr_Node); 1829 Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt); 1830 return Def_Node; 1831 end P_Floating_Point_Definition; 1832 1833 ------------------------------------- 1834 -- 3.5.7 Real Range Specification -- 1835 ------------------------------------- 1836 1837 -- REAL_RANGE_SPECIFICATION ::= 1838 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION 1839 1840 -- Error recovery: cannot raise Error_Resync 1841 1842 function P_Real_Range_Specification_Opt return Node_Id is 1843 Specification_Node : Node_Id; 1844 Expr_Node : Node_Id; 1845 1846 begin 1847 if Token = Tok_Range then 1848 Specification_Node := 1849 New_Node (N_Real_Range_Specification, Token_Ptr); 1850 Scan; -- past RANGE 1851 Expr_Node := P_Expression_No_Right_Paren; 1852 Check_Simple_Expression (Expr_Node); 1853 Set_Low_Bound (Specification_Node, Expr_Node); 1854 T_Dot_Dot; 1855 Expr_Node := P_Expression_No_Right_Paren; 1856 Check_Simple_Expression (Expr_Node); 1857 Set_High_Bound (Specification_Node, Expr_Node); 1858 return Specification_Node; 1859 else 1860 return Empty; 1861 end if; 1862 end P_Real_Range_Specification_Opt; 1863 1864 ----------------------------------- 1865 -- 3.5.9 Fixed Point Definition -- 1866 ----------------------------------- 1867 1868 -- FIXED_POINT_DEFINITION ::= 1869 -- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION 1870 1871 -- ORDINARY_FIXED_POINT_DEFINITION ::= 1872 -- delta static_EXPRESSION REAL_RANGE_SPECIFICATION 1873 1874 -- DECIMAL_FIXED_POINT_DEFINITION ::= 1875 -- delta static_EXPRESSION 1876 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION] 1877 1878 -- The caller has checked that the initial token is DELTA 1879 1880 -- Error recovery: cannot raise Error_Resync 1881 1882 function P_Fixed_Point_Definition return Node_Id is 1883 Delta_Node : Node_Id; 1884 Delta_Loc : Source_Ptr; 1885 Def_Node : Node_Id; 1886 Expr_Node : Node_Id; 1887 1888 begin 1889 Delta_Loc := Token_Ptr; 1890 Scan; -- past DELTA 1891 Delta_Node := P_Expression_No_Right_Paren; 1892 Check_Simple_Expression_In_Ada_83 (Delta_Node); 1893 1894 if Token = Tok_Digits then 1895 if Ada_83 then 1896 Error_Msg_SC ("(Ada 83) decimal fixed type not allowed!"); 1897 end if; 1898 1899 Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Delta_Loc); 1900 Scan; -- past DIGITS 1901 Expr_Node := P_Expression_No_Right_Paren; 1902 Check_Simple_Expression_In_Ada_83 (Expr_Node); 1903 Set_Digits_Expression (Def_Node, Expr_Node); 1904 1905 else 1906 Def_Node := New_Node (N_Ordinary_Fixed_Point_Definition, Delta_Loc); 1907 1908 -- Range is required in ordinary fixed point case 1909 1910 if Token /= Tok_Range then 1911 Error_Msg_AP ("range must be given for fixed-point type"); 1912 T_Range; 1913 end if; 1914 end if; 1915 1916 Set_Delta_Expression (Def_Node, Delta_Node); 1917 Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt); 1918 return Def_Node; 1919 end P_Fixed_Point_Definition; 1920 1921 -------------------------------------------- 1922 -- 3.5.9 Ordinary Fixed Point Definition -- 1923 -------------------------------------------- 1924 1925 -- Parsed by P_Fixed_Point_Definition (3.5.9) 1926 1927 ------------------------------------------- 1928 -- 3.5.9 Decimal Fixed Point Definition -- 1929 ------------------------------------------- 1930 1931 -- Parsed by P_Decimal_Point_Definition (3.5.9) 1932 1933 ------------------------------ 1934 -- 3.5.9 Digits Constraint -- 1935 ------------------------------ 1936 1937 -- DIGITS_CONSTRAINT ::= 1938 -- digits static_EXPRESSION [RANGE_CONSTRAINT] 1939 1940 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION 1941 1942 -- The caller has checked that the initial token is DIGITS 1943 1944 function P_Digits_Constraint return Node_Id is 1945 Constraint_Node : Node_Id; 1946 Expr_Node : Node_Id; 1947 1948 begin 1949 Constraint_Node := New_Node (N_Digits_Constraint, Token_Ptr); 1950 Scan; -- past DIGITS 1951 Expr_Node := P_Expression_No_Right_Paren; 1952 Check_Simple_Expression_In_Ada_83 (Expr_Node); 1953 Set_Digits_Expression (Constraint_Node, Expr_Node); 1954 1955 if Token = Tok_Range then 1956 Set_Range_Constraint (Constraint_Node, P_Range_Constraint); 1957 end if; 1958 1959 return Constraint_Node; 1960 end P_Digits_Constraint; 1961 1962 ----------------------------- 1963 -- 3.5.9 Delta Constraint -- 1964 ----------------------------- 1965 1966 -- DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT] 1967 1968 -- Note: this is an obsolescent feature in Ada 95 (I.3) 1969 1970 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION 1971 1972 -- The caller has checked that the initial token is DELTA 1973 1974 -- Error recovery: cannot raise Error_Resync 1975 1976 function P_Delta_Constraint return Node_Id is 1977 Constraint_Node : Node_Id; 1978 Expr_Node : Node_Id; 1979 1980 begin 1981 Constraint_Node := New_Node (N_Delta_Constraint, Token_Ptr); 1982 Scan; -- past DELTA 1983 Expr_Node := P_Expression_No_Right_Paren; 1984 Check_Simple_Expression_In_Ada_83 (Expr_Node); 1985 Set_Delta_Expression (Constraint_Node, Expr_Node); 1986 1987 if Token = Tok_Range then 1988 Set_Range_Constraint (Constraint_Node, P_Range_Constraint); 1989 end if; 1990 1991 return Constraint_Node; 1992 end P_Delta_Constraint; 1993 1994 -------------------------------- 1995 -- 3.6 Array Type Definition -- 1996 -------------------------------- 1997 1998 -- ARRAY_TYPE_DEFINITION ::= 1999 -- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION 2000 2001 -- UNCONSTRAINED_ARRAY_DEFINITION ::= 2002 -- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of 2003 -- COMPONENT_DEFINITION 2004 2005 -- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <> 2006 2007 -- CONSTRAINED_ARRAY_DEFINITION ::= 2008 -- array (DISCRETE_SUBTYPE_DEFINITION {, DISCRETE_SUBTYPE_DEFINITION}) of 2009 -- COMPONENT_DEFINITION 2010 2011 -- DISCRETE_SUBTYPE_DEFINITION ::= 2012 -- DISCRETE_SUBTYPE_INDICATION | RANGE 2013 2014 -- COMPONENT_DEFINITION ::= [aliased] SUBTYPE_INDICATION 2015 2016 -- The caller has checked that the initial token is ARRAY 2017 2018 -- Error recovery: can raise Error_Resync 2019 2020 function P_Array_Type_Definition return Node_Id is 2021 Array_Loc : Source_Ptr; 2022 CompDef_Node : Node_Id; 2023 Def_Node : Node_Id; 2024 Subs_List : List_Id; 2025 Scan_State : Saved_Scan_State; 2026 2027 begin 2028 Array_Loc := Token_Ptr; 2029 Scan; -- past ARRAY 2030 Subs_List := New_List; 2031 T_Left_Paren; 2032 2033 -- It's quite tricky to disentangle these two possibilities, so we do 2034 -- a prescan to determine which case we have and then reset the scan. 2035 -- The prescan skips past possible subtype mark tokens. 2036 2037 Save_Scan_State (Scan_State); -- just after paren 2038 2039 while Token in Token_Class_Desig or else 2040 Token = Tok_Dot or else 2041 Token = Tok_Apostrophe -- because of 'BASE, 'CLASS 2042 loop 2043 Scan; 2044 end loop; 2045 2046 -- If we end up on RANGE <> then we have the unconstrained case. We 2047 -- will also allow the RANGE to be omitted, just to improve error 2048 -- handling for a case like array (integer <>) of integer; 2049 2050 Scan; -- past possible RANGE or <> 2051 2052 if (Prev_Token = Tok_Range and then Token = Tok_Box) or else 2053 Prev_Token = Tok_Box 2054 then 2055 Def_Node := New_Node (N_Unconstrained_Array_Definition, Array_Loc); 2056 Restore_Scan_State (Scan_State); -- to first subtype mark 2057 2058 loop 2059 Append (P_Subtype_Mark_Resync, Subs_List); 2060 T_Range; 2061 T_Box; 2062 exit when Token = Tok_Right_Paren or else Token = Tok_Of; 2063 T_Comma; 2064 end loop; 2065 2066 Set_Subtype_Marks (Def_Node, Subs_List); 2067 2068 else 2069 Def_Node := New_Node (N_Constrained_Array_Definition, Array_Loc); 2070 Restore_Scan_State (Scan_State); -- to first discrete range 2071 2072 loop 2073 Append (P_Discrete_Subtype_Definition, Subs_List); 2074 exit when not Comma_Present; 2075 end loop; 2076 2077 Set_Discrete_Subtype_Definitions (Def_Node, Subs_List); 2078 end if; 2079 2080 T_Right_Paren; 2081 T_Of; 2082 2083 CompDef_Node := New_Node (N_Component_Definition, Token_Ptr); 2084 2085 if Token = Tok_Aliased then 2086 Set_Aliased_Present (CompDef_Node, True); 2087 Scan; -- past ALIASED 2088 end if; 2089 2090 Set_Subtype_Indication (CompDef_Node, P_Subtype_Indication); 2091 Set_Component_Definition (Def_Node, CompDef_Node); 2092 2093 return Def_Node; 2094 end P_Array_Type_Definition; 2095 2096 ----------------------------------------- 2097 -- 3.6 Unconstrained Array Definition -- 2098 ----------------------------------------- 2099 2100 -- Parsed by P_Array_Type_Definition (3.6) 2101 2102 --------------------------------------- 2103 -- 3.6 Constrained Array Definition -- 2104 --------------------------------------- 2105 2106 -- Parsed by P_Array_Type_Definition (3.6) 2107 2108 -------------------------------------- 2109 -- 3.6 Discrete Subtype Definition -- 2110 -------------------------------------- 2111 2112 -- DISCRETE_SUBTYPE_DEFINITION ::= 2113 -- discrete_SUBTYPE_INDICATION | RANGE 2114 2115 -- Note: the discrete subtype definition appearing in a constrained 2116 -- array definition is parsed by P_Array_Type_Definition (3.6) 2117 2118 -- Error recovery: cannot raise Error_Resync 2119 2120 function P_Discrete_Subtype_Definition return Node_Id is 2121 begin 2122 -- The syntax of a discrete subtype definition is identical to that 2123 -- of a discrete range, so we simply share the same parsing code. 2124 2125 return P_Discrete_Range; 2126 end P_Discrete_Subtype_Definition; 2127 2128 ------------------------------- 2129 -- 3.6 Component Definition -- 2130 ------------------------------- 2131 2132 -- For the array case, parsed by P_Array_Type_Definition (3.6) 2133 -- For the record case, parsed by P_Component_Declaration (3.8) 2134 2135 ----------------------------- 2136 -- 3.6.1 Index Constraint -- 2137 ----------------------------- 2138 2139 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1) 2140 2141 --------------------------- 2142 -- 3.6.1 Discrete Range -- 2143 --------------------------- 2144 2145 -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE 2146 2147 -- The possible forms for a discrete range are: 2148 2149 -- Subtype_Mark (SUBTYPE_INDICATION, 3.2.2) 2150 -- Subtype_Mark range Range (SUBTYPE_INDICATION, 3.2.2) 2151 -- Range_Attribute (RANGE, 3.5) 2152 -- Simple_Expression .. Simple_Expression (RANGE, 3.5) 2153 2154 -- Error recovery: cannot raise Error_Resync 2155 2156 function P_Discrete_Range return Node_Id is 2157 Expr_Node : Node_Id; 2158 Range_Node : Node_Id; 2159 2160 begin 2161 Expr_Node := P_Simple_Expression_Or_Range_Attribute; 2162 2163 if Expr_Form = EF_Range_Attr then 2164 return Expr_Node; 2165 2166 elsif Token = Tok_Range then 2167 if Expr_Form /= EF_Simple_Name then 2168 Error_Msg_SC ("range must be preceded by subtype mark"); 2169 end if; 2170 2171 return P_Subtype_Indication (Expr_Node); 2172 2173 -- Check Expression .. Expression case 2174 2175 elsif Token = Tok_Dot_Dot then 2176 Range_Node := New_Node (N_Range, Token_Ptr); 2177 Set_Low_Bound (Range_Node, Expr_Node); 2178 Scan; -- past .. 2179 Expr_Node := P_Expression; 2180 Check_Simple_Expression (Expr_Node); 2181 Set_High_Bound (Range_Node, Expr_Node); 2182 return Range_Node; 2183 2184 -- Otherwise we must have a subtype mark 2185 2186 elsif Expr_Form = EF_Simple_Name then 2187 return Expr_Node; 2188 2189 -- If incorrect, complain that we expect .. 2190 2191 else 2192 T_Dot_Dot; 2193 return Expr_Node; 2194 end if; 2195 end P_Discrete_Range; 2196 2197 ---------------------------- 2198 -- 3.7 Discriminant Part -- 2199 ---------------------------- 2200 2201 -- DISCRIMINANT_PART ::= 2202 -- UNKNOWN_DISCRIMINANT_PART 2203 -- | KNOWN_DISCRIMINANT_PART 2204 2205 -- A discriminant part is parsed by P_Known_Discriminant_Part_Opt (3.7) 2206 -- or P_Unknown_Discriminant_Part (3.7), since we know which we want. 2207 2208 ------------------------------------ 2209 -- 3.7 Unknown Discriminant Part -- 2210 ------------------------------------ 2211 2212 -- UNKNOWN_DISCRIMINANT_PART ::= (<>) 2213 2214 -- If no unknown discriminant part is present, then False is returned, 2215 -- otherwise the unknown discriminant is scanned out and True is returned. 2216 2217 -- Error recovery: cannot raise Error_Resync 2218 2219 function P_Unknown_Discriminant_Part_Opt return Boolean is 2220 Scan_State : Saved_Scan_State; 2221 2222 begin 2223 if Token /= Tok_Left_Paren then 2224 return False; 2225 2226 else 2227 Save_Scan_State (Scan_State); 2228 Scan; -- past the left paren 2229 2230 if Token = Tok_Box then 2231 2232 if Ada_83 then 2233 Error_Msg_SC ("(Ada 83) unknown discriminant not allowed!"); 2234 end if; 2235 2236 Scan; -- past the box 2237 T_Right_Paren; -- must be followed by right paren 2238 return True; 2239 2240 else 2241 Restore_Scan_State (Scan_State); 2242 return False; 2243 end if; 2244 end if; 2245 end P_Unknown_Discriminant_Part_Opt; 2246 2247 ---------------------------------- 2248 -- 3.7 Known Discriminant Part -- 2249 ---------------------------------- 2250 2251 -- KNOWN_DISCRIMINANT_PART ::= 2252 -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION}) 2253 2254 -- DISCRIMINANT_SPECIFICATION ::= 2255 -- DEFINING_IDENTIFIER_LIST : SUBTYPE_MARK 2256 -- [:= DEFAULT_EXPRESSION] 2257 -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION 2258 -- [:= DEFAULT_EXPRESSION] 2259 2260 -- If no known discriminant part is present, then No_List is returned 2261 2262 -- Error recovery: cannot raise Error_Resync 2263 2264 function P_Known_Discriminant_Part_Opt return List_Id is 2265 Specification_Node : Node_Id; 2266 Specification_List : List_Id; 2267 Ident_Sloc : Source_Ptr; 2268 Scan_State : Saved_Scan_State; 2269 Num_Idents : Nat; 2270 Ident : Nat; 2271 2272 Idents : array (Int range 1 .. 4096) of Entity_Id; 2273 -- This array holds the list of defining identifiers. The upper bound 2274 -- of 4096 is intended to be essentially infinite, and we do not even 2275 -- bother to check for it being exceeded. 2276 2277 begin 2278 if Token = Tok_Left_Paren then 2279 Specification_List := New_List; 2280 Scan; -- past ( 2281 P_Pragmas_Misplaced; 2282 2283 Specification_Loop : loop 2284 2285 Ident_Sloc := Token_Ptr; 2286 Idents (1) := P_Defining_Identifier (C_Comma_Colon); 2287 Num_Idents := 1; 2288 2289 while Comma_Present loop 2290 Num_Idents := Num_Idents + 1; 2291 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon); 2292 end loop; 2293 2294 T_Colon; 2295 2296 -- If there are multiple identifiers, we repeatedly scan the 2297 -- type and initialization expression information by resetting 2298 -- the scan pointer (so that we get completely separate trees 2299 -- for each occurrence). 2300 2301 if Num_Idents > 1 then 2302 Save_Scan_State (Scan_State); 2303 end if; 2304 2305 -- Loop through defining identifiers in list 2306 2307 Ident := 1; 2308 Ident_Loop : loop 2309 Specification_Node := 2310 New_Node (N_Discriminant_Specification, Ident_Sloc); 2311 Set_Defining_Identifier (Specification_Node, Idents (Ident)); 2312 2313 if Token = Tok_Access then 2314 if Ada_83 then 2315 Error_Msg_SC 2316 ("(Ada 83) access discriminant not allowed!"); 2317 end if; 2318 2319 Set_Discriminant_Type 2320 (Specification_Node, P_Access_Definition); 2321 else 2322 Set_Discriminant_Type 2323 (Specification_Node, P_Subtype_Mark); 2324 No_Constraint; 2325 end if; 2326 2327 Set_Expression 2328 (Specification_Node, Init_Expr_Opt (True)); 2329 2330 if Ident > 1 then 2331 Set_Prev_Ids (Specification_Node, True); 2332 end if; 2333 2334 if Ident < Num_Idents then 2335 Set_More_Ids (Specification_Node, True); 2336 end if; 2337 2338 Append (Specification_Node, Specification_List); 2339 exit Ident_Loop when Ident = Num_Idents; 2340 Ident := Ident + 1; 2341 Restore_Scan_State (Scan_State); 2342 end loop Ident_Loop; 2343 2344 exit Specification_Loop when Token /= Tok_Semicolon; 2345 Scan; -- past ; 2346 P_Pragmas_Misplaced; 2347 end loop Specification_Loop; 2348 2349 T_Right_Paren; 2350 return Specification_List; 2351 2352 else 2353 return No_List; 2354 end if; 2355 end P_Known_Discriminant_Part_Opt; 2356 2357 ------------------------------------- 2358 -- 3.7 DIscriminant Specification -- 2359 ------------------------------------- 2360 2361 -- Parsed by P_Known_Discriminant_Part_Opt (3.7) 2362 2363 ----------------------------- 2364 -- 3.7 Default Expression -- 2365 ----------------------------- 2366 2367 -- Always parsed (simply as an Expression) by the parent construct 2368 2369 ------------------------------------ 2370 -- 3.7.1 Discriminant Constraint -- 2371 ------------------------------------ 2372 2373 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1) 2374 2375 -------------------------------------------------------- 2376 -- 3.7.1 Index or Discriminant Constraint (also 3.6) -- 2377 -------------------------------------------------------- 2378 2379 -- DISCRIMINANT_CONSTRAINT ::= 2380 -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION}) 2381 2382 -- DISCRIMINANT_ASSOCIATION ::= 2383 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>] 2384 -- EXPRESSION 2385 2386 -- This routine parses either an index or a discriminant constraint. As 2387 -- is clear from the above grammar, it is often possible to clearly 2388 -- determine which of the two possibilities we have, but there are 2389 -- cases (those in which we have a series of expressions of the same 2390 -- syntactic form as subtype indications), where we cannot tell. Since 2391 -- this means that in any case the semantic phase has to distinguish 2392 -- between the two, there is not much point in the parser trying to 2393 -- distinguish even those cases where the difference is clear. In any 2394 -- case, if we have a situation like: 2395 2396 -- (A => 123, 235 .. 500) 2397 2398 -- it is not clear which of the two items is the wrong one, better to 2399 -- let the semantic phase give a clear message. Consequently, this 2400 -- routine in general returns a list of items which can be either 2401 -- discrete ranges or discriminant associations. 2402 2403 -- The caller has checked that the initial token is a left paren 2404 2405 -- Error recovery: can raise Error_Resync 2406 2407 function P_Index_Or_Discriminant_Constraint return Node_Id is 2408 Scan_State : Saved_Scan_State; 2409 Constr_Node : Node_Id; 2410 Constr_List : List_Id; 2411 Expr_Node : Node_Id; 2412 Result_Node : Node_Id; 2413 2414 begin 2415 Result_Node := New_Node (N_Index_Or_Discriminant_Constraint, Token_Ptr); 2416 Scan; -- past ( 2417 Constr_List := New_List; 2418 Set_Constraints (Result_Node, Constr_List); 2419 2420 -- The two syntactic forms are a little mixed up, so what we are doing 2421 -- here is looking at the first entry to determine which case we have 2422 2423 -- A discriminant constraint is a list of discriminant associations, 2424 -- which have one of the following possible forms: 2425 2426 -- Expression 2427 -- Id => Expression 2428 -- Id | Id | .. | Id => Expression 2429 2430 -- An index constraint is a list of discrete ranges which have one 2431 -- of the following possible forms: 2432 2433 -- Subtype_Mark 2434 -- Subtype_Mark range Range 2435 -- Range_Attribute 2436 -- Simple_Expression .. Simple_Expression 2437 2438 -- Loop through discriminants in list 2439 2440 loop 2441 -- Check cases of Id => Expression or Id | Id => Expression 2442 2443 if Token = Tok_Identifier then 2444 Save_Scan_State (Scan_State); -- at Id 2445 Scan; -- past Id 2446 2447 if Token = Tok_Arrow or else Token = Tok_Vertical_Bar then 2448 Restore_Scan_State (Scan_State); -- to Id 2449 Append (P_Discriminant_Association, Constr_List); 2450 goto Loop_Continue; 2451 else 2452 Restore_Scan_State (Scan_State); -- to Id 2453 end if; 2454 end if; 2455 2456 -- Otherwise scan out an expression and see what we have got 2457 2458 Expr_Node := P_Expression_Or_Range_Attribute; 2459 2460 if Expr_Form = EF_Range_Attr then 2461 Append (Expr_Node, Constr_List); 2462 2463 elsif Token = Tok_Range then 2464 if Expr_Form /= EF_Simple_Name then 2465 Error_Msg_SC ("subtype mark required before RANGE"); 2466 end if; 2467 2468 Append (P_Subtype_Indication (Expr_Node), Constr_List); 2469 goto Loop_Continue; 2470 2471 -- Check Simple_Expression .. Simple_Expression case 2472 2473 elsif Token = Tok_Dot_Dot then 2474 Check_Simple_Expression (Expr_Node); 2475 Constr_Node := New_Node (N_Range, Token_Ptr); 2476 Set_Low_Bound (Constr_Node, Expr_Node); 2477 Scan; -- past .. 2478 Expr_Node := P_Expression; 2479 Check_Simple_Expression (Expr_Node); 2480 Set_High_Bound (Constr_Node, Expr_Node); 2481 Append (Constr_Node, Constr_List); 2482 goto Loop_Continue; 2483 2484 -- Case of an expression which could be either form 2485 2486 else 2487 Append (Expr_Node, Constr_List); 2488 goto Loop_Continue; 2489 end if; 2490 2491 -- Here with a single entry scanned 2492 2493 <<Loop_Continue>> 2494 exit when not Comma_Present; 2495 2496 end loop; 2497 2498 T_Right_Paren; 2499 return Result_Node; 2500 end P_Index_Or_Discriminant_Constraint; 2501 2502 ------------------------------------- 2503 -- 3.7.1 Discriminant Association -- 2504 ------------------------------------- 2505 2506 -- DISCRIMINANT_ASSOCIATION ::= 2507 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>] 2508 -- EXPRESSION 2509 2510 -- This routine is used only when the name list is present and the caller 2511 -- has already checked this (by scanning ahead and repositioning the 2512 -- scan). 2513 2514 -- Error_Recovery: cannot raise Error_Resync; 2515 2516 function P_Discriminant_Association return Node_Id is 2517 Discr_Node : Node_Id; 2518 Names_List : List_Id; 2519 Ident_Sloc : Source_Ptr; 2520 2521 begin 2522 Ident_Sloc := Token_Ptr; 2523 Names_List := New_List; 2524 2525 loop 2526 Append (P_Identifier (C_Vertical_Bar_Arrow), Names_List); 2527 exit when Token /= Tok_Vertical_Bar; 2528 Scan; -- past | 2529 end loop; 2530 2531 Discr_Node := New_Node (N_Discriminant_Association, Ident_Sloc); 2532 Set_Selector_Names (Discr_Node, Names_List); 2533 TF_Arrow; 2534 Set_Expression (Discr_Node, P_Expression); 2535 return Discr_Node; 2536 end P_Discriminant_Association; 2537 2538 --------------------------------- 2539 -- 3.8 Record Type Definition -- 2540 --------------------------------- 2541 2542 -- RECORD_TYPE_DEFINITION ::= 2543 -- [[abstract] tagged] [limited] RECORD_DEFINITION 2544 2545 -- There is no node in the tree for a record type definition. Instead 2546 -- a record definition node appears, with possible Abstract_Present, 2547 -- Tagged_Present, and Limited_Present flags set appropriately. 2548 2549 ---------------------------- 2550 -- 3.8 Record Definition -- 2551 ---------------------------- 2552 2553 -- RECORD_DEFINITION ::= 2554 -- record 2555 -- COMPONENT_LIST 2556 -- end record 2557 -- | null record 2558 2559 -- Note: in the case where a record definition node is used to represent 2560 -- a record type definition, the caller sets the Tagged_Present and 2561 -- Limited_Present flags in the resulting N_Record_Definition node as 2562 -- required. 2563 2564 -- Note that the RECORD token at the start may be missing in certain 2565 -- error situations, so this function is expected to post the error 2566 2567 -- Error recovery: can raise Error_Resync 2568 2569 function P_Record_Definition return Node_Id is 2570 Rec_Node : Node_Id; 2571 2572 begin 2573 Rec_Node := New_Node (N_Record_Definition, Token_Ptr); 2574 2575 -- Null record case 2576 2577 if Token = Tok_Null then 2578 Scan; -- past NULL 2579 T_Record; 2580 Set_Null_Present (Rec_Node, True); 2581 2582 -- Case starting with RECORD keyword. Build scope stack entry. For the 2583 -- column, we use the first non-blank character on the line, to deal 2584 -- with situations such as: 2585 2586 -- type X is record 2587 -- ... 2588 -- end record; 2589 2590 -- which is not official RM indentation, but is not uncommon usage 2591 2592 else 2593 Push_Scope_Stack; 2594 Scope.Table (Scope.Last).Etyp := E_Record; 2595 Scope.Table (Scope.Last).Ecol := Start_Column; 2596 Scope.Table (Scope.Last).Sloc := Token_Ptr; 2597 Scope.Table (Scope.Last).Labl := Error; 2598 Scope.Table (Scope.Last).Junk := (Token /= Tok_Record); 2599 2600 T_Record; 2601 2602 Set_Component_List (Rec_Node, P_Component_List); 2603 2604 loop 2605 exit when Check_End; 2606 Discard_Junk_Node (P_Component_List); 2607 end loop; 2608 end if; 2609 2610 return Rec_Node; 2611 end P_Record_Definition; 2612 2613 ------------------------- 2614 -- 3.8 Component List -- 2615 ------------------------- 2616 2617 -- COMPONENT_LIST ::= 2618 -- COMPONENT_ITEM {COMPONENT_ITEM} 2619 -- | {COMPONENT_ITEM} VARIANT_PART 2620 -- | null; 2621 2622 -- Error recovery: cannot raise Error_Resync 2623 2624 function P_Component_List return Node_Id is 2625 Component_List_Node : Node_Id; 2626 Decls_List : List_Id; 2627 Scan_State : Saved_Scan_State; 2628 2629 begin 2630 Component_List_Node := New_Node (N_Component_List, Token_Ptr); 2631 Decls_List := New_List; 2632 2633 if Token = Tok_Null then 2634 Scan; -- past NULL 2635 TF_Semicolon; 2636 P_Pragmas_Opt (Decls_List); 2637 Set_Null_Present (Component_List_Node, True); 2638 return Component_List_Node; 2639 2640 else 2641 P_Pragmas_Opt (Decls_List); 2642 2643 if Token /= Tok_Case then 2644 Component_Scan_Loop : loop 2645 P_Component_Items (Decls_List); 2646 P_Pragmas_Opt (Decls_List); 2647 2648 exit Component_Scan_Loop when Token = Tok_End 2649 or else Token = Tok_Case 2650 or else Token = Tok_When; 2651 2652 -- We are done if we do not have an identifier. However, if 2653 -- we have a misspelled reserved identifier that is in a column 2654 -- to the right of the record definition, we will treat it as 2655 -- an identifier. It turns out to be too dangerous in practice 2656 -- to accept such a mis-spelled identifier which does not have 2657 -- this additional clue that confirms the incorrect spelling. 2658 2659 if Token /= Tok_Identifier then 2660 if Start_Column > Scope.Table (Scope.Last).Ecol 2661 and then Is_Reserved_Identifier 2662 then 2663 Save_Scan_State (Scan_State); -- at reserved id 2664 Scan; -- possible reserved id 2665 2666 if Token = Tok_Comma or else Token = Tok_Colon then 2667 Restore_Scan_State (Scan_State); 2668 Scan_Reserved_Identifier (Force_Msg => True); 2669 2670 -- Note reserved identifier used as field name after 2671 -- all because not followed by colon or comma 2672 2673 else 2674 Restore_Scan_State (Scan_State); 2675 exit Component_Scan_Loop; 2676 end if; 2677 2678 -- Non-identifier that definitely was not reserved id 2679 2680 else 2681 exit Component_Scan_Loop; 2682 end if; 2683 end if; 2684 end loop Component_Scan_Loop; 2685 end if; 2686 2687 if Token = Tok_Case then 2688 Set_Variant_Part (Component_List_Node, P_Variant_Part); 2689 2690 -- Check for junk after variant part 2691 2692 if Token = Tok_Identifier then 2693 Save_Scan_State (Scan_State); 2694 Scan; -- past identifier 2695 2696 if Token = Tok_Colon then 2697 Restore_Scan_State (Scan_State); 2698 Error_Msg_SC ("component may not follow variant part"); 2699 Discard_Junk_Node (P_Component_List); 2700 2701 elsif Token = Tok_Case then 2702 Restore_Scan_State (Scan_State); 2703 Error_Msg_SC ("only one variant part allowed in a record"); 2704 Discard_Junk_Node (P_Component_List); 2705 2706 else 2707 Restore_Scan_State (Scan_State); 2708 end if; 2709 end if; 2710 end if; 2711 end if; 2712 2713 Set_Component_Items (Component_List_Node, Decls_List); 2714 return Component_List_Node; 2715 end P_Component_List; 2716 2717 ------------------------- 2718 -- 3.8 Component Item -- 2719 ------------------------- 2720 2721 -- COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE 2722 2723 -- COMPONENT_DECLARATION ::= 2724 -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION 2725 -- [:= DEFAULT_EXPRESSION]; 2726 2727 -- COMPONENT_DEFINITION ::= [aliased] SUBTYPE_INDICATION 2728 2729 -- Error recovery: cannot raise Error_Resync, if an error occurs, 2730 -- the scan is positioned past the following semicolon. 2731 2732 -- Note: we do not yet allow representation clauses to appear as component 2733 -- items, do we need to add this capability sometime in the future ??? 2734 2735 procedure P_Component_Items (Decls : List_Id) is 2736 CompDef_Node : Node_Id; 2737 Decl_Node : Node_Id; 2738 Scan_State : Saved_Scan_State; 2739 Num_Idents : Nat; 2740 Ident : Nat; 2741 Ident_Sloc : Source_Ptr; 2742 2743 Idents : array (Int range 1 .. 4096) of Entity_Id; 2744 -- This array holds the list of defining identifiers. The upper bound 2745 -- of 4096 is intended to be essentially infinite, and we do not even 2746 -- bother to check for it being exceeded. 2747 2748 begin 2749 if Token /= Tok_Identifier then 2750 Error_Msg_SC ("component declaration expected"); 2751 Resync_Past_Semicolon; 2752 return; 2753 end if; 2754 2755 Ident_Sloc := Token_Ptr; 2756 Idents (1) := P_Defining_Identifier (C_Comma_Colon); 2757 Num_Idents := 1; 2758 2759 while Comma_Present loop 2760 Num_Idents := Num_Idents + 1; 2761 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon); 2762 end loop; 2763 2764 T_Colon; 2765 2766 -- If there are multiple identifiers, we repeatedly scan the 2767 -- type and initialization expression information by resetting 2768 -- the scan pointer (so that we get completely separate trees 2769 -- for each occurrence). 2770 2771 if Num_Idents > 1 then 2772 Save_Scan_State (Scan_State); 2773 end if; 2774 2775 -- Loop through defining identifiers in list 2776 2777 Ident := 1; 2778 Ident_Loop : loop 2779 2780 -- The following block is present to catch Error_Resync 2781 -- which causes the parse to be reset past the semicolon 2782 2783 begin 2784 Decl_Node := New_Node (N_Component_Declaration, Ident_Sloc); 2785 Set_Defining_Identifier (Decl_Node, Idents (Ident)); 2786 2787 if Token = Tok_Constant then 2788 Error_Msg_SC ("constant components are not permitted"); 2789 Scan; 2790 end if; 2791 2792 CompDef_Node := New_Node (N_Component_Definition, Token_Ptr); 2793 2794 if Token_Name = Name_Aliased then 2795 Check_95_Keyword (Tok_Aliased, Tok_Identifier); 2796 end if; 2797 2798 if Token = Tok_Aliased then 2799 Scan; -- past ALIASED 2800 Set_Aliased_Present (CompDef_Node, True); 2801 end if; 2802 2803 if Token = Tok_Array then 2804 Error_Msg_SC ("anonymous arrays not allowed as components"); 2805 raise Error_Resync; 2806 end if; 2807 2808 Set_Subtype_Indication (CompDef_Node, P_Subtype_Indication); 2809 Set_Component_Definition (Decl_Node, CompDef_Node); 2810 Set_Expression (Decl_Node, Init_Expr_Opt); 2811 2812 if Ident > 1 then 2813 Set_Prev_Ids (Decl_Node, True); 2814 end if; 2815 2816 if Ident < Num_Idents then 2817 Set_More_Ids (Decl_Node, True); 2818 end if; 2819 2820 Append (Decl_Node, Decls); 2821 2822 exception 2823 when Error_Resync => 2824 if Token /= Tok_End then 2825 Resync_Past_Semicolon; 2826 end if; 2827 end; 2828 2829 exit Ident_Loop when Ident = Num_Idents; 2830 Ident := Ident + 1; 2831 Restore_Scan_State (Scan_State); 2832 2833 end loop Ident_Loop; 2834 2835 TF_Semicolon; 2836 end P_Component_Items; 2837 2838 -------------------------------- 2839 -- 3.8 Component Declaration -- 2840 -------------------------------- 2841 2842 -- Parsed by P_Component_Items (3.8) 2843 2844 ------------------------- 2845 -- 3.8.1 Variant Part -- 2846 ------------------------- 2847 2848 -- VARIANT_PART ::= 2849 -- case discriminant_DIRECT_NAME is 2850 -- VARIANT 2851 -- {VARIANT} 2852 -- end case; 2853 2854 -- The caller has checked that the initial token is CASE 2855 2856 -- Error recovery: cannot raise Error_Resync 2857 2858 function P_Variant_Part return Node_Id is 2859 Variant_Part_Node : Node_Id; 2860 Variants_List : List_Id; 2861 Case_Node : Node_Id; 2862 2863 begin 2864 Variant_Part_Node := New_Node (N_Variant_Part, Token_Ptr); 2865 Push_Scope_Stack; 2866 Scope.Table (Scope.Last).Etyp := E_Case; 2867 Scope.Table (Scope.Last).Sloc := Token_Ptr; 2868 Scope.Table (Scope.Last).Ecol := Start_Column; 2869 2870 Scan; -- past CASE 2871 Case_Node := P_Expression; 2872 Set_Name (Variant_Part_Node, Case_Node); 2873 2874 if Nkind (Case_Node) /= N_Identifier then 2875 Set_Name (Variant_Part_Node, Error); 2876 Error_Msg ("discriminant name expected", Sloc (Case_Node)); 2877 end if; 2878 2879 TF_Is; 2880 Variants_List := New_List; 2881 P_Pragmas_Opt (Variants_List); 2882 2883 -- Test missing variant 2884 2885 if Token = Tok_End then 2886 Error_Msg_BC ("WHEN expected (must have at least one variant)"); 2887 else 2888 Append (P_Variant, Variants_List); 2889 end if; 2890 2891 -- Loop through variants, note that we allow if in place of when, 2892 -- this error will be detected and handled in P_Variant. 2893 2894 loop 2895 P_Pragmas_Opt (Variants_List); 2896 2897 if Token /= Tok_When 2898 and then Token /= Tok_If 2899 and then Token /= Tok_Others 2900 then 2901 exit when Check_End; 2902 end if; 2903 2904 Append (P_Variant, Variants_List); 2905 end loop; 2906 2907 Set_Variants (Variant_Part_Node, Variants_List); 2908 return Variant_Part_Node; 2909 end P_Variant_Part; 2910 2911 -------------------- 2912 -- 3.8.1 Variant -- 2913 -------------------- 2914 2915 -- VARIANT ::= 2916 -- when DISCRETE_CHOICE_LIST => 2917 -- COMPONENT_LIST 2918 2919 -- Error recovery: cannot raise Error_Resync 2920 2921 -- The initial token on entry is either WHEN, IF or OTHERS 2922 2923 function P_Variant return Node_Id is 2924 Variant_Node : Node_Id; 2925 2926 begin 2927 -- Special check to recover nicely from use of IF in place of WHEN 2928 2929 if Token = Tok_If then 2930 T_When; 2931 Scan; -- past IF 2932 else 2933 T_When; 2934 end if; 2935 2936 Variant_Node := New_Node (N_Variant, Prev_Token_Ptr); 2937 Set_Discrete_Choices (Variant_Node, P_Discrete_Choice_List); 2938 TF_Arrow; 2939 Set_Component_List (Variant_Node, P_Component_List); 2940 return Variant_Node; 2941 end P_Variant; 2942 2943 --------------------------------- 2944 -- 3.8.1 Discrete Choice List -- 2945 --------------------------------- 2946 2947 -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE} 2948 2949 -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others 2950 2951 -- Note: in Ada 83, the expression must be a simple expression 2952 2953 -- Error recovery: cannot raise Error_Resync 2954 2955 function P_Discrete_Choice_List return List_Id is 2956 Choices : List_Id; 2957 Expr_Node : Node_Id; 2958 Choice_Node : Node_Id; 2959 2960 begin 2961 Choices := New_List; 2962 2963 loop 2964 if Token = Tok_Others then 2965 Append (New_Node (N_Others_Choice, Token_Ptr), Choices); 2966 Scan; -- past OTHERS 2967 2968 else 2969 begin 2970 Expr_Node := No_Right_Paren (P_Expression_Or_Range_Attribute); 2971 2972 if Token = Tok_Colon 2973 and then Nkind (Expr_Node) = N_Identifier 2974 then 2975 Error_Msg_SP ("label not permitted in this context"); 2976 Scan; -- past colon 2977 2978 elsif Expr_Form = EF_Range_Attr then 2979 Append (Expr_Node, Choices); 2980 2981 elsif Token = Tok_Dot_Dot then 2982 Check_Simple_Expression (Expr_Node); 2983 Choice_Node := New_Node (N_Range, Token_Ptr); 2984 Set_Low_Bound (Choice_Node, Expr_Node); 2985 Scan; -- past .. 2986 Expr_Node := P_Expression_No_Right_Paren; 2987 Check_Simple_Expression (Expr_Node); 2988 Set_High_Bound (Choice_Node, Expr_Node); 2989 Append (Choice_Node, Choices); 2990 2991 elsif Expr_Form = EF_Simple_Name then 2992 if Token = Tok_Range then 2993 Append (P_Subtype_Indication (Expr_Node), Choices); 2994 2995 elsif Token in Token_Class_Consk then 2996 Error_Msg_SC 2997 ("the only constraint allowed here " & 2998 "is a range constraint"); 2999 Discard_Junk_Node (P_Constraint_Opt); 3000 Append (Expr_Node, Choices); 3001 3002 else 3003 Append (Expr_Node, Choices); 3004 end if; 3005 3006 else 3007 Check_Simple_Expression_In_Ada_83 (Expr_Node); 3008 Append (Expr_Node, Choices); 3009 end if; 3010 3011 exception 3012 when Error_Resync => 3013 Resync_Choice; 3014 return Error_List; 3015 end; 3016 end if; 3017 3018 if Token = Tok_Comma then 3019 Error_Msg_SC (""","" should be ""'|"""); 3020 else 3021 exit when Token /= Tok_Vertical_Bar; 3022 end if; 3023 3024 Scan; -- past | or comma 3025 end loop; 3026 3027 return Choices; 3028 end P_Discrete_Choice_List; 3029 3030 ---------------------------- 3031 -- 3.8.1 Discrete Choice -- 3032 ---------------------------- 3033 3034 -- Parsed by P_Discrete_Choice_List (3.8.1) 3035 3036 ---------------------------------- 3037 -- 3.9.1 Record Extension Part -- 3038 ---------------------------------- 3039 3040 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION 3041 3042 -- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4) 3043 3044 ---------------------------------- 3045 -- 3.10 Access Type Definition -- 3046 ---------------------------------- 3047 3048 -- ACCESS_TYPE_DEFINITION ::= 3049 -- ACCESS_TO_OBJECT_DEFINITION 3050 -- | ACCESS_TO_SUBPROGRAM_DEFINITION 3051 3052 -- ACCESS_TO_OBJECT_DEFINITION ::= 3053 -- access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION 3054 3055 -- GENERAL_ACCESS_MODIFIER ::= all | constant 3056 3057 -- ACCESS_TO_SUBPROGRAM_DEFINITION 3058 -- access [protected] procedure PARAMETER_PROFILE 3059 -- | access [protected] function PARAMETER_AND_RESULT_PROFILE 3060 3061 -- PARAMETER_PROFILE ::= [FORMAL_PART] 3062 3063 -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK 3064 3065 -- The caller has checked that the initial token is ACCESS 3066 3067 -- Error recovery: can raise Error_Resync 3068 3069 function P_Access_Type_Definition return Node_Id is 3070 Prot_Flag : Boolean; 3071 Access_Loc : Source_Ptr; 3072 Type_Def_Node : Node_Id; 3073 3074 procedure Check_Junk_Subprogram_Name; 3075 -- Used in access to subprogram definition cases to check for an 3076 -- identifier or operator symbol that does not belong. 3077 3078 procedure Check_Junk_Subprogram_Name is 3079 Saved_State : Saved_Scan_State; 3080 3081 begin 3082 if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then 3083 Save_Scan_State (Saved_State); 3084 Scan; -- past possible junk subprogram name 3085 3086 if Token = Tok_Left_Paren or else Token = Tok_Semicolon then 3087 Error_Msg_SP ("unexpected subprogram name ignored"); 3088 return; 3089 3090 else 3091 Restore_Scan_State (Saved_State); 3092 end if; 3093 end if; 3094 end Check_Junk_Subprogram_Name; 3095 3096 -- Start of processing for P_Access_Type_Definition 3097 3098 begin 3099 Access_Loc := Token_Ptr; 3100 Scan; -- past ACCESS 3101 3102 if Token_Name = Name_Protected then 3103 Check_95_Keyword (Tok_Protected, Tok_Procedure); 3104 Check_95_Keyword (Tok_Protected, Tok_Function); 3105 end if; 3106 3107 Prot_Flag := (Token = Tok_Protected); 3108 3109 if Prot_Flag then 3110 Scan; -- past PROTECTED 3111 if Token /= Tok_Procedure and then Token /= Tok_Function then 3112 Error_Msg_SC ("FUNCTION or PROCEDURE expected"); 3113 end if; 3114 end if; 3115 3116 if Token = Tok_Procedure then 3117 if Ada_83 then 3118 Error_Msg_SC ("(Ada 83) access to procedure not allowed!"); 3119 end if; 3120 3121 Type_Def_Node := New_Node (N_Access_Procedure_Definition, Access_Loc); 3122 Scan; -- past PROCEDURE 3123 Check_Junk_Subprogram_Name; 3124 Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile); 3125 Set_Protected_Present (Type_Def_Node, Prot_Flag); 3126 3127 elsif Token = Tok_Function then 3128 if Ada_83 then 3129 Error_Msg_SC ("(Ada 83) access to function not allowed!"); 3130 end if; 3131 3132 Type_Def_Node := New_Node (N_Access_Function_Definition, Access_Loc); 3133 Scan; -- past FUNCTION 3134 Check_Junk_Subprogram_Name; 3135 Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile); 3136 Set_Protected_Present (Type_Def_Node, Prot_Flag); 3137 TF_Return; 3138 Set_Subtype_Mark (Type_Def_Node, P_Subtype_Mark); 3139 No_Constraint; 3140 3141 else 3142 Type_Def_Node := 3143 New_Node (N_Access_To_Object_Definition, Access_Loc); 3144 3145 if Token = Tok_All or else Token = Tok_Constant then 3146 if Ada_83 then 3147 Error_Msg_SC ("(Ada 83) access modifier not allowed!"); 3148 end if; 3149 3150 if Token = Tok_All then 3151 Set_All_Present (Type_Def_Node, True); 3152 3153 else 3154 Set_Constant_Present (Type_Def_Node, True); 3155 end if; 3156 3157 Scan; -- past ALL or CONSTANT 3158 end if; 3159 3160 Set_Subtype_Indication (Type_Def_Node, P_Subtype_Indication); 3161 end if; 3162 3163 return Type_Def_Node; 3164 end P_Access_Type_Definition; 3165 3166 --------------------------------------- 3167 -- 3.10 Access To Object Definition -- 3168 --------------------------------------- 3169 3170 -- Parsed by P_Access_Type_Definition (3.10) 3171 3172 ----------------------------------- 3173 -- 3.10 General Access Modifier -- 3174 ----------------------------------- 3175 3176 -- Parsed by P_Access_Type_Definition (3.10) 3177 3178 ------------------------------------------- 3179 -- 3.10 Access To Subprogram Definition -- 3180 ------------------------------------------- 3181 3182 -- Parsed by P_Access_Type_Definition (3.10) 3183 3184 ----------------------------- 3185 -- 3.10 Access Definition -- 3186 ----------------------------- 3187 3188 -- ACCESS_DEFINITION ::= access SUBTYPE_MARK 3189 3190 -- The caller has checked that the initial token is ACCESS 3191 3192 -- Error recovery: cannot raise Error_Resync 3193 3194 function P_Access_Definition return Node_Id is 3195 Def_Node : Node_Id; 3196 3197 begin 3198 Def_Node := New_Node (N_Access_Definition, Token_Ptr); 3199 Scan; -- past ACCESS 3200 Set_Subtype_Mark (Def_Node, P_Subtype_Mark); 3201 No_Constraint; 3202 return Def_Node; 3203 end P_Access_Definition; 3204 3205 ----------------------------------------- 3206 -- 3.10.1 Incomplete Type Declaration -- 3207 ----------------------------------------- 3208 3209 -- Parsed by P_Type_Declaration (3.2.1) 3210 3211 ---------------------------- 3212 -- 3.11 Declarative Part -- 3213 ---------------------------- 3214 3215 -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM} 3216 3217 -- Error recovery: cannot raise Error_Resync (because P_Declarative_Items 3218 -- handles errors, and returns cleanly after an error has occurred) 3219 3220 function P_Declarative_Part return List_Id is 3221 Decls : List_Id; 3222 Done : Boolean; 3223 3224 begin 3225 -- Indicate no bad declarations detected yet. This will be reset by 3226 -- P_Declarative_Items if a bad declaration is discovered. 3227 3228 Missing_Begin_Msg := No_Error_Msg; 3229 3230 -- Get rid of active SIS entry from outer scope. This means we will 3231 -- miss some nested cases, but it doesn't seem worth the effort. See 3232 -- discussion in Par for further details 3233 3234 SIS_Entry_Active := False; 3235 Decls := New_List; 3236 3237 -- Loop to scan out the declarations 3238 3239 loop 3240 P_Declarative_Items (Decls, Done, In_Spec => False); 3241 exit when Done; 3242 end loop; 3243 3244 -- Get rid of active SIS entry which is left set only if we scanned a 3245 -- procedure declaration and have not found the body. We could give 3246 -- an error message, but that really would be usurping the role of 3247 -- semantic analysis (this really is a missing body case). 3248 3249 SIS_Entry_Active := False; 3250 return Decls; 3251 end P_Declarative_Part; 3252 3253 ---------------------------- 3254 -- 3.11 Declarative Item -- 3255 ---------------------------- 3256 3257 -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY 3258 3259 -- Can return Error if a junk declaration is found, or Empty if no 3260 -- declaration is found (i.e. a token ending declarations, such as 3261 -- BEGIN or END is encountered). 3262 3263 -- Error recovery: cannot raise Error_Resync. If an error resync occurs, 3264 -- then the scan is set past the next semicolon and Error is returned. 3265 3266 procedure P_Declarative_Items 3267 (Decls : List_Id; 3268 Done : out Boolean; 3269 In_Spec : Boolean) 3270 is 3271 Scan_State : Saved_Scan_State; 3272 3273 begin 3274 if Style_Check then Style.Check_Indentation; end if; 3275 3276 case Token is 3277 3278 when Tok_Function => 3279 Check_Bad_Layout; 3280 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls); 3281 Done := False; 3282 3283 when Tok_For => 3284 Check_Bad_Layout; 3285 3286 -- Check for loop (premature statement) 3287 3288 Save_Scan_State (Scan_State); 3289 Scan; -- past FOR 3290 3291 if Token = Tok_Identifier then 3292 Scan; -- past identifier 3293 3294 if Token = Tok_In then 3295 Restore_Scan_State (Scan_State); 3296 Statement_When_Declaration_Expected (Decls, Done, In_Spec); 3297 return; 3298 end if; 3299 end if; 3300 3301 -- Not a loop, so must be rep clause 3302 3303 Restore_Scan_State (Scan_State); 3304 Append (P_Representation_Clause, Decls); 3305 Done := False; 3306 3307 when Tok_Generic => 3308 Check_Bad_Layout; 3309 Append (P_Generic, Decls); 3310 Done := False; 3311 3312 when Tok_Identifier => 3313 Check_Bad_Layout; 3314 P_Identifier_Declarations (Decls, Done, In_Spec); 3315 3316 when Tok_Package => 3317 Check_Bad_Layout; 3318 Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls); 3319 Done := False; 3320 3321 when Tok_Pragma => 3322 Append (P_Pragma, Decls); 3323 Done := False; 3324 3325 when Tok_Procedure => 3326 Check_Bad_Layout; 3327 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls); 3328 Done := False; 3329 3330 when Tok_Protected => 3331 Check_Bad_Layout; 3332 Scan; -- past PROTECTED 3333 Append (P_Protected, Decls); 3334 Done := False; 3335 3336 when Tok_Subtype => 3337 Check_Bad_Layout; 3338 Append (P_Subtype_Declaration, Decls); 3339 Done := False; 3340 3341 when Tok_Task => 3342 Check_Bad_Layout; 3343 Scan; -- past TASK 3344 Append (P_Task, Decls); 3345 Done := False; 3346 3347 when Tok_Type => 3348 Check_Bad_Layout; 3349 Append (P_Type_Declaration, Decls); 3350 Done := False; 3351 3352 when Tok_Use => 3353 Check_Bad_Layout; 3354 Append (P_Use_Clause, Decls); 3355 Done := False; 3356 3357 when Tok_With => 3358 Check_Bad_Layout; 3359 Error_Msg_SC ("WITH can only appear in context clause"); 3360 raise Error_Resync; 3361 3362 -- BEGIN terminates the scan of a sequence of declarations unless 3363 -- there is a missing subprogram body, see section on handling 3364 -- semicolon in place of IS. We only treat the begin as satisfying 3365 -- the subprogram declaration if it falls in the expected column 3366 -- or to its right. 3367 3368 when Tok_Begin => 3369 if SIS_Entry_Active and then Start_Column >= SIS_Ecol then 3370 3371 -- Here we have the case where a BEGIN is encountered during 3372 -- declarations in a declarative part, or at the outer level, 3373 -- and there is a subprogram declaration outstanding for which 3374 -- no body has been supplied. This is the case where we assume 3375 -- that the semicolon in the subprogram declaration should 3376 -- really have been is. The active SIS entry describes the 3377 -- subprogram declaration. On return the declaration has been 3378 -- modified to become a body. 3379 3380 declare 3381 Specification_Node : Node_Id; 3382 Decl_Node : Node_Id; 3383 Body_Node : Node_Id; 3384 3385 begin 3386 -- First issue the error message. If we had a missing 3387 -- semicolon in the declaration, then change the message 3388 -- to <missing "is"> 3389 3390 if SIS_Missing_Semicolon_Message /= No_Error_Msg then 3391 Change_Error_Text -- Replace: "missing "";"" " 3392 (SIS_Missing_Semicolon_Message, "missing ""is"""); 3393 3394 -- Otherwise we saved the semicolon position, so complain 3395 3396 else 3397 Error_Msg (""";"" should be IS", SIS_Semicolon_Sloc); 3398 end if; 3399 3400 -- The next job is to fix up any declarations that occurred 3401 -- between the procedure header and the BEGIN. These got 3402 -- chained to the outer declarative region (immediately 3403 -- after the procedure declaration) and they should be 3404 -- chained to the subprogram itself, which is a body 3405 -- rather than a spec. 3406 3407 Specification_Node := Specification (SIS_Declaration_Node); 3408 Change_Node (SIS_Declaration_Node, N_Subprogram_Body); 3409 Body_Node := SIS_Declaration_Node; 3410 Set_Specification (Body_Node, Specification_Node); 3411 Set_Declarations (Body_Node, New_List); 3412 3413 loop 3414 Decl_Node := Remove_Next (Body_Node); 3415 exit when Decl_Node = Empty; 3416 Append (Decl_Node, Declarations (Body_Node)); 3417 end loop; 3418 3419 -- Now make the scope table entry for the Begin-End and 3420 -- scan it out 3421 3422 Push_Scope_Stack; 3423 Scope.Table (Scope.Last).Sloc := SIS_Sloc; 3424 Scope.Table (Scope.Last).Etyp := E_Name; 3425 Scope.Table (Scope.Last).Ecol := SIS_Ecol; 3426 Scope.Table (Scope.Last).Labl := SIS_Labl; 3427 Scope.Table (Scope.Last).Lreq := False; 3428 SIS_Entry_Active := False; 3429 Scan; -- past BEGIN 3430 Set_Handled_Statement_Sequence (Body_Node, 3431 P_Handled_Sequence_Of_Statements); 3432 End_Statements (Handled_Statement_Sequence (Body_Node)); 3433 end; 3434 3435 Done := False; 3436 3437 else 3438 Done := True; 3439 end if; 3440 3441 -- Normally an END terminates the scan for basic declarative 3442 -- items. The one exception is END RECORD, which is probably 3443 -- left over from some other junk. 3444 3445 when Tok_End => 3446 Save_Scan_State (Scan_State); -- at END 3447 Scan; -- past END 3448 3449 if Token = Tok_Record then 3450 Error_Msg_SP ("no RECORD for this `end record`!"); 3451 Scan; -- past RECORD 3452 TF_Semicolon; 3453 3454 else 3455 Restore_Scan_State (Scan_State); -- to END 3456 Done := True; 3457 end if; 3458 3459 -- The following tokens which can only be the start of a statement 3460 -- are considered to end a declarative part (i.e. we have a missing 3461 -- BEGIN situation). We are fairly conservative in making this 3462 -- judgment, because it is a real mess to go into statement mode 3463 -- prematurely in response to a junk declaration. 3464 3465 when Tok_Abort | 3466 Tok_Accept | 3467 Tok_Declare | 3468 Tok_Delay | 3469 Tok_Exit | 3470 Tok_Goto | 3471 Tok_If | 3472 Tok_Loop | 3473 Tok_Null | 3474 Tok_Requeue | 3475 Tok_Select | 3476 Tok_While => 3477 3478 -- But before we decide that it's a statement, let's check for 3479 -- a reserved word misused as an identifier. 3480 3481 if Is_Reserved_Identifier then 3482 Save_Scan_State (Scan_State); 3483 Scan; -- past the token 3484 3485 -- If reserved identifier not followed by colon or comma, then 3486 -- this is most likely an assignment statement to the bad id. 3487 3488 if Token /= Tok_Colon and then Token /= Tok_Comma then 3489 Restore_Scan_State (Scan_State); 3490 Statement_When_Declaration_Expected (Decls, Done, In_Spec); 3491 return; 3492 3493 -- Otherwise we have a declaration of the bad id 3494 3495 else 3496 Restore_Scan_State (Scan_State); 3497 Scan_Reserved_Identifier (Force_Msg => True); 3498 P_Identifier_Declarations (Decls, Done, In_Spec); 3499 end if; 3500 3501 -- If not reserved identifier, then it's definitely a statement 3502 3503 else 3504 Statement_When_Declaration_Expected (Decls, Done, In_Spec); 3505 return; 3506 end if; 3507 3508 -- The token RETURN may well also signal a missing BEGIN situation, 3509 -- however, we never let it end the declarative part, because it may 3510 -- also be part of a half-baked function declaration. 3511 3512 when Tok_Return => 3513 Error_Msg_SC ("misplaced RETURN statement"); 3514 raise Error_Resync; 3515 3516 -- PRIVATE definitely terminates the declarations in a spec, 3517 -- and is an error in a body. 3518 3519 when Tok_Private => 3520 if In_Spec then 3521 Done := True; 3522 else 3523 Error_Msg_SC ("PRIVATE not allowed in body"); 3524 Scan; -- past PRIVATE 3525 end if; 3526 3527 -- An end of file definitely terminates the declarations! 3528 3529 when Tok_EOF => 3530 Done := True; 3531 3532 -- The remaining tokens do not end the scan, but cannot start a 3533 -- valid declaration, so we signal an error and resynchronize. 3534 -- But first check for misuse of a reserved identifier. 3535 3536 when others => 3537 3538 -- Here we check for a reserved identifier 3539 3540 if Is_Reserved_Identifier then 3541 Save_Scan_State (Scan_State); 3542 Scan; -- past the token 3543 3544 if Token /= Tok_Colon and then Token /= Tok_Comma then 3545 Restore_Scan_State (Scan_State); 3546 Set_Declaration_Expected; 3547 raise Error_Resync; 3548 else 3549 Restore_Scan_State (Scan_State); 3550 Scan_Reserved_Identifier (Force_Msg => True); 3551 Check_Bad_Layout; 3552 P_Identifier_Declarations (Decls, Done, In_Spec); 3553 end if; 3554 3555 else 3556 Set_Declaration_Expected; 3557 raise Error_Resync; 3558 end if; 3559 end case; 3560 3561 -- To resynchronize after an error, we scan to the next semicolon and 3562 -- return with Done = False, indicating that there may still be more 3563 -- valid declarations to come. 3564 3565 exception 3566 when Error_Resync => 3567 Resync_Past_Semicolon; 3568 Done := False; 3569 end P_Declarative_Items; 3570 3571 ---------------------------------- 3572 -- 3.11 Basic Declarative Item -- 3573 ---------------------------------- 3574 3575 -- BASIC_DECLARATIVE_ITEM ::= 3576 -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE 3577 3578 -- Scan zero or more basic declarative items 3579 3580 -- Error recovery: cannot raise Error_Resync. If an error is detected, then 3581 -- the scan pointer is repositioned past the next semicolon, and the scan 3582 -- for declarative items continues. 3583 3584 function P_Basic_Declarative_Items return List_Id is 3585 Decl : Node_Id; 3586 Decls : List_Id; 3587 Kind : Node_Kind; 3588 Done : Boolean; 3589 3590 begin 3591 -- Indicate no bad declarations detected yet in the current context: 3592 -- visible or private declarations of a package spec. 3593 3594 Missing_Begin_Msg := No_Error_Msg; 3595 3596 -- Get rid of active SIS entry from outer scope. This means we will 3597 -- miss some nested cases, but it doesn't seem worth the effort. See 3598 -- discussion in Par for further details 3599 3600 SIS_Entry_Active := False; 3601 3602 -- Loop to scan out declarations 3603 3604 Decls := New_List; 3605 3606 loop 3607 P_Declarative_Items (Decls, Done, In_Spec => True); 3608 exit when Done; 3609 end loop; 3610 3611 -- Get rid of active SIS entry. This is set only if we have scanned a 3612 -- procedure declaration and have not found the body. We could give 3613 -- an error message, but that really would be usurping the role of 3614 -- semantic analysis (this really is a case of a missing body). 3615 3616 SIS_Entry_Active := False; 3617 3618 -- Test for assorted illegal declarations not diagnosed elsewhere. 3619 3620 Decl := First (Decls); 3621 3622 while Present (Decl) loop 3623 Kind := Nkind (Decl); 3624 3625 -- Test for body scanned, not acceptable as basic decl item 3626 3627 if Kind = N_Subprogram_Body or else 3628 Kind = N_Package_Body or else 3629 Kind = N_Task_Body or else 3630 Kind = N_Protected_Body 3631 then 3632 Error_Msg 3633 ("proper body not allowed in package spec", Sloc (Decl)); 3634 3635 -- Test for body stub scanned, not acceptable as basic decl item 3636 3637 elsif Kind in N_Body_Stub then 3638 Error_Msg 3639 ("body stub not allowed in package spec", Sloc (Decl)); 3640 3641 elsif Kind = N_Assignment_Statement then 3642 Error_Msg 3643 ("assignment statement not allowed in package spec", 3644 Sloc (Decl)); 3645 end if; 3646 3647 Next (Decl); 3648 end loop; 3649 3650 return Decls; 3651 end P_Basic_Declarative_Items; 3652 3653 ---------------- 3654 -- 3.11 Body -- 3655 ---------------- 3656 3657 -- For proper body, see below 3658 -- For body stub, see 10.1.3 3659 3660 ----------------------- 3661 -- 3.11 Proper Body -- 3662 ----------------------- 3663 3664 -- Subprogram body is parsed by P_Subprogram (6.1) 3665 -- Package body is parsed by P_Package (7.1) 3666 -- Task body is parsed by P_Task (9.1) 3667 -- Protected body is parsed by P_Protected (9.4) 3668 3669 ------------------------------ 3670 -- Set_Declaration_Expected -- 3671 ------------------------------ 3672 3673 procedure Set_Declaration_Expected is 3674 begin 3675 Error_Msg_SC ("declaration expected"); 3676 3677 if Missing_Begin_Msg = No_Error_Msg then 3678 Missing_Begin_Msg := Get_Msg_Id; 3679 end if; 3680 end Set_Declaration_Expected; 3681 3682 ---------------------- 3683 -- Skip_Declaration -- 3684 ---------------------- 3685 3686 procedure Skip_Declaration (S : List_Id) is 3687 Dummy_Done : Boolean; 3688 3689 begin 3690 P_Declarative_Items (S, Dummy_Done, False); 3691 end Skip_Declaration; 3692 3693 ----------------------------------------- 3694 -- Statement_When_Declaration_Expected -- 3695 ----------------------------------------- 3696 3697 procedure Statement_When_Declaration_Expected 3698 (Decls : List_Id; 3699 Done : out Boolean; 3700 In_Spec : Boolean) 3701 is 3702 begin 3703 -- Case of second occurrence of statement in one declaration sequence 3704 3705 if Missing_Begin_Msg /= No_Error_Msg then 3706 3707 -- In the procedure spec case, just ignore it, we only give one 3708 -- message for the first occurrence, since otherwise we may get 3709 -- horrible cascading if BODY was missing in the header line. 3710 3711 if In_Spec then 3712 null; 3713 3714 -- In the declarative part case, take a second statement as a sure 3715 -- sign that we really have a missing BEGIN, and end the declarative 3716 -- part now. Note that the caller will fix up the first message to 3717 -- say "missing BEGIN" so that's how the error will be signalled. 3718 3719 else 3720 Done := True; 3721 return; 3722 end if; 3723 3724 -- Case of first occurrence of unexpected statement 3725 3726 else 3727 -- If we are in a package spec, then give message of statement 3728 -- not allowed in package spec. This message never gets changed. 3729 3730 if In_Spec then 3731 Error_Msg_SC ("statement not allowed in package spec"); 3732 3733 -- If in declarative part, then we give the message complaining 3734 -- about finding a statement when a declaration is expected. This 3735 -- gets changed to a complaint about a missing BEGIN if we later 3736 -- find that no BEGIN is present. 3737 3738 else 3739 Error_Msg_SC ("statement not allowed in declarative part"); 3740 end if; 3741 3742 -- Capture message Id. This is used for two purposes, first to 3743 -- stop multiple messages, see test above, and second, to allow 3744 -- the replacement of the message in the declarative part case. 3745 3746 Missing_Begin_Msg := Get_Msg_Id; 3747 end if; 3748 3749 -- In all cases except the case in which we decided to terminate the 3750 -- declaration sequence on a second error, we scan out the statement 3751 -- and append it to the list of declarations (note that the semantics 3752 -- can handle statements in a declaration list so if we proceed to 3753 -- call the semantic phase, all will be (reasonably) well! 3754 3755 Append_List_To (Decls, P_Sequence_Of_Statements (SS_Unco)); 3756 3757 -- Done is set to False, since we want to continue the scan of 3758 -- declarations, hoping that this statement was a temporary glitch. 3759 -- If we indeed are now in the statement part (i.e. this was a missing 3760 -- BEGIN, then it's not terrible, we will simply keep calling this 3761 -- procedure to process the statements one by one, and then finally 3762 -- hit the missing BEGIN, which will clean up the error message. 3763 3764 Done := False; 3765 end Statement_When_Declaration_Expected; 3766 3767end Ch3; 3768