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