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                if SPARK_Mode then
 673                   Error_Msg_SP ("|~~no mixing of positional and named "
 674                                 & "parameter association");
 675                end if;
 676
 677                Restore_Scan_State (Scan_State); -- to Id
 678                goto LP_State_Call;
 679
 680             --  Otherwise it's just an expression after all, so backup
 681
 682             else
 683                Restore_Scan_State (Scan_State); -- to Id
 684             end if;
 685          end if;
 686
 687          --  Here we have an expression after all, so stay in this state
 688
 689          Expr_Node := P_Expression_If_OK;
 690          goto LP_State_Expr;
 691
 692       --  LP_State_Call corresponds to the situation in which at least
 693       --  one instance of Id => Expression has been encountered, so we
 694       --  know that we do not have a name, but rather a call. We enter
 695       --  it with the scan pointer pointing to the next argument to scan,
 696       --  and Arg_List containing the list of arguments scanned so far.
 697
 698       <<LP_State_Call>>
 699
 700          --  Test for case of Id => Expression (named parameter)
 701
 702          if Token = Tok_Identifier then
 703             Save_Scan_State (Scan_State); -- at Id
 704             Ident_Node := Token_Node;
 705             Scan; -- past Id
 706
 707             --  Deal with => (allow := as erroneous substitute)
 708
 709             if Token = Tok_Arrow or else Token = Tok_Colon_Equal then
 710                Arg_Node := New_Node (N_Parameter_Association, Prev_Token_Ptr);
 711                Set_Selector_Name (Arg_Node, Ident_Node);
 712                T_Arrow;
 713                Set_Explicit_Actual_Parameter (Arg_Node, P_Expression);
 714                Append (Arg_Node, Arg_List);
 715
 716                --  If a comma follows, go back and scan next entry
 717
 718                if Comma_Present then
 719                   goto LP_State_Call;
 720
 721                --  Otherwise we have the end of a call
 722
 723                else
 724                   Prefix_Node := Name_Node;
 725                   Name_Node := New_Node (N_Function_Call, Sloc (Prefix_Node));
 726                   Set_Name (Name_Node, Prefix_Node);
 727                   Set_Parameter_Associations (Name_Node, Arg_List);
 728                   T_Right_Paren;
 729
 730                   if Token in Token_Class_Namext then
 731                      goto Scan_Name_Extension_OK;
 732
 733                   --  This is a case of a call which cannot be a name
 734
 735                   else
 736                      Expr_Form := EF_Name;
 737                      return Name_Node;
 738                   end if;
 739                end if;
 740
 741             --  Not named parameter: Id started an expression after all
 742
 743             else
 744                Restore_Scan_State (Scan_State); -- to Id
 745             end if;
 746          end if;
 747
 748          --  Here if entry did not start with Id => which means that it
 749          --  is a positional parameter, which is not allowed, since we
 750          --  have seen at least one named parameter already.
 751
 752          Error_Msg_SC
 753             ("positional parameter association " &
 754               "not allowed after named one");
 755
 756          Expr_Node := P_Expression_If_OK;
 757
 758          --  Leaving the '>' in an association is not unusual, so suggest
 759          --  a possible fix.
 760
 761          if Nkind (Expr_Node) = N_Op_Eq then
 762             Error_Msg_N ("\maybe `='>` was intended", Expr_Node);
 763          end if;
 764
 765          --  We go back to scanning out expressions, so that we do not get
 766          --  multiple error messages when several positional parameters
 767          --  follow a named parameter.
 768
 769          goto LP_State_Expr;
 770
 771          --  End of treatment for name extensions starting with left paren
 772
 773       --  End of loop through name extensions
 774
 775    end P_Name;
 776
 777    --  This function parses a restricted form of Names which are either
 778    --  designators, or designators preceded by a sequence of prefixes
 779    --  that are direct names.
 780
 781    --  Error recovery: cannot raise Error_Resync
 782
 783    function P_Function_Name return Node_Id is
 784       Designator_Node : Node_Id;
 785       Prefix_Node     : Node_Id;
 786       Selector_Node   : Node_Id;
 787       Dot_Sloc        : Source_Ptr := No_Location;
 788
 789    begin
 790       --  Prefix_Node is set to the gathered prefix so far, Empty means that
 791       --  no prefix has been scanned. This allows us to build up the result
 792       --  in the required right recursive manner.
 793
 794       Prefix_Node := Empty;
 795
 796       --  Loop through prefixes
 797
 798       loop
 799          Designator_Node := Token_Node;
 800
 801          if Token not in Token_Class_Desig then
 802             return P_Identifier; -- let P_Identifier issue the error message
 803
 804          else -- Token in Token_Class_Desig
 805             Scan; -- past designator
 806             exit when Token /= Tok_Dot;
 807          end if;
 808
 809          --  Here at a dot, with token just before it in Designator_Node
 810
 811          if No (Prefix_Node) then
 812             Prefix_Node := Designator_Node;
 813          else
 814             Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
 815             Set_Prefix (Selector_Node, Prefix_Node);
 816             Set_Selector_Name (Selector_Node, Designator_Node);
 817             Prefix_Node := Selector_Node;
 818          end if;
 819
 820          Dot_Sloc := Token_Ptr;
 821          Scan; -- past dot
 822       end loop;
 823
 824       --  Fall out of the loop having just scanned a designator
 825
 826       if No (Prefix_Node) then
 827          return Designator_Node;
 828       else
 829          Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
 830          Set_Prefix (Selector_Node, Prefix_Node);
 831          Set_Selector_Name (Selector_Node, Designator_Node);
 832          return Selector_Node;
 833       end if;
 834
 835    exception
 836       when Error_Resync =>
 837          return Error;
 838    end P_Function_Name;
 839
 840    --  This function parses a restricted form of Names which are either
 841    --  identifiers, or identifiers preceded by a sequence of prefixes
 842    --  that are direct names.
 843
 844    --  Error recovery: cannot raise Error_Resync
 845
 846    function P_Qualified_Simple_Name return Node_Id is
 847       Designator_Node : Node_Id;
 848       Prefix_Node     : Node_Id;
 849       Selector_Node   : Node_Id;
 850       Dot_Sloc        : Source_Ptr := No_Location;
 851
 852    begin
 853       --  Prefix node is set to the gathered prefix so far, Empty means that
 854       --  no prefix has been scanned. This allows us to build up the result
 855       --  in the required right recursive manner.
 856
 857       Prefix_Node := Empty;
 858
 859       --  Loop through prefixes
 860
 861       loop
 862          Designator_Node := Token_Node;
 863
 864          if Token = Tok_Identifier then
 865             Scan; -- past identifier
 866             exit when Token /= Tok_Dot;
 867
 868          elsif Token not in Token_Class_Desig then
 869             return P_Identifier; -- let P_Identifier issue the error message
 870
 871          else
 872             Scan; -- past designator
 873
 874             if Token /= Tok_Dot then
 875                Error_Msg_SP ("identifier expected");
 876                return Error;
 877             end if;
 878          end if;
 879
 880          --  Here at a dot, with token just before it in Designator_Node
 881
 882          if No (Prefix_Node) then
 883             Prefix_Node := Designator_Node;
 884          else
 885             Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
 886             Set_Prefix (Selector_Node, Prefix_Node);
 887             Set_Selector_Name (Selector_Node, Designator_Node);
 888             Prefix_Node := Selector_Node;
 889          end if;
 890
 891          Dot_Sloc := Token_Ptr;
 892          Scan; -- past dot
 893       end loop;
 894
 895       --  Fall out of the loop having just scanned an identifier
 896
 897       if No (Prefix_Node) then
 898          return Designator_Node;
 899       else
 900          Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
 901          Set_Prefix (Selector_Node, Prefix_Node);
 902          Set_Selector_Name (Selector_Node, Designator_Node);
 903          return Selector_Node;
 904       end if;
 905
 906    exception
 907       when Error_Resync =>
 908          return Error;
 909    end P_Qualified_Simple_Name;
 910
 911    --  This procedure differs from P_Qualified_Simple_Name only in that it
 912    --  raises Error_Resync if any error is encountered. It only returns after
 913    --  scanning a valid qualified simple name.
 914
 915    --  Error recovery: can raise Error_Resync
 916
 917    function P_Qualified_Simple_Name_Resync return Node_Id is
 918       Designator_Node : Node_Id;
 919       Prefix_Node     : Node_Id;
 920       Selector_Node   : Node_Id;
 921       Dot_Sloc        : Source_Ptr := No_Location;
 922
 923    begin
 924       Prefix_Node := Empty;
 925
 926       --  Loop through prefixes
 927
 928       loop
 929          Designator_Node := Token_Node;
 930
 931          if Token = Tok_Identifier then
 932             Scan; -- past identifier
 933             exit when Token /= Tok_Dot;
 934
 935          elsif Token not in Token_Class_Desig then
 936             Discard_Junk_Node (P_Identifier); -- to issue the error message
 937             raise Error_Resync;
 938
 939          else
 940             Scan; -- past designator
 941
 942             if Token /= Tok_Dot then
 943                Error_Msg_SP ("identifier expected");
 944                raise Error_Resync;
 945             end if;
 946          end if;
 947
 948          --  Here at a dot, with token just before it in Designator_Node
 949
 950          if No (Prefix_Node) then
 951             Prefix_Node := Designator_Node;
 952          else
 953             Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
 954             Set_Prefix (Selector_Node, Prefix_Node);
 955             Set_Selector_Name (Selector_Node, Designator_Node);
 956             Prefix_Node := Selector_Node;
 957          end if;
 958
 959          Dot_Sloc := Token_Ptr;
 960          Scan; -- past period
 961       end loop;
 962
 963       --  Fall out of the loop having just scanned an identifier
 964
 965       if No (Prefix_Node) then
 966          return Designator_Node;
 967       else
 968          Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
 969          Set_Prefix (Selector_Node, Prefix_Node);
 970          Set_Selector_Name (Selector_Node, Designator_Node);
 971          return Selector_Node;
 972       end if;
 973    end P_Qualified_Simple_Name_Resync;
 974
 975    ----------------------
 976    -- 4.1  Direct_Name --
 977    ----------------------
 978
 979    --  Parsed by P_Name and other functions in section 4.1
 980
 981    -----------------
 982    -- 4.1  Prefix --
 983    -----------------
 984
 985    --  Parsed by P_Name (4.1)
 986
 987    -------------------------------
 988    -- 4.1  Explicit Dereference --
 989    -------------------------------
 990
 991    --  Parsed by P_Name (4.1)
 992
 993    -------------------------------
 994    -- 4.1  Implicit_Dereference --
 995    -------------------------------
 996
 997    --  Parsed by P_Name (4.1)
 998
 999    ----------------------------
1000    -- 4.1  Indexed Component --
1001    ----------------------------
1002
1003    --  Parsed by P_Name (4.1)
1004
1005    ----------------
1006    -- 4.1  Slice --
1007    ----------------
1008
1009    --  Parsed by P_Name (4.1)
1010
1011    -----------------------------
1012    -- 4.1  Selected_Component --
1013    -----------------------------
1014
1015    --  Parsed by P_Name (4.1)
1016
1017    ------------------------
1018    -- 4.1  Selector Name --
1019    ------------------------
1020
1021    --  Parsed by P_Name (4.1)
1022
1023    ------------------------------
1024    -- 4.1  Attribute Reference --
1025    ------------------------------
1026
1027    --  Parsed by P_Name (4.1)
1028
1029    -------------------------------
1030    -- 4.1  Attribute Designator --
1031    -------------------------------
1032
1033    --  Parsed by P_Name (4.1)
1034
1035    --------------------------------------
1036    -- 4.1.4  Range Attribute Reference --
1037    --------------------------------------
1038
1039    --  RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR
1040
1041    --  RANGE_ATTRIBUTE_DESIGNATOR ::= range [(static_EXPRESSION)]
1042
1043    --  In the grammar, a RANGE attribute is simply a name, but its use is
1044    --  highly restricted, so in the parser, we do not regard it as a name.
1045    --  Instead, P_Name returns without scanning the 'RANGE part of the
1046    --  attribute, and the caller uses the following function to construct
1047    --  a range attribute in places where it is appropriate.
1048
1049    --  Note that RANGE here is treated essentially as an identifier,
1050    --  rather than a reserved word.
1051
1052    --  The caller has parsed the prefix, i.e. a name, and Token points to
1053    --  the apostrophe. The token after the apostrophe is known to be RANGE
1054    --  at this point. The prefix node becomes the prefix of the attribute.
1055
1056    --  Error_Recovery: Cannot raise Error_Resync
1057
1058    function P_Range_Attribute_Reference
1059      (Prefix_Node : Node_Id)
1060       return        Node_Id
1061    is
1062       Attr_Node  : Node_Id;
1063
1064    begin
1065       Attr_Node := New_Node (N_Attribute_Reference, Token_Ptr);
1066       Set_Prefix (Attr_Node, Prefix_Node);
1067       Scan; -- past apostrophe
1068
1069       if Style_Check then
1070          Style.Check_Attribute_Name (True);
1071       end if;
1072
1073       Set_Attribute_Name (Attr_Node, Name_Range);
1074       Scan; -- past RANGE
1075
1076       if Token = Tok_Left_Paren then
1077          Scan; -- past left paren
1078          Set_Expressions (Attr_Node, New_List (P_Expression_If_OK));
1079          T_Right_Paren;
1080       end if;
1081
1082       return Attr_Node;
1083    end P_Range_Attribute_Reference;
1084
1085    ---------------------------------------
1086    -- 4.1.4  Range Attribute Designator --
1087    ---------------------------------------
1088
1089    --  Parsed by P_Range_Attribute_Reference (4.4)
1090
1091    --------------------
1092    -- 4.3  Aggregate --
1093    --------------------
1094
1095    --  AGGREGATE ::= RECORD_AGGREGATE | EXTENSION_AGGREGATE | ARRAY_AGGREGATE
1096
1097    --  Parsed by P_Aggregate_Or_Paren_Expr (4.3), except in the case where
1098    --  an aggregate is known to be required (code statement, extension
1099    --  aggregate), in which cases this routine performs the necessary check
1100    --  that we have an aggregate rather than a parenthesized expression
1101
1102    --  Error recovery: can raise Error_Resync
1103
1104    function P_Aggregate return Node_Id is
1105       Aggr_Sloc : constant Source_Ptr := Token_Ptr;
1106       Aggr_Node : constant Node_Id    := P_Aggregate_Or_Paren_Expr;
1107
1108    begin
1109       if Nkind (Aggr_Node) /= N_Aggregate
1110            and then
1111          Nkind (Aggr_Node) /= N_Extension_Aggregate
1112       then
1113          Error_Msg
1114            ("aggregate may not have single positional component", Aggr_Sloc);
1115          return Error;
1116       else
1117          return Aggr_Node;
1118       end if;
1119    end P_Aggregate;
1120
1121    ------------------------------------------------
1122    -- 4.3  Aggregate or Parenthesized Expression --
1123    ------------------------------------------------
1124
1125    --  This procedure parses out either an aggregate or a parenthesized
1126    --  expression (these two constructs are closely related, since a
1127    --  parenthesized expression looks like an aggregate with a single
1128    --  positional component).
1129
1130    --  AGGREGATE ::=
1131    --    RECORD_AGGREGATE | EXTENSION_AGGREGATE | ARRAY_AGGREGATE
1132
1133    --  RECORD_AGGREGATE ::= (RECORD_COMPONENT_ASSOCIATION_LIST)
1134
1135    --  RECORD_COMPONENT_ASSOCIATION_LIST ::=
1136    --     RECORD_COMPONENT_ASSOCIATION {, RECORD_COMPONENT_ASSOCIATION}
1137    --   | null record
1138
1139    --  RECORD_COMPONENT_ASSOCIATION ::=
1140    --    [COMPONENT_CHOICE_LIST =>] EXPRESSION
1141
1142    --  COMPONENT_CHOICE_LIST ::=
1143    --    component_SELECTOR_NAME {| component_SELECTOR_NAME}
1144    --  | others
1145
1146    --  EXTENSION_AGGREGATE ::=
1147    --    (ANCESTOR_PART with RECORD_COMPONENT_ASSOCIATION_LIST)
1148
1149    --  ANCESTOR_PART ::= EXPRESSION | SUBTYPE_MARK
1150
1151    --  ARRAY_AGGREGATE ::=
1152    --    POSITIONAL_ARRAY_AGGREGATE | NAMED_ARRAY_AGGREGATE
1153
1154    --  POSITIONAL_ARRAY_AGGREGATE ::=
1155    --    (EXPRESSION, EXPRESSION {, EXPRESSION})
1156    --  | (EXPRESSION {, EXPRESSION}, others => EXPRESSION)
1157    --  | (EXPRESSION {, EXPRESSION}, others => <>)
1158
1159    --  NAMED_ARRAY_AGGREGATE ::=
1160    --    (ARRAY_COMPONENT_ASSOCIATION {, ARRAY_COMPONENT_ASSOCIATION})
1161
1162    --  PRIMARY ::= (EXPRESSION);
1163
1164    --  Error recovery: can raise Error_Resync
1165
1166    --  Note: POSITIONAL_ARRAY_AGGREGATE rule has been extended to give support
1167    --        to Ada 2005 limited aggregates (AI-287)
1168
1169    function P_Aggregate_Or_Paren_Expr return Node_Id is
1170       Aggregate_Node : Node_Id;
1171       Expr_List      : List_Id;
1172       Assoc_List     : List_Id;
1173       Expr_Node      : Node_Id;
1174       Lparen_Sloc    : Source_Ptr;
1175       Scan_State     : Saved_Scan_State;
1176
1177       procedure Box_Error;
1178       --  Called if <> is encountered as positional aggregate element. Issues
1179       --  error message and sets Expr_Node to Error.
1180
1181       ---------------
1182       -- Box_Error --
1183       ---------------
1184
1185       procedure Box_Error is
1186       begin
1187          if Ada_Version < Ada_2005 then
1188             Error_Msg_SC ("box in aggregate is an Ada 2005 extension");
1189          end if;
1190
1191          --  Ada 2005 (AI-287): The box notation is allowed only with named
1192          --  notation because positional notation might be error prone. For
1193          --  example, in "(X, <>, Y, <>)", there is no type associated with
1194          --  the boxes, so you might not be leaving out the components you
1195          --  thought you were leaving out.
1196
1197          Error_Msg_SC ("(Ada 2005) box only allowed with named notation");
1198          Scan; -- past box
1199          Expr_Node := Error;
1200       end Box_Error;
1201
1202    --  Start of processing for P_Aggregate_Or_Paren_Expr
1203
1204    begin
1205       Lparen_Sloc := Token_Ptr;
1206       T_Left_Paren;
1207
1208       --  Conditional expression case
1209
1210       if Token = Tok_If then
1211          Expr_Node := P_Conditional_Expression;
1212          T_Right_Paren;
1213          return Expr_Node;
1214
1215       --  Case expression case
1216
1217       elsif Token = Tok_Case then
1218          Expr_Node := P_Case_Expression;
1219          T_Right_Paren;
1220          return Expr_Node;
1221
1222       --  Quantified expression case
1223
1224       elsif Token = Tok_For then
1225          Expr_Node := P_Quantified_Expression;
1226          T_Right_Paren;
1227          return Expr_Node;
1228
1229       --  Note: the mechanism used here of rescanning the initial expression
1230       --  is distinctly unpleasant, but it saves a lot of fiddling in scanning
1231       --  out the discrete choice list.
1232
1233       --  Deal with expression and extension aggregate cases first
1234
1235       elsif Token /= Tok_Others then
1236          Save_Scan_State (Scan_State); -- at start of expression
1237
1238          --  Deal with (NULL RECORD) case
1239
1240          if Token = Tok_Null then
1241             Scan; -- past NULL
1242
1243             if Token = Tok_Record then
1244                Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
1245                Set_Null_Record_Present (Aggregate_Node, True);
1246                Scan; -- past RECORD
1247                T_Right_Paren;
1248                return Aggregate_Node;
1249             else
1250                Restore_Scan_State (Scan_State); -- to NULL that must be expr
1251             end if;
1252          end if;
1253
1254          --  Scan expression, handling box appearing as positional argument
1255
1256          if Token = Tok_Box then
1257             Box_Error;
1258          else
1259             Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
1260          end if;
1261
1262          --  Extension aggregate case
1263
1264          if Token = Tok_With then
1265             if Nkind (Expr_Node) = N_Attribute_Reference
1266               and then Attribute_Name (Expr_Node) = Name_Range
1267             then
1268                Bad_Range_Attribute (Sloc (Expr_Node));
1269                return Error;
1270             end if;
1271
1272             if Ada_Version = Ada_83 then
1273                Error_Msg_SC ("(Ada 83) extension aggregate not allowed");
1274             end if;
1275
1276             Aggregate_Node := New_Node (N_Extension_Aggregate, Lparen_Sloc);
1277             Set_Ancestor_Part (Aggregate_Node, Expr_Node);
1278             Scan; -- past WITH
1279
1280             --  Deal with WITH NULL RECORD case
1281
1282             if Token = Tok_Null then
1283                Save_Scan_State (Scan_State); -- at NULL
1284                Scan; -- past NULL
1285
1286                if Token = Tok_Record then
1287                   Scan; -- past RECORD
1288                   Set_Null_Record_Present (Aggregate_Node, True);
1289                   T_Right_Paren;
1290                   return Aggregate_Node;
1291
1292                else
1293                   Restore_Scan_State (Scan_State); -- to NULL that must be expr
1294                end if;
1295             end if;
1296
1297             if Token /= Tok_Others then
1298                Save_Scan_State (Scan_State);
1299                Expr_Node := P_Expression;
1300             else
1301                Expr_Node := Empty;
1302             end if;
1303
1304          --  Expression case
1305
1306          elsif Token = Tok_Right_Paren or else Token in Token_Class_Eterm then
1307             if Nkind (Expr_Node) = N_Attribute_Reference
1308               and then Attribute_Name (Expr_Node) = Name_Range
1309             then
1310                Error_Msg
1311                  ("|parentheses not allowed for range attribute", Lparen_Sloc);
1312                Scan; -- past right paren
1313                return Expr_Node;
1314             end if;
1315
1316             --  Bump paren count of expression
1317
1318             if Expr_Node /= Error then
1319                Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1);
1320             end if;
1321
1322             T_Right_Paren; -- past right paren (error message if none)
1323             return Expr_Node;
1324
1325          --  Normal aggregate case
1326
1327          else
1328             Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
1329          end if;
1330
1331       --  Others case
1332
1333       else
1334          Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
1335          Expr_Node := Empty;
1336       end if;
1337
1338       --  Prepare to scan list of component associations
1339
1340       Expr_List  := No_List; -- don't set yet, maybe all named entries
1341       Assoc_List := No_List; -- don't set yet, maybe all positional entries
1342
1343       --  This loop scans through component associations. On entry to the
1344       --  loop, an expression has been scanned at the start of the current
1345       --  association unless initial token was OTHERS, in which case
1346       --  Expr_Node is set to Empty.
1347
1348       loop
1349          --  Deal with others association first. This is a named association
1350
1351          if No (Expr_Node) then
1352             if No (Assoc_List) then
1353                Assoc_List := New_List;
1354             end if;
1355
1356             Append (P_Record_Or_Array_Component_Association, Assoc_List);
1357
1358          --  Improper use of WITH
1359
1360          elsif Token = Tok_With then
1361             Error_Msg_SC ("WITH must be preceded by single expression in " &
1362                              "extension aggregate");
1363             raise Error_Resync;
1364
1365          --  Range attribute can only appear as part of a discrete choice list
1366
1367          elsif Nkind (Expr_Node) = N_Attribute_Reference
1368            and then Attribute_Name (Expr_Node) = Name_Range
1369            and then Token /= Tok_Arrow
1370            and then Token /= Tok_Vertical_Bar
1371          then
1372             Bad_Range_Attribute (Sloc (Expr_Node));
1373             return Error;
1374
1375          --  Assume positional case if comma, right paren, or literal or
1376          --  identifier or OTHERS follows (the latter cases are missing
1377          --  comma cases). Also assume positional if a semicolon follows,
1378          --  which can happen if there are missing parens
1379
1380          elsif Token = Tok_Comma
1381            or else Token = Tok_Right_Paren
1382            or else Token = Tok_Others
1383            or else Token in Token_Class_Lit_Or_Name
1384            or else Token = Tok_Semicolon
1385          then
1386             if Present (Assoc_List) then
1387                Error_Msg_BC -- CODEFIX
1388                   ("""='>"" expected (positional association cannot follow " &
1389                    "named association)");
1390             end if;
1391
1392             if No (Expr_List) then
1393                Expr_List := New_List;
1394             end if;
1395
1396             Append (Expr_Node, Expr_List);
1397
1398          --  Check for aggregate followed by left parent, maybe missing comma
1399
1400          elsif Nkind (Expr_Node) = N_Aggregate
1401            and then Token = Tok_Left_Paren
1402          then
1403             T_Comma;
1404
1405             if No (Expr_List) then
1406                Expr_List := New_List;
1407             end if;
1408
1409             Append (Expr_Node, Expr_List);
1410
1411          --  Anything else is assumed to be a named association
1412
1413          else
1414             Restore_Scan_State (Scan_State); -- to start of expression
1415
1416             if No (Assoc_List) then
1417                Assoc_List := New_List;
1418             end if;
1419
1420             Append (P_Record_Or_Array_Component_Association, Assoc_List);
1421          end if;
1422
1423          exit when not Comma_Present;
1424
1425          --  If we are at an expression terminator, something is seriously
1426          --  wrong, so let's get out now, before we start eating up stuff
1427          --  that doesn't belong to us!
1428
1429          if Token in Token_Class_Eterm then
1430
1431             --  If Some becomes a keyword, the following is needed to make it
1432             --  acceptable in older versions of Ada.
1433
1434             if Token = Tok_Some
1435               and then Ada_Version < Ada_2012
1436             then
1437                Scan_Reserved_Identifier (False);
1438             else
1439                Error_Msg_AP
1440                  ("expecting expression or component association");
1441                exit;
1442             end if;
1443          end if;
1444
1445          --  Deal with misused box
1446
1447          if Token = Tok_Box then
1448             Box_Error;
1449
1450          --  Otherwise initiate for reentry to top of loop by scanning an
1451          --  initial expression, unless the first token is OTHERS.
1452
1453          elsif Token = Tok_Others then
1454             Expr_Node := Empty;
1455
1456          else
1457             Save_Scan_State (Scan_State); -- at start of expression
1458             Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
1459
1460          end if;
1461       end loop;
1462
1463       --  All component associations (positional and named) have been scanned
1464
1465       T_Right_Paren;
1466       Set_Expressions (Aggregate_Node, Expr_List);
1467       Set_Component_Associations (Aggregate_Node, Assoc_List);
1468       return Aggregate_Node;
1469    end P_Aggregate_Or_Paren_Expr;
1470
1471    ------------------------------------------------
1472    -- 4.3  Record or Array Component Association --
1473    ------------------------------------------------
1474
1475    --  RECORD_COMPONENT_ASSOCIATION ::=
1476    --    [COMPONENT_CHOICE_LIST =>] EXPRESSION
1477    --  | COMPONENT_CHOICE_LIST => <>
1478
1479    --  COMPONENT_CHOICE_LIST =>
1480    --    component_SELECTOR_NAME {| component_SELECTOR_NAME}
1481    --  | others
1482
1483    --  ARRAY_COMPONENT_ASSOCIATION ::=
1484    --    DISCRETE_CHOICE_LIST => EXPRESSION
1485    --  | DISCRETE_CHOICE_LIST => <>
1486
1487    --  Note: this routine only handles the named cases, including others.
1488    --  Cases where the component choice list is not present have already
1489    --  been handled directly.
1490
1491    --  Error recovery: can raise Error_Resync
1492
1493    --  Note: RECORD_COMPONENT_ASSOCIATION and ARRAY_COMPONENT_ASSOCIATION
1494    --        rules have been extended to give support to Ada 2005 limited
1495    --        aggregates (AI-287)
1496
1497    function P_Record_Or_Array_Component_Association return Node_Id is
1498       Assoc_Node : Node_Id;
1499
1500    begin
1501       Assoc_Node := New_Node (N_Component_Association, Token_Ptr);
1502       Set_Choices (Assoc_Node, P_Discrete_Choice_List);
1503       Set_Sloc (Assoc_Node, Token_Ptr);
1504       TF_Arrow;
1505
1506       if Token = Tok_Box then
1507
1508          --  Ada 2005(AI-287): The box notation is used to indicate the
1509          --  default initialization of aggregate components
1510
1511          if Ada_Version < Ada_2005 then
1512             Error_Msg_SP
1513               ("component association with '<'> is an Ada 2005 extension");
1514             Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1515          end if;
1516
1517          Set_Box_Present (Assoc_Node);
1518          Scan; -- Past box
1519       else
1520          Set_Expression (Assoc_Node, P_Expression);
1521       end if;
1522
1523       return Assoc_Node;
1524    end P_Record_Or_Array_Component_Association;
1525
1526    -----------------------------
1527    -- 4.3.1  Record Aggregate --
1528    -----------------------------
1529
1530    --  Case of enumeration aggregate is parsed by P_Aggregate (4.3)
1531    --  All other cases are parsed by P_Aggregate_Or_Paren_Expr (4.3)
1532
1533    ----------------------------------------------
1534    -- 4.3.1  Record Component Association List --
1535    ----------------------------------------------
1536
1537    --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1538
1539    ----------------------------------
1540    -- 4.3.1  Component Choice List --
1541    ----------------------------------
1542
1543    --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1544
1545    --------------------------------
1546    -- 4.3.1  Extension Aggregate --
1547    --------------------------------
1548
1549    --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1550
1551    --------------------------
1552    -- 4.3.1  Ancestor Part --
1553    --------------------------
1554
1555    --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1556
1557    ----------------------------
1558    -- 4.3.1  Array Aggregate --
1559    ----------------------------
1560
1561    --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1562
1563    ---------------------------------------
1564    -- 4.3.1  Positional Array Aggregate --
1565    ---------------------------------------
1566
1567    --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1568
1569    ----------------------------------
1570    -- 4.3.1  Named Array Aggregate --
1571    ----------------------------------
1572
1573    --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1574
1575    ----------------------------------------
1576    -- 4.3.1  Array Component Association --
1577    ----------------------------------------
1578
1579    --  Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1580
1581    ---------------------
1582    -- 4.4  Expression --
1583    ---------------------
1584
1585    --  This procedure parses EXPRESSION or CHOICE_EXPRESSION
1586
1587    --  EXPRESSION ::=
1588    --    RELATION {LOGICAL_OPERATOR RELATION}
1589
1590    --  CHOICE_EXPRESSION ::=
1591    --    CHOICE_RELATION {LOGICAL_OPERATOR CHOICE_RELATION}
1592
1593    --  LOGICAL_OPERATOR ::= and | and then | or | or else | xor
1594
1595    --  On return, Expr_Form indicates the categorization of the expression
1596    --  EF_Range_Attr is not a possible value (if a range attribute is found,
1597    --  an error message is given, and Error is returned).
1598
1599    --  Error recovery: cannot raise Error_Resync
1600
1601    function P_Expression return Node_Id is
1602       Logical_Op      : Node_Kind;
1603       Prev_Logical_Op : Node_Kind;
1604       Op_Location     : Source_Ptr;
1605       Node1           : Node_Id;
1606       Node2           : Node_Id;
1607
1608    begin
1609       Node1 := P_Relation;
1610
1611       if Token in Token_Class_Logop then
1612          Prev_Logical_Op := N_Empty;
1613
1614          loop
1615             Op_Location := Token_Ptr;
1616             Logical_Op := P_Logical_Operator;
1617
1618             if Prev_Logical_Op /= N_Empty and then
1619                Logical_Op /= Prev_Logical_Op
1620             then
1621                Error_Msg
1622                  ("mixed logical operators in expression", Op_Location);
1623                Prev_Logical_Op := N_Empty;
1624             else
1625                Prev_Logical_Op := Logical_Op;
1626             end if;
1627
1628             Node2 := Node1;
1629             Node1 := New_Op_Node (Logical_Op, Op_Location);
1630             Set_Left_Opnd (Node1, Node2);
1631             Set_Right_Opnd (Node1, P_Relation);
1632             exit when Token not in Token_Class_Logop;
1633          end loop;
1634
1635          Expr_Form := EF_Non_Simple;
1636       end if;
1637
1638       if Token = Tok_Apostrophe then
1639          Bad_Range_Attribute (Token_Ptr);
1640          return Error;
1641       else
1642          return Node1;
1643       end if;
1644    end P_Expression;
1645
1646    --  This function is identical to the normal P_Expression, except that it
1647    --  also permits the appearance of a case, conditional, or quantified
1648    --  expression without the usual surrounding parentheses.
1649
1650    function P_Expression_If_OK return Node_Id is
1651    begin
1652       if Token = Tok_Case then
1653          return P_Case_Expression;
1654
1655       elsif Token = Tok_If then
1656          return P_Conditional_Expression;
1657
1658       elsif Token = Tok_For then
1659          return P_Quantified_Expression;
1660
1661       else
1662          return P_Expression;
1663       end if;
1664    end P_Expression_If_OK;
1665
1666    --  This function is identical to the normal P_Expression, except that it
1667    --  checks that the expression scan did not stop on a right paren. It is
1668    --  called in all contexts where a right parenthesis cannot legitimately
1669    --  follow an expression.
1670
1671    --  Error recovery: can not raise Error_Resync
1672
1673    function P_Expression_No_Right_Paren return Node_Id is
1674       Expr : constant Node_Id := P_Expression;
1675    begin
1676       Ignore (Tok_Right_Paren);
1677       return Expr;
1678    end P_Expression_No_Right_Paren;
1679
1680    ----------------------------------------
1681    -- 4.4  Expression_Or_Range_Attribute --
1682    ----------------------------------------
1683
1684    --  EXPRESSION ::=
1685    --    RELATION {and RELATION} | RELATION {and then RELATION}
1686    --  | RELATION {or RELATION}  | RELATION {or else RELATION}
1687    --  | RELATION {xor RELATION}
1688
1689    --  RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR
1690
1691    --  RANGE_ATTRIBUTE_DESIGNATOR ::= range [(static_EXPRESSION)]
1692
1693    --  On return, Expr_Form indicates the categorization of the expression
1694    --  and EF_Range_Attr is one of the possibilities.
1695
1696    --  Error recovery: cannot raise Error_Resync
1697
1698    --  In the grammar, a RANGE attribute is simply a name, but its use is
1699    --  highly restricted, so in the parser, we do not regard it as a name.
1700    --  Instead, P_Name returns without scanning the 'RANGE part of the
1701    --  attribute, and P_Expression_Or_Range_Attribute handles the range
1702    --  attribute reference. In the normal case where a range attribute is
1703    --  not allowed, an error message is issued by P_Expression.
1704
1705    function P_Expression_Or_Range_Attribute return Node_Id is
1706       Logical_Op      : Node_Kind;
1707       Prev_Logical_Op : Node_Kind;
1708       Op_Location     : Source_Ptr;
1709       Node1           : Node_Id;
1710       Node2           : Node_Id;
1711       Attr_Node       : Node_Id;
1712
1713    begin
1714       Node1 := P_Relation;
1715
1716       if Token = Tok_Apostrophe then
1717          Attr_Node := P_Range_Attribute_Reference (Node1);
1718          Expr_Form := EF_Range_Attr;
1719          return Attr_Node;
1720
1721       elsif Token in Token_Class_Logop then
1722          Prev_Logical_Op := N_Empty;
1723
1724          loop
1725             Op_Location := Token_Ptr;
1726             Logical_Op := P_Logical_Operator;
1727
1728             if Prev_Logical_Op /= N_Empty and then
1729                Logical_Op /= Prev_Logical_Op
1730             then
1731                Error_Msg
1732                  ("mixed logical operators in expression", Op_Location);
1733                Prev_Logical_Op := N_Empty;
1734             else
1735                Prev_Logical_Op := Logical_Op;
1736             end if;
1737
1738             Node2 := Node1;
1739             Node1 := New_Op_Node (Logical_Op, Op_Location);
1740             Set_Left_Opnd (Node1, Node2);
1741             Set_Right_Opnd (Node1, P_Relation);
1742             exit when Token not in Token_Class_Logop;
1743          end loop;
1744
1745          Expr_Form := EF_Non_Simple;
1746       end if;
1747
1748       if Token = Tok_Apostrophe then
1749          Bad_Range_Attribute (Token_Ptr);
1750          return Error;
1751       else
1752          return Node1;
1753       end if;
1754    end P_Expression_Or_Range_Attribute;
1755
1756    --  Version that allows a non-parenthesized case, conditional, or quantified
1757    --  expression
1758
1759    function P_Expression_Or_Range_Attribute_If_OK return Node_Id is
1760    begin
1761       if Token = Tok_Case then
1762          return P_Case_Expression;
1763
1764       elsif Token = Tok_If then
1765          return P_Conditional_Expression;
1766
1767       elsif Token = Tok_For then
1768          return P_Quantified_Expression;
1769
1770       else
1771          return P_Expression_Or_Range_Attribute;
1772       end if;
1773    end P_Expression_Or_Range_Attribute_If_OK;
1774
1775    -------------------
1776    -- 4.4  Relation --
1777    -------------------
1778
1779    --  This procedure scans both relations and choice relations
1780
1781    --  CHOICE_RELATION ::=
1782    --    SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION]
1783
1784    --  RELATION ::=
1785    --    SIMPLE_EXPRESSION [not] in MEMBERSHIP_CHOICE_LIST
1786
1787    --  MEMBERSHIP_CHOICE_LIST ::=
1788    --    MEMBERSHIP_CHOICE {'|' MEMBERSHIP CHOICE}
1789
1790    --  MEMBERSHIP_CHOICE ::=
1791    --    CHOICE_EXPRESSION | RANGE | SUBTYPE_MARK
1792
1793    --  On return, Expr_Form indicates the categorization of the expression
1794
1795    --  Note: if Token = Tok_Apostrophe on return, then Expr_Form is set to
1796    --  EF_Simple_Name and the following token is RANGE (range attribute case).
1797
1798    --  Error recovery: cannot raise Error_Resync. If an error occurs within an
1799    --  expression, then tokens are scanned until either a non-expression token,
1800    --  a right paren (not matched by a left paren) or a comma, is encountered.
1801
1802    function P_Relation return Node_Id is
1803       Node1, Node2 : Node_Id;
1804       Optok        : Source_Ptr;
1805
1806    begin
1807       Node1 := P_Simple_Expression;
1808
1809       if Token not in Token_Class_Relop then
1810          return Node1;
1811
1812       else
1813          --  Here we have a relational operator following. If so then scan it
1814          --  out. Note that the assignment symbol := is treated as a relational
1815          --  operator to improve the error recovery when it is misused for =.
1816          --  P_Relational_Operator also parses the IN and NOT IN operations.
1817
1818          Optok := Token_Ptr;
1819          Node2 := New_Op_Node (P_Relational_Operator, Optok);
1820          Set_Left_Opnd (Node2, Node1);
1821
1822          --  Case of IN or NOT IN
1823
1824          if Prev_Token = Tok_In then
1825             P_Membership_Test (Node2);
1826
1827          --  Case of relational operator (= /= < <= > >=)
1828
1829          else
1830             Set_Right_Opnd (Node2, P_Simple_Expression);
1831          end if;
1832
1833          Expr_Form := EF_Non_Simple;
1834
1835          if Token in Token_Class_Relop then
1836             Error_Msg_SC ("unexpected relational operator");
1837             raise Error_Resync;
1838          end if;
1839
1840          return Node2;
1841       end if;
1842
1843    --  If any error occurs, then scan to the next expression terminator symbol
1844    --  or comma or right paren at the outer (i.e. current) parentheses level.
1845    --  The flags are set to indicate a normal simple expression.
1846
1847    exception
1848       when Error_Resync =>
1849          Resync_Expression;
1850          Expr_Form := EF_Simple;
1851          return Error;
1852    end P_Relation;
1853
1854    ----------------------------
1855    -- 4.4  Simple Expression --
1856    ----------------------------
1857
1858    --  SIMPLE_EXPRESSION ::=
1859    --    [UNARY_ADDING_OPERATOR] TERM {BINARY_ADDING_OPERATOR TERM}
1860
1861    --  On return, Expr_Form indicates the categorization of the expression
1862
1863    --  Note: if Token = Tok_Apostrophe on return, then Expr_Form is set to
1864    --  EF_Simple_Name and the following token is RANGE (range attribute case).
1865
1866    --  Error recovery: cannot raise Error_Resync. If an error occurs within an
1867    --  expression, then tokens are scanned until either a non-expression token,
1868    --  a right paren (not matched by a left paren) or a comma, is encountered.
1869
1870    --  Note: P_Simple_Expression is called only internally by higher level
1871    --  expression routines. In cases in the grammar where a simple expression
1872    --  is required, the approach is to scan an expression, and then post an
1873    --  appropriate error message if the expression obtained is not simple. This
1874    --  gives better error recovery and treatment.
1875
1876    function P_Simple_Expression return Node_Id is
1877       Scan_State : Saved_Scan_State;
1878       Node1      : Node_Id;
1879       Node2      : Node_Id;
1880       Tokptr     : Source_Ptr;
1881
1882    begin
1883       --  Check for cases starting with a name. There are two reasons for
1884       --  special casing. First speed things up by catching a common case
1885       --  without going through several routine layers. Second the caller must
1886       --  be informed via Expr_Form when the simple expression is a name.
1887
1888       if Token in Token_Class_Name then
1889          Node1 := P_Name;
1890
1891          --  Deal with apostrophe cases
1892
1893          if Token = Tok_Apostrophe then
1894             Save_Scan_State (Scan_State); -- at apostrophe
1895             Scan; -- past apostrophe
1896
1897             --  If qualified expression, scan it out and fall through
1898
1899             if Token = Tok_Left_Paren then
1900                Node1 := P_Qualified_Expression (Node1);
1901                Expr_Form := EF_Simple;
1902
1903             --  If range attribute, then we return with Token pointing to the
1904             --  apostrophe. Note: avoid the normal error check on exit. We
1905             --  know that the expression really is complete in this case!
1906
1907             else -- Token = Tok_Range then
1908                Restore_Scan_State (Scan_State); -- to apostrophe
1909                Expr_Form := EF_Simple_Name;
1910                return Node1;
1911             end if;
1912          end if;
1913
1914          --  If an expression terminator follows, the previous processing
1915          --  completely scanned out the expression (a common case), and
1916          --  left Expr_Form set appropriately for returning to our caller.
1917
1918          if Token in Token_Class_Sterm then
1919             null;
1920
1921          --  If we do not have an expression terminator, then complete the
1922          --  scan of a simple expression. This code duplicates the code
1923          --  found in P_Term and P_Factor.
1924
1925          else
1926             if Token = Tok_Double_Asterisk then
1927                if Style_Check then
1928                   Style.Check_Exponentiation_Operator;
1929                end if;
1930
1931                Node2 := New_Op_Node (N_Op_Expon, Token_Ptr);
1932                Scan; -- past **
1933                Set_Left_Opnd (Node2, Node1);
1934                Set_Right_Opnd (Node2, P_Primary);
1935                Node1 := Node2;
1936             end if;
1937
1938             loop
1939                exit when Token not in Token_Class_Mulop;
1940                Tokptr := Token_Ptr;
1941                Node2 := New_Op_Node (P_Multiplying_Operator, Tokptr);
1942
1943                if Style_Check then
1944                   Style.Check_Binary_Operator;
1945                end if;
1946
1947                Scan; -- past operator
1948                Set_Left_Opnd (Node2, Node1);
1949                Set_Right_Opnd (Node2, P_Factor);
1950                Node1 := Node2;
1951             end loop;
1952
1953             loop
1954                exit when Token not in Token_Class_Binary_Addop;
1955                Tokptr := Token_Ptr;
1956                Node2 := New_Op_Node (P_Binary_Adding_Operator, Tokptr);
1957
1958                if Style_Check then
1959                   Style.Check_Binary_Operator;
1960                end if;
1961
1962                Scan; -- past operator
1963                Set_Left_Opnd (Node2, Node1);
1964                Set_Right_Opnd (Node2, P_Term);
1965                Node1 := Node2;
1966             end loop;
1967
1968             Expr_Form := EF_Simple;
1969          end if;
1970
1971       --  Cases where simple expression does not start with a name
1972
1973       else
1974          --  Scan initial sign and initial Term
1975
1976          if Token in Token_Class_Unary_Addop then
1977             Tokptr := Token_Ptr;
1978             Node1 := New_Op_Node (P_Unary_Adding_Operator, Tokptr);
1979
1980             if Style_Check then
1981                Style.Check_Unary_Plus_Or_Minus;
1982             end if;
1983
1984             Scan; -- past operator
1985             Set_Right_Opnd (Node1, P_Term);
1986          else
1987             Node1 := P_Term;
1988          end if;
1989
1990          --  In the following, we special-case a sequence of concatenations of
1991          --  string literals, such as "aaa" & "bbb" & ... & "ccc", with nothing
1992          --  else mixed in. For such a sequence, we return a tree representing
1993          --  "" & "aaabbb...ccc" (a single concatenation). This is done only if
1994          --  the number of concatenations is large. If semantic analysis
1995          --  resolves the "&" to a predefined one, then this folding gives the
1996          --  right answer. Otherwise, semantic analysis will complain about a
1997          --  capacity-exceeded error. The purpose of this trick is to avoid
1998          --  creating a deeply nested tree, which would cause deep recursion
1999          --  during semantics, causing stack overflow. This way, we can handle
2000          --  enormous concatenations in the normal case of predefined "&".  We
2001          --  first build up the normal tree, and then rewrite it if
2002          --  appropriate.
2003
2004          declare
2005             Num_Concats_Threshold : constant Positive := 1000;
2006             --  Arbitrary threshold value to enable optimization
2007
2008             First_Node : constant Node_Id := Node1;
2009             Is_Strlit_Concat : Boolean;
2010             --  True iff we've parsed a sequence of concatenations of string
2011             --  literals, with nothing else mixed in.
2012
2013             Num_Concats : Natural;
2014             --  Number of "&" operators if Is_Strlit_Concat is True
2015
2016          begin
2017             Is_Strlit_Concat :=
2018               Nkind (Node1) = N_String_Literal
2019                 and then Token = Tok_Ampersand;
2020             Num_Concats := 0;
2021
2022             --  Scan out sequence of terms separated by binary adding operators
2023
2024             loop
2025                exit when Token not in Token_Class_Binary_Addop;
2026                Tokptr := Token_Ptr;
2027                Node2 := New_Op_Node (P_Binary_Adding_Operator, Tokptr);
2028                Scan; -- past operator
2029                Set_Left_Opnd (Node2, Node1);
2030                Node1 := P_Term;
2031                Set_Right_Opnd (Node2, Node1);
2032
2033                --  Check if we're still concatenating string literals
2034
2035                Is_Strlit_Concat :=
2036                  Is_Strlit_Concat
2037                    and then Nkind (Node2) = N_Op_Concat
2038                  and then Nkind (Node1) = N_String_Literal;
2039
2040                if Is_Strlit_Concat then
2041                   Num_Concats := Num_Concats + 1;
2042                end if;
2043
2044                Node1 := Node2;
2045             end loop;
2046
2047             --  If we have an enormous series of concatenations of string
2048             --  literals, rewrite as explained above. The Is_Folded_In_Parser
2049             --  flag tells semantic analysis that if the "&" is not predefined,
2050             --  the folded value is wrong.
2051
2052             if Is_Strlit_Concat
2053               and then Num_Concats >= Num_Concats_Threshold
2054             then
2055                declare
2056                   Empty_String_Val : String_Id;
2057                   --  String_Id for ""
2058
2059                   Strlit_Concat_Val : String_Id;
2060                   --  Contains the folded value (which will be correct if the
2061                   --  "&" operators are the predefined ones).
2062
2063                   Cur_Node : Node_Id;
2064                   --  For walking up the tree
2065
2066                   New_Node : Node_Id;
2067                   --  Folded node to replace Node1
2068
2069                   Loc : constant Source_Ptr := Sloc (First_Node);
2070
2071                begin
2072                   --  Walk up the tree starting at the leftmost string literal
2073                   --  (First_Node), building up the Strlit_Concat_Val as we
2074                   --  go. Note that we do not use recursion here -- the whole
2075                   --  point is to avoid recursively walking that enormous tree.
2076
2077                   Start_String;
2078                   Store_String_Chars (Strval (First_Node));
2079
2080                   Cur_Node := Parent (First_Node);
2081                   while Present (Cur_Node) loop
2082                      pragma Assert (Nkind (Cur_Node) = N_Op_Concat and then
2083                         Nkind (Right_Opnd (Cur_Node)) = N_String_Literal);
2084
2085                      Store_String_Chars (Strval (Right_Opnd (Cur_Node)));
2086                      Cur_Node := Parent (Cur_Node);
2087                   end loop;
2088
2089                   Strlit_Concat_Val := End_String;
2090
2091                   --  Create new folded node, and rewrite result with a concat-
2092                   --  enation of an empty string literal and the folded node.
2093
2094                   Start_String;
2095                   Empty_String_Val := End_String;
2096                   New_Node :=
2097                     Make_Op_Concat (Loc,
2098                       Make_String_Literal (Loc, Empty_String_Val),
2099                       Make_String_Literal (Loc, Strlit_Concat_Val,
2100                         Is_Folded_In_Parser => True));
2101                   Rewrite (Node1, New_Node);
2102                end;
2103             end if;
2104          end;
2105
2106          --  All done, we clearly do not have name or numeric literal so this
2107          --  is a case of a simple expression which is some other possibility.
2108
2109          Expr_Form := EF_Simple;
2110       end if;
2111
2112       --  Come here at end of simple expression, where we do a couple of
2113       --  special checks to improve error recovery.
2114
2115       --  Special test to improve error recovery. If the current token
2116       --  is a period, then someone is trying to do selection on something
2117       --  that is not a name, e.g. a qualified expression.
2118
2119       if Token = Tok_Dot then
2120          Error_Msg_SC ("prefix for selection is not a name");
2121
2122          --  If qualified expression, comment and continue, otherwise something
2123          --  is pretty nasty so do an Error_Resync call.
2124
2125          if Ada_Version < Ada_2012
2126            and then Nkind (Node1) = N_Qualified_Expression
2127          then
2128             Error_Msg_SC ("\would be legal in Ada 2012 mode");
2129          else
2130             raise Error_Resync;
2131          end if;
2132       end if;
2133
2134       --  Special test to improve error recovery: If the current token is
2135       --  not the first token on a line (as determined by checking the
2136       --  previous token position with the start of the current line),
2137       --  then we insist that we have an appropriate terminating token.
2138       --  Consider the following two examples:
2139
2140       --   1)  if A nad B then ...
2141
2142       --   2)  A := B
2143       --       C := D
2144
2145       --  In the first example, we would like to issue a binary operator
2146       --  expected message and resynchronize to the then. In the second
2147       --  example, we do not want to issue a binary operator message, so
2148       --  that instead we will get the missing semicolon message. This
2149       --  distinction is of course a heuristic which does not always work,
2150       --  but in practice it is quite effective.
2151
2152       --  Note: the one case in which we do not go through this circuit is
2153       --  when we have scanned a range attribute and want to return with
2154       --  Token pointing to the apostrophe. The apostrophe is not normally
2155       --  an expression terminator, and is not in Token_Class_Sterm, but
2156       --  in this special case we know that the expression is complete.
2157
2158       if not Token_Is_At_Start_Of_Line
2159          and then Token not in Token_Class_Sterm
2160       then
2161          --  Normally the right error message is indeed that we expected a
2162          --  binary operator, but in the case of being between a right and left
2163          --  paren, e.g. in an aggregate, a more likely error is missing comma.
2164
2165          if Prev_Token = Tok_Right_Paren and then Token = Tok_Left_Paren then
2166             T_Comma;
2167          else
2168             Error_Msg_AP ("binary operator expected");
2169          end if;
2170
2171          raise Error_Resync;
2172
2173       else
2174          return Node1;
2175       end if;
2176
2177    --  If any error occurs, then scan to next expression terminator symbol
2178    --  or comma, right paren or vertical bar at the outer (i.e. current) paren
2179    --  level. Expr_Form is set to indicate a normal simple expression.
2180
2181    exception
2182       when Error_Resync =>
2183          Resync_Expression;
2184          Expr_Form := EF_Simple;
2185          return Error;
2186    end P_Simple_Expression;
2187
2188    -----------------------------------------------
2189    -- 4.4  Simple Expression or Range Attribute --
2190    -----------------------------------------------
2191
2192    --  SIMPLE_EXPRESSION ::=
2193    --    [UNARY_ADDING_OPERATOR] TERM {BINARY_ADDING_OPERATOR TERM}
2194
2195    --  RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR
2196
2197    --  RANGE_ATTRIBUTE_DESIGNATOR ::= range [(static_EXPRESSION)]
2198
2199    --  Error recovery: cannot raise Error_Resync
2200
2201    function P_Simple_Expression_Or_Range_Attribute return Node_Id is
2202       Sexpr     : Node_Id;
2203       Attr_Node : Node_Id;
2204
2205    begin
2206       --  We don't just want to roar ahead and call P_Simple_Expression
2207       --  here, since we want to handle the case of a parenthesized range
2208       --  attribute cleanly.
2209
2210       if Token = Tok_Left_Paren then
2211          declare
2212             Lptr       : constant Source_Ptr := Token_Ptr;
2213             Scan_State : Saved_Scan_State;
2214
2215          begin
2216             Save_Scan_State (Scan_State);
2217             Scan; -- past left paren
2218             Sexpr := P_Simple_Expression;
2219
2220             if Token = Tok_Apostrophe then
2221                Attr_Node := P_Range_Attribute_Reference (Sexpr);
2222                Expr_Form := EF_Range_Attr;
2223
2224                if Token = Tok_Right_Paren then
2225                   Scan; -- scan past right paren if present
2226                end if;
2227
2228                Error_Msg ("parentheses not allowed for range attribute", Lptr);
2229
2230                return Attr_Node;
2231             end if;
2232
2233             Restore_Scan_State (Scan_State);
2234          end;
2235       end if;
2236
2237       --  Here after dealing with parenthesized range attribute
2238
2239       Sexpr := P_Simple_Expression;
2240
2241       if Token = Tok_Apostrophe then
2242          Attr_Node := P_Range_Attribute_Reference (Sexpr);
2243          Expr_Form := EF_Range_Attr;
2244          return Attr_Node;
2245
2246       else
2247          return Sexpr;
2248       end if;
2249    end P_Simple_Expression_Or_Range_Attribute;
2250
2251    ---------------
2252    -- 4.4  Term --
2253    ---------------
2254
2255    --  TERM ::= FACTOR {MULTIPLYING_OPERATOR FACTOR}
2256
2257    --  Error recovery: can raise Error_Resync
2258
2259    function P_Term return Node_Id is
2260       Node1, Node2 : Node_Id;
2261       Tokptr       : Source_Ptr;
2262
2263    begin
2264       Node1 := P_Factor;
2265
2266       loop
2267          exit when Token not in Token_Class_Mulop;
2268          Tokptr := Token_Ptr;
2269          Node2 := New_Op_Node (P_Multiplying_Operator, Tokptr);
2270          Scan; -- past operator
2271          Set_Left_Opnd (Node2, Node1);
2272          Set_Right_Opnd (Node2, P_Factor);
2273          Node1 := Node2;
2274       end loop;
2275
2276       return Node1;
2277    end P_Term;
2278
2279    -----------------
2280    -- 4.4  Factor --
2281    -----------------
2282
2283    --  FACTOR ::= PRIMARY [** PRIMARY] | abs PRIMARY | not PRIMARY
2284
2285    --  Error recovery: can raise Error_Resync
2286
2287    function P_Factor return Node_Id is
2288       Node1 : Node_Id;
2289       Node2 : Node_Id;
2290
2291    begin
2292       if Token = Tok_Abs then
2293          Node1 := New_Op_Node (N_Op_Abs, Token_Ptr);
2294
2295          if Style_Check then
2296             Style.Check_Abs_Not;
2297          end if;
2298
2299          Scan; -- past ABS
2300          Set_Right_Opnd (Node1, P_Primary);
2301          return Node1;
2302
2303       elsif Token = Tok_Not then
2304          Node1 := New_Op_Node (N_Op_Not, Token_Ptr);
2305
2306          if Style_Check then
2307             Style.Check_Abs_Not;
2308          end if;
2309
2310          Scan; -- past NOT
2311          Set_Right_Opnd (Node1, P_Primary);
2312          return Node1;
2313
2314       else
2315          Node1 := P_Primary;
2316
2317          if Token = Tok_Double_Asterisk then
2318             Node2 := New_Op_Node (N_Op_Expon, Token_Ptr);
2319             Scan; -- past **
2320             Set_Left_Opnd (Node2, Node1);
2321             Set_Right_Opnd (Node2, P_Primary);
2322             return Node2;
2323          else
2324             return Node1;
2325          end if;
2326       end if;
2327    end P_Factor;
2328
2329    ------------------
2330    -- 4.4  Primary --
2331    ------------------
2332
2333    --  PRIMARY ::=
2334    --    NUMERIC_LITERAL  | null
2335    --  | STRING_LITERAL   | AGGREGATE
2336    --  | NAME             | QUALIFIED_EXPRESSION
2337    --  | ALLOCATOR        | (EXPRESSION) | QUANTIFIED_EXPRESSION
2338
2339    --  Error recovery: can raise Error_Resync
2340
2341    function P_Primary return Node_Id is
2342       Scan_State : Saved_Scan_State;
2343       Node1      : Node_Id;
2344
2345    begin
2346       --  The loop runs more than once only if misplaced pragmas are found
2347
2348       loop
2349          case Token is
2350
2351             --  Name token can start a name, call or qualified expression, all
2352             --  of which are acceptable possibilities for primary. Note also
2353             --  that string literal is included in name (as operator symbol)
2354             --  and type conversion is included in name (as indexed component).
2355
2356             when Tok_Char_Literal | Tok_Operator_Symbol | Tok_Identifier =>
2357                Node1 := P_Name;
2358
2359                --  All done unless apostrophe follows
2360
2361                if Token /= Tok_Apostrophe then
2362                   return Node1;
2363
2364                --  Apostrophe following means that we have either just parsed
2365                --  the subtype mark of a qualified expression, or the prefix
2366                --  or a range attribute.
2367
2368                else -- Token = Tok_Apostrophe
2369                   Save_Scan_State (Scan_State); -- at apostrophe
2370                   Scan; -- past apostrophe
2371
2372                   --  If range attribute, then this is always an error, since
2373                   --  the only legitimate case (where the scanned expression is
2374                   --  a qualified simple name) is handled at the level of the
2375                   --  Simple_Expression processing. This case corresponds to a
2376                   --  usage such as 3 + A'Range, which is always illegal.
2377
2378                   if Token = Tok_Range then
2379                      Restore_Scan_State (Scan_State); -- to apostrophe
2380                      Bad_Range_Attribute (Token_Ptr);
2381                      return Error;
2382
2383                   --  If left paren, then we have a qualified expression.
2384                   --  Note that P_Name guarantees that in this case, where
2385                   --  Token = Tok_Apostrophe on return, the only two possible
2386                   --  tokens following the apostrophe are left paren and
2387                   --  RANGE, so we know we have a left paren here.
2388
2389                   else -- Token = Tok_Left_Paren
2390                      return P_Qualified_Expression (Node1);
2391
2392                   end if;
2393                end if;
2394
2395             --  Numeric or string literal
2396
2397             when Tok_Integer_Literal |
2398                  Tok_Real_Literal    |
2399                  Tok_String_Literal  =>
2400
2401                Node1 := Token_Node;
2402                Scan; -- past number
2403                return Node1;
2404
2405             --  Left paren, starts aggregate or parenthesized expression
2406
2407             when Tok_Left_Paren =>
2408                declare
2409                   Expr : constant Node_Id := P_Aggregate_Or_Paren_Expr;
2410
2411                begin
2412                   if Nkind (Expr) = N_Attribute_Reference
2413                     and then Attribute_Name (Expr) = Name_Range
2414                   then
2415                      Bad_Range_Attribute (Sloc (Expr));
2416                   end if;
2417
2418                   return Expr;
2419                end;
2420
2421             --  Allocator
2422
2423             when Tok_New =>
2424                return P_Allocator;
2425
2426             --  Null
2427
2428             when Tok_Null =>
2429                Scan; -- past NULL
2430                return New_Node (N_Null, Prev_Token_Ptr);
2431
2432             --  Pragma, not allowed here, so just skip past it
2433
2434             when Tok_Pragma =>
2435                P_Pragmas_Misplaced;
2436
2437             --  Deal with IF (possible unparenthesized conditional expression)
2438
2439             when Tok_If =>
2440
2441                --  If this looks like a real if, defined as an IF appearing at
2442                --  the start of a new line, then we consider we have a missing
2443                --  operand.
2444
2445                if Token_Is_At_Start_Of_Line then
2446                   Error_Msg_AP ("missing operand");
2447                   return Error;
2448
2449                --  If this looks like a conditional expression, then treat it
2450                --  that way with an error message.
2451
2452                elsif Ada_Version >= Ada_2012 then
2453                   Error_Msg_SC
2454                     ("conditional expression must be parenthesized");
2455                   return P_Conditional_Expression;
2456
2457                --  Otherwise treat as misused identifier
2458
2459                else
2460                   return P_Identifier;
2461                end if;
2462
2463             --  Deal with CASE (possible unparenthesized case expression)
2464
2465             when Tok_Case =>
2466
2467                --  If this looks like a real case, defined as a CASE appearing
2468                --  the start of a new line, then we consider we have a missing
2469                --  operand.
2470
2471                if Token_Is_At_Start_Of_Line then
2472                   Error_Msg_AP ("missing operand");
2473                   return Error;
2474
2475                --  If this looks like a case expression, then treat it that way
2476                --  with an error message.
2477
2478                elsif Ada_Version >= Ada_2012 then
2479                   Error_Msg_SC ("case expression must be parenthesized");
2480                   return P_Case_Expression;
2481
2482                --  Otherwise treat as misused identifier
2483
2484                else
2485                   return P_Identifier;
2486                end if;
2487
2488             --  For [all | some]  indicates a quantified expression
2489
2490             when Tok_For =>
2491
2492                if Token_Is_At_Start_Of_Line then
2493                   Error_Msg_AP ("misplaced loop");
2494                   return Error;
2495
2496                elsif Ada_Version >= Ada_2012 then
2497                   Error_Msg_SC ("quantified expression must be parenthesized");
2498                   return P_Quantified_Expression;
2499
2500                else
2501
2502                --  Otherwise treat as misused identifier
2503
2504                   return P_Identifier;
2505                end if;
2506
2507             --  Anything else is illegal as the first token of a primary, but
2508             --  we test for a reserved identifier so that it is treated nicely
2509
2510             when others =>
2511                if Is_Reserved_Identifier then
2512                   return P_Identifier;
2513
2514                elsif Prev_Token = Tok_Comma then
2515                   Error_Msg_SP -- CODEFIX
2516                     ("|extra "","" ignored");
2517                   raise Error_Resync;
2518
2519                else
2520                   Error_Msg_AP ("missing operand");
2521                   raise Error_Resync;
2522                end if;
2523
2524          end case;
2525       end loop;
2526    end P_Primary;
2527
2528    -------------------------------
2529    -- 4.4 Quantified_Expression --
2530    -------------------------------
2531
2532    --  QUANTIFIED_EXPRESSION ::=
2533    --    for QUANTIFIER LOOP_PARAMETER_SPECIFICATION => PREDICATE |
2534    --    for QUANTIFIER ITERATOR_SPECIFICATION => PREDICATE
2535
2536    function P_Quantified_Expression return Node_Id is
2537       I_Spec : Node_Id;
2538       Node1  : Node_Id;
2539
2540    begin
2541       Scan;  --  past FOR
2542
2543       Node1 := New_Node (N_Quantified_Expression, Prev_Token_Ptr);
2544
2545       if Token = Tok_All then
2546          Set_All_Present (Node1);
2547
2548       --  We treat Some as a non-reserved keyword, so it appears to the scanner
2549       --  as an identifier. If Some is made into a reserved word, the check
2550       --  below is against Tok_Some.
2551
2552       elsif Token /= Tok_Identifier
2553         or else Chars (Token_Node) /= Name_Some
2554       then
2555          Error_Msg_AP ("missing quantifier");
2556          raise Error_Resync;
2557       end if;
2558
2559       Scan; -- past SOME
2560       I_Spec := P_Loop_Parameter_Specification;
2561
2562       if Nkind (I_Spec) = N_Loop_Parameter_Specification then
2563          Set_Loop_Parameter_Specification (Node1, I_Spec);
2564       else
2565          Set_Iterator_Specification (Node1, I_Spec);
2566       end if;
2567
2568       if Token = Tok_Arrow then
2569          Scan;
2570          Set_Condition (Node1, P_Expression);
2571          return Node1;
2572       else
2573          Error_Msg_AP ("missing arrow");
2574          raise Error_Resync;
2575       end if;
2576    end P_Quantified_Expression;
2577
2578    ---------------------------
2579    -- 4.5  Logical Operator --
2580    ---------------------------
2581
2582    --  LOGICAL_OPERATOR  ::=  and | or | xor
2583
2584    --  Note: AND THEN and OR ELSE are also treated as logical operators
2585    --  by the parser (even though they are not operators semantically)
2586
2587    --  The value returned is the appropriate Node_Kind code for the operator
2588    --  On return, Token points to the token following the scanned operator.
2589
2590    --  The caller has checked that the first token is a legitimate logical
2591    --  operator token (i.e. is either XOR, AND, OR).
2592
2593    --  Error recovery: cannot raise Error_Resync
2594
2595    function P_Logical_Operator return Node_Kind is
2596    begin
2597       if Token = Tok_And then
2598          if Style_Check then
2599             Style.Check_Binary_Operator;
2600          end if;
2601
2602          Scan; -- past AND
2603
2604          if Token = Tok_Then then
2605             Scan; -- past THEN
2606             return N_And_Then;
2607          else
2608             return N_Op_And;
2609          end if;
2610
2611       elsif Token = Tok_Or then
2612          if Style_Check then
2613             Style.Check_Binary_Operator;
2614          end if;
2615
2616          Scan; -- past OR
2617
2618          if Token = Tok_Else then
2619             Scan; -- past ELSE
2620             return N_Or_Else;
2621          else
2622             return N_Op_Or;
2623          end if;
2624
2625       else -- Token = Tok_Xor
2626          if Style_Check then
2627             Style.Check_Binary_Operator;
2628          end if;
2629
2630          Scan; -- past XOR
2631          return N_Op_Xor;
2632       end if;
2633    end P_Logical_Operator;
2634
2635    ------------------------------
2636    -- 4.5  Relational Operator --
2637    ------------------------------
2638
2639    --  RELATIONAL_OPERATOR ::= = | /= | < | <= | > | >=
2640
2641    --  The value returned is the appropriate Node_Kind code for the operator.
2642    --  On return, Token points to the operator token, NOT past it.
2643
2644    --  The caller has checked that the first token is a legitimate relational
2645    --  operator token (i.e. is one of the operator tokens listed above).
2646
2647    --  Error recovery: cannot raise Error_Resync
2648
2649    function P_Relational_Operator return Node_Kind is
2650       Op_Kind : Node_Kind;
2651       Relop_Node : constant array (Token_Class_Relop) of Node_Kind :=
2652                      (Tok_Less          => N_Op_Lt,
2653                       Tok_Equal         => N_Op_Eq,
2654                       Tok_Greater       => N_Op_Gt,
2655                       Tok_Not_Equal     => N_Op_Ne,
2656                       Tok_Greater_Equal => N_Op_Ge,
2657                       Tok_Less_Equal    => N_Op_Le,
2658                       Tok_In            => N_In,
2659                       Tok_Not           => N_Not_In,
2660                       Tok_Box           => N_Op_Ne);
2661
2662    begin
2663       if Token = Tok_Box then
2664          Error_Msg_SC -- CODEFIX
2665            ("|""'<'>"" should be ""/=""");
2666       end if;
2667
2668       Op_Kind := Relop_Node (Token);
2669
2670       if Style_Check then
2671          Style.Check_Binary_Operator;
2672       end if;
2673
2674       Scan; -- past operator token
2675
2676       if Prev_Token = Tok_Not then
2677          T_In;
2678       end if;
2679
2680       return Op_Kind;
2681    end P_Relational_Operator;
2682
2683    ---------------------------------
2684    -- 4.5  Binary Adding Operator --
2685    ---------------------------------
2686
2687    --  BINARY_ADDING_OPERATOR ::= + | - | &
2688
2689    --  The value returned is the appropriate Node_Kind code for the operator.
2690    --  On return, Token points to the operator token (NOT past it).
2691
2692    --  The caller has checked that the first token is a legitimate adding
2693    --  operator token (i.e. is one of the operator tokens listed above).
2694
2695    --  Error recovery: cannot raise Error_Resync
2696
2697    function P_Binary_Adding_Operator return Node_Kind is
2698       Addop_Node : constant array (Token_Class_Binary_Addop) of Node_Kind :=
2699                      (Tok_Ampersand => N_Op_Concat,
2700                       Tok_Minus     => N_Op_Subtract,
2701                       Tok_Plus      => N_Op_Add);
2702    begin
2703       return Addop_Node (Token);
2704    end P_Binary_Adding_Operator;
2705
2706    --------------------------------
2707    -- 4.5  Unary Adding Operator --
2708    --------------------------------
2709
2710    --  UNARY_ADDING_OPERATOR ::= + | -
2711
2712    --  The value returned is the appropriate Node_Kind code for the operator.
2713    --  On return, Token points to the operator token (NOT past it).
2714
2715    --  The caller has checked that the first token is a legitimate adding
2716    --  operator token (i.e. is one of the operator tokens listed above).
2717
2718    --  Error recovery: cannot raise Error_Resync
2719
2720    function P_Unary_Adding_Operator return Node_Kind is
2721       Addop_Node : constant array (Token_Class_Unary_Addop) of Node_Kind :=
2722                      (Tok_Minus => N_Op_Minus,
2723                       Tok_Plus  => N_Op_Plus);
2724    begin
2725       return Addop_Node (Token);
2726    end P_Unary_Adding_Operator;
2727
2728    -------------------------------
2729    -- 4.5  Multiplying Operator --
2730    -------------------------------
2731
2732    --  MULTIPLYING_OPERATOR ::= * | / | mod | rem
2733
2734    --  The value returned is the appropriate Node_Kind code for the operator.
2735    --  On return, Token points to the operator token (NOT past it).
2736
2737    --  The caller has checked that the first token is a legitimate multiplying
2738    --  operator token (i.e. is one of the operator tokens listed above).
2739
2740    --  Error recovery: cannot raise Error_Resync
2741
2742    function P_Multiplying_Operator return Node_Kind is
2743       Mulop_Node : constant array (Token_Class_Mulop) of Node_Kind :=
2744         (Tok_Asterisk       => N_Op_Multiply,
2745          Tok_Mod            => N_Op_Mod,
2746          Tok_Rem            => N_Op_Rem,
2747          Tok_Slash          => N_Op_Divide);
2748    begin
2749       return Mulop_Node (Token);
2750    end P_Multiplying_Operator;
2751
2752    --------------------------------------
2753    -- 4.5  Highest Precedence Operator --
2754    --------------------------------------
2755
2756    --  Parsed by P_Factor (4.4)
2757
2758    --  Note: this rule is not in fact used by the grammar at any point!
2759
2760    --------------------------
2761    -- 4.6  Type Conversion --
2762    --------------------------
2763
2764    --  Parsed by P_Primary as a Name (4.1)
2765
2766    -------------------------------
2767    -- 4.7  Qualified Expression --
2768    -------------------------------
2769
2770    --  QUALIFIED_EXPRESSION ::=
2771    --    SUBTYPE_MARK ' (EXPRESSION) | SUBTYPE_MARK ' AGGREGATE
2772
2773    --  The caller has scanned the name which is the Subtype_Mark parameter
2774    --  and scanned past the single quote following the subtype mark. The
2775    --  caller has not checked that this name is in fact appropriate for
2776    --  a subtype mark name (i.e. it is a selected component or identifier).
2777
2778    --  Error_Recovery: cannot raise Error_Resync
2779
2780    function P_Qualified_Expression (Subtype_Mark : Node_Id) return Node_Id is
2781       Qual_Node : Node_Id;
2782    begin
2783       Qual_Node := New_Node (N_Qualified_Expression, Prev_Token_Ptr);
2784       Set_Subtype_Mark (Qual_Node, Check_Subtype_Mark (Subtype_Mark));
2785       Set_Expression (Qual_Node, P_Aggregate_Or_Paren_Expr);
2786       return Qual_Node;
2787    end P_Qualified_Expression;
2788
2789    --------------------
2790    -- 4.8  Allocator --
2791    --------------------
2792
2793    --  ALLOCATOR ::=
2794    --    new [NULL_EXCLUSION] SUBTYPE_INDICATION | new QUALIFIED_EXPRESSION
2795
2796    --  The caller has checked that the initial token is NEW
2797
2798    --  Error recovery: can raise Error_Resync
2799
2800    function P_Allocator return Node_Id is
2801       Alloc_Node             : Node_Id;
2802       Type_Node              : Node_Id;
2803       Null_Exclusion_Present : Boolean;
2804
2805    begin
2806       Alloc_Node := New_Node (N_Allocator, Token_Ptr);
2807       T_New;
2808
2809       --  Scan Null_Exclusion if present (Ada 2005 (AI-231))
2810
2811       Null_Exclusion_Present := P_Null_Exclusion;
2812       Set_Null_Exclusion_Present (Alloc_Node, Null_Exclusion_Present);
2813       Type_Node := P_Subtype_Mark_Resync;
2814
2815       if Token = Tok_Apostrophe then
2816          Scan; -- past apostrophe
2817          Set_Expression (Alloc_Node, P_Qualified_Expression (Type_Node));
2818       else
2819          Set_Expression
2820            (Alloc_Node,
2821             P_Subtype_Indication (Type_Node, Null_Exclusion_Present));
2822       end if;
2823
2824       return Alloc_Node;
2825    end P_Allocator;
2826
2827    -----------------------
2828    -- P_Case_Expression --
2829    -----------------------
2830
2831    function P_Case_Expression return Node_Id is
2832       Loc        : constant Source_Ptr := Token_Ptr;
2833       Case_Node  : Node_Id;
2834       Save_State : Saved_Scan_State;
2835
2836    begin
2837       if Ada_Version < Ada_2012 then
2838          Error_Msg_SC ("|case expression is an Ada 2012 feature");
2839          Error_Msg_SC ("\|unit must be compiled with -gnat2012 switch");
2840       end if;
2841
2842       Scan; -- past CASE
2843       Case_Node :=
2844         Make_Case_Expression (Loc,
2845           Expression   => P_Expression_No_Right_Paren,
2846           Alternatives => New_List);
2847       T_Is;
2848
2849       --  We now have scanned out CASE expression IS, scan alternatives
2850
2851       loop
2852          T_When;
2853          Append_To (Alternatives (Case_Node), P_Case_Expression_Alternative);
2854
2855          --  Missing comma if WHEN (more alternatives present)
2856
2857          if Token = Tok_When then
2858             T_Comma;
2859
2860          --  If comma/WHEN, skip comma and we have another alternative
2861
2862          elsif Token = Tok_Comma then
2863             Save_Scan_State (Save_State);
2864             Scan; -- past comma
2865
2866             if Token /= Tok_When then
2867                Restore_Scan_State (Save_State);
2868                exit;
2869             end if;
2870
2871          --  If no comma or WHEN, definitely done
2872
2873          else
2874             exit;
2875          end if;
2876       end loop;
2877
2878       --  If we have an END CASE, diagnose as not needed
2879
2880       if Token = Tok_End then
2881          Error_Msg_SC ("`END CASE` not allowed at end of case expression");
2882          Scan; -- past END
2883
2884          if Token = Tok_Case then
2885             Scan; -- past CASE;
2886          end if;
2887       end if;
2888
2889       --  Return the Case_Expression node
2890
2891       return Case_Node;
2892    end P_Case_Expression;
2893
2894    -----------------------------------
2895    -- P_Case_Expression_Alternative --
2896    -----------------------------------
2897
2898    --  CASE_STATEMENT_ALTERNATIVE ::=
2899    --    when DISCRETE_CHOICE_LIST =>
2900    --      EXPRESSION
2901
2902    --  The caller has checked that and scanned past the initial WHEN token
2903    --  Error recovery: can raise Error_Resync
2904
2905    function P_Case_Expression_Alternative return Node_Id is
2906       Case_Alt_Node : Node_Id;
2907    begin
2908       Case_Alt_Node := New_Node (N_Case_Expression_Alternative, Token_Ptr);
2909       Set_Discrete_Choices (Case_Alt_Node, P_Discrete_Choice_List);
2910       TF_Arrow;
2911       Set_Expression (Case_Alt_Node, P_Expression);
2912       return Case_Alt_Node;
2913    end P_Case_Expression_Alternative;
2914
2915    ------------------------------
2916    -- P_Conditional_Expression --
2917    ------------------------------
2918
2919    function P_Conditional_Expression return Node_Id is
2920       Exprs : constant List_Id    := New_List;
2921       Loc   : constant Source_Ptr := Token_Ptr;
2922       Expr  : Node_Id;
2923       State : Saved_Scan_State;
2924
2925    begin
2926       Inside_Conditional_Expression := Inside_Conditional_Expression + 1;
2927
2928       if Token = Tok_If and then Ada_Version < Ada_2012 then
2929          Error_Msg_SC ("|conditional expression is an Ada 2012 feature");
2930          Error_Msg_SC ("\|unit must be compiled with -gnat2012 switch");
2931       end if;
2932
2933       Scan; -- past IF or ELSIF
2934       Append_To (Exprs, P_Condition);
2935       TF_Then;
2936       Append_To (Exprs, P_Expression);
2937
2938       --  We now have scanned out IF expr THEN expr
2939
2940       --  Check for common error of semicolon before the ELSE
2941
2942       if Token = Tok_Semicolon then
2943          Save_Scan_State (State);
2944          Scan; -- past semicolon
2945
2946          if Token = Tok_Else or else Token = Tok_Elsif then
2947             Error_Msg_SP -- CODEFIX
2948               ("|extra "";"" ignored");
2949
2950          else
2951             Restore_Scan_State (State);
2952          end if;
2953       end if;
2954
2955       --  Scan out ELSIF sequence if present
2956
2957       if Token = Tok_Elsif then
2958          Expr := P_Conditional_Expression;
2959          Set_Is_Elsif (Expr);
2960          Append_To (Exprs, Expr);
2961
2962       --  Scan out ELSE phrase if present
2963
2964       elsif Token = Tok_Else then
2965
2966          --  Scan out ELSE expression
2967
2968          Scan; -- Past ELSE
2969          Append_To (Exprs, P_Expression);
2970
2971       --  Two expression case (implied True, filled in during semantics)
2972
2973       else
2974          null;
2975       end if;
2976
2977       --  If we have an END IF, diagnose as not needed
2978
2979       if Token = Tok_End then
2980          Error_Msg_SC
2981            ("`END IF` not allowed at end of conditional expression");
2982          Scan; -- past END
2983
2984          if Token = Tok_If then
2985             Scan; -- past IF;
2986          end if;
2987       end if;
2988
2989       Inside_Conditional_Expression := Inside_Conditional_Expression - 1;
2990
2991       --  Return the Conditional_Expression node
2992
2993       return
2994         Make_Conditional_Expression (Loc,
2995           Expressions => Exprs);
2996    end P_Conditional_Expression;
2997
2998    -----------------------
2999    -- P_Membership_Test --
3000    -----------------------
3001
3002    --  MEMBERSHIP_CHOICE_LIST ::= MEMBERHIP_CHOICE {'|' MEMBERSHIP_CHOICE}
3003    --  MEMBERSHIP_CHOICE      ::= CHOICE_EXPRESSION | range | subtype_mark
3004
3005    procedure P_Membership_Test (N : Node_Id) is
3006       Alt : constant Node_Id :=
3007               P_Range_Or_Subtype_Mark
3008                 (Allow_Simple_Expression => (Ada_Version >= Ada_2012));
3009
3010    begin
3011       --  Set case
3012
3013       if Token = Tok_Vertical_Bar then
3014          if Ada_Version < Ada_2012 then
3015             Error_Msg_SC ("set notation is an Ada 2012 feature");
3016             Error_Msg_SC ("\|unit must be compiled with -gnat2012 switch");
3017          end if;
3018
3019          Set_Alternatives (N, New_List (Alt));
3020          Set_Right_Opnd   (N, Empty);
3021
3022          --  Loop to accumulate alternatives
3023
3024          while Token = Tok_Vertical_Bar loop
3025             Scan; -- past vertical bar
3026             Append_To
3027               (Alternatives (N),
3028                P_Range_Or_Subtype_Mark (Allow_Simple_Expression => True));
3029          end loop;
3030
3031       --  Not set case
3032
3033       else
3034          Set_Right_Opnd   (N, Alt);
3035          Set_Alternatives (N, No_List);
3036       end if;
3037    end P_Membership_Test;
3038
3039 end Ch4;