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