1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- P A R . C H 5 -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26pragma Style_Checks (All_Checks); 27-- Turn off subprogram body ordering check. Subprograms are in order by RM 28-- section rather than alphabetical. 29 30with Sinfo.CN; use Sinfo.CN; 31 32separate (Par) 33package body Ch5 is 34 35 -- Local functions, used only in this chapter 36 37 function P_Case_Statement return Node_Id; 38 function P_Case_Statement_Alternative return Node_Id; 39 function P_Exit_Statement return Node_Id; 40 function P_Goto_Statement return Node_Id; 41 function P_If_Statement return Node_Id; 42 function P_Label return Node_Id; 43 function P_Null_Statement return Node_Id; 44 45 function P_Assignment_Statement (LHS : Node_Id) return Node_Id; 46 -- Parse assignment statement. On entry, the caller has scanned the left 47 -- hand side (passed in as Lhs), and the colon-equal (or some symbol 48 -- taken to be an error equivalent such as equal). 49 50 function P_Begin_Statement (Block_Name : Node_Id := Empty) return Node_Id; 51 -- Parse begin-end statement. If Block_Name is non-Empty on entry, it is 52 -- the N_Identifier node for the label on the block. If Block_Name is 53 -- Empty on entry (the default), then the block statement is unlabeled. 54 55 function P_Declare_Statement (Block_Name : Node_Id := Empty) return Node_Id; 56 -- Parse declare block. If Block_Name is non-Empty on entry, it is 57 -- the N_Identifier node for the label on the block. If Block_Name is 58 -- Empty on entry (the default), then the block statement is unlabeled. 59 60 function P_For_Statement (Loop_Name : Node_Id := Empty) return Node_Id; 61 -- Parse for statement. If Loop_Name is non-Empty on entry, it is 62 -- the N_Identifier node for the label on the loop. If Loop_Name is 63 -- Empty on entry (the default), then the for statement is unlabeled. 64 65 function P_Iterator_Specification (Def_Id : Node_Id) return Node_Id; 66 -- Parse an iterator specification. The defining identifier has already 67 -- been scanned, as it is the common prefix between loop and iterator 68 -- specification. 69 70 function P_Loop_Statement (Loop_Name : Node_Id := Empty) return Node_Id; 71 -- Parse loop statement. If Loop_Name is non-Empty on entry, it is 72 -- the N_Identifier node for the label on the loop. If Loop_Name is 73 -- Empty on entry (the default), then the loop statement is unlabeled. 74 75 function P_While_Statement (Loop_Name : Node_Id := Empty) return Node_Id; 76 -- Parse while statement. If Loop_Name is non-Empty on entry, it is 77 -- the N_Identifier node for the label on the loop. If Loop_Name is 78 -- Empty on entry (the default), then the while statement is unlabeled. 79 80 function Set_Loop_Block_Name (L : Character) return Name_Id; 81 -- Given a letter 'L' for a loop or 'B' for a block, returns a name 82 -- of the form L_nn or B_nn where nn is a serial number obtained by 83 -- incrementing the variable Loop_Block_Count. 84 85 procedure Then_Scan; 86 -- Scan past THEN token, testing for illegal junk after it 87 88 --------------------------------- 89 -- 5.1 Sequence of Statements -- 90 --------------------------------- 91 92 -- SEQUENCE_OF_STATEMENTS ::= STATEMENT {STATEMENT} {LABEL} 93 -- Note: the final label is an Ada 2012 addition. 94 95 -- STATEMENT ::= 96 -- {LABEL} SIMPLE_STATEMENT | {LABEL} COMPOUND_STATEMENT 97 98 -- SIMPLE_STATEMENT ::= NULL_STATEMENT 99 -- | ASSIGNMENT_STATEMENT | EXIT_STATEMENT 100 -- | GOTO_STATEMENT | PROCEDURE_CALL_STATEMENT 101 -- | RETURN_STATEMENT | ENTRY_CALL_STATEMENT 102 -- | REQUEUE_STATEMENT | DELAY_STATEMENT 103 -- | ABORT_STATEMENT | RAISE_STATEMENT 104 -- | CODE_STATEMENT 105 106 -- COMPOUND_STATEMENT ::= 107 -- IF_STATEMENT | CASE_STATEMENT 108 -- | LOOP_STATEMENT | BLOCK_STATEMENT 109 -- | ACCEPT_STATEMENT | SELECT_STATEMENT 110 111 -- This procedure scans a sequence of statements. The caller sets SS_Flags 112 -- to indicate acceptable termination conditions for the sequence: 113 114 -- SS_Flags.Eftm Terminate on ELSIF 115 -- SS_Flags.Eltm Terminate on ELSE 116 -- SS_Flags.Extm Terminate on EXCEPTION 117 -- SS_Flags.Ortm Terminate on OR 118 -- SS_Flags.Tatm Terminate on THEN ABORT (Token = ABORT on return) 119 -- SS_Flags.Whtm Terminate on WHEN 120 -- SS_Flags.Unco Unconditional terminate after scanning one statement 121 122 -- In addition, the scan is always terminated by encountering END or the 123 -- end of file (EOF) condition. If one of the six above terminators is 124 -- encountered with the corresponding SS_Flags flag not set, then the 125 -- action taken is as follows: 126 127 -- If the keyword occurs to the left of the expected column of the end 128 -- for the current sequence (as recorded in the current end context), 129 -- then it is assumed to belong to an outer context, and is considered 130 -- to terminate the sequence of statements. 131 132 -- If the keyword occurs to the right of, or in the expected column of 133 -- the end for the current sequence, then an error message is output, 134 -- the keyword together with its associated context is skipped, and 135 -- the statement scan continues until another terminator is found. 136 137 -- Note that the first action means that control can return to the caller 138 -- with Token set to a terminator other than one of those specified by the 139 -- SS parameter. The caller should treat such a case as equivalent to END. 140 141 -- In addition, the flag SS_Flags.Sreq is set to True to indicate that at 142 -- least one real statement (other than a pragma) is required in the 143 -- statement sequence. During the processing of the sequence, this 144 -- flag is manipulated to indicate the current status of the requirement 145 -- for a statement. For example, it is turned off by the occurrence of a 146 -- statement, and back on by a label (which requires a following statement) 147 148 -- Error recovery: cannot raise Error_Resync. If an error occurs during 149 -- parsing a statement, then the scan pointer is advanced past the next 150 -- semicolon and the parse continues. 151 152 function P_Sequence_Of_Statements (SS_Flags : SS_Rec) return List_Id is 153 154 Statement_Required : Boolean; 155 -- This flag indicates if a subsequent statement (other than a pragma) 156 -- is required. It is initialized from the Sreq flag, and modified as 157 -- statements are scanned (a statement turns it off, and a label turns 158 -- it back on again since a statement must follow a label). 159 -- Note : this final requirement is lifted in Ada 2012. 160 161 Statement_Seen : Boolean; 162 -- In Ada 2012, a label can end a sequence of statements, but the 163 -- sequence cannot contain only labels. This flag is set whenever a 164 -- label is encountered, to enforce this rule at the end of a sequence. 165 166 Declaration_Found : Boolean := False; 167 -- This flag is set True if a declaration is encountered, so that the 168 -- error message about declarations in the statement part is only 169 -- given once for a given sequence of statements. 170 171 Scan_State_Label : Saved_Scan_State; 172 Scan_State : Saved_Scan_State; 173 174 Statement_List : List_Id; 175 Block_Label : Name_Id; 176 Id_Node : Node_Id; 177 Name_Node : Node_Id; 178 179 procedure Junk_Declaration; 180 -- Procedure called to handle error of declaration encountered in 181 -- statement sequence. 182 183 procedure Test_Statement_Required; 184 -- Flag error if Statement_Required flag set 185 186 ---------------------- 187 -- Junk_Declaration -- 188 ---------------------- 189 190 procedure Junk_Declaration is 191 begin 192 if (not Declaration_Found) or All_Errors_Mode then 193 Error_Msg_SC -- CODEFIX 194 ("declarations must come before BEGIN"); 195 Declaration_Found := True; 196 end if; 197 198 Skip_Declaration (Statement_List); 199 end Junk_Declaration; 200 201 ----------------------------- 202 -- Test_Statement_Required -- 203 ----------------------------- 204 205 procedure Test_Statement_Required is 206 function All_Pragmas return Boolean; 207 -- Return True if statement list is all pragmas 208 209 ----------------- 210 -- All_Pragmas -- 211 ----------------- 212 213 function All_Pragmas return Boolean is 214 S : Node_Id; 215 begin 216 S := First (Statement_List); 217 while Present (S) loop 218 if Nkind (S) /= N_Pragma then 219 return False; 220 else 221 Next (S); 222 end if; 223 end loop; 224 225 return True; 226 end All_Pragmas; 227 228 -- Start of processing for Test_Statement_Required 229 230 begin 231 if Statement_Required then 232 233 -- Check no statement required after label in Ada 2012, and that 234 -- it is OK to have nothing but pragmas in a statement sequence. 235 236 if Ada_Version >= Ada_2012 237 and then not Is_Empty_List (Statement_List) 238 and then 239 ((Nkind (Last (Statement_List)) = N_Label 240 and then Statement_Seen) 241 or else All_Pragmas) 242 then 243 declare 244 Null_Stm : constant Node_Id := 245 Make_Null_Statement (Token_Ptr); 246 begin 247 Set_Comes_From_Source (Null_Stm, False); 248 Append_To (Statement_List, Null_Stm); 249 end; 250 251 -- If not Ada 2012, or not special case above, give error message 252 253 else 254 Error_Msg_BC -- CODEFIX 255 ("statement expected"); 256 end if; 257 end if; 258 end Test_Statement_Required; 259 260 -- Start of processing for P_Sequence_Of_Statements 261 262 begin 263 Statement_List := New_List; 264 Statement_Required := SS_Flags.Sreq; 265 Statement_Seen := False; 266 267 loop 268 Ignore (Tok_Semicolon); 269 270 begin 271 if Style_Check then 272 Style.Check_Indentation; 273 end if; 274 275 -- Deal with reserved identifier (in assignment or call) 276 277 if Is_Reserved_Identifier then 278 Save_Scan_State (Scan_State); -- at possible bad identifier 279 Scan; -- and scan past it 280 281 -- We have an reserved word which is spelled in identifier 282 -- style, so the question is whether it really is intended 283 -- to be an identifier. 284 285 if 286 -- If followed by a semicolon, then it is an identifier, 287 -- with the exception of the cases tested for below. 288 289 (Token = Tok_Semicolon 290 and then Prev_Token /= Tok_Return 291 and then Prev_Token /= Tok_Null 292 and then Prev_Token /= Tok_Raise 293 and then Prev_Token /= Tok_End 294 and then Prev_Token /= Tok_Exit) 295 296 -- If followed by colon, colon-equal, or dot, then we 297 -- definitely have an identifier (could not be reserved) 298 299 or else Token = Tok_Colon 300 or else Token = Tok_Colon_Equal 301 or else Token = Tok_Dot 302 303 -- Left paren means we have an identifier except for those 304 -- reserved words that can legitimately be followed by a 305 -- left paren. 306 307 or else 308 (Token = Tok_Left_Paren 309 and then Prev_Token /= Tok_Case 310 and then Prev_Token /= Tok_Delay 311 and then Prev_Token /= Tok_If 312 and then Prev_Token /= Tok_Elsif 313 and then Prev_Token /= Tok_Return 314 and then Prev_Token /= Tok_When 315 and then Prev_Token /= Tok_While 316 and then Prev_Token /= Tok_Separate) 317 then 318 -- Here we have an apparent reserved identifier and the 319 -- token past it is appropriate to this usage (and would 320 -- be a definite error if this is not an identifier). What 321 -- we do is to use P_Identifier to fix up the identifier, 322 -- and then fall into the normal processing. 323 324 Restore_Scan_State (Scan_State); -- back to the ID 325 Scan_Reserved_Identifier (Force_Msg => False); 326 327 -- Not a reserved identifier after all (or at least we can't 328 -- be sure that it is), so reset the scan and continue. 329 330 else 331 Restore_Scan_State (Scan_State); -- back to the reserved word 332 end if; 333 end if; 334 335 -- Now look to see what kind of statement we have 336 337 case Token is 338 339 -- Case of end or EOF 340 341 when Tok_End | Tok_EOF => 342 343 -- These tokens always terminate the statement sequence 344 345 Test_Statement_Required; 346 exit; 347 348 -- Case of ELSIF 349 350 when Tok_Elsif => 351 352 -- Terminate if Eftm set or if the ELSIF is to the left 353 -- of the expected column of the end for this sequence 354 355 if SS_Flags.Eftm 356 or else Start_Column < Scope.Table (Scope.Last).Ecol 357 then 358 Test_Statement_Required; 359 exit; 360 361 -- Otherwise complain and skip past ELSIF Condition then 362 363 else 364 Error_Msg_SC ("ELSIF not allowed here"); 365 Scan; -- past ELSIF 366 Discard_Junk_Node (P_Expression_No_Right_Paren); 367 Then_Scan; 368 Statement_Required := False; 369 end if; 370 371 -- Case of ELSE 372 373 when Tok_Else => 374 375 -- Terminate if Eltm set or if the else is to the left 376 -- of the expected column of the end for this sequence 377 378 if SS_Flags.Eltm 379 or else Start_Column < Scope.Table (Scope.Last).Ecol 380 then 381 Test_Statement_Required; 382 exit; 383 384 -- Otherwise complain and skip past else 385 386 else 387 Error_Msg_SC ("ELSE not allowed here"); 388 Scan; -- past ELSE 389 Statement_Required := False; 390 end if; 391 392 -- Case of exception 393 394 when Tok_Exception => 395 Test_Statement_Required; 396 397 -- If Extm not set and the exception is not to the left of 398 -- the expected column of the end for this sequence, then we 399 -- assume it belongs to the current sequence, even though it 400 -- is not permitted. 401 402 if not SS_Flags.Extm and then 403 Start_Column >= Scope.Table (Scope.Last).Ecol 404 405 then 406 Error_Msg_SC ("exception handler not permitted here"); 407 Scan; -- past EXCEPTION 408 Discard_Junk_List (Parse_Exception_Handlers); 409 end if; 410 411 -- Always return, in the case where we scanned out handlers 412 -- that we did not expect, Parse_Exception_Handlers returned 413 -- with Token being either end or EOF, so we are OK. 414 415 exit; 416 417 -- Case of OR 418 419 when Tok_Or => 420 421 -- Terminate if Ortm set or if the or is to the left of the 422 -- expected column of the end for this sequence. 423 424 if SS_Flags.Ortm 425 or else Start_Column < Scope.Table (Scope.Last).Ecol 426 then 427 Test_Statement_Required; 428 exit; 429 430 -- Otherwise complain and skip past or 431 432 else 433 Error_Msg_SC ("OR not allowed here"); 434 Scan; -- past or 435 Statement_Required := False; 436 end if; 437 438 -- Case of THEN (deal also with THEN ABORT) 439 440 when Tok_Then => 441 Save_Scan_State (Scan_State); -- at THEN 442 Scan; -- past THEN 443 444 -- Terminate if THEN ABORT allowed (ATC case) 445 446 exit when SS_Flags.Tatm and then Token = Tok_Abort; 447 448 -- Otherwise we treat THEN as some kind of mess where we did 449 -- not see the associated IF, but we pick up assuming it had 450 -- been there. 451 452 Restore_Scan_State (Scan_State); -- to THEN 453 Append_To (Statement_List, P_If_Statement); 454 Statement_Required := False; 455 456 -- Case of WHEN (error because we are not in a case) 457 458 when Tok_When | Tok_Others => 459 460 -- Terminate if Whtm set or if the WHEN is to the left of 461 -- the expected column of the end for this sequence. 462 463 if SS_Flags.Whtm 464 or else Start_Column < Scope.Table (Scope.Last).Ecol 465 then 466 Test_Statement_Required; 467 exit; 468 469 -- Otherwise complain and skip when Choice {| Choice} => 470 471 else 472 Error_Msg_SC ("WHEN not allowed here"); 473 Scan; -- past when 474 Discard_Junk_List (P_Discrete_Choice_List); 475 TF_Arrow; 476 Statement_Required := False; 477 end if; 478 479 -- Cases of statements starting with an identifier 480 481 when Tok_Identifier => 482 Check_Bad_Layout; 483 484 -- Save scan pointers and line number in case block label 485 486 Id_Node := Token_Node; 487 Block_Label := Token_Name; 488 Save_Scan_State (Scan_State_Label); -- at possible label 489 Scan; -- past Id 490 491 -- Check for common case of assignment, since it occurs 492 -- frequently, and we want to process it efficiently. 493 494 if Token = Tok_Colon_Equal then 495 Scan; -- past the colon-equal 496 Append_To (Statement_List, 497 P_Assignment_Statement (Id_Node)); 498 Statement_Required := False; 499 500 -- Check common case of procedure call, another case that 501 -- we want to speed up as much as possible. 502 503 elsif Token = Tok_Semicolon then 504 Change_Name_To_Procedure_Call_Statement (Id_Node); 505 Append_To (Statement_List, Id_Node); 506 Scan; -- past semicolon 507 Statement_Required := False; 508 509 -- Here is the special test for a suspicious label, more 510 -- accurately a suspicious name, which we think perhaps 511 -- should have been a label. If next token is one of 512 -- LOOP, FOR, WHILE, DECLARE, BEGIN, then make an entry 513 -- in the suspicious label table. 514 515 if Token = Tok_Loop or else 516 Token = Tok_For or else 517 Token = Tok_While or else 518 Token = Tok_Declare or else 519 Token = Tok_Begin 520 then 521 Suspicious_Labels.Append 522 ((Proc_Call => Id_Node, 523 Semicolon_Loc => Prev_Token_Ptr, 524 Start_Token => Token_Ptr)); 525 end if; 526 527 -- Check for case of "go to" in place of "goto" 528 529 elsif Token = Tok_Identifier 530 and then Block_Label = Name_Go 531 and then Token_Name = Name_To 532 then 533 Error_Msg_SP -- CODEFIX 534 ("goto is one word"); 535 Append_To (Statement_List, P_Goto_Statement); 536 Statement_Required := False; 537 538 -- Check common case of = used instead of :=, just so we 539 -- give a better error message for this special misuse. 540 541 elsif Token = Tok_Equal then 542 T_Colon_Equal; -- give := expected message 543 Append_To (Statement_List, 544 P_Assignment_Statement (Id_Node)); 545 Statement_Required := False; 546 547 -- Check case of loop label or block label 548 549 elsif Token = Tok_Colon 550 or else (Token in Token_Class_Labeled_Stmt 551 and then not Token_Is_At_Start_Of_Line) 552 then 553 T_Colon; -- past colon (if there, or msg for missing one) 554 555 -- Test for more than one label 556 557 loop 558 exit when Token /= Tok_Identifier; 559 Save_Scan_State (Scan_State); -- at second Id 560 Scan; -- past Id 561 562 if Token = Tok_Colon then 563 Error_Msg_SP 564 ("only one label allowed on block or loop"); 565 Scan; -- past colon on extra label 566 567 -- Use the second label as the "real" label 568 569 Scan_State_Label := Scan_State; 570 571 -- We will set Error_name as the Block_Label since 572 -- we really don't know which of the labels might 573 -- be used at the end of the loop or block. 574 575 Block_Label := Error_Name; 576 577 -- If Id with no colon, then backup to point to the 578 -- Id and we will issue the message below when we try 579 -- to scan out the statement as some other form. 580 581 else 582 Restore_Scan_State (Scan_State); -- to second Id 583 exit; 584 end if; 585 end loop; 586 587 -- Loop_Statement (labeled Loop_Statement) 588 589 if Token = Tok_Loop then 590 Append_To (Statement_List, 591 P_Loop_Statement (Id_Node)); 592 593 -- While statement (labeled loop statement with WHILE) 594 595 elsif Token = Tok_While then 596 Append_To (Statement_List, 597 P_While_Statement (Id_Node)); 598 599 -- Declare statement (labeled block statement with 600 -- DECLARE part) 601 602 elsif Token = Tok_Declare then 603 Append_To (Statement_List, 604 P_Declare_Statement (Id_Node)); 605 606 -- Begin statement (labeled block statement with no 607 -- DECLARE part) 608 609 elsif Token = Tok_Begin then 610 Append_To (Statement_List, 611 P_Begin_Statement (Id_Node)); 612 613 -- For statement (labeled loop statement with FOR) 614 615 elsif Token = Tok_For then 616 Append_To (Statement_List, 617 P_For_Statement (Id_Node)); 618 619 -- Improper statement follows label. If we have an 620 -- expression token, then assume the colon was part 621 -- of a misplaced declaration. 622 623 elsif Token not in Token_Class_Eterm then 624 Restore_Scan_State (Scan_State_Label); 625 Junk_Declaration; 626 627 -- Otherwise complain we have inappropriate statement 628 629 else 630 Error_Msg_AP 631 ("loop or block statement must follow label"); 632 end if; 633 634 Statement_Required := False; 635 636 -- Here we have an identifier followed by something 637 -- other than a colon, semicolon or assignment symbol. 638 -- The only valid possibility is a name extension symbol 639 640 elsif Token in Token_Class_Namext then 641 Restore_Scan_State (Scan_State_Label); -- to Id 642 Name_Node := P_Name; 643 644 -- Skip junk right parens in this context 645 646 Ignore (Tok_Right_Paren); 647 648 -- Check context following call 649 650 if Token = Tok_Colon_Equal then 651 Scan; -- past colon equal 652 Append_To (Statement_List, 653 P_Assignment_Statement (Name_Node)); 654 Statement_Required := False; 655 656 -- Check common case of = used instead of := 657 658 elsif Token = Tok_Equal then 659 T_Colon_Equal; -- give := expected message 660 Append_To (Statement_List, 661 P_Assignment_Statement (Name_Node)); 662 Statement_Required := False; 663 664 -- Check apostrophe cases 665 666 elsif Token = Tok_Apostrophe then 667 Append_To (Statement_List, 668 P_Code_Statement (Name_Node)); 669 Statement_Required := False; 670 671 -- The only other valid item after a name is ; which 672 -- means that the item we just scanned was a call. 673 674 elsif Token = Tok_Semicolon then 675 Change_Name_To_Procedure_Call_Statement (Name_Node); 676 Append_To (Statement_List, Name_Node); 677 Scan; -- past semicolon 678 Statement_Required := False; 679 680 -- A slash following an identifier or a selected 681 -- component in this situation is most likely a period 682 -- (see location of keys on keyboard). 683 684 elsif Token = Tok_Slash 685 and then (Nkind (Name_Node) = N_Identifier 686 or else 687 Nkind (Name_Node) = N_Selected_Component) 688 then 689 Error_Msg_SC -- CODEFIX 690 ("""/"" should be ""."""); 691 Statement_Required := False; 692 raise Error_Resync; 693 694 -- Else we have a missing semicolon 695 696 else 697 TF_Semicolon; 698 Statement_Required := False; 699 end if; 700 701 -- If junk after identifier, check if identifier is an 702 -- instance of an incorrectly spelled keyword. If so, we 703 -- do nothing. The Bad_Spelling_Of will have reset Token 704 -- to the appropriate keyword, so the next time round the 705 -- loop we will process the modified token. Note that we 706 -- check for ELSIF before ELSE here. That's not accidental. 707 -- We don't want to identify a misspelling of ELSE as 708 -- ELSIF, and in particular we do not want to treat ELSEIF 709 -- as ELSE IF. 710 711 else 712 Restore_Scan_State (Scan_State_Label); -- to identifier 713 714 if Bad_Spelling_Of (Tok_Abort) 715 or else Bad_Spelling_Of (Tok_Accept) 716 or else Bad_Spelling_Of (Tok_Case) 717 or else Bad_Spelling_Of (Tok_Declare) 718 or else Bad_Spelling_Of (Tok_Delay) 719 or else Bad_Spelling_Of (Tok_Elsif) 720 or else Bad_Spelling_Of (Tok_Else) 721 or else Bad_Spelling_Of (Tok_End) 722 or else Bad_Spelling_Of (Tok_Exception) 723 or else Bad_Spelling_Of (Tok_Exit) 724 or else Bad_Spelling_Of (Tok_For) 725 or else Bad_Spelling_Of (Tok_Goto) 726 or else Bad_Spelling_Of (Tok_If) 727 or else Bad_Spelling_Of (Tok_Loop) 728 or else Bad_Spelling_Of (Tok_Or) 729 or else Bad_Spelling_Of (Tok_Pragma) 730 or else Bad_Spelling_Of (Tok_Raise) 731 or else Bad_Spelling_Of (Tok_Requeue) 732 or else Bad_Spelling_Of (Tok_Return) 733 or else Bad_Spelling_Of (Tok_Select) 734 or else Bad_Spelling_Of (Tok_When) 735 or else Bad_Spelling_Of (Tok_While) 736 then 737 null; 738 739 -- If not a bad spelling, then we really have junk 740 741 else 742 Scan; -- past identifier again 743 744 -- If next token is first token on line, then we 745 -- consider that we were missing a semicolon after 746 -- the identifier, and process it as a procedure 747 -- call with no parameters. 748 749 if Token_Is_At_Start_Of_Line then 750 Change_Name_To_Procedure_Call_Statement (Id_Node); 751 Append_To (Statement_List, Id_Node); 752 T_Semicolon; -- to give error message 753 Statement_Required := False; 754 755 -- Otherwise we give a missing := message and 756 -- simply abandon the junk that is there now. 757 758 else 759 T_Colon_Equal; -- give := expected message 760 raise Error_Resync; 761 end if; 762 763 end if; 764 end if; 765 766 -- Statement starting with operator symbol. This could be 767 -- a call, a name starting an assignment, or a qualified 768 -- expression. 769 770 when Tok_Operator_Symbol => 771 Check_Bad_Layout; 772 Name_Node := P_Name; 773 774 -- An attempt at a range attribute or a qualified expression 775 -- must be illegal here (a code statement cannot possibly 776 -- allow qualification by a function name). 777 778 if Token = Tok_Apostrophe then 779 Error_Msg_SC ("apostrophe illegal here"); 780 raise Error_Resync; 781 end if; 782 783 -- Scan possible assignment if we have a name 784 785 if Expr_Form = EF_Name 786 and then Token = Tok_Colon_Equal 787 then 788 Scan; -- past colon equal 789 Append_To (Statement_List, 790 P_Assignment_Statement (Name_Node)); 791 else 792 Change_Name_To_Procedure_Call_Statement (Name_Node); 793 Append_To (Statement_List, Name_Node); 794 end if; 795 796 TF_Semicolon; 797 Statement_Required := False; 798 799 -- Label starting with << which must precede real statement 800 -- Note: in Ada 2012, the label may end the sequence. 801 802 when Tok_Less_Less => 803 if Present (Last (Statement_List)) 804 and then Nkind (Last (Statement_List)) /= N_Label 805 then 806 Statement_Seen := True; 807 end if; 808 809 Append_To (Statement_List, P_Label); 810 Statement_Required := True; 811 812 -- Pragma appearing as a statement in a statement sequence 813 814 when Tok_Pragma => 815 Check_Bad_Layout; 816 Append_To (Statement_List, P_Pragma); 817 818 -- Abort_Statement 819 820 when Tok_Abort => 821 Check_Bad_Layout; 822 Append_To (Statement_List, P_Abort_Statement); 823 Statement_Required := False; 824 825 -- Accept_Statement 826 827 when Tok_Accept => 828 Check_Bad_Layout; 829 Append_To (Statement_List, P_Accept_Statement); 830 Statement_Required := False; 831 832 -- Begin_Statement (Block_Statement with no declare, no label) 833 834 when Tok_Begin => 835 Check_Bad_Layout; 836 Append_To (Statement_List, P_Begin_Statement); 837 Statement_Required := False; 838 839 -- Case_Statement 840 841 when Tok_Case => 842 Check_Bad_Layout; 843 Append_To (Statement_List, P_Case_Statement); 844 Statement_Required := False; 845 846 -- Block_Statement with DECLARE and no label 847 848 when Tok_Declare => 849 Check_Bad_Layout; 850 Append_To (Statement_List, P_Declare_Statement); 851 Statement_Required := False; 852 853 -- Delay_Statement 854 855 when Tok_Delay => 856 Check_Bad_Layout; 857 Append_To (Statement_List, P_Delay_Statement); 858 Statement_Required := False; 859 860 -- Exit_Statement 861 862 when Tok_Exit => 863 Check_Bad_Layout; 864 Append_To (Statement_List, P_Exit_Statement); 865 Statement_Required := False; 866 867 -- Loop_Statement with FOR and no label 868 869 when Tok_For => 870 Check_Bad_Layout; 871 Append_To (Statement_List, P_For_Statement); 872 Statement_Required := False; 873 874 -- Goto_Statement 875 876 when Tok_Goto => 877 Check_Bad_Layout; 878 Append_To (Statement_List, P_Goto_Statement); 879 Statement_Required := False; 880 881 -- If_Statement 882 883 when Tok_If => 884 Check_Bad_Layout; 885 Append_To (Statement_List, P_If_Statement); 886 Statement_Required := False; 887 888 -- Loop_Statement 889 890 when Tok_Loop => 891 Check_Bad_Layout; 892 Append_To (Statement_List, P_Loop_Statement); 893 Statement_Required := False; 894 895 -- Null_Statement 896 897 when Tok_Null => 898 Check_Bad_Layout; 899 Append_To (Statement_List, P_Null_Statement); 900 Statement_Required := False; 901 902 -- Raise_Statement 903 904 when Tok_Raise => 905 Check_Bad_Layout; 906 Append_To (Statement_List, P_Raise_Statement); 907 Statement_Required := False; 908 909 -- Requeue_Statement 910 911 when Tok_Requeue => 912 Check_Bad_Layout; 913 Append_To (Statement_List, P_Requeue_Statement); 914 Statement_Required := False; 915 916 -- Return_Statement 917 918 when Tok_Return => 919 Check_Bad_Layout; 920 Append_To (Statement_List, P_Return_Statement); 921 Statement_Required := False; 922 923 -- Select_Statement 924 925 when Tok_Select => 926 Check_Bad_Layout; 927 Append_To (Statement_List, P_Select_Statement); 928 Statement_Required := False; 929 930 -- While_Statement (Block_Statement with while and no loop) 931 932 when Tok_While => 933 Check_Bad_Layout; 934 Append_To (Statement_List, P_While_Statement); 935 Statement_Required := False; 936 937 -- Anything else is some kind of junk, signal an error message 938 -- and then raise Error_Resync, to merge with the normal 939 -- handling of a bad statement. 940 941 when others => 942 943 if Token in Token_Class_Declk then 944 Junk_Declaration; 945 946 else 947 Error_Msg_BC -- CODEFIX 948 ("statement expected"); 949 raise Error_Resync; 950 end if; 951 end case; 952 953 -- On error resynchronization, skip past next semicolon, and, since 954 -- we are still in the statement loop, look for next statement. We 955 -- set Statement_Required False to avoid an unnecessary error message 956 -- complaining that no statement was found (i.e. we consider the 957 -- junk to satisfy the requirement for a statement being present). 958 959 exception 960 when Error_Resync => 961 Resync_Past_Semicolon_Or_To_Loop_Or_Then; 962 Statement_Required := False; 963 end; 964 965 exit when SS_Flags.Unco; 966 967 end loop; 968 969 return Statement_List; 970 971 end P_Sequence_Of_Statements; 972 973 -------------------- 974 -- 5.1 Statement -- 975 -------------------- 976 977 --------------------------- 978 -- 5.1 Simple Statement -- 979 --------------------------- 980 981 -- Parsed by P_Sequence_Of_Statements (5.1) 982 983 ----------------------------- 984 -- 5.1 Compound Statement -- 985 ----------------------------- 986 987 -- Parsed by P_Sequence_Of_Statements (5.1) 988 989 ------------------------- 990 -- 5.1 Null Statement -- 991 ------------------------- 992 993 -- NULL_STATEMENT ::= null; 994 995 -- The caller has already checked that the current token is null 996 997 -- Error recovery: cannot raise Error_Resync 998 999 function P_Null_Statement return Node_Id is 1000 Null_Stmt_Node : Node_Id; 1001 1002 begin 1003 Null_Stmt_Node := New_Node (N_Null_Statement, Token_Ptr); 1004 Scan; -- past NULL 1005 TF_Semicolon; 1006 return Null_Stmt_Node; 1007 end P_Null_Statement; 1008 1009 ---------------- 1010 -- 5.1 Label -- 1011 ---------------- 1012 1013 -- LABEL ::= <<label_STATEMENT_IDENTIFIER>> 1014 1015 -- STATEMENT_IDENTIFIER ::= DIRECT_NAME 1016 1017 -- The IDENTIFIER of a STATEMENT_IDENTIFIER shall be an identifier 1018 -- (not an OPERATOR_SYMBOL) 1019 1020 -- The caller has already checked that the current token is << 1021 1022 -- Error recovery: can raise Error_Resync 1023 1024 function P_Label return Node_Id is 1025 Label_Node : Node_Id; 1026 1027 begin 1028 Label_Node := New_Node (N_Label, Token_Ptr); 1029 Scan; -- past << 1030 Set_Identifier (Label_Node, P_Identifier (C_Greater_Greater)); 1031 T_Greater_Greater; 1032 Append_Elmt (Label_Node, Label_List); 1033 return Label_Node; 1034 end P_Label; 1035 1036 ------------------------------- 1037 -- 5.1 Statement Identifier -- 1038 ------------------------------- 1039 1040 -- Statement label is parsed by P_Label (5.1) 1041 1042 -- Loop label is parsed by P_Loop_Statement (5.5), P_For_Statement (5.5) 1043 -- or P_While_Statement (5.5) 1044 1045 -- Block label is parsed by P_Begin_Statement (5.6) or 1046 -- P_Declare_Statement (5.6) 1047 1048 ------------------------------- 1049 -- 5.2 Assignment Statement -- 1050 ------------------------------- 1051 1052 -- ASSIGNMENT_STATEMENT ::= 1053 -- variable_NAME := EXPRESSION; 1054 1055 -- Error recovery: can raise Error_Resync 1056 1057 function P_Assignment_Statement (LHS : Node_Id) return Node_Id is 1058 Assign_Node : Node_Id; 1059 1060 begin 1061 Assign_Node := New_Node (N_Assignment_Statement, Prev_Token_Ptr); 1062 Set_Name (Assign_Node, LHS); 1063 Set_Expression (Assign_Node, P_Expression_No_Right_Paren); 1064 TF_Semicolon; 1065 return Assign_Node; 1066 end P_Assignment_Statement; 1067 1068 ----------------------- 1069 -- 5.3 If Statement -- 1070 ----------------------- 1071 1072 -- IF_STATEMENT ::= 1073 -- if CONDITION then 1074 -- SEQUENCE_OF_STATEMENTS 1075 -- {elsif CONDITION then 1076 -- SEQUENCE_OF_STATEMENTS} 1077 -- [else 1078 -- SEQUENCE_OF_STATEMENTS] 1079 -- end if; 1080 1081 -- The caller has checked that the initial token is IF (or in the error 1082 -- case of a mysterious THEN, the initial token may simply be THEN, in 1083 -- which case, no condition (or IF) was scanned). 1084 1085 -- Error recovery: can raise Error_Resync 1086 1087 function P_If_Statement return Node_Id is 1088 If_Node : Node_Id; 1089 Elsif_Node : Node_Id; 1090 Loc : Source_Ptr; 1091 1092 procedure Add_Elsif_Part; 1093 -- An internal procedure used to scan out a single ELSIF part. On entry 1094 -- the ELSIF (or an ELSE which has been determined should be ELSIF) is 1095 -- scanned out and is in Prev_Token. 1096 1097 procedure Check_If_Column; 1098 -- An internal procedure used to check that THEN, ELSE, or ELSIF 1099 -- appear in the right place if column checking is enabled (i.e. if 1100 -- they are the first token on the line, then they must appear in 1101 -- the same column as the opening IF). 1102 1103 procedure Check_Then_Column; 1104 -- This procedure carries out the style checks for a THEN token 1105 -- Note that the caller has set Loc to the Source_Ptr value for 1106 -- the previous IF or ELSIF token. 1107 1108 function Else_Should_Be_Elsif return Boolean; 1109 -- An internal routine used to do a special error recovery check when 1110 -- an ELSE is encountered. It determines if the ELSE should be treated 1111 -- as an ELSIF. A positive decision (TRUE returned, is made if the ELSE 1112 -- is followed by a sequence of tokens, starting on the same line as 1113 -- the ELSE, which are not expression terminators, followed by a THEN. 1114 -- On entry, the ELSE has been scanned out. 1115 1116 procedure Add_Elsif_Part is 1117 begin 1118 if No (Elsif_Parts (If_Node)) then 1119 Set_Elsif_Parts (If_Node, New_List); 1120 end if; 1121 1122 Elsif_Node := New_Node (N_Elsif_Part, Prev_Token_Ptr); 1123 Loc := Prev_Token_Ptr; 1124 Set_Condition (Elsif_Node, P_Condition); 1125 Check_Then_Column; 1126 Then_Scan; 1127 Set_Then_Statements 1128 (Elsif_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq)); 1129 Append (Elsif_Node, Elsif_Parts (If_Node)); 1130 end Add_Elsif_Part; 1131 1132 procedure Check_If_Column is 1133 begin 1134 if RM_Column_Check and then Token_Is_At_Start_Of_Line 1135 and then Start_Column /= Scope.Table (Scope.Last).Ecol 1136 then 1137 Error_Msg_Col := Scope.Table (Scope.Last).Ecol; 1138 Error_Msg_SC ("(style) this token should be@"); 1139 end if; 1140 end Check_If_Column; 1141 1142 procedure Check_Then_Column is 1143 begin 1144 if Token = Tok_Then then 1145 Check_If_Column; 1146 1147 if Style_Check then 1148 Style.Check_Then (Loc); 1149 end if; 1150 end if; 1151 end Check_Then_Column; 1152 1153 function Else_Should_Be_Elsif return Boolean is 1154 Scan_State : Saved_Scan_State; 1155 1156 begin 1157 if Token_Is_At_Start_Of_Line then 1158 return False; 1159 1160 else 1161 Save_Scan_State (Scan_State); 1162 1163 loop 1164 if Token in Token_Class_Eterm then 1165 Restore_Scan_State (Scan_State); 1166 return False; 1167 else 1168 Scan; -- past non-expression terminating token 1169 1170 if Token = Tok_Then then 1171 Restore_Scan_State (Scan_State); 1172 return True; 1173 end if; 1174 end if; 1175 end loop; 1176 end if; 1177 end Else_Should_Be_Elsif; 1178 1179 -- Start of processing for P_If_Statement 1180 1181 begin 1182 If_Node := New_Node (N_If_Statement, Token_Ptr); 1183 1184 Push_Scope_Stack; 1185 Scope.Table (Scope.Last).Etyp := E_If; 1186 Scope.Table (Scope.Last).Ecol := Start_Column; 1187 Scope.Table (Scope.Last).Sloc := Token_Ptr; 1188 Scope.Table (Scope.Last).Labl := Error; 1189 Scope.Table (Scope.Last).Node := If_Node; 1190 1191 if Token = Tok_If then 1192 Loc := Token_Ptr; 1193 Scan; -- past IF 1194 Set_Condition (If_Node, P_Condition); 1195 1196 -- Deal with misuse of IF expression => used instead 1197 -- of WHEN expression => 1198 1199 if Token = Tok_Arrow then 1200 Error_Msg_SC -- CODEFIX 1201 ("THEN expected"); 1202 Scan; -- past the arrow 1203 Pop_Scope_Stack; -- remove unneeded entry 1204 raise Error_Resync; 1205 end if; 1206 1207 Check_Then_Column; 1208 1209 else 1210 Error_Msg_SC ("no IF for this THEN"); 1211 Set_Condition (If_Node, Error); 1212 end if; 1213 1214 Then_Scan; 1215 1216 Set_Then_Statements 1217 (If_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq)); 1218 1219 -- This loop scans out else and elsif parts 1220 1221 loop 1222 if Token = Tok_Elsif then 1223 Check_If_Column; 1224 1225 if Present (Else_Statements (If_Node)) then 1226 Error_Msg_SP ("ELSIF cannot appear after ELSE"); 1227 end if; 1228 1229 Scan; -- past ELSIF 1230 Add_Elsif_Part; 1231 1232 elsif Token = Tok_Else then 1233 Check_If_Column; 1234 Scan; -- past ELSE 1235 1236 if Else_Should_Be_Elsif then 1237 Error_Msg_SP -- CODEFIX 1238 ("ELSE should be ELSIF"); 1239 Add_Elsif_Part; 1240 1241 else 1242 -- Here we have an else that really is an else 1243 1244 if Present (Else_Statements (If_Node)) then 1245 Error_Msg_SP ("only one ELSE part allowed"); 1246 Append_List 1247 (P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq), 1248 Else_Statements (If_Node)); 1249 else 1250 Set_Else_Statements 1251 (If_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq)); 1252 end if; 1253 end if; 1254 1255 -- If anything other than ELSE or ELSIF, exit the loop. The token 1256 -- had better be END (and in fact it had better be END IF), but 1257 -- we will let End_Statements take care of checking that. 1258 1259 else 1260 exit; 1261 end if; 1262 end loop; 1263 1264 End_Statements; 1265 return If_Node; 1266 1267 end P_If_Statement; 1268 1269 -------------------- 1270 -- 5.3 Condition -- 1271 -------------------- 1272 1273 -- CONDITION ::= boolean_EXPRESSION 1274 1275 function P_Condition return Node_Id is 1276 begin 1277 return P_Condition (P_Expression_No_Right_Paren); 1278 end P_Condition; 1279 1280 function P_Condition (Cond : Node_Id) return Node_Id is 1281 begin 1282 -- It is never possible for := to follow a condition, so if we get 1283 -- a := we assume it is a mistyped equality. Note that we do not try 1284 -- to reconstruct the tree correctly in this case, but we do at least 1285 -- give an accurate error message. 1286 1287 if Token = Tok_Colon_Equal then 1288 while Token = Tok_Colon_Equal loop 1289 Error_Msg_SC -- CODEFIX 1290 (""":="" should be ""="""); 1291 Scan; -- past junk := 1292 Discard_Junk_Node (P_Expression_No_Right_Paren); 1293 end loop; 1294 1295 return Cond; 1296 1297 -- Otherwise check for redundant parentheses 1298 1299 -- If the condition is a conditional or a quantified expression, it is 1300 -- parenthesized in the context of a condition, because of a separate 1301 -- syntax rule. 1302 1303 else 1304 if Style_Check and then Paren_Count (Cond) > 0 then 1305 if not Nkind_In (Cond, N_If_Expression, 1306 N_Case_Expression, 1307 N_Quantified_Expression) 1308 or else Paren_Count (Cond) > 1 1309 then 1310 Style.Check_Xtra_Parens (First_Sloc (Cond)); 1311 end if; 1312 end if; 1313 1314 -- And return the result 1315 1316 return Cond; 1317 end if; 1318 end P_Condition; 1319 1320 ------------------------- 1321 -- 5.4 Case Statement -- 1322 ------------------------- 1323 1324 -- CASE_STATEMENT ::= 1325 -- case EXPRESSION is 1326 -- CASE_STATEMENT_ALTERNATIVE 1327 -- {CASE_STATEMENT_ALTERNATIVE} 1328 -- end case; 1329 1330 -- The caller has checked that the first token is CASE 1331 1332 -- Can raise Error_Resync 1333 1334 function P_Case_Statement return Node_Id is 1335 Case_Node : Node_Id; 1336 Alternatives_List : List_Id; 1337 First_When_Loc : Source_Ptr; 1338 1339 begin 1340 Case_Node := New_Node (N_Case_Statement, Token_Ptr); 1341 1342 Push_Scope_Stack; 1343 Scope.Table (Scope.Last).Etyp := E_Case; 1344 Scope.Table (Scope.Last).Ecol := Start_Column; 1345 Scope.Table (Scope.Last).Sloc := Token_Ptr; 1346 Scope.Table (Scope.Last).Labl := Error; 1347 Scope.Table (Scope.Last).Node := Case_Node; 1348 1349 Scan; -- past CASE 1350 Set_Expression (Case_Node, P_Expression_No_Right_Paren); 1351 TF_Is; 1352 1353 -- Prepare to parse case statement alternatives 1354 1355 Alternatives_List := New_List; 1356 P_Pragmas_Opt (Alternatives_List); 1357 First_When_Loc := Token_Ptr; 1358 1359 -- Loop through case statement alternatives 1360 1361 loop 1362 -- If we have a WHEN or OTHERS, then that's fine keep going. Note 1363 -- that it is a semantic check to ensure the proper use of OTHERS 1364 1365 if Token = Tok_When or else Token = Tok_Others then 1366 Append (P_Case_Statement_Alternative, Alternatives_List); 1367 1368 -- If we have an END, then probably we are at the end of the case 1369 -- but we only exit if Check_End thinks the END was reasonable. 1370 1371 elsif Token = Tok_End then 1372 exit when Check_End; 1373 1374 -- Here if token is other than WHEN, OTHERS or END. We definitely 1375 -- have an error, but the question is whether or not to get out of 1376 -- the case statement. We don't want to get out early, or we will 1377 -- get a slew of junk error messages for subsequent when tokens. 1378 1379 -- If the token is not at the start of the line, or if it is indented 1380 -- with respect to the current case statement, then the best guess is 1381 -- that we are still supposed to be inside the case statement. We 1382 -- complain about the missing WHEN, and discard the junk statements. 1383 1384 elsif not Token_Is_At_Start_Of_Line 1385 or else Start_Column > Scope.Table (Scope.Last).Ecol 1386 then 1387 Error_Msg_BC ("WHEN (case statement alternative) expected"); 1388 1389 -- Here is a possibility for infinite looping if we don't make 1390 -- progress. So try to process statements, otherwise exit 1391 1392 declare 1393 Error_Ptr : constant Source_Ptr := Scan_Ptr; 1394 begin 1395 Discard_Junk_List (P_Sequence_Of_Statements (SS_Whtm)); 1396 exit when Scan_Ptr = Error_Ptr and then Check_End; 1397 end; 1398 1399 -- Here we have a junk token at the start of the line and it is 1400 -- not indented. If Check_End thinks there is a missing END, then 1401 -- we will get out of the case, otherwise we keep going. 1402 1403 else 1404 exit when Check_End; 1405 end if; 1406 end loop; 1407 1408 -- Make sure we have at least one alternative 1409 1410 if No (First_Non_Pragma (Alternatives_List)) then 1411 Error_Msg 1412 ("WHEN expected, must have at least one alternative in case", 1413 First_When_Loc); 1414 return Error; 1415 1416 else 1417 Set_Alternatives (Case_Node, Alternatives_List); 1418 return Case_Node; 1419 end if; 1420 end P_Case_Statement; 1421 1422 ------------------------------------- 1423 -- 5.4 Case Statement Alternative -- 1424 ------------------------------------- 1425 1426 -- CASE_STATEMENT_ALTERNATIVE ::= 1427 -- when DISCRETE_CHOICE_LIST => 1428 -- SEQUENCE_OF_STATEMENTS 1429 1430 -- The caller has checked that the initial token is WHEN or OTHERS 1431 -- Error recovery: can raise Error_Resync 1432 1433 function P_Case_Statement_Alternative return Node_Id is 1434 Case_Alt_Node : Node_Id; 1435 1436 begin 1437 if Style_Check then 1438 Style.Check_Indentation; 1439 end if; 1440 1441 Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Token_Ptr); 1442 T_When; -- past WHEN (or give error in OTHERS case) 1443 Set_Discrete_Choices (Case_Alt_Node, P_Discrete_Choice_List); 1444 TF_Arrow; 1445 Set_Statements (Case_Alt_Node, P_Sequence_Of_Statements (SS_Sreq_Whtm)); 1446 return Case_Alt_Node; 1447 end P_Case_Statement_Alternative; 1448 1449 ------------------------- 1450 -- 5.5 Loop Statement -- 1451 ------------------------- 1452 1453 -- LOOP_STATEMENT ::= 1454 -- [LOOP_STATEMENT_IDENTIFIER:] 1455 -- [ITERATION_SCHEME] loop 1456 -- SEQUENCE_OF_STATEMENTS 1457 -- end loop [loop_IDENTIFIER]; 1458 1459 -- ITERATION_SCHEME ::= 1460 -- while CONDITION 1461 -- | for LOOP_PARAMETER_SPECIFICATION 1462 1463 -- The parsing of loop statements is handled by one of three functions 1464 -- P_Loop_Statement, P_For_Statement or P_While_Statement depending 1465 -- on the initial keyword in the construct (excluding the identifier) 1466 1467 -- P_Loop_Statement 1468 1469 -- This function parses the case where no iteration scheme is present 1470 1471 -- The caller has checked that the initial token is LOOP. The parameter 1472 -- is the node identifiers for the loop label if any (or is set to Empty 1473 -- if there is no loop label). 1474 1475 -- Error recovery : cannot raise Error_Resync 1476 1477 function P_Loop_Statement (Loop_Name : Node_Id := Empty) return Node_Id is 1478 Loop_Node : Node_Id; 1479 Created_Name : Node_Id; 1480 1481 begin 1482 Push_Scope_Stack; 1483 Scope.Table (Scope.Last).Labl := Loop_Name; 1484 Scope.Table (Scope.Last).Ecol := Start_Column; 1485 Scope.Table (Scope.Last).Sloc := Token_Ptr; 1486 Scope.Table (Scope.Last).Etyp := E_Loop; 1487 1488 Loop_Node := New_Node (N_Loop_Statement, Token_Ptr); 1489 TF_Loop; 1490 1491 if No (Loop_Name) then 1492 Created_Name := 1493 Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L')); 1494 Set_Comes_From_Source (Created_Name, False); 1495 Set_Has_Created_Identifier (Loop_Node, True); 1496 Set_Identifier (Loop_Node, Created_Name); 1497 Scope.Table (Scope.Last).Labl := Created_Name; 1498 else 1499 Set_Identifier (Loop_Node, Loop_Name); 1500 end if; 1501 1502 Append_Elmt (Loop_Node, Label_List); 1503 Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq)); 1504 End_Statements (Loop_Node); 1505 return Loop_Node; 1506 end P_Loop_Statement; 1507 1508 -- P_For_Statement 1509 1510 -- This function parses a loop statement with a FOR iteration scheme 1511 1512 -- The caller has checked that the initial token is FOR. The parameter 1513 -- is the node identifier for the block label if any (or is set to Empty 1514 -- if there is no block label). 1515 1516 -- Note: the caller fills in the Identifier field if a label was present 1517 1518 -- Error recovery: can raise Error_Resync 1519 1520 function P_For_Statement (Loop_Name : Node_Id := Empty) return Node_Id is 1521 Loop_Node : Node_Id; 1522 Iter_Scheme_Node : Node_Id; 1523 Loop_For_Flag : Boolean; 1524 Created_Name : Node_Id; 1525 Spec : Node_Id; 1526 1527 begin 1528 Push_Scope_Stack; 1529 Scope.Table (Scope.Last).Labl := Loop_Name; 1530 Scope.Table (Scope.Last).Ecol := Start_Column; 1531 Scope.Table (Scope.Last).Sloc := Token_Ptr; 1532 Scope.Table (Scope.Last).Etyp := E_Loop; 1533 1534 Loop_For_Flag := (Prev_Token = Tok_Loop); 1535 Scan; -- past FOR 1536 Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr); 1537 Spec := P_Loop_Parameter_Specification; 1538 1539 if Nkind (Spec) = N_Loop_Parameter_Specification then 1540 Set_Loop_Parameter_Specification (Iter_Scheme_Node, Spec); 1541 else 1542 Set_Iterator_Specification (Iter_Scheme_Node, Spec); 1543 end if; 1544 1545 -- The following is a special test so that a miswritten for loop such 1546 -- as "loop for I in 1..10;" is handled nicely, without making an extra 1547 -- entry in the scope stack. We don't bother to actually fix up the 1548 -- tree in this case since it's not worth the effort. Instead we just 1549 -- eat up the loop junk, leaving the entry for what now looks like an 1550 -- unmodified loop intact. 1551 1552 if Loop_For_Flag and then Token = Tok_Semicolon then 1553 Error_Msg_SC ("LOOP belongs here, not before FOR"); 1554 Pop_Scope_Stack; 1555 return Error; 1556 1557 -- Normal case 1558 1559 else 1560 Loop_Node := New_Node (N_Loop_Statement, Token_Ptr); 1561 1562 if No (Loop_Name) then 1563 Created_Name := 1564 Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L')); 1565 Set_Comes_From_Source (Created_Name, False); 1566 Set_Has_Created_Identifier (Loop_Node, True); 1567 Set_Identifier (Loop_Node, Created_Name); 1568 Scope.Table (Scope.Last).Labl := Created_Name; 1569 else 1570 Set_Identifier (Loop_Node, Loop_Name); 1571 end if; 1572 1573 TF_Loop; 1574 Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq)); 1575 End_Statements (Loop_Node); 1576 Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node); 1577 Append_Elmt (Loop_Node, Label_List); 1578 return Loop_Node; 1579 end if; 1580 end P_For_Statement; 1581 1582 -- P_While_Statement 1583 1584 -- This procedure scans a loop statement with a WHILE iteration scheme 1585 1586 -- The caller has checked that the initial token is WHILE. The parameter 1587 -- is the node identifier for the block label if any (or is set to Empty 1588 -- if there is no block label). 1589 1590 -- Error recovery: cannot raise Error_Resync 1591 1592 function P_While_Statement (Loop_Name : Node_Id := Empty) return Node_Id is 1593 Loop_Node : Node_Id; 1594 Iter_Scheme_Node : Node_Id; 1595 Loop_While_Flag : Boolean; 1596 Created_Name : Node_Id; 1597 1598 begin 1599 Push_Scope_Stack; 1600 Scope.Table (Scope.Last).Labl := Loop_Name; 1601 Scope.Table (Scope.Last).Ecol := Start_Column; 1602 Scope.Table (Scope.Last).Sloc := Token_Ptr; 1603 Scope.Table (Scope.Last).Etyp := E_Loop; 1604 1605 Loop_While_Flag := (Prev_Token = Tok_Loop); 1606 Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr); 1607 Scan; -- past WHILE 1608 Set_Condition (Iter_Scheme_Node, P_Condition); 1609 1610 -- The following is a special test so that a miswritten for loop such 1611 -- as "loop while I > 10;" is handled nicely, without making an extra 1612 -- entry in the scope stack. We don't bother to actually fix up the 1613 -- tree in this case since it's not worth the effort. Instead we just 1614 -- eat up the loop junk, leaving the entry for what now looks like an 1615 -- unmodified loop intact. 1616 1617 if Loop_While_Flag and then Token = Tok_Semicolon then 1618 Error_Msg_SC ("LOOP belongs here, not before WHILE"); 1619 Pop_Scope_Stack; 1620 return Error; 1621 1622 -- Normal case 1623 1624 else 1625 Loop_Node := New_Node (N_Loop_Statement, Token_Ptr); 1626 TF_Loop; 1627 1628 if No (Loop_Name) then 1629 Created_Name := 1630 Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L')); 1631 Set_Comes_From_Source (Created_Name, False); 1632 Set_Has_Created_Identifier (Loop_Node, True); 1633 Set_Identifier (Loop_Node, Created_Name); 1634 Scope.Table (Scope.Last).Labl := Created_Name; 1635 else 1636 Set_Identifier (Loop_Node, Loop_Name); 1637 end if; 1638 1639 Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq)); 1640 End_Statements (Loop_Node); 1641 Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node); 1642 Append_Elmt (Loop_Node, Label_List); 1643 return Loop_Node; 1644 end if; 1645 end P_While_Statement; 1646 1647 --------------------------------------- 1648 -- 5.5 Loop Parameter Specification -- 1649 --------------------------------------- 1650 1651 -- LOOP_PARAMETER_SPECIFICATION ::= 1652 -- DEFINING_IDENTIFIER in [reverse] DISCRETE_SUBTYPE_DEFINITION 1653 1654 -- Error recovery: cannot raise Error_Resync 1655 1656 function P_Loop_Parameter_Specification return Node_Id is 1657 Loop_Param_Specification_Node : Node_Id; 1658 1659 ID_Node : Node_Id; 1660 Scan_State : Saved_Scan_State; 1661 1662 begin 1663 1664 Save_Scan_State (Scan_State); 1665 ID_Node := P_Defining_Identifier (C_In); 1666 1667 -- If the next token is OF, it indicates an Ada 2012 iterator. If the 1668 -- next token is a colon, this is also an Ada 2012 iterator, including 1669 -- a subtype indication for the loop parameter. Otherwise we parse the 1670 -- construct as a loop parameter specification. Note that the form 1671 -- "for A in B" is ambiguous, and must be resolved semantically: if B 1672 -- is a discrete subtype this is a loop specification, but if it is an 1673 -- expression it is an iterator specification. Ambiguity is resolved 1674 -- during analysis of the loop parameter specification. 1675 1676 if Token = Tok_Of or else Token = Tok_Colon then 1677 Error_Msg_Ada_2012_Feature ("iterator", Token_Ptr); 1678 return P_Iterator_Specification (ID_Node); 1679 end if; 1680 1681 -- The span of the Loop_Parameter_Specification starts at the 1682 -- defining identifier. 1683 1684 Loop_Param_Specification_Node := 1685 New_Node (N_Loop_Parameter_Specification, Sloc (ID_Node)); 1686 Set_Defining_Identifier (Loop_Param_Specification_Node, ID_Node); 1687 1688 if Token = Tok_Left_Paren then 1689 Error_Msg_SC ("subscripted loop parameter not allowed"); 1690 Restore_Scan_State (Scan_State); 1691 Discard_Junk_Node (P_Name); 1692 1693 elsif Token = Tok_Dot then 1694 Error_Msg_SC ("selected loop parameter not allowed"); 1695 Restore_Scan_State (Scan_State); 1696 Discard_Junk_Node (P_Name); 1697 end if; 1698 1699 T_In; 1700 1701 if Token = Tok_Reverse then 1702 Scan; -- past REVERSE 1703 Set_Reverse_Present (Loop_Param_Specification_Node, True); 1704 end if; 1705 1706 Set_Discrete_Subtype_Definition 1707 (Loop_Param_Specification_Node, P_Discrete_Subtype_Definition); 1708 return Loop_Param_Specification_Node; 1709 1710 exception 1711 when Error_Resync => 1712 return Error; 1713 end P_Loop_Parameter_Specification; 1714 1715 ---------------------------------- 1716 -- 5.5.1 Iterator_Specification -- 1717 ---------------------------------- 1718 1719 function P_Iterator_Specification (Def_Id : Node_Id) return Node_Id is 1720 Node1 : Node_Id; 1721 1722 begin 1723 Node1 := New_Node (N_Iterator_Specification, Sloc (Def_Id)); 1724 Set_Defining_Identifier (Node1, Def_Id); 1725 1726 if Token = Tok_Colon then 1727 Scan; -- past : 1728 Set_Subtype_Indication (Node1, P_Subtype_Indication); 1729 end if; 1730 1731 if Token = Tok_Of then 1732 Set_Of_Present (Node1); 1733 Scan; -- past OF 1734 1735 elsif Token = Tok_In then 1736 Scan; -- past IN 1737 1738 elsif Prev_Token = Tok_In 1739 and then Present (Subtype_Indication (Node1)) 1740 then 1741 -- Simplest recovery is to transform it into an element iterator. 1742 -- Error message on 'in" has already been emitted when parsing the 1743 -- optional constraint. 1744 1745 Set_Of_Present (Node1); 1746 Error_Msg_N 1747 ("subtype indication is only legal on an element iterator", 1748 Subtype_Indication (Node1)); 1749 1750 else 1751 return Error; 1752 end if; 1753 1754 if Token = Tok_Reverse then 1755 Scan; -- past REVERSE 1756 Set_Reverse_Present (Node1, True); 1757 end if; 1758 1759 Set_Name (Node1, P_Name); 1760 return Node1; 1761 end P_Iterator_Specification; 1762 1763 -------------------------- 1764 -- 5.6 Block Statement -- 1765 -------------------------- 1766 1767 -- BLOCK_STATEMENT ::= 1768 -- [block_STATEMENT_IDENTIFIER:] 1769 -- [declare 1770 -- DECLARATIVE_PART] 1771 -- begin 1772 -- HANDLED_SEQUENCE_OF_STATEMENTS 1773 -- end [block_IDENTIFIER]; 1774 1775 -- The parsing of block statements is handled by one of the two functions 1776 -- P_Declare_Statement or P_Begin_Statement depending on whether or not 1777 -- a declare section is present 1778 1779 -- P_Declare_Statement 1780 1781 -- This function parses a block statement with DECLARE present 1782 1783 -- The caller has checked that the initial token is DECLARE 1784 1785 -- Error recovery: cannot raise Error_Resync 1786 1787 function P_Declare_Statement 1788 (Block_Name : Node_Id := Empty) 1789 return Node_Id 1790 is 1791 Block_Node : Node_Id; 1792 Created_Name : Node_Id; 1793 1794 begin 1795 Block_Node := New_Node (N_Block_Statement, Token_Ptr); 1796 1797 Push_Scope_Stack; 1798 Scope.Table (Scope.Last).Etyp := E_Name; 1799 Scope.Table (Scope.Last).Lreq := Present (Block_Name); 1800 Scope.Table (Scope.Last).Ecol := Start_Column; 1801 Scope.Table (Scope.Last).Labl := Block_Name; 1802 Scope.Table (Scope.Last).Sloc := Token_Ptr; 1803 1804 Scan; -- past DECLARE 1805 1806 if No (Block_Name) then 1807 Created_Name := 1808 Make_Identifier (Sloc (Block_Node), Set_Loop_Block_Name ('B')); 1809 Set_Comes_From_Source (Created_Name, False); 1810 Set_Has_Created_Identifier (Block_Node, True); 1811 Set_Identifier (Block_Node, Created_Name); 1812 Scope.Table (Scope.Last).Labl := Created_Name; 1813 else 1814 Set_Identifier (Block_Node, Block_Name); 1815 end if; 1816 1817 Append_Elmt (Block_Node, Label_List); 1818 Parse_Decls_Begin_End (Block_Node); 1819 return Block_Node; 1820 end P_Declare_Statement; 1821 1822 -- P_Begin_Statement 1823 1824 -- This function parses a block statement with no DECLARE present 1825 1826 -- The caller has checked that the initial token is BEGIN 1827 1828 -- Error recovery: cannot raise Error_Resync 1829 1830 function P_Begin_Statement 1831 (Block_Name : Node_Id := Empty) 1832 return Node_Id 1833 is 1834 Block_Node : Node_Id; 1835 Created_Name : Node_Id; 1836 1837 begin 1838 Block_Node := New_Node (N_Block_Statement, Token_Ptr); 1839 1840 Push_Scope_Stack; 1841 Scope.Table (Scope.Last).Etyp := E_Name; 1842 Scope.Table (Scope.Last).Lreq := Present (Block_Name); 1843 Scope.Table (Scope.Last).Ecol := Start_Column; 1844 Scope.Table (Scope.Last).Labl := Block_Name; 1845 Scope.Table (Scope.Last).Sloc := Token_Ptr; 1846 1847 if No (Block_Name) then 1848 Created_Name := 1849 Make_Identifier (Sloc (Block_Node), Set_Loop_Block_Name ('B')); 1850 Set_Comes_From_Source (Created_Name, False); 1851 Set_Has_Created_Identifier (Block_Node, True); 1852 Set_Identifier (Block_Node, Created_Name); 1853 Scope.Table (Scope.Last).Labl := Created_Name; 1854 else 1855 Set_Identifier (Block_Node, Block_Name); 1856 end if; 1857 1858 Append_Elmt (Block_Node, Label_List); 1859 1860 Scope.Table (Scope.Last).Ecol := Start_Column; 1861 Scope.Table (Scope.Last).Sloc := Token_Ptr; 1862 Scan; -- past BEGIN 1863 Set_Handled_Statement_Sequence 1864 (Block_Node, P_Handled_Sequence_Of_Statements); 1865 End_Statements (Handled_Statement_Sequence (Block_Node)); 1866 return Block_Node; 1867 end P_Begin_Statement; 1868 1869 ------------------------- 1870 -- 5.7 Exit Statement -- 1871 ------------------------- 1872 1873 -- EXIT_STATEMENT ::= 1874 -- exit [loop_NAME] [when CONDITION]; 1875 1876 -- The caller has checked that the initial token is EXIT 1877 1878 -- Error recovery: can raise Error_Resync 1879 1880 function P_Exit_Statement return Node_Id is 1881 Exit_Node : Node_Id; 1882 1883 function Missing_Semicolon_On_Exit return Boolean; 1884 -- This function deals with the following specialized situation 1885 -- 1886 -- when 'x' => 1887 -- exit [identifier] 1888 -- when 'y' => 1889 -- 1890 -- This looks like a messed up EXIT WHEN, when in fact the problem 1891 -- is a missing semicolon. It is called with Token pointing to the 1892 -- WHEN token, and returns True if a semicolon is missing before 1893 -- the WHEN as in the above example. 1894 1895 ------------------------------- 1896 -- Missing_Semicolon_On_Exit -- 1897 ------------------------------- 1898 1899 function Missing_Semicolon_On_Exit return Boolean is 1900 State : Saved_Scan_State; 1901 1902 begin 1903 if not Token_Is_At_Start_Of_Line then 1904 return False; 1905 1906 elsif Scope.Table (Scope.Last).Etyp /= E_Case then 1907 return False; 1908 1909 else 1910 Save_Scan_State (State); 1911 Scan; -- past WHEN 1912 Scan; -- past token after WHEN 1913 1914 if Token = Tok_Arrow then 1915 Restore_Scan_State (State); 1916 return True; 1917 else 1918 Restore_Scan_State (State); 1919 return False; 1920 end if; 1921 end if; 1922 end Missing_Semicolon_On_Exit; 1923 1924 -- Start of processing for P_Exit_Statement 1925 1926 begin 1927 Exit_Node := New_Node (N_Exit_Statement, Token_Ptr); 1928 Scan; -- past EXIT 1929 1930 if Token = Tok_Identifier then 1931 Set_Name (Exit_Node, P_Qualified_Simple_Name); 1932 1933 elsif Style_Check then 1934 -- This EXIT has no name, so check that 1935 -- the innermost loop is unnamed too. 1936 1937 Check_No_Exit_Name : 1938 for J in reverse 1 .. Scope.Last loop 1939 if Scope.Table (J).Etyp = E_Loop then 1940 if Present (Scope.Table (J).Labl) 1941 and then Comes_From_Source (Scope.Table (J).Labl) 1942 then 1943 -- Innermost loop in fact had a name, style check fails 1944 1945 Style.No_Exit_Name (Scope.Table (J).Labl); 1946 end if; 1947 1948 exit Check_No_Exit_Name; 1949 end if; 1950 end loop Check_No_Exit_Name; 1951 end if; 1952 1953 if Token = Tok_When and then not Missing_Semicolon_On_Exit then 1954 Scan; -- past WHEN 1955 Set_Condition (Exit_Node, P_Condition); 1956 1957 -- Allow IF instead of WHEN, giving error message 1958 1959 elsif Token = Tok_If then 1960 T_When; 1961 Scan; -- past IF used in place of WHEN 1962 Set_Condition (Exit_Node, P_Expression_No_Right_Paren); 1963 end if; 1964 1965 TF_Semicolon; 1966 return Exit_Node; 1967 end P_Exit_Statement; 1968 1969 ------------------------- 1970 -- 5.8 Goto Statement -- 1971 ------------------------- 1972 1973 -- GOTO_STATEMENT ::= goto label_NAME; 1974 1975 -- The caller has checked that the initial token is GOTO (or TO in the 1976 -- error case where GO and TO were incorrectly separated). 1977 1978 -- Error recovery: can raise Error_Resync 1979 1980 function P_Goto_Statement return Node_Id is 1981 Goto_Node : Node_Id; 1982 1983 begin 1984 Goto_Node := New_Node (N_Goto_Statement, Token_Ptr); 1985 Scan; -- past GOTO (or TO) 1986 Set_Name (Goto_Node, P_Qualified_Simple_Name_Resync); 1987 Append_Elmt (Goto_Node, Goto_List); 1988 No_Constraint; 1989 TF_Semicolon; 1990 return Goto_Node; 1991 end P_Goto_Statement; 1992 1993 --------------------------- 1994 -- Parse_Decls_Begin_End -- 1995 --------------------------- 1996 1997 -- This function parses the construct: 1998 1999 -- DECLARATIVE_PART 2000 -- begin 2001 -- HANDLED_SEQUENCE_OF_STATEMENTS 2002 -- end [NAME]; 2003 2004 -- The caller has built the scope stack entry, and created the node to 2005 -- whose Declarations and Handled_Statement_Sequence fields are to be 2006 -- set. On return these fields are filled in (except in the case of a 2007 -- task body, where the handled statement sequence is optional, and may 2008 -- thus be Empty), and the scan is positioned past the End sequence. 2009 2010 -- If the BEGIN is missing, then the parent node is used to help construct 2011 -- an appropriate missing BEGIN message. Possibilities for the parent are: 2012 2013 -- N_Block_Statement declare block 2014 -- N_Entry_Body entry body 2015 -- N_Package_Body package body (begin part optional) 2016 -- N_Subprogram_Body procedure or function body 2017 -- N_Task_Body task body 2018 2019 -- Note: in the case of a block statement, there is definitely a DECLARE 2020 -- present (because a Begin statement without a DECLARE is handled by the 2021 -- P_Begin_Statement procedure, which does not call Parse_Decls_Begin_End. 2022 2023 -- Error recovery: cannot raise Error_Resync 2024 2025 procedure Parse_Decls_Begin_End (Parent : Node_Id) is 2026 Body_Decl : Node_Id; 2027 Decls : List_Id; 2028 Parent_Nkind : Node_Kind; 2029 Spec_Node : Node_Id; 2030 HSS : Node_Id; 2031 2032 procedure Missing_Begin (Msg : String); 2033 -- Called to post a missing begin message. In the normal case this is 2034 -- posted at the start of the current token. A special case arises when 2035 -- P_Declarative_Items has previously found a missing begin, in which 2036 -- case we replace the original error message. 2037 2038 procedure Set_Null_HSS (Parent : Node_Id); 2039 -- Construct an empty handled statement sequence and install in Parent 2040 -- Leaves HSS set to reference the newly constructed statement sequence. 2041 2042 ------------------- 2043 -- Missing_Begin -- 2044 ------------------- 2045 2046 procedure Missing_Begin (Msg : String) is 2047 begin 2048 if Missing_Begin_Msg = No_Error_Msg then 2049 Error_Msg_BC (Msg); 2050 else 2051 Change_Error_Text (Missing_Begin_Msg, Msg); 2052 2053 -- Purge any messages issued after than, since a missing begin 2054 -- can cause a lot of havoc, and it is better not to dump these 2055 -- cascaded messages on the user. 2056 2057 Purge_Messages (Get_Location (Missing_Begin_Msg), Prev_Token_Ptr); 2058 end if; 2059 end Missing_Begin; 2060 2061 ------------------ 2062 -- Set_Null_HSS -- 2063 ------------------ 2064 2065 procedure Set_Null_HSS (Parent : Node_Id) is 2066 Null_Stm : Node_Id; 2067 2068 begin 2069 Null_Stm := 2070 Make_Null_Statement (Token_Ptr); 2071 Set_Comes_From_Source (Null_Stm, False); 2072 2073 HSS := 2074 Make_Handled_Sequence_Of_Statements (Token_Ptr, 2075 Statements => New_List (Null_Stm)); 2076 Set_Comes_From_Source (HSS, False); 2077 2078 Set_Handled_Statement_Sequence (Parent, HSS); 2079 end Set_Null_HSS; 2080 2081 -- Start of processing for Parse_Decls_Begin_End 2082 2083 begin 2084 Decls := P_Declarative_Part; 2085 2086 if Ada_Version = Ada_83 then 2087 Check_Later_Vs_Basic_Declarations (Decls, During_Parsing => True); 2088 end if; 2089 2090 -- Here is where we deal with the case of IS used instead of semicolon. 2091 -- Specifically, if the last declaration in the declarative part is a 2092 -- subprogram body still marked as having a bad IS, then this is where 2093 -- we decide that the IS should really have been a semicolon and that 2094 -- the body should have been a declaration. Note that if the bad IS 2095 -- had turned out to be OK (i.e. a decent begin/end was found for it), 2096 -- then the Bad_Is_Detected flag would have been reset by now. 2097 2098 Body_Decl := Last (Decls); 2099 2100 if Present (Body_Decl) 2101 and then Nkind (Body_Decl) = N_Subprogram_Body 2102 and then Bad_Is_Detected (Body_Decl) 2103 then 2104 -- OK, we have the case of a bad IS, so we need to fix up the tree. 2105 -- What we have now is a subprogram body with attached declarations 2106 -- and a possible statement sequence. 2107 2108 -- First step is to take the declarations that were part of the bogus 2109 -- subprogram body and append them to the outer declaration chain. 2110 -- In other words we append them past the body (which we will later 2111 -- convert into a declaration). 2112 2113 Append_List (Declarations (Body_Decl), Decls); 2114 2115 -- Now take the handled statement sequence of the bogus body and 2116 -- set it as the statement sequence for the outer construct. Note 2117 -- that it may be empty (we specially allowed a missing BEGIN for 2118 -- a subprogram body marked as having a bad IS -- see below). 2119 2120 Set_Handled_Statement_Sequence (Parent, 2121 Handled_Statement_Sequence (Body_Decl)); 2122 2123 -- Next step is to convert the old body node to a declaration node 2124 2125 Spec_Node := Specification (Body_Decl); 2126 Change_Node (Body_Decl, N_Subprogram_Declaration); 2127 Set_Specification (Body_Decl, Spec_Node); 2128 2129 -- Final step is to put the declarations for the parent where 2130 -- they belong, and then fall through the IF to scan out the 2131 -- END statements. 2132 2133 Set_Declarations (Parent, Decls); 2134 2135 -- This is the normal case (i.e. any case except the bad IS case) 2136 -- If we have a BEGIN, then scan out the sequence of statements, and 2137 -- also reset the expected column for the END to match the BEGIN. 2138 2139 else 2140 Set_Declarations (Parent, Decls); 2141 2142 if Token = Tok_Begin then 2143 if Style_Check then 2144 Style.Check_Indentation; 2145 end if; 2146 2147 Error_Msg_Col := Scope.Table (Scope.Last).Ecol; 2148 2149 if RM_Column_Check 2150 and then Token_Is_At_Start_Of_Line 2151 and then Start_Column /= Error_Msg_Col 2152 then 2153 Error_Msg_SC ("(style) BEGIN in wrong column, should be@"); 2154 2155 else 2156 Scope.Table (Scope.Last).Ecol := Start_Column; 2157 end if; 2158 2159 Scope.Table (Scope.Last).Sloc := Token_Ptr; 2160 Scan; -- past BEGIN 2161 Set_Handled_Statement_Sequence (Parent, 2162 P_Handled_Sequence_Of_Statements); 2163 2164 -- No BEGIN present 2165 2166 else 2167 Parent_Nkind := Nkind (Parent); 2168 2169 -- A special check for the missing IS case. If we have a 2170 -- subprogram body that was marked as having a suspicious 2171 -- IS, and the current token is END, then we simply confirm 2172 -- the suspicion, and do not require a BEGIN to be present 2173 2174 if Parent_Nkind = N_Subprogram_Body 2175 and then Token = Tok_End 2176 and then Scope.Table (Scope.Last).Etyp = E_Suspicious_Is 2177 then 2178 Scope.Table (Scope.Last).Etyp := E_Bad_Is; 2179 2180 -- Otherwise BEGIN is not required for a package body, so we 2181 -- don't mind if it is missing, but we do construct a dummy 2182 -- one (so that we have somewhere to set End_Label). 2183 2184 -- However if we have something other than a BEGIN which 2185 -- looks like it might be statements, then we signal a missing 2186 -- BEGIN for these cases as well. We define "something which 2187 -- looks like it might be statements" as a token other than 2188 -- END, EOF, or a token which starts declarations. 2189 2190 elsif Parent_Nkind = N_Package_Body 2191 and then (Token = Tok_End 2192 or else Token = Tok_EOF 2193 or else Token in Token_Class_Declk) 2194 then 2195 Set_Null_HSS (Parent); 2196 2197 -- These are cases in which a BEGIN is required and not present 2198 2199 else 2200 Set_Null_HSS (Parent); 2201 2202 -- Prepare to issue error message 2203 2204 Error_Msg_Sloc := Scope.Table (Scope.Last).Sloc; 2205 Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl; 2206 2207 -- Now issue appropriate message 2208 2209 if Parent_Nkind = N_Block_Statement then 2210 Missing_Begin ("missing BEGIN for DECLARE#!"); 2211 2212 elsif Parent_Nkind = N_Entry_Body then 2213 Missing_Begin ("missing BEGIN for ENTRY#!"); 2214 2215 elsif Parent_Nkind = N_Subprogram_Body then 2216 if Nkind (Specification (Parent)) 2217 = N_Function_Specification 2218 then 2219 Missing_Begin ("missing BEGIN for function&#!"); 2220 else 2221 Missing_Begin ("missing BEGIN for procedure&#!"); 2222 end if; 2223 2224 -- The case for package body arises only when 2225 -- we have possible statement junk present. 2226 2227 elsif Parent_Nkind = N_Package_Body then 2228 Missing_Begin ("missing BEGIN for package body&#!"); 2229 2230 else 2231 pragma Assert (Parent_Nkind = N_Task_Body); 2232 Missing_Begin ("missing BEGIN for task body&#!"); 2233 end if; 2234 2235 -- Here we pick up the statements after the BEGIN that 2236 -- should have been present but was not. We don't insist 2237 -- on statements being present if P_Declarative_Part had 2238 -- already found a missing BEGIN, since it might have 2239 -- swallowed a lone statement into the declarative part. 2240 2241 if Missing_Begin_Msg /= No_Error_Msg 2242 and then Token = Tok_End 2243 then 2244 null; 2245 else 2246 Set_Handled_Statement_Sequence (Parent, 2247 P_Handled_Sequence_Of_Statements); 2248 end if; 2249 end if; 2250 end if; 2251 end if; 2252 2253 -- Here with declarations and handled statement sequence scanned 2254 2255 if Present (Handled_Statement_Sequence (Parent)) then 2256 End_Statements (Handled_Statement_Sequence (Parent)); 2257 else 2258 End_Statements; 2259 end if; 2260 2261 -- We know that End_Statements removed an entry from the scope stack 2262 -- (because it is required to do so under all circumstances). We can 2263 -- therefore reference the entry it removed one past the stack top. 2264 -- What we are interested in is whether it was a case of a bad IS. 2265 2266 if Scope.Table (Scope.Last + 1).Etyp = E_Bad_Is then 2267 Error_Msg -- CODEFIX 2268 ("|IS should be "";""", Scope.Table (Scope.Last + 1).S_Is); 2269 Set_Bad_Is_Detected (Parent, True); 2270 end if; 2271 2272 end Parse_Decls_Begin_End; 2273 2274 ------------------------- 2275 -- Set_Loop_Block_Name -- 2276 ------------------------- 2277 2278 function Set_Loop_Block_Name (L : Character) return Name_Id is 2279 begin 2280 Name_Buffer (1) := L; 2281 Name_Buffer (2) := '_'; 2282 Name_Len := 2; 2283 Loop_Block_Count := Loop_Block_Count + 1; 2284 Add_Nat_To_Name_Buffer (Loop_Block_Count); 2285 return Name_Find; 2286 end Set_Loop_Block_Name; 2287 2288 --------------- 2289 -- Then_Scan -- 2290 --------------- 2291 2292 procedure Then_Scan is 2293 begin 2294 TF_Then; 2295 2296 while Token = Tok_Then loop 2297 Error_Msg_SC -- CODEFIX 2298 ("redundant THEN"); 2299 TF_Then; 2300 end loop; 2301 2302 if Token = Tok_And or else Token = Tok_Or then 2303 Error_Msg_SC ("unexpected logical operator"); 2304 Scan; -- past logical operator 2305 2306 if (Prev_Token = Tok_And and then Token = Tok_Then) 2307 or else 2308 (Prev_Token = Tok_Or and then Token = Tok_Else) 2309 then 2310 Scan; 2311 end if; 2312 2313 Discard_Junk_Node (P_Expression); 2314 end if; 2315 2316 if Token = Tok_Then then 2317 Scan; 2318 end if; 2319 end Then_Scan; 2320 2321end Ch5; 2322