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