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