Merge from mainline (167278:168000).
[official-gcc/graphite-test-results.git] / gcc / ada / par-endh.adb
blobb250ecb950e5ec7435a466a491cb52d1d518d6af
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-2010, 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 ------------------------------------------------------------------------------
26 with Namet.Sp; use Namet.Sp;
27 with Stringt; use Stringt;
28 with Uintp; use Uintp;
30 with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
32 separate (Par)
33 package body Endh is
35 ----------------
36 -- Local Data --
37 ----------------
39 type End_Action_Type is (
40 -- Type used to describe the result of the Pop_End_Context call
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).
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.
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.
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.
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.
70 End_Sloc : Source_Ptr;
71 -- Source location of END token
73 End_OK : Boolean;
74 -- Set False if error is found in END line
76 End_Column : Column_Number;
77 -- Column of END line
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)
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.
89 End_Labl_Present : Boolean;
90 -- Indicates that the value in End_Labl was for an explicit label
92 Syntax_OK : Boolean;
93 -- Set True if the entry is syntactically correct
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.
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.
107 Column_OK : Boolean;
108 -- Column_OK is set True if the END sequence appears in the expected column
110 Scan_State : Saved_Scan_State;
111 -- Save state at start of END sequence, in case we decide not to eat it up
113 -----------------------
114 -- Local Subprograms --
115 -----------------------
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.
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)
128 procedure Output_End_Deleted;
129 -- Output a message complaining that the current END structure does not
130 -- match anything and is being deleted.
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.
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.
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.
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.
165 ---------------
166 -- Check_End --
167 ---------------
169 function Check_End (Decl : Node_Id := Empty) return Boolean is
170 Name_On_Separate_Line : Boolean;
171 -- Set True if the name on an END line is on a separate source line
172 -- from the END. This is highly suspicious, but is allowed. The point
173 -- is that we want to make sure that we don't just have a missing
174 -- semicolon misleading us into swallowing an identifier from the
175 -- following line.
177 Name_Scan_State : Saved_Scan_State;
178 -- Save state at start of name if Name_On_Separate_Line is TRUE
180 Span_Node : constant Node_Id := Scope.Table (Scope.Last).Node;
182 begin
183 End_Labl_Present := False;
184 End_Labl := Empty;
186 -- Our first task is to scan out the END sequence if one is present.
187 -- If none is present, signal by setting End_Type to E_Dummy.
189 if Token /= Tok_End then
190 End_Type := E_Dummy;
192 else
193 Save_Scan_State (Scan_State); -- at END
194 End_Sloc := Token_Ptr;
195 End_Column := Start_Column;
196 End_OK := True;
197 Scan; -- past END
199 -- Set End_Span if expected. note that this will be useless
200 -- if we do not have the right ending keyword, but in this
201 -- case we have a malformed program anyway, and the setting
202 -- of End_Span will simply be unreliable in this case anyway.
204 if Present (Span_Node) then
205 Set_End_Location (Span_Node, Token_Ptr);
206 end if;
208 -- Cases of keywords where no label is allowed
210 if Token = Tok_Case then
211 End_Type := E_Case;
212 Scan; -- past CASE
214 elsif Token = Tok_If then
215 End_Type := E_If;
216 Scan; -- past IF
218 elsif Token = Tok_Record then
219 End_Type := E_Record;
220 Scan; -- past RECORD
222 elsif Token = Tok_Return then
223 End_Type := E_Return;
224 Scan; -- past RETURN
226 elsif Token = Tok_Select then
227 End_Type := E_Select;
228 Scan; -- past SELECT
230 -- Cases which do allow labels
232 else
233 -- LOOP
235 if Token = Tok_Loop then
236 Scan; -- past LOOP
237 End_Type := E_Loop;
239 -- FOR or WHILE allowed (signalling error) to substitute for LOOP
240 -- if on the same line as the END
242 elsif (Token = Tok_For or else Token = Tok_While)
243 and then not Token_Is_At_Start_Of_Line
244 then
245 Scan; -- past FOR or WHILE
246 End_Type := E_Loop;
247 End_OK := False;
249 -- Cases with no keyword
251 else
252 End_Type := E_Name;
253 end if;
255 -- Now see if a name is present
257 if Token = Tok_Identifier or else
258 Token = Tok_String_Literal or else
259 Token = Tok_Operator_Symbol
260 then
261 if Token_Is_At_Start_Of_Line then
262 Name_On_Separate_Line := True;
263 Save_Scan_State (Name_Scan_State);
264 else
265 Name_On_Separate_Line := False;
266 end if;
268 End_Labl := P_Designator;
269 End_Labl_Present := True;
271 -- We have now scanned out a name. Here is where we do a check
272 -- to catch the cases like:
274 -- end loop
275 -- X := 3;
277 -- where the missing semicolon might make us swallow up the X
278 -- as a bogus end label. In a situation like this, where the
279 -- apparent name is on a separate line, we accept it only if
280 -- it matches the label and is followed by a semicolon.
282 if Name_On_Separate_Line then
283 if Token /= Tok_Semicolon or else
284 not Same_Label (End_Labl, Scope.Table (Scope.Last).Labl)
285 then
286 Restore_Scan_State (Name_Scan_State);
287 End_Labl := Empty;
288 End_Labl_Present := False;
289 end if;
290 end if;
292 -- Here for case of name allowed, but no name present. We will
293 -- supply an implicit matching name, with source location set
294 -- to the scan location past the END token.
296 else
297 End_Labl := Scope.Table (Scope.Last).Labl;
299 if End_Labl > Empty_Or_Error then
301 -- The task here is to construct a designator from the
302 -- opening label, with the components all marked as not
303 -- from source, and Is_End_Label set in the identifier
304 -- or operator symbol. The location for all components
305 -- is the current token location.
307 -- Case of child unit name
309 if Nkind (End_Labl) = N_Defining_Program_Unit_Name then
310 Child_End : declare
311 Eref : constant Node_Id :=
312 Make_Identifier (Token_Ptr,
313 Chars =>
314 Chars (Defining_Identifier (End_Labl)));
316 function Copy_Name (N : Node_Id) return Node_Id;
317 -- Copies a selected component or identifier
319 ---------------
320 -- Copy_Name --
321 ---------------
323 function Copy_Name (N : Node_Id) return Node_Id is
324 R : Node_Id;
326 begin
327 if Nkind (N) = N_Selected_Component then
328 return
329 Make_Selected_Component (Token_Ptr,
330 Prefix =>
331 Copy_Name (Prefix (N)),
332 Selector_Name =>
333 Copy_Name (Selector_Name (N)));
335 else
336 R := Make_Identifier (Token_Ptr, Chars (N));
337 Set_Comes_From_Source (N, False);
338 return R;
339 end if;
340 end Copy_Name;
342 -- Start of processing for Child_End
344 begin
345 Set_Comes_From_Source (Eref, False);
347 End_Labl :=
348 Make_Designator (Token_Ptr,
349 Name => Copy_Name (Name (End_Labl)),
350 Identifier => Eref);
351 end Child_End;
353 -- Simple identifier case
355 elsif Nkind (End_Labl) = N_Defining_Identifier
356 or else Nkind (End_Labl) = N_Identifier
357 then
358 End_Labl := Make_Identifier (Token_Ptr, Chars (End_Labl));
360 elsif Nkind (End_Labl) = N_Defining_Operator_Symbol
361 or else Nkind (End_Labl) = N_Operator_Symbol
362 then
363 Get_Decoded_Name_String (Chars (End_Labl));
365 End_Labl :=
366 Make_Operator_Symbol (Token_Ptr,
367 Chars => Chars (End_Labl),
368 Strval => String_From_Name_Buffer);
369 end if;
371 Set_Comes_From_Source (End_Labl, False);
372 End_Labl_Present := False;
374 -- Do style check for missing label
376 if Style_Check
377 and then End_Type = E_Name
378 and then Explicit_Start_Label (Scope.Last)
379 then
380 Style.No_End_Name (Scope.Table (Scope.Last).Labl);
381 end if;
382 end if;
383 end if;
384 end if;
386 -- Deal with terminating aspect specifications and following semi-
387 -- colon. We skip this in the case of END RECORD, since in this
388 -- case the aspect specifications and semicolon are handled at
389 -- a higher level.
391 if End_Type /= E_Record then
393 -- Scan aspect specifications if permitted here
395 if Aspect_Specifications_Present then
396 if No (Decl) then
397 P_Aspect_Specifications (Error);
398 else
399 P_Aspect_Specifications (Decl);
400 end if;
402 -- If no aspect specifications, must have a semicolon
404 elsif End_Type /= E_Record then
405 if Token = Tok_Semicolon then
406 T_Semicolon;
408 -- Semicolon is missing. If the missing semicolon is at the end
409 -- of the line, i.e. we are at the start of the line now, then
410 -- a missing semicolon gets flagged, but is not serious enough
411 -- to consider the END statement to be bad in the sense that we
412 -- are dealing with (i.e. to be suspicious that this END is not
413 -- the END statement we are looking for).
415 -- Similarly, if we are at a colon, we flag it but a colon for
416 -- a semicolon is not serious enough to consider the END to be
417 -- incorrect. Same thing for a period in place of a semicolon.
419 elsif Token_Is_At_Start_Of_Line
420 or else Token = Tok_Colon
421 or else Token = Tok_Dot
422 then
423 T_Semicolon;
425 -- If the missing semicolon is not at the start of the line,
426 -- then we consider the END line to be dubious in this sense.
428 else
429 End_OK := False;
430 end if;
431 end if;
432 end if;
433 end if;
435 -- Now we call the Pop_End_Context routine to get a recommendation
436 -- as to what should be done with the END sequence we have scanned.
438 Pop_End_Context;
440 -- Remaining action depends on End_Action set by Pop_End_Context
442 case End_Action is
444 -- Accept_As_Scanned. In this case, Pop_End_Context left Token
445 -- pointing past the last token of a syntactically correct END
447 when Accept_As_Scanned =>
449 -- Syntactically correct included the possibility of a missing
450 -- semicolon. If we do have a missing semicolon, then we have
451 -- already given a message, but now we scan out possible rubbish
452 -- on the same line as the END
454 while not Token_Is_At_Start_Of_Line
455 and then Prev_Token /= Tok_Record
456 and then Prev_Token /= Tok_Semicolon
457 and then Token /= Tok_End
458 and then Token /= Tok_EOF
459 loop
460 Scan; -- past junk
461 end loop;
463 return True;
465 -- Insert_And_Accept. In this case, Pop_End_Context has reset Token
466 -- to point to the start of the END sequence, and recommends that it
467 -- be left in place to satisfy an outer scope level END. This means
468 -- that we proceed as though an END were present, and leave the scan
469 -- pointer unchanged.
471 when Insert_And_Accept =>
472 return True;
474 -- Skip_And_Accept. In this case, Pop_End_Context has reset Token
475 -- to point to the start of the END sequence. This END sequence is
476 -- syntactically incorrect, and an appropriate error message has
477 -- already been posted. Pop_End_Context recommends accepting the
478 -- END sequence as the one we want, so we skip past it and then
479 -- proceed as though an END were present.
481 when Skip_And_Accept =>
482 End_Skip;
483 return True;
485 -- Skip_And_Reject. In this case, Pop_End_Context has reset Token
486 -- to point to the start of the END sequence. This END sequence is
487 -- syntactically incorrect, and an appropriate error message has
488 -- already been posted. Pop_End_Context recommends entirely ignoring
489 -- this END sequence, so we skip past it and then return False, since
490 -- as far as the caller is concerned, no END sequence is present.
492 when Skip_And_Reject =>
493 End_Skip;
494 return False;
495 end case;
496 end Check_End;
498 --------------
499 -- End Skip --
500 --------------
502 -- This procedure skips past an END sequence. On entry Token contains
503 -- Tok_End, and we know that the END sequence is syntactically incorrect,
504 -- and that an appropriate error message has already been posted. The
505 -- mission is simply to position the scan pointer to be the best guess of
506 -- the position after the END sequence. We do not issue any additional
507 -- error messages while carrying this out.
509 -- Error recovery: does not raise Error_Resync
511 procedure End_Skip is
512 begin
513 Scan; -- past END
515 -- If the scan past the END leaves us on the next line, that's probably
516 -- where we should quit the scan, since it is likely that what we have
517 -- is a missing semicolon. Consider the following:
519 -- END
520 -- Process_Input;
522 -- This will have looked like a syntactically valid END sequence to the
523 -- initial scan of the END, but subsequent checking will have determined
524 -- that the label Process_Input is not an appropriate label. The real
525 -- error is a missing semicolon after the END, and by leaving the scan
526 -- pointer just past the END, we will improve the error recovery.
528 if Token_Is_At_Start_Of_Line then
529 return;
530 end if;
532 -- If there is a semicolon after the END, scan it out and we are done
534 if Token = Tok_Semicolon then
535 T_Semicolon;
536 return;
537 end if;
539 -- Otherwise skip past a token after the END on the same line. Note
540 -- that we do not eat a token on the following line since it seems
541 -- very unlikely in any case that the END gets separated from its
542 -- token, and we do not want to swallow up a keyword that starts a
543 -- legitimate construct following the bad END.
545 if not Token_Is_At_Start_Of_Line
546 and then
548 -- Cases of normal tokens following an END
550 (Token = Tok_Case or else
551 Token = Tok_For or else
552 Token = Tok_If or else
553 Token = Tok_Loop or else
554 Token = Tok_Record or else
555 Token = Tok_Select or else
557 -- Cases of bogus keywords ending loops
559 Token = Tok_For or else
560 Token = Tok_While or else
562 -- Cases of operator symbol names without quotes
564 Token = Tok_Abs or else
565 Token = Tok_And or else
566 Token = Tok_Mod or else
567 Token = Tok_Not or else
568 Token = Tok_Or or else
569 Token = Tok_Xor)
571 then
572 Scan; -- past token after END
574 -- If that leaves us on the next line, then we are done. This is the
575 -- same principle described above for the case of END at line end
577 if Token_Is_At_Start_Of_Line then
578 return;
580 -- If we just scanned out record, then we are done, since the
581 -- semicolon after END RECORD is not part of the END sequence
583 elsif Prev_Token = Tok_Record then
584 return;
586 -- If we have a semicolon, scan it out and we are done
588 elsif Token = Tok_Semicolon then
589 T_Semicolon;
590 return;
591 end if;
592 end if;
594 -- Check for a label present on the same line
596 loop
597 if Token_Is_At_Start_Of_Line then
598 return;
599 end if;
601 if Token /= Tok_Identifier
602 and then Token /= Tok_Operator_Symbol
603 and then Token /= Tok_String_Literal
604 then
605 exit;
606 end if;
608 Scan; -- past identifier, operator symbol or string literal
610 if Token_Is_At_Start_Of_Line then
611 return;
612 elsif Token = Tok_Dot then
613 Scan; -- past dot
614 end if;
615 end loop;
617 -- Skip final semicolon
619 if Token = Tok_Semicolon then
620 T_Semicolon;
622 -- If we don't have a final semicolon, skip until we either encounter
623 -- an END token, or a semicolon or the start of the next line. This
624 -- allows general junk to follow the end line (normally it is hard to
625 -- think that anyone will put anything deliberate here, and remember
626 -- that we know there is a missing semicolon in any case). We also
627 -- quite on an EOF (or else we would get stuck in an infinite loop
628 -- if there is no line end at the end of the last line of the file)
630 else
631 while Token /= Tok_End
632 and then Token /= Tok_EOF
633 and then Token /= Tok_Semicolon
634 and then not Token_Is_At_Start_Of_Line
635 loop
636 Scan; -- past junk token on same line
637 end loop;
638 end if;
640 return;
641 end End_Skip;
643 --------------------
644 -- End Statements --
645 --------------------
647 -- This procedure is called when END is required or expected to terminate
648 -- a sequence of statements. The caller has already made an appropriate
649 -- entry on the scope stack to describe the expected form of the END.
650 -- End_Statements should only be used in cases where the only appropriate
651 -- terminator is END.
653 -- Error recovery: cannot raise Error_Resync;
655 procedure End_Statements
656 (Parent : Node_Id := Empty;
657 Decl : Node_Id := Empty) is
658 begin
659 -- This loop runs more than once in the case where Check_End rejects
660 -- the END sequence, as indicated by Check_End returning False.
662 loop
663 if Check_End (Decl) then
664 if Present (Parent) then
665 Set_End_Label (Parent, End_Labl);
666 end if;
668 return;
669 end if;
671 -- Extra statements past the bogus END are discarded. This is not
672 -- ideal for maximum error recovery, but it's too much trouble to
673 -- find an appropriate place to put them!
675 Discard_Junk_List (P_Sequence_Of_Statements (SS_None));
676 end loop;
677 end End_Statements;
679 ------------------------
680 -- Evaluate End Entry --
681 ------------------------
683 procedure Evaluate_End_Entry (SS_Index : Nat) is
684 begin
685 Column_OK := (End_Column = Scope.Table (SS_Index).Ecol);
687 Token_OK := (End_Type = Scope.Table (SS_Index).Etyp or else
688 (End_Type = E_Name and then
689 Scope.Table (SS_Index).Etyp >= E_Name));
691 Label_OK := End_Labl_Present
692 and then
693 (Same_Label (End_Labl, Scope.Table (SS_Index).Labl)
694 or else Scope.Table (SS_Index).Labl = Error);
696 -- Compute setting of Syntax_OK. We definitely have a syntax error
697 -- if the Token does not match properly or if P_End_Scan detected
698 -- a syntax error such as a missing semicolon.
700 if not Token_OK or not End_OK then
701 Syntax_OK := False;
703 -- Final check is that label is OK. Certainly it is OK if there
704 -- was an exact match on the label (the END label = the stack label)
706 elsif Label_OK then
707 Syntax_OK := True;
709 -- Case of label present
711 elsif End_Labl_Present then
713 -- If probably misspelling, then complain, and pretend it is OK
715 declare
716 Nam : constant Node_Or_Entity_Id := Scope.Table (SS_Index).Labl;
718 begin
719 if Nkind (End_Labl) in N_Has_Chars
720 and then Comes_From_Source (Nam)
721 and then Nkind (Nam) in N_Has_Chars
722 and then Chars (End_Labl) > Error_Name
723 and then Chars (Nam) > Error_Name
724 then
725 Error_Msg_Name_1 := Chars (Nam);
727 if Error_Msg_Name_1 > Error_Name then
728 if Is_Bad_Spelling_Of (Chars (Nam), Chars (End_Labl)) then
729 Error_Msg_Name_1 := Chars (Nam);
730 Error_Msg_N -- CODEFIX
731 ("misspelling of %", End_Labl);
732 Syntax_OK := True;
733 return;
734 end if;
735 end if;
736 end if;
737 end;
739 Syntax_OK := False;
741 -- Otherwise we have cases of no label on the END line. For the loop
742 -- case, this is acceptable only if the loop is unlabeled.
744 elsif End_Type = E_Loop then
745 Syntax_OK := not Explicit_Start_Label (SS_Index);
747 -- Cases where a label is definitely allowed on the END line
749 elsif End_Type = E_Name then
750 Syntax_OK := (not Explicit_Start_Label (SS_Index))
751 or else
752 (not Scope.Table (SS_Index).Lreq);
754 -- Otherwise we have cases which don't allow labels anyway, so we
755 -- certainly accept an END which does not have a label.
757 else
758 Syntax_OK := True;
759 end if;
760 end Evaluate_End_Entry;
762 --------------------------
763 -- Explicit_Start_Label --
764 --------------------------
766 function Explicit_Start_Label (SS_Index : Nat) return Boolean is
767 L : constant Node_Id := Scope.Table (SS_Index).Labl;
768 Etyp : constant SS_End_Type := Scope.Table (SS_Index).Etyp;
770 begin
771 if No (L) then
772 return False;
774 -- In the following test we protect the call to Comes_From_Source
775 -- against lines containing previously reported syntax errors.
777 elsif (Etyp = E_Loop
778 or else Etyp = E_Name
779 or else Etyp = E_Suspicious_Is
780 or else Etyp = E_Bad_Is)
781 and then Comes_From_Source (L)
782 then
783 return True;
784 else
785 return False;
786 end if;
787 end Explicit_Start_Label;
789 ------------------------
790 -- Output End Deleted --
791 ------------------------
793 procedure Output_End_Deleted is
794 begin
796 if End_Type = E_Loop then
797 Error_Msg_SC ("no LOOP for this `END LOOP`!");
799 elsif End_Type = E_Case then
800 Error_Msg_SC ("no CASE for this `END CASE`");
802 elsif End_Type = E_If then
803 Error_Msg_SC ("no IF for this `END IF`!");
805 elsif End_Type = E_Record then
806 Error_Msg_SC ("no RECORD for this `END RECORD`!");
808 elsif End_Type = E_Return then
809 Error_Msg_SC ("no RETURN for this `END RETURN`!");
811 elsif End_Type = E_Select then
812 Error_Msg_SC ("no SELECT for this `END SELECT`!");
814 else
815 Error_Msg_SC ("no BEGIN for this END!");
816 end if;
817 end Output_End_Deleted;
819 -------------------------
820 -- Output End Expected --
821 -------------------------
823 procedure Output_End_Expected (Ins : Boolean) is
824 End_Type : SS_End_Type;
826 begin
827 -- Suppress message if this was a potentially junk entry (e.g. a
828 -- record entry where no record keyword was present.
830 if Scope.Table (Scope.Last).Junk then
831 return;
832 end if;
834 End_Type := Scope.Table (Scope.Last).Etyp;
835 Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
836 Error_Msg_Sloc := Scope.Table (Scope.Last).Sloc;
838 if Explicit_Start_Label (Scope.Last) then
839 Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl;
840 else
841 Error_Msg_Node_1 := Empty;
842 end if;
844 -- Suppress message if error was posted on opening label
846 if Error_Msg_Node_1 > Empty_Or_Error
847 and then Error_Posted (Error_Msg_Node_1)
848 then
849 return;
850 end if;
852 if End_Type = E_Case then
853 Error_Msg_SC -- CODEFIX
854 ("`END CASE;` expected@ for CASE#!");
856 elsif End_Type = E_If then
857 Error_Msg_SC -- CODEFIX
858 ("`END IF;` expected@ for IF#!");
860 elsif End_Type = E_Loop then
861 if Error_Msg_Node_1 = Empty then
862 Error_Msg_SC -- CODEFIX
863 ("`END LOOP;` expected@ for LOOP#!");
864 else
865 Error_Msg_SC -- CODEFIX
866 ("`END LOOP &;` expected@!");
867 end if;
869 elsif End_Type = E_Record then
870 Error_Msg_SC -- CODEFIX
871 ("`END RECORD;` expected@ for RECORD#!");
873 elsif End_Type = E_Return then
874 Error_Msg_SC -- CODEFIX
875 ("`END RETURN;` expected@ for RETURN#!");
877 elsif End_Type = E_Select then
878 Error_Msg_SC -- CODEFIX
879 ("`END SELECT;` expected@ for SELECT#!");
881 -- All remaining cases are cases with a name (we do not treat
882 -- the suspicious is cases specially for a replaced end, only
883 -- for an inserted end).
885 elsif End_Type = E_Name or else (not Ins) then
886 if Error_Msg_Node_1 = Empty then
887 Error_Msg_SC -- CODEFIX
888 ("`END;` expected@ for BEGIN#!");
889 else
890 Error_Msg_SC -- CODEFIX
891 ("`END &;` expected@!");
892 end if;
894 -- The other possibility is a missing END for a subprogram with a
895 -- suspicious IS (that probably should have been a semicolon). The
896 -- Missing IS confirms the suspicion!
898 else -- End_Type = E_Suspicious_Is or E_Bad_Is
899 Scope.Table (Scope.Last).Etyp := E_Bad_Is;
900 end if;
901 end Output_End_Expected;
903 ------------------------
904 -- Output End Missing --
905 ------------------------
907 procedure Output_End_Missing is
908 End_Type : SS_End_Type;
910 begin
911 -- Suppress message if this was a potentially junk entry (e.g. a
912 -- record entry where no record keyword was present.
914 if Scope.Table (Scope.Last).Junk then
915 return;
916 end if;
918 End_Type := Scope.Table (Scope.Last).Etyp;
919 Error_Msg_Sloc := Scope.Table (Scope.Last).Sloc;
921 if Explicit_Start_Label (Scope.Last) then
922 Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl;
923 else
924 Error_Msg_Node_1 := Empty;
925 end if;
927 if End_Type = E_Case then
928 Error_Msg_BC ("missing `END CASE;` for CASE#!");
930 elsif End_Type = E_If then
931 Error_Msg_BC ("missing `END IF;` for IF#!");
933 elsif End_Type = E_Loop then
934 if Error_Msg_Node_1 = Empty then
935 Error_Msg_BC ("missing `END LOOP;` for LOOP#!");
936 else
937 Error_Msg_BC ("missing `END LOOP &;`!");
938 end if;
940 elsif End_Type = E_Record then
941 Error_Msg_SC
942 ("missing `END RECORD;` for RECORD#!");
944 elsif End_Type = E_Return then
945 Error_Msg_SC
946 ("missing `END RETURN;` for RETURN#!");
948 elsif End_Type = E_Select then
949 Error_Msg_BC
950 ("missing `END SELECT;` for SELECT#!");
952 elsif End_Type = E_Name then
953 if Error_Msg_Node_1 = Empty then
954 Error_Msg_BC ("missing `END;` for BEGIN#!");
955 else
956 Error_Msg_BC ("missing `END &;`!");
957 end if;
959 else -- End_Type = E_Suspicious_Is or E_Bad_Is
960 Scope.Table (Scope.Last).Etyp := E_Bad_Is;
961 end if;
962 end Output_End_Missing;
964 ---------------------
965 -- Pop End Context --
966 ---------------------
968 procedure Pop_End_Context is
970 Pretty_Good : Boolean;
971 -- This flag is set True if the END sequence is syntactically incorrect,
972 -- but is (from a heuristic point of view), pretty likely to be simply
973 -- a misspelling of the intended END.
975 Outer_Match : Boolean;
976 -- This flag is set True if we decide that the current END sequence
977 -- belongs to some outer level entry in the scope stack, and thus
978 -- we will NOT eat it up in matching the current expected END.
980 begin
981 -- If not at END, then output END expected message
983 if End_Type = E_Dummy then
984 Output_End_Missing;
985 Pop_Scope_Stack;
986 End_Action := Insert_And_Accept;
987 return;
989 -- Otherwise we do have an END present
991 else
992 -- A special check. If we have END; followed by an end of file,
993 -- WITH or SEPARATE, then if we are not at the outer level, then
994 -- we have a syntax error. Consider the example:
996 -- ...
997 -- declare
998 -- X : Integer;
999 -- begin
1000 -- X := Father (A);
1001 -- Process (X, X);
1002 -- end;
1003 -- with Package1;
1004 -- ...
1006 -- Now the END; here is a syntactically correct closer for the
1007 -- declare block, but if we eat it up, then we obviously have
1008 -- a missing END for the outer context (since WITH can only appear
1009 -- at the outer level.
1011 -- In this situation, we always reserve the END; for the outer level,
1012 -- even if it is in the wrong column. This is because it's much more
1013 -- useful to have the error message point to the DECLARE than to the
1014 -- package header in this case.
1016 -- We also reserve an end with a name before the end of file if the
1017 -- name is the one we expect at the outer level.
1019 if (Token = Tok_EOF or else
1020 Token = Tok_With or else
1021 Token = Tok_Separate)
1022 and then End_Type >= E_Name
1023 and then (not End_Labl_Present
1024 or else Same_Label (End_Labl, Scope.Table (1).Labl))
1025 and then Scope.Last > 1
1026 then
1027 Restore_Scan_State (Scan_State); -- to END
1028 Output_End_Expected (Ins => True);
1029 Pop_Scope_Stack;
1030 End_Action := Insert_And_Accept;
1031 return;
1032 end if;
1034 -- Otherwise we go through the normal END evaluation procedure
1036 Evaluate_End_Entry (Scope.Last);
1038 -- If top entry in stack is syntactically correct, then we have
1039 -- scanned it out and everything is fine. This is the required
1040 -- action to properly process correct Ada programs.
1042 if Syntax_OK then
1044 -- Complain if checking columns and END is not in right column.
1045 -- Right in this context means exactly right, or on the same
1046 -- line as the opener.
1048 if RM_Column_Check then
1049 if End_Column /= Scope.Table (Scope.Last).Ecol
1050 and then Current_Line_Start > Scope.Table (Scope.Last).Sloc
1052 -- A special case, for END RECORD, we are also allowed to
1053 -- line up with the TYPE keyword opening the declaration.
1055 and then (Scope.Table (Scope.Last).Etyp /= E_Record
1056 or else Get_Column_Number (End_Sloc) /=
1057 Get_Column_Number (Type_Token_Location))
1058 then
1059 Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
1060 Error_Msg
1061 ("(style) END in wrong column, should be@", End_Sloc);
1062 end if;
1063 end if;
1065 -- One final check. If the end had a label, check for an exact
1066 -- duplicate of this end sequence, and if so, skip it with an
1067 -- appropriate message.
1069 if End_Labl_Present and then Token = Tok_End then
1070 declare
1071 Scan_State : Saved_Scan_State;
1072 End_Loc : constant Source_Ptr := Token_Ptr;
1073 Nxt_Labl : Node_Id;
1074 Dup_Found : Boolean := False;
1076 begin
1077 Save_Scan_State (Scan_State);
1079 Scan; -- past END
1081 if Token = Tok_Identifier
1082 or else Token = Tok_Operator_Symbol
1083 then
1084 Nxt_Labl := P_Designator;
1086 -- We only consider it an error if the label is a match
1087 -- and would be wrong for the level one above us, and
1088 -- the indentation is the same.
1090 if Token = Tok_Semicolon
1091 and then Same_Label (End_Labl, Nxt_Labl)
1092 and then End_Column = Start_Column
1093 and then
1094 (Scope.Last = 1
1095 or else
1096 (not Explicit_Start_Label (Scope.Last - 1))
1097 or else
1098 (not Same_Label
1099 (End_Labl,
1100 Scope.Table (Scope.Last - 1).Labl)))
1101 then
1102 T_Semicolon;
1103 Error_Msg ("duplicate end line ignored", End_Loc);
1104 Dup_Found := True;
1105 end if;
1106 end if;
1108 if not Dup_Found then
1109 Restore_Scan_State (Scan_State);
1110 end if;
1111 end;
1112 end if;
1114 -- All OK, so return to caller indicating END is OK
1116 Pop_Scope_Stack;
1117 End_Action := Accept_As_Scanned;
1118 return;
1119 end if;
1121 -- If that check failed, then we definitely have an error. The issue
1122 -- is how to choose among three possible courses of action:
1124 -- 1. Ignore the current END text completely, scanning past it,
1125 -- deciding that it belongs neither to the current context,
1126 -- nor to any outer context.
1128 -- 2. Accept the current END text, scanning past it, and issuing
1129 -- an error message that it does not have the right form.
1131 -- 3. Leave the current END text in place, NOT scanning past it,
1132 -- issuing an error message indicating the END expected for the
1133 -- current context. In this case, the END is available to match
1134 -- some outer END context.
1136 -- From a correct functioning point of view, it does not make any
1137 -- difference which of these three approaches we take, the program
1138 -- will work correctly in any case. However, making an accurate
1139 -- choice among these alternatives, i.e. choosing the one that
1140 -- corresponds to what the programmer had in mind, does make a
1141 -- significant difference in the quality of error recovery.
1143 Restore_Scan_State (Scan_State); -- to END
1145 -- First we see how good the current END entry is with respect to
1146 -- what we expect. It is considered pretty good if the token is OK,
1147 -- and either the label or the column matches. An END for RECORD is
1148 -- always considered to be pretty good in the record case. This is
1149 -- because not only does a record disallow a nested structure, but
1150 -- also it is unlikely that such nesting could occur by accident.
1152 Pretty_Good := (Token_OK and (Column_OK or Label_OK))
1153 or else Scope.Table (Scope.Last).Etyp = E_Record;
1155 -- Next check, if there is a deeper entry in the stack which
1156 -- has a very high probability of being acceptable, then insert
1157 -- the END entry we want, leaving the higher level entry for later
1159 for J in reverse 1 .. Scope.Last - 1 loop
1160 Evaluate_End_Entry (J);
1162 -- To even consider the deeper entry to be immediately acceptable,
1163 -- it must be syntactically correct. Furthermore it must either
1164 -- have a correct label, or the correct column. If the current
1165 -- entry was a close match (Pretty_Good set), then we are even
1166 -- more strict in accepting the outer level one: even if it has
1167 -- the right label, it must have the right column as well.
1169 if Syntax_OK then
1170 if Pretty_Good then
1171 Outer_Match := Label_OK and Column_OK;
1172 else
1173 Outer_Match := Label_OK or Column_OK;
1174 end if;
1175 else
1176 Outer_Match := False;
1177 end if;
1179 -- If the outer entry does convincingly match the END text, then
1180 -- back up the scan to the start of the END sequence, issue an
1181 -- error message indicating the END we expected, and return with
1182 -- Token pointing to the END (case 3 from above discussion).
1184 if Outer_Match then
1185 Output_End_Missing;
1186 Pop_Scope_Stack;
1187 End_Action := Insert_And_Accept;
1188 return;
1189 end if;
1190 end loop;
1192 -- Here we have a situation in which the current END entry is
1193 -- syntactically incorrect, but there is no deeper entry in the
1194 -- END stack which convincingly matches it.
1196 -- If the END text was judged to be a Pretty_Good match for the
1197 -- expected token or if it appears left of the expected column,
1198 -- then we will accept it as the one we want, scanning past it, even
1199 -- though it is not completely right (we issue a message showing what
1200 -- we expected it to be). This is action 2 from the discussion above.
1201 -- There is one other special case to consider: the LOOP case.
1202 -- Consider the example:
1204 -- Lbl: loop
1205 -- null;
1206 -- end loop;
1208 -- Here the column lines up with Lbl, so END LOOP is to the right,
1209 -- but it is still acceptable. LOOP is the one case where alignment
1210 -- practices vary substantially in practice.
1212 if Pretty_Good
1213 or else End_Column <= Scope.Table (Scope.Last).Ecol
1214 or else (End_Type = Scope.Table (Scope.Last).Etyp
1215 and then End_Type = E_Loop)
1216 then
1217 Output_End_Expected (Ins => False);
1218 Pop_Scope_Stack;
1219 End_Action := Skip_And_Accept;
1220 return;
1222 -- Here we have the case where the END is to the right of the
1223 -- expected column and does not have a correct label to convince
1224 -- us that it nevertheless belongs to the current scope. For this
1225 -- we consider that it probably belongs not to the current context,
1226 -- but to some inner context that was not properly recognized (due to
1227 -- other syntax errors), and for which no proper scope stack entry
1228 -- was made. The proper action in this case is to delete the END text
1229 -- and return False to the caller as a signal to keep on looking for
1230 -- an acceptable END. This is action 1 from the discussion above.
1232 else
1233 Output_End_Deleted;
1234 End_Action := Skip_And_Reject;
1235 return;
1236 end if;
1237 end if;
1238 end Pop_End_Context;
1240 ----------------
1241 -- Same_Label --
1242 ----------------
1244 function Same_Label (Label1, Label2 : Node_Id) return Boolean is
1245 begin
1246 if Nkind (Label1) in N_Has_Chars
1247 and then Nkind (Label2) in N_Has_Chars
1248 then
1249 return Chars (Label1) = Chars (Label2);
1251 elsif Nkind (Label1) = N_Selected_Component
1252 and then Nkind (Label2) = N_Selected_Component
1253 then
1254 return Same_Label (Prefix (Label1), Prefix (Label2)) and then
1255 Same_Label (Selector_Name (Label1), Selector_Name (Label2));
1257 elsif Nkind (Label1) = N_Designator
1258 and then Nkind (Label2) = N_Defining_Program_Unit_Name
1259 then
1260 return Same_Label (Name (Label1), Name (Label2)) and then
1261 Same_Label (Identifier (Label1), Defining_Identifier (Label2));
1263 else
1264 return False;
1265 end if;
1266 end Same_Label;
1268 end Endh;