gcc/ada/par-ch3.adb

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