gcc/ada/par-ch3.adb

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