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