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