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 3034 -- Catch ouf-of-order keywords 3035 3036 elsif Token = Tok_Constant then 3037 Scan; 3038 3039 if Token = Tok_Access then 3040 Error_Msg_SC ("CONSTANT must appear after ACCESS"); 3041 Set_Discriminant_Type 3042 (Specification_Node, 3043 P_Access_Definition (Not_Null_Present)); 3044 3045 else 3046 Error_Msg_SC ("misplaced CONSTANT"); 3047 end if; 3048 3049 else 3050 Set_Discriminant_Type 3051 (Specification_Node, P_Subtype_Mark); 3052 No_Constraint; 3053 Set_Null_Exclusion_Present -- Ada 2005 (AI-231) 3054 (Specification_Node, Not_Null_Present); 3055 end if; 3056 3057 Set_Expression 3058 (Specification_Node, Init_Expr_Opt (True)); 3059 3060 if Ident > 1 then 3061 Set_Prev_Ids (Specification_Node, True); 3062 end if; 3063 3064 if Ident < Num_Idents then 3065 Set_More_Ids (Specification_Node, True); 3066 end if; 3067 3068 Append (Specification_Node, Specification_List); 3069 exit Ident_Loop when Ident = Num_Idents; 3070 Ident := Ident + 1; 3071 Restore_Scan_State (Scan_State); 3072 T_Colon; 3073 end loop Ident_Loop; 3074 3075 exit Specification_Loop when Token /= Tok_Semicolon; 3076 Scan; -- past ; 3077 P_Pragmas_Misplaced; 3078 end loop Specification_Loop; 3079 3080 T_Right_Paren; 3081 return Specification_List; 3082 3083 else 3084 return No_List; 3085 end if; 3086 end P_Known_Discriminant_Part_Opt; 3087 3088 ------------------------------------- 3089 -- 3.7 Discriminant Specification -- 3090 ------------------------------------- 3091 3092 -- Parsed by P_Known_Discriminant_Part_Opt (3.7) 3093 3094 ----------------------------- 3095 -- 3.7 Default Expression -- 3096 ----------------------------- 3097 3098 -- Always parsed (simply as an Expression) by the parent construct 3099 3100 ------------------------------------ 3101 -- 3.7.1 Discriminant Constraint -- 3102 ------------------------------------ 3103 3104 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1) 3105 3106 -------------------------------------------------------- 3107 -- 3.7.1 Index or Discriminant Constraint (also 3.6) -- 3108 -------------------------------------------------------- 3109 3110 -- DISCRIMINANT_CONSTRAINT ::= 3111 -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION}) 3112 3113 -- DISCRIMINANT_ASSOCIATION ::= 3114 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>] 3115 -- EXPRESSION 3116 3117 -- This routine parses either an index or a discriminant constraint. As 3118 -- is clear from the above grammar, it is often possible to clearly 3119 -- determine which of the two possibilities we have, but there are 3120 -- cases (those in which we have a series of expressions of the same 3121 -- syntactic form as subtype indications), where we cannot tell. Since 3122 -- this means that in any case the semantic phase has to distinguish 3123 -- between the two, there is not much point in the parser trying to 3124 -- distinguish even those cases where the difference is clear. In any 3125 -- case, if we have a situation like: 3126 3127 -- (A => 123, 235 .. 500) 3128 3129 -- it is not clear which of the two items is the wrong one, better to 3130 -- let the semantic phase give a clear message. Consequently, this 3131 -- routine in general returns a list of items which can be either 3132 -- discrete ranges or discriminant associations. 3133 3134 -- The caller has checked that the initial token is a left paren 3135 3136 -- Error recovery: can raise Error_Resync 3137 3138 function P_Index_Or_Discriminant_Constraint return Node_Id is 3139 Scan_State : Saved_Scan_State; 3140 Constr_Node : Node_Id; 3141 Constr_List : List_Id; 3142 Expr_Node : Node_Id; 3143 Result_Node : Node_Id; 3144 3145 begin 3146 Result_Node := New_Node (N_Index_Or_Discriminant_Constraint, Token_Ptr); 3147 Scan; -- past ( 3148 Constr_List := New_List; 3149 Set_Constraints (Result_Node, Constr_List); 3150 3151 -- The two syntactic forms are a little mixed up, so what we are doing 3152 -- here is looking at the first entry to determine which case we have 3153 3154 -- A discriminant constraint is a list of discriminant associations, 3155 -- which have one of the following possible forms: 3156 3157 -- Expression 3158 -- Id => Expression 3159 -- Id | Id | .. | Id => Expression 3160 3161 -- An index constraint is a list of discrete ranges which have one 3162 -- of the following possible forms: 3163 3164 -- Subtype_Mark 3165 -- Subtype_Mark range Range 3166 -- Range_Attribute 3167 -- Simple_Expression .. Simple_Expression 3168 3169 -- Loop through discriminants in list 3170 3171 loop 3172 -- Check cases of Id => Expression or Id | Id => Expression 3173 3174 if Token = Tok_Identifier then 3175 Save_Scan_State (Scan_State); -- at Id 3176 Scan; -- past Id 3177 3178 if Token = Tok_Arrow or else Token = Tok_Vertical_Bar then 3179 Restore_Scan_State (Scan_State); -- to Id 3180 Append (P_Discriminant_Association, Constr_List); 3181 goto Loop_Continue; 3182 else 3183 Restore_Scan_State (Scan_State); -- to Id 3184 end if; 3185 end if; 3186 3187 -- Otherwise scan out an expression and see what we have got 3188 3189 Expr_Node := P_Expression_Or_Range_Attribute; 3190 3191 if Expr_Form = EF_Range_Attr then 3192 Append (Expr_Node, Constr_List); 3193 3194 elsif Token = Tok_Range then 3195 if Expr_Form /= EF_Simple_Name then 3196 Error_Msg_SC ("subtype mark required before RANGE"); 3197 end if; 3198 3199 Append (P_Subtype_Indication (Expr_Node), Constr_List); 3200 goto Loop_Continue; 3201 3202 -- Check Simple_Expression .. Simple_Expression case 3203 3204 elsif Token = Tok_Dot_Dot then 3205 Check_Simple_Expression (Expr_Node); 3206 Constr_Node := New_Node (N_Range, Token_Ptr); 3207 Set_Low_Bound (Constr_Node, Expr_Node); 3208 Scan; -- past .. 3209 Expr_Node := P_Expression; 3210 Check_Simple_Expression (Expr_Node); 3211 Set_High_Bound (Constr_Node, Expr_Node); 3212 Append (Constr_Node, Constr_List); 3213 goto Loop_Continue; 3214 3215 -- Case of an expression which could be either form 3216 3217 else 3218 Append (Expr_Node, Constr_List); 3219 goto Loop_Continue; 3220 end if; 3221 3222 -- Here with a single entry scanned 3223 3224 <<Loop_Continue>> 3225 exit when not Comma_Present; 3226 3227 end loop; 3228 3229 T_Right_Paren; 3230 return Result_Node; 3231 end P_Index_Or_Discriminant_Constraint; 3232 3233 ------------------------------------- 3234 -- 3.7.1 Discriminant Association -- 3235 ------------------------------------- 3236 3237 -- DISCRIMINANT_ASSOCIATION ::= 3238 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>] 3239 -- EXPRESSION 3240 3241 -- This routine is used only when the name list is present and the caller 3242 -- has already checked this (by scanning ahead and repositioning the 3243 -- scan). 3244 3245 -- Error_Recovery: cannot raise Error_Resync; 3246 3247 function P_Discriminant_Association return Node_Id is 3248 Discr_Node : Node_Id; 3249 Names_List : List_Id; 3250 Ident_Sloc : Source_Ptr; 3251 3252 begin 3253 Ident_Sloc := Token_Ptr; 3254 Names_List := New_List; 3255 3256 loop 3257 Append (P_Identifier (C_Vertical_Bar_Arrow), Names_List); 3258 exit when Token /= Tok_Vertical_Bar; 3259 Scan; -- past | 3260 end loop; 3261 3262 Discr_Node := New_Node (N_Discriminant_Association, Ident_Sloc); 3263 Set_Selector_Names (Discr_Node, Names_List); 3264 TF_Arrow; 3265 Set_Expression (Discr_Node, P_Expression); 3266 return Discr_Node; 3267 end P_Discriminant_Association; 3268 3269 --------------------------------- 3270 -- 3.8 Record Type Definition -- 3271 --------------------------------- 3272 3273 -- RECORD_TYPE_DEFINITION ::= 3274 -- [[abstract] tagged] [limited] RECORD_DEFINITION 3275 3276 -- There is no node in the tree for a record type definition. Instead 3277 -- a record definition node appears, with possible Abstract_Present, 3278 -- Tagged_Present, and Limited_Present flags set appropriately. 3279 3280 ---------------------------- 3281 -- 3.8 Record Definition -- 3282 ---------------------------- 3283 3284 -- RECORD_DEFINITION ::= 3285 -- record 3286 -- COMPONENT_LIST 3287 -- end record 3288 -- | null record 3289 3290 -- Note: in the case where a record definition node is used to represent 3291 -- a record type definition, the caller sets the Tagged_Present and 3292 -- Limited_Present flags in the resulting N_Record_Definition node as 3293 -- required. 3294 3295 -- Note that the RECORD token at the start may be missing in certain 3296 -- error situations, so this function is expected to post the error 3297 3298 -- Error recovery: can raise Error_Resync 3299 3300 function P_Record_Definition return Node_Id is 3301 Rec_Node : Node_Id; 3302 3303 begin 3304 Inside_Record_Definition := True; 3305 Rec_Node := New_Node (N_Record_Definition, Token_Ptr); 3306 3307 -- Null record case 3308 3309 if Token = Tok_Null then 3310 Scan; -- past NULL 3311 T_Record; 3312 Set_Null_Present (Rec_Node, True); 3313 3314 -- Catch incomplete declaration to prevent cascaded errors, see 3315 -- ACATS B393002 for an example. 3316 3317 elsif Token = Tok_Semicolon then 3318 Error_Msg_AP ("missing record definition"); 3319 3320 -- Case starting with RECORD keyword. Build scope stack entry. For the 3321 -- column, we use the first non-blank character on the line, to deal 3322 -- with situations such as: 3323 3324 -- type X is record 3325 -- ... 3326 -- end record; 3327 3328 -- which is not official RM indentation, but is not uncommon usage, and 3329 -- in particular is standard GNAT coding style, so handle it nicely. 3330 3331 else 3332 Push_Scope_Stack; 3333 Scope.Table (Scope.Last).Etyp := E_Record; 3334 Scope.Table (Scope.Last).Ecol := Start_Column; 3335 Scope.Table (Scope.Last).Sloc := Token_Ptr; 3336 Scope.Table (Scope.Last).Labl := Error; 3337 Scope.Table (Scope.Last).Junk := (Token /= Tok_Record); 3338 3339 T_Record; 3340 3341 Set_Component_List (Rec_Node, P_Component_List); 3342 3343 loop 3344 exit when Check_End; 3345 Discard_Junk_Node (P_Component_List); 3346 end loop; 3347 end if; 3348 3349 Inside_Record_Definition := False; 3350 return Rec_Node; 3351 end P_Record_Definition; 3352 3353 ------------------------- 3354 -- 3.8 Component List -- 3355 ------------------------- 3356 3357 -- COMPONENT_LIST ::= 3358 -- COMPONENT_ITEM {COMPONENT_ITEM} 3359 -- | {COMPONENT_ITEM} VARIANT_PART 3360 -- | null; 3361 3362 -- Error recovery: cannot raise Error_Resync 3363 3364 function P_Component_List return Node_Id is 3365 Component_List_Node : Node_Id; 3366 Decls_List : List_Id; 3367 Scan_State : Saved_Scan_State; 3368 Null_Loc : Source_Ptr; 3369 3370 begin 3371 Component_List_Node := New_Node (N_Component_List, Token_Ptr); 3372 Decls_List := New_List; 3373 3374 -- Handle null 3375 3376 if Token = Tok_Null then 3377 Null_Loc := Token_Ptr; 3378 Scan; -- past NULL 3379 TF_Semicolon; 3380 P_Pragmas_Opt (Decls_List); 3381 3382 -- If we have an END or WHEN now, everything is fine, otherwise we 3383 -- complain about the null, ignore it, and scan for more components. 3384 3385 if Token = Tok_End or else Token = Tok_When then 3386 Set_Null_Present (Component_List_Node, True); 3387 return Component_List_Node; 3388 else 3389 Error_Msg ("NULL component only allowed in null record", Null_Loc); 3390 end if; 3391 end if; 3392 3393 -- Scan components for non-null record 3394 3395 P_Pragmas_Opt (Decls_List); 3396 3397 if Token /= Tok_Case then 3398 Component_Scan_Loop : loop 3399 P_Component_Items (Decls_List); 3400 P_Pragmas_Opt (Decls_List); 3401 3402 exit Component_Scan_Loop when Token = Tok_End 3403 or else Token = Tok_Case 3404 or else Token = Tok_When; 3405 3406 -- We are done if we do not have an identifier. However, if we 3407 -- have a misspelled reserved identifier that is in a column to 3408 -- the right of the record definition, we will treat it as an 3409 -- identifier. It turns out to be too dangerous in practice to 3410 -- accept such a mis-spelled identifier which does not have this 3411 -- additional clue that confirms the incorrect spelling. 3412 3413 if Token /= Tok_Identifier then 3414 if Start_Column > Scope.Table (Scope.Last).Ecol 3415 and then Is_Reserved_Identifier 3416 then 3417 Save_Scan_State (Scan_State); -- at reserved id 3418 Scan; -- possible reserved id 3419 3420 if Token = Tok_Comma or else Token = Tok_Colon then 3421 Restore_Scan_State (Scan_State); 3422 Scan_Reserved_Identifier (Force_Msg => True); 3423 3424 -- Note reserved identifier used as field name after all 3425 -- because not followed by colon or comma. 3426 3427 else 3428 Restore_Scan_State (Scan_State); 3429 exit Component_Scan_Loop; 3430 end if; 3431 3432 -- Non-identifier that definitely was not reserved id 3433 3434 else 3435 exit Component_Scan_Loop; 3436 end if; 3437 end if; 3438 end loop Component_Scan_Loop; 3439 end if; 3440 3441 if Token = Tok_Case then 3442 Set_Variant_Part (Component_List_Node, P_Variant_Part); 3443 3444 -- Check for junk after variant part 3445 3446 if Token = Tok_Identifier then 3447 Save_Scan_State (Scan_State); 3448 Scan; -- past identifier 3449 3450 if Token = Tok_Colon then 3451 Restore_Scan_State (Scan_State); 3452 Error_Msg_SC ("component may not follow variant part"); 3453 Discard_Junk_Node (P_Component_List); 3454 3455 elsif Token = Tok_Case then 3456 Restore_Scan_State (Scan_State); 3457 Error_Msg_SC ("only one variant part allowed in a record"); 3458 Discard_Junk_Node (P_Component_List); 3459 3460 else 3461 Restore_Scan_State (Scan_State); 3462 end if; 3463 end if; 3464 end if; 3465 3466 Set_Component_Items (Component_List_Node, Decls_List); 3467 return Component_List_Node; 3468 end P_Component_List; 3469 3470 ------------------------- 3471 -- 3.8 Component Item -- 3472 ------------------------- 3473 3474 -- COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE 3475 3476 -- COMPONENT_DECLARATION ::= 3477 -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION 3478 -- [:= DEFAULT_EXPRESSION] 3479 -- [ASPECT_SPECIFICATIONS]; 3480 3481 -- COMPONENT_DEFINITION ::= 3482 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION 3483 3484 -- Error recovery: cannot raise Error_Resync, if an error occurs, 3485 -- the scan is positioned past the following semicolon. 3486 3487 -- Note: we do not yet allow representation clauses to appear as component 3488 -- items, do we need to add this capability sometime in the future ??? 3489 3490 procedure P_Component_Items (Decls : List_Id) is 3491 Aliased_Present : Boolean := False; 3492 CompDef_Node : Node_Id; 3493 Decl_Node : Node_Id; 3494 Scan_State : Saved_Scan_State; 3495 Not_Null_Present : Boolean := False; 3496 Num_Idents : Nat; 3497 Ident : Nat; 3498 Ident_Sloc : Source_Ptr; 3499 3500 Idents : array (Int range 1 .. 4096) of Entity_Id; 3501 -- This array holds the list of defining identifiers. The upper bound 3502 -- of 4096 is intended to be essentially infinite, and we do not even 3503 -- bother to check for it being exceeded. 3504 3505 begin 3506 if Token /= Tok_Identifier then 3507 Error_Msg_SC ("component declaration expected"); 3508 Resync_Past_Semicolon; 3509 return; 3510 end if; 3511 3512 Ident_Sloc := Token_Ptr; 3513 Check_Bad_Layout; 3514 Idents (1) := P_Defining_Identifier (C_Comma_Colon); 3515 Num_Idents := 1; 3516 3517 while Comma_Present loop 3518 Num_Idents := Num_Idents + 1; 3519 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon); 3520 end loop; 3521 3522 -- If there are multiple identifiers, we repeatedly scan the 3523 -- type and initialization expression information by resetting 3524 -- the scan pointer (so that we get completely separate trees 3525 -- for each occurrence). 3526 3527 if Num_Idents > 1 then 3528 Save_Scan_State (Scan_State); 3529 end if; 3530 3531 T_Colon; 3532 3533 -- Loop through defining identifiers in list 3534 3535 Ident := 1; 3536 Ident_Loop : loop 3537 3538 -- The following block is present to catch Error_Resync 3539 -- which causes the parse to be reset past the semicolon 3540 3541 begin 3542 Decl_Node := New_Node (N_Component_Declaration, Ident_Sloc); 3543 Set_Defining_Identifier (Decl_Node, Idents (Ident)); 3544 3545 if Token = Tok_Constant then 3546 Error_Msg_SC ("constant components are not permitted"); 3547 Scan; 3548 end if; 3549 3550 CompDef_Node := New_Node (N_Component_Definition, Token_Ptr); 3551 3552 if Token_Name = Name_Aliased then 3553 Check_95_Keyword (Tok_Aliased, Tok_Identifier); 3554 end if; 3555 3556 if Token = Tok_Aliased then 3557 Aliased_Present := True; 3558 Scan; -- past ALIASED 3559 end if; 3560 3561 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254) 3562 3563 -- Ada 2005 (AI-230): Access Definition case 3564 3565 if Token = Tok_Access then 3566 if Ada_Version < Ada_2005 then 3567 Error_Msg_SP 3568 ("generalized use of anonymous access types " & 3569 "is an Ada 2005 extension"); 3570 Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); 3571 end if; 3572 3573 -- AI95-406 makes "aliased" legal (and useless) here, so the 3574 -- following code which used to be required is commented out. 3575 3576 -- if Aliased_Present then 3577 -- Error_Msg_SP ("ALIASED not allowed here"); 3578 -- end if; 3579 3580 Set_Subtype_Indication (CompDef_Node, Empty); 3581 Set_Aliased_Present (CompDef_Node, False); 3582 Set_Access_Definition (CompDef_Node, 3583 P_Access_Definition (Not_Null_Present)); 3584 else 3585 3586 Set_Access_Definition (CompDef_Node, Empty); 3587 Set_Aliased_Present (CompDef_Node, Aliased_Present); 3588 Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present); 3589 3590 if Token = Tok_Array then 3591 Error_Msg_SC ("anonymous arrays not allowed as components"); 3592 raise Error_Resync; 3593 end if; 3594 3595 Set_Subtype_Indication (CompDef_Node, 3596 P_Subtype_Indication (Not_Null_Present)); 3597 end if; 3598 3599 Set_Component_Definition (Decl_Node, CompDef_Node); 3600 Set_Expression (Decl_Node, Init_Expr_Opt); 3601 3602 if Ident > 1 then 3603 Set_Prev_Ids (Decl_Node, True); 3604 end if; 3605 3606 if Ident < Num_Idents then 3607 Set_More_Ids (Decl_Node, True); 3608 end if; 3609 3610 Append (Decl_Node, Decls); 3611 3612 exception 3613 when Error_Resync => 3614 if Token /= Tok_End then 3615 Resync_Past_Semicolon; 3616 end if; 3617 end; 3618 3619 exit Ident_Loop when Ident = Num_Idents; 3620 Ident := Ident + 1; 3621 Restore_Scan_State (Scan_State); 3622 T_Colon; 3623 end loop Ident_Loop; 3624 3625 P_Aspect_Specifications (Decl_Node); 3626 end P_Component_Items; 3627 3628 -------------------------------- 3629 -- 3.8 Component Declaration -- 3630 -------------------------------- 3631 3632 -- Parsed by P_Component_Items (3.8) 3633 3634 ------------------------- 3635 -- 3.8.1 Variant Part -- 3636 ------------------------- 3637 3638 -- VARIANT_PART ::= 3639 -- case discriminant_DIRECT_NAME is 3640 -- VARIANT 3641 -- {VARIANT} 3642 -- end case; 3643 3644 -- The caller has checked that the initial token is CASE 3645 3646 -- Error recovery: cannot raise Error_Resync 3647 3648 function P_Variant_Part return Node_Id is 3649 Variant_Part_Node : Node_Id; 3650 Variants_List : List_Id; 3651 Case_Node : Node_Id; 3652 3653 begin 3654 Variant_Part_Node := New_Node (N_Variant_Part, Token_Ptr); 3655 Push_Scope_Stack; 3656 Scope.Table (Scope.Last).Etyp := E_Case; 3657 Scope.Table (Scope.Last).Sloc := Token_Ptr; 3658 Scope.Table (Scope.Last).Ecol := Start_Column; 3659 3660 Scan; -- past CASE 3661 Case_Node := P_Expression; 3662 Set_Name (Variant_Part_Node, Case_Node); 3663 3664 if Nkind (Case_Node) /= N_Identifier then 3665 Set_Name (Variant_Part_Node, Error); 3666 Error_Msg ("discriminant name expected", Sloc (Case_Node)); 3667 3668 elsif Paren_Count (Case_Node) /= 0 then 3669 Error_Msg 3670 ("|discriminant name may not be parenthesized", 3671 Sloc (Case_Node)); 3672 Set_Paren_Count (Case_Node, 0); 3673 end if; 3674 3675 TF_Is; 3676 Variants_List := New_List; 3677 P_Pragmas_Opt (Variants_List); 3678 3679 -- Test missing variant 3680 3681 if Token = Tok_End then 3682 Error_Msg_BC ("WHEN expected (must have at least one variant)"); 3683 else 3684 Append (P_Variant, Variants_List); 3685 end if; 3686 3687 -- Loop through variants, note that we allow if in place of when, 3688 -- this error will be detected and handled in P_Variant. 3689 3690 loop 3691 P_Pragmas_Opt (Variants_List); 3692 3693 if Token /= Tok_When 3694 and then Token /= Tok_If 3695 and then Token /= Tok_Others 3696 then 3697 exit when Check_End; 3698 end if; 3699 3700 Append (P_Variant, Variants_List); 3701 end loop; 3702 3703 Set_Variants (Variant_Part_Node, Variants_List); 3704 return Variant_Part_Node; 3705 end P_Variant_Part; 3706 3707 -------------------- 3708 -- 3.8.1 Variant -- 3709 -------------------- 3710 3711 -- VARIANT ::= 3712 -- when DISCRETE_CHOICE_LIST => 3713 -- COMPONENT_LIST 3714 3715 -- Error recovery: cannot raise Error_Resync 3716 3717 -- The initial token on entry is either WHEN, IF or OTHERS 3718 3719 function P_Variant return Node_Id is 3720 Variant_Node : Node_Id; 3721 3722 begin 3723 -- Special check to recover nicely from use of IF in place of WHEN 3724 3725 if Token = Tok_If then 3726 T_When; 3727 Scan; -- past IF 3728 else 3729 T_When; 3730 end if; 3731 3732 Variant_Node := New_Node (N_Variant, Prev_Token_Ptr); 3733 Set_Discrete_Choices (Variant_Node, P_Discrete_Choice_List); 3734 TF_Arrow; 3735 Set_Component_List (Variant_Node, P_Component_List); 3736 return Variant_Node; 3737 end P_Variant; 3738 3739 --------------------------------- 3740 -- 3.8.1 Discrete Choice List -- 3741 --------------------------------- 3742 3743 -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE} 3744 3745 -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others 3746 3747 -- Note: in Ada 83, the expression must be a simple expression 3748 3749 -- Error recovery: cannot raise Error_Resync 3750 3751 function P_Discrete_Choice_List return List_Id is 3752 Choices : List_Id; 3753 Expr_Node : Node_Id; 3754 Choice_Node : Node_Id; 3755 3756 begin 3757 Choices := New_List; 3758 loop 3759 if Token = Tok_Others then 3760 Append (New_Node (N_Others_Choice, Token_Ptr), Choices); 3761 Scan; -- past OTHERS 3762 3763 else 3764 begin 3765 -- Scan out expression or range attribute 3766 3767 Expr_Node := P_Expression_Or_Range_Attribute; 3768 Ignore (Tok_Right_Paren); 3769 3770 if Token = Tok_Colon 3771 and then Nkind (Expr_Node) = N_Identifier 3772 then 3773 Error_Msg_SP ("label not permitted in this context"); 3774 Scan; -- past colon 3775 3776 -- Range attribute 3777 3778 elsif Expr_Form = EF_Range_Attr then 3779 Append (Expr_Node, Choices); 3780 3781 -- Explicit range 3782 3783 elsif Token = Tok_Dot_Dot then 3784 Check_Simple_Expression (Expr_Node); 3785 Choice_Node := New_Node (N_Range, Token_Ptr); 3786 Set_Low_Bound (Choice_Node, Expr_Node); 3787 Scan; -- past .. 3788 Expr_Node := P_Expression_No_Right_Paren; 3789 Check_Simple_Expression (Expr_Node); 3790 Set_High_Bound (Choice_Node, Expr_Node); 3791 Append (Choice_Node, Choices); 3792 3793 -- Simple name, must be subtype, so range allowed 3794 3795 elsif Expr_Form = EF_Simple_Name then 3796 if Token = Tok_Range then 3797 Append (P_Subtype_Indication (Expr_Node), Choices); 3798 3799 elsif Token in Token_Class_Consk then 3800 Error_Msg_SC 3801 ("the only constraint allowed here " & 3802 "is a range constraint"); 3803 Discard_Junk_Node (P_Constraint_Opt); 3804 Append (Expr_Node, Choices); 3805 3806 else 3807 Append (Expr_Node, Choices); 3808 end if; 3809 3810 -- Expression 3811 3812 else 3813 -- In Ada 2012 mode, the expression must be a simple 3814 -- expression. The reason for this restriction (i.e. going 3815 -- back to the Ada 83 rule) is to avoid ambiguities when set 3816 -- membership operations are allowed, consider the 3817 -- following: 3818 3819 -- when A in 1 .. 10 | 12 => 3820 3821 -- This is ambiguous without parentheses, so we require one 3822 -- of the following two parenthesized forms to disambiguate: 3823 3824 -- one of the following: 3825 3826 -- when (A in 1 .. 10 | 12) => 3827 -- when (A in 1 .. 10) | 12 => 3828 3829 -- To solve this, in Ada 2012 mode, we disallow the use of 3830 -- membership operations in expressions in choices. 3831 3832 -- Technically in the grammar, the expression must match the 3833 -- grammar for restricted expression. 3834 3835 if Ada_Version >= Ada_2012 then 3836 Check_Restricted_Expression (Expr_Node); 3837 3838 -- In Ada 83 mode, the syntax required a simple expression 3839 3840 else 3841 Check_Simple_Expression_In_Ada_83 (Expr_Node); 3842 end if; 3843 3844 Append (Expr_Node, Choices); 3845 end if; 3846 3847 exception 3848 when Error_Resync => 3849 Resync_Choice; 3850 return Error_List; 3851 end; 3852 end if; 3853 3854 if Token = Tok_Comma then 3855 Scan; -- past comma 3856 3857 if Token = Tok_Vertical_Bar then 3858 Error_Msg_SP -- CODEFIX 3859 ("|extra "","" ignored"); 3860 Scan; -- past | 3861 3862 else 3863 Error_Msg_SP -- CODEFIX 3864 (""","" should be ""'|"""); 3865 end if; 3866 3867 else 3868 exit when Token /= Tok_Vertical_Bar; 3869 Scan; -- past | 3870 end if; 3871 3872 end loop; 3873 3874 return Choices; 3875 end P_Discrete_Choice_List; 3876 3877 ---------------------------- 3878 -- 3.8.1 Discrete Choice -- 3879 ---------------------------- 3880 3881 -- Parsed by P_Discrete_Choice_List (3.8.1) 3882 3883 ---------------------------------- 3884 -- 3.9.1 Record Extension Part -- 3885 ---------------------------------- 3886 3887 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION 3888 3889 -- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4) 3890 3891 -------------------------------------- 3892 -- 3.9.4 Interface Type Definition -- 3893 -------------------------------------- 3894 3895 -- INTERFACE_TYPE_DEFINITION ::= 3896 -- [limited | task | protected | synchronized] interface 3897 -- [and INTERFACE_LIST] 3898 3899 -- Error recovery: cannot raise Error_Resync 3900 3901 function P_Interface_Type_Definition 3902 (Abstract_Present : Boolean) return Node_Id 3903 is 3904 Typedef_Node : Node_Id; 3905 3906 begin 3907 if Ada_Version < Ada_2005 then 3908 Error_Msg_SP ("abstract interface is an Ada 2005 extension"); 3909 Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); 3910 end if; 3911 3912 if Abstract_Present then 3913 Error_Msg_SP 3914 ("ABSTRACT not allowed in interface type definition " & 3915 "(RM 3.9.4(2/2))"); 3916 end if; 3917 3918 Scan; -- past INTERFACE 3919 3920 -- Ada 2005 (AI-345): In case of interfaces with a null list of 3921 -- interfaces we build a record_definition node. 3922 3923 if Token = Tok_Semicolon or else Aspect_Specifications_Present then 3924 Typedef_Node := New_Node (N_Record_Definition, Token_Ptr); 3925 3926 Set_Abstract_Present (Typedef_Node); 3927 Set_Tagged_Present (Typedef_Node); 3928 Set_Null_Present (Typedef_Node); 3929 Set_Interface_Present (Typedef_Node); 3930 3931 -- Ada 2005 (AI-251): In case of not-synchronized interfaces that have 3932 -- a list of interfaces we build a derived_type_definition node. This 3933 -- simplifies the semantic analysis (and hence further maintenance) 3934 3935 else 3936 if Token /= Tok_And then 3937 Error_Msg_AP ("AND expected"); 3938 else 3939 Scan; -- past AND 3940 end if; 3941 3942 Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr); 3943 3944 Set_Abstract_Present (Typedef_Node); 3945 Set_Interface_Present (Typedef_Node); 3946 Set_Subtype_Indication (Typedef_Node, P_Qualified_Simple_Name); 3947 3948 Set_Record_Extension_Part (Typedef_Node, 3949 New_Node (N_Record_Definition, Token_Ptr)); 3950 Set_Null_Present (Record_Extension_Part (Typedef_Node)); 3951 3952 if Token = Tok_And then 3953 Set_Interface_List (Typedef_Node, New_List); 3954 Scan; -- past AND 3955 3956 loop 3957 Append (P_Qualified_Simple_Name, 3958 Interface_List (Typedef_Node)); 3959 exit when Token /= Tok_And; 3960 Scan; -- past AND 3961 end loop; 3962 end if; 3963 end if; 3964 3965 return Typedef_Node; 3966 end P_Interface_Type_Definition; 3967 3968 ---------------------------------- 3969 -- 3.10 Access Type Definition -- 3970 ---------------------------------- 3971 3972 -- ACCESS_TYPE_DEFINITION ::= 3973 -- ACCESS_TO_OBJECT_DEFINITION 3974 -- | ACCESS_TO_SUBPROGRAM_DEFINITION 3975 3976 -- ACCESS_TO_OBJECT_DEFINITION ::= 3977 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION 3978 3979 -- GENERAL_ACCESS_MODIFIER ::= all | constant 3980 3981 -- ACCESS_TO_SUBPROGRAM_DEFINITION 3982 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE 3983 -- | [NULL_EXCLUSION] access [protected] function 3984 -- PARAMETER_AND_RESULT_PROFILE 3985 3986 -- PARAMETER_PROFILE ::= [FORMAL_PART] 3987 3988 -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK 3989 3990 -- Ada 2005 (AI-254): If Header_Already_Parsed then the caller has already 3991 -- parsed the null_exclusion part and has also removed the ACCESS token; 3992 -- otherwise the caller has just checked that the initial token is ACCESS 3993 3994 -- Error recovery: can raise Error_Resync 3995 3996 function P_Access_Type_Definition 3997 (Header_Already_Parsed : Boolean := False) return Node_Id 3998 is 3999 Access_Loc : constant Source_Ptr := Token_Ptr; 4000 Prot_Flag : Boolean; 4001 Not_Null_Present : Boolean := False; 4002 Not_Null_Subtype : Boolean := False; 4003 Type_Def_Node : Node_Id; 4004 Result_Not_Null : Boolean; 4005 Result_Node : Node_Id; 4006 4007 procedure Check_Junk_Subprogram_Name; 4008 -- Used in access to subprogram definition cases to check for an 4009 -- identifier or operator symbol that does not belong. 4010 4011 -------------------------------- 4012 -- Check_Junk_Subprogram_Name -- 4013 -------------------------------- 4014 4015 procedure Check_Junk_Subprogram_Name is 4016 Saved_State : Saved_Scan_State; 4017 4018 begin 4019 if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then 4020 Save_Scan_State (Saved_State); 4021 Scan; -- past possible junk subprogram name 4022 4023 if Token = Tok_Left_Paren or else Token = Tok_Semicolon then 4024 Error_Msg_SP ("unexpected subprogram name ignored"); 4025 return; 4026 4027 else 4028 Restore_Scan_State (Saved_State); 4029 end if; 4030 end if; 4031 end Check_Junk_Subprogram_Name; 4032 4033 -- Start of processing for P_Access_Type_Definition 4034 4035 begin 4036 if not Header_Already_Parsed then 4037 4038 -- NOT NULL ACCESS .. is a common form of access definition. 4039 -- ACCESS NOT NULL .. is certainly rare, but syntactically legal. 4040 -- NOT NULL ACCESS NOT NULL .. is rarer yet, and also legal. 4041 -- The last two cases are only meaningful if the following subtype 4042 -- indication denotes an access type (semantic check). The flag 4043 -- Not_Null_Subtype indicates that this second null exclusion is 4044 -- present in the access type definition. 4045 4046 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) 4047 Scan; -- past ACCESS 4048 Not_Null_Subtype := P_Null_Exclusion; -- Might also appear 4049 end if; 4050 4051 if Token_Name = Name_Protected then 4052 Check_95_Keyword (Tok_Protected, Tok_Procedure); 4053 Check_95_Keyword (Tok_Protected, Tok_Function); 4054 end if; 4055 4056 Prot_Flag := (Token = Tok_Protected); 4057 4058 if Prot_Flag then 4059 Scan; -- past PROTECTED 4060 4061 if Token /= Tok_Procedure and then Token /= Tok_Function then 4062 Error_Msg_SC -- CODEFIX 4063 ("FUNCTION or PROCEDURE expected"); 4064 end if; 4065 end if; 4066 4067 if Token = Tok_Procedure then 4068 if Ada_Version = Ada_83 then 4069 Error_Msg_SC ("(Ada 83) access to procedure not allowed!"); 4070 end if; 4071 4072 Type_Def_Node := New_Node (N_Access_Procedure_Definition, Access_Loc); 4073 Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present); 4074 Scan; -- past PROCEDURE 4075 Check_Junk_Subprogram_Name; 4076 Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile); 4077 Set_Protected_Present (Type_Def_Node, Prot_Flag); 4078 4079 elsif Token = Tok_Function then 4080 if Ada_Version = Ada_83 then 4081 Error_Msg_SC ("(Ada 83) access to function not allowed!"); 4082 end if; 4083 4084 Type_Def_Node := New_Node (N_Access_Function_Definition, Access_Loc); 4085 Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present); 4086 Scan; -- past FUNCTION 4087 Check_Junk_Subprogram_Name; 4088 Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile); 4089 Set_Protected_Present (Type_Def_Node, Prot_Flag); 4090 TF_Return; 4091 4092 Result_Not_Null := P_Null_Exclusion; -- Ada 2005 (AI-231) 4093 4094 -- Ada 2005 (AI-318-02) 4095 4096 if Token = Tok_Access then 4097 if Ada_Version < Ada_2005 then 4098 Error_Msg_SC 4099 ("anonymous access result type is an Ada 2005 extension"); 4100 Error_Msg_SC ("\unit must be compiled with -gnat05 switch"); 4101 end if; 4102 4103 Result_Node := P_Access_Definition (Result_Not_Null); 4104 4105 else 4106 Result_Node := P_Subtype_Mark; 4107 No_Constraint; 4108 4109 -- A null exclusion on the result type must be recorded in a flag 4110 -- distinct from the one used for the access-to-subprogram type's 4111 -- null exclusion. 4112 4113 Set_Null_Exclusion_In_Return_Present 4114 (Type_Def_Node, Result_Not_Null); 4115 end if; 4116 4117 Set_Result_Definition (Type_Def_Node, Result_Node); 4118 4119 else 4120 Type_Def_Node := 4121 New_Node (N_Access_To_Object_Definition, Access_Loc); 4122 Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present); 4123 Set_Null_Excluding_Subtype (Type_Def_Node, Not_Null_Subtype); 4124 4125 if Token = Tok_All or else Token = Tok_Constant then 4126 if Ada_Version = Ada_83 then 4127 Error_Msg_SC ("(Ada 83) access modifier not allowed!"); 4128 end if; 4129 4130 if Token = Tok_All then 4131 Set_All_Present (Type_Def_Node, True); 4132 4133 else 4134 Set_Constant_Present (Type_Def_Node, True); 4135 end if; 4136 4137 Scan; -- past ALL or CONSTANT 4138 end if; 4139 4140 Set_Subtype_Indication (Type_Def_Node, 4141 P_Subtype_Indication (Not_Null_Present)); 4142 end if; 4143 4144 return Type_Def_Node; 4145 end P_Access_Type_Definition; 4146 4147 --------------------------------------- 4148 -- 3.10 Access To Object Definition -- 4149 --------------------------------------- 4150 4151 -- Parsed by P_Access_Type_Definition (3.10) 4152 4153 ----------------------------------- 4154 -- 3.10 General Access Modifier -- 4155 ----------------------------------- 4156 4157 -- Parsed by P_Access_Type_Definition (3.10) 4158 4159 ------------------------------------------- 4160 -- 3.10 Access To Subprogram Definition -- 4161 ------------------------------------------- 4162 4163 -- Parsed by P_Access_Type_Definition (3.10) 4164 4165 ----------------------------- 4166 -- 3.10 Access Definition -- 4167 ----------------------------- 4168 4169 -- ACCESS_DEFINITION ::= 4170 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK 4171 -- | ACCESS_TO_SUBPROGRAM_DEFINITION 4172 -- 4173 -- ACCESS_TO_SUBPROGRAM_DEFINITION 4174 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE 4175 -- | [NULL_EXCLUSION] access [protected] function 4176 -- PARAMETER_AND_RESULT_PROFILE 4177 4178 -- The caller has parsed the null-exclusion part and it has also checked 4179 -- that the next token is ACCESS 4180 4181 -- Error recovery: cannot raise Error_Resync 4182 4183 function P_Access_Definition 4184 (Null_Exclusion_Present : Boolean) return Node_Id 4185 is 4186 Def_Node : Node_Id; 4187 Subp_Node : Node_Id; 4188 4189 begin 4190 Def_Node := New_Node (N_Access_Definition, Token_Ptr); 4191 Scan; -- past ACCESS 4192 4193 -- Ada 2005 (AI-254): Access_To_Subprogram_Definition 4194 4195 if Token = Tok_Protected 4196 or else Token = Tok_Procedure 4197 or else Token = Tok_Function 4198 then 4199 if Ada_Version < Ada_2005 then 4200 Error_Msg_SP ("access-to-subprogram is an Ada 2005 extension"); 4201 Error_Msg_SP ("\unit should be compiled with -gnat05 switch"); 4202 end if; 4203 4204 Subp_Node := P_Access_Type_Definition (Header_Already_Parsed => True); 4205 Set_Null_Exclusion_Present (Subp_Node, Null_Exclusion_Present); 4206 Set_Access_To_Subprogram_Definition (Def_Node, Subp_Node); 4207 4208 -- Ada 2005 (AI-231) 4209 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK 4210 4211 else 4212 Set_Null_Exclusion_Present (Def_Node, Null_Exclusion_Present); 4213 4214 if Token = Tok_All then 4215 if Ada_Version < Ada_2005 then 4216 Error_Msg_SP 4217 ("ALL is not permitted for anonymous access types"); 4218 end if; 4219 4220 Scan; -- past ALL 4221 Set_All_Present (Def_Node); 4222 4223 elsif Token = Tok_Constant then 4224 if Ada_Version < Ada_2005 then 4225 Error_Msg_SP ("access-to-constant is an Ada 2005 extension"); 4226 Error_Msg_SP ("\unit should be compiled with -gnat05 switch"); 4227 end if; 4228 4229 Scan; -- past CONSTANT 4230 Set_Constant_Present (Def_Node); 4231 end if; 4232 4233 Set_Subtype_Mark (Def_Node, P_Subtype_Mark); 4234 No_Constraint; 4235 end if; 4236 4237 return Def_Node; 4238 end P_Access_Definition; 4239 4240 ----------------------------------------- 4241 -- 3.10.1 Incomplete Type Declaration -- 4242 ----------------------------------------- 4243 4244 -- Parsed by P_Type_Declaration (3.2.1) 4245 4246 ---------------------------- 4247 -- 3.11 Declarative Part -- 4248 ---------------------------- 4249 4250 -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM} 4251 4252 -- Error recovery: cannot raise Error_Resync (because P_Declarative_Items 4253 -- handles errors, and returns cleanly after an error has occurred) 4254 4255 function P_Declarative_Part return List_Id is 4256 Decls : List_Id; 4257 Done : Boolean; 4258 4259 begin 4260 -- Indicate no bad declarations detected yet. This will be reset by 4261 -- P_Declarative_Items if a bad declaration is discovered. 4262 4263 Missing_Begin_Msg := No_Error_Msg; 4264 4265 -- Get rid of active SIS entry from outer scope. This means we will 4266 -- miss some nested cases, but it doesn't seem worth the effort. See 4267 -- discussion in Par for further details 4268 4269 SIS_Entry_Active := False; 4270 Decls := New_List; 4271 4272 -- Loop to scan out the declarations 4273 4274 loop 4275 P_Declarative_Items (Decls, Done, In_Spec => False); 4276 exit when Done; 4277 end loop; 4278 4279 -- Get rid of active SIS entry which is left set only if we scanned a 4280 -- procedure declaration and have not found the body. We could give 4281 -- an error message, but that really would be usurping the role of 4282 -- semantic analysis (this really is a missing body case). 4283 4284 SIS_Entry_Active := False; 4285 return Decls; 4286 end P_Declarative_Part; 4287 4288 ---------------------------- 4289 -- 3.11 Declarative Item -- 4290 ---------------------------- 4291 4292 -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY 4293 4294 -- Can return Error if a junk declaration is found, or Empty if no 4295 -- declaration is found (i.e. a token ending declarations, such as 4296 -- BEGIN or END is encountered). 4297 4298 -- Error recovery: cannot raise Error_Resync. If an error resync occurs, 4299 -- then the scan is set past the next semicolon and Error is returned. 4300 4301 procedure P_Declarative_Items 4302 (Decls : List_Id; 4303 Done : out Boolean; 4304 In_Spec : Boolean) 4305 is 4306 Scan_State : Saved_Scan_State; 4307 4308 begin 4309 if Style_Check then 4310 Style.Check_Indentation; 4311 end if; 4312 4313 case Token is 4314 4315 when Tok_Function => 4316 Check_Bad_Layout; 4317 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); 4318 Done := False; 4319 4320 when Tok_For => 4321 Check_Bad_Layout; 4322 4323 -- Check for loop (premature statement) 4324 4325 Save_Scan_State (Scan_State); 4326 Scan; -- past FOR 4327 4328 if Token = Tok_Identifier then 4329 Scan; -- past identifier 4330 4331 if Token = Tok_In then 4332 Restore_Scan_State (Scan_State); 4333 Statement_When_Declaration_Expected (Decls, Done, In_Spec); 4334 return; 4335 end if; 4336 end if; 4337 4338 -- Not a loop, so must be rep clause 4339 4340 Restore_Scan_State (Scan_State); 4341 Append (P_Representation_Clause, Decls); 4342 Done := False; 4343 4344 when Tok_Generic => 4345 Check_Bad_Layout; 4346 Append (P_Generic, Decls); 4347 Done := False; 4348 4349 when Tok_Identifier => 4350 Check_Bad_Layout; 4351 4352 -- Special check for misuse of overriding not in Ada 2005 mode 4353 4354 if Token_Name = Name_Overriding 4355 and then not Next_Token_Is (Tok_Colon) 4356 then 4357 Error_Msg_SC ("overriding indicator is an Ada 2005 extension"); 4358 Error_Msg_SC ("\unit must be compiled with -gnat05 switch"); 4359 4360 Token := Tok_Overriding; 4361 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); 4362 Done := False; 4363 4364 -- Normal case, no overriding, or overriding followed by colon 4365 4366 else 4367 P_Identifier_Declarations (Decls, Done, In_Spec); 4368 end if; 4369 4370 -- Ada 2005: A subprogram declaration can start with "not" or 4371 -- "overriding". In older versions, "overriding" is handled 4372 -- like an identifier, with the appropriate messages. 4373 4374 when Tok_Not => 4375 Check_Bad_Layout; 4376 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); 4377 Done := False; 4378 4379 when Tok_Overriding => 4380 Check_Bad_Layout; 4381 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); 4382 Done := False; 4383 4384 when Tok_Package => 4385 Check_Bad_Layout; 4386 Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); 4387 Done := False; 4388 4389 when Tok_Pragma => 4390 Append (P_Pragma, Decls); 4391 Done := False; 4392 4393 when Tok_Procedure => 4394 Check_Bad_Layout; 4395 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); 4396 Done := False; 4397 4398 when Tok_Protected => 4399 Check_Bad_Layout; 4400 Scan; -- past PROTECTED 4401 Append (P_Protected, Decls); 4402 Done := False; 4403 4404 when Tok_Subtype => 4405 Check_Bad_Layout; 4406 Append (P_Subtype_Declaration, Decls); 4407 Done := False; 4408 4409 when Tok_Task => 4410 Check_Bad_Layout; 4411 Scan; -- past TASK 4412 Append (P_Task, Decls); 4413 Done := False; 4414 4415 when Tok_Type => 4416 Check_Bad_Layout; 4417 Append (P_Type_Declaration, Decls); 4418 Done := False; 4419 4420 when Tok_Use => 4421 Check_Bad_Layout; 4422 Append (P_Use_Clause, Decls); 4423 Done := False; 4424 4425 when Tok_With => 4426 Check_Bad_Layout; 4427 4428 if Aspect_Specifications_Present then 4429 4430 -- If we are after a semicolon, complain that it was ignored. 4431 -- But we don't really ignore it, since we dump the aspects, 4432 -- so we make the error message a normal fatal message which 4433 -- will inhibit semantic analysis anyway). 4434 4435 if Prev_Token = Tok_Semicolon then 4436 Error_Msg_SP -- CODEFIX 4437 ("extra "";"" ignored"); 4438 4439 -- If not just past semicolon, just complain that aspects are 4440 -- not allowed at this point. 4441 4442 else 4443 Error_Msg_SC ("aspect specifications not allowed here"); 4444 end if; 4445 4446 -- Assume that this is a misplaced aspect specification within 4447 -- a declarative list. After discarding the misplaced aspects 4448 -- we can continue the scan. 4449 4450 Done := False; 4451 4452 declare 4453 Dummy_Node : constant Node_Id := 4454 New_Node (N_Package_Specification, Token_Ptr); 4455 pragma Warnings (Off, Dummy_Node); 4456 -- Dummy node to attach aspect specifications to. We will 4457 -- then throw them away. 4458 4459 begin 4460 P_Aspect_Specifications (Dummy_Node, Semicolon => True); 4461 end; 4462 4463 -- Here if not aspect specifications case 4464 4465 else 4466 Error_Msg_SC ("WITH can only appear in context clause"); 4467 raise Error_Resync; 4468 end if; 4469 4470 -- BEGIN terminates the scan of a sequence of declarations unless 4471 -- there is a missing subprogram body, see section on handling 4472 -- semicolon in place of IS. We only treat the begin as satisfying 4473 -- the subprogram declaration if it falls in the expected column 4474 -- or to its right. 4475 4476 when Tok_Begin => 4477 if SIS_Entry_Active and then Start_Column >= SIS_Ecol then 4478 4479 -- Here we have the case where a BEGIN is encountered during 4480 -- declarations in a declarative part, or at the outer level, 4481 -- and there is a subprogram declaration outstanding for which 4482 -- no body has been supplied. This is the case where we assume 4483 -- that the semicolon in the subprogram declaration should 4484 -- really have been is. The active SIS entry describes the 4485 -- subprogram declaration. On return the declaration has been 4486 -- modified to become a body. 4487 4488 declare 4489 Specification_Node : Node_Id; 4490 Decl_Node : Node_Id; 4491 Body_Node : Node_Id; 4492 4493 begin 4494 -- First issue the error message. If we had a missing 4495 -- semicolon in the declaration, then change the message 4496 -- to <missing "is"> 4497 4498 if SIS_Missing_Semicolon_Message /= No_Error_Msg then 4499 Change_Error_Text -- Replace: "missing "";"" " 4500 (SIS_Missing_Semicolon_Message, "missing ""is"""); 4501 4502 -- Otherwise we saved the semicolon position, so complain 4503 4504 else 4505 Error_Msg -- CODEFIX 4506 ("|"";"" should be IS", SIS_Semicolon_Sloc); 4507 end if; 4508 4509 -- The next job is to fix up any declarations that occurred 4510 -- between the procedure header and the BEGIN. These got 4511 -- chained to the outer declarative region (immediately 4512 -- after the procedure declaration) and they should be 4513 -- chained to the subprogram itself, which is a body 4514 -- rather than a spec. 4515 4516 Specification_Node := Specification (SIS_Declaration_Node); 4517 Change_Node (SIS_Declaration_Node, N_Subprogram_Body); 4518 Body_Node := SIS_Declaration_Node; 4519 Set_Specification (Body_Node, Specification_Node); 4520 Set_Declarations (Body_Node, New_List); 4521 4522 loop 4523 Decl_Node := Remove_Next (Body_Node); 4524 exit when Decl_Node = Empty; 4525 Append (Decl_Node, Declarations (Body_Node)); 4526 end loop; 4527 4528 -- Now make the scope table entry for the Begin-End and 4529 -- scan it out 4530 4531 Push_Scope_Stack; 4532 Scope.Table (Scope.Last).Sloc := SIS_Sloc; 4533 Scope.Table (Scope.Last).Etyp := E_Name; 4534 Scope.Table (Scope.Last).Ecol := SIS_Ecol; 4535 Scope.Table (Scope.Last).Labl := SIS_Labl; 4536 Scope.Table (Scope.Last).Lreq := False; 4537 SIS_Entry_Active := False; 4538 Scan; -- past BEGIN 4539 Set_Handled_Statement_Sequence (Body_Node, 4540 P_Handled_Sequence_Of_Statements); 4541 End_Statements (Handled_Statement_Sequence (Body_Node)); 4542 end; 4543 4544 Done := False; 4545 4546 else 4547 Done := True; 4548 end if; 4549 4550 -- Normally an END terminates the scan for basic declarative items. 4551 -- The one exception is END RECORD, which is probably left over from 4552 -- some other junk. 4553 4554 when Tok_End => 4555 Save_Scan_State (Scan_State); -- at END 4556 Scan; -- past END 4557 4558 if Token = Tok_Record then 4559 Error_Msg_SP ("no RECORD for this `end record`!"); 4560 Scan; -- past RECORD 4561 TF_Semicolon; 4562 4563 -- This might happen because of misplaced aspect specification. 4564 -- After discarding the misplaced aspects we can continue the 4565 -- scan. 4566 4567 Done := False; 4568 else 4569 Restore_Scan_State (Scan_State); -- to END 4570 Done := True; 4571 end if; 4572 4573 -- The following tokens which can only be the start of a statement 4574 -- are considered to end a declarative part (i.e. we have a missing 4575 -- BEGIN situation). We are fairly conservative in making this 4576 -- judgment, because it is a real mess to go into statement mode 4577 -- prematurely in response to a junk declaration. 4578 4579 when Tok_Abort | 4580 Tok_Accept | 4581 Tok_Declare | 4582 Tok_Delay | 4583 Tok_Exit | 4584 Tok_Goto | 4585 Tok_If | 4586 Tok_Loop | 4587 Tok_Null | 4588 Tok_Requeue | 4589 Tok_Select | 4590 Tok_While => 4591 4592 -- But before we decide that it's a statement, let's check for 4593 -- a reserved word misused as an identifier. 4594 4595 if Is_Reserved_Identifier then 4596 Save_Scan_State (Scan_State); 4597 Scan; -- past the token 4598 4599 -- If reserved identifier not followed by colon or comma, then 4600 -- this is most likely an assignment statement to the bad id. 4601 4602 if Token /= Tok_Colon and then Token /= Tok_Comma then 4603 Restore_Scan_State (Scan_State); 4604 Statement_When_Declaration_Expected (Decls, Done, In_Spec); 4605 return; 4606 4607 -- Otherwise we have a declaration of the bad id 4608 4609 else 4610 Restore_Scan_State (Scan_State); 4611 Scan_Reserved_Identifier (Force_Msg => True); 4612 P_Identifier_Declarations (Decls, Done, In_Spec); 4613 end if; 4614 4615 -- If not reserved identifier, then it's definitely a statement 4616 4617 else 4618 Statement_When_Declaration_Expected (Decls, Done, In_Spec); 4619 return; 4620 end if; 4621 4622 -- The token RETURN may well also signal a missing BEGIN situation, 4623 -- however, we never let it end the declarative part, because it may 4624 -- also be part of a half-baked function declaration. 4625 4626 when Tok_Return => 4627 Error_Msg_SC ("misplaced RETURN statement"); 4628 raise Error_Resync; 4629 4630 -- PRIVATE definitely terminates the declarations in a spec, 4631 -- and is an error in a body. 4632 4633 when Tok_Private => 4634 if In_Spec then 4635 Done := True; 4636 else 4637 Error_Msg_SC ("PRIVATE not allowed in body"); 4638 Scan; -- past PRIVATE 4639 end if; 4640 4641 -- An end of file definitely terminates the declarations 4642 4643 when Tok_EOF => 4644 Done := True; 4645 4646 -- The remaining tokens do not end the scan, but cannot start a 4647 -- valid declaration, so we signal an error and resynchronize. 4648 -- But first check for misuse of a reserved identifier. 4649 4650 when others => 4651 4652 -- Here we check for a reserved identifier 4653 4654 if Is_Reserved_Identifier then 4655 Save_Scan_State (Scan_State); 4656 Scan; -- past the token 4657 4658 if Token /= Tok_Colon and then Token /= Tok_Comma then 4659 Restore_Scan_State (Scan_State); 4660 Set_Declaration_Expected; 4661 raise Error_Resync; 4662 else 4663 Restore_Scan_State (Scan_State); 4664 Scan_Reserved_Identifier (Force_Msg => True); 4665 Check_Bad_Layout; 4666 P_Identifier_Declarations (Decls, Done, In_Spec); 4667 end if; 4668 4669 else 4670 Set_Declaration_Expected; 4671 raise Error_Resync; 4672 end if; 4673 end case; 4674 4675 -- To resynchronize after an error, we scan to the next semicolon and 4676 -- return with Done = False, indicating that there may still be more 4677 -- valid declarations to come. 4678 4679 exception 4680 when Error_Resync => 4681 Resync_Past_Semicolon; 4682 Done := False; 4683 end P_Declarative_Items; 4684 4685 ---------------------------------- 4686 -- 3.11 Basic Declarative Item -- 4687 ---------------------------------- 4688 4689 -- BASIC_DECLARATIVE_ITEM ::= 4690 -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE 4691 4692 -- Scan zero or more basic declarative items 4693 4694 -- Error recovery: cannot raise Error_Resync. If an error is detected, then 4695 -- the scan pointer is repositioned past the next semicolon, and the scan 4696 -- for declarative items continues. 4697 4698 function P_Basic_Declarative_Items return List_Id is 4699 Decl : Node_Id; 4700 Decls : List_Id; 4701 Kind : Node_Kind; 4702 Done : Boolean; 4703 4704 begin 4705 -- Indicate no bad declarations detected yet in the current context: 4706 -- visible or private declarations of a package spec. 4707 4708 Missing_Begin_Msg := No_Error_Msg; 4709 4710 -- Get rid of active SIS entry from outer scope. This means we will 4711 -- miss some nested cases, but it doesn't seem worth the effort. See 4712 -- discussion in Par for further details 4713 4714 SIS_Entry_Active := False; 4715 4716 -- Loop to scan out declarations 4717 4718 Decls := New_List; 4719 4720 loop 4721 P_Declarative_Items (Decls, Done, In_Spec => True); 4722 exit when Done; 4723 end loop; 4724 4725 -- Get rid of active SIS entry. This is set only if we have scanned a 4726 -- procedure declaration and have not found the body. We could give 4727 -- an error message, but that really would be usurping the role of 4728 -- semantic analysis (this really is a case of a missing body). 4729 4730 SIS_Entry_Active := False; 4731 4732 -- Test for assorted illegal declarations not diagnosed elsewhere 4733 4734 Decl := First (Decls); 4735 4736 while Present (Decl) loop 4737 Kind := Nkind (Decl); 4738 4739 -- Test for body scanned, not acceptable as basic decl item 4740 4741 if Kind = N_Subprogram_Body or else 4742 Kind = N_Package_Body or else 4743 Kind = N_Task_Body or else 4744 Kind = N_Protected_Body 4745 then 4746 Error_Msg ("proper body not allowed in package spec", Sloc (Decl)); 4747 4748 -- Complete declaration of mangled subprogram body, for better 4749 -- recovery if analysis is attempted. 4750 4751 if Nkind_In (Decl, N_Subprogram_Body, N_Package_Body, N_Task_Body) 4752 and then No (Handled_Statement_Sequence (Decl)) 4753 then 4754 Set_Handled_Statement_Sequence (Decl, 4755 Make_Handled_Sequence_Of_Statements (Sloc (Decl), 4756 Statements => New_List)); 4757 end if; 4758 4759 -- Test for body stub scanned, not acceptable as basic decl item 4760 4761 elsif Kind in N_Body_Stub then 4762 Error_Msg ("body stub not allowed in package spec", Sloc (Decl)); 4763 4764 elsif Kind = N_Assignment_Statement then 4765 Error_Msg 4766 ("assignment statement not allowed in package spec", 4767 Sloc (Decl)); 4768 end if; 4769 4770 Next (Decl); 4771 end loop; 4772 4773 return Decls; 4774 end P_Basic_Declarative_Items; 4775 4776 ---------------- 4777 -- 3.11 Body -- 4778 ---------------- 4779 4780 -- For proper body, see below 4781 -- For body stub, see 10.1.3 4782 4783 ----------------------- 4784 -- 3.11 Proper Body -- 4785 ----------------------- 4786 4787 -- Subprogram body is parsed by P_Subprogram (6.1) 4788 -- Package body is parsed by P_Package (7.1) 4789 -- Task body is parsed by P_Task (9.1) 4790 -- Protected body is parsed by P_Protected (9.4) 4791 4792 ------------------------------ 4793 -- Set_Declaration_Expected -- 4794 ------------------------------ 4795 4796 procedure Set_Declaration_Expected is 4797 begin 4798 Error_Msg_SC ("declaration expected"); 4799 4800 if Missing_Begin_Msg = No_Error_Msg then 4801 Missing_Begin_Msg := Get_Msg_Id; 4802 end if; 4803 end Set_Declaration_Expected; 4804 4805 ---------------------- 4806 -- Skip_Declaration -- 4807 ---------------------- 4808 4809 procedure Skip_Declaration (S : List_Id) is 4810 Dummy_Done : Boolean; 4811 pragma Warnings (Off, Dummy_Done); 4812 begin 4813 P_Declarative_Items (S, Dummy_Done, False); 4814 end Skip_Declaration; 4815 4816 ----------------------------------------- 4817 -- Statement_When_Declaration_Expected -- 4818 ----------------------------------------- 4819 4820 procedure Statement_When_Declaration_Expected 4821 (Decls : List_Id; 4822 Done : out Boolean; 4823 In_Spec : Boolean) 4824 is 4825 begin 4826 -- Case of second occurrence of statement in one declaration sequence 4827 4828 if Missing_Begin_Msg /= No_Error_Msg then 4829 4830 -- In the procedure spec case, just ignore it, we only give one 4831 -- message for the first occurrence, since otherwise we may get 4832 -- horrible cascading if BODY was missing in the header line. 4833 4834 if In_Spec then 4835 null; 4836 4837 -- Just ignore it if we are in -gnatd.2 (allow statements to appear 4838 -- in declaration sequences) mode. 4839 4840 elsif Debug_Flag_Dot_2 then 4841 null; 4842 4843 -- In the declarative part case, take a second statement as a sure 4844 -- sign that we really have a missing BEGIN, and end the declarative 4845 -- part now. Note that the caller will fix up the first message to 4846 -- say "missing BEGIN" so that's how the error will be signalled. 4847 4848 else 4849 Done := True; 4850 return; 4851 end if; 4852 4853 -- Case of first occurrence of unexpected statement 4854 4855 else 4856 -- Do not give error message if we are operating in -gnatd.2 mode 4857 -- (alllow statements to appear in declarative parts). 4858 4859 if not Debug_Flag_Dot_2 then 4860 4861 -- If we are in a package spec, then give message of statement 4862 -- not allowed in package spec. This message never gets changed. 4863 4864 if In_Spec then 4865 Error_Msg_SC ("statement not allowed in package spec"); 4866 4867 -- If in declarative part, then we give the message complaining 4868 -- about finding a statement when a declaration is expected. This 4869 -- gets changed to a complaint about a missing BEGIN if we later 4870 -- find that no BEGIN is present. 4871 4872 else 4873 Error_Msg_SC ("statement not allowed in declarative part"); 4874 end if; 4875 4876 -- Capture message Id. This is used for two purposes, first to 4877 -- stop multiple messages, see test above, and second, to allow 4878 -- the replacement of the message in the declarative part case. 4879 4880 Missing_Begin_Msg := Get_Msg_Id; 4881 end if; 4882 end if; 4883 4884 -- In all cases except the case in which we decided to terminate the 4885 -- declaration sequence on a second error, we scan out the statement 4886 -- and append it to the list of declarations (note that the semantics 4887 -- can handle statements in a declaration list so if we proceed to 4888 -- call the semantic phase, all will be (reasonably) well. 4889 4890 Append_List_To (Decls, P_Sequence_Of_Statements (SS_Unco)); 4891 4892 -- Done is set to False, since we want to continue the scan of 4893 -- declarations, hoping that this statement was a temporary glitch. 4894 -- If we indeed are now in the statement part (i.e. this was a missing 4895 -- BEGIN, then it's not terrible, we will simply keep calling this 4896 -- procedure to process the statements one by one, and then finally 4897 -- hit the missing BEGIN, which will clean up the error message. 4898 4899 Done := False; 4900 end Statement_When_Declaration_Expected; 4901 4902end Ch3; 4903