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