gcc/ada/par-ch3.adb

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