gcc/ada/par-ch3.adb

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