gcc/ada/par-ch4.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              P A R . C H 4                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2010, 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 3,  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 COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 pragma Style_Checks (All_Checks);
  27 --  Turn off subprogram body ordering check. Subprograms are in order
  28 --  by RM section rather than alphabetical
  29
  30 with Stringt; use Stringt;
  31
  32 separate (Par)
  33 package body Ch4 is
  34
  35    --  Attributes that cannot have arguments
  36
  37    Is_Parameterless_Attribute : constant Attribute_Class_Array :=
  38      (Attribute_Body_Version => True,
  39       Attribute_External_Tag => True,
  40       Attribute_Img          => True,
  41       Attribute_Version      => True,
  42       Attribute_Base         => True,
  43       Attribute_Class        => True,
  44       Attribute_Stub_Type    => True,
  45       Attribute_Type_Key     => True,
  46       others                 => False);
  47    --  This map contains True for parameterless attributes that return a
  48    --  string or a type. For those attributes, a left parenthesis after
  49    --  the attribute should not be analyzed as the beginning of a parameters
  50    --  list because it may denote a slice operation (X'Img (1 .. 2)) or
  51    --  a type conversion (X'Class (Y)).
  52
  53    --  Note that this map designates the minimum set of attributes where a
  54    --  construct in parentheses that is not an argument can appear right
  55    --  after the attribute. For attributes like 'Size, we do not put them
  56    --  in the map. If someone writes X'Size (3), that's illegal in any case,
  57    --  but we get a better error message by parsing the (3) as an illegal
  58    --  argument to the attribute, rather than some meaningless junk that
  59    --  follows the attribute.
  60
  61    -----------------------
  62    -- Local Subprograms --
  63    -----------------------
  64
  65    function P_Aggregate_Or_Paren_Expr                 return Node_Id;
  66    function P_Allocator                               return Node_Id;
  67    function P_Case_Expression_Alternative             return Node_Id;
  68    function P_Record_Or_Array_Component_Association   return Node_Id;
  69    function P_Factor                                  return Node_Id;
  70    function P_Primary                                 return Node_Id;
  71    function P_Relation                                return Node_Id;
  72    function P_Term                                    return Node_Id;
  73
  74    function P_Binary_Adding_Operator                  return Node_Kind;
  75    function P_Logical_Operator                        return Node_Kind;
  76    function P_Multiplying_Operator                    return Node_Kind;
  77    function P_Relational_Operator                     return Node_Kind;
  78    function P_Unary_Adding_Operator                   return Node_Kind;
  79
  80    procedure Bad_Range_Attribute (Loc : Source_Ptr);
  81    --  Called to place complaint about bad range attribute at the given
  82    --  source location. Terminates by raising Error_Resync.
  83
  84    procedure P_Membership_Test (N : Node_Id);
  85    --  N is the node for a N_In or N_Not_In node whose right operand has not
  86    --  yet been processed. It is called just after scanning out the IN keyword.
  87    --  On return, either Right_Opnd or Alternatives is set, as appropriate.
  88
  89    function P_Range_Attribute_Reference (Prefix_Node : Node_Id) return Node_Id;
  90    --  Scan a range attribute reference. The caller has scanned out the
  91    --  prefix. The current token is known to be an apostrophe and the
  92    --  following token is known to be RANGE.
  93
  94    -------------------------
  95    -- Bad_Range_Attribute --
  96    -------------------------
  97
  98    procedure Bad_Range_Attribute (Loc : Source_Ptr) is
  99    begin
 100       Error_Msg ("range attribute cannot be used in expression!", Loc);
 101       Resync_Expression;
 102    end Bad_Range_Attribute;
 103
 104    --------------------------
 105    -- 4.1  Name (also 6.4) --
 106    --------------------------
 107
 108    --  NAME ::=
 109    --    DIRECT_NAME        | EXPLICIT_DEREFERENCE
 110    --  | INDEXED_COMPONENT  | SLICE
 111    --  | SELECTED_COMPONENT | ATTRIBUTE
 112    --  | TYPE_CONVERSION    | FUNCTION_CALL
 113    --  | CHARACTER_LITERAL
 114
 115    --  DIRECT_NAME ::= IDENTIFIER | OPERATOR_SYMBOL
 116
 117    --  PREFIX ::= NAME | IMPLICIT_DEREFERENCE
 118
 119    --  EXPLICIT_DEREFERENCE ::= NAME . all
 120
 121    --  IMPLICIT_DEREFERENCE ::= NAME
 122
 123    --  INDEXED_COMPONENT ::= PREFIX (EXPRESSION {, EXPRESSION})
 124
 125    --  SLICE ::= PREFIX (DISCRETE_RANGE)
 126
 127    --  SELECTED_COMPONENT ::= PREFIX . SELECTOR_NAME
 128
 129    --  SELECTOR_NAME ::= IDENTIFIER | CHARACTER_LITERAL | OPERATOR_SYMBOL
 130
 131    --  ATTRIBUTE_REFERENCE ::= PREFIX ' ATTRIBUTE_DESIGNATOR
 132
 133    --  ATTRIBUTE_DESIGNATOR ::=
 134    --    IDENTIFIER [(static_EXPRESSION)]
 135    --  | access | delta | digits
 136
 137    --  FUNCTION_CALL ::=
 138    --    function_NAME
 139    --  | function_PREFIX ACTUAL_PARAMETER_PART
 140
 141    --  ACTUAL_PARAMETER_PART ::=
 142    --    (PARAMETER_ASSOCIATION {,PARAMETER_ASSOCIATION})
 143
 144    --  PARAMETER_ASSOCIATION ::=
 145    --    [formal_parameter_SELECTOR_NAME =>] EXPLICIT_ACTUAL_PARAMETER
 146
 147    --  EXPLICIT_ACTUAL_PARAMETER ::= EXPRESSION | variable_NAME
 148
 149    --  Note: syntactically a procedure call looks just like a function call,
 150    --  so this routine is in practice used to scan out procedure calls as well.
 151
 152    --  On return, Expr_Form is set to either EF_Name or EF_Simple_Name
 153
 154    --  Error recovery: can raise Error_Resync
 155
 156    --  Note: if on return Token = Tok_Apostrophe, then the apostrophe must be
 157    --  followed by either a left paren (qualified expression case), or by
 158    --  range (range attribute case). All other uses of apostrophe (i.e. all
 159    --  other attributes) are handled in this routine.
 160
 161    --  Error recovery: can raise Error_Resync
 162
 163    function P_Name return Node_Id is
 164       Scan_State  : Saved_Scan_State;
 165       Name_Node   : Node_Id;
 166       Prefix_Node : Node_Id;
 167       Ident_Node  : Node_Id;
 168       Expr_Node   : Node_Id;
 169       Range_Node  : Node_Id;
 170       Arg_Node    : Node_Id;
 171
 172       Arg_List  : List_Id := No_List; -- kill junk warning
 173       Attr_Name : Name_Id := No_Name; -- kill junk warning
 174
 175    begin
 176       --  Case of not a name
 177
 178       if Token not in Token_Class_Name then
 179
 180          --  If it looks like start of expression, complain and scan expression
 181
 182          if Token in Token_Class_Literal
 183            or else Token = Tok_Left_Paren
 184          then
 185             Error_Msg_SC ("name expected");
 186             return P_Expression;
 187
 188          --  Otherwise some other junk, not much we can do
 189
 190          else
 191             Error_Msg_AP ("name expected");
 192             raise Error_Resync;
 193          end if;
 194       end if;
 195
 196       --  Loop through designators in qualified name
 197
 198       Name_Node := Token_Node;
 199
 200       loop
 201          Scan; -- past designator
 202          exit when Token /= Tok_Dot;
 203          Save_Scan_State (Scan_State); -- at dot
 204          Scan; -- past dot
 205
 206          --  If we do not have another designator after the dot, then join
 207          --  the normal circuit to handle a dot extension (may be .all or
 208          --  character literal case). Otherwise loop back to scan the next
 209          --  designator.
 210
 211          if Token not in Token_Class_Desig then
 212             goto Scan_Name_Extension_Dot;
 213          else
 214             Prefix_Node := Name_Node;
 215             Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
 216             Set_Prefix (Name_Node, Prefix_Node);
 217             Set_Selector_Name (Name_Node, Token_Node);
 218          end if;
 219       end loop;
 220
 221       --  We have now scanned out a qualified designator. If the last token is
 222       --  an operator symbol, then we certainly do not have the Snam case, so
 223       --  we can just use the normal name extension check circuit
 224
 225       if Prev_Token = Tok_Operator_Symbol then
 226          goto Scan_Name_Extension;
 227       end if;
 228
 229       --  We have scanned out a qualified simple name, check for name extension
 230       --  Note that we know there is no dot here at this stage, so the only
 231       --  possible cases of name extension are apostrophe and left paren.
 232
 233       if Token = Tok_Apostrophe then
 234          Save_Scan_State (Scan_State); -- at apostrophe
 235          Scan; -- past apostrophe
 236
 237          --  Qualified expression in Ada 2012 mode (treated as a name)
 238
 239          if Ada_Version >= Ada_2012 and then Token = Tok_Left_Paren then
 240             goto Scan_Name_Extension_Apostrophe;
 241
 242          --  If left paren not in Ada 2012, then it is not part of the name,
 243          --  since qualified expressions are not names in prior versions of
 244          --  Ada, so return with Token backed up to point to the apostrophe.
 245          --  The treatment for the range attribute is similar (we do not
 246          --  consider x'range to be a name in this grammar).
 247
 248          elsif Token = Tok_Left_Paren or else Token = Tok_Range then
 249             Restore_Scan_State (Scan_State); -- to apostrophe
 250             Expr_Form := EF_Simple_Name;
 251             return Name_Node;
 252
 253          --  Otherwise we have the case of a name extended by an attribute
 254
 255          else
 256             goto Scan_Name_Extension_Apostrophe;
 257          end if;
 258
 259       --  Check case of qualified simple name extended by a left parenthesis
 260
 261       elsif Token = Tok_Left_Paren then
 262          Scan; -- past left paren
 263          goto Scan_Name_Extension_Left_Paren;
 264
 265       --  Otherwise the qualified simple name is not extended, so return
 266
 267       else
 268          Expr_Form := EF_Simple_Name;
 269          return Name_Node;
 270       end if;
 271
 272       --  Loop scanning past name extensions. A label is used for control
 273       --  transfer for this loop for ease of interfacing with the finite state
 274       --  machine in the parenthesis scanning circuit, and also to allow for
 275       --  passing in control to the appropriate point from the above code.
 276
 277       <<Scan_Name_Extension>>
 278
 279          --  Character literal used as name cannot be extended. Also this
 280          --  cannot be a call, since the name for a call must be a designator.
 281          --  Return in these cases, or if there is no name extension
 282
 283          if Token not in Token_Class_Namext
 284            or else Prev_Token = Tok_Char_Literal
 285          then
 286             Expr_Form := EF_Name;
 287             return Name_Node;
 288          end if;
 289
 290       --  Merge here when we know there is a name extension
 291
 292       <<Scan_Name_Extension_OK>>
 293
 294          if Token = Tok_Left_Paren then
 295             Scan; -- past left paren
 296             goto Scan_Name_Extension_Left_Paren;
 297
 298          elsif Token = Tok_Apostrophe then
 299             Save_Scan_State (Scan_State); -- at apostrophe
 300             Scan; -- past apostrophe
 301             goto Scan_Name_Extension_Apostrophe;
 302
 303          else -- Token = Tok_Dot
 304             Save_Scan_State (Scan_State); -- at dot
 305             Scan; -- past dot
 306             goto Scan_Name_Extension_Dot;
 307          end if;
 308
 309       --  Case of name extended by dot (selection), dot is already skipped
 310       --  and the scan state at the point of the dot is saved in Scan_State.
 311
 312       <<Scan_Name_Extension_Dot>>
 313
 314          --  Explicit dereference case
 315
 316          if Token = Tok_All then
 317             Prefix_Node := Name_Node;
 318             Name_Node := New_Node (N_Explicit_Dereference, Token_Ptr);
 319             Set_Prefix (Name_Node, Prefix_Node);
 320             Scan; -- past ALL
 321             goto Scan_Name_Extension;
 322
 323          --  Selected component case
 324
 325          elsif Token in Token_Class_Name then
 326             Prefix_Node := Name_Node;
 327             Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
 328             Set_Prefix (Name_Node, Prefix_Node);
 329             Set_Selector_Name (Name_Node, Token_Node);
 330             Scan; -- past selector
 331             goto Scan_Name_Extension;
 332
 333          --  Reserved identifier as selector
 334
 335          elsif Is_Reserved_Identifier then
 336             Scan_Reserved_Identifier (Force_Msg => False);
 337             Prefix_Node := Name_Node;
 338             Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
 339             Set_Prefix (Name_Node, Prefix_Node);
 340             Set_Selector_Name (Name_Node, Token_Node);
 341             Scan; -- past identifier used as selector
 342             goto Scan_Name_Extension;
 343
 344          --  If dot is at end of line and followed by nothing legal,
 345          --  then assume end of name and quit (dot will be taken as
 346          --  an erroneous form of some other punctuation by our caller).
 347
 348          elsif Token_Is_At_Start_Of_Line then
 349             Restore_Scan_State (Scan_State);
 350             return Name_Node;
 351
 352          --  Here if nothing legal after the dot
 353
 354          else
 355             Error_Msg_AP ("selector expected");
 356             raise Error_Resync;
 357          end if;
 358
 359       --  Here for an apostrophe as name extension. The scan position at the
 360       --  apostrophe has already been saved, and the apostrophe scanned out.
 361
 362       <<Scan_Name_Extension_Apostrophe>>
 363
 364          Scan_Apostrophe : declare
 365             function Apostrophe_Should_Be_Semicolon return Boolean;
 366             --  Checks for case where apostrophe should probably be
 367             --  a semicolon, and if so, gives appropriate message,
 368             --  resets the scan pointer to the apostrophe, changes
 369             --  the current token to Tok_Semicolon, and returns True.
 370             --  Otherwise returns False.
 371
 372             ------------------------------------
 373             -- Apostrophe_Should_Be_Semicolon --
 374             ------------------------------------
 375
 376             function Apostrophe_Should_Be_Semicolon return Boolean is
 377             begin
 378                if Token_Is_At_Start_Of_Line then
 379                   Restore_Scan_State (Scan_State); -- to apostrophe
 380                   Error_Msg_SC ("|""''"" should be "";""");
 381                   Token := Tok_Semicolon;
 382                   return True;
 383                else
 384                   return False;
 385                end if;
 386             end Apostrophe_Should_Be_Semicolon;
 387
 388          --  Start of processing for Scan_Apostrophe
 389
 390          begin
 391             --  Check for qualified expression case in Ada 2012 mode
 392
 393             if Ada_Version >= Ada_2012 and then Token = Tok_Left_Paren then
 394                Name_Node := P_Qualified_Expression (Name_Node);
 395                goto Scan_Name_Extension;
 396
 397             --  If range attribute after apostrophe, then return with Token
 398             --  pointing to the apostrophe. Note that in this case the prefix
 399             --  need not be a simple name (cases like A.all'range). Similarly
 400             --  if there is a left paren after the apostrophe, then we also
 401             --  return with Token pointing to the apostrophe (this is the
 402             --  aggregate case, or some error case).
 403
 404             elsif Token = Tok_Range or else Token = Tok_Left_Paren then
 405                Restore_Scan_State (Scan_State); -- to apostrophe
 406                Expr_Form := EF_Name;
 407                return Name_Node;
 408
 409             --  Here for cases where attribute designator is an identifier
 410
 411             elsif Token = Tok_Identifier then
 412                Attr_Name := Token_Name;
 413
 414                if not Is_Attribute_Name (Attr_Name) then
 415                   if Apostrophe_Should_Be_Semicolon then
 416                      Expr_Form := EF_Name;
 417                      return Name_Node;
 418
 419                   --  Here for a bad attribute name
 420
 421                   else
 422                      Signal_Bad_Attribute;
 423                      Scan; -- past bad identifier
 424
 425                      if Token = Tok_Left_Paren then
 426                         Scan; -- past left paren
 427
 428                         loop
 429                            Discard_Junk_Node (P_Expression_If_OK);
 430                            exit when not  Comma_Present;
 431                         end loop;
 432
 433                         T_Right_Paren;
 434                      end if;
 435
 436                      return Error;
 437                   end if;
 438                end if;
 439
 440                if Style_Check then
 441                   Style.Check_Attribute_Name (False);
 442                end if;
 443
 444             --  Here for case of attribute designator is not an identifier
 445
 446             else
 447                if Token = Tok_Delta then
 448                   Attr_Name := Name_Delta;
 449
 450                elsif Token = Tok_Digits then
 451                   Attr_Name := Name_Digits;
 452
 453                elsif Token = Tok_Access then
 454                   Attr_Name := Name_Access;
 455
 456                elsif Token = Tok_Mod and then Ada_Version >= Ada_95 then
 457                   Attr_Name := Name_Mod;
 458
 459                elsif Apostrophe_Should_Be_Semicolon then
 460                   Expr_Form := EF_Name;
 461                   return Name_Node;
 462
 463                else
 464                   Error_Msg_AP ("attribute designator expected");
 465                   raise Error_Resync;
 466                end if;
 467
 468                if Style_Check then
 469                   Style.Check_Attribute_Name (True);
 470                end if;
 471             end if;
 472
 473             --  We come here with an OK attribute scanned, and the
 474             --  corresponding Attribute identifier node stored in Ident_Node.
 475
 476             Prefix_Node := Name_Node;
 477             Name_Node := New_Node (N_Attribute_Reference, Prev_Token_Ptr);
 478             Scan; -- past attribute designator
 479             Set_Prefix (Name_Node, Prefix_Node);
 480             Set_Attribute_Name (Name_Node, Attr_Name);
 481
 482             --  Scan attribute arguments/designator. We skip this if we know
 483             --  that the attribute cannot have an argument.
 484
 485             if Token = Tok_Left_Paren
 486               and then not
 487                 Is_Parameterless_Attribute (Get_Attribute_Id (Attr_Name))
 488             then
 489                Set_Expressions (Name_Node, New_List);
 490                Scan; -- past left paren
 491
 492                loop
 493                   declare
 494                      Expr : constant Node_Id := P_Expression_If_OK;
 495
 496                   begin
 497                      if Token = Tok_Arrow then
 498                         Error_Msg_SC
 499                           ("named parameters not permitted for attributes");
 500                         Scan; -- past junk arrow
 501
 502                      else
 503                         Append (Expr, Expressions (Name_Node));
 504                         exit when not Comma_Present;
 505                      end if;
 506                   end;
 507                end loop;
 508
 509                T_Right_Paren;
 510             end if;
 511
 512             goto Scan_Name_Extension;
 513          end Scan_Apostrophe;
 514
 515       --  Here for left parenthesis extending name (left paren skipped)
 516
 517       <<Scan_Name_Extension_Left_Paren>>
 518
 519          --  We now have to scan through a list of items, terminated by a
 520          --  right parenthesis. The scan is handled by a finite state
 521          --  machine. The possibilities are:
 522
 523          --   (discrete_range)
 524
 525          --      This is a slice. This case is handled in LP_State_Init
 526
 527          --   (expression, expression, ..)
 528
 529          --      This is interpreted as an indexed component, i.e. as a
 530          --      case of a name which can be extended in the normal manner.
 531          --      This case is handled by LP_State_Name or LP_State_Expr.
 532
 533          --      Note: conditional expressions (without an extra level of
 534          --      parentheses) are permitted in this context).
 535
 536          --   (..., identifier => expression , ...)
 537
 538          --      If there is at least one occurrence of identifier => (but
 539          --      none of the other cases apply), then we have a call.
 540
 541          --  Test for Id => case
 542
 543          if Token = Tok_Identifier then
 544             Save_Scan_State (Scan_State); -- at Id
 545             Scan; -- past Id
 546
 547             --  Test for => (allow := as an error substitute)
 548
 549             if Token = Tok_Arrow or else Token = Tok_Colon_Equal then
 550                Restore_Scan_State (Scan_State); -- to Id
 551                Arg_List := New_List;
 552                goto LP_State_Call;
 553
 554             else
 555                Restore_Scan_State (Scan_State); -- to Id
 556             end if;
 557          end if;
 558
 559          --  Here we have an expression after all
 560
 561          Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
 562
 563          --  Check cases of discrete range for a slice
 564
 565          --  First possibility: Range_Attribute_Reference
 566
 567          if Expr_Form = EF_Range_Attr then
 568             Range_Node := Expr_Node;
 569
 570          --  Second possibility: Simple_expression .. Simple_expression
 571
 572          elsif Token = Tok_Dot_Dot then
 573             Check_Simple_Expression (Expr_Node);
 574             Range_Node := New_Node (N_Range, Token_Ptr);
 575             Set_Low_Bound (Range_Node, Expr_Node);
 576             Scan; -- past ..
 577             Expr_Node := P_Expression;
 578             Check_Simple_Expression (Expr_Node);
 579             Set_High_Bound (Range_Node, Expr_Node);
 580
 581          --  Third possibility: Type_name range Range
 582
 583          elsif Token = Tok_Range then
 584             if Expr_Form /= EF_Simple_Name then
 585                Error_Msg_SC ("subtype mark must precede RANGE");
 586                raise Error_Resync;
 587             end if;
 588
 589             Range_Node := P_Subtype_Indication (Expr_Node);
 590
 591          --  Otherwise we just have an expression. It is true that we might
 592          --  have a subtype mark without a range constraint but this case
 593          --  is syntactically indistinguishable from the expression case.
 594
 595          else
 596             Arg_List := New_List;
 597             goto LP_State_Expr;
 598          end if;
 599
 600          --  Fall through here with unmistakable Discrete range scanned,
 601          --  which means that we definitely have the case of a slice. The
 602          --  Discrete range is in Range_Node.
 603
 604          if Token = Tok_Comma then
 605             Error_Msg_SC ("slice cannot have more than one dimension");
 606             raise Error_Resync;
 607
 608          elsif Token /= Tok_Right_Paren then
 609             T_Right_Paren;
 610             raise Error_Resync;
 611
 612          else
 613             Scan; -- past right paren
 614             Prefix_Node := Name_Node;
 615             Name_Node := New_Node (N_Slice, Sloc (Prefix_Node));
 616             Set_Prefix (Name_Node, Prefix_Node);
 617             Set_Discrete_Range (Name_Node, Range_Node);
 618
 619             --  An operator node is legal as a prefix to other names,
 620             --  but not for a slice.
 621
 622             if Nkind (Prefix_Node) = N_Operator_Symbol then
 623                Error_Msg_N ("illegal prefix for slice", Prefix_Node);
 624             end if;
 625
 626             --  If we have a name extension, go scan it
 627
 628             if Token in Token_Class_Namext then
 629                goto Scan_Name_Extension_OK;
 630
 631             --  Otherwise return (a slice is a name, but is not a call)
 632
 633             else
 634                Expr_Form := EF_Name;
 635                return Name_Node;
 636             end if;
 637          end if;
 638
 639       --  In LP_State_Expr, we have scanned one or more expressions, and
 640       --  so we have a call or an indexed component which is a name. On
 641       --  entry we have the expression just scanned in Expr_Node and
 642       --  Arg_List contains the list of expressions encountered so far
 643
 644       <<LP_State_Expr>>
 645          Append (Expr_Node, Arg_List);
 646
 647          if Token = Tok_Arrow then
 648             Error_Msg
 649               ("expect identifier in parameter association",
 650                 Sloc (Expr_Node));
 651             Scan;  --   past arrow
 652
 653          elsif not Comma_Present then
 654             T_Right_Paren;
 655             Prefix_Node := Name_Node;
 656             Name_Node := New_Node (N_Indexed_Component, Sloc (Prefix_Node));
 657             Set_Prefix (Name_Node, Prefix_Node);
 658             Set_Expressions (Name_Node, Arg_List);
 659             goto Scan_Name_Extension;
 660          end if;
 661
 662          --  Comma present (and scanned out), test for identifier => case
 663          --  Test for identifier => case
 664
 665          if Token = Tok_Identifier then
 666             Save_Scan_State (Scan_State); -- at Id
 667             Scan; -- past Id
 668
 669             --  Test for => (allow := as error substitute)
 670
 671             if Token = Tok_Arrow or else Token = Tok_Colon_Equal then
 672                Restore_Scan_State (Scan_State); -- to Id
 673                goto LP_State_Call;
 674
 675             --  Otherwise it's just an expression after all, so backup
 676
 677             else
 678                Restore_Scan_State (Scan_State); -- to Id
 679             end if;
 680          end if;
 681
 682          --  Here we have an expression after all, so stay in this state
 683
 684          Expr_Node := P_Expression_If_OK;
 685          goto LP_State_Expr;
 686
 687       --  LP_State_Call corresponds to the situation in which at least
 688       --  one instance of Id => Expression has been encountered, so we
 689       --  know that we do not have a name, but rather a call. We enter
 690       --  it with the scan pointer pointing to the next argument to scan,
 691       --  and Arg_List containing the list of arguments scanned so far.
 692
 693       <<LP_State_Call>>
 694
 695          --  Test for case of Id => Expression (named parameter)
 696
 697          if Token = Tok_Identifier then
 698             Save_Scan_State (Scan_State); -- at Id
 699             Ident_Node := Token_Node;
 700             Scan; -- past Id
 701
 702             --  Deal with => (allow := as erroneous substitute)
 703
 704             if Token = Tok_Arrow or else Token = Tok_Colon_Equal then
 705                Arg_Node := New_Node (N_Parameter_Association, Prev_Token_Ptr);
 706                Set_Selector_Name (Arg_Node, Ident_Node);
 707                T_Arrow;
 708                Set_Explicit_Actual_Parameter (Arg_Node, P_Expression);
 709                Append (Arg_Node, Arg_List);
 710
 711                --  If a comma follows, go back and scan next entry
 712
 713                if Comma_Present then
 714                   goto LP_State_Call;
 715
 716                --  Otherwise we have the end of a call
 717
 718                else
 719                   Prefix_Node := Name_Node;
 720                   Name_Node := New_Node (N_Function_Call, Sloc (Prefix_Node));
 721                   Set_Name (Name_Node, Prefix_Node);
 722                   Set_Parameter_Associations (Name_Node, Arg_List);
 723                   T_Right_Paren;
 724
 725                   if Token in Token_Class_Namext then
 726                      goto Scan_Name_Extension_OK;
 727
 728                   --  This is a case of a call which cannot be a name
 729
 730                   else
 731                      Expr_Form := EF_Name;
 732                      return Name_Node;
 733                   end if;
 734                end if;
 735
 736             --  Not named parameter: Id started an expression after all
 737
 738             else
 739                Restore_Scan_State (Scan_State); -- to Id
 740             end if;
 741          end if;
 742
 743          --  Here if entry did not start with Id => which means that it
 744          --  is a positional parameter, which is not allowed, since we
 745          --  have seen at least one named parameter already.
 746
 747          Error_Msg_SC
 748             ("positional parameter association " &
 749               "not allowed after named one");
 750
 751          Expr_Node := P_Expression_If_OK;
 752
 753          --  Leaving the '>' in an association is not unusual, so suggest
 754          --  a possible fix.
 755
 756          if Nkind (Expr_Node) = N_Op_Eq then
 757             Error_Msg_N ("\maybe `='>` was intended", Expr_Node);
 758          end if;
 759
 760          --  We go back to scanning out expressions, so that we do not get
 761          --  multiple error messages when several positional parameters
 762          --  follow a named parameter.
 763
 764          goto LP_State_Expr;
 765
 766          --  End of treatment for name extensions starting with left paren
 767
 768       --  End of loop through name extensions
 769
 770    end P_Name;
 771
 772    --  This function parses a restricted form of Names which are either
 773    --  designators, or designators preceded by a sequence of prefixes
 774    --  that are direct names.
 775
 776    --  Error recovery: cannot raise Error_Resync
 777
 778    function P_Function_Name return Node_Id is
 779       Designator_Node : Node_Id;
 780       Prefix_Node     : Node_Id;
 781       Selector_Node   : Node_Id;
 782       Dot_Sloc        : Source_Ptr := No_Location;
 783
 784    begin
 785       --  Prefix_Node is set to the gathered prefix so far, Empty means that
 786       --  no prefix has been scanned. This allows us to build up the result
 787       --  in the required right recursive manner.
 788
 789       Prefix_Node := Empty;
 790
 791       --  Loop through prefixes
 792
 793       loop
 794          Designator_Node := Token_Node;
 795
 796          if Token not in Token_Class_Desig then
 797             return P_Identifier; -- let P_Identifier issue the error message
 798
 799          else -- Token in Token_Class_Desig
 800             Scan; -- past designator
 801             exit when Token /= Tok_Dot;
 802          end if;
 803
 804          --  Here at a dot, with token just before it in Designator_Node
 805
 806          if No (Prefix_Node) then
 807             Prefix_Node := Designator_Node;
 808          else
 809             Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
 810             Set_Prefix (Selector_Node, Prefix_Node);
 811             Set_Selector_Name (Selector_Node, Designator_Node);
 812             Prefix_Node := Selector_Node;
 813          end if;
 814
 815          Dot_Sloc := Token_Ptr;
 816          Scan; -- past dot
 817       end loop;
 818
 819       --  Fall out of the loop having just scanned a designator
 820
 821       if No (Prefix_Node) then
 822          return Designator_Node;
 823       else
 824          Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
 825          Set_Prefix (Selector_Node, Prefix_Node);
 826          Set_Selector_Name (Selector_Node, Designator_Node);
 827          return Selector_Node;
 828       end if;
 829
 830    exception
 831       when Error_Resync =>
 832          return Error;
 833    end P_Function_Name;
 834
 835    --  This function parses a restricted form of Names which are either
 836    --  identifiers, or identifiers preceded by a sequence of prefixes
 837    --  that are direct names.
 838
 839    --  Error recovery: cannot raise Error_Resync
 840
 841    function P_Qualified_Simple_Name return Node_Id is
 842       Designator_Node : Node_Id;
 843       Prefix_Node     : Node_Id;
 844       Selector_Node   : Node_Id;
 845       Dot_Sloc        : Source_Ptr := No_Location;
 846
 847    begin
 848       --  Prefix node is set to the gathered prefix so far, Empty means that
 849       --  no prefix has been scanned. This allows us to build up the result
 850       --  in the required right recursive manner.
 851
 852       Prefix_Node := Empty;
 853
 854       --  Loop through prefixes
 855
 856       loop
 857          Designator_Node := Token_Node;
 858
 859          if Token = Tok_Identifier then
 860             Scan; -- past identifier
 861             exit when Token /= Tok_Dot;
 862
 863          elsif Token not in Token_Class_Desig then
 864             return P_Identifier; -- let P_Identifier issue the error message
 865
 866          else
 867             Scan; -- past designator
 868
 869             if Token /= Tok_Dot then
 870                Error_Msg_SP ("identifier expected");
 871                return Error;
 872             end if;
 873          end if;
 874
 875          --  Here at a dot, with token just before it in Designator_Node
 876
 877          if No (Prefix_Node) then
 878             Prefix_Node := Designator_Node;
 879          else
 880             Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
 881             Set_Prefix (Selector_Node, Prefix_Node);
 882             Set_Selector_Name (Selector_Node, Designator_Node);
 883             Prefix_Node := Selector_Node;
 884          end if;
 885
 886          Dot_Sloc := Token_Ptr;
 887          Scan; -- past dot
 888       end loop;
 889
 890       --  Fall out of the loop having just scanned an identifier
 891
 892       if No (Prefix_Node) then
 893          return Designator_Node;
 894       else
 895          Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
 896          Set_Prefix (Selector_Node, Prefix_Node);
 897          Set_Selector_Name (Selector_Node, Designator_Node);
 898          return Selector_Node;
 899       end if;
 900
 901    exception
 902       when Error_Resync =>
 903          return Error;
 904    end P_Qualified_Simple_Name;
 905
 906    --  This procedure differs from P_Qualified_Simple_Name only in that it
 907    --  raises Error_Resync if any error is encountered. It only returns after
 908    --  scanning a valid qualified simple name.
 909
 910    --  Error recovery: can raise Error_Resync
 911
 912    function P_Qualified_Simple_Name_Resync return Node_Id is
 913       Designator_Node : Node_Id;
 914       Prefix_Node     : Node_Id;
 915       Selector_Node   : Node_Id;
 916       Dot_Sloc        : Source_Ptr := No_Location;
 917
 918    begin
 919       Prefix_Node := Empty;
 920
 921       --  Loop through prefixes
 922
 923       loop
 924          Designator_Node := Token_Node;
 925
 926          if Token = Tok_Identifier then
 927             Scan; -- past identifier
 928             exit when Token /= Tok_Dot;
 929
 930          elsif Token not in Token_Class_Desig then
 931             Discard_Junk_Node (P_Identifier); -- to issue the error message
 932             raise Error_Resync;
 933
 934          else
 935             Scan; -- past designator
 936
 937             if Token /= Tok_Dot then
 938                Error_Msg_SP ("identifier expected");
 939                raise Error_Resync;
 940             end if;
 941          end if;
 942
 943          --  Here at a dot, with token just before it in Designator_Node
 944
 945          if No (Prefix_Node) then
 946             Prefix_Node := Designator_Node;
 947          else
 948             Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
 949             Set_Prefix (Selector_Node, Prefix_Node);
 950             Set_Selector_Name (Selector_Node, Designator_Node);
 951             Prefix_Node := Selector_Node;
 952          end if;
 953
 954          Dot_Sloc := Token_Ptr;
 955          Scan; -- past period
 956       end loop;
 957
 958       --  Fall out of the loop having just scanned an identifier
 959
 960       if No (Prefix_Node) then
 961          return Designator_Node;
 962       else
 963          Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
 964          Set_Prefix (Selector_Node, Prefix_Node);
 965          Set_Selector_Name (Selector_Node, Designator_Node);
 966          return Selector_Node;
 967       end if;
 968    end P_Qualified_Simple_Name_Resync;
 969
 970    ----------------------
 971    -- 4.1  Direct_Name --
 972    ----------------------
 973
 974    --  Parsed by P_Name and other functions in section 4.1
 975
 976    -----------------
 977    -- 4.1  Prefix --
 978    -----------------
 979
 980    --  Parsed by P_Name (4.1)
 981
 982    -------------------------------
 983    -- 4.1  Explicit Dereference --
 984    -------------------------------
 985
 986    --  Parsed by P_Name (4.1)
 987
 988    -------------------------------
 989    -- 4.1  Implicit_Dereference --
 990    -------------------------------
 991
 992    --  Parsed by P_Name (4.1)
 993
 994    ----------------------------
 995    -- 4.1  Indexed Component --
 996    ----------------------------
 997
 998    --  Parsed by P_Name (4.1)
 999
1000    ----------------
1001    -- 4.1  Slice --
1002    ----------------
1003
1004    --  Parsed by P_Name (4.1)
1005
1006    -----------------------------
1007    -- 4.1  Selected_Component --
1008    -----------------------------
1009
1010    --  Parsed by P_Name (4.1)
1011
1012    ------------------------
1013    -- 4.1  Selector Name --
1014    ------------------------
1015
1016    --  Parsed by P_Name (4.1)
1017
1018    ------------------------------
1019    -- 4.1  Attribute Reference --
1020    ------------------------------
1021
1022    --  Parsed by P_Name (4.1)
1023
1024    -------------------------------
1025    -- 4.1  Attribute Designator --
1026    -------------------------------
1027
1028    --  Parsed by P_Name (4.1)
1029
1030    --------------------------------------
1031    -- 4.1.4  Range Attribute Reference --
1032    --------------------------------------
1033
1034    --  RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR
1035
1036    --  RANGE_ATTRIBUTE_DESIGNATOR ::= range [(static_EXPRESSION)]
1037
1038    --  In the grammar, a RANGE attribute is simply a name, but its use is
1039    --  highly restricted, so in the parser, we do not regard it as a name.
1040    --  Instead, P_Name returns without scanning the 'RANGE part of the
1041    --  attribute, and the caller uses the following function to construct
1042    --  a range attribute in places where it is appropriate.
1043
1044    --  Note that RANGE here is treated essentially as an identifier,
1045    --  rather than a reserved word.
1046
1047    --  The caller has parsed the prefix, i.e. a name, and Token points to
1048    --  the apostrophe. The token after the apostrophe is known to be RANGE
1049    --  at this point. The prefix node becomes the prefix of the attribute.
1050
1051    --  Error_Recovery: Cannot raise Error_Resync
1052
1053    function P_Range_Attribute_Reference
1054      (Prefix_Node : Node_Id)
1055       return        Node_Id
1056    is
1057       Attr_Node  : Node_Id;
1058
1059    begin
1060       Attr_Node := New_Node (N_Attribute_Reference, Token_Ptr);
1061       Set_Prefix (Attr_Node, Prefix_Node);
1062       Scan; -- past apostrophe
1063
1064       if Style_Check then
1065          Style.Check_Attribute_Name (True);
1066       end if;
1067
1068       Set_Attribute_Name (Attr_Node, Name_Range);
1069       Scan; -- past RANGE
1070
1071       if Token = Tok_Left_Paren then
1072          Scan; -- past left paren
1073          Set_Expressions (Attr_Node, New_List (P_Expression_If_OK));
1074          T_Right_Paren;
1075       end if;
1076
1077       return Attr_Node;
1078    end P_Range_Attribute_Reference;
1079
1080    ---------------------------------------
1081    -- 4.1.4  Range Attribute Designator --
1082    ---------------------------------------
1083
1084    --  Parsed by P_Range_Attribute_Reference (4.4)
1085
1086    --------------------
1087    -- 4.3  Aggregate --
1088    --------------------
1089
1090    --  AGGREGATE ::= RECORD_AGGREGATE | EXTENSION_AGGREGATE | ARRAY_AGGREGATE
1091
1092    --  Parsed by P_Aggregate_Or_Paren_Expr (4.3), except in the case where
1093    --  an aggregate is known to be required (code statement, extension
1094    --  aggregate), in which cases this routine performs the necessary check
1095    --  that we have an aggregate rather than a parenthesized expression
1096
1097    --  Error recovery: can raise Error_Resync
1098
1099    function P_Aggregate return Node_Id is
1100       Aggr_Sloc : constant Source_Ptr := Token_Ptr;
1101       Aggr_Node : constant Node_Id    := P_Aggregate_Or_Paren_Expr;
1102
1103    begin
1104       if Nkind (Aggr_Node) /= N_Aggregate
1105            and then
1106          Nkind (Aggr_Node) /= N_Extension_Aggregate
1107       then
1108          Error_Msg
1109            ("aggregate may not have single positional component", Aggr_Sloc);
1110          return Error;
1111       else
1112          return Aggr_Node;
1113       end if;
1114    end P_Aggregate;
1115
1116    ------------------------------------------------
1117    -- 4.3  Aggregate or Parenthesized Expression --
1118    ------------------------------------------------
1119
1120    --  This procedure parses out either an aggregate or a parenthesized
1121    --  expression (these two constructs are closely related, since a
1122    --  parenthesized expression looks like an aggregate with a single
1123    --  positional component).
1124
1125    --  AGGREGATE ::=
1126    --    RECORD_AGGREGATE | EXTENSION_AGGREGATE | ARRAY_AGGREGATE
1127
1128    --  RECORD_AGGREGATE ::= (RECORD_COMPONENT_ASSOCIATION_LIST)
1129
1130    --  RECORD_COMPONENT_ASSOCIATION_LIST ::=
1131    --     RECORD_COMPONENT_ASSOCIATION {, RECORD_COMPONENT_ASSOCIATION}
1132    --   | null record
1133
1134    --  RECORD_COMPONENT_ASSOCIATION ::=
1135    --    [COMPONENT_CHOICE_LIST =>] EXPRESSION
1136
1137    --  COMPONENT_CHOICE_LIST ::=
1138    --    component_SELECTOR_NAME {| component_SELECTOR_NAME}
1139    --  | others
1140
1141    --  EXTENSION_AGGREGATE ::=
1142    --    (ANCESTOR_PART with RECORD_COMPONENT_ASSOCIATION_LIST)
1143
1144    --  ANCESTOR_PART ::= EXPRESSION | SUBTYPE_MARK
1145
1146    --  ARRAY_AGGREGATE ::=
1147    --    POSITIONAL_ARRAY_AGGREGATE | NAMED_ARRAY_AGGREGATE
1148
1149    --  POSITIONAL_ARRAY_AGGREGATE ::=
1150    --    (EXPRESSION, EXPRESSION {, EXPRESSION})
1151    --  | (EXPRESSION {, EXPRESSION}, others => EXPRESSION)
1152    --  | (EXPRESSION {, EXPRESSION}, others => <>)
1153
1154    --  NAMED_ARRAY_AGGREGATE ::=
1155    --    (ARRAY_COMPONENT_ASSOCIATION {, ARRAY_COMPONENT_ASSOCIATION})
1156
1157    --  PRIMARY ::= (EXPRESSION);
1158
1159    --  Error recovery: can raise Error_Resync
1160
1161    --  Note: POSITIONAL_ARRAY_AGGREGATE rule has been extended to give support
1162    --        to Ada 2005 limited aggregates (AI-287)
1163
1164    function P_Aggregate_Or_Paren_Expr return Node_Id is
1165       Aggregate_Node : Node_Id;
1166       Expr_List      : List_Id;
1167       Assoc_List     : List_Id;
1168       Expr_Node      : Node_Id;
1169       Lparen_Sloc    : Source_Ptr;
1170       Scan_State     : Saved_Scan_State;
1171
1172       procedure Box_Error;
1173       --  Called if <> is encountered as positional aggregate element. Issues
1174       --  error message and sets Expr_Node to Error.
1175
1176       ---------------
1177       -- Box_Error --
1178       ---------------
1179
1180       procedure Box_Error is
1181       begin
1182          if Ada_Version < Ada_2005 then
1183             Error_Msg_SC ("box in aggregate is an Ada 2005 extension");
1184          end if;
1185
1186          --  Ada 2005 (AI-287): The box notation is allowed only with named
1187          --  notation because positional notation might be error prone. For
1188          --  example, in "(X, <>, Y, <>)", there is no type associated with
1189          --  the boxes, so you might not be leaving out the components you
1190          --  thought you were leaving out.
1191
1192          Error_Msg_SC ("(Ada 2005) box only allowed with named notation");
1193          Scan; -- past box
1194          Expr_Node := Error;
1195       end Box_Error;
1196
1197    --  Start of processsing for P_Aggregate_Or_Paren_Expr
1198
1199    begin
1200       Lparen_Sloc := Token_Ptr;
1201       T_Left_Paren;
1202
1203       --  Conditional expression case
1204
1205       if Token = Tok_If then
1206          Expr_Node := P_Conditional_Expression;
1207          T_Right_Paren;
1208          return Expr_Node;
1209
1210       --  Case expression case
1211
1212       elsif Token = Tok_Case then
1213          Expr_Node := P_Case_Expression;
1214          T_Right_Paren;
1215          return Expr_Node;
1216
1217       --  Quantified expression case
1218
1219       elsif Token = Tok_For then
1220          Expr_Node := P_Quantified_Expression;
1221          T_Right_Paren;
1222          return Expr_Node;
1223
1224       --  Note: the mechanism used here of rescanning the initial expression
1225       --  is distinctly unpleasant, but it saves a lot of fiddling in scanning
1226       --  out the discrete choice list.
1227
1228       --  Deal with expression and extension aggregate cases first
1229
1230       elsif Token /= Tok_Others then
1231          Save_Scan_State (Scan_State); -- at start of expression
1232
1233          --  Deal with (NULL RECORD) case
1234
1235          if Token = Tok_Null then
1236             Scan; -- past NULL
1237
1238             if Token = Tok_Record then
1239                Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
1240                Set_Null_Record_Present (Aggregate_Node, True);
1241                Scan; -- past RECORD
1242                T_Right_Paren;
1243                return Aggregate_Node;
1244             else
1245                Restore_Scan_State (Scan_State); -- to NULL that must be expr
1246             end if;
1247          end if;
1248
1249          --  Scan expression, handling box appearing as positional argument
1250
1251          if Token = Tok_Box then
1252             Box_Error;
1253          else
1254             Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
1255          end if;
1256
1257          --  Extension aggregate case
1258
1259          if Token = Tok_With then
1260             if Nkind (Expr_Node) = N_Attribute_Reference
1261               and then Attribute_Name (Expr_Node) = Name_Range
1262             then
1263                Bad_Range_Attribute (Sloc (Expr_Node));
1264                return Error;
1265             end if;
1266
1267             if Ada_Version = Ada_83 then
1268                Error_Msg_SC ("(Ada 83) extension aggregate not allowed");
1269             end if;
1270
1271             Aggregate_Node := New_Node (N_Extension_Aggregate, Lparen_Sloc);
1272             Set_Ancestor_Part (Aggregate_Node, Expr_Node);
1273             Scan; -- past WITH
1274
1275             --  Deal with WITH NULL RECORD case
1276
1277             if Token = Tok_Null then
1278                Save_Scan_State (Scan_State); -- at NULL
1279                Scan; -- past NULL
1280
1281                if Token = Tok_Record then
1282                   Scan; -- past RECORD
1283                   Set_Null_Record_Present (Aggregate_Node, True);
1284                   T_Right_Paren;
1285                   return Aggregate_Node;
1286
1287                else
1288                   Restore_Scan_State (Scan_State); -- to NULL that must be expr
1289                end if;
1290             end if;
1291
1292             if Token /= Tok_Others then
1293                Save_Scan_State (Scan_State);
1294                Expr_Node := P_Expression;
1295             else
1296                Expr_Node := Empty;
1297             end if;
1298
1299          --  Expression case
1300
1301          elsif Token = Tok_Right_Paren or else Token in Token_Class_Eterm then
1302             if Nkind (Expr_Node) = N_Attribute_Reference
1303               and then Attribute_Name (Expr_Node) = Name_Range
1304             then
1305                Error_Msg
1306                  ("|parentheses not allowed for range attribute", Lparen_Sloc);
1307                Scan; -- past right paren
1308                return Expr_Node;
1309             end if;
1310
1311             --  Bump paren count of expression
1312
1313             if Expr_Node /= Error then
1314                Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1);
1315             end if;
1316
1317             T_Right_Paren; -- past right paren (error message if none)
1318             return Expr_Node;
1319
1320          --  Normal aggregate case
1321
1322          else
1323             Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
1324          end if;
1325
1326       --  Others case
1327
1328       else
1329          Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
1330          Expr_Node := Empty;
1331       end if;
1332
1333       --  Prepare to scan list of component associations
1334
1335       Expr_List  := No_List; -- don't set yet, maybe all named entries
1336       Assoc_List := No_List; -- don't set yet, maybe all positional entries
1337
1338       --  This loop scans through component associations. On entry to the
1339       --  loop, an expression has been scanned at the start of the current
1340       --  association unless initial token was OTHERS, in which case
1341       --  Expr_Node is set to Empty.
1342
1343       loop
1344          --  Deal with others association first. This is a named association
1345
1346          if No (Expr_Node) then
1347             if No (Assoc_List) then
1348                Assoc_List := New_List;
1349             end if;
1350
1351             Append (P_Record_Or_Array_Component_Association, Assoc_List);
1352
1353          --  Improper use of WITH
1354
1355          elsif Token = Tok_With then
1356             Error_Msg_SC ("WITH must be preceded by single expression in " &
1357                              "extension aggregate");
1358             raise Error_Resync;
1359
1360          --  Range attribute can only appear as part of a discrete choice list
1361
1362          elsif Nkind (Expr_Node) = N_Attribute_Reference
1363            and then Attribute_Name (Expr_Node) = Name_Range
1364            and then Token /= Tok_Arrow
1365            and then Token /= Tok_Vertical_Bar
1366          then
1367             Bad_Range_Attribute (Sloc (Expr_Node));
1368             return Error;
1369
1370          --  Assume positional case if comma, right paren, or literal or
1371          --  identifier or OTHERS follows (the latter cases are missing
1372          --  comma cases). Also assume positional if a semicolon follows,
1373          --  which can happen if there are missing parens
1374
1375          elsif Token = Tok_Comma
1376            or else Token = Tok_Right_Paren
1377            or else Token = Tok_Others
1378            or else Token in Token_Class_Lit_Or_Name
1379            or else Token = Tok_Semicolon
1380          then
1381             if Present (Assoc_List) then
1382                Error_Msg_BC -- CODEFIX
1383                   ("""='>"" expected (positional association cannot follow " &
1384                    "named association)");
1385             end if;
1386
1387             if No (Expr_List) then
1388                Expr_List := New_List;
1389             end if;
1390
1391             Append (Expr_Node, Expr_List);
1392
1393          --  Check for aggregate followed by left parent, maybe missing comma
1394
1395          elsif Nkind (Expr_Node) = N_Aggregate
1396            and then Token = Tok_Left_Paren
1397          then
1398             T_Comma;
1399
1400             if No (Expr_List) then
1401                Expr_List := New_List;
1402             end if;
1403
1404             Append (Expr_Node, Expr_List);
1405
1406          --  Anything else is assumed to be a named association
1407
1408          else
1409             Restore_Scan_State (Scan_State); -- to start of expression
1410
1411             if No (Assoc_List) then
1412                Assoc_List := New_List;
1413             end if;
1414
1415             Append (P_Record_Or_Array_Component_Association, Assoc_List);
1416          end if;
1417
1418          exit when not Comma_Present;
1419
1420          --  If we are at an expression terminator, something is seriously
1421          --  wrong, so let's get out now, before we start eating up stuff
1422          --  that doesn't belong to us!
1423
1424          if Token in Token_Class_Eterm then
1425
1426             --  If Some becomes a keyword, the following is needed to make it
1427             --  acceptable in older versions of Ada.
1428
1429             if Token = Tok_Some
1430               and then Ada_Version < Ada_2012
1431             then
1432                Scan_Reserved_Identifier (False);
1433             else
1434                Error_Msg_AP
1435                  ("expecting expression or component association");
1436                exit;
1437             end if;
1438          end if;
1439
1440          --  Deal with misused box
1441
1442          if Token = Tok_Box then
1443             Box_Error;
1444
1445          --  Otherwise initiate for reentry to top of loop by scanning an
1446          --  initial expression, unless the first token is OTHERS.
1447
1448          elsif Token = Tok_Others then
1449             Expr_Node := Empty;
1450
1451          else
1452             Save_Scan_State (Scan_State); -- at start of expression
1453             Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
1454
1455          end if;
1456       end loop;
1457
1458       --  All component associations (positional and named) have been scanned
1459
1460       T_Right_Paren;
1461       Set_Expressions (Aggregate_Node, Expr_List);
1462       Set_Component_Associations (Aggregate_Node, Assoc_List);
1463       return Aggregate_Node;
1464    end P_Aggregate_Or_Paren_Expr;
1465
1466    ------------------------------------------------
1467    -- 4.3  Record or Array Component Association --
1468    ------------------------------------------------
1469
1470    --  RECORD_COMPONENT_ASSOCIATION ::=
1471    --    [COMPONENT_CHOICE_LIST =>] EXPRESSION
1472    --  | COMPONENT_CHOICE_LIST => <>
1473
1474    --  COMPONENT_CHOICE_LIST =>
1475    --    component_SELECTOR_NAME {| component_SELECTOR_NAME}
1476    --  | others
1477
1478    --  ARRAY_COMPONENT_ASSOCIATION ::=
1479    --    DISCRETE_CHOICE_LIST => EXPRESSION
1480    --  | DISCRETE_CHOICE_LIST => <>
1481
1482    --  Note: this routine only handles the named cases, including others.
1483    --  Cases where the component choice list is not present have already
1484    --  been handled directly.
1485
1486    --  Error recovery: can raise Error_Resync
1487
1488    --  Note: RECORD_COMPONENT_ASSOCIATION and ARRAY_COMPONENT_ASSOCIATION
1489    --        rules have been extended to give support to Ada 2005 limited
1490    --        aggregates (AI-287)
1491
1492    function P_Record_Or_Array_Component_Association return Node_Id is
1493       Assoc_Node : Node_Id;
1494
1495    begin
1496       Assoc_Node := New_Node (N_Component_Association, Token_Ptr);
1497       Set_Choices (Assoc_Node, P_Discrete_Choice_List);
1498       Set_Sloc (Assoc_Node, Token_Ptr);
1499       TF_Arrow;
1500
1501       if Token = Tok_Box then
1502
1503          --  Ada 2005(AI-287): The box notation is used to indicate the
1504          --  default initialization of aggregate components
1505
1506          if Ada_Version < Ada_2005 then
1507             Error_Msg_SP
1508               ("component association with '<'> is an Ada 2005 extension");
1509             Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1510          end if;
1511
1512          Set_Box_Present (Assoc_Node);
1513          Scan; -- Past box
1514       else
1515          Set_Expression (Assoc_Node, P_Expression);
1516       end if;
1517
1518       return Assoc_Node;
1519    end P_Record_Or_Array_Component_Association;
1520
1521    -----------------------------
1522    -- 4.3.1  Record Aggregate --
1523    -----------------------------
1524
1525    --  Case of enumeration aggregate is parsed by P_Aggregate (4.3)
1526    --  All other cases are parsed by P_Aggregate_Or_Paren_Expr (4.3)
1527
1528    ----------------------------------------------
1529    -- 4.3.1  Record Component Association List --
1530    ----------------------------------------------
1531
1532    --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1533
1534    ----------------------------------
1535    -- 4.3.1  Component Choice List --
1536    ----------------------------------
1537
1538    --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1539
1540    --------------------------------
1541    -- 4.3.1  Extension Aggregate --
1542    --------------------------------
1543
1544    --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1545
1546    --------------------------
1547    -- 4.3.1  Ancestor Part --
1548    --------------------------
1549
1550    --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1551
1552    ----------------------------
1553    -- 4.3.1  Array Aggregate --
1554    ----------------------------
1555
1556    --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1557
1558    ---------------------------------------
1559    -- 4.3.1  Positional Array Aggregate --
1560    ---------------------------------------
1561
1562    --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1563
1564    ----------------------------------
1565    -- 4.3.1  Named Array Aggregate --
1566    ----------------------------------
1567
1568    --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1569
1570    ----------------------------------------
1571    -- 4.3.1  Array Component Association --
1572    ----------------------------------------
1573
1574    --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1575
1576    ---------------------
1577    -- 4.4  Expression --
1578    ---------------------
1579
1580    --  EXPRESSION ::=
1581    --    RELATION {and RELATION} | RELATION {and then RELATION}
1582    --  | RELATION {or RELATION}  | RELATION {or else RELATION}
1583    --  | RELATION {xor RELATION}
1584
1585    --  On return, Expr_Form indicates the categorization of the expression
1586    --  EF_Range_Attr is not a possible value (if a range attribute is found,
1587    --  an error message is given, and Error is returned).
1588
1589    --  Error recovery: cannot raise Error_Resync
1590
1591    function P_Expression return Node_Id is
1592       Logical_Op      : Node_Kind;
1593       Prev_Logical_Op : Node_Kind;
1594       Op_Location     : Source_Ptr;
1595       Node1           : Node_Id;
1596       Node2           : Node_Id;
1597
1598    begin
1599       Node1 := P_Relation;
1600
1601       if Token in Token_Class_Logop then
1602          Prev_Logical_Op := N_Empty;
1603
1604          loop
1605             Op_Location := Token_Ptr;
1606             Logical_Op := P_Logical_Operator;
1607
1608             if Prev_Logical_Op /= N_Empty and then
1609                Logical_Op /= Prev_Logical_Op
1610             then
1611                Error_Msg
1612                  ("mixed logical operators in expression", Op_Location);
1613                Prev_Logical_Op := N_Empty;
1614             else
1615                Prev_Logical_Op := Logical_Op;
1616             end if;
1617
1618             Node2 := Node1;
1619             Node1 := New_Op_Node (Logical_Op, Op_Location);
1620             Set_Left_Opnd (Node1, Node2);
1621             Set_Right_Opnd (Node1, P_Relation);
1622             exit when Token not in Token_Class_Logop;
1623          end loop;
1624
1625          Expr_Form := EF_Non_Simple;
1626       end if;
1627
1628       if Token = Tok_Apostrophe then
1629          Bad_Range_Attribute (Token_Ptr);
1630          return Error;
1631       else
1632          return Node1;
1633       end if;
1634    end P_Expression;
1635
1636    --  This function is identical to the normal P_Expression, except that it
1637    --  also permits the appearance of a case, conditional, or quantified
1638    --  expression without the usual surrounding parentheses.
1639
1640    function P_Expression_If_OK return Node_Id is
1641    begin
1642       if Token = Tok_Case then
1643          return P_Case_Expression;
1644
1645       elsif Token = Tok_If then
1646          return P_Conditional_Expression;
1647
1648       elsif Token = Tok_For then
1649          return P_Quantified_Expression;
1650
1651       else
1652          return P_Expression;
1653       end if;
1654    end P_Expression_If_OK;
1655
1656    --  This function is identical to the normal P_Expression, except that it
1657    --  checks that the expression scan did not stop on a right paren. It is
1658    --  called in all contexts where a right parenthesis cannot legitimately
1659    --  follow an expression.
1660
1661    --  Error recovery: can not raise Error_Resync
1662
1663    function P_Expression_No_Right_Paren return Node_Id is
1664       Expr : constant Node_Id := P_Expression;
1665    begin
1666       Ignore (Tok_Right_Paren);
1667       return Expr;
1668    end P_Expression_No_Right_Paren;
1669
1670    ----------------------------------------
1671    -- 4.4  Expression_Or_Range_Attribute --
1672    ----------------------------------------
1673
1674    --  EXPRESSION ::=
1675    --    RELATION {and RELATION} | RELATION {and then RELATION}
1676    --  | RELATION {or RELATION}  | RELATION {or else RELATION}
1677    --  | RELATION {xor RELATION}
1678
1679    --  RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR
1680
1681    --  RANGE_ATTRIBUTE_DESIGNATOR ::= range [(static_EXPRESSION)]
1682
1683    --  On return, Expr_Form indicates the categorization of the expression
1684    --  and EF_Range_Attr is one of the possibilities.
1685
1686    --  Error recovery: cannot raise Error_Resync
1687
1688    --  In the grammar, a RANGE attribute is simply a name, but its use is
1689    --  highly restricted, so in the parser, we do not regard it as a name.
1690    --  Instead, P_Name returns without scanning the 'RANGE part of the
1691    --  attribute, and P_Expression_Or_Range_Attribute handles the range
1692    --  attribute reference. In the normal case where a range attribute is
1693    --  not allowed, an error message is issued by P_Expression.
1694
1695    function P_Expression_Or_Range_Attribute return Node_Id is
1696       Logical_Op      : Node_Kind;
1697       Prev_Logical_Op : Node_Kind;
1698       Op_Location     : Source_Ptr;
1699       Node1           : Node_Id;
1700       Node2           : Node_Id;
1701       Attr_Node       : Node_Id;
1702
1703    begin
1704       Node1 := P_Relation;
1705
1706       if Token = Tok_Apostrophe then
1707          Attr_Node := P_Range_Attribute_Reference (Node1);
1708          Expr_Form := EF_Range_Attr;
1709          return Attr_Node;
1710
1711       elsif Token in Token_Class_Logop then
1712          Prev_Logical_Op := N_Empty;
1713
1714          loop
1715             Op_Location := Token_Ptr;
1716             Logical_Op := P_Logical_Operator;
1717
1718             if Prev_Logical_Op /= N_Empty and then
1719                Logical_Op /= Prev_Logical_Op
1720             then
1721                Error_Msg
1722                  ("mixed logical operators in expression", Op_Location);
1723                Prev_Logical_Op := N_Empty;
1724             else
1725                Prev_Logical_Op := Logical_Op;
1726             end if;
1727
1728             Node2 := Node1;
1729             Node1 := New_Op_Node (Logical_Op, Op_Location);
1730             Set_Left_Opnd (Node1, Node2);
1731             Set_Right_Opnd (Node1, P_Relation);
1732             exit when Token not in Token_Class_Logop;
1733          end loop;
1734
1735          Expr_Form := EF_Non_Simple;
1736       end if;
1737
1738       if Token = Tok_Apostrophe then
1739          Bad_Range_Attribute (Token_Ptr);
1740          return Error;
1741       else
1742          return Node1;
1743       end if;
1744    end P_Expression_Or_Range_Attribute;
1745
1746    --  Version that allows a non-parenthesized case, conditional, or quantified
1747    --  expression
1748
1749    function P_Expression_Or_Range_Attribute_If_OK return Node_Id is
1750    begin
1751       if Token = Tok_Case then
1752          return P_Case_Expression;
1753
1754       elsif Token = Tok_If then
1755          return P_Conditional_Expression;
1756
1757       elsif Token = Tok_For then
1758          return P_Quantified_Expression;
1759
1760       else
1761          return P_Expression_Or_Range_Attribute;
1762       end if;
1763    end P_Expression_Or_Range_Attribute_If_OK;
1764
1765    -------------------
1766    -- 4.4  Relation --
1767    -------------------
1768
1769    --  RELATION ::=
1770    --    SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION]
1771    --  | SIMPLE_EXPRESSION [not] in MEMBERSHIP_CHOICE_LIST
1772
1773    --  On return, Expr_Form indicates the categorization of the expression
1774
1775    --  Note: if Token = Tok_Apostrophe on return, then Expr_Form is set to
1776    --  EF_Simple_Name and the following token is RANGE (range attribute case).
1777
1778    --  Error recovery: cannot raise Error_Resync. If an error occurs within an
1779    --  expression, then tokens are scanned until either a non-expression token,
1780    --  a right paren (not matched by a left paren) or a comma, is encountered.
1781
1782    function P_Relation return Node_Id is
1783       Node1, Node2 : Node_Id;
1784       Optok        : Source_Ptr;
1785
1786    begin
1787       Node1 := P_Simple_Expression;
1788
1789       if Token not in Token_Class_Relop then
1790          return Node1;
1791
1792       else
1793          --  Here we have a relational operator following. If so then scan it
1794          --  out. Note that the assignment symbol := is treated as a relational
1795          --  operator to improve the error recovery when it is misused for =.
1796          --  P_Relational_Operator also parses the IN and NOT IN operations.
1797
1798          Optok := Token_Ptr;
1799          Node2 := New_Op_Node (P_Relational_Operator, Optok);
1800          Set_Left_Opnd (Node2, Node1);
1801
1802          --  Case of IN or NOT IN
1803
1804          if Prev_Token = Tok_In then
1805             P_Membership_Test (Node2);
1806
1807          --  Case of relational operator (= /= < <= > >=)
1808
1809          else
1810             Set_Right_Opnd (Node2, P_Simple_Expression);
1811          end if;
1812
1813          Expr_Form := EF_Non_Simple;
1814
1815          if Token in Token_Class_Relop then
1816             Error_Msg_SC ("unexpected relational operator");
1817             raise Error_Resync;
1818          end if;
1819
1820          return Node2;
1821       end if;
1822
1823    --  If any error occurs, then scan to the next expression terminator symbol
1824    --  or comma or right paren at the outer (i.e. current) parentheses level.
1825    --  The flags are set to indicate a normal simple expression.
1826
1827    exception
1828       when Error_Resync =>
1829          Resync_Expression;
1830          Expr_Form := EF_Simple;
1831          return Error;
1832    end P_Relation;
1833
1834    ----------------------------
1835    -- 4.4  Simple Expression --
1836    ----------------------------
1837
1838    --  SIMPLE_EXPRESSION ::=
1839    --    [UNARY_ADDING_OPERATOR] TERM {BINARY_ADDING_OPERATOR TERM}
1840
1841    --  On return, Expr_Form indicates the categorization of the expression
1842
1843    --  Note: if Token = Tok_Apostrophe on return, then Expr_Form is set to
1844    --  EF_Simple_Name and the following token is RANGE (range attribute case).
1845
1846    --  Error recovery: cannot raise Error_Resync. If an error occurs within an
1847    --  expression, then tokens are scanned until either a non-expression token,
1848    --  a right paren (not matched by a left paren) or a comma, is encountered.
1849
1850    --  Note: P_Simple_Expression is called only internally by higher level
1851    --  expression routines. In cases in the grammar where a simple expression
1852    --  is required, the approach is to scan an expression, and then post an
1853    --  appropriate error message if the expression obtained is not simple. This
1854    --  gives better error recovery and treatment.
1855
1856    function P_Simple_Expression return Node_Id is
1857       Scan_State : Saved_Scan_State;
1858       Node1      : Node_Id;
1859       Node2      : Node_Id;
1860       Tokptr     : Source_Ptr;
1861
1862    begin
1863       --  Check for cases starting with a name. There are two reasons for
1864       --  special casing. First speed things up by catching a common case
1865       --  without going through several routine layers. Second the caller must
1866       --  be informed via Expr_Form when the simple expression is a name.
1867
1868       if Token in Token_Class_Name then
1869          Node1 := P_Name;
1870
1871          --  Deal with apostrophe cases
1872
1873          if Token = Tok_Apostrophe then
1874             Save_Scan_State (Scan_State); -- at apostrophe
1875             Scan; -- past apostrophe
1876
1877             --  If qualified expression, scan it out and fall through
1878
1879             if Token = Tok_Left_Paren then
1880                Node1 := P_Qualified_Expression (Node1);
1881                Expr_Form := EF_Simple;
1882
1883             --  If range attribute, then we return with Token pointing to the
1884             --  apostrophe. Note: avoid the normal error check on exit. We
1885             --  know that the expression really is complete in this case!
1886
1887             else -- Token = Tok_Range then
1888                Restore_Scan_State (Scan_State); -- to apostrophe
1889                Expr_Form := EF_Simple_Name;
1890                return Node1;
1891             end if;
1892          end if;
1893
1894          --  If an expression terminator follows, the previous processing
1895          --  completely scanned out the expression (a common case), and
1896          --  left Expr_Form set appropriately for returning to our caller.
1897
1898          if Token in Token_Class_Sterm then
1899             null;
1900
1901          --  If we do not have an expression terminator, then complete the
1902          --  scan of a simple expression. This code duplicates the code
1903          --  found in P_Term and P_Factor.
1904
1905          else
1906             if Token = Tok_Double_Asterisk then
1907                if Style_Check then
1908                   Style.Check_Exponentiation_Operator;
1909                end if;
1910
1911                Node2 := New_Op_Node (N_Op_Expon, Token_Ptr);
1912                Scan; -- past **
1913                Set_Left_Opnd (Node2, Node1);
1914                Set_Right_Opnd (Node2, P_Primary);
1915                Node1 := Node2;
1916             end if;
1917
1918             loop
1919                exit when Token not in Token_Class_Mulop;
1920                Tokptr := Token_Ptr;
1921                Node2 := New_Op_Node (P_Multiplying_Operator, Tokptr);
1922
1923                if Style_Check then
1924                   Style.Check_Binary_Operator;
1925                end if;
1926
1927                Scan; -- past operator
1928                Set_Left_Opnd (Node2, Node1);
1929                Set_Right_Opnd (Node2, P_Factor);
1930                Node1 := Node2;
1931             end loop;
1932
1933             loop
1934                exit when Token not in Token_Class_Binary_Addop;
1935                Tokptr := Token_Ptr;
1936                Node2 := New_Op_Node (P_Binary_Adding_Operator, Tokptr);
1937
1938                if Style_Check then
1939                   Style.Check_Binary_Operator;
1940                end if;
1941
1942                Scan; -- past operator
1943                Set_Left_Opnd (Node2, Node1);
1944                Set_Right_Opnd (Node2, P_Term);
1945                Node1 := Node2;
1946             end loop;
1947
1948             Expr_Form := EF_Simple;
1949          end if;
1950
1951       --  Cases where simple expression does not start with a name
1952
1953       else
1954          --  Scan initial sign and initial Term
1955
1956          if Token in Token_Class_Unary_Addop then
1957             Tokptr := Token_Ptr;
1958             Node1 := New_Op_Node (P_Unary_Adding_Operator, Tokptr);
1959
1960             if Style_Check then
1961                Style.Check_Unary_Plus_Or_Minus;
1962             end if;
1963
1964             Scan; -- past operator
1965             Set_Right_Opnd (Node1, P_Term);
1966          else
1967             Node1 := P_Term;
1968          end if;
1969
1970          --  In the following, we special-case a sequence of concatenations of
1971          --  string literals, such as "aaa" & "bbb" & ... & "ccc", with nothing
1972          --  else mixed in. For such a sequence, we return a tree representing
1973          --  "" & "aaabbb...ccc" (a single concatenation). This is done only if
1974          --  the number of concatenations is large. If semantic analysis
1975          --  resolves the "&" to a predefined one, then this folding gives the
1976          --  right answer. Otherwise, semantic analysis will complain about a
1977          --  capacity-exceeded error. The purpose of this trick is to avoid
1978          --  creating a deeply nested tree, which would cause deep recursion
1979          --  during semantics, causing stack overflow. This way, we can handle
1980          --  enormous concatenations in the normal case of predefined "&".  We
1981          --  first build up the normal tree, and then rewrite it if
1982          --  appropriate.
1983
1984          declare
1985             Num_Concats_Threshold : constant Positive := 1000;
1986             --  Arbitrary threshold value to enable optimization
1987
1988             First_Node : constant Node_Id := Node1;
1989             Is_Strlit_Concat : Boolean;
1990             --  True iff we've parsed a sequence of concatenations of string
1991             --  literals, with nothing else mixed in.
1992
1993             Num_Concats : Natural;
1994             --  Number of "&" operators if Is_Strlit_Concat is True
1995
1996          begin
1997             Is_Strlit_Concat :=
1998               Nkind (Node1) = N_String_Literal
1999                 and then Token = Tok_Ampersand;
2000             Num_Concats := 0;
2001
2002             --  Scan out sequence of terms separated by binary adding operators
2003
2004             loop
2005                exit when Token not in Token_Class_Binary_Addop;
2006                Tokptr := Token_Ptr;
2007                Node2 := New_Op_Node (P_Binary_Adding_Operator, Tokptr);
2008                Scan; -- past operator
2009                Set_Left_Opnd (Node2, Node1);
2010                Node1 := P_Term;
2011                Set_Right_Opnd (Node2, Node1);
2012
2013                --  Check if we're still concatenating string literals
2014
2015                Is_Strlit_Concat :=
2016                  Is_Strlit_Concat
2017                    and then Nkind (Node2) = N_Op_Concat
2018                  and then Nkind (Node1) = N_String_Literal;
2019
2020                if Is_Strlit_Concat then
2021                   Num_Concats := Num_Concats + 1;
2022                end if;
2023
2024                Node1 := Node2;
2025             end loop;
2026
2027             --  If we have an enormous series of concatenations of string
2028             --  literals, rewrite as explained above. The Is_Folded_In_Parser
2029             --  flag tells semantic analysis that if the "&" is not predefined,
2030             --  the folded value is wrong.
2031
2032             if Is_Strlit_Concat
2033               and then Num_Concats >= Num_Concats_Threshold
2034             then
2035                declare
2036                   Empty_String_Val : String_Id;
2037                   --  String_Id for ""
2038
2039                   Strlit_Concat_Val : String_Id;
2040                   --  Contains the folded value (which will be correct if the
2041                   --  "&" operators are the predefined ones).
2042
2043                   Cur_Node : Node_Id;
2044                   --  For walking up the tree
2045
2046                   New_Node : Node_Id;
2047                   --  Folded node to replace Node1
2048
2049                   Loc : constant Source_Ptr := Sloc (First_Node);
2050
2051                begin
2052                   --  Walk up the tree starting at the leftmost string literal
2053                   --  (First_Node), building up the Strlit_Concat_Val as we
2054                   --  go. Note that we do not use recursion here -- the whole
2055                   --  point is to avoid recursively walking that enormous tree.
2056
2057                   Start_String;
2058                   Store_String_Chars (Strval (First_Node));
2059
2060                   Cur_Node := Parent (First_Node);
2061                   while Present (Cur_Node) loop
2062                      pragma Assert (Nkind (Cur_Node) = N_Op_Concat and then
2063                         Nkind (Right_Opnd (Cur_Node)) = N_String_Literal);
2064
2065                      Store_String_Chars (Strval (Right_Opnd (Cur_Node)));
2066                      Cur_Node := Parent (Cur_Node);
2067                   end loop;
2068
2069                   Strlit_Concat_Val := End_String;
2070
2071                   --  Create new folded node, and rewrite result with a concat-
2072                   --  enation of an empty string literal and the folded node.
2073
2074                   Start_String;
2075                   Empty_String_Val := End_String;
2076                   New_Node :=
2077                     Make_Op_Concat (Loc,
2078                       Make_String_Literal (Loc, Empty_String_Val),
2079                       Make_String_Literal (Loc, Strlit_Concat_Val,
2080                         Is_Folded_In_Parser => True));
2081                   Rewrite (Node1, New_Node);
2082                end;
2083             end if;
2084          end;
2085
2086          --  All done, we clearly do not have name or numeric literal so this
2087          --  is a case of a simple expression which is some other possibility.
2088
2089          Expr_Form := EF_Simple;
2090       end if;
2091
2092       --  Come here at end of simple expression, where we do a couple of
2093       --  special checks to improve error recovery.
2094
2095       --  Special test to improve error recovery. If the current token
2096       --  is a period, then someone is trying to do selection on something
2097       --  that is not a name, e.g. a qualified expression.
2098
2099       if Token = Tok_Dot then
2100          Error_Msg_SC ("prefix for selection is not a name");
2101
2102          --  If qualified expression, comment and continue, otherwise something
2103          --  is pretty nasty so do an Error_Resync call.
2104
2105          if Ada_Version < Ada_2012
2106            and then Nkind (Node1) = N_Qualified_Expression
2107          then
2108             Error_Msg_SC ("\would be legal in Ada 2012 mode");
2109          else
2110             raise Error_Resync;
2111          end if;
2112       end if;
2113
2114       --  Special test to improve error recovery: If the current token is
2115       --  not the first token on a line (as determined by checking the
2116       --  previous token position with the start of the current line),
2117       --  then we insist that we have an appropriate terminating token.
2118       --  Consider the following two examples:
2119
2120       --   1)  if A nad B then ...
2121
2122       --   2)  A := B
2123       --       C := D
2124
2125       --  In the first example, we would like to issue a binary operator
2126       --  expected message and resynchronize to the then. In the second
2127       --  example, we do not want to issue a binary operator message, so
2128       --  that instead we will get the missing semicolon message. This
2129       --  distinction is of course a heuristic which does not always work,
2130       --  but in practice it is quite effective.
2131
2132       --  Note: the one case in which we do not go through this circuit is
2133       --  when we have scanned a range attribute and want to return with
2134       --  Token pointing to the apostrophe. The apostrophe is not normally
2135       --  an expression terminator, and is not in Token_Class_Sterm, but
2136       --  in this special case we know that the expression is complete.
2137
2138       if not Token_Is_At_Start_Of_Line
2139          and then Token not in Token_Class_Sterm
2140       then
2141          --  Normally the right error message is indeed that we expected a
2142          --  binary operator, but in the case of being between a right and left
2143          --  paren, e.g. in an aggregate, a more likely error is missing comma.
2144
2145          if Prev_Token = Tok_Right_Paren and then Token = Tok_Left_Paren then
2146             T_Comma;
2147          else
2148             Error_Msg_AP ("binary operator expected");
2149          end if;
2150
2151          raise Error_Resync;
2152
2153       else
2154          return Node1;
2155       end if;
2156
2157    --  If any error occurs, then scan to next expression terminator symbol
2158    --  or comma, right paren or vertical bar at the outer (i.e. current) paren
2159    --  level. Expr_Form is set to indicate a normal simple expression.
2160
2161    exception
2162       when Error_Resync =>
2163          Resync_Expression;
2164          Expr_Form := EF_Simple;
2165          return Error;
2166    end P_Simple_Expression;
2167
2168    -----------------------------------------------
2169    -- 4.4  Simple Expression or Range Attribute --
2170    -----------------------------------------------
2171
2172    --  SIMPLE_EXPRESSION ::=
2173    --    [UNARY_ADDING_OPERATOR] TERM {BINARY_ADDING_OPERATOR TERM}
2174
2175    --  RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR
2176
2177    --  RANGE_ATTRIBUTE_DESIGNATOR ::= range [(static_EXPRESSION)]
2178
2179    --  Error recovery: cannot raise Error_Resync
2180
2181    function P_Simple_Expression_Or_Range_Attribute return Node_Id is
2182       Sexpr     : Node_Id;
2183       Attr_Node : Node_Id;
2184
2185    begin
2186       --  We don't just want to roar ahead and call P_Simple_Expression
2187       --  here, since we want to handle the case of a parenthesized range
2188       --  attribute cleanly.
2189
2190       if Token = Tok_Left_Paren then
2191          declare
2192             Lptr       : constant Source_Ptr := Token_Ptr;
2193             Scan_State : Saved_Scan_State;
2194
2195          begin
2196             Save_Scan_State (Scan_State);
2197             Scan; -- past left paren
2198             Sexpr := P_Simple_Expression;
2199
2200             if Token = Tok_Apostrophe then
2201                Attr_Node := P_Range_Attribute_Reference (Sexpr);
2202                Expr_Form := EF_Range_Attr;
2203
2204                if Token = Tok_Right_Paren then
2205                   Scan; -- scan past right paren if present
2206                end if;
2207
2208                Error_Msg ("parentheses not allowed for range attribute", Lptr);
2209
2210                return Attr_Node;
2211             end if;
2212
2213             Restore_Scan_State (Scan_State);
2214          end;
2215       end if;
2216
2217       --  Here after dealing with parenthesized range attribute
2218
2219       Sexpr := P_Simple_Expression;
2220
2221       if Token = Tok_Apostrophe then
2222          Attr_Node := P_Range_Attribute_Reference (Sexpr);
2223          Expr_Form := EF_Range_Attr;
2224          return Attr_Node;
2225
2226       else
2227          return Sexpr;
2228       end if;
2229    end P_Simple_Expression_Or_Range_Attribute;
2230
2231    ---------------
2232    -- 4.4  Term --
2233    ---------------
2234
2235    --  TERM ::= FACTOR {MULTIPLYING_OPERATOR FACTOR}
2236
2237    --  Error recovery: can raise Error_Resync
2238
2239    function P_Term return Node_Id is
2240       Node1, Node2 : Node_Id;
2241       Tokptr       : Source_Ptr;
2242
2243    begin
2244       Node1 := P_Factor;
2245
2246       loop
2247          exit when Token not in Token_Class_Mulop;
2248          Tokptr := Token_Ptr;
2249          Node2 := New_Op_Node (P_Multiplying_Operator, Tokptr);
2250          Scan; -- past operator
2251          Set_Left_Opnd (Node2, Node1);
2252          Set_Right_Opnd (Node2, P_Factor);
2253          Node1 := Node2;
2254       end loop;
2255
2256       return Node1;
2257    end P_Term;
2258
2259    -----------------
2260    -- 4.4  Factor --
2261    -----------------
2262
2263    --  FACTOR ::= PRIMARY [** PRIMARY] | abs PRIMARY | not PRIMARY
2264
2265    --  Error recovery: can raise Error_Resync
2266
2267    function P_Factor return Node_Id is
2268       Node1 : Node_Id;
2269       Node2 : Node_Id;
2270
2271    begin
2272       if Token = Tok_Abs then
2273          Node1 := New_Op_Node (N_Op_Abs, Token_Ptr);
2274
2275          if Style_Check then
2276             Style.Check_Abs_Not;
2277          end if;
2278
2279          Scan; -- past ABS
2280          Set_Right_Opnd (Node1, P_Primary);
2281          return Node1;
2282
2283       elsif Token = Tok_Not then
2284          Node1 := New_Op_Node (N_Op_Not, Token_Ptr);
2285
2286          if Style_Check then
2287             Style.Check_Abs_Not;
2288          end if;
2289
2290          Scan; -- past NOT
2291          Set_Right_Opnd (Node1, P_Primary);
2292          return Node1;
2293
2294       else
2295          Node1 := P_Primary;
2296
2297          if Token = Tok_Double_Asterisk then
2298             Node2 := New_Op_Node (N_Op_Expon, Token_Ptr);
2299             Scan; -- past **
2300             Set_Left_Opnd (Node2, Node1);
2301             Set_Right_Opnd (Node2, P_Primary);
2302             return Node2;
2303          else
2304             return Node1;
2305          end if;
2306       end if;
2307    end P_Factor;
2308
2309    ------------------
2310    -- 4.4  Primary --
2311    ------------------
2312
2313    --  PRIMARY ::=
2314    --    NUMERIC_LITERAL  | null
2315    --  | STRING_LITERAL   | AGGREGATE
2316    --  | NAME             | QUALIFIED_EXPRESSION
2317    --  | ALLOCATOR        | (EXPRESSION) | QUANTIFIED_EXPRESSION
2318
2319    --  Error recovery: can raise Error_Resync
2320
2321    function P_Primary return Node_Id is
2322       Scan_State : Saved_Scan_State;
2323       Node1      : Node_Id;
2324
2325    begin
2326       --  The loop runs more than once only if misplaced pragmas are found
2327
2328       loop
2329          case Token is
2330
2331             --  Name token can start a name, call or qualified expression, all
2332             --  of which are acceptable possibilities for primary. Note also
2333             --  that string literal is included in name (as operator symbol)
2334             --  and type conversion is included in name (as indexed component).
2335
2336             when Tok_Char_Literal | Tok_Operator_Symbol | Tok_Identifier =>
2337                Node1 := P_Name;
2338
2339                --  All done unless apostrophe follows
2340
2341                if Token /= Tok_Apostrophe then
2342                   return Node1;
2343
2344                --  Apostrophe following means that we have either just parsed
2345                --  the subtype mark of a qualified expression, or the prefix
2346                --  or a range attribute.
2347
2348                else -- Token = Tok_Apostrophe
2349                   Save_Scan_State (Scan_State); -- at apostrophe
2350                   Scan; -- past apostrophe
2351
2352                   --  If range attribute, then this is always an error, since
2353                   --  the only legitimate case (where the scanned expression is
2354                   --  a qualified simple name) is handled at the level of the
2355                   --  Simple_Expression processing. This case corresponds to a
2356                   --  usage such as 3 + A'Range, which is always illegal.
2357
2358                   if Token = Tok_Range then
2359                      Restore_Scan_State (Scan_State); -- to apostrophe
2360                      Bad_Range_Attribute (Token_Ptr);
2361                      return Error;
2362
2363                   --  If left paren, then we have a qualified expression.
2364                   --  Note that P_Name guarantees that in this case, where
2365                   --  Token = Tok_Apostrophe on return, the only two possible
2366                   --  tokens following the apostrophe are left paren and
2367                   --  RANGE, so we know we have a left paren here.
2368
2369                   else -- Token = Tok_Left_Paren
2370                      return P_Qualified_Expression (Node1);
2371
2372                   end if;
2373                end if;
2374
2375             --  Numeric or string literal
2376
2377             when Tok_Integer_Literal |
2378                  Tok_Real_Literal    |
2379                  Tok_String_Literal  =>
2380
2381                Node1 := Token_Node;
2382                Scan; -- past number
2383                return Node1;
2384
2385             --  Left paren, starts aggregate or parenthesized expression
2386
2387             when Tok_Left_Paren =>
2388                declare
2389                   Expr : constant Node_Id := P_Aggregate_Or_Paren_Expr;
2390
2391                begin
2392                   if Nkind (Expr) = N_Attribute_Reference
2393                     and then Attribute_Name (Expr) = Name_Range
2394                   then
2395                      Bad_Range_Attribute (Sloc (Expr));
2396                   end if;
2397
2398                   return Expr;
2399                end;
2400
2401             --  Allocator
2402
2403             when Tok_New =>
2404                return P_Allocator;
2405
2406             --  Null
2407
2408             when Tok_Null =>
2409                Scan; -- past NULL
2410                return New_Node (N_Null, Prev_Token_Ptr);
2411
2412             --  Pragma, not allowed here, so just skip past it
2413
2414             when Tok_Pragma =>
2415                P_Pragmas_Misplaced;
2416
2417             --  Deal with IF (possible unparenthesized conditional expression)
2418
2419             when Tok_If =>
2420
2421                --  If this looks like a real if, defined as an IF appearing at
2422                --  the start of a new line, then we consider we have a missing
2423                --  operand.
2424
2425                if Token_Is_At_Start_Of_Line then
2426                   Error_Msg_AP ("missing operand");
2427                   return Error;
2428
2429                --  If this looks like a conditional expression, then treat it
2430                --  that way with an error message.
2431
2432                elsif Ada_Version >= Ada_2012 then
2433                   Error_Msg_SC
2434                     ("conditional expression must be parenthesized");
2435                   return P_Conditional_Expression;
2436
2437                --  Otherwise treat as misused identifier
2438
2439                else
2440                   return P_Identifier;
2441                end if;
2442
2443             --  Deal with CASE (possible unparenthesized case expression)
2444
2445             when Tok_Case =>
2446
2447                --  If this looks like a real case, defined as a CASE appearing
2448                --  the start of a new line, then we consider we have a missing
2449                --  operand.
2450
2451                if Token_Is_At_Start_Of_Line then
2452                   Error_Msg_AP ("missing operand");
2453                   return Error;
2454
2455                --  If this looks like a case expression, then treat it that way
2456                --  with an error message.
2457
2458                elsif Ada_Version >= Ada_2012 then
2459                   Error_Msg_SC ("case expression must be parenthesized");
2460                   return P_Case_Expression;
2461
2462                --  Otherwise treat as misused identifier
2463
2464                else
2465                   return P_Identifier;
2466                end if;
2467
2468             --  For [all | some]  indicates a quantified expression
2469
2470             when Tok_For =>
2471
2472                if Token_Is_At_Start_Of_Line then
2473                   Error_Msg_AP ("misplaced loop");
2474                   return Error;
2475
2476                elsif Ada_Version >= Ada_2012 then
2477                   Error_Msg_SC ("quantified expression must be parenthesized");
2478                   return P_Quantified_Expression;
2479
2480                else
2481
2482                --  Otherwise treat as misused identifier
2483
2484                   return P_Identifier;
2485                end if;
2486
2487             --  Anything else is illegal as the first token of a primary, but
2488             --  we test for a reserved identifier so that it is treated nicely
2489
2490             when others =>
2491                if Is_Reserved_Identifier then
2492                   return P_Identifier;
2493
2494                elsif Prev_Token = Tok_Comma then
2495                   Error_Msg_SP -- CODEFIX
2496                     ("|extra "","" ignored");
2497                   raise Error_Resync;
2498
2499                else
2500                   Error_Msg_AP ("missing operand");
2501                   raise Error_Resync;
2502                end if;
2503
2504          end case;
2505       end loop;
2506    end P_Primary;
2507
2508    -------------------------------
2509    -- 4.4 Quantified_Expression --
2510    -------------------------------
2511
2512    --  QUANTIFIED_EXPRESSION ::=
2513    --    for QUANTIFIER LOOP_PARAMETER_SPECIFICATION => PREDICATE |
2514    --    for QUANTIFIER ITERATOR_SPECIFICATION => PREDICATE
2515
2516    function P_Quantified_Expression return Node_Id is
2517       Node1 : Node_Id;
2518
2519    begin
2520       Scan;  --  past FOR
2521
2522       Node1 := New_Node (N_Quantified_Expression, Prev_Token_Ptr);
2523
2524       if Token = Tok_All then
2525          Set_All_Present (Node1);
2526
2527       --  We treat Some as a non-reserved keyword, so it appears to
2528       --  the scanner as an identifier. If Some is made into a reserved
2529       --  work, the check below is against Tok_Some.
2530
2531       elsif Token /= Tok_Identifier
2532         or else Chars (Token_Node) /= Name_Some
2533       then
2534          Error_Msg_AP ("missing quantifier");
2535          raise Error_Resync;
2536       end if;
2537
2538       Scan;
2539       Set_Loop_Parameter_Specification (Node1, P_Loop_Parameter_Specification);
2540       if Token = Tok_Arrow then
2541          Scan;
2542          Set_Condition (Node1, P_Expression);
2543          return Node1;
2544       else
2545          Error_Msg_AP ("missing arrow");
2546          raise Error_Resync;
2547       end if;
2548    end P_Quantified_Expression;
2549
2550    ---------------------------
2551    -- 4.5  Logical Operator --
2552    ---------------------------
2553
2554    --  LOGICAL_OPERATOR  ::=  and | or | xor
2555
2556    --  Note: AND THEN and OR ELSE are also treated as logical operators
2557    --  by the parser (even though they are not operators semantically)
2558
2559    --  The value returned is the appropriate Node_Kind code for the operator
2560    --  On return, Token points to the token following the scanned operator.
2561
2562    --  The caller has checked that the first token is a legitimate logical
2563    --  operator token (i.e. is either XOR, AND, OR).
2564
2565    --  Error recovery: cannot raise Error_Resync
2566
2567    function P_Logical_Operator return Node_Kind is
2568    begin
2569       if Token = Tok_And then
2570          if Style_Check then
2571             Style.Check_Binary_Operator;
2572          end if;
2573
2574          Scan; -- past AND
2575
2576          if Token = Tok_Then then
2577             Scan; -- past THEN
2578             return N_And_Then;
2579          else
2580             return N_Op_And;
2581          end if;
2582
2583       elsif Token = Tok_Or then
2584          if Style_Check then
2585             Style.Check_Binary_Operator;
2586          end if;
2587
2588          Scan; -- past OR
2589
2590          if Token = Tok_Else then
2591             Scan; -- past ELSE
2592             return N_Or_Else;
2593          else
2594             return N_Op_Or;
2595          end if;
2596
2597       else -- Token = Tok_Xor
2598          if Style_Check then
2599             Style.Check_Binary_Operator;
2600          end if;
2601
2602          Scan; -- past XOR
2603          return N_Op_Xor;
2604       end if;
2605    end P_Logical_Operator;
2606
2607    ------------------------------
2608    -- 4.5  Relational Operator --
2609    ------------------------------
2610
2611    --  RELATIONAL_OPERATOR ::= = | /= | < | <= | > | >=
2612
2613    --  The value returned is the appropriate Node_Kind code for the operator.
2614    --  On return, Token points to the operator token, NOT past it.
2615
2616    --  The caller has checked that the first token is a legitimate relational
2617    --  operator token (i.e. is one of the operator tokens listed above).
2618
2619    --  Error recovery: cannot raise Error_Resync
2620
2621    function P_Relational_Operator return Node_Kind is
2622       Op_Kind : Node_Kind;
2623       Relop_Node : constant array (Token_Class_Relop) of Node_Kind :=
2624                      (Tok_Less          => N_Op_Lt,
2625                       Tok_Equal         => N_Op_Eq,
2626                       Tok_Greater       => N_Op_Gt,
2627                       Tok_Not_Equal     => N_Op_Ne,
2628                       Tok_Greater_Equal => N_Op_Ge,
2629                       Tok_Less_Equal    => N_Op_Le,
2630                       Tok_In            => N_In,
2631                       Tok_Not           => N_Not_In,
2632                       Tok_Box           => N_Op_Ne);
2633
2634    begin
2635       if Token = Tok_Box then
2636          Error_Msg_SC -- CODEFIX
2637            ("|""'<'>"" should be ""/=""");
2638       end if;
2639
2640       Op_Kind := Relop_Node (Token);
2641
2642       if Style_Check then
2643          Style.Check_Binary_Operator;
2644       end if;
2645
2646       Scan; -- past operator token
2647
2648       if Prev_Token = Tok_Not then
2649          T_In;
2650       end if;
2651
2652       return Op_Kind;
2653    end P_Relational_Operator;
2654
2655    ---------------------------------
2656    -- 4.5  Binary Adding Operator --
2657    ---------------------------------
2658
2659    --  BINARY_ADDING_OPERATOR ::= + | - | &
2660
2661    --  The value returned is the appropriate Node_Kind code for the operator.
2662    --  On return, Token points to the operator token (NOT past it).
2663
2664    --  The caller has checked that the first token is a legitimate adding
2665    --  operator token (i.e. is one of the operator tokens listed above).
2666
2667    --  Error recovery: cannot raise Error_Resync
2668
2669    function P_Binary_Adding_Operator return Node_Kind is
2670       Addop_Node : constant array (Token_Class_Binary_Addop) of Node_Kind :=
2671                      (Tok_Ampersand => N_Op_Concat,
2672                       Tok_Minus     => N_Op_Subtract,
2673                       Tok_Plus      => N_Op_Add);
2674    begin
2675       return Addop_Node (Token);
2676    end P_Binary_Adding_Operator;
2677
2678    --------------------------------
2679    -- 4.5  Unary Adding Operator --
2680    --------------------------------
2681
2682    --  UNARY_ADDING_OPERATOR ::= + | -
2683
2684    --  The value returned is the appropriate Node_Kind code for the operator.
2685    --  On return, Token points to the operator token (NOT past it).
2686
2687    --  The caller has checked that the first token is a legitimate adding
2688    --  operator token (i.e. is one of the operator tokens listed above).
2689
2690    --  Error recovery: cannot raise Error_Resync
2691
2692    function P_Unary_Adding_Operator return Node_Kind is
2693       Addop_Node : constant array (Token_Class_Unary_Addop) of Node_Kind :=
2694                      (Tok_Minus => N_Op_Minus,
2695                       Tok_Plus  => N_Op_Plus);
2696    begin
2697       return Addop_Node (Token);
2698    end P_Unary_Adding_Operator;
2699
2700    -------------------------------
2701    -- 4.5  Multiplying Operator --
2702    -------------------------------
2703
2704    --  MULTIPLYING_OPERATOR ::= * | / | mod | rem
2705
2706    --  The value returned is the appropriate Node_Kind code for the operator.
2707    --  On return, Token points to the operator token (NOT past it).
2708
2709    --  The caller has checked that the first token is a legitimate multiplying
2710    --  operator token (i.e. is one of the operator tokens listed above).
2711
2712    --  Error recovery: cannot raise Error_Resync
2713
2714    function P_Multiplying_Operator return Node_Kind is
2715       Mulop_Node : constant array (Token_Class_Mulop) of Node_Kind :=
2716         (Tok_Asterisk       => N_Op_Multiply,
2717          Tok_Mod            => N_Op_Mod,
2718          Tok_Rem            => N_Op_Rem,
2719          Tok_Slash          => N_Op_Divide);
2720    begin
2721       return Mulop_Node (Token);
2722    end P_Multiplying_Operator;
2723
2724    --------------------------------------
2725    -- 4.5  Highest Precedence Operator --
2726    --------------------------------------
2727
2728    --  Parsed by P_Factor (4.4)
2729
2730    --  Note: this rule is not in fact used by the grammar at any point!
2731
2732    --------------------------
2733    -- 4.6  Type Conversion --
2734    --------------------------
2735
2736    --  Parsed by P_Primary as a Name (4.1)
2737
2738    -------------------------------
2739    -- 4.7  Qualified Expression --
2740    -------------------------------
2741
2742    --  QUALIFIED_EXPRESSION ::=
2743    --    SUBTYPE_MARK ' (EXPRESSION) | SUBTYPE_MARK ' AGGREGATE
2744
2745    --  The caller has scanned the name which is the Subtype_Mark parameter
2746    --  and scanned past the single quote following the subtype mark. The
2747    --  caller has not checked that this name is in fact appropriate for
2748    --  a subtype mark name (i.e. it is a selected component or identifier).
2749
2750    --  Error_Recovery: cannot raise Error_Resync
2751
2752    function P_Qualified_Expression (Subtype_Mark : Node_Id) return Node_Id is
2753       Qual_Node : Node_Id;
2754    begin
2755       Qual_Node := New_Node (N_Qualified_Expression, Prev_Token_Ptr);
2756       Set_Subtype_Mark (Qual_Node, Check_Subtype_Mark (Subtype_Mark));
2757       Set_Expression (Qual_Node, P_Aggregate_Or_Paren_Expr);
2758       return Qual_Node;
2759    end P_Qualified_Expression;
2760
2761    --------------------
2762    -- 4.8  Allocator --
2763    --------------------
2764
2765    --  ALLOCATOR ::=
2766    --    new [NULL_EXCLUSION] SUBTYPE_INDICATION | new QUALIFIED_EXPRESSION
2767
2768    --  The caller has checked that the initial token is NEW
2769
2770    --  Error recovery: can raise Error_Resync
2771
2772    function P_Allocator return Node_Id is
2773       Alloc_Node             : Node_Id;
2774       Type_Node              : Node_Id;
2775       Null_Exclusion_Present : Boolean;
2776
2777    begin
2778       Alloc_Node := New_Node (N_Allocator, Token_Ptr);
2779       T_New;
2780
2781       --  Scan Null_Exclusion if present (Ada 2005 (AI-231))
2782
2783       Null_Exclusion_Present := P_Null_Exclusion;
2784       Set_Null_Exclusion_Present (Alloc_Node, Null_Exclusion_Present);
2785       Type_Node := P_Subtype_Mark_Resync;
2786
2787       if Token = Tok_Apostrophe then
2788          Scan; -- past apostrophe
2789          Set_Expression (Alloc_Node, P_Qualified_Expression (Type_Node));
2790       else
2791          Set_Expression
2792            (Alloc_Node,
2793             P_Subtype_Indication (Type_Node, Null_Exclusion_Present));
2794       end if;
2795
2796       return Alloc_Node;
2797    end P_Allocator;
2798
2799    -----------------------
2800    -- P_Case_Expression --
2801    -----------------------
2802
2803    function P_Case_Expression return Node_Id is
2804       Loc        : constant Source_Ptr := Token_Ptr;
2805       Case_Node  : Node_Id;
2806       Save_State : Saved_Scan_State;
2807
2808    begin
2809       if Ada_Version < Ada_2012 then
2810          Error_Msg_SC ("|case expression is an Ada 2012 feature");
2811          Error_Msg_SC ("\|unit must be compiled with -gnat2012 switch");
2812       end if;
2813
2814       Scan; -- past CASE
2815       Case_Node :=
2816         Make_Case_Expression (Loc,
2817           Expression   => P_Expression_No_Right_Paren,
2818           Alternatives => New_List);
2819       T_Is;
2820
2821       --  We now have scanned out CASE expression IS, scan alternatives
2822
2823       loop
2824          T_When;
2825          Append_To (Alternatives (Case_Node), P_Case_Expression_Alternative);
2826
2827          --  Missing comma if WHEN (more alternatives present)
2828
2829          if Token = Tok_When then
2830             T_Comma;
2831
2832          --  If comma/WHEN, skip comma and we have another alternative
2833
2834          elsif Token = Tok_Comma then
2835             Save_Scan_State (Save_State);
2836             Scan; -- past comma
2837
2838             if Token /= Tok_When then
2839                Restore_Scan_State (Save_State);
2840                exit;
2841             end if;
2842
2843          --  If no comma or WHEN, definitely done
2844
2845          else
2846             exit;
2847          end if;
2848       end loop;
2849
2850       --  If we have an END CASE, diagnose as not needed
2851
2852       if Token = Tok_End then
2853          Error_Msg_SC ("`END CASE` not allowed at end of case expression");
2854          Scan; -- past END
2855
2856          if Token = Tok_Case then
2857             Scan; -- past CASE;
2858          end if;
2859       end if;
2860
2861       --  Return the Case_Expression node
2862
2863       return Case_Node;
2864    end P_Case_Expression;
2865
2866    -----------------------------------
2867    -- P_Case_Expression_Alternative --
2868    -----------------------------------
2869
2870    --  CASE_STATEMENT_ALTERNATIVE ::=
2871    --    when DISCRETE_CHOICE_LIST =>
2872    --      EXPRESSION
2873
2874    --  The caller has checked that and scanned past the initial WHEN token
2875    --  Error recovery: can raise Error_Resync
2876
2877    function P_Case_Expression_Alternative return Node_Id is
2878       Case_Alt_Node : Node_Id;
2879    begin
2880       Case_Alt_Node := New_Node (N_Case_Expression_Alternative, Token_Ptr);
2881       Set_Discrete_Choices (Case_Alt_Node, P_Discrete_Choice_List);
2882       TF_Arrow;
2883       Set_Expression (Case_Alt_Node, P_Expression);
2884       return Case_Alt_Node;
2885    end P_Case_Expression_Alternative;
2886
2887    ------------------------------
2888    -- P_Conditional_Expression --
2889    ------------------------------
2890
2891    function P_Conditional_Expression return Node_Id is
2892       Exprs : constant List_Id    := New_List;
2893       Loc   : constant Source_Ptr := Token_Ptr;
2894       Expr  : Node_Id;
2895       State : Saved_Scan_State;
2896
2897    begin
2898       Inside_Conditional_Expression := Inside_Conditional_Expression + 1;
2899
2900       if Token = Tok_If and then Ada_Version < Ada_2012 then
2901          Error_Msg_SC ("|conditional expression is an Ada 2012 feature");
2902          Error_Msg_SC ("\|unit must be compiled with -gnat2012 switch");
2903       end if;
2904
2905       Scan; -- past IF or ELSIF
2906       Append_To (Exprs, P_Condition);
2907       TF_Then;
2908       Append_To (Exprs, P_Expression);
2909
2910       --  We now have scanned out IF expr THEN expr
2911
2912       --  Check for common error of semicolon before the ELSE
2913
2914       if Token = Tok_Semicolon then
2915          Save_Scan_State (State);
2916          Scan; -- past semicolon
2917
2918          if Token = Tok_Else or else Token = Tok_Elsif then
2919             Error_Msg_SP -- CODEFIX
2920               ("|extra "";"" ignored");
2921
2922          else
2923             Restore_Scan_State (State);
2924          end if;
2925       end if;
2926
2927       --  Scan out ELSIF sequence if present
2928
2929       if Token = Tok_Elsif then
2930          Expr := P_Conditional_Expression;
2931          Set_Is_Elsif (Expr);
2932          Append_To (Exprs, Expr);
2933
2934       --  Scan out ELSE phrase if present
2935
2936       elsif Token = Tok_Else then
2937
2938          --  Scan out ELSE expression
2939
2940          Scan; -- Past ELSE
2941          Append_To (Exprs, P_Expression);
2942
2943       --  Two expression case (implied True, filled in during semantics)
2944
2945       else
2946          null;
2947       end if;
2948
2949       --  If we have an END IF, diagnose as not needed
2950
2951       if Token = Tok_End then
2952          Error_Msg_SC
2953            ("`END IF` not allowed at end of conditional expression");
2954          Scan; -- past END
2955
2956          if Token = Tok_If then
2957             Scan; -- past IF;
2958          end if;
2959       end if;
2960
2961       Inside_Conditional_Expression := Inside_Conditional_Expression - 1;
2962
2963       --  Return the Conditional_Expression node
2964
2965       return
2966         Make_Conditional_Expression (Loc,
2967           Expressions => Exprs);
2968    end P_Conditional_Expression;
2969
2970    -----------------------
2971    -- P_Membership_Test --
2972    -----------------------
2973
2974    --  MEMBERSHIP_CHOICE_LIST ::= MEMBERHIP_CHOICE {'|' MEMBERSHIP_CHOICE}
2975    --  MEMBERSHIP_CHOICE      ::= CHOICE_EXPRESSION | range | subtype_mark
2976
2977    procedure P_Membership_Test (N : Node_Id) is
2978       Alt : constant Node_Id :=
2979               P_Range_Or_Subtype_Mark
2980                 (Allow_Simple_Expression => (Ada_Version >= Ada_2012));
2981
2982    begin
2983       --  Set case
2984
2985       if Token = Tok_Vertical_Bar then
2986          if Ada_Version < Ada_2012 then
2987             Error_Msg_SC ("set notation is an Ada 2012 feature");
2988             Error_Msg_SC ("\|unit must be compiled with -gnat2012 switch");
2989          end if;
2990
2991          Set_Alternatives (N, New_List (Alt));
2992          Set_Right_Opnd   (N, Empty);
2993
2994          --  Loop to accumulate alternatives
2995
2996          while Token = Tok_Vertical_Bar loop
2997             Scan; -- past vertical bar
2998             Append_To
2999               (Alternatives (N),
3000                P_Range_Or_Subtype_Mark (Allow_Simple_Expression => True));
3001          end loop;
3002
3003       --  Not set case
3004
3005       else
3006          Set_Right_Opnd   (N, Alt);
3007          Set_Alternatives (N, No_List);
3008       end if;
3009    end P_Membership_Test;
3010
3011 end Ch4;