gcc/ada/par-ch3.adb

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