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