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