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