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