File : par-endh.adb
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-2014, 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
26 with Namet.Sp; use Namet.Sp;
27 with Stringt; use Stringt;
28 with Uintp; use Uintp;
29
30 with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
31
32 separate (Par)
33 package 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_For or else
580 Token = Tok_If or else
581 Token = Tok_Loop or else
582 Token = Tok_Record or else
583 Token = Tok_Select or else
584
585 -- Cases of bogus keywords ending loops
586
587 Token = Tok_For or else
588 Token = Tok_While or else
589
590 -- Cases of operator symbol names without quotes
591
592 Token = Tok_Abs or else
593 Token = Tok_And or else
594 Token = Tok_Mod or else
595 Token = Tok_Not or else
596 Token = Tok_Or or else
597 Token = Tok_Xor)
598
599 then
600 Scan; -- past token after END
601
602 -- If that leaves us on the next line, then we are done. This is the
603 -- same principle described above for the case of END at line end
604
605 if Token_Is_At_Start_Of_Line then
606 return;
607
608 -- If we just scanned out record, then we are done, since the
609 -- semicolon after END RECORD is not part of the END sequence
610
611 elsif Prev_Token = Tok_Record then
612 return;
613
614 -- If we have a semicolon, scan it out and we are done
615
616 elsif Token = Tok_Semicolon then
617 T_Semicolon;
618 return;
619 end if;
620 end if;
621
622 -- Check for a label present on the same line
623
624 loop
625 if Token_Is_At_Start_Of_Line then
626 return;
627 end if;
628
629 if Token /= Tok_Identifier
630 and then Token /= Tok_Operator_Symbol
631 and then Token /= Tok_String_Literal
632 then
633 exit;
634 end if;
635
636 Scan; -- past identifier, operator symbol or string literal
637
638 if Token_Is_At_Start_Of_Line then
639 return;
640 elsif Token = Tok_Dot then
641 Scan; -- past dot
642 end if;
643 end loop;
644
645 -- Skip final semicolon
646
647 if Token = Tok_Semicolon then
648 T_Semicolon;
649
650 -- If we don't have a final semicolon, skip until we either encounter
651 -- an END token, or a semicolon or the start of the next line. This
652 -- allows general junk to follow the end line (normally it is hard to
653 -- think that anyone will put anything deliberate here, and remember
654 -- that we know there is a missing semicolon in any case). We also
655 -- quite on an EOF (or else we would get stuck in an infinite loop
656 -- if there is no line end at the end of the last line of the file)
657
658 else
659 while Token /= Tok_End
660 and then Token /= Tok_EOF
661 and then Token /= Tok_Semicolon
662 and then not Token_Is_At_Start_Of_Line
663 loop
664 Scan; -- past junk token on same line
665 end loop;
666 end if;
667
668 return;
669 end End_Skip;
670
671 --------------------
672 -- End Statements --
673 --------------------
674
675 -- This procedure is called when END is required or expected to terminate
676 -- a sequence of statements. The caller has already made an appropriate
677 -- entry on the scope stack to describe the expected form of the END.
678 -- End_Statements should only be used in cases where the only appropriate
679 -- terminator is END.
680
681 -- Error recovery: cannot raise Error_Resync;
682
683 procedure End_Statements
684 (Parent : Node_Id := Empty;
685 Decl : Node_Id := Empty;
686 Is_Sloc : Source_Ptr := No_Location)
687 is
688 begin
689 -- This loop runs more than once in the case where Check_End rejects
690 -- the END sequence, as indicated by Check_End returning False.
691
692 loop
693 if Check_End (Decl, Is_Sloc) then
694 if Present (Parent) then
695 Set_End_Label (Parent, End_Labl);
696 end if;
697
698 return;
699 end if;
700
701 -- Extra statements past the bogus END are discarded. This is not
702 -- ideal for maximum error recovery, but it's too much trouble to
703 -- find an appropriate place to put them.
704
705 Discard_Junk_List (P_Sequence_Of_Statements (SS_None));
706 end loop;
707 end End_Statements;
708
709 ------------------------
710 -- Evaluate End Entry --
711 ------------------------
712
713 procedure Evaluate_End_Entry (SS_Index : Nat) is
714 STE : Scope_Table_Entry renames Scope.Table (SS_Index);
715
716 begin
717 Column_OK := (End_Column = STE.Ecol);
718
719 Token_OK := (End_Type = STE.Etyp
720 or else (End_Type = E_Name and then STE.Etyp >= E_Name));
721
722 Label_OK := End_Labl_Present
723 and then (Same_Label (End_Labl, STE.Labl)
724 or else STE.Labl = Error);
725
726 -- Special case to consider. Suppose we have the suspicious label case,
727 -- e.g. a situation like:
728
729 -- My_Label;
730 -- declare
731 -- ...
732 -- begin
733 -- ...
734 -- end My_Label;
735
736 -- This is the case where we want to use the entry in the suspicous
737 -- label table to flag the semicolon saying it should be a colon.
738
739 -- Label_OK will be false because the label does not match (we have
740 -- My_Label on the end line, and the generated name for the scope). Also
741 -- End_Labl_Present will be True.
742
743 if not Label_OK
744 and then End_Labl_Present
745 and then not Comes_From_Source (Scope.Table (SS_Index).Labl)
746 then
747 -- Here is where we will search the suspicious labels table
748
749 for J in 1 .. Suspicious_Labels.Last loop
750 declare
751 SLE : Suspicious_Label_Entry renames
752 Suspicious_Labels.Table (J);
753 begin
754 -- See if character name of label matches
755
756 if Chars (Name (SLE.Proc_Call)) = Chars (End_Labl)
757
758 -- And first token of loop/block identifies this entry
759
760 and then SLE.Start_Token = STE.Sloc
761 then
762 -- We have the special case, issue the error message
763
764 Error_Msg -- CODEFIX
765 (""";"" should be "":""", SLE.Semicolon_Loc);
766
767 -- And indicate we consider the Label OK after all
768
769 Label_OK := True;
770 exit;
771 end if;
772 end;
773 end loop;
774 end if;
775
776 -- Compute setting of Syntax_OK. We definitely have a syntax error
777 -- if the Token does not match properly or if P_End_Scan detected
778 -- a syntax error such as a missing semicolon.
779
780 if not Token_OK or not End_OK then
781 Syntax_OK := False;
782
783 -- Final check is that label is OK. Certainly it is OK if there
784 -- was an exact match on the label (the END label = the stack label)
785
786 elsif Label_OK then
787 Syntax_OK := True;
788
789 -- Case of label present
790
791 elsif End_Labl_Present then
792
793 -- If probably misspelling, then complain, and pretend it is OK
794
795 declare
796 Nam : constant Node_Or_Entity_Id := Scope.Table (SS_Index).Labl;
797
798 begin
799 if Nkind (End_Labl) in N_Has_Chars
800 and then Comes_From_Source (Nam)
801 and then Nkind (Nam) in N_Has_Chars
802 and then Chars (End_Labl) > Error_Name
803 and then Chars (Nam) > Error_Name
804 then
805 Error_Msg_Name_1 := Chars (Nam);
806
807 if Error_Msg_Name_1 > Error_Name then
808 if Is_Bad_Spelling_Of (Chars (Nam), Chars (End_Labl)) then
809 Error_Msg_Name_1 := Chars (Nam);
810 Error_Msg_N -- CODEFIX
811 ("misspelling of %", End_Labl);
812 Syntax_OK := True;
813 return;
814 end if;
815 end if;
816 end if;
817 end;
818
819 Syntax_OK := False;
820
821 -- Otherwise we have cases of no label on the END line. For the loop
822 -- case, this is acceptable only if the loop is unlabeled.
823
824 elsif End_Type = E_Loop then
825 Syntax_OK := not Explicit_Start_Label (SS_Index);
826
827 -- Cases where a label is definitely allowed on the END line
828
829 elsif End_Type = E_Name then
830 Syntax_OK := (not Explicit_Start_Label (SS_Index))
831 or else
832 (not Scope.Table (SS_Index).Lreq);
833
834 -- Otherwise we have cases which don't allow labels anyway, so we
835 -- certainly accept an END which does not have a label.
836
837 else
838 Syntax_OK := True;
839 end if;
840 end Evaluate_End_Entry;
841
842 --------------------------
843 -- Explicit_Start_Label --
844 --------------------------
845
846 function Explicit_Start_Label (SS_Index : Nat) return Boolean is
847 L : constant Node_Id := Scope.Table (SS_Index).Labl;
848 Etyp : constant SS_End_Type := Scope.Table (SS_Index).Etyp;
849
850 begin
851 if No (L) then
852 return False;
853
854 -- In the following test we protect the call to Comes_From_Source
855 -- against lines containing previously reported syntax errors.
856
857 elsif (Etyp = E_Loop or else
858 Etyp = E_Name or else
859 Etyp = E_Suspicious_Is or else
860 Etyp = E_Bad_Is)
861 and then Comes_From_Source (L)
862 then
863 return True;
864
865 else
866 return False;
867 end if;
868 end Explicit_Start_Label;
869
870 ------------------------
871 -- Output_End_Deleted --
872 ------------------------
873
874 procedure Output_End_Deleted is
875 begin
876 if End_Type = E_Loop then
877 Error_Msg_SC ("no LOOP for this `END LOOP`!");
878
879 elsif End_Type = E_Case then
880 Error_Msg_SC ("no CASE for this `END CASE`");
881
882 elsif End_Type = E_If then
883 Error_Msg_SC ("no IF for this `END IF`!");
884
885 elsif End_Type = E_Record then
886 Error_Msg_SC ("no RECORD for this `END RECORD`!");
887
888 elsif End_Type = E_Return then
889 Error_Msg_SC ("no RETURN for this `END RETURN`!");
890
891 elsif End_Type = E_Select then
892 Error_Msg_SC ("no SELECT for this `END SELECT`!");
893
894 else
895 Error_Msg_SC ("no BEGIN for this END!");
896 end if;
897 end Output_End_Deleted;
898
899 -------------------------
900 -- Output_End_Expected --
901 -------------------------
902
903 procedure Output_End_Expected (Ins : Boolean) is
904 End_Type : SS_End_Type;
905
906 begin
907 -- Suppress message if this was a potentially junk entry (e.g. a record
908 -- entry where no record keyword was present).
909
910 if Scope.Table (Scope.Last).Junk then
911 return;
912 end if;
913
914 End_Type := Scope.Table (Scope.Last).Etyp;
915 Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
916 Error_Msg_Sloc := Scope.Table (Scope.Last).Sloc;
917
918 if Explicit_Start_Label (Scope.Last) then
919 Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl;
920 else
921 Error_Msg_Node_1 := Empty;
922 end if;
923
924 -- Suppress message if error was posted on opening label
925
926 if Error_Msg_Node_1 > Empty_Or_Error
927 and then Error_Posted (Error_Msg_Node_1)
928 then
929 return;
930 end if;
931
932 if End_Type = E_Case then
933 Error_Msg_SC -- CODEFIX
934 ("`END CASE;` expected@ for CASE#!");
935
936 elsif End_Type = E_If then
937 Error_Msg_SC -- CODEFIX
938 ("`END IF;` expected@ for IF#!");
939
940 elsif End_Type = E_Loop then
941 if Error_Msg_Node_1 = Empty then
942 Error_Msg_SC -- CODEFIX
943 ("`END LOOP;` expected@ for LOOP#!");
944 else
945 Error_Msg_SC -- CODEFIX
946 ("`END LOOP &;` expected@!");
947 end if;
948
949 elsif End_Type = E_Record then
950 Error_Msg_SC -- CODEFIX
951 ("`END RECORD;` expected@ for RECORD#!");
952
953 elsif End_Type = E_Return then
954 Error_Msg_SC -- CODEFIX
955 ("`END RETURN;` expected@ for RETURN#!");
956
957 elsif End_Type = E_Select then
958 Error_Msg_SC -- CODEFIX
959 ("`END SELECT;` expected@ for SELECT#!");
960
961 -- All remaining cases are cases with a name (we do not treat the
962 -- suspicious is cases specially for a replaced end, only for an
963 -- inserted end).
964
965 elsif End_Type = E_Name or else not Ins then
966 if Error_Msg_Node_1 = Empty then
967 Error_Msg_SC -- CODEFIX
968 ("`END;` expected@ for BEGIN#!");
969 else
970 Error_Msg_SC -- CODEFIX
971 ("`END &;` expected@!");
972 end if;
973
974 -- The other possibility is a missing END for a subprogram with a
975 -- suspicious IS (that probably should have been a semicolon). The
976 -- missing IS confirms the suspicion.
977
978 else -- End_Type = E_Suspicious_Is or E_Bad_Is
979 Scope.Table (Scope.Last).Etyp := E_Bad_Is;
980 end if;
981 end Output_End_Expected;
982
983 ------------------------
984 -- Output_End_Missing --
985 ------------------------
986
987 procedure Output_End_Missing is
988 End_Type : SS_End_Type;
989
990 begin
991 -- Suppress message if this was a potentially junk entry (e.g. a record
992 -- entry where no record keyword was present).
993
994 if Scope.Table (Scope.Last).Junk then
995 return;
996 end if;
997
998 End_Type := Scope.Table (Scope.Last).Etyp;
999 Error_Msg_Sloc := Scope.Table (Scope.Last).Sloc;
1000
1001 if Explicit_Start_Label (Scope.Last) then
1002 Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl;
1003 else
1004 Error_Msg_Node_1 := Empty;
1005 end if;
1006
1007 if End_Type = E_Case then
1008 Error_Msg_BC ("missing `END CASE;` for CASE#!");
1009
1010 elsif End_Type = E_If then
1011 Error_Msg_BC ("missing `END IF;` for IF#!");
1012
1013 elsif End_Type = E_Loop then
1014 if Error_Msg_Node_1 = Empty then
1015 Error_Msg_BC ("missing `END LOOP;` for LOOP#!");
1016 else
1017 Error_Msg_BC ("missing `END LOOP &;`!");
1018 end if;
1019
1020 elsif End_Type = E_Record then
1021 Error_Msg_SC
1022 ("missing `END RECORD;` for RECORD#!");
1023
1024 elsif End_Type = E_Return then
1025 Error_Msg_SC
1026 ("missing `END RETURN;` for RETURN#!");
1027
1028 elsif End_Type = E_Select then
1029 Error_Msg_BC
1030 ("missing `END SELECT;` for SELECT#!");
1031
1032 elsif End_Type = E_Name then
1033 if Error_Msg_Node_1 = Empty then
1034 Error_Msg_BC ("missing `END;` for BEGIN#!");
1035 else
1036 Error_Msg_BC ("missing `END &;`!");
1037 end if;
1038
1039 else -- End_Type = E_Suspicious_Is or E_Bad_Is
1040 Scope.Table (Scope.Last).Etyp := E_Bad_Is;
1041 end if;
1042 end Output_End_Missing;
1043
1044 ---------------------
1045 -- Pop_End_Context --
1046 ---------------------
1047
1048 procedure Pop_End_Context is
1049
1050 Pretty_Good : Boolean;
1051 -- This flag is set True if the END sequence is syntactically incorrect,
1052 -- but is (from a heuristic point of view), pretty likely to be simply
1053 -- a misspelling of the intended END.
1054
1055 Outer_Match : Boolean;
1056 -- This flag is set True if we decide that the current END sequence
1057 -- belongs to some outer level entry in the scope stack, and thus
1058 -- we will NOT eat it up in matching the current expected END.
1059
1060 begin
1061 -- If not at END, then output END expected message
1062
1063 if End_Type = E_Dummy then
1064 Output_End_Missing;
1065 Pop_Scope_Stack;
1066 End_Action := Insert_And_Accept;
1067 return;
1068
1069 -- Otherwise we do have an END present
1070
1071 else
1072 -- A special check. If we have END; followed by an end of file,
1073 -- WITH or SEPARATE, then if we are not at the outer level, then
1074 -- we have a syntax error. Consider the example:
1075
1076 -- ...
1077 -- declare
1078 -- X : Integer;
1079 -- begin
1080 -- X := Father (A);
1081 -- Process (X, X);
1082 -- end;
1083 -- with Package1;
1084 -- ...
1085
1086 -- Now the END; here is a syntactically correct closer for the
1087 -- declare block, but if we eat it up, then we obviously have
1088 -- a missing END for the outer context (since WITH can only appear
1089 -- at the outer level.
1090
1091 -- In this situation, we always reserve the END; for the outer level,
1092 -- even if it is in the wrong column. This is because it's much more
1093 -- useful to have the error message point to the DECLARE than to the
1094 -- package header in this case.
1095
1096 -- We also reserve an end with a name before the end of file if the
1097 -- name is the one we expect at the outer level.
1098
1099 if (Token = Tok_EOF or else
1100 Token = Tok_With or else
1101 Token = Tok_Separate)
1102 and then End_Type >= E_Name
1103 and then (not End_Labl_Present
1104 or else Same_Label (End_Labl, Scope.Table (1).Labl))
1105 and then Scope.Last > 1
1106 then
1107 Restore_Scan_State (Scan_State); -- to END
1108 Output_End_Expected (Ins => True);
1109 Pop_Scope_Stack;
1110 End_Action := Insert_And_Accept;
1111 return;
1112 end if;
1113
1114 -- Otherwise we go through the normal END evaluation procedure
1115
1116 Evaluate_End_Entry (Scope.Last);
1117
1118 -- If top entry in stack is syntactically correct, then we have
1119 -- scanned it out and everything is fine. This is the required
1120 -- action to properly process correct Ada programs.
1121
1122 if Syntax_OK then
1123
1124 -- Complain if checking columns and END is not in right column.
1125 -- Right in this context means exactly right, or on the same
1126 -- line as the opener.
1127
1128 if RM_Column_Check then
1129 if End_Column /= Scope.Table (Scope.Last).Ecol
1130 and then Current_Line_Start > Scope.Table (Scope.Last).Sloc
1131
1132 -- A special case, for END RECORD, we are also allowed to
1133 -- line up with the TYPE keyword opening the declaration.
1134
1135 and then (Scope.Table (Scope.Last).Etyp /= E_Record
1136 or else Get_Column_Number (End_Sloc) /=
1137 Get_Column_Number (Type_Token_Location))
1138 then
1139 Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
1140 Error_Msg
1141 ("(style) END in wrong column, should be@", End_Sloc);
1142 end if;
1143 end if;
1144
1145 -- One final check. If the end had a label, check for an exact
1146 -- duplicate of this end sequence, and if so, skip it with an
1147 -- appropriate message.
1148
1149 if End_Labl_Present and then Token = Tok_End then
1150 declare
1151 Scan_State : Saved_Scan_State;
1152 End_Loc : constant Source_Ptr := Token_Ptr;
1153 Nxt_Labl : Node_Id;
1154 Dup_Found : Boolean := False;
1155
1156 begin
1157 Save_Scan_State (Scan_State);
1158
1159 Scan; -- past END
1160
1161 if Token = Tok_Identifier
1162 or else Token = Tok_Operator_Symbol
1163 then
1164 Nxt_Labl := P_Designator;
1165
1166 -- We only consider it an error if the label is a match
1167 -- and would be wrong for the level one above us, and
1168 -- the indentation is the same.
1169
1170 if Token = Tok_Semicolon
1171 and then Same_Label (End_Labl, Nxt_Labl)
1172 and then End_Column = Start_Column
1173 and then
1174 (Scope.Last = 1
1175 or else
1176 (not Explicit_Start_Label (Scope.Last - 1))
1177 or else
1178 (not Same_Label
1179 (End_Labl,
1180 Scope.Table (Scope.Last - 1).Labl)))
1181 then
1182 T_Semicolon;
1183 Error_Msg ("duplicate end line ignored", End_Loc);
1184 Dup_Found := True;
1185 end if;
1186 end if;
1187
1188 if not Dup_Found then
1189 Restore_Scan_State (Scan_State);
1190 end if;
1191 end;
1192 end if;
1193
1194 -- All OK, so return to caller indicating END is OK
1195
1196 Pop_Scope_Stack;
1197 End_Action := Accept_As_Scanned;
1198 return;
1199 end if;
1200
1201 -- If that check failed, then we definitely have an error. The issue
1202 -- is how to choose among three possible courses of action:
1203
1204 -- 1. Ignore the current END text completely, scanning past it,
1205 -- deciding that it belongs neither to the current context,
1206 -- nor to any outer context.
1207
1208 -- 2. Accept the current END text, scanning past it, and issuing
1209 -- an error message that it does not have the right form.
1210
1211 -- 3. Leave the current END text in place, NOT scanning past it,
1212 -- issuing an error message indicating the END expected for the
1213 -- current context. In this case, the END is available to match
1214 -- some outer END context.
1215
1216 -- From a correct functioning point of view, it does not make any
1217 -- difference which of these three approaches we take, the program
1218 -- will work correctly in any case. However, making an accurate
1219 -- choice among these alternatives, i.e. choosing the one that
1220 -- corresponds to what the programmer had in mind, does make a
1221 -- significant difference in the quality of error recovery.
1222
1223 Restore_Scan_State (Scan_State); -- to END
1224
1225 -- First we see how good the current END entry is with respect to
1226 -- what we expect. It is considered pretty good if the token is OK,
1227 -- and either the label or the column matches. An END for RECORD is
1228 -- always considered to be pretty good in the record case. This is
1229 -- because not only does a record disallow a nested structure, but
1230 -- also it is unlikely that such nesting could occur by accident.
1231
1232 Pretty_Good := (Token_OK and (Column_OK or Label_OK))
1233 or else Scope.Table (Scope.Last).Etyp = E_Record;
1234
1235 -- Next check, if there is a deeper entry in the stack which
1236 -- has a very high probability of being acceptable, then insert
1237 -- the END entry we want, leaving the higher level entry for later
1238
1239 for J in reverse 1 .. Scope.Last - 1 loop
1240 Evaluate_End_Entry (J);
1241
1242 -- To even consider the deeper entry to be immediately acceptable,
1243 -- it must be syntactically correct. Furthermore it must either
1244 -- have a correct label, or the correct column. If the current
1245 -- entry was a close match (Pretty_Good set), then we are even
1246 -- more strict in accepting the outer level one: even if it has
1247 -- the right label, it must have the right column as well.
1248
1249 if Syntax_OK then
1250 if Pretty_Good then
1251 Outer_Match := Label_OK and Column_OK;
1252 else
1253 Outer_Match := Label_OK or Column_OK;
1254 end if;
1255 else
1256 Outer_Match := False;
1257 end if;
1258
1259 -- If the outer entry does convincingly match the END text, then
1260 -- back up the scan to the start of the END sequence, issue an
1261 -- error message indicating the END we expected, and return with
1262 -- Token pointing to the END (case 3 from above discussion).
1263
1264 if Outer_Match then
1265 Output_End_Missing;
1266 Pop_Scope_Stack;
1267 End_Action := Insert_And_Accept;
1268 return;
1269 end if;
1270 end loop;
1271
1272 -- Here we have a situation in which the current END entry is
1273 -- syntactically incorrect, but there is no deeper entry in the
1274 -- END stack which convincingly matches it.
1275
1276 -- If the END text was judged to be a Pretty_Good match for the
1277 -- expected token or if it appears left of the expected column,
1278 -- then we will accept it as the one we want, scanning past it, even
1279 -- though it is not completely right (we issue a message showing what
1280 -- we expected it to be). This is action 2 from the discussion above.
1281 -- There is one other special case to consider: the LOOP case.
1282 -- Consider the example:
1283
1284 -- Lbl: loop
1285 -- null;
1286 -- end loop;
1287
1288 -- Here the column lines up with Lbl, so END LOOP is to the right,
1289 -- but it is still acceptable. LOOP is the one case where alignment
1290 -- practices vary substantially in practice.
1291
1292 if Pretty_Good
1293 or else End_Column <= Scope.Table (Scope.Last).Ecol
1294 or else (End_Type = Scope.Table (Scope.Last).Etyp
1295 and then End_Type = E_Loop)
1296 then
1297 Output_End_Expected (Ins => False);
1298 Pop_Scope_Stack;
1299 End_Action := Skip_And_Accept;
1300 return;
1301
1302 -- Here we have the case where the END is to the right of the
1303 -- expected column and does not have a correct label to convince
1304 -- us that it nevertheless belongs to the current scope. For this
1305 -- we consider that it probably belongs not to the current context,
1306 -- but to some inner context that was not properly recognized (due to
1307 -- other syntax errors), and for which no proper scope stack entry
1308 -- was made. The proper action in this case is to delete the END text
1309 -- and return False to the caller as a signal to keep on looking for
1310 -- an acceptable END. This is action 1 from the discussion above.
1311
1312 else
1313 Output_End_Deleted;
1314 End_Action := Skip_And_Reject;
1315 return;
1316 end if;
1317 end if;
1318 end Pop_End_Context;
1319
1320 ----------------
1321 -- Same_Label --
1322 ----------------
1323
1324 function Same_Label (Label1, Label2 : Node_Id) return Boolean is
1325 begin
1326 if Nkind (Label1) in N_Has_Chars
1327 and then Nkind (Label2) in N_Has_Chars
1328 then
1329 return Chars (Label1) = Chars (Label2);
1330
1331 elsif Nkind (Label1) = N_Selected_Component
1332 and then Nkind (Label2) = N_Selected_Component
1333 then
1334 return Same_Label (Prefix (Label1), Prefix (Label2)) and then
1335 Same_Label (Selector_Name (Label1), Selector_Name (Label2));
1336
1337 elsif Nkind (Label1) = N_Designator
1338 and then Nkind (Label2) = N_Defining_Program_Unit_Name
1339 then
1340 return Same_Label (Name (Label1), Name (Label2)) and then
1341 Same_Label (Identifier (Label1), Defining_Identifier (Label2));
1342
1343 else
1344 return False;
1345 end if;
1346 end Same_Label;
1347
1348 end Endh;