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