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