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