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