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