1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- P A R . E N D H -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2019, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Namet.Sp; use Namet.Sp; 27with Stringt; use Stringt; 28with Uintp; use Uintp; 29 30with GNAT.Spelling_Checker; use GNAT.Spelling_Checker; 31 32separate (Par) 33package body Endh is 34 35 ---------------- 36 -- Local Data -- 37 ---------------- 38 39 type End_Action_Type is ( 40 -- Type used to describe the result of the Pop_End_Context call 41 42 Accept_As_Scanned, 43 -- Current end sequence is entirely c correct. In this case Token and 44 -- the scan pointer are left pointing past the end sequence (i.e. they 45 -- are unchanged from the values set on entry to Pop_End_Context). 46 47 Insert_And_Accept, 48 -- Current end sequence is to be left in place to satisfy some outer 49 -- scope. Token and the scan pointer are set to point to the end 50 -- token, and should be left there. A message has been generated 51 -- indicating a missing end sequence. This status is also used for 52 -- the case when no end token is present. 53 54 Skip_And_Accept, 55 -- The end sequence is incorrect (and an error message has been 56 -- posted), but it will still be accepted. In this case Token and 57 -- the scan pointer point back to the end token, and the caller 58 -- should skip past the end sequence before proceeding. 59 60 Skip_And_Reject); 61 -- The end sequence is judged to belong to an unrecognized inner 62 -- scope. An appropriate message has been issued and the caller 63 -- should skip past the end sequence and then proceed as though 64 -- no end sequence had been encountered. 65 66 End_Action : End_Action_Type; 67 -- The variable set by Pop_End_Context call showing which of the four 68 -- decisions described above is judged the best. 69 70 End_Sloc : Source_Ptr; 71 -- Source location of END token 72 73 End_OK : Boolean; 74 -- Set False if error is found in END line 75 76 End_Column : Column_Number; 77 -- Column of END line 78 79 End_Type : SS_End_Type; 80 -- Type of END expected. The special value E_Dummy is set to indicate that 81 -- no END token was present (so a missing END inserted message is needed) 82 83 End_Labl : Node_Id; 84 -- Node_Id value for explicit name on END line, or for compiler supplied 85 -- name in the case where an optional name is not given. Empty if no name 86 -- appears. If non-empty, then it is either an N_Designator node for a 87 -- child unit or a node with a Chars field identifying the actual label. 88 89 End_Labl_Present : Boolean; 90 -- Indicates that the value in End_Labl was for an explicit label 91 92 Syntax_OK : Boolean; 93 -- Set True if the entry is syntactically correct 94 95 Token_OK : Boolean; 96 -- Set True if the keyword in the END sequence matches, or if neither 97 -- the END sequence nor the END stack entry has a keyword. 98 99 Label_OK : Boolean; 100 -- Set True if both the END sequence and the END stack entry contained 101 -- labels (other than No_Name or Error_Name) and the labels matched. 102 -- This is a stronger condition than SYNTAX_OK, since it means that a 103 -- label was present, even in a case where it was optional. Note that 104 -- the case of no label required, and no label present does NOT set 105 -- Label_OK to True, it is True only if a positive label match is found. 106 107 Column_OK : Boolean; 108 -- Column_OK is set True if the END sequence appears in the expected column 109 110 Scan_State : Saved_Scan_State; 111 -- Save state at start of END sequence, in case we decide not to eat it up 112 113 ----------------------- 114 -- Local Subprograms -- 115 ----------------------- 116 117 procedure Evaluate_End_Entry (SS_Index : Nat); 118 -- Compare scanned END entry (as recorded by a prior call to P_End_Scan) 119 -- with a specified entry in the scope stack (the single parameter is the 120 -- entry index in the scope stack). Note that Scan is not called. The above 121 -- variables xxx_OK are set to indicate the result of the evaluation. 122 123 function Explicit_Start_Label (SS_Index : Nat) return Boolean; 124 -- Determines whether the specified entry in the scope stack has an 125 -- explicit start label (i.e. one other than one that was created by 126 -- the parser when no explicit label was present). 127 128 procedure Output_End_Deleted; 129 -- Output a message complaining that the current END structure does not 130 -- match anything and is being deleted. 131 132 procedure Output_End_Expected (Ins : Boolean); 133 -- Output a message at the start of the current token which is always an 134 -- END, complaining that the END is not of the right form. The message 135 -- indicates the expected form. The information for the message is taken 136 -- from the top entry in the scope stack. The Ins parameter is True if 137 -- an end is being inserted, and false if an existing end is being 138 -- replaced. Note that in the case of a suspicious IS for the Ins case, 139 -- we do not output the message, but instead simply mark the scope stack 140 -- entry as being a case of a bad IS. 141 142 procedure Output_End_Missing; 143 -- Output a message just before the current token, complaining that the 144 -- END is not of the right form. The message indicates the expected form. 145 -- The information for the message is taken from the top entry in the 146 -- scope stack. Note that in the case of a suspicious IS, we do not output 147 -- the message, but instead simply mark the scope stack entry as a bad IS. 148 149 procedure Pop_End_Context; 150 -- Pop_End_Context is called after processing a construct, to pop the 151 -- top entry off the end stack. It decides on the appropriate action to 152 -- to take, signalling the result by setting End_Action as described in 153 -- the global variable section. 154 155 function Same_Label (Label1, Label2 : Node_Id) return Boolean; 156 -- This function compares the two names associated with the given nodes. 157 -- If they are both simple (i.e. have Chars fields), then they have to 158 -- be the same name. Otherwise they must both be N_Selected_Component 159 -- nodes, referring to the same set of names, or Label1 is an N_Designator 160 -- referring to the same set of names as the N_Defining_Program_Unit_Name 161 -- in Label2. Any other combination returns False. This routine is used 162 -- to compare the End_Labl scanned from the End line with the saved label 163 -- value in the scope stack. 164 165 --------------- 166 -- Check_End -- 167 --------------- 168 169 function Check_End 170 (Decl : Node_Id := Empty; 171 Is_Loc : Source_Ptr := No_Location) return Boolean 172 is 173 Name_On_Separate_Line : Boolean; 174 -- Set True if the name on an END line is on a separate source line 175 -- from the END. This is highly suspicious, but is allowed. The point 176 -- is that we want to make sure that we don't just have a missing 177 -- semicolon misleading us into swallowing an identifier from the 178 -- following line. 179 180 Name_Scan_State : Saved_Scan_State; 181 -- Save state at start of name if Name_On_Separate_Line is TRUE 182 183 Span_Node : constant Node_Id := Scope.Table (Scope.Last).Node; 184 185 begin 186 End_Labl_Present := False; 187 End_Labl := Empty; 188 189 -- Our first task is to scan out the END sequence if one is present. 190 -- If none is present, signal by setting End_Type to E_Dummy. 191 192 if Token /= Tok_End then 193 End_Type := E_Dummy; 194 195 else 196 Save_Scan_State (Scan_State); -- at END 197 End_Sloc := Token_Ptr; 198 End_Column := Start_Column; 199 End_OK := True; 200 Scan; -- past END 201 202 -- Set End_Span if expected. Note that this will be useless 203 -- if we do not have the right ending keyword, but in this 204 -- case we have a malformed program anyway, and the setting 205 -- of End_Span will simply be unreliable in this case anyway. 206 207 if Present (Span_Node) then 208 Set_End_Location (Span_Node, Token_Ptr); 209 end if; 210 211 -- Cases of keywords where no label is allowed 212 213 if Token = Tok_Case then 214 End_Type := E_Case; 215 Scan; -- past CASE 216 217 elsif Token = Tok_If then 218 End_Type := E_If; 219 Scan; -- past IF 220 221 elsif Token = Tok_Record then 222 End_Type := E_Record; 223 Scan; -- past RECORD 224 225 elsif Token = Tok_Return then 226 End_Type := E_Return; 227 Scan; -- past RETURN 228 229 elsif Token = Tok_Select then 230 End_Type := E_Select; 231 Scan; -- past SELECT 232 233 -- Cases which do allow labels 234 235 else 236 -- LOOP 237 238 if Token = Tok_Loop then 239 Scan; -- past LOOP 240 End_Type := E_Loop; 241 242 -- FOR or WHILE allowed (signalling error) to substitute for LOOP 243 -- if on the same line as the END. 244 245 elsif (Token = Tok_For or else Token = Tok_While) 246 and then not Token_Is_At_Start_Of_Line 247 then 248 Scan; -- past FOR or WHILE 249 End_Type := E_Loop; 250 End_OK := False; 251 252 -- Cases with no keyword 253 254 else 255 End_Type := E_Name; 256 end if; 257 258 -- Now see if a name is present 259 260 if Token = Tok_Identifier or else 261 Token = Tok_String_Literal or else 262 Token = Tok_Operator_Symbol 263 then 264 if Token_Is_At_Start_Of_Line then 265 Name_On_Separate_Line := True; 266 Save_Scan_State (Name_Scan_State); 267 else 268 Name_On_Separate_Line := False; 269 end if; 270 271 End_Labl := P_Designator; 272 End_Labl_Present := True; 273 274 -- We have now scanned out a name. Here is where we do a check 275 -- to catch the cases like: 276 -- 277 -- end loop 278 -- X := 3; 279 -- 280 -- where the missing semicolon might make us swallow up the X 281 -- as a bogus end label. In a situation like this, where the 282 -- apparent name is on a separate line, we accept it only if 283 -- it matches the label and is followed by a semicolon. 284 285 if Name_On_Separate_Line then 286 if Token /= Tok_Semicolon or else 287 not Same_Label (End_Labl, Scope.Table (Scope.Last).Labl) 288 then 289 Restore_Scan_State (Name_Scan_State); 290 End_Labl := Empty; 291 End_Labl_Present := False; 292 end if; 293 end if; 294 295 -- Here for case of name allowed, but no name present. We will 296 -- supply an implicit matching name, with source location set 297 -- to the scan location past the END token. 298 299 else 300 End_Labl := Scope.Table (Scope.Last).Labl; 301 302 if End_Labl > Empty_Or_Error then 303 304 -- The task here is to construct a designator from the 305 -- opening label, with the components all marked as not 306 -- from source, and Is_End_Label set in the identifier 307 -- or operator symbol. The location for all components 308 -- is the current token location. 309 310 -- Case of child unit name 311 312 if Nkind (End_Labl) = N_Defining_Program_Unit_Name then 313 Child_End : declare 314 Eref : constant Node_Id := 315 Make_Identifier (Token_Ptr, 316 Chars => 317 Chars (Defining_Identifier (End_Labl))); 318 319 function Copy_Name (N : Node_Id) return Node_Id; 320 -- Copies a selected component or identifier 321 322 --------------- 323 -- Copy_Name -- 324 --------------- 325 326 function Copy_Name (N : Node_Id) return Node_Id is 327 R : Node_Id; 328 329 begin 330 if Nkind (N) = N_Selected_Component then 331 return 332 Make_Selected_Component (Token_Ptr, 333 Prefix => 334 Copy_Name (Prefix (N)), 335 Selector_Name => 336 Copy_Name (Selector_Name (N))); 337 338 else 339 R := Make_Identifier (Token_Ptr, Chars (N)); 340 Set_Comes_From_Source (N, False); 341 return R; 342 end if; 343 end Copy_Name; 344 345 -- Start of processing for Child_End 346 347 begin 348 Set_Comes_From_Source (Eref, False); 349 350 End_Labl := 351 Make_Designator (Token_Ptr, 352 Name => Copy_Name (Name (End_Labl)), 353 Identifier => Eref); 354 end Child_End; 355 356 -- Simple identifier case 357 358 elsif Nkind (End_Labl) = N_Defining_Identifier 359 or else Nkind (End_Labl) = N_Identifier 360 then 361 End_Labl := Make_Identifier (Token_Ptr, Chars (End_Labl)); 362 363 elsif Nkind (End_Labl) = N_Defining_Operator_Symbol 364 or else Nkind (End_Labl) = N_Operator_Symbol 365 then 366 Get_Decoded_Name_String (Chars (End_Labl)); 367 368 End_Labl := 369 Make_Operator_Symbol (Token_Ptr, 370 Chars => Chars (End_Labl), 371 Strval => String_From_Name_Buffer); 372 end if; 373 374 Set_Comes_From_Source (End_Labl, False); 375 End_Labl_Present := False; 376 377 -- Do style check for label permitted but not present. Note: 378 -- for the case of a block statement, the label is required 379 -- to be repeated, and this legality rule is enforced 380 -- independently. 381 382 if Style_Check 383 and then End_Type = E_Name 384 and then Explicit_Start_Label (Scope.Last) 385 and then Nkind (Parent (Scope.Table (Scope.Last).Labl)) 386 /= N_Block_Statement 387 then 388 Style.No_End_Name (Scope.Table (Scope.Last).Labl); 389 end if; 390 end if; 391 end if; 392 end if; 393 394 -- Deal with terminating aspect specifications and following semi- 395 -- colon. We skip this in the case of END RECORD, since in this 396 -- case the aspect specifications and semicolon are handled at 397 -- a higher level. 398 399 if End_Type /= E_Record then 400 401 -- Scan aspect specifications 402 403 if Aspect_Specifications_Present then 404 405 -- Aspect specifications not allowed 406 407 if No (Decl) then 408 409 -- Package declaration case 410 411 if Is_Loc /= No_Location then 412 Error_Msg_SC 413 ("misplaced aspects for package declaration"); 414 Error_Msg 415 ("info: aspect specifications belong here??", Is_Loc); 416 P_Aspect_Specifications (Empty); 417 418 -- Other cases where aspect specifications are not allowed 419 420 else 421 P_Aspect_Specifications (Error); 422 end if; 423 424 -- Aspect specifications allowed 425 426 else 427 P_Aspect_Specifications (Decl); 428 end if; 429 430 -- If no aspect specifications, must have a semicolon 431 432 elsif End_Type /= E_Record then 433 if Token = Tok_Semicolon then 434 T_Semicolon; 435 436 -- Semicolon is missing. If the missing semicolon is at the end 437 -- of the line, i.e. we are at the start of the line now, then 438 -- a missing semicolon gets flagged, but is not serious enough 439 -- to consider the END statement to be bad in the sense that we 440 -- are dealing with (i.e. to be suspicious that this END is not 441 -- the END statement we are looking for). 442 443 -- Similarly, if we are at a colon, we flag it but a colon for 444 -- a semicolon is not serious enough to consider the END to be 445 -- incorrect. Same thing for a period in place of a semicolon. 446 447 elsif Token_Is_At_Start_Of_Line 448 or else Token = Tok_Colon 449 or else Token = Tok_Dot 450 then 451 T_Semicolon; 452 453 -- If the missing semicolon is not at the start of the line, 454 -- then we consider the END line to be dubious in this sense. 455 456 else 457 End_OK := False; 458 end if; 459 end if; 460 end if; 461 end if; 462 463 -- Now we call the Pop_End_Context routine to get a recommendation 464 -- as to what should be done with the END sequence we have scanned. 465 466 Pop_End_Context; 467 468 -- Remaining action depends on End_Action set by Pop_End_Context 469 470 case End_Action is 471 472 -- Accept_As_Scanned. In this case, Pop_End_Context left Token 473 -- pointing past the last token of a syntactically correct END 474 475 when Accept_As_Scanned => 476 477 -- Syntactically correct included the possibility of a missing 478 -- semicolon. If we do have a missing semicolon, then we have 479 -- already given a message, but now we scan out possible rubbish 480 -- on the same line as the END 481 482 while not Token_Is_At_Start_Of_Line 483 and then Prev_Token /= Tok_Record 484 and then Prev_Token /= Tok_Semicolon 485 and then Token /= Tok_End 486 and then Token /= Tok_EOF 487 loop 488 Scan; -- past junk 489 end loop; 490 491 return True; 492 493 -- Insert_And_Accept. In this case, Pop_End_Context has reset Token 494 -- to point to the start of the END sequence, and recommends that it 495 -- be left in place to satisfy an outer scope level END. This means 496 -- that we proceed as though an END were present, and leave the scan 497 -- pointer unchanged. 498 499 when Insert_And_Accept => 500 return True; 501 502 -- Skip_And_Accept. In this case, Pop_End_Context has reset Token 503 -- to point to the start of the END sequence. This END sequence is 504 -- syntactically incorrect, and an appropriate error message has 505 -- already been posted. Pop_End_Context recommends accepting the 506 -- END sequence as the one we want, so we skip past it and then 507 -- proceed as though an END were present. 508 509 when Skip_And_Accept => 510 End_Skip; 511 return True; 512 513 -- Skip_And_Reject. In this case, Pop_End_Context has reset Token 514 -- to point to the start of the END sequence. This END sequence is 515 -- syntactically incorrect, and an appropriate error message has 516 -- already been posted. Pop_End_Context recommends entirely ignoring 517 -- this END sequence, so we skip past it and then return False, since 518 -- as far as the caller is concerned, no END sequence is present. 519 520 when Skip_And_Reject => 521 End_Skip; 522 return False; 523 end case; 524 end Check_End; 525 526 -------------- 527 -- End Skip -- 528 -------------- 529 530 -- This procedure skips past an END sequence. On entry Token contains 531 -- Tok_End, and we know that the END sequence is syntactically incorrect, 532 -- and that an appropriate error message has already been posted. The 533 -- mission is simply to position the scan pointer to be the best guess of 534 -- the position after the END sequence. We do not issue any additional 535 -- error messages while carrying this out. 536 537 -- Error recovery: does not raise Error_Resync 538 539 procedure End_Skip is 540 begin 541 Scan; -- past END 542 543 -- If the scan past the END leaves us on the next line, that's probably 544 -- where we should quit the scan, since it is likely that what we have 545 -- is a missing semicolon. Consider the following: 546 547 -- END 548 -- Process_Input; 549 550 -- This will have looked like a syntactically valid END sequence to the 551 -- initial scan of the END, but subsequent checking will have determined 552 -- that the label Process_Input is not an appropriate label. The real 553 -- error is a missing semicolon after the END, and by leaving the scan 554 -- pointer just past the END, we will improve the error recovery. 555 556 if Token_Is_At_Start_Of_Line then 557 return; 558 end if; 559 560 -- If there is a semicolon after the END, scan it out and we are done 561 562 if Token = Tok_Semicolon then 563 T_Semicolon; 564 return; 565 end if; 566 567 -- Otherwise skip past a token after the END on the same line. Note 568 -- that we do not eat a token on the following line since it seems 569 -- very unlikely in any case that the END gets separated from its 570 -- token, and we do not want to swallow up a keyword that starts a 571 -- legitimate construct following the bad END. 572 573 if not Token_Is_At_Start_Of_Line 574 and then 575 576 -- Cases of normal tokens following an END 577 578 (Token = Tok_Case or else 579 Token = Tok_If or else 580 Token = Tok_Loop or else 581 Token = Tok_Record or else 582 Token = Tok_Select or else 583 584 -- Cases of bogus keywords ending loops 585 586 Token = Tok_For or else 587 Token = Tok_While or else 588 589 -- Cases of operator symbol names without quotes 590 591 Token = Tok_Abs or else 592 Token = Tok_And or else 593 Token = Tok_Mod or else 594 Token = Tok_Not or else 595 Token = Tok_Or or else 596 Token = Tok_Xor) 597 598 then 599 Scan; -- past token after END 600 601 -- If that leaves us on the next line, then we are done. This is the 602 -- same principle described above for the case of END at line end 603 604 if Token_Is_At_Start_Of_Line then 605 return; 606 607 -- If we just scanned out record, then we are done, since the 608 -- semicolon after END RECORD is not part of the END sequence 609 610 elsif Prev_Token = Tok_Record then 611 return; 612 613 -- If we have a semicolon, scan it out and we are done 614 615 elsif Token = Tok_Semicolon then 616 T_Semicolon; 617 return; 618 end if; 619 end if; 620 621 -- Check for a label present on the same line 622 623 loop 624 if Token_Is_At_Start_Of_Line then 625 return; 626 end if; 627 628 if Token /= Tok_Identifier 629 and then Token /= Tok_Operator_Symbol 630 and then Token /= Tok_String_Literal 631 then 632 exit; 633 end if; 634 635 Scan; -- past identifier, operator symbol or string literal 636 637 if Token_Is_At_Start_Of_Line then 638 return; 639 elsif Token = Tok_Dot then 640 Scan; -- past dot 641 end if; 642 end loop; 643 644 -- Skip final semicolon 645 646 if Token = Tok_Semicolon then 647 T_Semicolon; 648 649 -- If we don't have a final semicolon, skip until we either encounter 650 -- an END token, or a semicolon or the start of the next line. This 651 -- allows general junk to follow the end line (normally it is hard to 652 -- think that anyone will put anything deliberate here, and remember 653 -- that we know there is a missing semicolon in any case). We also 654 -- quite on an EOF (or else we would get stuck in an infinite loop 655 -- if there is no line end at the end of the last line of the file) 656 657 else 658 while Token /= Tok_End 659 and then Token /= Tok_EOF 660 and then Token /= Tok_Semicolon 661 and then not Token_Is_At_Start_Of_Line 662 loop 663 Scan; -- past junk token on same line 664 end loop; 665 end if; 666 667 return; 668 end End_Skip; 669 670 -------------------- 671 -- End Statements -- 672 -------------------- 673 674 -- This procedure is called when END is required or expected to terminate 675 -- a sequence of statements. The caller has already made an appropriate 676 -- entry on the scope stack to describe the expected form of the END. 677 -- End_Statements should only be used in cases where the only appropriate 678 -- terminator is END. 679 680 -- Error recovery: cannot raise Error_Resync; 681 682 procedure End_Statements 683 (Parent : Node_Id := Empty; 684 Decl : Node_Id := Empty; 685 Is_Sloc : Source_Ptr := No_Location) 686 is 687 begin 688 -- This loop runs more than once in the case where Check_End rejects 689 -- the END sequence, as indicated by Check_End returning False. 690 691 loop 692 if Check_End (Decl, Is_Sloc) then 693 if Present (Parent) then 694 Set_End_Label (Parent, End_Labl); 695 end if; 696 697 return; 698 end if; 699 700 -- Extra statements past the bogus END are discarded. This is not 701 -- ideal for maximum error recovery, but it's too much trouble to 702 -- find an appropriate place to put them. 703 704 Discard_Junk_List (P_Sequence_Of_Statements (SS_None)); 705 end loop; 706 end End_Statements; 707 708 ------------------------ 709 -- Evaluate End Entry -- 710 ------------------------ 711 712 procedure Evaluate_End_Entry (SS_Index : Nat) is 713 STE : Scope_Table_Entry renames Scope.Table (SS_Index); 714 715 begin 716 Column_OK := (End_Column = STE.Ecol); 717 718 Token_OK := (End_Type = STE.Etyp 719 or else (End_Type = E_Name and then STE.Etyp >= E_Name)); 720 721 Label_OK := End_Labl_Present 722 and then (Same_Label (End_Labl, STE.Labl) 723 or else STE.Labl = Error); 724 725 -- Special case to consider. Suppose we have the suspicious label case, 726 -- e.g. a situation like: 727 728 -- My_Label; 729 -- declare 730 -- ... 731 -- begin 732 -- ... 733 -- end My_Label; 734 735 -- This is the case where we want to use the entry in the suspicous 736 -- label table to flag the semicolon saying it should be a colon. 737 738 -- Label_OK will be false because the label does not match (we have 739 -- My_Label on the end line, and the generated name for the scope). Also 740 -- End_Labl_Present will be True. 741 742 if not Label_OK 743 and then End_Labl_Present 744 and then not Comes_From_Source (Scope.Table (SS_Index).Labl) 745 then 746 -- Here is where we will search the suspicious labels table 747 748 for J in 1 .. Suspicious_Labels.Last loop 749 declare 750 SLE : Suspicious_Label_Entry renames 751 Suspicious_Labels.Table (J); 752 begin 753 -- See if character name of label matches 754 755 if Chars (Name (SLE.Proc_Call)) = Chars (End_Labl) 756 757 -- And first token of loop/block identifies this entry 758 759 and then SLE.Start_Token = STE.Sloc 760 then 761 -- We have the special case, issue the error message 762 763 Error_Msg -- CODEFIX 764 (""";"" should be "":""", SLE.Semicolon_Loc); 765 766 -- And indicate we consider the Label OK after all 767 768 Label_OK := True; 769 exit; 770 end if; 771 end; 772 end loop; 773 end if; 774 775 -- Compute setting of Syntax_OK. We definitely have a syntax error 776 -- if the Token does not match properly or if P_End_Scan detected 777 -- a syntax error such as a missing semicolon. 778 779 if not Token_OK or not End_OK then 780 Syntax_OK := False; 781 782 -- Final check is that label is OK. Certainly it is OK if there 783 -- was an exact match on the label (the END label = the stack label) 784 785 elsif Label_OK then 786 Syntax_OK := True; 787 788 -- Case of label present 789 790 elsif End_Labl_Present then 791 792 -- If probably misspelling, then complain, and pretend it is OK 793 794 declare 795 Nam : constant Node_Or_Entity_Id := Scope.Table (SS_Index).Labl; 796 797 begin 798 if Nkind (End_Labl) in N_Has_Chars 799 and then Comes_From_Source (Nam) 800 and then Nkind (Nam) in N_Has_Chars 801 and then Chars (End_Labl) > Error_Name 802 and then Chars (Nam) > Error_Name 803 then 804 Error_Msg_Name_1 := Chars (Nam); 805 806 if Error_Msg_Name_1 > Error_Name then 807 if Is_Bad_Spelling_Of (Chars (Nam), Chars (End_Labl)) then 808 Error_Msg_Name_1 := Chars (Nam); 809 Error_Msg_N -- CODEFIX 810 ("misspelling of %", End_Labl); 811 Syntax_OK := True; 812 return; 813 end if; 814 end if; 815 end if; 816 end; 817 818 Syntax_OK := False; 819 820 -- Otherwise we have cases of no label on the END line. For the loop 821 -- case, this is acceptable only if the loop is unlabeled. 822 823 elsif End_Type = E_Loop then 824 Syntax_OK := not Explicit_Start_Label (SS_Index); 825 826 -- Cases where a label is definitely allowed on the END line 827 828 elsif End_Type = E_Name then 829 Syntax_OK := (not Explicit_Start_Label (SS_Index)) 830 or else 831 (not Scope.Table (SS_Index).Lreq); 832 833 -- Otherwise we have cases which don't allow labels anyway, so we 834 -- certainly accept an END which does not have a label. 835 836 else 837 Syntax_OK := True; 838 end if; 839 end Evaluate_End_Entry; 840 841 -------------------------- 842 -- Explicit_Start_Label -- 843 -------------------------- 844 845 function Explicit_Start_Label (SS_Index : Nat) return Boolean is 846 L : constant Node_Id := Scope.Table (SS_Index).Labl; 847 Etyp : constant SS_End_Type := Scope.Table (SS_Index).Etyp; 848 849 begin 850 if No (L) then 851 return False; 852 853 -- In the following test we protect the call to Comes_From_Source 854 -- against lines containing previously reported syntax errors. 855 856 elsif (Etyp = E_Loop or else 857 Etyp = E_Name or else 858 Etyp = E_Suspicious_Is or else 859 Etyp = E_Bad_Is) 860 and then Comes_From_Source (L) 861 then 862 return True; 863 864 else 865 return False; 866 end if; 867 end Explicit_Start_Label; 868 869 ------------------------ 870 -- Output_End_Deleted -- 871 ------------------------ 872 873 procedure Output_End_Deleted is 874 begin 875 if End_Type = E_Loop then 876 Error_Msg_SC ("no LOOP for this `END LOOP`!"); 877 878 elsif End_Type = E_Case then 879 Error_Msg_SC ("no CASE for this `END CASE`"); 880 881 elsif End_Type = E_If then 882 Error_Msg_SC ("no IF for this `END IF`!"); 883 884 elsif End_Type = E_Record then 885 Error_Msg_SC ("no RECORD for this `END RECORD`!"); 886 887 elsif End_Type = E_Return then 888 Error_Msg_SC ("no RETURN for this `END RETURN`!"); 889 890 elsif End_Type = E_Select then 891 Error_Msg_SC ("no SELECT for this `END SELECT`!"); 892 893 else 894 Error_Msg_SC ("no BEGIN for this END!"); 895 end if; 896 end Output_End_Deleted; 897 898 ------------------------- 899 -- Output_End_Expected -- 900 ------------------------- 901 902 procedure Output_End_Expected (Ins : Boolean) is 903 End_Type : SS_End_Type; 904 905 begin 906 -- Suppress message if this was a potentially junk entry (e.g. a record 907 -- entry where no record keyword was present). 908 909 if Scope.Table (Scope.Last).Junk then 910 return; 911 end if; 912 913 End_Type := Scope.Table (Scope.Last).Etyp; 914 Error_Msg_Col := Scope.Table (Scope.Last).Ecol; 915 Error_Msg_Sloc := Scope.Table (Scope.Last).Sloc; 916 917 if Explicit_Start_Label (Scope.Last) then 918 Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl; 919 else 920 Error_Msg_Node_1 := Empty; 921 end if; 922 923 -- Suppress message if error was posted on opening label 924 925 if Error_Msg_Node_1 > Empty_Or_Error 926 and then Error_Posted (Error_Msg_Node_1) 927 then 928 return; 929 end if; 930 931 if End_Type = E_Case then 932 Error_Msg_SC -- CODEFIX 933 ("`END CASE;` expected@ for CASE#!"); 934 935 elsif End_Type = E_If then 936 Error_Msg_SC -- CODEFIX 937 ("`END IF;` expected@ for IF#!"); 938 939 elsif End_Type = E_Loop then 940 if Error_Msg_Node_1 = Empty then 941 Error_Msg_SC -- CODEFIX 942 ("`END LOOP;` expected@ for LOOP#!"); 943 else 944 Error_Msg_SC -- CODEFIX 945 ("`END LOOP &;` expected@!"); 946 end if; 947 948 elsif End_Type = E_Record then 949 Error_Msg_SC -- CODEFIX 950 ("`END RECORD;` expected@ for RECORD#!"); 951 952 elsif End_Type = E_Return then 953 Error_Msg_SC -- CODEFIX 954 ("`END RETURN;` expected@ for RETURN#!"); 955 956 elsif End_Type = E_Select then 957 Error_Msg_SC -- CODEFIX 958 ("`END SELECT;` expected@ for SELECT#!"); 959 960 -- All remaining cases are cases with a name (we do not treat the 961 -- suspicious is cases specially for a replaced end, only for an 962 -- inserted end). 963 964 elsif End_Type = E_Name or else not Ins then 965 if Error_Msg_Node_1 = Empty then 966 Error_Msg_SC -- CODEFIX 967 ("`END;` expected@ for BEGIN#!"); 968 else 969 Error_Msg_SC -- CODEFIX 970 ("`END &;` expected@!"); 971 end if; 972 973 -- The other possibility is a missing END for a subprogram with a 974 -- suspicious IS (that probably should have been a semicolon). The 975 -- missing IS confirms the suspicion. 976 977 else -- End_Type = E_Suspicious_Is or E_Bad_Is 978 Scope.Table (Scope.Last).Etyp := E_Bad_Is; 979 end if; 980 end Output_End_Expected; 981 982 ------------------------ 983 -- Output_End_Missing -- 984 ------------------------ 985 986 procedure Output_End_Missing is 987 End_Type : SS_End_Type; 988 989 begin 990 -- Suppress message if this was a potentially junk entry (e.g. a record 991 -- entry where no record keyword was present). 992 993 if Scope.Table (Scope.Last).Junk then 994 return; 995 end if; 996 997 End_Type := Scope.Table (Scope.Last).Etyp; 998 Error_Msg_Sloc := Scope.Table (Scope.Last).Sloc; 999 1000 if Explicit_Start_Label (Scope.Last) then 1001 Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl; 1002 else 1003 Error_Msg_Node_1 := Empty; 1004 end if; 1005 1006 if End_Type = E_Case then 1007 Error_Msg_BC ("missing `END CASE;` for CASE#!"); 1008 1009 elsif End_Type = E_If then 1010 Error_Msg_BC ("missing `END IF;` for IF#!"); 1011 1012 elsif End_Type = E_Loop then 1013 if Error_Msg_Node_1 = Empty then 1014 Error_Msg_BC ("missing `END LOOP;` for LOOP#!"); 1015 else 1016 Error_Msg_BC ("missing `END LOOP &;`!"); 1017 end if; 1018 1019 elsif End_Type = E_Record then 1020 Error_Msg_SC 1021 ("missing `END RECORD;` for RECORD#!"); 1022 1023 elsif End_Type = E_Return then 1024 Error_Msg_SC 1025 ("missing `END RETURN;` for RETURN#!"); 1026 1027 elsif End_Type = E_Select then 1028 Error_Msg_BC 1029 ("missing `END SELECT;` for SELECT#!"); 1030 1031 elsif End_Type = E_Name then 1032 if Error_Msg_Node_1 = Empty then 1033 Error_Msg_BC ("missing `END;` for BEGIN#!"); 1034 else 1035 Error_Msg_BC ("missing `END &;`!"); 1036 end if; 1037 1038 else -- End_Type = E_Suspicious_Is or E_Bad_Is 1039 Scope.Table (Scope.Last).Etyp := E_Bad_Is; 1040 end if; 1041 end Output_End_Missing; 1042 1043 --------------------- 1044 -- Pop_End_Context -- 1045 --------------------- 1046 1047 procedure Pop_End_Context is 1048 1049 Pretty_Good : Boolean; 1050 -- This flag is set True if the END sequence is syntactically incorrect, 1051 -- but is (from a heuristic point of view), pretty likely to be simply 1052 -- a misspelling of the intended END. 1053 1054 Outer_Match : Boolean; 1055 -- This flag is set True if we decide that the current END sequence 1056 -- belongs to some outer level entry in the scope stack, and thus 1057 -- we will NOT eat it up in matching the current expected END. 1058 1059 begin 1060 -- If not at END, then output END expected message 1061 1062 if End_Type = E_Dummy then 1063 Output_End_Missing; 1064 Pop_Scope_Stack; 1065 End_Action := Insert_And_Accept; 1066 return; 1067 1068 -- Otherwise we do have an END present 1069 1070 else 1071 -- A special check. If we have END; followed by an end of file, 1072 -- WITH or SEPARATE, then if we are not at the outer level, then 1073 -- we have a syntax error. Consider the example: 1074 1075 -- ... 1076 -- declare 1077 -- X : Integer; 1078 -- begin 1079 -- X := Father (A); 1080 -- Process (X, X); 1081 -- end; 1082 -- with Package1; 1083 -- ... 1084 1085 -- Now the END; here is a syntactically correct closer for the 1086 -- declare block, but if we eat it up, then we obviously have 1087 -- a missing END for the outer context (since WITH can only appear 1088 -- at the outer level. 1089 1090 -- In this situation, we always reserve the END; for the outer level, 1091 -- even if it is in the wrong column. This is because it's much more 1092 -- useful to have the error message point to the DECLARE than to the 1093 -- package header in this case. 1094 1095 -- We also reserve an end with a name before the end of file if the 1096 -- name is the one we expect at the outer level. 1097 1098 if (Token = Tok_EOF or else 1099 Token = Tok_With or else 1100 Token = Tok_Separate) 1101 and then End_Type >= E_Name 1102 and then (not End_Labl_Present 1103 or else Same_Label (End_Labl, Scope.Table (1).Labl)) 1104 and then Scope.Last > 1 1105 then 1106 Restore_Scan_State (Scan_State); -- to END 1107 Output_End_Expected (Ins => True); 1108 Pop_Scope_Stack; 1109 End_Action := Insert_And_Accept; 1110 return; 1111 end if; 1112 1113 -- Otherwise we go through the normal END evaluation procedure 1114 1115 Evaluate_End_Entry (Scope.Last); 1116 1117 -- If top entry in stack is syntactically correct, then we have 1118 -- scanned it out and everything is fine. This is the required 1119 -- action to properly process correct Ada programs. 1120 1121 if Syntax_OK then 1122 1123 -- Complain if checking columns and END is not in right column. 1124 -- Right in this context means exactly right, or on the same 1125 -- line as the opener. 1126 1127 if RM_Column_Check then 1128 if End_Column /= Scope.Table (Scope.Last).Ecol 1129 and then Current_Line_Start > Scope.Table (Scope.Last).Sloc 1130 1131 -- A special case, for END RECORD, we are also allowed to 1132 -- line up with the TYPE keyword opening the declaration. 1133 1134 and then (Scope.Table (Scope.Last).Etyp /= E_Record 1135 or else Get_Column_Number (End_Sloc) /= 1136 Get_Column_Number (Type_Token_Location)) 1137 then 1138 Error_Msg_Col := Scope.Table (Scope.Last).Ecol; 1139 Error_Msg 1140 ("(style) END in wrong column, should be@", End_Sloc); 1141 end if; 1142 end if; 1143 1144 -- One final check. If the end had a label, check for an exact 1145 -- duplicate of this end sequence, and if so, skip it with an 1146 -- appropriate message. 1147 1148 if End_Labl_Present and then Token = Tok_End then 1149 declare 1150 Scan_State : Saved_Scan_State; 1151 End_Loc : constant Source_Ptr := Token_Ptr; 1152 Nxt_Labl : Node_Id; 1153 Dup_Found : Boolean := False; 1154 1155 begin 1156 Save_Scan_State (Scan_State); 1157 1158 Scan; -- past END 1159 1160 if Token = Tok_Identifier 1161 or else Token = Tok_Operator_Symbol 1162 then 1163 Nxt_Labl := P_Designator; 1164 1165 -- We only consider it an error if the label is a match 1166 -- and would be wrong for the level one above us, and 1167 -- the indentation is the same. 1168 1169 if Token = Tok_Semicolon 1170 and then Same_Label (End_Labl, Nxt_Labl) 1171 and then End_Column = Start_Column 1172 and then 1173 (Scope.Last = 1 1174 or else 1175 (not Explicit_Start_Label (Scope.Last - 1)) 1176 or else 1177 (not Same_Label 1178 (End_Labl, 1179 Scope.Table (Scope.Last - 1).Labl))) 1180 then 1181 T_Semicolon; 1182 Error_Msg ("duplicate end line ignored", End_Loc); 1183 Dup_Found := True; 1184 end if; 1185 end if; 1186 1187 if not Dup_Found then 1188 Restore_Scan_State (Scan_State); 1189 end if; 1190 end; 1191 end if; 1192 1193 -- All OK, so return to caller indicating END is OK 1194 1195 Pop_Scope_Stack; 1196 End_Action := Accept_As_Scanned; 1197 return; 1198 end if; 1199 1200 -- If that check failed, then we definitely have an error. The issue 1201 -- is how to choose among three possible courses of action: 1202 1203 -- 1. Ignore the current END text completely, scanning past it, 1204 -- deciding that it belongs neither to the current context, 1205 -- nor to any outer context. 1206 1207 -- 2. Accept the current END text, scanning past it, and issuing 1208 -- an error message that it does not have the right form. 1209 1210 -- 3. Leave the current END text in place, NOT scanning past it, 1211 -- issuing an error message indicating the END expected for the 1212 -- current context. In this case, the END is available to match 1213 -- some outer END context. 1214 1215 -- From a correct functioning point of view, it does not make any 1216 -- difference which of these three approaches we take, the program 1217 -- will work correctly in any case. However, making an accurate 1218 -- choice among these alternatives, i.e. choosing the one that 1219 -- corresponds to what the programmer had in mind, does make a 1220 -- significant difference in the quality of error recovery. 1221 1222 Restore_Scan_State (Scan_State); -- to END 1223 1224 -- First we see how good the current END entry is with respect to 1225 -- what we expect. It is considered pretty good if the token is OK, 1226 -- and either the label or the column matches. An END for RECORD is 1227 -- always considered to be pretty good in the record case. This is 1228 -- because not only does a record disallow a nested structure, but 1229 -- also it is unlikely that such nesting could occur by accident. 1230 1231 Pretty_Good := (Token_OK and (Column_OK or Label_OK)) 1232 or else Scope.Table (Scope.Last).Etyp = E_Record; 1233 1234 -- Next check, if there is a deeper entry in the stack which 1235 -- has a very high probability of being acceptable, then insert 1236 -- the END entry we want, leaving the higher level entry for later 1237 1238 for J in reverse 1 .. Scope.Last - 1 loop 1239 Evaluate_End_Entry (J); 1240 1241 -- To even consider the deeper entry to be immediately acceptable, 1242 -- it must be syntactically correct. Furthermore it must either 1243 -- have a correct label, or the correct column. If the current 1244 -- entry was a close match (Pretty_Good set), then we are even 1245 -- more strict in accepting the outer level one: even if it has 1246 -- the right label, it must have the right column as well. 1247 1248 if Syntax_OK then 1249 if Pretty_Good then 1250 Outer_Match := Label_OK and Column_OK; 1251 else 1252 Outer_Match := Label_OK or Column_OK; 1253 end if; 1254 else 1255 Outer_Match := False; 1256 end if; 1257 1258 -- If the outer entry does convincingly match the END text, then 1259 -- back up the scan to the start of the END sequence, issue an 1260 -- error message indicating the END we expected, and return with 1261 -- Token pointing to the END (case 3 from above discussion). 1262 1263 if Outer_Match then 1264 Output_End_Missing; 1265 Pop_Scope_Stack; 1266 End_Action := Insert_And_Accept; 1267 return; 1268 end if; 1269 end loop; 1270 1271 -- Here we have a situation in which the current END entry is 1272 -- syntactically incorrect, but there is no deeper entry in the 1273 -- END stack which convincingly matches it. 1274 1275 -- If the END text was judged to be a Pretty_Good match for the 1276 -- expected token or if it appears left of the expected column, 1277 -- then we will accept it as the one we want, scanning past it, even 1278 -- though it is not completely right (we issue a message showing what 1279 -- we expected it to be). This is action 2 from the discussion above. 1280 -- There is one other special case to consider: the LOOP case. 1281 -- Consider the example: 1282 1283 -- Lbl: loop 1284 -- null; 1285 -- end loop; 1286 1287 -- Here the column lines up with Lbl, so END LOOP is to the right, 1288 -- but it is still acceptable. LOOP is the one case where alignment 1289 -- practices vary substantially in practice. 1290 1291 if Pretty_Good 1292 or else End_Column <= Scope.Table (Scope.Last).Ecol 1293 or else (End_Type = Scope.Table (Scope.Last).Etyp 1294 and then End_Type = E_Loop) 1295 then 1296 Output_End_Expected (Ins => False); 1297 Pop_Scope_Stack; 1298 End_Action := Skip_And_Accept; 1299 return; 1300 1301 -- Here we have the case where the END is to the right of the 1302 -- expected column and does not have a correct label to convince 1303 -- us that it nevertheless belongs to the current scope. For this 1304 -- we consider that it probably belongs not to the current context, 1305 -- but to some inner context that was not properly recognized (due to 1306 -- other syntax errors), and for which no proper scope stack entry 1307 -- was made. The proper action in this case is to delete the END text 1308 -- and return False to the caller as a signal to keep on looking for 1309 -- an acceptable END. This is action 1 from the discussion above. 1310 1311 else 1312 Output_End_Deleted; 1313 End_Action := Skip_And_Reject; 1314 return; 1315 end if; 1316 end if; 1317 end Pop_End_Context; 1318 1319 ---------------- 1320 -- Same_Label -- 1321 ---------------- 1322 1323 function Same_Label (Label1, Label2 : Node_Id) return Boolean is 1324 begin 1325 if Nkind (Label1) in N_Has_Chars 1326 and then Nkind (Label2) in N_Has_Chars 1327 then 1328 return Chars (Label1) = Chars (Label2); 1329 1330 elsif Nkind (Label1) = N_Selected_Component 1331 and then Nkind (Label2) = N_Selected_Component 1332 then 1333 return Same_Label (Prefix (Label1), Prefix (Label2)) and then 1334 Same_Label (Selector_Name (Label1), Selector_Name (Label2)); 1335 1336 elsif Nkind (Label1) = N_Designator 1337 and then Nkind (Label2) = N_Defining_Program_Unit_Name 1338 then 1339 return Same_Label (Name (Label1), Name (Label2)) and then 1340 Same_Label (Identifier (Label1), Defining_Identifier (Label2)); 1341 1342 else 1343 return False; 1344 end if; 1345 end Same_Label; 1346 1347end Endh; 1348