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