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-2013, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26pragma Style_Checks (All_Checks); 27-- Turn off subprogram body ordering check. Subprograms are in order 28-- by RM section rather than alphabetical. 29 30with Sinfo.CN; use Sinfo.CN; 31 32separate (Par) 33 34--------- 35-- Ch3 -- 36--------- 37 38package body Ch3 is 39 40 ----------------------- 41 -- Local Subprograms -- 42 ----------------------- 43 44 function P_Component_List return Node_Id; 45 function P_Defining_Character_Literal return Node_Id; 46 function P_Delta_Constraint return Node_Id; 47 function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id; 48 function P_Digits_Constraint return Node_Id; 49 function P_Discriminant_Association return Node_Id; 50 function P_Enumeration_Literal_Specification return Node_Id; 51 function P_Enumeration_Type_Definition return Node_Id; 52 function P_Fixed_Point_Definition return Node_Id; 53 function P_Floating_Point_Definition return Node_Id; 54 function P_Index_Or_Discriminant_Constraint return Node_Id; 55 function P_Real_Range_Specification_Opt return Node_Id; 56 function P_Subtype_Declaration return Node_Id; 57 function P_Type_Declaration return Node_Id; 58 function P_Modular_Type_Definition return Node_Id; 59 function P_Variant return Node_Id; 60 function P_Variant_Part return Node_Id; 61 62 procedure Check_Restricted_Expression (N : Node_Id); 63 -- Check that the expression N meets the Restricted_Expression syntax. 64 -- The syntax is as follows: 65 -- 66 -- RESTRICTED_EXPRESSION ::= 67 -- RESTRICTED_RELATION {and RESTRICTED_RELATION} 68 -- | RESTRICTED_RELATION {and then RESTRICTED_RELATION} 69 -- | RESTRICTED_RELATION {or RESTRICTED_RELATION} 70 -- | RESTRICTED_RELATION {or else RESTRICTED_RELATION} 71 -- | RESTRICTED_RELATION {xor RESTRICTED_RELATION} 72 -- 73 -- RESTRICTED_RELATION ::= 74 -- SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION] 75 -- 76 -- This syntax is used for choices when extensions (and set notations) 77 -- are enabled, to remove the ambiguity of "when X in A | B". We consider 78 -- it very unlikely that this will ever arise in practice. 79 80 procedure P_Declarative_Items 81 (Decls : List_Id; 82 Done : out Boolean; 83 In_Spec : Boolean); 84 -- Scans out a single declarative item, or, in the case of a declaration 85 -- with a list of identifiers, a list of declarations, one for each of the 86 -- identifiers in the list. The declaration or declarations scanned are 87 -- appended to the given list. Done indicates whether or not there may be 88 -- additional declarative items to scan. If Done is True, then a decision 89 -- has been made that there are no more items to scan. If Done is False, 90 -- then there may be additional declarations to scan. In_Spec is true if 91 -- we are scanning a package declaration, and is used to generate an 92 -- appropriate message if a statement is encountered in such a context. 93 94 procedure P_Identifier_Declarations 95 (Decls : List_Id; 96 Done : out Boolean; 97 In_Spec : Boolean); 98 -- Scans out a set of declarations for an identifier or list of 99 -- identifiers, and appends them to the given list. The parameters have 100 -- the same significance as for P_Declarative_Items. 101 102 procedure Statement_When_Declaration_Expected 103 (Decls : List_Id; 104 Done : out Boolean; 105 In_Spec : Boolean); 106 -- Called when a statement is found at a point where a declaration was 107 -- expected. The parameters are as described for P_Declarative_Items. 108 109 procedure Set_Declaration_Expected; 110 -- Posts a "declaration expected" error messages at the start of the 111 -- current token, and if this is the first such message issued, saves 112 -- the message id in Missing_Begin_Msg, for possible later replacement. 113 114 --------------------------------- 115 -- Check_Restricted_Expression -- 116 --------------------------------- 117 118 procedure Check_Restricted_Expression (N : Node_Id) is 119 begin 120 if Nkind_In (N, N_Op_And, N_Op_Or, N_Op_Xor, N_And_Then, N_Or_Else) then 121 Check_Restricted_Expression (Left_Opnd (N)); 122 Check_Restricted_Expression (Right_Opnd (N)); 123 124 elsif Nkind_In (N, N_In, N_Not_In) 125 and then Paren_Count (N) = 0 126 then 127 Error_Msg_N ("|this expression must be parenthesized!", N); 128 end if; 129 end Check_Restricted_Expression; 130 131 ------------------- 132 -- Init_Expr_Opt -- 133 ------------------- 134 135 function Init_Expr_Opt (P : Boolean := False) return Node_Id is 136 begin 137 -- For colon, assume it means := unless it is at the end of 138 -- a line, in which case guess that it means a semicolon. 139 140 if Token = Tok_Colon then 141 if Token_Is_At_End_Of_Line then 142 T_Semicolon; 143 return Empty; 144 end if; 145 146 -- Here if := or something that we will take as equivalent 147 148 elsif Token = Tok_Colon_Equal 149 or else Token = Tok_Equal 150 or else Token = Tok_Is 151 then 152 null; 153 154 -- Another possibility. If we have a literal followed by a semicolon, 155 -- we assume that we have a missing colon-equal. 156 157 elsif Token in Token_Class_Literal then 158 declare 159 Scan_State : Saved_Scan_State; 160 161 begin 162 Save_Scan_State (Scan_State); 163 Scan; -- past literal or identifier 164 165 if Token = Tok_Semicolon then 166 Restore_Scan_State (Scan_State); 167 else 168 Restore_Scan_State (Scan_State); 169 return Empty; 170 end if; 171 end; 172 173 -- Otherwise we definitely have no initialization expression 174 175 else 176 return Empty; 177 end if; 178 179 -- Merge here if we have an initialization expression 180 181 T_Colon_Equal; 182 183 if P then 184 return P_Expression; 185 else 186 return P_Expression_No_Right_Paren; 187 end if; 188 end Init_Expr_Opt; 189 190 ---------------------------- 191 -- 3.1 Basic Declaration -- 192 ---------------------------- 193 194 -- Parsed by P_Basic_Declarative_Items (3.9) 195 196 ------------------------------ 197 -- 3.1 Defining Identifier -- 198 ------------------------------ 199 200 -- DEFINING_IDENTIFIER ::= IDENTIFIER 201 202 -- Error recovery: can raise Error_Resync 203 204 function P_Defining_Identifier (C : Id_Check := None) return Node_Id is 205 Ident_Node : Node_Id; 206 207 begin 208 -- Scan out the identifier. Note that this code is essentially identical 209 -- to P_Identifier, except that in the call to Scan_Reserved_Identifier 210 -- we set Force_Msg to True, since we want at least one message for each 211 -- separate declaration (but not use) of a reserved identifier. 212 213 -- Duplication should be removed, common code should be factored??? 214 215 if Token = Tok_Identifier then 216 Check_Future_Keyword; 217 218 -- If we have a reserved identifier, manufacture an identifier with 219 -- a corresponding name after posting an appropriate error message 220 221 elsif Is_Reserved_Identifier (C) then 222 Scan_Reserved_Identifier (Force_Msg => True); 223 224 -- Otherwise we have junk that cannot be interpreted as an identifier 225 226 else 227 T_Identifier; -- to give message 228 raise Error_Resync; 229 end if; 230 231 Ident_Node := Token_Node; 232 Scan; -- past the reserved identifier 233 234 -- If we already have a defining identifier, clean it out and make 235 -- a new clean identifier. This situation arises in some error cases 236 -- and we need to fix it. 237 238 if Nkind (Ident_Node) = N_Defining_Identifier then 239 Ident_Node := Make_Identifier (Sloc (Ident_Node), Chars (Ident_Node)); 240 end if; 241 242 -- Change identifier to defining identifier if not in error 243 244 if Ident_Node /= Error then 245 Change_Identifier_To_Defining_Identifier (Ident_Node); 246 247 -- Warn if standard redefinition, except that we never warn on a 248 -- record field definition (since this is always a harmless case). 249 250 if not Inside_Record_Definition then 251 Warn_If_Standard_Redefinition (Ident_Node); 252 end if; 253 end if; 254 255 return Ident_Node; 256 end P_Defining_Identifier; 257 258 ----------------------------- 259 -- 3.2.1 Type Declaration -- 260 ----------------------------- 261 262 -- TYPE_DECLARATION ::= 263 -- FULL_TYPE_DECLARATION 264 -- | INCOMPLETE_TYPE_DECLARATION 265 -- | PRIVATE_TYPE_DECLARATION 266 -- | PRIVATE_EXTENSION_DECLARATION 267 268 -- FULL_TYPE_DECLARATION ::= 269 -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION 270 -- [ASPECT_SPECIFICATIONS]; 271 -- | CONCURRENT_TYPE_DECLARATION 272 273 -- INCOMPLETE_TYPE_DECLARATION ::= 274 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] [is tagged]; 275 276 -- PRIVATE_TYPE_DECLARATION ::= 277 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] 278 -- is [abstract] [tagged] [limited] private 279 -- [ASPECT_SPECIFICATIONS]; 280 281 -- PRIVATE_EXTENSION_DECLARATION ::= 282 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is 283 -- [abstract] [limited | synchronized] 284 -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST] 285 -- with private [ASPECT_SPECIFICATIONS]; 286 287 -- TYPE_DEFINITION ::= 288 -- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION 289 -- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION 290 -- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION 291 -- | DERIVED_TYPE_DEFINITION | INTERFACE_TYPE_DEFINITION 292 293 -- INTEGER_TYPE_DEFINITION ::= 294 -- SIGNED_INTEGER_TYPE_DEFINITION 295 -- MODULAR_TYPE_DEFINITION 296 297 -- INTERFACE_TYPE_DEFINITION ::= 298 -- [limited | task | protected | synchronized ] interface 299 -- [and INTERFACE_LIST] 300 301 -- Error recovery: can raise Error_Resync 302 303 -- The processing for full type declarations, incomplete type declarations, 304 -- private type declarations and type definitions is included in this 305 -- function. The processing for concurrent type declarations is NOT here, 306 -- but rather in chapter 9 (this function handles only declarations 307 -- starting with TYPE). 308 309 function P_Type_Declaration return Node_Id is 310 Abstract_Present : Boolean := False; 311 Abstract_Loc : Source_Ptr := No_Location; 312 Decl_Node : Node_Id; 313 Discr_List : List_Id; 314 Discr_Sloc : Source_Ptr; 315 End_Labl : Node_Id; 316 Ident_Node : Node_Id; 317 Is_Derived_Iface : Boolean := False; 318 Type_Loc : Source_Ptr; 319 Type_Start_Col : Column_Number; 320 Unknown_Dis : Boolean; 321 322 Typedef_Node : Node_Id; 323 -- Normally holds type definition, except in the case of a private 324 -- extension declaration, in which case it holds the declaration itself 325 326 begin 327 Type_Loc := Token_Ptr; 328 Type_Start_Col := Start_Column; 329 330 -- If we have TYPE, then proceed ahead and scan identifier 331 332 if Token = Tok_Type then 333 Type_Token_Location := Type_Loc; 334 Scan; -- past TYPE 335 Ident_Node := P_Defining_Identifier (C_Is); 336 337 -- Otherwise this is an error case 338 339 else 340 T_Type; 341 Type_Token_Location := Type_Loc; 342 Ident_Node := P_Defining_Identifier (C_Is); 343 end if; 344 345 Discr_Sloc := Token_Ptr; 346 347 if P_Unknown_Discriminant_Part_Opt then 348 Unknown_Dis := True; 349 Discr_List := No_List; 350 else 351 Unknown_Dis := False; 352 Discr_List := P_Known_Discriminant_Part_Opt; 353 end if; 354 355 -- Incomplete type declaration. We complete the processing for this 356 -- case here and return the resulting incomplete type declaration node 357 358 if Token = Tok_Semicolon then 359 Scan; -- past ; 360 Decl_Node := New_Node (N_Incomplete_Type_Declaration, Type_Loc); 361 Set_Defining_Identifier (Decl_Node, Ident_Node); 362 Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis); 363 Set_Discriminant_Specifications (Decl_Node, Discr_List); 364 return Decl_Node; 365 366 else 367 Decl_Node := Empty; 368 end if; 369 370 -- Full type declaration or private type declaration, must have IS 371 372 if Token = Tok_Equal then 373 TF_Is; 374 Scan; -- past = used in place of IS 375 376 elsif Token = Tok_Renames then 377 Error_Msg_SC -- CODEFIX 378 ("RENAMES should be IS"); 379 Scan; -- past RENAMES used in place of IS 380 381 else 382 TF_Is; 383 end if; 384 385 -- First an error check, if we have two identifiers in a row, a likely 386 -- possibility is that the first of the identifiers is an incorrectly 387 -- spelled keyword. 388 389 if Token = Tok_Identifier then 390 declare 391 SS : Saved_Scan_State; 392 I2 : Boolean; 393 394 begin 395 Save_Scan_State (SS); 396 Scan; -- past initial identifier 397 I2 := (Token = Tok_Identifier); 398 Restore_Scan_State (SS); 399 400 if I2 401 and then 402 (Bad_Spelling_Of (Tok_Abstract) or else 403 Bad_Spelling_Of (Tok_Access) or else 404 Bad_Spelling_Of (Tok_Aliased) or else 405 Bad_Spelling_Of (Tok_Constant)) 406 then 407 null; 408 end if; 409 end; 410 end if; 411 412 -- Check for misuse of Ada 95 keyword abstract in Ada 83 mode 413 414 if Token_Name = Name_Abstract then 415 Check_95_Keyword (Tok_Abstract, Tok_Tagged); 416 Check_95_Keyword (Tok_Abstract, Tok_New); 417 end if; 418 419 -- Check cases of misuse of ABSTRACT 420 421 if Token = Tok_Abstract then 422 Abstract_Present := True; 423 Abstract_Loc := Token_Ptr; 424 Scan; -- past ABSTRACT 425 426 -- Ada 2005 (AI-419): AARM 3.4 (2/2) 427 428 if (Ada_Version < Ada_2005 and then Token = Tok_Limited) 429 or else Token = Tok_Private 430 or else Token = Tok_Record 431 or else Token = Tok_Null 432 then 433 Error_Msg_AP ("TAGGED expected"); 434 end if; 435 end if; 436 437 -- Check for misuse of Ada 95 keyword Tagged 438 439 if Token_Name = Name_Tagged then 440 Check_95_Keyword (Tok_Tagged, Tok_Private); 441 Check_95_Keyword (Tok_Tagged, Tok_Limited); 442 Check_95_Keyword (Tok_Tagged, Tok_Record); 443 end if; 444 445 -- Special check for misuse of Aliased 446 447 if Token = Tok_Aliased or else Token_Name = Name_Aliased then 448 Error_Msg_SC ("ALIASED not allowed in type definition"); 449 Scan; -- past ALIASED 450 end if; 451 452 -- The following processing deals with either a private type declaration 453 -- or a full type declaration. In the private type case, we build the 454 -- N_Private_Type_Declaration node, setting its Tagged_Present and 455 -- Limited_Present flags, on encountering the Private keyword, and 456 -- leave Typedef_Node set to Empty. For the full type declaration 457 -- case, Typedef_Node gets set to the type definition. 458 459 Typedef_Node := Empty; 460 461 -- Switch on token following the IS. The loop normally runs once. It 462 -- only runs more than once if an error is detected, to try again after 463 -- detecting and fixing up the error. 464 465 loop 466 case Token is 467 468 when Tok_Access | 469 Tok_Not => -- Ada 2005 (AI-231) 470 Typedef_Node := P_Access_Type_Definition; 471 exit; 472 473 when Tok_Array => 474 Typedef_Node := P_Array_Type_Definition; 475 exit; 476 477 when Tok_Delta => 478 Typedef_Node := P_Fixed_Point_Definition; 479 exit; 480 481 when Tok_Digits => 482 Typedef_Node := P_Floating_Point_Definition; 483 exit; 484 485 when Tok_In => 486 Ignore (Tok_In); 487 488 when Tok_Integer_Literal => 489 T_Range; 490 Typedef_Node := P_Signed_Integer_Type_Definition; 491 exit; 492 493 when Tok_Null => 494 Typedef_Node := P_Record_Definition; 495 exit; 496 497 when Tok_Left_Paren => 498 Typedef_Node := P_Enumeration_Type_Definition; 499 500 End_Labl := Make_Identifier (Token_Ptr, Chars (Ident_Node)); 501 Set_Comes_From_Source (End_Labl, False); 502 503 Set_End_Label (Typedef_Node, End_Labl); 504 exit; 505 506 when Tok_Mod => 507 Typedef_Node := P_Modular_Type_Definition; 508 exit; 509 510 when Tok_New => 511 Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl; 512 513 if Nkind (Typedef_Node) = N_Derived_Type_Definition 514 and then Present (Record_Extension_Part (Typedef_Node)) 515 then 516 End_Labl := Make_Identifier (Token_Ptr, Chars (Ident_Node)); 517 Set_Comes_From_Source (End_Labl, False); 518 519 Set_End_Label 520 (Record_Extension_Part (Typedef_Node), End_Labl); 521 end if; 522 523 exit; 524 525 when Tok_Range => 526 Typedef_Node := P_Signed_Integer_Type_Definition; 527 exit; 528 529 when Tok_Record => 530 Typedef_Node := P_Record_Definition; 531 532 End_Labl := Make_Identifier (Token_Ptr, Chars (Ident_Node)); 533 Set_Comes_From_Source (End_Labl, False); 534 535 Set_End_Label (Typedef_Node, End_Labl); 536 exit; 537 538 when Tok_Tagged => 539 Scan; -- past TAGGED 540 541 -- Ada 2005 (AI-326): If the words IS TAGGED appear, the type 542 -- is a tagged incomplete type. 543 544 if Ada_Version >= Ada_2005 545 and then Token = Tok_Semicolon 546 then 547 Scan; -- past ; 548 549 Decl_Node := 550 New_Node (N_Incomplete_Type_Declaration, Type_Loc); 551 Set_Defining_Identifier (Decl_Node, Ident_Node); 552 Set_Tagged_Present (Decl_Node); 553 Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis); 554 Set_Discriminant_Specifications (Decl_Node, Discr_List); 555 556 return Decl_Node; 557 end if; 558 559 if Token = Tok_Abstract then 560 Error_Msg_SC -- CODEFIX 561 ("ABSTRACT must come before TAGGED"); 562 Abstract_Present := True; 563 Abstract_Loc := Token_Ptr; 564 Scan; -- past ABSTRACT 565 end if; 566 567 if Token = Tok_Limited then 568 Scan; -- past LIMITED 569 570 -- TAGGED LIMITED PRIVATE case 571 572 if Token = Tok_Private then 573 Decl_Node := 574 New_Node (N_Private_Type_Declaration, Type_Loc); 575 Set_Tagged_Present (Decl_Node, True); 576 Set_Limited_Present (Decl_Node, True); 577 Scan; -- past PRIVATE 578 579 -- TAGGED LIMITED RECORD 580 581 else 582 Typedef_Node := P_Record_Definition; 583 Set_Tagged_Present (Typedef_Node, True); 584 Set_Limited_Present (Typedef_Node, True); 585 586 End_Labl := 587 Make_Identifier (Token_Ptr, Chars (Ident_Node)); 588 Set_Comes_From_Source (End_Labl, False); 589 590 Set_End_Label (Typedef_Node, End_Labl); 591 end if; 592 593 else 594 -- TAGGED PRIVATE 595 596 if Token = Tok_Private then 597 Decl_Node := 598 New_Node (N_Private_Type_Declaration, Type_Loc); 599 Set_Tagged_Present (Decl_Node, True); 600 Scan; -- past PRIVATE 601 602 -- TAGGED RECORD 603 604 else 605 Typedef_Node := P_Record_Definition; 606 Set_Tagged_Present (Typedef_Node, True); 607 608 End_Labl := 609 Make_Identifier (Token_Ptr, Chars (Ident_Node)); 610 Set_Comes_From_Source (End_Labl, False); 611 612 Set_End_Label (Typedef_Node, End_Labl); 613 end if; 614 end if; 615 616 exit; 617 618 when Tok_Limited => 619 Scan; -- past LIMITED 620 621 loop 622 if Token = Tok_Tagged then 623 Error_Msg_SC -- CODEFIX 624 ("TAGGED must come before LIMITED"); 625 Scan; -- past TAGGED 626 627 elsif Token = Tok_Abstract then 628 Error_Msg_SC -- CODEFIX 629 ("ABSTRACT must come before LIMITED"); 630 Scan; -- past ABSTRACT 631 632 else 633 exit; 634 end if; 635 end loop; 636 637 -- LIMITED RECORD or LIMITED NULL RECORD 638 639 if Token = Tok_Record or else Token = Tok_Null then 640 if Ada_Version = Ada_83 then 641 Error_Msg_SP 642 ("(Ada 83) limited record declaration not allowed!"); 643 644 -- In Ada 2005, "abstract limited" can appear before "new", 645 -- but it cannot be part of an untagged record declaration. 646 647 elsif Abstract_Present 648 and then Prev_Token /= Tok_Tagged 649 then 650 Error_Msg_SP ("TAGGED expected"); 651 end if; 652 653 Typedef_Node := P_Record_Definition; 654 Set_Limited_Present (Typedef_Node, True); 655 656 -- Ada 2005 (AI-251): LIMITED INTERFACE 657 658 -- If we are compiling in Ada 83 or Ada 95 mode, "interface" 659 -- is not a reserved word but we force its analysis to 660 -- generate the corresponding usage error. 661 662 elsif Token = Tok_Interface 663 or else (Token = Tok_Identifier 664 and then Chars (Token_Node) = Name_Interface) 665 then 666 Typedef_Node := 667 P_Interface_Type_Definition (Abstract_Present); 668 Abstract_Present := True; 669 Set_Limited_Present (Typedef_Node); 670 671 if Nkind (Typedef_Node) = N_Derived_Type_Definition then 672 Is_Derived_Iface := True; 673 end if; 674 675 -- Ada 2005 (AI-419): LIMITED NEW 676 677 elsif Token = Tok_New then 678 if Ada_Version < Ada_2005 then 679 Error_Msg_SP 680 ("LIMITED in derived type is an Ada 2005 extension"); 681 Error_Msg_SP 682 ("\unit must be compiled with -gnat05 switch"); 683 end if; 684 685 Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl; 686 Set_Limited_Present (Typedef_Node); 687 688 if Nkind (Typedef_Node) = N_Derived_Type_Definition 689 and then Present (Record_Extension_Part (Typedef_Node)) 690 then 691 End_Labl := 692 Make_Identifier (Token_Ptr, Chars (Ident_Node)); 693 Set_Comes_From_Source (End_Labl, False); 694 695 Set_End_Label 696 (Record_Extension_Part (Typedef_Node), End_Labl); 697 end if; 698 699 -- LIMITED PRIVATE is the only remaining possibility here 700 701 else 702 Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc); 703 Set_Limited_Present (Decl_Node, True); 704 T_Private; -- past PRIVATE (or complain if not there) 705 end if; 706 707 exit; 708 709 -- Here we have an identifier after the IS, which is certainly 710 -- wrong and which might be one of several different mistakes. 711 712 when Tok_Identifier => 713 714 -- First case, if identifier is on same line, then probably we 715 -- have something like "type X is Integer .." and the best 716 -- diagnosis is a missing NEW. Note: the missing new message 717 -- will be posted by P_Derived_Type_Def_Or_Private_Ext_Decl. 718 719 if not Token_Is_At_Start_Of_Line then 720 Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl; 721 722 -- If the identifier is at the start of the line, and is in the 723 -- same column as the type declaration itself then we consider 724 -- that we had a missing type definition on the previous line 725 726 elsif Start_Column <= Type_Start_Col then 727 Error_Msg_AP ("type definition expected"); 728 Typedef_Node := Error; 729 730 -- If the identifier is at the start of the line, and is in 731 -- a column to the right of the type declaration line, then we 732 -- may have something like: 733 734 -- type x is 735 -- r : integer 736 737 -- and the best diagnosis is a missing record keyword 738 739 else 740 Typedef_Node := P_Record_Definition; 741 end if; 742 743 exit; 744 745 -- Ada 2005 (AI-251): INTERFACE 746 747 when Tok_Interface => 748 Typedef_Node := P_Interface_Type_Definition (Abstract_Present); 749 Abstract_Present := True; 750 exit; 751 752 when Tok_Private => 753 Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc); 754 Scan; -- past PRIVATE 755 756 -- Check error cases of private [abstract] tagged 757 758 if Token = Tok_Abstract then 759 Error_Msg_SC ("`ABSTRACT TAGGED` must come before PRIVATE"); 760 Scan; -- past ABSTRACT 761 762 if Token = Tok_Tagged then 763 Scan; -- past TAGGED 764 end if; 765 766 elsif Token = Tok_Tagged then 767 Error_Msg_SC ("TAGGED must come before PRIVATE"); 768 Scan; -- past TAGGED 769 end if; 770 771 exit; 772 773 -- Ada 2005 (AI-345): Protected, synchronized or task interface 774 -- or Ada 2005 (AI-443): Synchronized private extension. 775 776 when Tok_Protected | 777 Tok_Synchronized | 778 Tok_Task => 779 780 declare 781 Saved_Token : constant Token_Type := Token; 782 783 begin 784 Scan; -- past TASK, PROTECTED or SYNCHRONIZED 785 786 -- Synchronized private extension 787 788 if Token = Tok_New then 789 Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl; 790 791 if Saved_Token = Tok_Synchronized then 792 if Nkind (Typedef_Node) = 793 N_Derived_Type_Definition 794 then 795 Error_Msg_N 796 ("SYNCHRONIZED not allowed for record extension", 797 Typedef_Node); 798 else 799 Set_Synchronized_Present (Typedef_Node); 800 end if; 801 802 else 803 Error_Msg_SC ("invalid kind of private extension"); 804 end if; 805 806 -- Interface 807 808 else 809 if Token /= Tok_Interface then 810 Error_Msg_SC ("NEW or INTERFACE expected"); 811 end if; 812 813 Typedef_Node := 814 P_Interface_Type_Definition (Abstract_Present); 815 Abstract_Present := True; 816 817 case Saved_Token is 818 when Tok_Task => 819 Set_Task_Present (Typedef_Node); 820 821 when Tok_Protected => 822 Set_Protected_Present (Typedef_Node); 823 824 when Tok_Synchronized => 825 Set_Synchronized_Present (Typedef_Node); 826 827 when others => 828 pragma Assert (False); 829 null; 830 end case; 831 end if; 832 end; 833 834 exit; 835 836 -- Anything else is an error 837 838 when others => 839 if Bad_Spelling_Of (Tok_Access) 840 or else 841 Bad_Spelling_Of (Tok_Array) 842 or else 843 Bad_Spelling_Of (Tok_Delta) 844 or else 845 Bad_Spelling_Of (Tok_Digits) 846 or else 847 Bad_Spelling_Of (Tok_Limited) 848 or else 849 Bad_Spelling_Of (Tok_Private) 850 or else 851 Bad_Spelling_Of (Tok_Range) 852 or else 853 Bad_Spelling_Of (Tok_Record) 854 or else 855 Bad_Spelling_Of (Tok_Tagged) 856 then 857 null; 858 859 else 860 Error_Msg_AP ("type definition expected"); 861 raise Error_Resync; 862 end if; 863 864 end case; 865 end loop; 866 867 -- For the private type declaration case, the private type declaration 868 -- node has been built, with the Tagged_Present and Limited_Present 869 -- flags set as needed, and Typedef_Node is left set to Empty. 870 871 if No (Typedef_Node) then 872 Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis); 873 Set_Abstract_Present (Decl_Node, Abstract_Present); 874 875 -- For a private extension declaration, Typedef_Node contains the 876 -- N_Private_Extension_Declaration node, which we now complete. Note 877 -- that the private extension declaration, unlike a full type 878 -- declaration, does permit unknown discriminants. 879 880 elsif Nkind (Typedef_Node) = N_Private_Extension_Declaration then 881 Decl_Node := Typedef_Node; 882 Set_Sloc (Decl_Node, Type_Loc); 883 Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis); 884 Set_Abstract_Present (Typedef_Node, Abstract_Present); 885 886 -- In the full type declaration case, Typedef_Node has the type 887 -- definition and here is where we build the full type declaration 888 -- node. This is also where we check for improper use of an unknown 889 -- discriminant part (not allowed for full type declaration). 890 891 else 892 if Nkind (Typedef_Node) = N_Record_Definition 893 or else (Nkind (Typedef_Node) = N_Derived_Type_Definition 894 and then Present (Record_Extension_Part (Typedef_Node))) 895 or else Is_Derived_Iface 896 then 897 Set_Abstract_Present (Typedef_Node, Abstract_Present); 898 899 elsif Abstract_Present then 900 Error_Msg ("ABSTRACT not allowed here, ignored", Abstract_Loc); 901 end if; 902 903 Decl_Node := New_Node (N_Full_Type_Declaration, Type_Loc); 904 Set_Type_Definition (Decl_Node, Typedef_Node); 905 906 if Unknown_Dis then 907 Error_Msg 908 ("Full type declaration cannot have unknown discriminants", 909 Discr_Sloc); 910 end if; 911 end if; 912 913 -- Remaining processing is common for all three cases 914 915 Set_Defining_Identifier (Decl_Node, Ident_Node); 916 Set_Discriminant_Specifications (Decl_Node, Discr_List); 917 P_Aspect_Specifications (Decl_Node); 918 return Decl_Node; 919 end P_Type_Declaration; 920 921 ---------------------------------- 922 -- 3.2.1 Full Type Declaration -- 923 ---------------------------------- 924 925 -- Parsed by P_Type_Declaration (3.2.1) 926 927 ---------------------------- 928 -- 3.2.1 Type Definition -- 929 ---------------------------- 930 931 -- Parsed by P_Type_Declaration (3.2.1) 932 933 -------------------------------- 934 -- 3.2.2 Subtype Declaration -- 935 -------------------------------- 936 937 -- SUBTYPE_DECLARATION ::= 938 -- subtype DEFINING_IDENTIFIER is [NULL_EXCLUSION] SUBTYPE_INDICATION 939 -- [ASPECT_SPECIFICATIONS]; 940 941 -- The caller has checked that the initial token is SUBTYPE 942 943 -- Error recovery: can raise Error_Resync 944 945 function P_Subtype_Declaration return Node_Id is 946 Decl_Node : Node_Id; 947 Not_Null_Present : Boolean := False; 948 949 begin 950 Decl_Node := New_Node (N_Subtype_Declaration, Token_Ptr); 951 Scan; -- past SUBTYPE 952 Set_Defining_Identifier (Decl_Node, P_Defining_Identifier (C_Is)); 953 TF_Is; 954 955 if Token = Tok_New then 956 Error_Msg_SC -- CODEFIX 957 ("NEW ignored (only allowed in type declaration)"); 958 Scan; -- past NEW 959 end if; 960 961 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) 962 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); 963 964 Set_Subtype_Indication 965 (Decl_Node, P_Subtype_Indication (Not_Null_Present)); 966 P_Aspect_Specifications (Decl_Node); 967 return Decl_Node; 968 end P_Subtype_Declaration; 969 970 ------------------------------- 971 -- 3.2.2 Subtype Indication -- 972 ------------------------------- 973 974 -- SUBTYPE_INDICATION ::= 975 -- [not null] SUBTYPE_MARK [CONSTRAINT] 976 977 -- Error recovery: can raise Error_Resync 978 979 function P_Null_Exclusion 980 (Allow_Anonymous_In_95 : Boolean := False) return Boolean 981 is 982 Not_Loc : constant Source_Ptr := Token_Ptr; 983 -- Source position of "not", if present 984 985 begin 986 if Token /= Tok_Not then 987 return False; 988 989 else 990 Scan; -- past NOT 991 992 if Token = Tok_Null then 993 Scan; -- past NULL 994 995 -- Ada 2005 (AI-441, AI-447): null_exclusion is illegal in Ada 95, 996 -- except in the case of anonymous access types. 997 998 -- Allow_Anonymous_In_95 will be True if we're parsing a formal 999 -- parameter or discriminant, which are the only places where 1000 -- anonymous access types occur in Ada 95. "Formal : not null 1001 -- access ..." is legal in Ada 95, whereas "Formal : not null 1002 -- Named_Access_Type" is not. 1003 1004 if Ada_Version >= Ada_2005 1005 or else (Ada_Version >= Ada_95 1006 and then Allow_Anonymous_In_95 1007 and then Token = Tok_Access) 1008 then 1009 null; -- OK 1010 1011 else 1012 Error_Msg 1013 ("`NOT NULL` access type is an Ada 2005 extension", Not_Loc); 1014 Error_Msg 1015 ("\unit should be compiled with -gnat05 switch", Not_Loc); 1016 end if; 1017 1018 else 1019 Error_Msg_SP ("NULL expected"); 1020 end if; 1021 1022 if Token = Tok_New then 1023 Error_Msg ("`NOT NULL` comes after NEW, not before", Not_Loc); 1024 end if; 1025 1026 return True; 1027 end if; 1028 end P_Null_Exclusion; 1029 1030 function P_Subtype_Indication 1031 (Not_Null_Present : Boolean := False) return Node_Id 1032 is 1033 Type_Node : Node_Id; 1034 1035 begin 1036 if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then 1037 Type_Node := P_Subtype_Mark; 1038 return P_Subtype_Indication (Type_Node, Not_Null_Present); 1039 1040 else 1041 -- Check for error of using record definition and treat it nicely, 1042 -- otherwise things are really messed up, so resynchronize. 1043 1044 if Token = Tok_Record then 1045 Error_Msg_SC ("anonymous record definitions are not permitted"); 1046 Discard_Junk_Node (P_Record_Definition); 1047 return Error; 1048 1049 else 1050 Error_Msg_AP ("subtype indication expected"); 1051 raise Error_Resync; 1052 end if; 1053 end if; 1054 end P_Subtype_Indication; 1055 1056 -- The following function is identical except that it is called with 1057 -- the subtype mark already scanned out, and it scans out the constraint 1058 1059 -- Error recovery: can raise Error_Resync 1060 1061 function P_Subtype_Indication 1062 (Subtype_Mark : Node_Id; 1063 Not_Null_Present : Boolean := False) return Node_Id 1064 is 1065 Indic_Node : Node_Id; 1066 Constr_Node : Node_Id; 1067 1068 begin 1069 Constr_Node := P_Constraint_Opt; 1070 1071 if No (Constr_Node) 1072 or else 1073 (Nkind (Constr_Node) = N_Range_Constraint 1074 and then Nkind (Range_Expression (Constr_Node)) = N_Error) 1075 then 1076 return Subtype_Mark; 1077 else 1078 if Not_Null_Present then 1079 Error_Msg_SP ("`NOT NULL` not allowed if constraint given"); 1080 end if; 1081 1082 Indic_Node := New_Node (N_Subtype_Indication, Sloc (Subtype_Mark)); 1083 Set_Subtype_Mark (Indic_Node, Check_Subtype_Mark (Subtype_Mark)); 1084 Set_Constraint (Indic_Node, Constr_Node); 1085 return Indic_Node; 1086 end if; 1087 end P_Subtype_Indication; 1088 1089 ------------------------- 1090 -- 3.2.2 Subtype Mark -- 1091 ------------------------- 1092 1093 -- SUBTYPE_MARK ::= subtype_NAME; 1094 1095 -- Note: The subtype mark which appears after an IN or NOT IN 1096 -- operator is parsed by P_Range_Or_Subtype_Mark (3.5) 1097 1098 -- Error recovery: cannot raise Error_Resync 1099 1100 function P_Subtype_Mark return Node_Id is 1101 begin 1102 return P_Subtype_Mark_Resync; 1103 exception 1104 when Error_Resync => 1105 return Error; 1106 end P_Subtype_Mark; 1107 1108 -- This routine differs from P_Subtype_Mark in that it insists that an 1109 -- identifier be present, and if it is not, it raises Error_Resync. 1110 1111 -- Error recovery: can raise Error_Resync 1112 1113 function P_Subtype_Mark_Resync return Node_Id is 1114 Type_Node : Node_Id; 1115 1116 begin 1117 if Token = Tok_Access then 1118 Error_Msg_SC ("anonymous access type definition not allowed here"); 1119 Scan; -- past ACCESS 1120 end if; 1121 1122 if Token = Tok_Array then 1123 Error_Msg_SC ("anonymous array definition not allowed here"); 1124 Discard_Junk_Node (P_Array_Type_Definition); 1125 return Error; 1126 1127 else 1128 Type_Node := P_Qualified_Simple_Name_Resync; 1129 1130 -- Check for a subtype mark attribute. The only valid possibilities 1131 -- are 'CLASS and 'BASE. Anything else is a definite error. We may 1132 -- as well catch it here. 1133 1134 if Token = Tok_Apostrophe then 1135 return P_Subtype_Mark_Attribute (Type_Node); 1136 else 1137 return Type_Node; 1138 end if; 1139 end if; 1140 end P_Subtype_Mark_Resync; 1141 1142 -- The following function is called to scan out a subtype mark attribute. 1143 -- The caller has already scanned out the subtype mark, which is passed in 1144 -- as the argument, and has checked that the current token is apostrophe. 1145 1146 -- Only a special subclass of attributes, called type attributes 1147 -- (see Snames package) are allowed in this syntactic position. 1148 1149 -- Note: if the apostrophe is followed by other than an identifier, then 1150 -- the input expression is returned unchanged, and the scan pointer is 1151 -- left pointing to the apostrophe. 1152 1153 -- Error recovery: can raise Error_Resync 1154 1155 function P_Subtype_Mark_Attribute (Type_Node : Node_Id) return Node_Id is 1156 Attr_Node : Node_Id := Empty; 1157 Scan_State : Saved_Scan_State; 1158 Prefix : Node_Id; 1159 1160 begin 1161 Prefix := Check_Subtype_Mark (Type_Node); 1162 1163 if Prefix = Error then 1164 raise Error_Resync; 1165 end if; 1166 1167 -- Loop through attributes appearing (more than one can appear as for 1168 -- for example in X'Base'Class). We are at an apostrophe on entry to 1169 -- this loop, and it runs once for each attribute parsed, with 1170 -- Prefix being the current possible prefix if it is an attribute. 1171 1172 loop 1173 Save_Scan_State (Scan_State); -- at Apostrophe 1174 Scan; -- past apostrophe 1175 1176 if Token /= Tok_Identifier then 1177 Restore_Scan_State (Scan_State); -- to apostrophe 1178 return Prefix; -- no attribute after all 1179 1180 elsif not Is_Type_Attribute_Name (Token_Name) then 1181 Error_Msg_N 1182 ("attribute & may not be used in a subtype mark", Token_Node); 1183 raise Error_Resync; 1184 1185 else 1186 Attr_Node := 1187 Make_Attribute_Reference (Prev_Token_Ptr, 1188 Prefix => Prefix, 1189 Attribute_Name => Token_Name); 1190 Scan; -- past type attribute identifier 1191 end if; 1192 1193 exit when Token /= Tok_Apostrophe; 1194 Prefix := Attr_Node; 1195 end loop; 1196 1197 -- Fall through here after scanning type attribute 1198 1199 return Attr_Node; 1200 end P_Subtype_Mark_Attribute; 1201 1202 ----------------------- 1203 -- 3.2.2 Constraint -- 1204 ----------------------- 1205 1206 -- CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT 1207 1208 -- SCALAR_CONSTRAINT ::= 1209 -- RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT 1210 1211 -- COMPOSITE_CONSTRAINT ::= 1212 -- INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT 1213 1214 -- If no constraint is present, this function returns Empty 1215 1216 -- Error recovery: can raise Error_Resync 1217 1218 function P_Constraint_Opt return Node_Id is 1219 begin 1220 if Token = Tok_Range 1221 or else Bad_Spelling_Of (Tok_Range) 1222 then 1223 return P_Range_Constraint; 1224 1225 elsif Token = Tok_Digits 1226 or else Bad_Spelling_Of (Tok_Digits) 1227 then 1228 return P_Digits_Constraint; 1229 1230 elsif Token = Tok_Delta 1231 or else Bad_Spelling_Of (Tok_Delta) 1232 then 1233 return P_Delta_Constraint; 1234 1235 elsif Token = Tok_Left_Paren then 1236 return P_Index_Or_Discriminant_Constraint; 1237 1238 elsif Token = Tok_In then 1239 Ignore (Tok_In); 1240 return P_Constraint_Opt; 1241 1242 else 1243 return Empty; 1244 end if; 1245 end P_Constraint_Opt; 1246 1247 ------------------------------ 1248 -- 3.2.2 Scalar Constraint -- 1249 ------------------------------ 1250 1251 -- Parsed by P_Constraint_Opt (3.2.2) 1252 1253 --------------------------------- 1254 -- 3.2.2 Composite Constraint -- 1255 --------------------------------- 1256 1257 -- Parsed by P_Constraint_Opt (3.2.2) 1258 1259 -------------------------------------------------------- 1260 -- 3.3 Identifier Declarations (Also 7.4, 8.5, 11.1) -- 1261 -------------------------------------------------------- 1262 1263 -- This routine scans out a declaration starting with an identifier: 1264 1265 -- OBJECT_DECLARATION ::= 1266 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant] 1267 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION] 1268 -- [ASPECT_SPECIFICATIONS]; 1269 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] 1270 -- ACCESS_DEFINITION [:= EXPRESSION] 1271 -- [ASPECT_SPECIFICATIONS]; 1272 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] 1273 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION] 1274 -- [ASPECT_SPECIFICATIONS]; 1275 1276 -- NUMBER_DECLARATION ::= 1277 -- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION; 1278 1279 -- OBJECT_RENAMING_DECLARATION ::= 1280 -- DEFINING_IDENTIFIER : 1281 -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME 1282 -- [ASPECT_SPECIFICATIONS]; 1283 -- | DEFINING_IDENTIFIER : 1284 -- ACCESS_DEFINITION renames object_NAME 1285 -- [ASPECT_SPECIFICATIONS]; 1286 1287 -- EXCEPTION_RENAMING_DECLARATION ::= 1288 -- DEFINING_IDENTIFIER : exception renames exception_NAME 1289 -- [ASPECT_SPECIFICATIONS]; 1290 1291 -- EXCEPTION_DECLARATION ::= 1292 -- DEFINING_IDENTIFIER_LIST : exception 1293 -- [ASPECT_SPECIFICATIONS]; 1294 1295 -- Note that the ALIASED indication in an object declaration is 1296 -- marked by a flag in the parent node. 1297 1298 -- The caller has checked that the initial token is an identifier 1299 1300 -- The value returned is a list of declarations, one for each identifier 1301 -- in the list (as described in Sinfo, we always split up multiple 1302 -- declarations into the equivalent sequence of single declarations 1303 -- using the More_Ids and Prev_Ids flags to preserve the source). 1304 1305 -- If the identifier turns out to be a probable statement rather than 1306 -- an identifier, then the scan is left pointing to the identifier and 1307 -- No_List is returned. 1308 1309 -- Error recovery: can raise Error_Resync 1310 1311 procedure P_Identifier_Declarations 1312 (Decls : List_Id; 1313 Done : out Boolean; 1314 In_Spec : Boolean) 1315 is 1316 Acc_Node : Node_Id; 1317 Decl_Node : Node_Id; 1318 Type_Node : Node_Id; 1319 Ident_Sloc : Source_Ptr; 1320 Scan_State : Saved_Scan_State; 1321 List_OK : Boolean := True; 1322 Ident : Nat; 1323 Init_Expr : Node_Id; 1324 Init_Loc : Source_Ptr; 1325 Con_Loc : Source_Ptr; 1326 Not_Null_Present : Boolean := False; 1327 1328 Idents : array (Int range 1 .. 4096) of Entity_Id; 1329 -- Used to save identifiers in the identifier list. The upper bound 1330 -- of 4096 is expected to be infinite in practice, and we do not even 1331 -- bother to check if this upper bound is exceeded. 1332 1333 Num_Idents : Nat := 1; 1334 -- Number of identifiers stored in Idents 1335 1336 procedure No_List; 1337 -- This procedure is called in renames cases to make sure that we do 1338 -- not have more than one identifier. If we do have more than one 1339 -- then an error message is issued (and the declaration is split into 1340 -- multiple declarations) 1341 1342 function Token_Is_Renames return Boolean; 1343 -- Checks if current token is RENAMES, and if so, scans past it and 1344 -- returns True, otherwise returns False. Includes checking for some 1345 -- common error cases. 1346 1347 ------------- 1348 -- No_List -- 1349 ------------- 1350 1351 procedure No_List is 1352 begin 1353 if Num_Idents > 1 then 1354 Error_Msg 1355 ("identifier list not allowed for RENAMES", 1356 Sloc (Idents (2))); 1357 end if; 1358 1359 List_OK := False; 1360 end No_List; 1361 1362 ---------------------- 1363 -- Token_Is_Renames -- 1364 ---------------------- 1365 1366 function Token_Is_Renames return Boolean is 1367 At_Colon : Saved_Scan_State; 1368 1369 begin 1370 if Token = Tok_Colon then 1371 Save_Scan_State (At_Colon); 1372 Scan; -- past colon 1373 Check_Misspelling_Of (Tok_Renames); 1374 1375 if Token = Tok_Renames then 1376 Error_Msg_SP -- CODEFIX 1377 ("|extra "":"" ignored"); 1378 Scan; -- past RENAMES 1379 return True; 1380 else 1381 Restore_Scan_State (At_Colon); 1382 return False; 1383 end if; 1384 1385 else 1386 Check_Misspelling_Of (Tok_Renames); 1387 1388 if Token = Tok_Renames then 1389 Scan; -- past RENAMES 1390 return True; 1391 else 1392 return False; 1393 end if; 1394 end if; 1395 end Token_Is_Renames; 1396 1397 -- Start of processing for P_Identifier_Declarations 1398 1399 begin 1400 Ident_Sloc := Token_Ptr; 1401 Save_Scan_State (Scan_State); -- at first identifier 1402 Idents (1) := P_Defining_Identifier (C_Comma_Colon); 1403 1404 -- If we have a colon after the identifier, then we can assume that 1405 -- this is in fact a valid identifier declaration and can steam ahead. 1406 1407 if Token = Tok_Colon then 1408 Scan; -- past colon 1409 1410 -- If we have a comma, then scan out the list of identifiers 1411 1412 elsif Token = Tok_Comma then 1413 while Comma_Present loop 1414 Num_Idents := Num_Idents + 1; 1415 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon); 1416 end loop; 1417 1418 Save_Scan_State (Scan_State); -- at colon 1419 T_Colon; 1420 1421 -- If we have identifier followed by := then we assume that what is 1422 -- really meant is an assignment statement. The assignment statement 1423 -- is scanned out and added to the list of declarations. An exception 1424 -- occurs if the := is followed by the keyword constant, in which case 1425 -- we assume it was meant to be a colon. 1426 1427 elsif Token = Tok_Colon_Equal then 1428 Scan; -- past := 1429 1430 if Token = Tok_Constant then 1431 Error_Msg_SP ("colon expected"); 1432 1433 else 1434 Restore_Scan_State (Scan_State); 1435 Statement_When_Declaration_Expected (Decls, Done, In_Spec); 1436 return; 1437 end if; 1438 1439 -- If we have an IS keyword, then assume the TYPE keyword was missing 1440 1441 elsif Token = Tok_Is then 1442 Restore_Scan_State (Scan_State); 1443 Append_To (Decls, P_Type_Declaration); 1444 Done := False; 1445 return; 1446 1447 -- Otherwise we have an error situation 1448 1449 else 1450 Restore_Scan_State (Scan_State); 1451 1452 -- First case is possible misuse of PROTECTED in Ada 83 mode. If 1453 -- so, fix the keyword and return to scan the protected declaration. 1454 1455 if Token_Name = Name_Protected then 1456 Check_95_Keyword (Tok_Protected, Tok_Identifier); 1457 Check_95_Keyword (Tok_Protected, Tok_Type); 1458 Check_95_Keyword (Tok_Protected, Tok_Body); 1459 1460 if Token = Tok_Protected then 1461 Done := False; 1462 return; 1463 end if; 1464 1465 -- Check misspelling possibilities. If so, correct the misspelling 1466 -- and return to scan out the resulting declaration. 1467 1468 elsif Bad_Spelling_Of (Tok_Function) 1469 or else Bad_Spelling_Of (Tok_Procedure) 1470 or else Bad_Spelling_Of (Tok_Package) 1471 or else Bad_Spelling_Of (Tok_Pragma) 1472 or else Bad_Spelling_Of (Tok_Protected) 1473 or else Bad_Spelling_Of (Tok_Generic) 1474 or else Bad_Spelling_Of (Tok_Subtype) 1475 or else Bad_Spelling_Of (Tok_Type) 1476 or else Bad_Spelling_Of (Tok_Task) 1477 or else Bad_Spelling_Of (Tok_Use) 1478 or else Bad_Spelling_Of (Tok_For) 1479 then 1480 Done := False; 1481 return; 1482 1483 -- Otherwise we definitely have an ordinary identifier with a junk 1484 -- token after it. Just complain that we expect a declaration, and 1485 -- skip to a semicolon 1486 1487 else 1488 Set_Declaration_Expected; 1489 Resync_Past_Semicolon; 1490 Done := False; 1491 return; 1492 end if; 1493 end if; 1494 1495 -- Come here with an identifier list and colon scanned out. We now 1496 -- build the nodes for the declarative items. One node is built for 1497 -- each identifier in the list, with the type information being 1498 -- repeated by rescanning the appropriate section of source. 1499 1500 -- First an error check, if we have two identifiers in a row, a likely 1501 -- possibility is that the first of the identifiers is an incorrectly 1502 -- spelled keyword. 1503 1504 if Token = Tok_Identifier then 1505 declare 1506 SS : Saved_Scan_State; 1507 I2 : Boolean; 1508 1509 begin 1510 Save_Scan_State (SS); 1511 Scan; -- past initial identifier 1512 I2 := (Token = Tok_Identifier); 1513 Restore_Scan_State (SS); 1514 1515 if I2 1516 and then 1517 (Bad_Spelling_Of (Tok_Access) or else 1518 Bad_Spelling_Of (Tok_Aliased) or else 1519 Bad_Spelling_Of (Tok_Constant)) 1520 then 1521 null; 1522 end if; 1523 end; 1524 end if; 1525 1526 -- Loop through identifiers 1527 1528 Ident := 1; 1529 Ident_Loop : loop 1530 1531 -- Check for some cases of misused Ada 95 keywords 1532 1533 if Token_Name = Name_Aliased then 1534 Check_95_Keyword (Tok_Aliased, Tok_Array); 1535 Check_95_Keyword (Tok_Aliased, Tok_Identifier); 1536 Check_95_Keyword (Tok_Aliased, Tok_Constant); 1537 end if; 1538 1539 -- Constant cases 1540 1541 if Token = Tok_Constant then 1542 Con_Loc := Token_Ptr; 1543 Scan; -- past CONSTANT 1544 1545 -- Number declaration, initialization required 1546 1547 Init_Expr := Init_Expr_Opt; 1548 1549 if Present (Init_Expr) then 1550 if Not_Null_Present then 1551 Error_Msg_SP 1552 ("`NOT NULL` not allowed in numeric expression"); 1553 end if; 1554 1555 Decl_Node := New_Node (N_Number_Declaration, Ident_Sloc); 1556 Set_Expression (Decl_Node, Init_Expr); 1557 1558 -- Constant object declaration 1559 1560 else 1561 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); 1562 Set_Constant_Present (Decl_Node, True); 1563 1564 if Token_Name = Name_Aliased then 1565 Check_95_Keyword (Tok_Aliased, Tok_Array); 1566 Check_95_Keyword (Tok_Aliased, Tok_Identifier); 1567 end if; 1568 1569 if Token = Tok_Aliased then 1570 Error_Msg_SC -- CODEFIX 1571 ("ALIASED should be before CONSTANT"); 1572 Scan; -- past ALIASED 1573 Set_Aliased_Present (Decl_Node, True); 1574 end if; 1575 1576 if Token = Tok_Array then 1577 Set_Object_Definition 1578 (Decl_Node, P_Array_Type_Definition); 1579 1580 else 1581 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) 1582 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); 1583 1584 if Token = Tok_Access then 1585 if Ada_Version < Ada_2005 then 1586 Error_Msg_SP 1587 ("generalized use of anonymous access types " & 1588 "is an Ada 2005 extension"); 1589 Error_Msg_SP 1590 ("\unit must be compiled with -gnat05 switch"); 1591 end if; 1592 1593 Set_Object_Definition 1594 (Decl_Node, P_Access_Definition (Not_Null_Present)); 1595 else 1596 Set_Object_Definition 1597 (Decl_Node, P_Subtype_Indication (Not_Null_Present)); 1598 end if; 1599 end if; 1600 1601 if Token = Tok_Renames then 1602 Error_Msg 1603 ("CONSTANT not permitted in renaming declaration", 1604 Con_Loc); 1605 Scan; -- Past renames 1606 Discard_Junk_Node (P_Name); 1607 end if; 1608 end if; 1609 1610 -- Exception cases 1611 1612 elsif Token = Tok_Exception then 1613 Scan; -- past EXCEPTION 1614 1615 if Token_Is_Renames then 1616 No_List; 1617 Decl_Node := 1618 New_Node (N_Exception_Renaming_Declaration, Ident_Sloc); 1619 Set_Name (Decl_Node, P_Qualified_Simple_Name_Resync); 1620 No_Constraint; 1621 else 1622 Decl_Node := New_Node (N_Exception_Declaration, Prev_Token_Ptr); 1623 end if; 1624 1625 -- Aliased case (note that an object definition is required) 1626 1627 elsif Token = Tok_Aliased then 1628 Scan; -- past ALIASED 1629 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); 1630 Set_Aliased_Present (Decl_Node, True); 1631 1632 if Token = Tok_Constant then 1633 Scan; -- past CONSTANT 1634 Set_Constant_Present (Decl_Node, True); 1635 end if; 1636 1637 if Token = Tok_Array then 1638 Set_Object_Definition 1639 (Decl_Node, P_Array_Type_Definition); 1640 1641 else 1642 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) 1643 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); 1644 1645 -- Access definition (AI-406) or subtype indication 1646 1647 if Token = Tok_Access then 1648 if Ada_Version < Ada_2005 then 1649 Error_Msg_SP 1650 ("generalized use of anonymous access types " & 1651 "is an Ada 2005 extension"); 1652 Error_Msg_SP 1653 ("\unit must be compiled with -gnat05 switch"); 1654 end if; 1655 1656 Set_Object_Definition 1657 (Decl_Node, P_Access_Definition (Not_Null_Present)); 1658 else 1659 Set_Object_Definition 1660 (Decl_Node, P_Subtype_Indication (Not_Null_Present)); 1661 end if; 1662 end if; 1663 1664 -- Array case 1665 1666 elsif Token = Tok_Array then 1667 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); 1668 Set_Object_Definition (Decl_Node, P_Array_Type_Definition); 1669 1670 -- Ada 2005 (AI-254, AI-406) 1671 1672 elsif Token = Tok_Not then 1673 1674 -- OBJECT_DECLARATION ::= 1675 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant] 1676 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION] 1677 -- [ASPECT_SPECIFICATIONS]; 1678 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] 1679 -- ACCESS_DEFINITION [:= EXPRESSION] 1680 -- [ASPECT_SPECIFICATIONS]; 1681 1682 -- OBJECT_RENAMING_DECLARATION ::= 1683 -- DEFINING_IDENTIFIER : 1684 -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME 1685 -- [ASPECT_SPECIFICATIONS]; 1686 -- | DEFINING_IDENTIFIER : 1687 -- ACCESS_DEFINITION renames object_NAME 1688 -- [ASPECT_SPECIFICATIONS]; 1689 1690 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/423) 1691 1692 if Token = Tok_Access then 1693 if Ada_Version < Ada_2005 then 1694 Error_Msg_SP 1695 ("generalized use of anonymous access types " & 1696 "is an Ada 2005 extension"); 1697 Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); 1698 end if; 1699 1700 Acc_Node := P_Access_Definition (Not_Null_Present); 1701 1702 if Token /= Tok_Renames then 1703 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); 1704 Set_Object_Definition (Decl_Node, Acc_Node); 1705 1706 else 1707 Scan; -- past renames 1708 No_List; 1709 Decl_Node := 1710 New_Node (N_Object_Renaming_Declaration, Ident_Sloc); 1711 Set_Access_Definition (Decl_Node, Acc_Node); 1712 Set_Name (Decl_Node, P_Name); 1713 end if; 1714 1715 else 1716 Type_Node := P_Subtype_Mark; 1717 1718 -- Object renaming declaration 1719 1720 if Token_Is_Renames then 1721 if Ada_Version < Ada_2005 then 1722 Error_Msg_SP 1723 ("`NOT NULL` not allowed in object renaming"); 1724 raise Error_Resync; 1725 1726 -- Ada 2005 (AI-423): Object renaming declaration with 1727 -- a null exclusion. 1728 1729 else 1730 No_List; 1731 Decl_Node := 1732 New_Node (N_Object_Renaming_Declaration, Ident_Sloc); 1733 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); 1734 Set_Subtype_Mark (Decl_Node, Type_Node); 1735 Set_Name (Decl_Node, P_Name); 1736 end if; 1737 1738 -- Object declaration 1739 1740 else 1741 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); 1742 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); 1743 Set_Object_Definition 1744 (Decl_Node, 1745 P_Subtype_Indication (Type_Node, Not_Null_Present)); 1746 1747 -- RENAMES at this point means that we had the combination 1748 -- of a constraint on the Type_Node and renames, which is 1749 -- illegal 1750 1751 if Token_Is_Renames then 1752 Error_Msg_N 1753 ("constraint not allowed in object renaming " 1754 & "declaration", 1755 Constraint (Object_Definition (Decl_Node))); 1756 raise Error_Resync; 1757 end if; 1758 end if; 1759 end if; 1760 1761 -- Ada 2005 (AI-230): Access Definition case 1762 1763 elsif Token = Tok_Access then 1764 if Ada_Version < Ada_2005 then 1765 Error_Msg_SP 1766 ("generalized use of anonymous access types " & 1767 "is an Ada 2005 extension"); 1768 Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); 1769 end if; 1770 1771 Acc_Node := P_Access_Definition (Null_Exclusion_Present => False); 1772 1773 -- Object declaration with access definition, or renaming 1774 1775 if Token /= Tok_Renames then 1776 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); 1777 Set_Object_Definition (Decl_Node, Acc_Node); 1778 1779 else 1780 Scan; -- past renames 1781 No_List; 1782 Decl_Node := 1783 New_Node (N_Object_Renaming_Declaration, Ident_Sloc); 1784 Set_Access_Definition (Decl_Node, Acc_Node); 1785 Set_Name (Decl_Node, P_Name); 1786 end if; 1787 1788 -- Subtype indication case 1789 1790 else 1791 Type_Node := P_Subtype_Mark; 1792 1793 -- Object renaming declaration 1794 1795 if Token_Is_Renames then 1796 No_List; 1797 Decl_Node := 1798 New_Node (N_Object_Renaming_Declaration, Ident_Sloc); 1799 Set_Subtype_Mark (Decl_Node, Type_Node); 1800 Set_Name (Decl_Node, P_Name); 1801 1802 -- Object declaration 1803 1804 else 1805 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); 1806 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); 1807 Set_Object_Definition 1808 (Decl_Node, 1809 P_Subtype_Indication (Type_Node, Not_Null_Present)); 1810 1811 -- RENAMES at this point means that we had the combination of 1812 -- a constraint on the Type_Node and renames, which is illegal 1813 1814 if Token_Is_Renames then 1815 Error_Msg_N 1816 ("constraint not allowed in object renaming declaration", 1817 Constraint (Object_Definition (Decl_Node))); 1818 raise Error_Resync; 1819 end if; 1820 end if; 1821 end if; 1822 1823 -- Scan out initialization, allowed only for object declaration 1824 1825 Init_Loc := Token_Ptr; 1826 Init_Expr := Init_Expr_Opt; 1827 1828 if Present (Init_Expr) then 1829 if Nkind (Decl_Node) = N_Object_Declaration then 1830 Set_Expression (Decl_Node, Init_Expr); 1831 Set_Has_Init_Expression (Decl_Node); 1832 else 1833 Error_Msg ("initialization not allowed here", Init_Loc); 1834 end if; 1835 end if; 1836 1837 Set_Defining_Identifier (Decl_Node, Idents (Ident)); 1838 P_Aspect_Specifications (Decl_Node); 1839 1840 if List_OK then 1841 if Ident < Num_Idents then 1842 Set_More_Ids (Decl_Node, True); 1843 end if; 1844 1845 if Ident > 1 then 1846 Set_Prev_Ids (Decl_Node, True); 1847 end if; 1848 end if; 1849 1850 Append (Decl_Node, Decls); 1851 exit Ident_Loop when Ident = Num_Idents; 1852 Restore_Scan_State (Scan_State); 1853 T_Colon; 1854 Ident := Ident + 1; 1855 end loop Ident_Loop; 1856 1857 Done := False; 1858 end P_Identifier_Declarations; 1859 1860 ------------------------------- 1861 -- 3.3.1 Object Declaration -- 1862 ------------------------------- 1863 1864 -- OBJECT DECLARATION ::= 1865 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant] 1866 -- SUBTYPE_INDICATION [:= EXPRESSION]; 1867 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] 1868 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION]; 1869 -- | SINGLE_TASK_DECLARATION 1870 -- | SINGLE_PROTECTED_DECLARATION 1871 1872 -- Cases starting with TASK are parsed by P_Task (9.1) 1873 -- Cases starting with PROTECTED are parsed by P_Protected (9.4) 1874 -- All other cases are parsed by P_Identifier_Declarations (3.3) 1875 1876 ------------------------------------- 1877 -- 3.3.1 Defining Identifier List -- 1878 ------------------------------------- 1879 1880 -- DEFINING_IDENTIFIER_LIST ::= 1881 -- DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER} 1882 1883 -- Always parsed by the construct in which it appears. See special 1884 -- section on "Handling of Defining Identifier Lists" in this unit. 1885 1886 ------------------------------- 1887 -- 3.3.2 Number Declaration -- 1888 ------------------------------- 1889 1890 -- Parsed by P_Identifier_Declarations (3.3) 1891 1892 ------------------------------------------------------------------------- 1893 -- 3.4 Derived Type Definition or Private Extension Declaration (7.3) -- 1894 ------------------------------------------------------------------------- 1895 1896 -- DERIVED_TYPE_DEFINITION ::= 1897 -- [abstract] [limited] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION 1898 -- [[and INTERFACE_LIST] RECORD_EXTENSION_PART] 1899 1900 -- PRIVATE_EXTENSION_DECLARATION ::= 1901 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is 1902 -- [abstract] [limited | synchronized] 1903 -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST] 1904 -- with private [ASPECT_SPECIFICATIONS]; 1905 1906 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION 1907 1908 -- The caller has already scanned out the part up to the NEW, and Token 1909 -- either contains Tok_New (or ought to, if it doesn't this procedure 1910 -- will post an appropriate "NEW expected" message). 1911 1912 -- Note: the caller is responsible for filling in the Sloc field of 1913 -- the returned node in the private extension declaration case as 1914 -- well as the stuff relating to the discriminant part. 1915 1916 -- Error recovery: can raise Error_Resync; 1917 1918 function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id is 1919 Typedef_Node : Node_Id; 1920 Typedecl_Node : Node_Id; 1921 Not_Null_Present : Boolean := False; 1922 1923 begin 1924 Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr); 1925 1926 if Ada_Version < Ada_2005 1927 and then Token = Tok_Identifier 1928 and then Token_Name = Name_Interface 1929 then 1930 Error_Msg_SP 1931 ("abstract interface is an Ada 2005 extension"); 1932 Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); 1933 else 1934 T_New; 1935 end if; 1936 1937 if Token = Tok_Abstract then 1938 Error_Msg_SC -- CODEFIX 1939 ("ABSTRACT must come before NEW, not after"); 1940 Scan; 1941 end if; 1942 1943 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) 1944 Set_Null_Exclusion_Present (Typedef_Node, Not_Null_Present); 1945 Set_Subtype_Indication (Typedef_Node, 1946 P_Subtype_Indication (Not_Null_Present)); 1947 1948 -- Ada 2005 (AI-251): Deal with interfaces 1949 1950 if Token = Tok_And then 1951 Scan; -- past AND 1952 1953 if Ada_Version < Ada_2005 then 1954 Error_Msg_SP 1955 ("abstract interface is an Ada 2005 extension"); 1956 Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); 1957 end if; 1958 1959 Set_Interface_List (Typedef_Node, New_List); 1960 1961 loop 1962 Append (P_Qualified_Simple_Name, Interface_List (Typedef_Node)); 1963 exit when Token /= Tok_And; 1964 Scan; -- past AND 1965 end loop; 1966 1967 if Token /= Tok_With then 1968 Error_Msg_SC ("WITH expected"); 1969 raise Error_Resync; 1970 end if; 1971 end if; 1972 1973 -- Deal with record extension, note that we assume that a WITH is 1974 -- missing in the case of "type X is new Y record ..." or in the 1975 -- case of "type X is new Y null record". 1976 1977 -- First make sure we don't have an aspect specification. If we do 1978 -- return now, so that our caller can check it (the WITH here is not 1979 -- part of a type extension). 1980 1981 if Aspect_Specifications_Present then 1982 return Typedef_Node; 1983 1984 -- OK, not an aspect specification, so continue test for extension 1985 1986 elsif Token = Tok_With 1987 or else Token = Tok_Record 1988 or else Token = Tok_Null 1989 then 1990 T_With; -- past WITH or give error message 1991 1992 if Token = Tok_Limited then 1993 Error_Msg_SC ("LIMITED keyword not allowed in private extension"); 1994 Scan; -- ignore LIMITED 1995 end if; 1996 1997 -- Private extension declaration 1998 1999 if Token = Tok_Private then 2000 Scan; -- past PRIVATE 2001 2002 -- Throw away the type definition node and build the type 2003 -- declaration node. Note the caller must set the Sloc, 2004 -- Discriminant_Specifications, Unknown_Discriminants_Present, 2005 -- and Defined_Identifier fields in the returned node. 2006 2007 Typedecl_Node := 2008 Make_Private_Extension_Declaration (No_Location, 2009 Defining_Identifier => Empty, 2010 Subtype_Indication => Subtype_Indication (Typedef_Node), 2011 Abstract_Present => Abstract_Present (Typedef_Node), 2012 Interface_List => Interface_List (Typedef_Node)); 2013 2014 return Typedecl_Node; 2015 2016 -- Derived type definition with record extension part 2017 2018 else 2019 Set_Record_Extension_Part (Typedef_Node, P_Record_Definition); 2020 return Typedef_Node; 2021 end if; 2022 2023 -- Derived type definition with no record extension part 2024 2025 else 2026 return Typedef_Node; 2027 end if; 2028 end P_Derived_Type_Def_Or_Private_Ext_Decl; 2029 2030 --------------------------- 2031 -- 3.5 Range Constraint -- 2032 --------------------------- 2033 2034 -- RANGE_CONSTRAINT ::= range RANGE 2035 2036 -- The caller has checked that the initial token is RANGE 2037 2038 -- Error recovery: cannot raise Error_Resync 2039 2040 function P_Range_Constraint return Node_Id is 2041 Range_Node : Node_Id; 2042 2043 begin 2044 Range_Node := New_Node (N_Range_Constraint, Token_Ptr); 2045 Scan; -- past RANGE 2046 Set_Range_Expression (Range_Node, P_Range); 2047 return Range_Node; 2048 end P_Range_Constraint; 2049 2050 ---------------- 2051 -- 3.5 Range -- 2052 ---------------- 2053 2054 -- RANGE ::= 2055 -- RANGE_ATTRIBUTE_REFERENCE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION 2056 2057 -- Note: the range that appears in a membership test is parsed by 2058 -- P_Range_Or_Subtype_Mark (3.5). 2059 2060 -- Error recovery: cannot raise Error_Resync 2061 2062 function P_Range return Node_Id is 2063 Expr_Node : Node_Id; 2064 Range_Node : Node_Id; 2065 2066 begin 2067 Expr_Node := P_Simple_Expression_Or_Range_Attribute; 2068 2069 if Expr_Form = EF_Range_Attr then 2070 return Expr_Node; 2071 2072 elsif Token = Tok_Dot_Dot then 2073 Range_Node := New_Node (N_Range, Token_Ptr); 2074 Set_Low_Bound (Range_Node, Expr_Node); 2075 Scan; -- past .. 2076 Expr_Node := P_Expression; 2077 Check_Simple_Expression (Expr_Node); 2078 Set_High_Bound (Range_Node, Expr_Node); 2079 return Range_Node; 2080 2081 -- Anything else is an error 2082 2083 else 2084 T_Dot_Dot; -- force missing .. message 2085 return Error; 2086 end if; 2087 end P_Range; 2088 2089 ---------------------------------- 2090 -- 3.5 P_Range_Or_Subtype_Mark -- 2091 ---------------------------------- 2092 2093 -- RANGE ::= 2094 -- RANGE_ATTRIBUTE_REFERENCE 2095 -- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION 2096 2097 -- This routine scans out the range or subtype mark that forms the right 2098 -- operand of a membership test (it is not used in any other contexts, and 2099 -- error messages are specialized with this knowledge in mind). 2100 2101 -- Note: as documented in the Sinfo interface, although the syntax only 2102 -- allows a subtype mark, we in fact allow any simple expression to be 2103 -- returned from this routine. The semantics is responsible for issuing 2104 -- an appropriate message complaining if the argument is not a name. 2105 -- This simplifies the coding and error recovery processing in the 2106 -- parser, and in any case it is preferable not to consider this a 2107 -- syntax error and to continue with the semantic analysis. 2108 2109 -- Error recovery: cannot raise Error_Resync 2110 2111 function P_Range_Or_Subtype_Mark 2112 (Allow_Simple_Expression : Boolean := False) return Node_Id 2113 is 2114 Expr_Node : Node_Id; 2115 Range_Node : Node_Id; 2116 Save_Loc : Source_Ptr; 2117 2118 -- Start of processing for P_Range_Or_Subtype_Mark 2119 2120 begin 2121 -- Save location of possible junk parentheses 2122 2123 Save_Loc := Token_Ptr; 2124 2125 -- Scan out either a simple expression or a range (this accepts more 2126 -- than is legal here, but as explained above, we like to allow more 2127 -- with a proper diagnostic, and in the case of a membership operation 2128 -- where sets are allowed, a simple expression is permissible anyway. 2129 2130 Expr_Node := P_Simple_Expression_Or_Range_Attribute; 2131 2132 -- Range attribute 2133 2134 if Expr_Form = EF_Range_Attr then 2135 return Expr_Node; 2136 2137 -- Simple_Expression .. Simple_Expression 2138 2139 elsif Token = Tok_Dot_Dot then 2140 Check_Simple_Expression (Expr_Node); 2141 Range_Node := New_Node (N_Range, Token_Ptr); 2142 Set_Low_Bound (Range_Node, Expr_Node); 2143 Scan; -- past .. 2144 Set_High_Bound (Range_Node, P_Simple_Expression); 2145 return Range_Node; 2146 2147 -- Case of subtype mark (optionally qualified simple name or an 2148 -- attribute whose prefix is an optionally qualified simple name) 2149 2150 elsif Expr_Form = EF_Simple_Name 2151 or else Nkind (Expr_Node) = N_Attribute_Reference 2152 then 2153 -- Check for error of range constraint after a subtype mark 2154 2155 if Token = Tok_Range then 2156 Error_Msg_SC ("range constraint not allowed in membership test"); 2157 Scan; -- past RANGE 2158 raise Error_Resync; 2159 2160 -- Check for error of DIGITS or DELTA after a subtype mark 2161 2162 elsif Token = Tok_Digits or else Token = Tok_Delta then 2163 Error_Msg_SC 2164 ("accuracy definition not allowed in membership test"); 2165 Scan; -- past DIGITS or DELTA 2166 raise Error_Resync; 2167 2168 -- Attribute reference, may or may not be OK, but in any case we 2169 -- will scan it out 2170 2171 elsif Token = Tok_Apostrophe then 2172 return P_Subtype_Mark_Attribute (Expr_Node); 2173 2174 -- OK case of simple name, just return it 2175 2176 else 2177 return Expr_Node; 2178 end if; 2179 2180 -- Simple expression case 2181 2182 elsif Expr_Form = EF_Simple and then Allow_Simple_Expression then 2183 return Expr_Node; 2184 2185 -- Here we have some kind of error situation. Check for junk parens 2186 -- then return what we have, caller will deal with other errors. 2187 2188 else 2189 if Nkind (Expr_Node) in N_Subexpr 2190 and then Paren_Count (Expr_Node) /= 0 2191 then 2192 Error_Msg ("|parentheses not allowed for subtype mark", Save_Loc); 2193 Set_Paren_Count (Expr_Node, 0); 2194 end if; 2195 2196 return Expr_Node; 2197 end if; 2198 end P_Range_Or_Subtype_Mark; 2199 2200 ---------------------------------------- 2201 -- 3.5.1 Enumeration Type Definition -- 2202 ---------------------------------------- 2203 2204 -- ENUMERATION_TYPE_DEFINITION ::= 2205 -- (ENUMERATION_LITERAL_SPECIFICATION 2206 -- {, ENUMERATION_LITERAL_SPECIFICATION}) 2207 2208 -- The caller has already scanned out the TYPE keyword 2209 2210 -- Error recovery: can raise Error_Resync; 2211 2212 function P_Enumeration_Type_Definition return Node_Id is 2213 Typedef_Node : Node_Id; 2214 2215 begin 2216 Typedef_Node := New_Node (N_Enumeration_Type_Definition, Token_Ptr); 2217 Set_Literals (Typedef_Node, New_List); 2218 2219 T_Left_Paren; 2220 2221 loop 2222 Append (P_Enumeration_Literal_Specification, Literals (Typedef_Node)); 2223 exit when not Comma_Present; 2224 end loop; 2225 2226 T_Right_Paren; 2227 return Typedef_Node; 2228 end P_Enumeration_Type_Definition; 2229 2230 ---------------------------------------------- 2231 -- 3.5.1 Enumeration Literal Specification -- 2232 ---------------------------------------------- 2233 2234 -- ENUMERATION_LITERAL_SPECIFICATION ::= 2235 -- DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL 2236 2237 -- Error recovery: can raise Error_Resync 2238 2239 function P_Enumeration_Literal_Specification return Node_Id is 2240 begin 2241 if Token = Tok_Char_Literal then 2242 return P_Defining_Character_Literal; 2243 else 2244 return P_Defining_Identifier (C_Comma_Right_Paren); 2245 end if; 2246 end P_Enumeration_Literal_Specification; 2247 2248 --------------------------------------- 2249 -- 3.5.1 Defining_Character_Literal -- 2250 --------------------------------------- 2251 2252 -- DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL 2253 2254 -- Error recovery: cannot raise Error_Resync 2255 2256 -- The caller has checked that the current token is a character literal 2257 2258 function P_Defining_Character_Literal return Node_Id is 2259 Literal_Node : Node_Id; 2260 begin 2261 Literal_Node := Token_Node; 2262 Change_Character_Literal_To_Defining_Character_Literal (Literal_Node); 2263 Scan; -- past character literal 2264 return Literal_Node; 2265 end P_Defining_Character_Literal; 2266 2267 ------------------------------------ 2268 -- 3.5.4 Integer Type Definition -- 2269 ------------------------------------ 2270 2271 -- Parsed by P_Type_Declaration (3.2.1) 2272 2273 ------------------------------------------- 2274 -- 3.5.4 Signed Integer Type Definition -- 2275 ------------------------------------------- 2276 2277 -- SIGNED_INTEGER_TYPE_DEFINITION ::= 2278 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION 2279 2280 -- Normally the initial token on entry is RANGE, but in some 2281 -- error conditions, the range token was missing and control is 2282 -- passed with Token pointing to first token of the first expression. 2283 2284 -- Error recovery: cannot raise Error_Resync 2285 2286 function P_Signed_Integer_Type_Definition return Node_Id is 2287 Typedef_Node : Node_Id; 2288 Expr_Node : Node_Id; 2289 2290 begin 2291 Typedef_Node := New_Node (N_Signed_Integer_Type_Definition, Token_Ptr); 2292 2293 if Token = Tok_Range then 2294 Scan; -- past RANGE 2295 end if; 2296 2297 Expr_Node := P_Expression_Or_Range_Attribute; 2298 2299 -- Range case (not permitted by the grammar, this is surprising but 2300 -- the grammar in the RM is as quoted above, and does not allow Range). 2301 2302 if Expr_Form = EF_Range_Attr then 2303 Error_Msg_N 2304 ("Range attribute not allowed here, use First .. Last", Expr_Node); 2305 Set_Low_Bound (Typedef_Node, Expr_Node); 2306 Set_Attribute_Name (Expr_Node, Name_First); 2307 Set_High_Bound (Typedef_Node, Copy_Separate_Tree (Expr_Node)); 2308 Set_Attribute_Name (High_Bound (Typedef_Node), Name_Last); 2309 2310 -- Normal case of explicit range 2311 2312 else 2313 Check_Simple_Expression (Expr_Node); 2314 Set_Low_Bound (Typedef_Node, Expr_Node); 2315 T_Dot_Dot; 2316 Expr_Node := P_Expression; 2317 Check_Simple_Expression (Expr_Node); 2318 Set_High_Bound (Typedef_Node, Expr_Node); 2319 end if; 2320 2321 return Typedef_Node; 2322 end P_Signed_Integer_Type_Definition; 2323 2324 ------------------------------------ 2325 -- 3.5.4 Modular Type Definition -- 2326 ------------------------------------ 2327 2328 -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION 2329 2330 -- The caller has checked that the initial token is MOD 2331 2332 -- Error recovery: cannot raise Error_Resync 2333 2334 function P_Modular_Type_Definition return Node_Id is 2335 Typedef_Node : Node_Id; 2336 2337 begin 2338 if Ada_Version = Ada_83 then 2339 Error_Msg_SC ("(Ada 83): modular types not allowed"); 2340 end if; 2341 2342 Typedef_Node := New_Node (N_Modular_Type_Definition, Token_Ptr); 2343 Scan; -- past MOD 2344 Set_Expression (Typedef_Node, P_Expression_No_Right_Paren); 2345 2346 -- Handle mod L..R cleanly 2347 2348 if Token = Tok_Dot_Dot then 2349 Error_Msg_SC ("range not allowed for modular type"); 2350 Scan; -- past .. 2351 Set_Expression (Typedef_Node, P_Expression_No_Right_Paren); 2352 end if; 2353 2354 return Typedef_Node; 2355 end P_Modular_Type_Definition; 2356 2357 --------------------------------- 2358 -- 3.5.6 Real Type Definition -- 2359 --------------------------------- 2360 2361 -- Parsed by P_Type_Declaration (3.2.1) 2362 2363 -------------------------------------- 2364 -- 3.5.7 Floating Point Definition -- 2365 -------------------------------------- 2366 2367 -- FLOATING_POINT_DEFINITION ::= 2368 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION] 2369 2370 -- Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION 2371 2372 -- The caller has checked that the initial token is DIGITS 2373 2374 -- Error recovery: cannot raise Error_Resync 2375 2376 function P_Floating_Point_Definition return Node_Id is 2377 Digits_Loc : constant Source_Ptr := Token_Ptr; 2378 Def_Node : Node_Id; 2379 Expr_Node : Node_Id; 2380 2381 begin 2382 Scan; -- past DIGITS 2383 Expr_Node := P_Expression_No_Right_Paren; 2384 Check_Simple_Expression_In_Ada_83 (Expr_Node); 2385 2386 -- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order 2387 2388 if Token = Tok_Delta then 2389 Error_Msg_SC -- CODEFIX 2390 ("|DELTA must come before DIGITS"); 2391 Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Digits_Loc); 2392 Scan; -- past DELTA 2393 Set_Delta_Expression (Def_Node, P_Expression_No_Right_Paren); 2394 2395 -- OK floating-point definition 2396 2397 else 2398 Def_Node := New_Node (N_Floating_Point_Definition, Digits_Loc); 2399 end if; 2400 2401 Set_Digits_Expression (Def_Node, Expr_Node); 2402 Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt); 2403 return Def_Node; 2404 end P_Floating_Point_Definition; 2405 2406 ------------------------------------- 2407 -- 3.5.7 Real Range Specification -- 2408 ------------------------------------- 2409 2410 -- REAL_RANGE_SPECIFICATION ::= 2411 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION 2412 2413 -- Error recovery: cannot raise Error_Resync 2414 2415 function P_Real_Range_Specification_Opt return Node_Id is 2416 Specification_Node : Node_Id; 2417 Expr_Node : Node_Id; 2418 2419 begin 2420 if Token = Tok_Range then 2421 Specification_Node := 2422 New_Node (N_Real_Range_Specification, Token_Ptr); 2423 Scan; -- past RANGE 2424 Expr_Node := P_Expression_No_Right_Paren; 2425 Check_Simple_Expression (Expr_Node); 2426 Set_Low_Bound (Specification_Node, Expr_Node); 2427 T_Dot_Dot; 2428 Expr_Node := P_Expression_No_Right_Paren; 2429 Check_Simple_Expression (Expr_Node); 2430 Set_High_Bound (Specification_Node, Expr_Node); 2431 return Specification_Node; 2432 else 2433 return Empty; 2434 end if; 2435 end P_Real_Range_Specification_Opt; 2436 2437 ----------------------------------- 2438 -- 3.5.9 Fixed Point Definition -- 2439 ----------------------------------- 2440 2441 -- FIXED_POINT_DEFINITION ::= 2442 -- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION 2443 2444 -- ORDINARY_FIXED_POINT_DEFINITION ::= 2445 -- delta static_EXPRESSION REAL_RANGE_SPECIFICATION 2446 2447 -- DECIMAL_FIXED_POINT_DEFINITION ::= 2448 -- delta static_EXPRESSION 2449 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION] 2450 2451 -- The caller has checked that the initial token is DELTA 2452 2453 -- Error recovery: cannot raise Error_Resync 2454 2455 function P_Fixed_Point_Definition return Node_Id is 2456 Delta_Node : Node_Id; 2457 Delta_Loc : Source_Ptr; 2458 Def_Node : Node_Id; 2459 Expr_Node : Node_Id; 2460 2461 begin 2462 Delta_Loc := Token_Ptr; 2463 Scan; -- past DELTA 2464 Delta_Node := P_Expression_No_Right_Paren; 2465 Check_Simple_Expression_In_Ada_83 (Delta_Node); 2466 2467 if Token = Tok_Digits then 2468 if Ada_Version = Ada_83 then 2469 Error_Msg_SC ("(Ada 83) decimal fixed type not allowed!"); 2470 end if; 2471 2472 Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Delta_Loc); 2473 Scan; -- past DIGITS 2474 Expr_Node := P_Expression_No_Right_Paren; 2475 Check_Simple_Expression_In_Ada_83 (Expr_Node); 2476 Set_Digits_Expression (Def_Node, Expr_Node); 2477 2478 else 2479 Def_Node := New_Node (N_Ordinary_Fixed_Point_Definition, Delta_Loc); 2480 2481 -- Range is required in ordinary fixed point case 2482 2483 if Token /= Tok_Range then 2484 Error_Msg_AP ("range must be given for fixed-point type"); 2485 T_Range; 2486 end if; 2487 end if; 2488 2489 Set_Delta_Expression (Def_Node, Delta_Node); 2490 Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt); 2491 return Def_Node; 2492 end P_Fixed_Point_Definition; 2493 2494 -------------------------------------------- 2495 -- 3.5.9 Ordinary Fixed Point Definition -- 2496 -------------------------------------------- 2497 2498 -- Parsed by P_Fixed_Point_Definition (3.5.9) 2499 2500 ------------------------------------------- 2501 -- 3.5.9 Decimal Fixed Point Definition -- 2502 ------------------------------------------- 2503 2504 -- Parsed by P_Decimal_Point_Definition (3.5.9) 2505 2506 ------------------------------ 2507 -- 3.5.9 Digits Constraint -- 2508 ------------------------------ 2509 2510 -- DIGITS_CONSTRAINT ::= 2511 -- digits static_EXPRESSION [RANGE_CONSTRAINT] 2512 2513 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION 2514 2515 -- The caller has checked that the initial token is DIGITS 2516 2517 function P_Digits_Constraint return Node_Id is 2518 Constraint_Node : Node_Id; 2519 Expr_Node : Node_Id; 2520 2521 begin 2522 Constraint_Node := New_Node (N_Digits_Constraint, Token_Ptr); 2523 Scan; -- past DIGITS 2524 Expr_Node := P_Expression; 2525 Check_Simple_Expression_In_Ada_83 (Expr_Node); 2526 Set_Digits_Expression (Constraint_Node, Expr_Node); 2527 2528 if Token = Tok_Range then 2529 Set_Range_Constraint (Constraint_Node, P_Range_Constraint); 2530 end if; 2531 2532 return Constraint_Node; 2533 end P_Digits_Constraint; 2534 2535 ----------------------------- 2536 -- 3.5.9 Delta Constraint -- 2537 ----------------------------- 2538 2539 -- DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT] 2540 2541 -- Note: this is an obsolescent feature in Ada 95 (I.3) 2542 2543 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION 2544 -- (also true in formal modes). 2545 2546 -- The caller has checked that the initial token is DELTA 2547 2548 -- Error recovery: cannot raise Error_Resync 2549 2550 function P_Delta_Constraint return Node_Id is 2551 Constraint_Node : Node_Id; 2552 Expr_Node : Node_Id; 2553 2554 begin 2555 Constraint_Node := New_Node (N_Delta_Constraint, Token_Ptr); 2556 Scan; -- past DELTA 2557 Expr_Node := P_Expression; 2558 Check_Simple_Expression_In_Ada_83 (Expr_Node); 2559 2560 Set_Delta_Expression (Constraint_Node, Expr_Node); 2561 2562 if Token = Tok_Range then 2563 Set_Range_Constraint (Constraint_Node, P_Range_Constraint); 2564 end if; 2565 2566 return Constraint_Node; 2567 end P_Delta_Constraint; 2568 2569 -------------------------------- 2570 -- 3.6 Array Type Definition -- 2571 -------------------------------- 2572 2573 -- ARRAY_TYPE_DEFINITION ::= 2574 -- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION 2575 2576 -- UNCONSTRAINED_ARRAY_DEFINITION ::= 2577 -- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of 2578 -- COMPONENT_DEFINITION 2579 2580 -- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <> 2581 2582 -- CONSTRAINED_ARRAY_DEFINITION ::= 2583 -- array (DISCRETE_SUBTYPE_DEFINITION {, DISCRETE_SUBTYPE_DEFINITION}) of 2584 -- COMPONENT_DEFINITION 2585 2586 -- DISCRETE_SUBTYPE_DEFINITION ::= 2587 -- DISCRETE_SUBTYPE_INDICATION | RANGE 2588 2589 -- COMPONENT_DEFINITION ::= 2590 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION 2591 2592 -- The caller has checked that the initial token is ARRAY 2593 2594 -- Error recovery: can raise Error_Resync 2595 2596 function P_Array_Type_Definition return Node_Id is 2597 Array_Loc : Source_Ptr; 2598 CompDef_Node : Node_Id; 2599 Def_Node : Node_Id; 2600 Not_Null_Present : Boolean := False; 2601 Subs_List : List_Id; 2602 Scan_State : Saved_Scan_State; 2603 Aliased_Present : Boolean := False; 2604 2605 begin 2606 Array_Loc := Token_Ptr; 2607 Scan; -- past ARRAY 2608 Subs_List := New_List; 2609 T_Left_Paren; 2610 2611 -- It's quite tricky to disentangle these two possibilities, so we do 2612 -- a prescan to determine which case we have and then reset the scan. 2613 -- The prescan skips past possible subtype mark tokens. 2614 2615 Save_Scan_State (Scan_State); -- just after paren 2616 2617 while Token in Token_Class_Desig or else 2618 Token = Tok_Dot or else 2619 Token = Tok_Apostrophe -- because of 'BASE, 'CLASS 2620 loop 2621 Scan; 2622 end loop; 2623 2624 -- If we end up on RANGE <> then we have the unconstrained case. We 2625 -- will also allow the RANGE to be omitted, just to improve error 2626 -- handling for a case like array (integer <>) of integer; 2627 2628 Scan; -- past possible RANGE or <> 2629 2630 if (Prev_Token = Tok_Range and then Token = Tok_Box) or else 2631 Prev_Token = Tok_Box 2632 then 2633 Def_Node := New_Node (N_Unconstrained_Array_Definition, Array_Loc); 2634 Restore_Scan_State (Scan_State); -- to first subtype mark 2635 2636 loop 2637 Append (P_Subtype_Mark_Resync, Subs_List); 2638 T_Range; 2639 T_Box; 2640 exit when Token = Tok_Right_Paren or else Token = Tok_Of; 2641 T_Comma; 2642 end loop; 2643 2644 Set_Subtype_Marks (Def_Node, Subs_List); 2645 2646 else 2647 Def_Node := New_Node (N_Constrained_Array_Definition, Array_Loc); 2648 Restore_Scan_State (Scan_State); -- to first discrete range 2649 2650 loop 2651 Append (P_Discrete_Subtype_Definition, Subs_List); 2652 exit when not Comma_Present; 2653 end loop; 2654 2655 Set_Discrete_Subtype_Definitions (Def_Node, Subs_List); 2656 end if; 2657 2658 T_Right_Paren; 2659 T_Of; 2660 2661 CompDef_Node := New_Node (N_Component_Definition, Token_Ptr); 2662 2663 if Token_Name = Name_Aliased then 2664 Check_95_Keyword (Tok_Aliased, Tok_Identifier); 2665 end if; 2666 2667 if Token = Tok_Aliased then 2668 Aliased_Present := True; 2669 Scan; -- past ALIASED 2670 end if; 2671 2672 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254) 2673 2674 -- Ada 2005 (AI-230): Access Definition case 2675 2676 if Token = Tok_Access then 2677 if Ada_Version < Ada_2005 then 2678 Error_Msg_SP 2679 ("generalized use of anonymous access types " & 2680 "is an Ada 2005 extension"); 2681 Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); 2682 end if; 2683 2684 -- AI95-406 makes "aliased" legal (and useless) in this context so 2685 -- followintg code which used to be needed is commented out. 2686 2687 -- if Aliased_Present then 2688 -- Error_Msg_SP ("ALIASED not allowed here"); 2689 -- end if; 2690 2691 Set_Subtype_Indication (CompDef_Node, Empty); 2692 Set_Aliased_Present (CompDef_Node, False); 2693 Set_Access_Definition (CompDef_Node, 2694 P_Access_Definition (Not_Null_Present)); 2695 else 2696 2697 Set_Access_Definition (CompDef_Node, Empty); 2698 Set_Aliased_Present (CompDef_Node, Aliased_Present); 2699 Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present); 2700 Set_Subtype_Indication (CompDef_Node, 2701 P_Subtype_Indication (Not_Null_Present)); 2702 end if; 2703 2704 Set_Component_Definition (Def_Node, CompDef_Node); 2705 2706 return Def_Node; 2707 end P_Array_Type_Definition; 2708 2709 ----------------------------------------- 2710 -- 3.6 Unconstrained Array Definition -- 2711 ----------------------------------------- 2712 2713 -- Parsed by P_Array_Type_Definition (3.6) 2714 2715 --------------------------------------- 2716 -- 3.6 Constrained Array Definition -- 2717 --------------------------------------- 2718 2719 -- Parsed by P_Array_Type_Definition (3.6) 2720 2721 -------------------------------------- 2722 -- 3.6 Discrete Subtype Definition -- 2723 -------------------------------------- 2724 2725 -- DISCRETE_SUBTYPE_DEFINITION ::= 2726 -- discrete_SUBTYPE_INDICATION | RANGE 2727 2728 -- Note: the discrete subtype definition appearing in a constrained 2729 -- array definition is parsed by P_Array_Type_Definition (3.6) 2730 2731 -- Error recovery: cannot raise Error_Resync 2732 2733 function P_Discrete_Subtype_Definition return Node_Id is 2734 begin 2735 -- The syntax of a discrete subtype definition is identical to that 2736 -- of a discrete range, so we simply share the same parsing code. 2737 2738 return P_Discrete_Range; 2739 end P_Discrete_Subtype_Definition; 2740 2741 ------------------------------- 2742 -- 3.6 Component Definition -- 2743 ------------------------------- 2744 2745 -- For the array case, parsed by P_Array_Type_Definition (3.6) 2746 -- For the record case, parsed by P_Component_Declaration (3.8) 2747 2748 ----------------------------- 2749 -- 3.6.1 Index Constraint -- 2750 ----------------------------- 2751 2752 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1) 2753 2754 --------------------------- 2755 -- 3.6.1 Discrete Range -- 2756 --------------------------- 2757 2758 -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE 2759 2760 -- The possible forms for a discrete range are: 2761 2762 -- Subtype_Mark (SUBTYPE_INDICATION, 3.2.2) 2763 -- Subtype_Mark range Range (SUBTYPE_INDICATION, 3.2.2) 2764 -- Range_Attribute (RANGE, 3.5) 2765 -- Simple_Expression .. Simple_Expression (RANGE, 3.5) 2766 2767 -- Error recovery: cannot raise Error_Resync 2768 2769 function P_Discrete_Range return Node_Id is 2770 Expr_Node : Node_Id; 2771 Range_Node : Node_Id; 2772 2773 begin 2774 Expr_Node := P_Simple_Expression_Or_Range_Attribute; 2775 2776 if Expr_Form = EF_Range_Attr then 2777 return Expr_Node; 2778 2779 elsif Token = Tok_Range then 2780 if Expr_Form /= EF_Simple_Name then 2781 Error_Msg_SC ("range must be preceded by subtype mark"); 2782 end if; 2783 2784 return P_Subtype_Indication (Expr_Node); 2785 2786 -- Check Expression .. Expression case 2787 2788 elsif Token = Tok_Dot_Dot then 2789 Range_Node := New_Node (N_Range, Token_Ptr); 2790 Set_Low_Bound (Range_Node, Expr_Node); 2791 Scan; -- past .. 2792 Expr_Node := P_Expression; 2793 Check_Simple_Expression (Expr_Node); 2794 Set_High_Bound (Range_Node, Expr_Node); 2795 return Range_Node; 2796 2797 -- Otherwise we must have a subtype mark, or an Ada 2012 iterator 2798 2799 elsif Expr_Form = EF_Simple_Name then 2800 return Expr_Node; 2801 2802 -- The domain of iteration must be a name. Semantics will determine that 2803 -- the expression has the proper form. 2804 2805 elsif Ada_Version >= Ada_2012 then 2806 return Expr_Node; 2807 2808 -- If incorrect, complain that we expect .. 2809 2810 else 2811 T_Dot_Dot; 2812 return Expr_Node; 2813 end if; 2814 end P_Discrete_Range; 2815 2816 ---------------------------- 2817 -- 3.7 Discriminant Part -- 2818 ---------------------------- 2819 2820 -- DISCRIMINANT_PART ::= 2821 -- UNKNOWN_DISCRIMINANT_PART 2822 -- | KNOWN_DISCRIMINANT_PART 2823 2824 -- A discriminant part is parsed by P_Known_Discriminant_Part_Opt (3.7) 2825 -- or P_Unknown_Discriminant_Part (3.7), since we know which we want. 2826 2827 ------------------------------------ 2828 -- 3.7 Unknown Discriminant Part -- 2829 ------------------------------------ 2830 2831 -- UNKNOWN_DISCRIMINANT_PART ::= (<>) 2832 2833 -- If no unknown discriminant part is present, then False is returned, 2834 -- otherwise the unknown discriminant is scanned out and True is returned. 2835 2836 -- Error recovery: cannot raise Error_Resync 2837 2838 function P_Unknown_Discriminant_Part_Opt return Boolean is 2839 Scan_State : Saved_Scan_State; 2840 2841 begin 2842 -- If <> right now, then this is missing left paren 2843 2844 if Token = Tok_Box then 2845 U_Left_Paren; 2846 2847 -- If not <> or left paren, then definitely no box 2848 2849 elsif Token /= Tok_Left_Paren then 2850 return False; 2851 2852 -- Left paren, so might be a box after it 2853 2854 else 2855 Save_Scan_State (Scan_State); 2856 Scan; -- past the left paren 2857 2858 if Token /= Tok_Box then 2859 Restore_Scan_State (Scan_State); 2860 return False; 2861 end if; 2862 end if; 2863 2864 -- We are now pointing to the box 2865 2866 if Ada_Version = Ada_83 then 2867 Error_Msg_SC ("(Ada 83) unknown discriminant not allowed!"); 2868 end if; 2869 2870 Scan; -- past the box 2871 U_Right_Paren; -- must be followed by right paren 2872 return True; 2873 end P_Unknown_Discriminant_Part_Opt; 2874 2875 ---------------------------------- 2876 -- 3.7 Known Discriminant Part -- 2877 ---------------------------------- 2878 2879 -- KNOWN_DISCRIMINANT_PART ::= 2880 -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION}) 2881 2882 -- DISCRIMINANT_SPECIFICATION ::= 2883 -- DEFINING_IDENTIFIER_LIST : [NULL_EXCLUSION] SUBTYPE_MARK 2884 -- [:= DEFAULT_EXPRESSION] 2885 -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION 2886 -- [:= DEFAULT_EXPRESSION] 2887 2888 -- If no known discriminant part is present, then No_List is returned 2889 2890 -- Error recovery: cannot raise Error_Resync 2891 2892 function P_Known_Discriminant_Part_Opt return List_Id is 2893 Specification_Node : Node_Id; 2894 Specification_List : List_Id; 2895 Ident_Sloc : Source_Ptr; 2896 Scan_State : Saved_Scan_State; 2897 Num_Idents : Nat; 2898 Not_Null_Present : Boolean; 2899 Ident : Nat; 2900 2901 Idents : array (Int range 1 .. 4096) of Entity_Id; 2902 -- This array holds the list of defining identifiers. The upper bound 2903 -- of 4096 is intended to be essentially infinite, and we do not even 2904 -- bother to check for it being exceeded. 2905 2906 begin 2907 if Token = Tok_Left_Paren then 2908 Specification_List := New_List; 2909 Scan; -- past ( 2910 P_Pragmas_Misplaced; 2911 2912 Specification_Loop : loop 2913 2914 Ident_Sloc := Token_Ptr; 2915 Idents (1) := P_Defining_Identifier (C_Comma_Colon); 2916 Num_Idents := 1; 2917 2918 while Comma_Present loop 2919 Num_Idents := Num_Idents + 1; 2920 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon); 2921 end loop; 2922 2923 -- If there are multiple identifiers, we repeatedly scan the 2924 -- type and initialization expression information by resetting 2925 -- the scan pointer (so that we get completely separate trees 2926 -- for each occurrence). 2927 2928 if Num_Idents > 1 then 2929 Save_Scan_State (Scan_State); 2930 end if; 2931 2932 T_Colon; 2933 2934 -- Loop through defining identifiers in list 2935 2936 Ident := 1; 2937 Ident_Loop : loop 2938 Specification_Node := 2939 New_Node (N_Discriminant_Specification, Ident_Sloc); 2940 Set_Defining_Identifier (Specification_Node, Idents (Ident)); 2941 Not_Null_Present := -- Ada 2005 (AI-231, AI-447) 2942 P_Null_Exclusion (Allow_Anonymous_In_95 => True); 2943 2944 if Token = Tok_Access then 2945 if Ada_Version = Ada_83 then 2946 Error_Msg_SC 2947 ("(Ada 83) access discriminant not allowed!"); 2948 end if; 2949 2950 Set_Discriminant_Type 2951 (Specification_Node, 2952 P_Access_Definition (Not_Null_Present)); 2953 else 2954 2955 Set_Discriminant_Type 2956 (Specification_Node, P_Subtype_Mark); 2957 No_Constraint; 2958 Set_Null_Exclusion_Present -- Ada 2005 (AI-231) 2959 (Specification_Node, Not_Null_Present); 2960 end if; 2961 2962 Set_Expression 2963 (Specification_Node, Init_Expr_Opt (True)); 2964 2965 if Ident > 1 then 2966 Set_Prev_Ids (Specification_Node, True); 2967 end if; 2968 2969 if Ident < Num_Idents then 2970 Set_More_Ids (Specification_Node, True); 2971 end if; 2972 2973 Append (Specification_Node, Specification_List); 2974 exit Ident_Loop when Ident = Num_Idents; 2975 Ident := Ident + 1; 2976 Restore_Scan_State (Scan_State); 2977 T_Colon; 2978 end loop Ident_Loop; 2979 2980 exit Specification_Loop when Token /= Tok_Semicolon; 2981 Scan; -- past ; 2982 P_Pragmas_Misplaced; 2983 end loop Specification_Loop; 2984 2985 T_Right_Paren; 2986 return Specification_List; 2987 2988 else 2989 return No_List; 2990 end if; 2991 end P_Known_Discriminant_Part_Opt; 2992 2993 ------------------------------------- 2994 -- 3.7 Discriminant Specification -- 2995 ------------------------------------- 2996 2997 -- Parsed by P_Known_Discriminant_Part_Opt (3.7) 2998 2999 ----------------------------- 3000 -- 3.7 Default Expression -- 3001 ----------------------------- 3002 3003 -- Always parsed (simply as an Expression) by the parent construct 3004 3005 ------------------------------------ 3006 -- 3.7.1 Discriminant Constraint -- 3007 ------------------------------------ 3008 3009 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1) 3010 3011 -------------------------------------------------------- 3012 -- 3.7.1 Index or Discriminant Constraint (also 3.6) -- 3013 -------------------------------------------------------- 3014 3015 -- DISCRIMINANT_CONSTRAINT ::= 3016 -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION}) 3017 3018 -- DISCRIMINANT_ASSOCIATION ::= 3019 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>] 3020 -- EXPRESSION 3021 3022 -- This routine parses either an index or a discriminant constraint. As 3023 -- is clear from the above grammar, it is often possible to clearly 3024 -- determine which of the two possibilities we have, but there are 3025 -- cases (those in which we have a series of expressions of the same 3026 -- syntactic form as subtype indications), where we cannot tell. Since 3027 -- this means that in any case the semantic phase has to distinguish 3028 -- between the two, there is not much point in the parser trying to 3029 -- distinguish even those cases where the difference is clear. In any 3030 -- case, if we have a situation like: 3031 3032 -- (A => 123, 235 .. 500) 3033 3034 -- it is not clear which of the two items is the wrong one, better to 3035 -- let the semantic phase give a clear message. Consequently, this 3036 -- routine in general returns a list of items which can be either 3037 -- discrete ranges or discriminant associations. 3038 3039 -- The caller has checked that the initial token is a left paren 3040 3041 -- Error recovery: can raise Error_Resync 3042 3043 function P_Index_Or_Discriminant_Constraint return Node_Id is 3044 Scan_State : Saved_Scan_State; 3045 Constr_Node : Node_Id; 3046 Constr_List : List_Id; 3047 Expr_Node : Node_Id; 3048 Result_Node : Node_Id; 3049 3050 begin 3051 Result_Node := New_Node (N_Index_Or_Discriminant_Constraint, Token_Ptr); 3052 Scan; -- past ( 3053 Constr_List := New_List; 3054 Set_Constraints (Result_Node, Constr_List); 3055 3056 -- The two syntactic forms are a little mixed up, so what we are doing 3057 -- here is looking at the first entry to determine which case we have 3058 3059 -- A discriminant constraint is a list of discriminant associations, 3060 -- which have one of the following possible forms: 3061 3062 -- Expression 3063 -- Id => Expression 3064 -- Id | Id | .. | Id => Expression 3065 3066 -- An index constraint is a list of discrete ranges which have one 3067 -- of the following possible forms: 3068 3069 -- Subtype_Mark 3070 -- Subtype_Mark range Range 3071 -- Range_Attribute 3072 -- Simple_Expression .. Simple_Expression 3073 3074 -- Loop through discriminants in list 3075 3076 loop 3077 -- Check cases of Id => Expression or Id | Id => Expression 3078 3079 if Token = Tok_Identifier then 3080 Save_Scan_State (Scan_State); -- at Id 3081 Scan; -- past Id 3082 3083 if Token = Tok_Arrow or else Token = Tok_Vertical_Bar then 3084 Restore_Scan_State (Scan_State); -- to Id 3085 Append (P_Discriminant_Association, Constr_List); 3086 goto Loop_Continue; 3087 else 3088 Restore_Scan_State (Scan_State); -- to Id 3089 end if; 3090 end if; 3091 3092 -- Otherwise scan out an expression and see what we have got 3093 3094 Expr_Node := P_Expression_Or_Range_Attribute; 3095 3096 if Expr_Form = EF_Range_Attr then 3097 Append (Expr_Node, Constr_List); 3098 3099 elsif Token = Tok_Range then 3100 if Expr_Form /= EF_Simple_Name then 3101 Error_Msg_SC ("subtype mark required before RANGE"); 3102 end if; 3103 3104 Append (P_Subtype_Indication (Expr_Node), Constr_List); 3105 goto Loop_Continue; 3106 3107 -- Check Simple_Expression .. Simple_Expression case 3108 3109 elsif Token = Tok_Dot_Dot then 3110 Check_Simple_Expression (Expr_Node); 3111 Constr_Node := New_Node (N_Range, Token_Ptr); 3112 Set_Low_Bound (Constr_Node, Expr_Node); 3113 Scan; -- past .. 3114 Expr_Node := P_Expression; 3115 Check_Simple_Expression (Expr_Node); 3116 Set_High_Bound (Constr_Node, Expr_Node); 3117 Append (Constr_Node, Constr_List); 3118 goto Loop_Continue; 3119 3120 -- Case of an expression which could be either form 3121 3122 else 3123 Append (Expr_Node, Constr_List); 3124 goto Loop_Continue; 3125 end if; 3126 3127 -- Here with a single entry scanned 3128 3129 <<Loop_Continue>> 3130 exit when not Comma_Present; 3131 3132 end loop; 3133 3134 T_Right_Paren; 3135 return Result_Node; 3136 end P_Index_Or_Discriminant_Constraint; 3137 3138 ------------------------------------- 3139 -- 3.7.1 Discriminant Association -- 3140 ------------------------------------- 3141 3142 -- DISCRIMINANT_ASSOCIATION ::= 3143 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>] 3144 -- EXPRESSION 3145 3146 -- This routine is used only when the name list is present and the caller 3147 -- has already checked this (by scanning ahead and repositioning the 3148 -- scan). 3149 3150 -- Error_Recovery: cannot raise Error_Resync; 3151 3152 function P_Discriminant_Association return Node_Id is 3153 Discr_Node : Node_Id; 3154 Names_List : List_Id; 3155 Ident_Sloc : Source_Ptr; 3156 3157 begin 3158 Ident_Sloc := Token_Ptr; 3159 Names_List := New_List; 3160 3161 loop 3162 Append (P_Identifier (C_Vertical_Bar_Arrow), Names_List); 3163 exit when Token /= Tok_Vertical_Bar; 3164 Scan; -- past | 3165 end loop; 3166 3167 Discr_Node := New_Node (N_Discriminant_Association, Ident_Sloc); 3168 Set_Selector_Names (Discr_Node, Names_List); 3169 TF_Arrow; 3170 Set_Expression (Discr_Node, P_Expression); 3171 return Discr_Node; 3172 end P_Discriminant_Association; 3173 3174 --------------------------------- 3175 -- 3.8 Record Type Definition -- 3176 --------------------------------- 3177 3178 -- RECORD_TYPE_DEFINITION ::= 3179 -- [[abstract] tagged] [limited] RECORD_DEFINITION 3180 3181 -- There is no node in the tree for a record type definition. Instead 3182 -- a record definition node appears, with possible Abstract_Present, 3183 -- Tagged_Present, and Limited_Present flags set appropriately. 3184 3185 ---------------------------- 3186 -- 3.8 Record Definition -- 3187 ---------------------------- 3188 3189 -- RECORD_DEFINITION ::= 3190 -- record 3191 -- COMPONENT_LIST 3192 -- end record 3193 -- | null record 3194 3195 -- Note: in the case where a record definition node is used to represent 3196 -- a record type definition, the caller sets the Tagged_Present and 3197 -- Limited_Present flags in the resulting N_Record_Definition node as 3198 -- required. 3199 3200 -- Note that the RECORD token at the start may be missing in certain 3201 -- error situations, so this function is expected to post the error 3202 3203 -- Error recovery: can raise Error_Resync 3204 3205 function P_Record_Definition return Node_Id is 3206 Rec_Node : Node_Id; 3207 3208 begin 3209 Inside_Record_Definition := True; 3210 Rec_Node := New_Node (N_Record_Definition, Token_Ptr); 3211 3212 -- Null record case 3213 3214 if Token = Tok_Null then 3215 Scan; -- past NULL 3216 T_Record; 3217 Set_Null_Present (Rec_Node, True); 3218 3219 -- Catch incomplete declaration to prevent cascaded errors, see 3220 -- ACATS B393002 for an example. 3221 3222 elsif Token = Tok_Semicolon then 3223 Error_Msg_AP ("missing record definition"); 3224 3225 -- Case starting with RECORD keyword. Build scope stack entry. For the 3226 -- column, we use the first non-blank character on the line, to deal 3227 -- with situations such as: 3228 3229 -- type X is record 3230 -- ... 3231 -- end record; 3232 3233 -- which is not official RM indentation, but is not uncommon usage, and 3234 -- in particular is standard GNAT coding style, so handle it nicely. 3235 3236 else 3237 Push_Scope_Stack; 3238 Scope.Table (Scope.Last).Etyp := E_Record; 3239 Scope.Table (Scope.Last).Ecol := Start_Column; 3240 Scope.Table (Scope.Last).Sloc := Token_Ptr; 3241 Scope.Table (Scope.Last).Labl := Error; 3242 Scope.Table (Scope.Last).Junk := (Token /= Tok_Record); 3243 3244 T_Record; 3245 3246 Set_Component_List (Rec_Node, P_Component_List); 3247 3248 loop 3249 exit when Check_End; 3250 Discard_Junk_Node (P_Component_List); 3251 end loop; 3252 end if; 3253 3254 Inside_Record_Definition := False; 3255 return Rec_Node; 3256 end P_Record_Definition; 3257 3258 ------------------------- 3259 -- 3.8 Component List -- 3260 ------------------------- 3261 3262 -- COMPONENT_LIST ::= 3263 -- COMPONENT_ITEM {COMPONENT_ITEM} 3264 -- | {COMPONENT_ITEM} VARIANT_PART 3265 -- | null; 3266 3267 -- Error recovery: cannot raise Error_Resync 3268 3269 function P_Component_List return Node_Id is 3270 Component_List_Node : Node_Id; 3271 Decls_List : List_Id; 3272 Scan_State : Saved_Scan_State; 3273 Null_Loc : Source_Ptr; 3274 3275 begin 3276 Component_List_Node := New_Node (N_Component_List, Token_Ptr); 3277 Decls_List := New_List; 3278 3279 -- Handle null 3280 3281 if Token = Tok_Null then 3282 Null_Loc := Token_Ptr; 3283 Scan; -- past NULL 3284 TF_Semicolon; 3285 P_Pragmas_Opt (Decls_List); 3286 3287 -- If we have an END or WHEN now, everything is fine, otherwise we 3288 -- complain about the null, ignore it, and scan for more components. 3289 3290 if Token = Tok_End or else Token = Tok_When then 3291 Set_Null_Present (Component_List_Node, True); 3292 return Component_List_Node; 3293 else 3294 Error_Msg ("NULL component only allowed in null record", Null_Loc); 3295 end if; 3296 end if; 3297 3298 -- Scan components for non-null record 3299 3300 P_Pragmas_Opt (Decls_List); 3301 3302 if Token /= Tok_Case then 3303 Component_Scan_Loop : loop 3304 P_Component_Items (Decls_List); 3305 P_Pragmas_Opt (Decls_List); 3306 3307 exit Component_Scan_Loop when Token = Tok_End 3308 or else Token = Tok_Case 3309 or else Token = Tok_When; 3310 3311 -- We are done if we do not have an identifier. However, if we 3312 -- have a misspelled reserved identifier that is in a column to 3313 -- the right of the record definition, we will treat it as an 3314 -- identifier. It turns out to be too dangerous in practice to 3315 -- accept such a mis-spelled identifier which does not have this 3316 -- additional clue that confirms the incorrect spelling. 3317 3318 if Token /= Tok_Identifier then 3319 if Start_Column > Scope.Table (Scope.Last).Ecol 3320 and then Is_Reserved_Identifier 3321 then 3322 Save_Scan_State (Scan_State); -- at reserved id 3323 Scan; -- possible reserved id 3324 3325 if Token = Tok_Comma or else Token = Tok_Colon then 3326 Restore_Scan_State (Scan_State); 3327 Scan_Reserved_Identifier (Force_Msg => True); 3328 3329 -- Note reserved identifier used as field name after all 3330 -- because not followed by colon or comma. 3331 3332 else 3333 Restore_Scan_State (Scan_State); 3334 exit Component_Scan_Loop; 3335 end if; 3336 3337 -- Non-identifier that definitely was not reserved id 3338 3339 else 3340 exit Component_Scan_Loop; 3341 end if; 3342 end if; 3343 end loop Component_Scan_Loop; 3344 end if; 3345 3346 if Token = Tok_Case then 3347 Set_Variant_Part (Component_List_Node, P_Variant_Part); 3348 3349 -- Check for junk after variant part 3350 3351 if Token = Tok_Identifier then 3352 Save_Scan_State (Scan_State); 3353 Scan; -- past identifier 3354 3355 if Token = Tok_Colon then 3356 Restore_Scan_State (Scan_State); 3357 Error_Msg_SC ("component may not follow variant part"); 3358 Discard_Junk_Node (P_Component_List); 3359 3360 elsif Token = Tok_Case then 3361 Restore_Scan_State (Scan_State); 3362 Error_Msg_SC ("only one variant part allowed in a record"); 3363 Discard_Junk_Node (P_Component_List); 3364 3365 else 3366 Restore_Scan_State (Scan_State); 3367 end if; 3368 end if; 3369 end if; 3370 3371 Set_Component_Items (Component_List_Node, Decls_List); 3372 return Component_List_Node; 3373 end P_Component_List; 3374 3375 ------------------------- 3376 -- 3.8 Component Item -- 3377 ------------------------- 3378 3379 -- COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE 3380 3381 -- COMPONENT_DECLARATION ::= 3382 -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION 3383 -- [:= DEFAULT_EXPRESSION] 3384 -- [ASPECT_SPECIFICATIONS]; 3385 3386 -- COMPONENT_DEFINITION ::= 3387 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION 3388 3389 -- Error recovery: cannot raise Error_Resync, if an error occurs, 3390 -- the scan is positioned past the following semicolon. 3391 3392 -- Note: we do not yet allow representation clauses to appear as component 3393 -- items, do we need to add this capability sometime in the future ??? 3394 3395 procedure P_Component_Items (Decls : List_Id) is 3396 Aliased_Present : Boolean := False; 3397 CompDef_Node : Node_Id; 3398 Decl_Node : Node_Id; 3399 Scan_State : Saved_Scan_State; 3400 Not_Null_Present : Boolean := False; 3401 Num_Idents : Nat; 3402 Ident : Nat; 3403 Ident_Sloc : Source_Ptr; 3404 3405 Idents : array (Int range 1 .. 4096) of Entity_Id; 3406 -- This array holds the list of defining identifiers. The upper bound 3407 -- of 4096 is intended to be essentially infinite, and we do not even 3408 -- bother to check for it being exceeded. 3409 3410 begin 3411 if Token /= Tok_Identifier then 3412 Error_Msg_SC ("component declaration expected"); 3413 Resync_Past_Semicolon; 3414 return; 3415 end if; 3416 3417 Ident_Sloc := Token_Ptr; 3418 Idents (1) := P_Defining_Identifier (C_Comma_Colon); 3419 Num_Idents := 1; 3420 3421 while Comma_Present loop 3422 Num_Idents := Num_Idents + 1; 3423 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon); 3424 end loop; 3425 3426 -- If there are multiple identifiers, we repeatedly scan the 3427 -- type and initialization expression information by resetting 3428 -- the scan pointer (so that we get completely separate trees 3429 -- for each occurrence). 3430 3431 if Num_Idents > 1 then 3432 Save_Scan_State (Scan_State); 3433 end if; 3434 3435 T_Colon; 3436 3437 -- Loop through defining identifiers in list 3438 3439 Ident := 1; 3440 Ident_Loop : loop 3441 3442 -- The following block is present to catch Error_Resync 3443 -- which causes the parse to be reset past the semicolon 3444 3445 begin 3446 Decl_Node := New_Node (N_Component_Declaration, Ident_Sloc); 3447 Set_Defining_Identifier (Decl_Node, Idents (Ident)); 3448 3449 if Token = Tok_Constant then 3450 Error_Msg_SC ("constant components are not permitted"); 3451 Scan; 3452 end if; 3453 3454 CompDef_Node := New_Node (N_Component_Definition, Token_Ptr); 3455 3456 if Token_Name = Name_Aliased then 3457 Check_95_Keyword (Tok_Aliased, Tok_Identifier); 3458 end if; 3459 3460 if Token = Tok_Aliased then 3461 Aliased_Present := True; 3462 Scan; -- past ALIASED 3463 end if; 3464 3465 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254) 3466 3467 -- Ada 2005 (AI-230): Access Definition case 3468 3469 if Token = Tok_Access then 3470 if Ada_Version < Ada_2005 then 3471 Error_Msg_SP 3472 ("generalized use of anonymous access types " & 3473 "is an Ada 2005 extension"); 3474 Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); 3475 end if; 3476 3477 -- AI95-406 makes "aliased" legal (and useless) here, so the 3478 -- following code which used to be required is commented out. 3479 3480 -- if Aliased_Present then 3481 -- Error_Msg_SP ("ALIASED not allowed here"); 3482 -- end if; 3483 3484 Set_Subtype_Indication (CompDef_Node, Empty); 3485 Set_Aliased_Present (CompDef_Node, False); 3486 Set_Access_Definition (CompDef_Node, 3487 P_Access_Definition (Not_Null_Present)); 3488 else 3489 3490 Set_Access_Definition (CompDef_Node, Empty); 3491 Set_Aliased_Present (CompDef_Node, Aliased_Present); 3492 Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present); 3493 3494 if Token = Tok_Array then 3495 Error_Msg_SC ("anonymous arrays not allowed as components"); 3496 raise Error_Resync; 3497 end if; 3498 3499 Set_Subtype_Indication (CompDef_Node, 3500 P_Subtype_Indication (Not_Null_Present)); 3501 end if; 3502 3503 Set_Component_Definition (Decl_Node, CompDef_Node); 3504 Set_Expression (Decl_Node, Init_Expr_Opt); 3505 3506 if Ident > 1 then 3507 Set_Prev_Ids (Decl_Node, True); 3508 end if; 3509 3510 if Ident < Num_Idents then 3511 Set_More_Ids (Decl_Node, True); 3512 end if; 3513 3514 Append (Decl_Node, Decls); 3515 3516 exception 3517 when Error_Resync => 3518 if Token /= Tok_End then 3519 Resync_Past_Semicolon; 3520 end if; 3521 end; 3522 3523 exit Ident_Loop when Ident = Num_Idents; 3524 Ident := Ident + 1; 3525 Restore_Scan_State (Scan_State); 3526 T_Colon; 3527 end loop Ident_Loop; 3528 3529 P_Aspect_Specifications (Decl_Node); 3530 end P_Component_Items; 3531 3532 -------------------------------- 3533 -- 3.8 Component Declaration -- 3534 -------------------------------- 3535 3536 -- Parsed by P_Component_Items (3.8) 3537 3538 ------------------------- 3539 -- 3.8.1 Variant Part -- 3540 ------------------------- 3541 3542 -- VARIANT_PART ::= 3543 -- case discriminant_DIRECT_NAME is 3544 -- VARIANT 3545 -- {VARIANT} 3546 -- end case; 3547 3548 -- The caller has checked that the initial token is CASE 3549 3550 -- Error recovery: cannot raise Error_Resync 3551 3552 function P_Variant_Part return Node_Id is 3553 Variant_Part_Node : Node_Id; 3554 Variants_List : List_Id; 3555 Case_Node : Node_Id; 3556 3557 begin 3558 Variant_Part_Node := New_Node (N_Variant_Part, Token_Ptr); 3559 Push_Scope_Stack; 3560 Scope.Table (Scope.Last).Etyp := E_Case; 3561 Scope.Table (Scope.Last).Sloc := Token_Ptr; 3562 Scope.Table (Scope.Last).Ecol := Start_Column; 3563 3564 Scan; -- past CASE 3565 Case_Node := P_Expression; 3566 Set_Name (Variant_Part_Node, Case_Node); 3567 3568 if Nkind (Case_Node) /= N_Identifier then 3569 Set_Name (Variant_Part_Node, Error); 3570 Error_Msg ("discriminant name expected", Sloc (Case_Node)); 3571 3572 elsif Paren_Count (Case_Node) /= 0 then 3573 Error_Msg 3574 ("|discriminant name may not be parenthesized", 3575 Sloc (Case_Node)); 3576 Set_Paren_Count (Case_Node, 0); 3577 end if; 3578 3579 TF_Is; 3580 Variants_List := New_List; 3581 P_Pragmas_Opt (Variants_List); 3582 3583 -- Test missing variant 3584 3585 if Token = Tok_End then 3586 Error_Msg_BC ("WHEN expected (must have at least one variant)"); 3587 else 3588 Append (P_Variant, Variants_List); 3589 end if; 3590 3591 -- Loop through variants, note that we allow if in place of when, 3592 -- this error will be detected and handled in P_Variant. 3593 3594 loop 3595 P_Pragmas_Opt (Variants_List); 3596 3597 if Token /= Tok_When 3598 and then Token /= Tok_If 3599 and then Token /= Tok_Others 3600 then 3601 exit when Check_End; 3602 end if; 3603 3604 Append (P_Variant, Variants_List); 3605 end loop; 3606 3607 Set_Variants (Variant_Part_Node, Variants_List); 3608 return Variant_Part_Node; 3609 end P_Variant_Part; 3610 3611 -------------------- 3612 -- 3.8.1 Variant -- 3613 -------------------- 3614 3615 -- VARIANT ::= 3616 -- when DISCRETE_CHOICE_LIST => 3617 -- COMPONENT_LIST 3618 3619 -- Error recovery: cannot raise Error_Resync 3620 3621 -- The initial token on entry is either WHEN, IF or OTHERS 3622 3623 function P_Variant return Node_Id is 3624 Variant_Node : Node_Id; 3625 3626 begin 3627 -- Special check to recover nicely from use of IF in place of WHEN 3628 3629 if Token = Tok_If then 3630 T_When; 3631 Scan; -- past IF 3632 else 3633 T_When; 3634 end if; 3635 3636 Variant_Node := New_Node (N_Variant, Prev_Token_Ptr); 3637 Set_Discrete_Choices (Variant_Node, P_Discrete_Choice_List); 3638 TF_Arrow; 3639 Set_Component_List (Variant_Node, P_Component_List); 3640 return Variant_Node; 3641 end P_Variant; 3642 3643 --------------------------------- 3644 -- 3.8.1 Discrete Choice List -- 3645 --------------------------------- 3646 3647 -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE} 3648 3649 -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others 3650 3651 -- Note: in Ada 83, the expression must be a simple expression 3652 3653 -- Error recovery: cannot raise Error_Resync 3654 3655 function P_Discrete_Choice_List return List_Id is 3656 Choices : List_Id; 3657 Expr_Node : Node_Id; 3658 Choice_Node : Node_Id; 3659 3660 begin 3661 Choices := New_List; 3662 loop 3663 if Token = Tok_Others then 3664 Append (New_Node (N_Others_Choice, Token_Ptr), Choices); 3665 Scan; -- past OTHERS 3666 3667 else 3668 begin 3669 -- Scan out expression or range attribute 3670 3671 Expr_Node := P_Expression_Or_Range_Attribute; 3672 Ignore (Tok_Right_Paren); 3673 3674 if Token = Tok_Colon 3675 and then Nkind (Expr_Node) = N_Identifier 3676 then 3677 Error_Msg_SP ("label not permitted in this context"); 3678 Scan; -- past colon 3679 3680 -- Range attribute 3681 3682 elsif Expr_Form = EF_Range_Attr then 3683 Append (Expr_Node, Choices); 3684 3685 -- Explicit range 3686 3687 elsif Token = Tok_Dot_Dot then 3688 Check_Simple_Expression (Expr_Node); 3689 Choice_Node := New_Node (N_Range, Token_Ptr); 3690 Set_Low_Bound (Choice_Node, Expr_Node); 3691 Scan; -- past .. 3692 Expr_Node := P_Expression_No_Right_Paren; 3693 Check_Simple_Expression (Expr_Node); 3694 Set_High_Bound (Choice_Node, Expr_Node); 3695 Append (Choice_Node, Choices); 3696 3697 -- Simple name, must be subtype, so range allowed 3698 3699 elsif Expr_Form = EF_Simple_Name then 3700 if Token = Tok_Range then 3701 Append (P_Subtype_Indication (Expr_Node), Choices); 3702 3703 elsif Token in Token_Class_Consk then 3704 Error_Msg_SC 3705 ("the only constraint allowed here " & 3706 "is a range constraint"); 3707 Discard_Junk_Node (P_Constraint_Opt); 3708 Append (Expr_Node, Choices); 3709 3710 else 3711 Append (Expr_Node, Choices); 3712 end if; 3713 3714 -- Expression 3715 3716 else 3717 -- In Ada 2012 mode, the expression must be a simple 3718 -- expression. The reason for this restriction (i.e. going 3719 -- back to the Ada 83 rule) is to avoid ambiguities when set 3720 -- membership operations are allowed, consider the 3721 -- following: 3722 3723 -- when A in 1 .. 10 | 12 => 3724 3725 -- This is ambiguous without parentheses, so we require one 3726 -- of the following two parenthesized forms to disambiguate: 3727 3728 -- one of the following: 3729 3730 -- when (A in 1 .. 10 | 12) => 3731 -- when (A in 1 .. 10) | 12 => 3732 3733 -- To solve this, in Ada 2012 mode, we disallow the use of 3734 -- membership operations in expressions in choices. 3735 3736 -- Technically in the grammar, the expression must match the 3737 -- grammar for restricted expression. 3738 3739 if Ada_Version >= Ada_2012 then 3740 Check_Restricted_Expression (Expr_Node); 3741 3742 -- In Ada 83 mode, the syntax required a simple expression 3743 3744 else 3745 Check_Simple_Expression_In_Ada_83 (Expr_Node); 3746 end if; 3747 3748 Append (Expr_Node, Choices); 3749 end if; 3750 3751 exception 3752 when Error_Resync => 3753 Resync_Choice; 3754 return Error_List; 3755 end; 3756 end if; 3757 3758 if Token = Tok_Comma then 3759 Scan; -- past comma 3760 3761 if Token = Tok_Vertical_Bar then 3762 Error_Msg_SP -- CODEFIX 3763 ("|extra "","" ignored"); 3764 Scan; -- past | 3765 3766 else 3767 Error_Msg_SP -- CODEFIX 3768 (""","" should be ""'|"""); 3769 end if; 3770 3771 else 3772 exit when Token /= Tok_Vertical_Bar; 3773 Scan; -- past | 3774 end if; 3775 3776 end loop; 3777 3778 return Choices; 3779 end P_Discrete_Choice_List; 3780 3781 ---------------------------- 3782 -- 3.8.1 Discrete Choice -- 3783 ---------------------------- 3784 3785 -- Parsed by P_Discrete_Choice_List (3.8.1) 3786 3787 ---------------------------------- 3788 -- 3.9.1 Record Extension Part -- 3789 ---------------------------------- 3790 3791 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION 3792 3793 -- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4) 3794 3795 -------------------------------------- 3796 -- 3.9.4 Interface Type Definition -- 3797 -------------------------------------- 3798 3799 -- INTERFACE_TYPE_DEFINITION ::= 3800 -- [limited | task | protected | synchronized] interface 3801 -- [and INTERFACE_LIST] 3802 3803 -- Error recovery: cannot raise Error_Resync 3804 3805 function P_Interface_Type_Definition 3806 (Abstract_Present : Boolean) return Node_Id 3807 is 3808 Typedef_Node : Node_Id; 3809 3810 begin 3811 if Ada_Version < Ada_2005 then 3812 Error_Msg_SP ("abstract interface is an Ada 2005 extension"); 3813 Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); 3814 end if; 3815 3816 if Abstract_Present then 3817 Error_Msg_SP 3818 ("ABSTRACT not allowed in interface type definition " & 3819 "(RM 3.9.4(2/2))"); 3820 end if; 3821 3822 Scan; -- past INTERFACE 3823 3824 -- Ada 2005 (AI-345): In case of interfaces with a null list of 3825 -- interfaces we build a record_definition node. 3826 3827 if Token = Tok_Semicolon or else Aspect_Specifications_Present then 3828 Typedef_Node := New_Node (N_Record_Definition, Token_Ptr); 3829 3830 Set_Abstract_Present (Typedef_Node); 3831 Set_Tagged_Present (Typedef_Node); 3832 Set_Null_Present (Typedef_Node); 3833 Set_Interface_Present (Typedef_Node); 3834 3835 -- Ada 2005 (AI-251): In case of not-synchronized interfaces that have 3836 -- a list of interfaces we build a derived_type_definition node. This 3837 -- simplifies the semantic analysis (and hence further maintenance) 3838 3839 else 3840 if Token /= Tok_And then 3841 Error_Msg_AP ("AND expected"); 3842 else 3843 Scan; -- past AND 3844 end if; 3845 3846 Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr); 3847 3848 Set_Abstract_Present (Typedef_Node); 3849 Set_Interface_Present (Typedef_Node); 3850 Set_Subtype_Indication (Typedef_Node, P_Qualified_Simple_Name); 3851 3852 Set_Record_Extension_Part (Typedef_Node, 3853 New_Node (N_Record_Definition, Token_Ptr)); 3854 Set_Null_Present (Record_Extension_Part (Typedef_Node)); 3855 3856 if Token = Tok_And then 3857 Set_Interface_List (Typedef_Node, New_List); 3858 Scan; -- past AND 3859 3860 loop 3861 Append (P_Qualified_Simple_Name, 3862 Interface_List (Typedef_Node)); 3863 exit when Token /= Tok_And; 3864 Scan; -- past AND 3865 end loop; 3866 end if; 3867 end if; 3868 3869 return Typedef_Node; 3870 end P_Interface_Type_Definition; 3871 3872 ---------------------------------- 3873 -- 3.10 Access Type Definition -- 3874 ---------------------------------- 3875 3876 -- ACCESS_TYPE_DEFINITION ::= 3877 -- ACCESS_TO_OBJECT_DEFINITION 3878 -- | ACCESS_TO_SUBPROGRAM_DEFINITION 3879 3880 -- ACCESS_TO_OBJECT_DEFINITION ::= 3881 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION 3882 3883 -- GENERAL_ACCESS_MODIFIER ::= all | constant 3884 3885 -- ACCESS_TO_SUBPROGRAM_DEFINITION 3886 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE 3887 -- | [NULL_EXCLUSION] access [protected] function 3888 -- PARAMETER_AND_RESULT_PROFILE 3889 3890 -- PARAMETER_PROFILE ::= [FORMAL_PART] 3891 3892 -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK 3893 3894 -- Ada 2005 (AI-254): If Header_Already_Parsed then the caller has already 3895 -- parsed the null_exclusion part and has also removed the ACCESS token; 3896 -- otherwise the caller has just checked that the initial token is ACCESS 3897 3898 -- Error recovery: can raise Error_Resync 3899 3900 function P_Access_Type_Definition 3901 (Header_Already_Parsed : Boolean := False) return Node_Id 3902 is 3903 Access_Loc : constant Source_Ptr := Token_Ptr; 3904 Prot_Flag : Boolean; 3905 Not_Null_Present : Boolean := False; 3906 Type_Def_Node : Node_Id; 3907 Result_Not_Null : Boolean; 3908 Result_Node : Node_Id; 3909 3910 procedure Check_Junk_Subprogram_Name; 3911 -- Used in access to subprogram definition cases to check for an 3912 -- identifier or operator symbol that does not belong. 3913 3914 -------------------------------- 3915 -- Check_Junk_Subprogram_Name -- 3916 -------------------------------- 3917 3918 procedure Check_Junk_Subprogram_Name is 3919 Saved_State : Saved_Scan_State; 3920 3921 begin 3922 if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then 3923 Save_Scan_State (Saved_State); 3924 Scan; -- past possible junk subprogram name 3925 3926 if Token = Tok_Left_Paren or else Token = Tok_Semicolon then 3927 Error_Msg_SP ("unexpected subprogram name ignored"); 3928 return; 3929 3930 else 3931 Restore_Scan_State (Saved_State); 3932 end if; 3933 end if; 3934 end Check_Junk_Subprogram_Name; 3935 3936 -- Start of processing for P_Access_Type_Definition 3937 3938 begin 3939 if not Header_Already_Parsed then 3940 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) 3941 Scan; -- past ACCESS 3942 end if; 3943 3944 if Token_Name = Name_Protected then 3945 Check_95_Keyword (Tok_Protected, Tok_Procedure); 3946 Check_95_Keyword (Tok_Protected, Tok_Function); 3947 end if; 3948 3949 Prot_Flag := (Token = Tok_Protected); 3950 3951 if Prot_Flag then 3952 Scan; -- past PROTECTED 3953 3954 if Token /= Tok_Procedure and then Token /= Tok_Function then 3955 Error_Msg_SC -- CODEFIX 3956 ("FUNCTION or PROCEDURE expected"); 3957 end if; 3958 end if; 3959 3960 if Token = Tok_Procedure then 3961 if Ada_Version = Ada_83 then 3962 Error_Msg_SC ("(Ada 83) access to procedure not allowed!"); 3963 end if; 3964 3965 Type_Def_Node := New_Node (N_Access_Procedure_Definition, Access_Loc); 3966 Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present); 3967 Scan; -- past PROCEDURE 3968 Check_Junk_Subprogram_Name; 3969 Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile); 3970 Set_Protected_Present (Type_Def_Node, Prot_Flag); 3971 3972 elsif Token = Tok_Function then 3973 if Ada_Version = Ada_83 then 3974 Error_Msg_SC ("(Ada 83) access to function not allowed!"); 3975 end if; 3976 3977 Type_Def_Node := New_Node (N_Access_Function_Definition, Access_Loc); 3978 Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present); 3979 Scan; -- past FUNCTION 3980 Check_Junk_Subprogram_Name; 3981 Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile); 3982 Set_Protected_Present (Type_Def_Node, Prot_Flag); 3983 TF_Return; 3984 3985 Result_Not_Null := P_Null_Exclusion; -- Ada 2005 (AI-231) 3986 3987 -- Ada 2005 (AI-318-02) 3988 3989 if Token = Tok_Access then 3990 if Ada_Version < Ada_2005 then 3991 Error_Msg_SC 3992 ("anonymous access result type is an Ada 2005 extension"); 3993 Error_Msg_SC ("\unit must be compiled with -gnat05 switch"); 3994 end if; 3995 3996 Result_Node := P_Access_Definition (Result_Not_Null); 3997 3998 else 3999 Result_Node := P_Subtype_Mark; 4000 No_Constraint; 4001 4002 -- A null exclusion on the result type must be recorded in a flag 4003 -- distinct from the one used for the access-to-subprogram type's 4004 -- null exclusion. 4005 4006 Set_Null_Exclusion_In_Return_Present 4007 (Type_Def_Node, Result_Not_Null); 4008 end if; 4009 4010 Set_Result_Definition (Type_Def_Node, Result_Node); 4011 4012 else 4013 Type_Def_Node := 4014 New_Node (N_Access_To_Object_Definition, Access_Loc); 4015 Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present); 4016 4017 if Token = Tok_All or else Token = Tok_Constant then 4018 if Ada_Version = Ada_83 then 4019 Error_Msg_SC ("(Ada 83) access modifier not allowed!"); 4020 end if; 4021 4022 if Token = Tok_All then 4023 Set_All_Present (Type_Def_Node, True); 4024 4025 else 4026 Set_Constant_Present (Type_Def_Node, True); 4027 end if; 4028 4029 Scan; -- past ALL or CONSTANT 4030 end if; 4031 4032 Set_Subtype_Indication (Type_Def_Node, 4033 P_Subtype_Indication (Not_Null_Present)); 4034 end if; 4035 4036 return Type_Def_Node; 4037 end P_Access_Type_Definition; 4038 4039 --------------------------------------- 4040 -- 3.10 Access To Object Definition -- 4041 --------------------------------------- 4042 4043 -- Parsed by P_Access_Type_Definition (3.10) 4044 4045 ----------------------------------- 4046 -- 3.10 General Access Modifier -- 4047 ----------------------------------- 4048 4049 -- Parsed by P_Access_Type_Definition (3.10) 4050 4051 ------------------------------------------- 4052 -- 3.10 Access To Subprogram Definition -- 4053 ------------------------------------------- 4054 4055 -- Parsed by P_Access_Type_Definition (3.10) 4056 4057 ----------------------------- 4058 -- 3.10 Access Definition -- 4059 ----------------------------- 4060 4061 -- ACCESS_DEFINITION ::= 4062 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK 4063 -- | ACCESS_TO_SUBPROGRAM_DEFINITION 4064 -- 4065 -- ACCESS_TO_SUBPROGRAM_DEFINITION 4066 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE 4067 -- | [NULL_EXCLUSION] access [protected] function 4068 -- PARAMETER_AND_RESULT_PROFILE 4069 4070 -- The caller has parsed the null-exclusion part and it has also checked 4071 -- that the next token is ACCESS 4072 4073 -- Error recovery: cannot raise Error_Resync 4074 4075 function P_Access_Definition 4076 (Null_Exclusion_Present : Boolean) return Node_Id 4077 is 4078 Def_Node : Node_Id; 4079 Subp_Node : Node_Id; 4080 4081 begin 4082 Def_Node := New_Node (N_Access_Definition, Token_Ptr); 4083 Scan; -- past ACCESS 4084 4085 -- Ada 2005 (AI-254): Access_To_Subprogram_Definition 4086 4087 if Token = Tok_Protected 4088 or else Token = Tok_Procedure 4089 or else Token = Tok_Function 4090 then 4091 if Ada_Version < Ada_2005 then 4092 Error_Msg_SP ("access-to-subprogram is an Ada 2005 extension"); 4093 Error_Msg_SP ("\unit should be compiled with -gnat05 switch"); 4094 end if; 4095 4096 Subp_Node := P_Access_Type_Definition (Header_Already_Parsed => True); 4097 Set_Null_Exclusion_Present (Subp_Node, Null_Exclusion_Present); 4098 Set_Access_To_Subprogram_Definition (Def_Node, Subp_Node); 4099 4100 -- Ada 2005 (AI-231) 4101 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK 4102 4103 else 4104 Set_Null_Exclusion_Present (Def_Node, Null_Exclusion_Present); 4105 4106 if Token = Tok_All then 4107 if Ada_Version < Ada_2005 then 4108 Error_Msg_SP 4109 ("ALL is not permitted for anonymous access types"); 4110 end if; 4111 4112 Scan; -- past ALL 4113 Set_All_Present (Def_Node); 4114 4115 elsif Token = Tok_Constant then 4116 if Ada_Version < Ada_2005 then 4117 Error_Msg_SP ("access-to-constant is an Ada 2005 extension"); 4118 Error_Msg_SP ("\unit should be compiled with -gnat05 switch"); 4119 end if; 4120 4121 Scan; -- past CONSTANT 4122 Set_Constant_Present (Def_Node); 4123 end if; 4124 4125 Set_Subtype_Mark (Def_Node, P_Subtype_Mark); 4126 No_Constraint; 4127 end if; 4128 4129 return Def_Node; 4130 end P_Access_Definition; 4131 4132 ----------------------------------------- 4133 -- 3.10.1 Incomplete Type Declaration -- 4134 ----------------------------------------- 4135 4136 -- Parsed by P_Type_Declaration (3.2.1) 4137 4138 ---------------------------- 4139 -- 3.11 Declarative Part -- 4140 ---------------------------- 4141 4142 -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM} 4143 4144 -- Error recovery: cannot raise Error_Resync (because P_Declarative_Items 4145 -- handles errors, and returns cleanly after an error has occurred) 4146 4147 function P_Declarative_Part return List_Id is 4148 Decls : List_Id; 4149 Done : Boolean; 4150 4151 begin 4152 -- Indicate no bad declarations detected yet. This will be reset by 4153 -- P_Declarative_Items if a bad declaration is discovered. 4154 4155 Missing_Begin_Msg := No_Error_Msg; 4156 4157 -- Get rid of active SIS entry from outer scope. This means we will 4158 -- miss some nested cases, but it doesn't seem worth the effort. See 4159 -- discussion in Par for further details 4160 4161 SIS_Entry_Active := False; 4162 Decls := New_List; 4163 4164 -- Loop to scan out the declarations 4165 4166 loop 4167 P_Declarative_Items (Decls, Done, In_Spec => False); 4168 exit when Done; 4169 end loop; 4170 4171 -- Get rid of active SIS entry which is left set only if we scanned a 4172 -- procedure declaration and have not found the body. We could give 4173 -- an error message, but that really would be usurping the role of 4174 -- semantic analysis (this really is a missing body case). 4175 4176 SIS_Entry_Active := False; 4177 return Decls; 4178 end P_Declarative_Part; 4179 4180 ---------------------------- 4181 -- 3.11 Declarative Item -- 4182 ---------------------------- 4183 4184 -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY 4185 4186 -- Can return Error if a junk declaration is found, or Empty if no 4187 -- declaration is found (i.e. a token ending declarations, such as 4188 -- BEGIN or END is encountered). 4189 4190 -- Error recovery: cannot raise Error_Resync. If an error resync occurs, 4191 -- then the scan is set past the next semicolon and Error is returned. 4192 4193 procedure P_Declarative_Items 4194 (Decls : List_Id; 4195 Done : out Boolean; 4196 In_Spec : Boolean) 4197 is 4198 Scan_State : Saved_Scan_State; 4199 4200 begin 4201 if Style_Check then 4202 Style.Check_Indentation; 4203 end if; 4204 4205 case Token is 4206 4207 when Tok_Function => 4208 Check_Bad_Layout; 4209 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); 4210 Done := False; 4211 4212 when Tok_For => 4213 Check_Bad_Layout; 4214 4215 -- Check for loop (premature statement) 4216 4217 Save_Scan_State (Scan_State); 4218 Scan; -- past FOR 4219 4220 if Token = Tok_Identifier then 4221 Scan; -- past identifier 4222 4223 if Token = Tok_In then 4224 Restore_Scan_State (Scan_State); 4225 Statement_When_Declaration_Expected (Decls, Done, In_Spec); 4226 return; 4227 end if; 4228 end if; 4229 4230 -- Not a loop, so must be rep clause 4231 4232 Restore_Scan_State (Scan_State); 4233 Append (P_Representation_Clause, Decls); 4234 Done := False; 4235 4236 when Tok_Generic => 4237 Check_Bad_Layout; 4238 Append (P_Generic, Decls); 4239 Done := False; 4240 4241 when Tok_Identifier => 4242 Check_Bad_Layout; 4243 4244 -- Special check for misuse of overriding not in Ada 2005 mode 4245 4246 if Token_Name = Name_Overriding 4247 and then not Next_Token_Is (Tok_Colon) 4248 then 4249 Error_Msg_SC ("overriding indicator is an Ada 2005 extension"); 4250 Error_Msg_SC ("\unit must be compiled with -gnat05 switch"); 4251 4252 Token := Tok_Overriding; 4253 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); 4254 Done := False; 4255 4256 -- Normal case, no overriding, or overriding followed by colon 4257 4258 else 4259 P_Identifier_Declarations (Decls, Done, In_Spec); 4260 end if; 4261 4262 -- Ada 2005: A subprogram declaration can start with "not" or 4263 -- "overriding". In older versions, "overriding" is handled 4264 -- like an identifier, with the appropriate messages. 4265 4266 when Tok_Not => 4267 Check_Bad_Layout; 4268 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); 4269 Done := False; 4270 4271 when Tok_Overriding => 4272 Check_Bad_Layout; 4273 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); 4274 Done := False; 4275 4276 when Tok_Package => 4277 Check_Bad_Layout; 4278 Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); 4279 Done := False; 4280 4281 when Tok_Pragma => 4282 Append (P_Pragma, Decls); 4283 Done := False; 4284 4285 when Tok_Procedure => 4286 Check_Bad_Layout; 4287 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); 4288 Done := False; 4289 4290 when Tok_Protected => 4291 Check_Bad_Layout; 4292 Scan; -- past PROTECTED 4293 Append (P_Protected, Decls); 4294 Done := False; 4295 4296 when Tok_Subtype => 4297 Check_Bad_Layout; 4298 Append (P_Subtype_Declaration, Decls); 4299 Done := False; 4300 4301 when Tok_Task => 4302 Check_Bad_Layout; 4303 Scan; -- past TASK 4304 Append (P_Task, Decls); 4305 Done := False; 4306 4307 when Tok_Type => 4308 Check_Bad_Layout; 4309 Append (P_Type_Declaration, Decls); 4310 Done := False; 4311 4312 when Tok_Use => 4313 Check_Bad_Layout; 4314 Append (P_Use_Clause, Decls); 4315 Done := False; 4316 4317 when Tok_With => 4318 Check_Bad_Layout; 4319 4320 if Aspect_Specifications_Present then 4321 4322 -- If we are after a semicolon, complain that it was ignored. 4323 -- But we don't really ignore it, since we dump the aspects, 4324 -- so we make the error message a normal fatal message which 4325 -- will inhibit semantic analysis anyway). 4326 4327 if Prev_Token = Tok_Semicolon then 4328 Error_Msg_SP -- CODEFIX 4329 ("extra "";"" ignored"); 4330 4331 -- If not just past semicolon, just complain that aspects are 4332 -- not allowed at this point. 4333 4334 else 4335 Error_Msg_SC ("aspect specifications not allowed here"); 4336 end if; 4337 4338 declare 4339 Dummy_Node : constant Node_Id := 4340 New_Node (N_Package_Specification, Token_Ptr); 4341 pragma Warnings (Off, Dummy_Node); 4342 -- Dummy node to attach aspect specifications to. We will 4343 -- then throw them away. 4344 4345 begin 4346 P_Aspect_Specifications (Dummy_Node, Semicolon => True); 4347 end; 4348 4349 -- Here if not aspect specifications case 4350 4351 else 4352 Error_Msg_SC ("WITH can only appear in context clause"); 4353 raise Error_Resync; 4354 end if; 4355 4356 -- BEGIN terminates the scan of a sequence of declarations unless 4357 -- there is a missing subprogram body, see section on handling 4358 -- semicolon in place of IS. We only treat the begin as satisfying 4359 -- the subprogram declaration if it falls in the expected column 4360 -- or to its right. 4361 4362 when Tok_Begin => 4363 if SIS_Entry_Active and then Start_Column >= SIS_Ecol then 4364 4365 -- Here we have the case where a BEGIN is encountered during 4366 -- declarations in a declarative part, or at the outer level, 4367 -- and there is a subprogram declaration outstanding for which 4368 -- no body has been supplied. This is the case where we assume 4369 -- that the semicolon in the subprogram declaration should 4370 -- really have been is. The active SIS entry describes the 4371 -- subprogram declaration. On return the declaration has been 4372 -- modified to become a body. 4373 4374 declare 4375 Specification_Node : Node_Id; 4376 Decl_Node : Node_Id; 4377 Body_Node : Node_Id; 4378 4379 begin 4380 -- First issue the error message. If we had a missing 4381 -- semicolon in the declaration, then change the message 4382 -- to <missing "is"> 4383 4384 if SIS_Missing_Semicolon_Message /= No_Error_Msg then 4385 Change_Error_Text -- Replace: "missing "";"" " 4386 (SIS_Missing_Semicolon_Message, "missing ""is"""); 4387 4388 -- Otherwise we saved the semicolon position, so complain 4389 4390 else 4391 Error_Msg -- CODEFIX 4392 ("|"";"" should be IS", SIS_Semicolon_Sloc); 4393 end if; 4394 4395 -- The next job is to fix up any declarations that occurred 4396 -- between the procedure header and the BEGIN. These got 4397 -- chained to the outer declarative region (immediately 4398 -- after the procedure declaration) and they should be 4399 -- chained to the subprogram itself, which is a body 4400 -- rather than a spec. 4401 4402 Specification_Node := Specification (SIS_Declaration_Node); 4403 Change_Node (SIS_Declaration_Node, N_Subprogram_Body); 4404 Body_Node := SIS_Declaration_Node; 4405 Set_Specification (Body_Node, Specification_Node); 4406 Set_Declarations (Body_Node, New_List); 4407 4408 loop 4409 Decl_Node := Remove_Next (Body_Node); 4410 exit when Decl_Node = Empty; 4411 Append (Decl_Node, Declarations (Body_Node)); 4412 end loop; 4413 4414 -- Now make the scope table entry for the Begin-End and 4415 -- scan it out 4416 4417 Push_Scope_Stack; 4418 Scope.Table (Scope.Last).Sloc := SIS_Sloc; 4419 Scope.Table (Scope.Last).Etyp := E_Name; 4420 Scope.Table (Scope.Last).Ecol := SIS_Ecol; 4421 Scope.Table (Scope.Last).Labl := SIS_Labl; 4422 Scope.Table (Scope.Last).Lreq := False; 4423 SIS_Entry_Active := False; 4424 Scan; -- past BEGIN 4425 Set_Handled_Statement_Sequence (Body_Node, 4426 P_Handled_Sequence_Of_Statements); 4427 End_Statements (Handled_Statement_Sequence (Body_Node)); 4428 end; 4429 4430 Done := False; 4431 4432 else 4433 Done := True; 4434 end if; 4435 4436 -- Normally an END terminates the scan for basic declarative items. 4437 -- The one exception is END RECORD, which is probably left over from 4438 -- some other junk. 4439 4440 when Tok_End => 4441 Save_Scan_State (Scan_State); -- at END 4442 Scan; -- past END 4443 4444 if Token = Tok_Record then 4445 Error_Msg_SP ("no RECORD for this `end record`!"); 4446 Scan; -- past RECORD 4447 TF_Semicolon; 4448 4449 else 4450 Restore_Scan_State (Scan_State); -- to END 4451 Done := True; 4452 end if; 4453 4454 -- The following tokens which can only be the start of a statement 4455 -- are considered to end a declarative part (i.e. we have a missing 4456 -- BEGIN situation). We are fairly conservative in making this 4457 -- judgment, because it is a real mess to go into statement mode 4458 -- prematurely in response to a junk declaration. 4459 4460 when Tok_Abort | 4461 Tok_Accept | 4462 Tok_Declare | 4463 Tok_Delay | 4464 Tok_Exit | 4465 Tok_Goto | 4466 Tok_If | 4467 Tok_Loop | 4468 Tok_Null | 4469 Tok_Requeue | 4470 Tok_Select | 4471 Tok_While => 4472 4473 -- But before we decide that it's a statement, let's check for 4474 -- a reserved word misused as an identifier. 4475 4476 if Is_Reserved_Identifier then 4477 Save_Scan_State (Scan_State); 4478 Scan; -- past the token 4479 4480 -- If reserved identifier not followed by colon or comma, then 4481 -- this is most likely an assignment statement to the bad id. 4482 4483 if Token /= Tok_Colon and then Token /= Tok_Comma then 4484 Restore_Scan_State (Scan_State); 4485 Statement_When_Declaration_Expected (Decls, Done, In_Spec); 4486 return; 4487 4488 -- Otherwise we have a declaration of the bad id 4489 4490 else 4491 Restore_Scan_State (Scan_State); 4492 Scan_Reserved_Identifier (Force_Msg => True); 4493 P_Identifier_Declarations (Decls, Done, In_Spec); 4494 end if; 4495 4496 -- If not reserved identifier, then it's definitely a statement 4497 4498 else 4499 Statement_When_Declaration_Expected (Decls, Done, In_Spec); 4500 return; 4501 end if; 4502 4503 -- The token RETURN may well also signal a missing BEGIN situation, 4504 -- however, we never let it end the declarative part, because it may 4505 -- also be part of a half-baked function declaration. 4506 4507 when Tok_Return => 4508 Error_Msg_SC ("misplaced RETURN statement"); 4509 raise Error_Resync; 4510 4511 -- PRIVATE definitely terminates the declarations in a spec, 4512 -- and is an error in a body. 4513 4514 when Tok_Private => 4515 if In_Spec then 4516 Done := True; 4517 else 4518 Error_Msg_SC ("PRIVATE not allowed in body"); 4519 Scan; -- past PRIVATE 4520 end if; 4521 4522 -- An end of file definitely terminates the declarations 4523 4524 when Tok_EOF => 4525 Done := True; 4526 4527 -- The remaining tokens do not end the scan, but cannot start a 4528 -- valid declaration, so we signal an error and resynchronize. 4529 -- But first check for misuse of a reserved identifier. 4530 4531 when others => 4532 4533 -- Here we check for a reserved identifier 4534 4535 if Is_Reserved_Identifier then 4536 Save_Scan_State (Scan_State); 4537 Scan; -- past the token 4538 4539 if Token /= Tok_Colon and then Token /= Tok_Comma then 4540 Restore_Scan_State (Scan_State); 4541 Set_Declaration_Expected; 4542 raise Error_Resync; 4543 else 4544 Restore_Scan_State (Scan_State); 4545 Scan_Reserved_Identifier (Force_Msg => True); 4546 Check_Bad_Layout; 4547 P_Identifier_Declarations (Decls, Done, In_Spec); 4548 end if; 4549 4550 else 4551 Set_Declaration_Expected; 4552 raise Error_Resync; 4553 end if; 4554 end case; 4555 4556 -- To resynchronize after an error, we scan to the next semicolon and 4557 -- return with Done = False, indicating that there may still be more 4558 -- valid declarations to come. 4559 4560 exception 4561 when Error_Resync => 4562 Resync_Past_Semicolon; 4563 Done := False; 4564 end P_Declarative_Items; 4565 4566 ---------------------------------- 4567 -- 3.11 Basic Declarative Item -- 4568 ---------------------------------- 4569 4570 -- BASIC_DECLARATIVE_ITEM ::= 4571 -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE 4572 4573 -- Scan zero or more basic declarative items 4574 4575 -- Error recovery: cannot raise Error_Resync. If an error is detected, then 4576 -- the scan pointer is repositioned past the next semicolon, and the scan 4577 -- for declarative items continues. 4578 4579 function P_Basic_Declarative_Items return List_Id is 4580 Decl : Node_Id; 4581 Decls : List_Id; 4582 Kind : Node_Kind; 4583 Done : Boolean; 4584 4585 begin 4586 -- Indicate no bad declarations detected yet in the current context: 4587 -- visible or private declarations of a package spec. 4588 4589 Missing_Begin_Msg := No_Error_Msg; 4590 4591 -- Get rid of active SIS entry from outer scope. This means we will 4592 -- miss some nested cases, but it doesn't seem worth the effort. See 4593 -- discussion in Par for further details 4594 4595 SIS_Entry_Active := False; 4596 4597 -- Loop to scan out declarations 4598 4599 Decls := New_List; 4600 4601 loop 4602 P_Declarative_Items (Decls, Done, In_Spec => True); 4603 exit when Done; 4604 end loop; 4605 4606 -- Get rid of active SIS entry. This is set only if we have scanned a 4607 -- procedure declaration and have not found the body. We could give 4608 -- an error message, but that really would be usurping the role of 4609 -- semantic analysis (this really is a case of a missing body). 4610 4611 SIS_Entry_Active := False; 4612 4613 -- Test for assorted illegal declarations not diagnosed elsewhere 4614 4615 Decl := First (Decls); 4616 4617 while Present (Decl) loop 4618 Kind := Nkind (Decl); 4619 4620 -- Test for body scanned, not acceptable as basic decl item 4621 4622 if Kind = N_Subprogram_Body or else 4623 Kind = N_Package_Body or else 4624 Kind = N_Task_Body or else 4625 Kind = N_Protected_Body 4626 then 4627 Error_Msg ("proper body not allowed in package spec", Sloc (Decl)); 4628 4629 -- Complete declaration of mangled subprogram body, for better 4630 -- recovery if analysis is attempted. 4631 4632 if Nkind_In (Decl, N_Subprogram_Body, N_Package_Body, N_Task_Body) 4633 and then No (Handled_Statement_Sequence (Decl)) 4634 then 4635 Set_Handled_Statement_Sequence (Decl, 4636 Make_Handled_Sequence_Of_Statements (Sloc (Decl), 4637 Statements => New_List)); 4638 end if; 4639 4640 -- Test for body stub scanned, not acceptable as basic decl item 4641 4642 elsif Kind in N_Body_Stub then 4643 Error_Msg ("body stub not allowed in package spec", Sloc (Decl)); 4644 4645 elsif Kind = N_Assignment_Statement then 4646 Error_Msg 4647 ("assignment statement not allowed in package spec", 4648 Sloc (Decl)); 4649 end if; 4650 4651 Next (Decl); 4652 end loop; 4653 4654 return Decls; 4655 end P_Basic_Declarative_Items; 4656 4657 ---------------- 4658 -- 3.11 Body -- 4659 ---------------- 4660 4661 -- For proper body, see below 4662 -- For body stub, see 10.1.3 4663 4664 ----------------------- 4665 -- 3.11 Proper Body -- 4666 ----------------------- 4667 4668 -- Subprogram body is parsed by P_Subprogram (6.1) 4669 -- Package body is parsed by P_Package (7.1) 4670 -- Task body is parsed by P_Task (9.1) 4671 -- Protected body is parsed by P_Protected (9.4) 4672 4673 ------------------------------ 4674 -- Set_Declaration_Expected -- 4675 ------------------------------ 4676 4677 procedure Set_Declaration_Expected is 4678 begin 4679 Error_Msg_SC ("declaration expected"); 4680 4681 if Missing_Begin_Msg = No_Error_Msg then 4682 Missing_Begin_Msg := Get_Msg_Id; 4683 end if; 4684 end Set_Declaration_Expected; 4685 4686 ---------------------- 4687 -- Skip_Declaration -- 4688 ---------------------- 4689 4690 procedure Skip_Declaration (S : List_Id) is 4691 Dummy_Done : Boolean; 4692 pragma Warnings (Off, Dummy_Done); 4693 begin 4694 P_Declarative_Items (S, Dummy_Done, False); 4695 end Skip_Declaration; 4696 4697 ----------------------------------------- 4698 -- Statement_When_Declaration_Expected -- 4699 ----------------------------------------- 4700 4701 procedure Statement_When_Declaration_Expected 4702 (Decls : List_Id; 4703 Done : out Boolean; 4704 In_Spec : Boolean) 4705 is 4706 begin 4707 -- Case of second occurrence of statement in one declaration sequence 4708 4709 if Missing_Begin_Msg /= No_Error_Msg then 4710 4711 -- In the procedure spec case, just ignore it, we only give one 4712 -- message for the first occurrence, since otherwise we may get 4713 -- horrible cascading if BODY was missing in the header line. 4714 4715 if In_Spec then 4716 null; 4717 4718 -- In the declarative part case, take a second statement as a sure 4719 -- sign that we really have a missing BEGIN, and end the declarative 4720 -- part now. Note that the caller will fix up the first message to 4721 -- say "missing BEGIN" so that's how the error will be signalled. 4722 4723 else 4724 Done := True; 4725 return; 4726 end if; 4727 4728 -- Case of first occurrence of unexpected statement 4729 4730 else 4731 -- If we are in a package spec, then give message of statement 4732 -- not allowed in package spec. This message never gets changed. 4733 4734 if In_Spec then 4735 Error_Msg_SC ("statement not allowed in package spec"); 4736 4737 -- If in declarative part, then we give the message complaining 4738 -- about finding a statement when a declaration is expected. This 4739 -- gets changed to a complaint about a missing BEGIN if we later 4740 -- find that no BEGIN is present. 4741 4742 else 4743 Error_Msg_SC ("statement not allowed in declarative part"); 4744 end if; 4745 4746 -- Capture message Id. This is used for two purposes, first to 4747 -- stop multiple messages, see test above, and second, to allow 4748 -- the replacement of the message in the declarative part case. 4749 4750 Missing_Begin_Msg := Get_Msg_Id; 4751 end if; 4752 4753 -- In all cases except the case in which we decided to terminate the 4754 -- declaration sequence on a second error, we scan out the statement 4755 -- and append it to the list of declarations (note that the semantics 4756 -- can handle statements in a declaration list so if we proceed to 4757 -- call the semantic phase, all will be (reasonably) well. 4758 4759 Append_List_To (Decls, P_Sequence_Of_Statements (SS_Unco)); 4760 4761 -- Done is set to False, since we want to continue the scan of 4762 -- declarations, hoping that this statement was a temporary glitch. 4763 -- If we indeed are now in the statement part (i.e. this was a missing 4764 -- BEGIN, then it's not terrible, we will simply keep calling this 4765 -- procedure to process the statements one by one, and then finally 4766 -- hit the missing BEGIN, which will clean up the error message. 4767 4768 Done := False; 4769 end Statement_When_Declaration_Expected; 4770 4771end Ch3; 4772