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-2020, 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 1303 1304 -- If the condition is a conditional or a quantified expression, it is 1305 -- parenthesized in the context of a condition, because of a separate 1306 -- syntax rule. 1307 1308 else 1309 if Style_Check 1310 and then 1311 Paren_Count (Cond) > 1312 (if Nkind (Cond) in N_Case_Expression 1313 | N_If_Expression 1314 | N_Quantified_Expression 1315 then 1 1316 else 0) 1317 then 1318 Style.Check_Xtra_Parens (First_Sloc (Cond)); 1319 end if; 1320 1321 -- And return the result 1322 1323 return Cond; 1324 end if; 1325 end P_Condition; 1326 1327 ------------------------- 1328 -- 5.4 Case Statement -- 1329 ------------------------- 1330 1331 -- CASE_STATEMENT ::= 1332 -- case EXPRESSION is 1333 -- CASE_STATEMENT_ALTERNATIVE 1334 -- {CASE_STATEMENT_ALTERNATIVE} 1335 -- end case; 1336 1337 -- The caller has checked that the first token is CASE 1338 1339 -- Can raise Error_Resync 1340 1341 function P_Case_Statement return Node_Id is 1342 Case_Node : Node_Id; 1343 Alternatives_List : List_Id; 1344 First_When_Loc : Source_Ptr; 1345 1346 begin 1347 Case_Node := New_Node (N_Case_Statement, Token_Ptr); 1348 1349 Push_Scope_Stack; 1350 Scopes (Scope.Last).Etyp := E_Case; 1351 Scopes (Scope.Last).Ecol := Start_Column; 1352 Scopes (Scope.Last).Sloc := Token_Ptr; 1353 Scopes (Scope.Last).Labl := Error; 1354 Scopes (Scope.Last).Node := Case_Node; 1355 1356 Scan; -- past CASE 1357 Set_Expression (Case_Node, P_Expression_No_Right_Paren); 1358 TF_Is; 1359 1360 -- Prepare to parse case statement alternatives 1361 1362 Alternatives_List := New_List; 1363 P_Pragmas_Opt (Alternatives_List); 1364 First_When_Loc := Token_Ptr; 1365 1366 -- Loop through case statement alternatives 1367 1368 loop 1369 -- If we have a WHEN or OTHERS, then that's fine keep going. Note 1370 -- that it is a semantic check to ensure the proper use of OTHERS 1371 1372 if Token = Tok_When or else Token = Tok_Others then 1373 Append (P_Case_Statement_Alternative, Alternatives_List); 1374 1375 -- If we have an END, then probably we are at the end of the case 1376 -- but we only exit if Check_End thinks the END was reasonable. 1377 1378 elsif Token = Tok_End then 1379 exit when Check_End; 1380 1381 -- Here if token is other than WHEN, OTHERS or END. We definitely 1382 -- have an error, but the question is whether or not to get out of 1383 -- the case statement. We don't want to get out early, or we will 1384 -- get a slew of junk error messages for subsequent when tokens. 1385 1386 -- If the token is not at the start of the line, or if it is indented 1387 -- with respect to the current case statement, then the best guess is 1388 -- that we are still supposed to be inside the case statement. We 1389 -- complain about the missing WHEN, and discard the junk statements. 1390 1391 elsif not Token_Is_At_Start_Of_Line 1392 or else Start_Column > Scopes (Scope.Last).Ecol 1393 then 1394 Error_Msg_BC ("WHEN (case statement alternative) expected"); 1395 1396 -- Here is a possibility for infinite looping if we don't make 1397 -- progress. So try to process statements, otherwise exit 1398 1399 declare 1400 Error_Ptr : constant Source_Ptr := Scan_Ptr; 1401 begin 1402 Discard_Junk_List (P_Sequence_Of_Statements (SS_Whtm)); 1403 exit when Scan_Ptr = Error_Ptr and then Check_End; 1404 end; 1405 1406 -- Here we have a junk token at the start of the line and it is 1407 -- not indented. If Check_End thinks there is a missing END, then 1408 -- we will get out of the case, otherwise we keep going. 1409 1410 else 1411 exit when Check_End; 1412 end if; 1413 end loop; 1414 1415 -- Make sure we have at least one alternative 1416 1417 if No (First_Non_Pragma (Alternatives_List)) then 1418 Error_Msg 1419 ("WHEN expected, must have at least one alternative in case", 1420 First_When_Loc); 1421 return Error; 1422 1423 else 1424 Set_Alternatives (Case_Node, Alternatives_List); 1425 return Case_Node; 1426 end if; 1427 end P_Case_Statement; 1428 1429 ------------------------------------- 1430 -- 5.4 Case Statement Alternative -- 1431 ------------------------------------- 1432 1433 -- CASE_STATEMENT_ALTERNATIVE ::= 1434 -- when DISCRETE_CHOICE_LIST => 1435 -- SEQUENCE_OF_STATEMENTS 1436 1437 -- The caller has checked that the initial token is WHEN or OTHERS 1438 -- Error recovery: can raise Error_Resync 1439 1440 function P_Case_Statement_Alternative return Node_Id is 1441 Case_Alt_Node : Node_Id; 1442 1443 begin 1444 if Style_Check then 1445 Style.Check_Indentation; 1446 end if; 1447 1448 Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Token_Ptr); 1449 T_When; -- past WHEN (or give error in OTHERS case) 1450 Set_Discrete_Choices (Case_Alt_Node, P_Discrete_Choice_List); 1451 TF_Arrow; 1452 Set_Statements (Case_Alt_Node, P_Sequence_Of_Statements (SS_Sreq_Whtm)); 1453 return Case_Alt_Node; 1454 end P_Case_Statement_Alternative; 1455 1456 ------------------------- 1457 -- 5.5 Loop Statement -- 1458 ------------------------- 1459 1460 -- LOOP_STATEMENT ::= 1461 -- [LOOP_STATEMENT_IDENTIFIER:] 1462 -- [ITERATION_SCHEME] loop 1463 -- SEQUENCE_OF_STATEMENTS 1464 -- end loop [loop_IDENTIFIER]; 1465 1466 -- ITERATION_SCHEME ::= 1467 -- while CONDITION 1468 -- | for LOOP_PARAMETER_SPECIFICATION 1469 1470 -- The parsing of loop statements is handled by one of three functions 1471 -- P_Loop_Statement, P_For_Statement or P_While_Statement depending 1472 -- on the initial keyword in the construct (excluding the identifier) 1473 1474 -- P_Loop_Statement 1475 1476 -- This function parses the case where no iteration scheme is present 1477 1478 -- The caller has checked that the initial token is LOOP. The parameter 1479 -- is the node identifiers for the loop label if any (or is set to Empty 1480 -- if there is no loop label). 1481 1482 -- Error recovery : cannot raise Error_Resync 1483 1484 function P_Loop_Statement (Loop_Name : Node_Id := Empty) return Node_Id is 1485 Loop_Node : Node_Id; 1486 Created_Name : Node_Id; 1487 1488 begin 1489 Push_Scope_Stack; 1490 Scopes (Scope.Last).Labl := Loop_Name; 1491 Scopes (Scope.Last).Ecol := Start_Column; 1492 Scopes (Scope.Last).Sloc := Token_Ptr; 1493 Scopes (Scope.Last).Etyp := E_Loop; 1494 1495 Loop_Node := New_Node (N_Loop_Statement, Token_Ptr); 1496 TF_Loop; 1497 1498 if No (Loop_Name) then 1499 Created_Name := 1500 Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L')); 1501 Set_Comes_From_Source (Created_Name, False); 1502 Set_Has_Created_Identifier (Loop_Node, True); 1503 Set_Identifier (Loop_Node, Created_Name); 1504 Scopes (Scope.Last).Labl := Created_Name; 1505 else 1506 Set_Identifier (Loop_Node, Loop_Name); 1507 end if; 1508 1509 Append_Elmt (Loop_Node, Label_List); 1510 Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq)); 1511 End_Statements (Loop_Node); 1512 return Loop_Node; 1513 end P_Loop_Statement; 1514 1515 -- P_For_Statement 1516 1517 -- This function parses a loop statement with a FOR iteration scheme 1518 1519 -- The caller has checked that the initial token is FOR. The parameter 1520 -- is the node identifier for the block label if any (or is set to Empty 1521 -- if there is no block label). 1522 1523 -- Note: the caller fills in the Identifier field if a label was present 1524 1525 -- Error recovery: can raise Error_Resync 1526 1527 function P_For_Statement (Loop_Name : Node_Id := Empty) return Node_Id is 1528 Loop_Node : Node_Id; 1529 Iter_Scheme_Node : Node_Id; 1530 Loop_For_Flag : Boolean; 1531 Created_Name : Node_Id; 1532 Spec : Node_Id; 1533 1534 begin 1535 Push_Scope_Stack; 1536 Scopes (Scope.Last).Labl := Loop_Name; 1537 Scopes (Scope.Last).Ecol := Start_Column; 1538 Scopes (Scope.Last).Sloc := Token_Ptr; 1539 Scopes (Scope.Last).Etyp := E_Loop; 1540 1541 Loop_For_Flag := (Prev_Token = Tok_Loop); 1542 Scan; -- past FOR 1543 Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr); 1544 Spec := P_Loop_Parameter_Specification; 1545 1546 if Nkind (Spec) = N_Loop_Parameter_Specification then 1547 Set_Loop_Parameter_Specification (Iter_Scheme_Node, Spec); 1548 else 1549 Set_Iterator_Specification (Iter_Scheme_Node, Spec); 1550 end if; 1551 1552 -- The following is a special test so that a miswritten for loop such 1553 -- as "loop for I in 1..10;" is handled nicely, without making an extra 1554 -- entry in the scope stack. We don't bother to actually fix up the 1555 -- tree in this case since it's not worth the effort. Instead we just 1556 -- eat up the loop junk, leaving the entry for what now looks like an 1557 -- unmodified loop intact. 1558 1559 if Loop_For_Flag and then Token = Tok_Semicolon then 1560 Error_Msg_SC ("LOOP belongs here, not before FOR"); 1561 Pop_Scope_Stack; 1562 return Error; 1563 1564 -- Normal case 1565 1566 else 1567 Loop_Node := New_Node (N_Loop_Statement, Token_Ptr); 1568 1569 if No (Loop_Name) then 1570 Created_Name := 1571 Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L')); 1572 Set_Comes_From_Source (Created_Name, False); 1573 Set_Has_Created_Identifier (Loop_Node, True); 1574 Set_Identifier (Loop_Node, Created_Name); 1575 Scopes (Scope.Last).Labl := Created_Name; 1576 else 1577 Set_Identifier (Loop_Node, Loop_Name); 1578 end if; 1579 1580 TF_Loop; 1581 Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq)); 1582 End_Statements (Loop_Node); 1583 Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node); 1584 Append_Elmt (Loop_Node, Label_List); 1585 return Loop_Node; 1586 end if; 1587 end P_For_Statement; 1588 1589 -- P_While_Statement 1590 1591 -- This procedure scans a loop statement with a WHILE iteration scheme 1592 1593 -- The caller has checked that the initial token is WHILE. The parameter 1594 -- is the node identifier for the block label if any (or is set to Empty 1595 -- if there is no block label). 1596 1597 -- Error recovery: cannot raise Error_Resync 1598 1599 function P_While_Statement (Loop_Name : Node_Id := Empty) return Node_Id is 1600 Loop_Node : Node_Id; 1601 Iter_Scheme_Node : Node_Id; 1602 Loop_While_Flag : Boolean; 1603 Created_Name : Node_Id; 1604 1605 begin 1606 Push_Scope_Stack; 1607 Scopes (Scope.Last).Labl := Loop_Name; 1608 Scopes (Scope.Last).Ecol := Start_Column; 1609 Scopes (Scope.Last).Sloc := Token_Ptr; 1610 Scopes (Scope.Last).Etyp := E_Loop; 1611 1612 Loop_While_Flag := (Prev_Token = Tok_Loop); 1613 Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr); 1614 Scan; -- past WHILE 1615 Set_Condition (Iter_Scheme_Node, P_Condition); 1616 1617 -- The following is a special test so that a miswritten for loop such 1618 -- as "loop while I > 10;" is handled nicely, without making an extra 1619 -- entry in the scope stack. We don't bother to actually fix up the 1620 -- tree in this case since it's not worth the effort. Instead we just 1621 -- eat up the loop junk, leaving the entry for what now looks like an 1622 -- unmodified loop intact. 1623 1624 if Loop_While_Flag and then Token = Tok_Semicolon then 1625 Error_Msg_SC ("LOOP belongs here, not before WHILE"); 1626 Pop_Scope_Stack; 1627 return Error; 1628 1629 -- Normal case 1630 1631 else 1632 Loop_Node := New_Node (N_Loop_Statement, Token_Ptr); 1633 TF_Loop; 1634 1635 if No (Loop_Name) then 1636 Created_Name := 1637 Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L')); 1638 Set_Comes_From_Source (Created_Name, False); 1639 Set_Has_Created_Identifier (Loop_Node, True); 1640 Set_Identifier (Loop_Node, Created_Name); 1641 Scopes (Scope.Last).Labl := Created_Name; 1642 else 1643 Set_Identifier (Loop_Node, Loop_Name); 1644 end if; 1645 1646 Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq)); 1647 End_Statements (Loop_Node); 1648 Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node); 1649 Append_Elmt (Loop_Node, Label_List); 1650 return Loop_Node; 1651 end if; 1652 end P_While_Statement; 1653 1654 --------------------------------------- 1655 -- 5.5 Loop Parameter Specification -- 1656 --------------------------------------- 1657 1658 -- LOOP_PARAMETER_SPECIFICATION ::= 1659 -- DEFINING_IDENTIFIER in [reverse] DISCRETE_SUBTYPE_DEFINITION 1660 -- [Iterator_Filter] 1661 1662 -- Error recovery: cannot raise Error_Resync 1663 1664 function P_Loop_Parameter_Specification return Node_Id is 1665 Loop_Param_Specification_Node : Node_Id; 1666 1667 ID_Node : Node_Id; 1668 Scan_State : Saved_Scan_State; 1669 1670 begin 1671 1672 Save_Scan_State (Scan_State); 1673 ID_Node := P_Defining_Identifier (C_In); 1674 1675 -- If the next token is OF, it indicates an Ada 2012 iterator. If the 1676 -- next token is a colon, this is also an Ada 2012 iterator, including 1677 -- a subtype indication for the loop parameter. Otherwise we parse the 1678 -- construct as a loop parameter specification. Note that the form 1679 -- "for A in B" is ambiguous, and must be resolved semantically: if B 1680 -- is a discrete subtype this is a loop specification, but if it is an 1681 -- expression it is an iterator specification. Ambiguity is resolved 1682 -- during analysis of the loop parameter specification. 1683 1684 if Token = Tok_Of or else Token = Tok_Colon then 1685 Error_Msg_Ada_2012_Feature ("iterator", Token_Ptr); 1686 return P_Iterator_Specification (ID_Node); 1687 end if; 1688 1689 -- The span of the Loop_Parameter_Specification starts at the 1690 -- defining identifier. 1691 1692 Loop_Param_Specification_Node := 1693 New_Node (N_Loop_Parameter_Specification, Sloc (ID_Node)); 1694 Set_Defining_Identifier (Loop_Param_Specification_Node, ID_Node); 1695 1696 if Token = Tok_Left_Paren then 1697 Error_Msg_SC ("subscripted loop parameter not allowed"); 1698 Restore_Scan_State (Scan_State); 1699 Discard_Junk_Node (P_Name); 1700 1701 elsif Token = Tok_Dot then 1702 Error_Msg_SC ("selected loop parameter not allowed"); 1703 Restore_Scan_State (Scan_State); 1704 Discard_Junk_Node (P_Name); 1705 end if; 1706 1707 T_In; 1708 1709 if Token = Tok_Reverse then 1710 Scan; -- past REVERSE 1711 Set_Reverse_Present (Loop_Param_Specification_Node, True); 1712 end if; 1713 1714 Set_Discrete_Subtype_Definition 1715 (Loop_Param_Specification_Node, P_Discrete_Subtype_Definition); 1716 1717 if Token = Tok_When then 1718 Error_Msg_Ada_2020_Feature ("iterator filter", Token_Ptr); 1719 1720 Scan; -- past WHEN 1721 Set_Iterator_Filter 1722 (Loop_Param_Specification_Node, P_Condition); 1723 end if; 1724 1725 return Loop_Param_Specification_Node; 1726 1727 exception 1728 when Error_Resync => 1729 return Error; 1730 end P_Loop_Parameter_Specification; 1731 1732 ---------------------------------- 1733 -- 5.5.1 Iterator_Specification -- 1734 ---------------------------------- 1735 1736 function P_Iterator_Specification (Def_Id : Node_Id) return Node_Id is 1737 Node1 : Node_Id; 1738 1739 begin 1740 Node1 := New_Node (N_Iterator_Specification, Sloc (Def_Id)); 1741 Set_Defining_Identifier (Node1, Def_Id); 1742 1743 if Token = Tok_Colon then 1744 Scan; -- past : 1745 Set_Subtype_Indication (Node1, P_Subtype_Indication); 1746 end if; 1747 1748 if Token = Tok_Of then 1749 Set_Of_Present (Node1); 1750 Scan; -- past OF 1751 1752 elsif Token = Tok_In then 1753 Scan; -- past IN 1754 1755 elsif Prev_Token = Tok_In 1756 and then Present (Subtype_Indication (Node1)) 1757 then 1758 -- Simplest recovery is to transform it into an element iterator. 1759 -- Error message on 'in" has already been emitted when parsing the 1760 -- optional constraint. 1761 1762 Set_Of_Present (Node1); 1763 Error_Msg_N 1764 ("subtype indication is only legal on an element iterator", 1765 Subtype_Indication (Node1)); 1766 1767 else 1768 return Error; 1769 end if; 1770 1771 if Token = Tok_Reverse then 1772 Scan; -- past REVERSE 1773 Set_Reverse_Present (Node1, True); 1774 end if; 1775 1776 Set_Name (Node1, P_Name); 1777 1778 if Token = Tok_When then 1779 Error_Msg_Ada_2020_Feature ("iterator filter", Token_Ptr); 1780 1781 Scan; -- past WHEN 1782 Set_Iterator_Filter 1783 (Node1, P_Condition); 1784 end if; 1785 1786 return Node1; 1787 end P_Iterator_Specification; 1788 1789 -------------------------- 1790 -- 5.6 Block Statement -- 1791 -------------------------- 1792 1793 -- BLOCK_STATEMENT ::= 1794 -- [block_STATEMENT_IDENTIFIER:] 1795 -- [declare 1796 -- DECLARATIVE_PART] 1797 -- begin 1798 -- HANDLED_SEQUENCE_OF_STATEMENTS 1799 -- end [block_IDENTIFIER]; 1800 1801 -- The parsing of block statements is handled by one of the two functions 1802 -- P_Declare_Statement or P_Begin_Statement depending on whether or not 1803 -- a declare section is present 1804 1805 -- P_Declare_Statement 1806 1807 -- This function parses a block statement with DECLARE present 1808 1809 -- The caller has checked that the initial token is DECLARE 1810 1811 -- Error recovery: cannot raise Error_Resync 1812 1813 function P_Declare_Statement 1814 (Block_Name : Node_Id := Empty) 1815 return Node_Id 1816 is 1817 Block_Node : Node_Id; 1818 Created_Name : Node_Id; 1819 1820 begin 1821 Block_Node := New_Node (N_Block_Statement, Token_Ptr); 1822 1823 Push_Scope_Stack; 1824 Scopes (Scope.Last).Etyp := E_Name; 1825 Scopes (Scope.Last).Lreq := Present (Block_Name); 1826 Scopes (Scope.Last).Ecol := Start_Column; 1827 Scopes (Scope.Last).Labl := Block_Name; 1828 Scopes (Scope.Last).Sloc := Token_Ptr; 1829 1830 Scan; -- past DECLARE 1831 1832 if No (Block_Name) then 1833 Created_Name := 1834 Make_Identifier (Sloc (Block_Node), Set_Loop_Block_Name ('B')); 1835 Set_Comes_From_Source (Created_Name, False); 1836 Set_Has_Created_Identifier (Block_Node, True); 1837 Set_Identifier (Block_Node, Created_Name); 1838 Scopes (Scope.Last).Labl := Created_Name; 1839 else 1840 Set_Identifier (Block_Node, Block_Name); 1841 end if; 1842 1843 Append_Elmt (Block_Node, Label_List); 1844 Parse_Decls_Begin_End (Block_Node); 1845 return Block_Node; 1846 end P_Declare_Statement; 1847 1848 -- P_Begin_Statement 1849 1850 -- This function parses a block statement with no DECLARE present 1851 1852 -- The caller has checked that the initial token is BEGIN 1853 1854 -- Error recovery: cannot raise Error_Resync 1855 1856 function P_Begin_Statement 1857 (Block_Name : Node_Id := Empty) 1858 return Node_Id 1859 is 1860 Block_Node : Node_Id; 1861 Created_Name : Node_Id; 1862 1863 begin 1864 Block_Node := New_Node (N_Block_Statement, Token_Ptr); 1865 1866 Push_Scope_Stack; 1867 Scopes (Scope.Last).Etyp := E_Name; 1868 Scopes (Scope.Last).Lreq := Present (Block_Name); 1869 Scopes (Scope.Last).Ecol := Start_Column; 1870 Scopes (Scope.Last).Labl := Block_Name; 1871 Scopes (Scope.Last).Sloc := Token_Ptr; 1872 1873 if No (Block_Name) then 1874 Created_Name := 1875 Make_Identifier (Sloc (Block_Node), Set_Loop_Block_Name ('B')); 1876 Set_Comes_From_Source (Created_Name, False); 1877 Set_Has_Created_Identifier (Block_Node, True); 1878 Set_Identifier (Block_Node, Created_Name); 1879 Scopes (Scope.Last).Labl := Created_Name; 1880 else 1881 Set_Identifier (Block_Node, Block_Name); 1882 end if; 1883 1884 Append_Elmt (Block_Node, Label_List); 1885 1886 Scopes (Scope.Last).Ecol := Start_Column; 1887 Scopes (Scope.Last).Sloc := Token_Ptr; 1888 Scan; -- past BEGIN 1889 Set_Handled_Statement_Sequence 1890 (Block_Node, P_Handled_Sequence_Of_Statements); 1891 End_Statements (Handled_Statement_Sequence (Block_Node)); 1892 return Block_Node; 1893 end P_Begin_Statement; 1894 1895 ------------------------- 1896 -- 5.7 Exit Statement -- 1897 ------------------------- 1898 1899 -- EXIT_STATEMENT ::= 1900 -- exit [loop_NAME] [when CONDITION]; 1901 1902 -- The caller has checked that the initial token is EXIT 1903 1904 -- Error recovery: can raise Error_Resync 1905 1906 function P_Exit_Statement return Node_Id is 1907 Exit_Node : Node_Id; 1908 1909 function Missing_Semicolon_On_Exit return Boolean; 1910 -- This function deals with the following specialized situation 1911 -- 1912 -- when 'x' => 1913 -- exit [identifier] 1914 -- when 'y' => 1915 -- 1916 -- This looks like a messed up EXIT WHEN, when in fact the problem 1917 -- is a missing semicolon. It is called with Token pointing to the 1918 -- WHEN token, and returns True if a semicolon is missing before 1919 -- the WHEN as in the above example. 1920 1921 ------------------------------- 1922 -- Missing_Semicolon_On_Exit -- 1923 ------------------------------- 1924 1925 function Missing_Semicolon_On_Exit return Boolean is 1926 State : Saved_Scan_State; 1927 1928 begin 1929 if not Token_Is_At_Start_Of_Line then 1930 return False; 1931 1932 elsif Scopes (Scope.Last).Etyp /= E_Case then 1933 return False; 1934 1935 else 1936 Save_Scan_State (State); 1937 Scan; -- past WHEN 1938 Scan; -- past token after WHEN 1939 1940 if Token = Tok_Arrow then 1941 Restore_Scan_State (State); 1942 return True; 1943 else 1944 Restore_Scan_State (State); 1945 return False; 1946 end if; 1947 end if; 1948 end Missing_Semicolon_On_Exit; 1949 1950 -- Start of processing for P_Exit_Statement 1951 1952 begin 1953 Exit_Node := New_Node (N_Exit_Statement, Token_Ptr); 1954 Scan; -- past EXIT 1955 1956 if Token = Tok_Identifier then 1957 Set_Name (Exit_Node, P_Qualified_Simple_Name); 1958 1959 elsif Style_Check then 1960 -- This EXIT has no name, so check that 1961 -- the innermost loop is unnamed too. 1962 1963 Check_No_Exit_Name : 1964 for J in reverse 1 .. Scope.Last loop 1965 if Scopes (J).Etyp = E_Loop then 1966 if Present (Scopes (J).Labl) 1967 and then Comes_From_Source (Scopes (J).Labl) 1968 then 1969 -- Innermost loop in fact had a name, style check fails 1970 1971 Style.No_Exit_Name (Scopes (J).Labl); 1972 end if; 1973 1974 exit Check_No_Exit_Name; 1975 end if; 1976 end loop Check_No_Exit_Name; 1977 end if; 1978 1979 if Token = Tok_When and then not Missing_Semicolon_On_Exit then 1980 Scan; -- past WHEN 1981 Set_Condition (Exit_Node, P_Condition); 1982 1983 -- Allow IF instead of WHEN, giving error message 1984 1985 elsif Token = Tok_If then 1986 T_When; 1987 Scan; -- past IF used in place of WHEN 1988 Set_Condition (Exit_Node, P_Expression_No_Right_Paren); 1989 end if; 1990 1991 TF_Semicolon; 1992 return Exit_Node; 1993 end P_Exit_Statement; 1994 1995 ------------------------- 1996 -- 5.8 Goto Statement -- 1997 ------------------------- 1998 1999 -- GOTO_STATEMENT ::= goto label_NAME; 2000 2001 -- The caller has checked that the initial token is GOTO (or TO in the 2002 -- error case where GO and TO were incorrectly separated). 2003 2004 -- Error recovery: can raise Error_Resync 2005 2006 function P_Goto_Statement return Node_Id is 2007 Goto_Node : Node_Id; 2008 2009 begin 2010 Goto_Node := New_Node (N_Goto_Statement, Token_Ptr); 2011 Scan; -- past GOTO (or TO) 2012 Set_Name (Goto_Node, P_Qualified_Simple_Name_Resync); 2013 Append_Elmt (Goto_Node, Goto_List); 2014 No_Constraint; 2015 TF_Semicolon; 2016 return Goto_Node; 2017 end P_Goto_Statement; 2018 2019 --------------------------- 2020 -- Parse_Decls_Begin_End -- 2021 --------------------------- 2022 2023 -- This function parses the construct: 2024 2025 -- DECLARATIVE_PART 2026 -- begin 2027 -- HANDLED_SEQUENCE_OF_STATEMENTS 2028 -- end [NAME]; 2029 2030 -- The caller has built the scope stack entry, and created the node to 2031 -- whose Declarations and Handled_Statement_Sequence fields are to be 2032 -- set. On return these fields are filled in (except in the case of a 2033 -- task body, where the handled statement sequence is optional, and may 2034 -- thus be Empty), and the scan is positioned past the End sequence. 2035 2036 -- If the BEGIN is missing, then the parent node is used to help construct 2037 -- an appropriate missing BEGIN message. Possibilities for the parent are: 2038 2039 -- N_Block_Statement declare block 2040 -- N_Entry_Body entry body 2041 -- N_Package_Body package body (begin part optional) 2042 -- N_Subprogram_Body procedure or function body 2043 -- N_Task_Body task body 2044 2045 -- Note: in the case of a block statement, there is definitely a DECLARE 2046 -- present (because a Begin statement without a DECLARE is handled by the 2047 -- P_Begin_Statement procedure, which does not call Parse_Decls_Begin_End. 2048 2049 -- Error recovery: cannot raise Error_Resync 2050 2051 procedure Parse_Decls_Begin_End (Parent : Node_Id) is 2052 Body_Decl : Node_Id; 2053 Decls : List_Id; 2054 Parent_Nkind : Node_Kind; 2055 Spec_Node : Node_Id; 2056 HSS : Node_Id; 2057 2058 procedure Missing_Begin (Msg : String); 2059 -- Called to post a missing begin message. In the normal case this is 2060 -- posted at the start of the current token. A special case arises when 2061 -- P_Declarative_Items has previously found a missing begin, in which 2062 -- case we replace the original error message. 2063 2064 procedure Set_Null_HSS (Parent : Node_Id); 2065 -- Construct an empty handled statement sequence and install in Parent 2066 -- Leaves HSS set to reference the newly constructed statement sequence. 2067 2068 ------------------- 2069 -- Missing_Begin -- 2070 ------------------- 2071 2072 procedure Missing_Begin (Msg : String) is 2073 begin 2074 if Missing_Begin_Msg = No_Error_Msg then 2075 Error_Msg_BC (Msg); 2076 else 2077 Change_Error_Text (Missing_Begin_Msg, Msg); 2078 2079 -- Purge any messages issued after than, since a missing begin 2080 -- can cause a lot of havoc, and it is better not to dump these 2081 -- cascaded messages on the user. 2082 2083 Purge_Messages (Get_Location (Missing_Begin_Msg), Prev_Token_Ptr); 2084 end if; 2085 end Missing_Begin; 2086 2087 ------------------ 2088 -- Set_Null_HSS -- 2089 ------------------ 2090 2091 procedure Set_Null_HSS (Parent : Node_Id) is 2092 Null_Stm : Node_Id; 2093 2094 begin 2095 Null_Stm := 2096 Make_Null_Statement (Token_Ptr); 2097 Set_Comes_From_Source (Null_Stm, False); 2098 2099 HSS := 2100 Make_Handled_Sequence_Of_Statements (Token_Ptr, 2101 Statements => New_List (Null_Stm)); 2102 Set_Comes_From_Source (HSS, False); 2103 2104 Set_Handled_Statement_Sequence (Parent, HSS); 2105 end Set_Null_HSS; 2106 2107 -- Start of processing for Parse_Decls_Begin_End 2108 2109 begin 2110 Decls := P_Declarative_Part; 2111 2112 if Ada_Version = Ada_83 then 2113 Check_Later_Vs_Basic_Declarations (Decls, During_Parsing => True); 2114 end if; 2115 2116 -- Here is where we deal with the case of IS used instead of semicolon. 2117 -- Specifically, if the last declaration in the declarative part is a 2118 -- subprogram body still marked as having a bad IS, then this is where 2119 -- we decide that the IS should really have been a semicolon and that 2120 -- the body should have been a declaration. Note that if the bad IS 2121 -- had turned out to be OK (i.e. a decent begin/end was found for it), 2122 -- then the Bad_Is_Detected flag would have been reset by now. 2123 2124 Body_Decl := Last (Decls); 2125 2126 if Present (Body_Decl) 2127 and then Nkind (Body_Decl) = N_Subprogram_Body 2128 and then Bad_Is_Detected (Body_Decl) 2129 then 2130 -- OK, we have the case of a bad IS, so we need to fix up the tree. 2131 -- What we have now is a subprogram body with attached declarations 2132 -- and a possible statement sequence. 2133 2134 -- First step is to take the declarations that were part of the bogus 2135 -- subprogram body and append them to the outer declaration chain. 2136 -- In other words we append them past the body (which we will later 2137 -- convert into a declaration). 2138 2139 Append_List (Declarations (Body_Decl), Decls); 2140 2141 -- Now take the handled statement sequence of the bogus body and 2142 -- set it as the statement sequence for the outer construct. Note 2143 -- that it may be empty (we specially allowed a missing BEGIN for 2144 -- a subprogram body marked as having a bad IS -- see below). 2145 2146 Set_Handled_Statement_Sequence (Parent, 2147 Handled_Statement_Sequence (Body_Decl)); 2148 2149 -- Next step is to convert the old body node to a declaration node 2150 2151 Spec_Node := Specification (Body_Decl); 2152 Change_Node (Body_Decl, N_Subprogram_Declaration); 2153 Set_Specification (Body_Decl, Spec_Node); 2154 2155 -- Final step is to put the declarations for the parent where 2156 -- they belong, and then fall through the IF to scan out the 2157 -- END statements. 2158 2159 Set_Declarations (Parent, Decls); 2160 2161 -- This is the normal case (i.e. any case except the bad IS case) 2162 -- If we have a BEGIN, then scan out the sequence of statements, and 2163 -- also reset the expected column for the END to match the BEGIN. 2164 2165 else 2166 Set_Declarations (Parent, Decls); 2167 2168 if Token = Tok_Begin then 2169 if Style_Check then 2170 Style.Check_Indentation; 2171 end if; 2172 2173 Error_Msg_Col := Scopes (Scope.Last).Ecol; 2174 2175 if RM_Column_Check 2176 and then Token_Is_At_Start_Of_Line 2177 and then Start_Column /= Error_Msg_Col 2178 then 2179 Error_Msg_SC ("(style) BEGIN in wrong column, should be@"); 2180 2181 else 2182 Scopes (Scope.Last).Ecol := Start_Column; 2183 end if; 2184 2185 Scopes (Scope.Last).Sloc := Token_Ptr; 2186 Scan; -- past BEGIN 2187 Set_Handled_Statement_Sequence (Parent, 2188 P_Handled_Sequence_Of_Statements); 2189 2190 -- No BEGIN present 2191 2192 else 2193 Parent_Nkind := Nkind (Parent); 2194 2195 -- A special check for the missing IS case. If we have a 2196 -- subprogram body that was marked as having a suspicious 2197 -- IS, and the current token is END, then we simply confirm 2198 -- the suspicion, and do not require a BEGIN to be present 2199 2200 if Parent_Nkind = N_Subprogram_Body 2201 and then Token = Tok_End 2202 and then Scopes (Scope.Last).Etyp = E_Suspicious_Is 2203 then 2204 Scopes (Scope.Last).Etyp := E_Bad_Is; 2205 2206 -- Otherwise BEGIN is not required for a package body, so we 2207 -- don't mind if it is missing, but we do construct a dummy 2208 -- one (so that we have somewhere to set End_Label). 2209 2210 -- However if we have something other than a BEGIN which 2211 -- looks like it might be statements, then we signal a missing 2212 -- BEGIN for these cases as well. We define "something which 2213 -- looks like it might be statements" as a token other than 2214 -- END, EOF, or a token which starts declarations. 2215 2216 elsif Parent_Nkind = N_Package_Body 2217 and then (Token = Tok_End 2218 or else Token = Tok_EOF 2219 or else Token in Token_Class_Declk) 2220 then 2221 Set_Null_HSS (Parent); 2222 2223 -- These are cases in which a BEGIN is required and not present 2224 2225 else 2226 Set_Null_HSS (Parent); 2227 2228 -- Prepare to issue error message 2229 2230 Error_Msg_Sloc := Scopes (Scope.Last).Sloc; 2231 Error_Msg_Node_1 := Scopes (Scope.Last).Labl; 2232 2233 -- Now issue appropriate message 2234 2235 if Parent_Nkind = N_Block_Statement then 2236 Missing_Begin ("missing BEGIN for DECLARE#!"); 2237 2238 elsif Parent_Nkind = N_Entry_Body then 2239 Missing_Begin ("missing BEGIN for ENTRY#!"); 2240 2241 elsif Parent_Nkind = N_Subprogram_Body then 2242 if Nkind (Specification (Parent)) 2243 = N_Function_Specification 2244 then 2245 Missing_Begin ("missing BEGIN for function&#!"); 2246 else 2247 Missing_Begin ("missing BEGIN for procedure&#!"); 2248 end if; 2249 2250 -- The case for package body arises only when 2251 -- we have possible statement junk present. 2252 2253 elsif Parent_Nkind = N_Package_Body then 2254 Missing_Begin ("missing BEGIN for package body&#!"); 2255 2256 else 2257 pragma Assert (Parent_Nkind = N_Task_Body); 2258 Missing_Begin ("missing BEGIN for task body&#!"); 2259 end if; 2260 2261 -- Here we pick up the statements after the BEGIN that 2262 -- should have been present but was not. We don't insist 2263 -- on statements being present if P_Declarative_Part had 2264 -- already found a missing BEGIN, since it might have 2265 -- swallowed a lone statement into the declarative part. 2266 2267 if Missing_Begin_Msg /= No_Error_Msg 2268 and then Token = Tok_End 2269 then 2270 null; 2271 else 2272 Set_Handled_Statement_Sequence (Parent, 2273 P_Handled_Sequence_Of_Statements); 2274 end if; 2275 end if; 2276 end if; 2277 end if; 2278 2279 -- Here with declarations and handled statement sequence scanned 2280 2281 if Present (Handled_Statement_Sequence (Parent)) then 2282 End_Statements (Handled_Statement_Sequence (Parent)); 2283 else 2284 End_Statements; 2285 end if; 2286 2287 -- We know that End_Statements removed an entry from the scope stack 2288 -- (because it is required to do so under all circumstances). We can 2289 -- therefore reference the entry it removed one past the stack top. 2290 -- What we are interested in is whether it was a case of a bad IS. 2291 -- We can't call Scopes here. 2292 2293 if Scope.Table (Scope.Last + 1).Etyp = E_Bad_Is then 2294 Error_Msg -- CODEFIX 2295 ("|IS should be "";""", Scope.Table (Scope.Last + 1).S_Is); 2296 Set_Bad_Is_Detected (Parent, True); 2297 end if; 2298 2299 end Parse_Decls_Begin_End; 2300 2301 ------------------------- 2302 -- Set_Loop_Block_Name -- 2303 ------------------------- 2304 2305 function Set_Loop_Block_Name (L : Character) return Name_Id is 2306 begin 2307 Name_Buffer (1) := L; 2308 Name_Buffer (2) := '_'; 2309 Name_Len := 2; 2310 Loop_Block_Count := Loop_Block_Count + 1; 2311 Add_Nat_To_Name_Buffer (Loop_Block_Count); 2312 return Name_Find; 2313 end Set_Loop_Block_Name; 2314 2315 --------------- 2316 -- Then_Scan -- 2317 --------------- 2318 2319 procedure Then_Scan is 2320 begin 2321 TF_Then; 2322 2323 while Token = Tok_Then loop 2324 Error_Msg_SC -- CODEFIX 2325 ("redundant THEN"); 2326 TF_Then; 2327 end loop; 2328 2329 if Token = Tok_And or else Token = Tok_Or then 2330 Error_Msg_SC ("unexpected logical operator"); 2331 Scan; -- past logical operator 2332 2333 if (Prev_Token = Tok_And and then Token = Tok_Then) 2334 or else 2335 (Prev_Token = Tok_Or and then Token = Tok_Else) 2336 then 2337 Scan; 2338 end if; 2339 2340 Discard_Junk_Node (P_Expression); 2341 end if; 2342 2343 if Token = Tok_Then then 2344 Scan; 2345 end if; 2346 end Then_Scan; 2347 2348end Ch5; 2349