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