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