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