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