gcc/ada/par-ch3.adb

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