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