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