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