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