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