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