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