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