gcc/ada/par-ch3.adb

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