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