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