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