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