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