summaryrefslogtreecommitdiff
path: root/gcc/ada/par-endh.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/ada/par-endh.adb')
-rw-r--r--gcc/ada/par-endh.adb1191
1 files changed, 1191 insertions, 0 deletions
diff --git a/gcc/ada/par-endh.adb b/gcc/ada/par-endh.adb
new file mode 100644
index 00000000000..fa5b8c20a1a
--- /dev/null
+++ b/gcc/ada/par-endh.adb
@@ -0,0 +1,1191 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- P A R . E N D H --
+-- --
+-- B o d y --
+-- --
+-- $Revision: 1.61 $
+-- --
+-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+with Stringt; use Stringt;
+with Uintp; use Uintp;
+
+with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
+
+separate (Par)
+package body Endh is
+
+ ----------------
+ -- Local Data --
+ ----------------
+
+ type End_Action_Type is (
+ -- Type used to describe the result of the Pop_End_Context call
+
+ Accept_As_Scanned,
+ -- Current end sequence is entirely c correct. In this case Token and
+ -- the scan pointer are left pointing past the end sequence (i.e. they
+ -- are unchanged from the values set on entry to Pop_End_Context).
+
+ Insert_And_Accept,
+ -- Current end sequence is to be left in place to satisfy some outer
+ -- scope. Token and the scan pointer are set to point to the end
+ -- token, and should be left there. A message has been generated
+ -- indicating a missing end sequence. This status is also used for
+ -- the case when no end token is present.
+
+ Skip_And_Accept,
+ -- The end sequence is incorrect (and an error message has been
+ -- posted), but it will still be accepted. In this case Token and
+ -- the scan pointer point back to the end token, and the caller
+ -- should skip past the end sequence before proceeding.
+
+ Skip_And_Reject);
+ -- The end sequence is judged to belong to an unrecognized inner
+ -- scope. An appropriate message has been issued and the caller
+ -- should skip past the end sequence and then proceed as though
+ -- no end sequence had been encountered.
+
+ End_Action : End_Action_Type;
+ -- The variable set by Pop_End_Context call showing which of the four
+ -- decisions described above is judged the best.
+
+ End_Sloc : Source_Ptr;
+ -- Source location of END token
+
+ End_OK : Boolean;
+ -- Set False if error is found in END line
+
+ End_Column : Column_Number;
+ -- Column of END line
+
+ End_Type : SS_End_Type;
+ -- Type of END expected. The special value E_Dummy is set to indicate that
+ -- no END token was present (so a missing END inserted message is needed)
+
+ End_Labl : Node_Id;
+ -- Node_Id value for explicit name on END line, or for compiler supplied
+ -- name in the case where an optional name is not given. Empty if no name
+ -- appears. If non-empty, then it is either an N_Designator node for a
+ -- child unit or a node with a Chars field identifying the actual label.
+
+ End_Labl_Present : Boolean;
+ -- Indicates that the value in End_Labl was for an explicit label.
+
+ Syntax_OK : Boolean;
+ -- Set True if the entry is syntactically correct
+
+ Token_OK : Boolean;
+ -- Set True if the keyword in the END sequence matches, or if neither
+ -- the END sequence nor the END stack entry has a keyword.
+
+ Label_OK : Boolean;
+ -- Set True if both the END sequence and the END stack entry contained
+ -- labels (other than No_Name or Error_Name) and the labels matched.
+ -- This is a stronger condition than SYNTAX_OK, since it means that a
+ -- label was present, even in a case where it was optional. Note that
+ -- the case of no label required, and no label present does NOT set
+ -- Label_OK to True, it is True only if a positive label match is found.
+
+ Column_OK : Boolean;
+ -- Column_OK is set True if the END sequence appears in the expected column
+
+ Scan_State : Saved_Scan_State;
+ -- Save state at start of END sequence, in case we decide not to eat it up
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Evaluate_End_Entry (SS_Index : Int);
+ -- Compare scanned END entry (as recorded by a prior call to P_End_Scan)
+ -- with a specified entry in the scope stack (the single parameter is the
+ -- entry index in the scope stack). Note that Scan is not called. The above
+ -- variables xxx_OK are set to indicate the result of the evaluation.
+
+ procedure Output_End_Deleted;
+ -- Output a message complaining that the current END structure does not
+ -- match anything and is being deleted.
+
+ procedure Output_End_Expected (Ins : Boolean);
+ -- Output a message at the start of the current token which is always an
+ -- END, complaining that the END is not of the right form. The message
+ -- indicates the expected form. The information for the message is taken
+ -- from the top entry in the scope stack. The Ins parameter is True if
+ -- an end is being inserted, and false if an existing end is being
+ -- replaced. Note that in the case of a suspicious IS for the Ins case,
+ -- we do not output the message, but instead simply mark the scope stack
+ -- entry as being a case of a bad IS.
+
+ procedure Output_End_Missing;
+ -- Output a message just before the current token, complaining that the
+ -- END is not of the right form. The message indicates the expected form.
+ -- The information for the message is taken from the top entry in the
+ -- scope stack. Note that in the case of a suspicious IS, we do not output
+ -- the message, but instead simply mark the scope stack entry as a bad IS.
+
+ procedure Pop_End_Context;
+ -- Pop_End_Context is called after processing a construct, to pop the
+ -- top entry off the end stack. It decides on the appropriate action to
+ -- to take, signalling the result by setting End_Action as described in
+ -- the global variable section.
+
+ function Same_Label (Label1, Label2 : Node_Id) return Boolean;
+ -- This function compares the two names associated with the given nodes.
+ -- If they are both simple (i.e. have Chars fields), then they have to
+ -- be the same name. Otherwise they must both be N_Selected_Component
+ -- nodes, referring to the same set of names, or Label1 is an N_Designator
+ -- referring to the same set of names as the N_Defining_Program_Unit_Name
+ -- in Label2. Any other combination returns False. This routine is used
+ -- to compare the End_Labl scanned from the End line with the saved label
+ -- value in the scope stack.
+
+ ---------------
+ -- Check_End --
+ ---------------
+
+ function Check_End return Boolean is
+ Name_On_Separate_Line : Boolean;
+ -- Set True if the name on an END line is on a separate source line
+ -- from the END. This is highly suspicious, but is allowed. The point
+ -- is that we want to make sure that we don't just have a missing
+ -- semicolon misleading us into swallowing an identifier from the
+ -- following line.
+
+ Name_Scan_State : Saved_Scan_State;
+ -- Save state at start of name if Name_On_Separate_Line is TRUE
+
+ Span_Node : constant Node_Id := Scope.Table (Scope.Last).Node;
+
+ begin
+ End_Labl_Present := False;
+ End_Labl := Empty;
+
+ -- Our first task is to scan out the END sequence if one is present.
+ -- If none is present, signal by setting End_Type to E_Dummy.
+
+ if Token /= Tok_End then
+ End_Type := E_Dummy;
+
+ else
+ Save_Scan_State (Scan_State); -- at END
+ End_Sloc := Token_Ptr;
+ End_Column := Start_Column;
+ End_OK := True;
+ Scan; -- past END
+
+ -- Set End_Span if expected. note that this will be useless
+ -- if we do not have the right ending keyword, but in this
+ -- case we have a malformed program anyway, and the setting
+ -- of End_Span will simply be unreliable in this case anyway.
+
+ if Present (Span_Node) then
+ Set_End_Location (Span_Node, Token_Ptr);
+ end if;
+
+ -- Cases of keywords where no label is allowed
+
+ if Token = Tok_Case then
+ End_Type := E_Case;
+ Scan; -- past CASE
+
+ elsif Token = Tok_If then
+ End_Type := E_If;
+ Scan; -- past IF
+
+ elsif Token = Tok_Record then
+ End_Type := E_Record;
+ Scan; -- past RECORD
+
+ elsif Token = Tok_Select then
+ End_Type := E_Select;
+ Scan; -- past SELECT
+
+ -- Cases which do allow labels
+
+ else
+ -- LOOP
+
+ if Token = Tok_Loop then
+ Scan; -- past LOOP
+ End_Type := E_Loop;
+
+ -- FOR or WHILE allowed (signalling error) to substitute for LOOP
+ -- if on the same line as the END
+
+ elsif (Token = Tok_For or else Token = Tok_While)
+ and then not Token_Is_At_Start_Of_Line
+ then
+ Scan; -- past FOR or WHILE
+ End_Type := E_Loop;
+ End_OK := False;
+
+ -- Cases with no keyword
+
+ else
+ End_Type := E_Name;
+ end if;
+
+ -- Now see if a name is present
+
+ if Token = Tok_Identifier or else
+ Token = Tok_String_Literal or else
+ Token = Tok_Operator_Symbol
+ then
+ if Token_Is_At_Start_Of_Line then
+ Name_On_Separate_Line := True;
+ Save_Scan_State (Name_Scan_State);
+ else
+ Name_On_Separate_Line := False;
+ end if;
+
+ End_Labl := P_Designator;
+ End_Labl_Present := True;
+
+ -- We have now scanned out a name. Here is where we do a check
+ -- to catch the cases like:
+ --
+ -- end loop
+ -- X := 3;
+ --
+ -- where the missing semicolon might make us swallow up the X
+ -- as a bogus end label. In a situation like this, where the
+ -- apparent name is on a separate line, we accept it only if
+ -- it matches the label and is followed by a semicolon.
+
+ if Name_On_Separate_Line then
+ if Token /= Tok_Semicolon or else
+ not Same_Label (End_Labl, Scope.Table (Scope.Last).Labl)
+ then
+ Restore_Scan_State (Name_Scan_State);
+ End_Labl := Empty;
+ End_Labl_Present := False;
+ end if;
+ end if;
+
+ -- Here for case of name allowed, but no name present. We will
+ -- supply an implicit matching name, with source location set
+ -- to the scan location past the END token.
+
+ else
+ End_Labl := Scope.Table (Scope.Last).Labl;
+
+ if End_Labl > Empty_Or_Error then
+
+ -- The task here is to construct a designator from the
+ -- opening label, with the components all marked as not
+ -- from source, and Is_End_Label set in the identifier
+ -- or operator symbol. The location for all components
+ -- is the curent token location.
+
+ -- Case of child unit name
+
+ if Nkind (End_Labl) = N_Defining_Program_Unit_Name then
+ declare
+ Eref : constant Node_Id :=
+ Make_Identifier (Token_Ptr,
+ Chars =>
+ Chars (Defining_Identifier (End_Labl)));
+
+ function Copy_Name (N : Node_Id) return Node_Id;
+ -- Copies a selected component or identifier
+
+ function Copy_Name (N : Node_Id) return Node_Id is
+ R : Node_Id;
+
+ begin
+ if Nkind (N) = N_Selected_Component then
+ return
+ Make_Selected_Component (Token_Ptr,
+ Prefix =>
+ Copy_Name (Prefix (N)),
+ Selector_Name =>
+ Copy_Name (Selector_Name (N)));
+
+ else
+ R :=
+ Make_Identifier (Token_Ptr,
+ Chars => Chars (N));
+ Set_Comes_From_Source (N, False);
+ return R;
+ end if;
+ end Copy_Name;
+
+ begin
+ Set_Comes_From_Source (Eref, False);
+
+ End_Labl :=
+ Make_Designator (Token_Ptr,
+ Name => Copy_Name (Name (End_Labl)),
+ Identifier => Eref);
+ end;
+
+ -- Simple identifier case
+
+ elsif Nkind (End_Labl) = N_Defining_Identifier
+ or else Nkind (End_Labl) = N_Identifier
+ then
+ End_Labl :=
+ Make_Identifier (Token_Ptr,
+ Chars => Chars (End_Labl));
+
+ elsif Nkind (End_Labl) = N_Defining_Operator_Symbol
+ or else Nkind (End_Labl) = N_Operator_Symbol
+ then
+ Get_Decoded_Name_String (Chars (End_Labl));
+
+ End_Labl :=
+ Make_Operator_Symbol (Token_Ptr,
+ Chars => Chars (End_Labl),
+ Strval => String_From_Name_Buffer);
+ end if;
+
+ Set_Comes_From_Source (End_Labl, False);
+ End_Labl_Present := False;
+
+ -- Do style check for missing label
+
+ if Style_Check
+ and then End_Type = E_Name
+ and then Present (Scope.Table (Scope.Last).Labl)
+ then
+ Style.No_End_Name (Scope.Table (Scope.Last).Labl);
+ end if;
+ end if;
+ end if;
+ end if;
+
+ -- Except in case of END RECORD, semicolon must follow. For END
+ -- RECORD, a semicolon does follow, but it is part of a higher level
+ -- construct. In any case, a missing semicolon is not serious enough
+ -- to consider the END statement to be bad in the sense that we
+ -- are dealing with (i.e. to be suspicious that it is not in fact
+ -- the END statement we are looking for!)
+
+ if End_Type /= E_Record then
+ if Token = Tok_Semicolon then
+ T_Semicolon;
+
+ -- Semicolon is missing. If the missing semicolon is at the end
+ -- of the line, i.e. we are at the start of the line now, then
+ -- a missing semicolon gets flagged, but is not serious enough
+ -- to consider the END statement to be bad in the sense that we
+ -- are dealing with (i.e. to be suspicious that this END is not
+ -- the END statement we are looking for).
+
+ -- Similarly, if we are at a colon, we flag it but a colon for
+ -- a semicolon is not serious enough to consider the END to be
+ -- incorrect. Same thing for a period in place of a semicolon.
+
+ elsif Token_Is_At_Start_Of_Line
+ or else Token = Tok_Colon
+ or else Token = Tok_Dot
+ then
+ T_Semicolon;
+
+ -- If the missing semicolon is not at the start of the line,
+ -- then we do consider the END line to be dubious in this sense.
+
+ else
+ End_OK := False;
+ end if;
+ end if;
+ end if;
+
+ -- Now we call the Pop_End_Context routine to get a recommendation
+ -- as to what should be done with the END sequence we have scanned.
+
+ Pop_End_Context;
+
+ -- Remaining action depends on End_Action set by Pop_End_Context
+
+ case End_Action is
+
+ -- Accept_As_Scanned. In this case, Pop_End_Context left Token
+ -- pointing past the last token of a syntactically correct END
+
+ when Accept_As_Scanned =>
+
+ -- Syntactically correct included the possibility of a missing
+ -- semicolon. If we do have a missing semicolon, then we have
+ -- already given a message, but now we scan out possible rubbish
+ -- on the same line as the END
+
+ while not Token_Is_At_Start_Of_Line
+ and then Prev_Token /= Tok_Record
+ and then Prev_Token /= Tok_Semicolon
+ and then Token /= Tok_End
+ and then Token /= Tok_EOF
+ loop
+ Scan; -- past junk
+ end loop;
+
+ return True;
+
+ -- Insert_And_Accept. In this case, Pop_End_Context has reset Token
+ -- to point to the start of the END sequence, and recommends that it
+ -- be left in place to satisfy an outer scope level END. This means
+ -- that we proceed as though an END were present, and leave the scan
+ -- pointer unchanged.
+
+ when Insert_And_Accept =>
+ return True;
+
+ -- Skip_And_Accept. In this case, Pop_End_Context has reset Token
+ -- to point to the start of the END sequence. This END sequence is
+ -- syntactically incorrect, and an appropriate error message has
+ -- already been posted. Pop_End_Context recommends accepting the
+ -- END sequence as the one we want, so we skip past it and then
+ -- proceed as though an END were present.
+
+ when Skip_And_Accept =>
+ End_Skip;
+ return True;
+
+ -- Skip_And_Reject. In this case, Pop_End_Context has reset Token
+ -- to point to the start of the END sequence. This END sequence is
+ -- syntactically incorrect, and an appropriate error message has
+ -- already been posted. Pop_End_Context recommends entirely ignoring
+ -- this END sequence, so we skip past it and then return False, since
+ -- as far as the caller is concerned, no END sequence is present.
+
+ when Skip_And_Reject =>
+ End_Skip;
+ return False;
+ end case;
+ end Check_End;
+
+ --------------
+ -- End Skip --
+ --------------
+
+ -- This procedure skips past an END sequence. On entry Token contains
+ -- Tok_End, and we know that the END sequence is syntactically incorrect,
+ -- and that an appropriate error message has already been posted. The
+ -- mission is simply to position the scan pointer to be the best guess of
+ -- the position after the END sequence. We do not issue any additional
+ -- error messages while carrying this out.
+
+ -- Error recovery: does not raise Error_Resync
+
+ procedure End_Skip is
+ begin
+ Scan; -- past END
+
+ -- If the scan past the END leaves us on the next line, that's probably
+ -- where we should quit the scan, since it is likely that what we have
+ -- is a missing semicolon. Consider the following:
+
+ -- END
+ -- Process_Input;
+
+ -- This will have looked like a syntactically valid END sequence to the
+ -- initial scan of the END, but subsequent checking will have determined
+ -- that the label Process_Input is not an appropriate label. The real
+ -- error is a missing semicolon after the END, and by leaving the scan
+ -- pointer just past the END, we will improve the error recovery.
+
+ if Token_Is_At_Start_Of_Line then
+ return;
+ end if;
+
+ -- If there is a semicolon after the END, scan it out and we are done
+
+ if Token = Tok_Semicolon then
+ T_Semicolon;
+ return;
+ end if;
+
+ -- Otherwise skip past a token after the END on the same line. Note
+ -- that we do not eat a token on the following line since it seems
+ -- very unlikely in any case that the END gets separated from its
+ -- token, and we do not want to swallow up a keyword that starts a
+ -- legitimate construct following the bad END.
+
+ if not Token_Is_At_Start_Of_Line
+ and then
+
+ -- Cases of normal tokens following an END
+
+ (Token = Tok_Case or else
+ Token = Tok_For or else
+ Token = Tok_If or else
+ Token = Tok_Loop or else
+ Token = Tok_Record or else
+ Token = Tok_Select or else
+
+ -- Cases of bogus keywords ending loops
+
+ Token = Tok_For or else
+ Token = Tok_While or else
+
+ -- Cases of operator symbol names without quotes
+
+ Token = Tok_Abs or else
+ Token = Tok_And or else
+ Token = Tok_Mod or else
+ Token = Tok_Not or else
+ Token = Tok_Or or else
+ Token = Tok_Xor)
+
+ then
+ Scan; -- past token after END
+
+ -- If that leaves us on the next line, then we are done. This is the
+ -- same principle described above for the case of END at line end
+
+ if Token_Is_At_Start_Of_Line then
+ return;
+
+ -- If we just scanned out record, then we are done, since the
+ -- semicolon after END RECORD is not part of the END sequence
+
+ elsif Prev_Token = Tok_Record then
+ return;
+
+ -- If we have a semicolon, scan it out and we are done
+
+ elsif Token = Tok_Semicolon then
+ T_Semicolon;
+ return;
+ end if;
+ end if;
+
+ -- Check for a label present on the same line
+
+ loop
+ if Token_Is_At_Start_Of_Line then
+ return;
+ end if;
+
+ if Token /= Tok_Identifier
+ and then Token /= Tok_Operator_Symbol
+ and then Token /= Tok_String_Literal
+ then
+ exit;
+ end if;
+
+ Scan; -- past identifier, operator symbol or string literal
+
+ if Token_Is_At_Start_Of_Line then
+ return;
+ elsif Token = Tok_Dot then
+ Scan; -- past dot
+ end if;
+ end loop;
+
+ -- Skip final semicolon
+
+ if Token = Tok_Semicolon then
+ T_Semicolon;
+
+ -- If we don't have a final semicolon, skip until we either encounter
+ -- an END token, or a semicolon or the start of the next line. This
+ -- allows general junk to follow the end line (normally it is hard to
+ -- think that anyone will put anything deliberate here, and remember
+ -- that we know there is a missing semicolon in any case). We also
+ -- quite on an EOF (or else we would get stuck in an infinite loop
+ -- if there is no line end at the end of the last line of the file)
+
+ else
+ while Token /= Tok_End
+ and then Token /= Tok_EOF
+ and then Token /= Tok_Semicolon
+ and then not Token_Is_At_Start_Of_Line
+ loop
+ Scan; -- past junk token on same line
+ end loop;
+ end if;
+
+ return;
+ end End_Skip;
+
+ --------------------
+ -- End Statements --
+ --------------------
+
+ -- This procedure is called when END is required or expected to terminate
+ -- a sequence of statements. The caller has already made an appropriate
+ -- entry on the scope stack to describe the expected form of the END.
+ -- End_Statements should only be used in cases where the only appropriate
+ -- terminator is END.
+
+ -- Error recovery: cannot raise Error_Resync;
+
+ procedure End_Statements (Parent : Node_Id := Empty) is
+ begin
+ -- This loop runs more than once in the case where Check_End rejects
+ -- the END sequence, as indicated by Check_End returning False.
+
+ loop
+ if Check_End then
+ if Present (Parent) then
+ Set_End_Label (Parent, End_Labl);
+ end if;
+
+ return;
+ end if;
+
+ -- Extra statements past the bogus END are discarded. This is not
+ -- ideal for maximum error recovery, but it's too much trouble to
+ -- find an appropriate place to put them!
+
+ Discard_Junk_List (P_Sequence_Of_Statements (SS_None));
+ end loop;
+ end End_Statements;
+
+ ------------------------
+ -- Evaluate End Entry --
+ ------------------------
+
+ procedure Evaluate_End_Entry (SS_Index : Int) is
+ begin
+ Column_OK := (End_Column = Scope.Table (SS_Index).Ecol);
+
+ Token_OK := (End_Type = Scope.Table (SS_Index).Etyp or else
+ (End_Type = E_Name and then
+ Scope.Table (SS_Index).Etyp >= E_Name));
+
+ Label_OK := End_Labl_Present
+ and then
+ (Same_Label (End_Labl, Scope.Table (SS_Index).Labl)
+ or else Scope.Table (SS_Index).Labl = Error);
+
+ -- Compute setting of Syntax_OK. We definitely have a syntax error
+ -- if the Token does not match properly or if P_End_Scan detected
+ -- a syntax error such as a missing semicolon.
+
+ if not Token_OK or not End_OK then
+ Syntax_OK := False;
+
+ -- Final check is that label is OK. Certainly it is OK if there
+ -- was an exact match on the label (the END label = the stack label)
+
+ elsif Label_OK then
+ Syntax_OK := True;
+
+ -- Case of label present
+
+ elsif End_Labl_Present then
+
+ -- If probably misspelling, then complain, and pretend it is OK
+
+ declare
+ Nam : constant Node_Or_Entity_Id := Scope.Table (SS_Index).Labl;
+
+ begin
+ if Nkind (End_Labl) in N_Has_Chars
+ and then Nkind (Nam) in N_Has_Chars
+ and then Chars (End_Labl) > Error_Name
+ and then Chars (Nam) > Error_Name
+ then
+ Get_Name_String (Chars (End_Labl));
+ Error_Msg_Name_1 := Chars (Nam);
+
+ if Error_Msg_Name_1 > Error_Name then
+ declare
+ S : String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
+
+ begin
+ Get_Name_String (Error_Msg_Name_1);
+
+ if Is_Bad_Spelling_Of
+ (Name_Buffer (1 .. Name_Len), S)
+ then
+ Error_Msg_N ("misspelling of %", End_Labl);
+ Syntax_OK := True;
+ return;
+ end if;
+ end;
+ end if;
+ end if;
+ end;
+
+ Syntax_OK := False;
+
+ -- Otherwise we have cases of no label on the END line. For the loop
+ -- case, this is acceptable only if the loop is unlabeled.
+
+ elsif End_Type = E_Loop then
+ Syntax_OK := (Scope.Table (SS_Index).Labl = Empty);
+
+ -- Cases where a label is definitely allowed on the END line
+
+ elsif End_Type = E_Name then
+ Syntax_OK := (Scope.Table (SS_Index).Labl = Empty or else
+ not Scope.Table (SS_Index).Lreq);
+
+ -- Otherwise we have cases which don't allow labels anyway, so we
+ -- certainly accept an END which does not have a label.
+
+ else
+ Syntax_OK := True;
+ end if;
+ end Evaluate_End_Entry;
+
+ ------------------------
+ -- Output End Deleted --
+ ------------------------
+
+ procedure Output_End_Deleted is
+ begin
+
+ if End_Type = E_Loop then
+ Error_Msg_SC ("no LOOP for this `END LOOP`!");
+
+ elsif End_Type = E_Case then
+ Error_Msg_SC ("no CASE for this `END CASE`");
+
+ elsif End_Type = E_If then
+ Error_Msg_SC ("no IF for this `END IF`!");
+
+ elsif End_Type = E_Record then
+ Error_Msg_SC ("no RECORD for this `END RECORD`!");
+
+ elsif End_Type = E_Select then
+ Error_Msg_SC ("no SELECT for this `END SELECT`!");
+
+ else
+ Error_Msg_SC ("no BEGIN for this END!");
+ end if;
+ end Output_End_Deleted;
+
+ -------------------------
+ -- Output End Expected --
+ -------------------------
+
+ procedure Output_End_Expected (Ins : Boolean) is
+ End_Type : SS_End_Type;
+
+ begin
+ -- Suppress message if this was a potentially junk entry (e.g. a
+ -- record entry where no record keyword was present.
+
+ if Scope.Table (Scope.Last).Junk then
+ return;
+ end if;
+
+ End_Type := Scope.Table (Scope.Last).Etyp;
+ Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
+ Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl;
+ Error_Msg_Sloc := Scope.Table (Scope.Last).Sloc;
+
+ -- Suppress message if error was posted on opening label
+
+ if Present (Error_Msg_Node_1)
+ and then Error_Posted (Error_Msg_Node_1)
+ then
+ return;
+ end if;
+
+ if End_Type = E_Case then
+ Error_Msg_SC ("`END CASE;` expected@ for CASE#!");
+
+ elsif End_Type = E_If then
+ Error_Msg_SC ("`END IF;` expected@ for IF#!");
+
+ elsif End_Type = E_Loop then
+ if Error_Msg_Node_1 = Empty then
+ Error_Msg_SC
+ ("`END LOOP;` expected@ for LOOP#!");
+ else
+ Error_Msg_SC ("`END LOOP &;` expected@!");
+ end if;
+
+ elsif End_Type = E_Record then
+ Error_Msg_SC
+ ("`END RECORD;` expected@ for RECORD#!");
+
+ elsif End_Type = E_Select then
+ Error_Msg_SC
+ ("`END SELECT;` expected@ for SELECT#!");
+
+ -- All remaining cases are cases with a name (we do not treat
+ -- the suspicious is cases specially for a replaced end, only
+ -- for an inserted end).
+
+ elsif End_Type = E_Name or else (not Ins) then
+ if Error_Msg_Node_1 = Empty then
+ Error_Msg_SC ("`END;` expected@ for BEGIN#!");
+ else
+ Error_Msg_SC ("`END &;` expected@!");
+ end if;
+
+ -- The other possibility is a missing END for a subprogram with a
+ -- suspicious IS (that probably should have been a semicolon). The
+ -- Missing IS confirms the suspicion!
+
+ else -- End_Type = E_Suspicious_Is or E_Bad_Is
+ Scope.Table (Scope.Last).Etyp := E_Bad_Is;
+ end if;
+ end Output_End_Expected;
+
+ ------------------------
+ -- Output End Missing --
+ ------------------------
+
+ procedure Output_End_Missing is
+ End_Type : SS_End_Type;
+
+ begin
+ -- Suppress message if this was a potentially junk entry (e.g. a
+ -- record entry where no record keyword was present.
+
+ if Scope.Table (Scope.Last).Junk then
+ return;
+ end if;
+
+ End_Type := Scope.Table (Scope.Last).Etyp;
+ Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl;
+ Error_Msg_Sloc := Scope.Table (Scope.Last).Sloc;
+
+ if End_Type = E_Case then
+ Error_Msg_BC ("missing `END CASE;` for CASE#!");
+
+ elsif End_Type = E_If then
+ Error_Msg_BC ("missing `END IF;` for IF#!");
+
+ elsif End_Type = E_Loop then
+ if Error_Msg_Node_1 = Empty then
+ Error_Msg_BC ("missing `END LOOP;` for LOOP#!");
+ else
+ Error_Msg_BC ("missing `END LOOP &;`!");
+ end if;
+
+ elsif End_Type = E_Record then
+ Error_Msg_SC
+ ("missing `END RECORD;` for RECORD#!");
+
+ elsif End_Type = E_Select then
+ Error_Msg_BC
+ ("missing `END SELECT;` for SELECT#!");
+
+ elsif End_Type = E_Name then
+ if Error_Msg_Node_1 = Empty then
+ Error_Msg_BC ("missing `END;` for BEGIN#!");
+ else
+ Error_Msg_BC ("missing `END &;`!");
+ end if;
+
+ else -- End_Type = E_Suspicious_Is or E_Bad_Is
+ Scope.Table (Scope.Last).Etyp := E_Bad_Is;
+ end if;
+ end Output_End_Missing;
+
+ ---------------------
+ -- Pop End Context --
+ ---------------------
+
+ procedure Pop_End_Context is
+
+ Pretty_Good : Boolean;
+ -- This flag is set True if the END sequence is syntactically incorrect,
+ -- but is (from a heuristic point of view), pretty likely to be simply
+ -- a misspelling of the intended END.
+
+ Outer_Match : Boolean;
+ -- This flag is set True if we decide that the current END sequence
+ -- belongs to some outer level entry in the scope stack, and thus
+ -- we will NOT eat it up in matching the current expected END.
+
+ begin
+ -- If not at END, then output END expected message
+
+ if End_Type = E_Dummy then
+ Output_End_Missing;
+ Pop_Scope_Stack;
+ End_Action := Insert_And_Accept;
+ return;
+
+ -- Otherwise we do have an END present
+
+ else
+ -- A special check. If we have END; followed by an end of file,
+ -- WITH or SEPARATE, then if we are not at the outer level, then
+ -- we have a sytax error. Consider the example:
+
+ -- ...
+ -- declare
+ -- X : Integer;
+ -- begin
+ -- X := Father (A);
+ -- Process (X, X);
+ -- end;
+ -- with Package1;
+ -- ...
+
+ -- Now the END; here is a syntactically correct closer for the
+ -- declare block, but if we eat it up, then we obviously have
+ -- a missing END for the outer context (since WITH can only appear
+ -- at the outer level.
+
+ -- In this situation, we always reserve the END; for the outer level,
+ -- even if it is in the wrong column. This is because it's much more
+ -- useful to have the error message point to the DECLARE than to the
+ -- package header in this case.
+
+ -- We also reserve an end with a name before the end of file if the
+ -- name is the one we expect at the outer level.
+
+ if (Token = Tok_EOF or else
+ Token = Tok_With or else
+ Token = Tok_Separate)
+ and then End_Type >= E_Name
+ and then (not End_Labl_Present
+ or else Same_Label (End_Labl, Scope.Table (1).Labl))
+ and then Scope.Last > 1
+ then
+ Restore_Scan_State (Scan_State); -- to END
+ Output_End_Expected (Ins => True);
+ Pop_Scope_Stack;
+ End_Action := Insert_And_Accept;
+ return;
+ end if;
+
+ -- Otherwise we go through the normal END evaluation procedure
+
+ Evaluate_End_Entry (Scope.Last);
+
+ -- If top entry in stack is syntactically correct, then we have
+ -- scanned it out and everything is fine. This is the required
+ -- action to properly process correct Ada programs.
+
+ if Syntax_OK then
+
+ -- Complain if checking columns and END is not in right column.
+ -- Right in this context means exactly right, or on the same
+ -- line as the opener.
+
+ if Style.RM_Column_Check then
+ if End_Column /= Scope.Table (Scope.Last).Ecol
+ and then Current_Line_Start > Scope.Table (Scope.Last).Sloc
+ then
+ Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
+ Error_Msg
+ ("(style) END in wrong column, should be@", End_Sloc);
+ end if;
+ end if;
+
+ -- One final check. If the end had a label, check for an exact
+ -- duplicate of this end sequence, and if so, skip it with an
+ -- appropriate message.
+
+ if End_Labl_Present and then Token = Tok_End then
+ declare
+ Scan_State : Saved_Scan_State;
+ End_Loc : constant Source_Ptr := Token_Ptr;
+ Nxt_Labl : Node_Id;
+ Dup_Found : Boolean := False;
+
+ begin
+ Save_Scan_State (Scan_State);
+
+ Scan; -- past END
+
+ if Token = Tok_Identifier
+ or else Token = Tok_Operator_Symbol
+ then
+ Nxt_Labl := P_Designator;
+
+ -- We only consider it an error if the label is a match
+ -- and would be wrong for the level one above us, and
+ -- the indentation is the same.
+
+ if Token = Tok_Semicolon
+ and then Same_Label (End_Labl, Nxt_Labl)
+ and then End_Column = Start_Column
+ and then
+ (Scope.Last = 1
+ or else
+ (No (Scope.Table (Scope.Last - 1).Labl)
+ or else
+ not Same_Label
+ (End_Labl,
+ Scope.Table (Scope.Last - 1).Labl)))
+ then
+ T_Semicolon;
+ Error_Msg ("duplicate end line ignored", End_Loc);
+ Dup_Found := True;
+ end if;
+ end if;
+
+ if not Dup_Found then
+ Restore_Scan_State (Scan_State);
+ end if;
+ end;
+ end if;
+
+ -- All OK, so return to caller indicating END is OK
+
+ Pop_Scope_Stack;
+ End_Action := Accept_As_Scanned;
+ return;
+ end if;
+
+ -- If that check failed, then we definitely have an error. The issue
+ -- is how to choose among three possible courses of action:
+
+ -- 1. Ignore the current END text completely, scanning past it,
+ -- deciding that it belongs neither to the current context,
+ -- nor to any outer context.
+
+ -- 2. Accept the current END text, scanning past it, and issuing
+ -- an error message that it does not have the right form.
+
+ -- 3. Leave the current END text in place, NOT scanning past it,
+ -- issuing an error message indicating the END expected for the
+ -- current context. In this case, the END is available to match
+ -- some outer END context.
+
+ -- From a correct functioning point of view, it does not make any
+ -- difference which of these three approaches we take, the program
+ -- will work correctly in any case. However, making an accurate
+ -- choice among these alternatives, i.e. choosing the one that
+ -- corresponds to what the programmer had in mind, does make a
+ -- significant difference in the quality of error recovery.
+
+ Restore_Scan_State (Scan_State); -- to END
+
+ -- First we see how good the current END entry is with respect to
+ -- what we expect. It is considered pretty good if the token is OK,
+ -- and either the label or the column matches. an END for RECORD is
+ -- always considered to be pretty good in the record case. This is
+ -- because not only does a record disallow a nested structure, but
+ -- also it is unlikely that such nesting could occur by accident.
+
+ Pretty_Good := (Token_OK and (Column_OK or Label_OK))
+ or else Scope.Table (Scope.Last).Etyp = E_Record;
+
+ -- Next check, if there is a deeper entry in the stack which
+ -- has a very high probability of being acceptable, then insert
+ -- the END entry we want, leaving the higher level entry for later
+
+ for J in reverse 1 .. Scope.Last - 1 loop
+ Evaluate_End_Entry (J);
+
+ -- To even consider the deeper entry to be immediately acceptable,
+ -- it must be syntactically correct. Furthermore it must either
+ -- have a correct label, or the correct column. If the current
+ -- entry was a close match (Pretty_Good set), then we are even
+ -- more strict in accepting the outer level one: even if it has
+ -- the right label, it must have the right column as well.
+
+ if Syntax_OK then
+ if Pretty_Good then
+ Outer_Match := Label_OK and Column_OK;
+ else
+ Outer_Match := Label_OK or Column_OK;
+ end if;
+ else
+ Outer_Match := False;
+ end if;
+
+ -- If the outer entry does convincingly match the END text, then
+ -- back up the scan to the start of the END sequence, issue an
+ -- error message indicating the END we expected, and return with
+ -- Token pointing to the END (case 3 from above discussion).
+
+ if Outer_Match then
+ Output_End_Missing;
+ Pop_Scope_Stack;
+ End_Action := Insert_And_Accept;
+ return;
+ end if;
+ end loop;
+
+ -- Here we have a situation in which the current END entry is
+ -- syntactically incorrect, but there is no deeper entry in the
+ -- END stack which convincingly matches it.
+
+ -- If the END text was judged to be a Pretty_Good match for the
+ -- expected token or if it appears left of the expected column,
+ -- then we will accept it as the one we want, scanning past it, even
+ -- though it is not completely right (we issue a message showing what
+ -- we expected it to be). This is action 2 from the discussion above.
+ -- There is one other special case to consider: the LOOP case.
+ -- Consider the example:
+
+ -- Lbl: loop
+ -- null;
+ -- end loop;
+
+ -- Here the column lines up with Lbl, so END LOOP is to the right,
+ -- but it is still acceptable. LOOP is the one case where alignment
+ -- practices vary substantially in practice.
+
+ if Pretty_Good
+ or else End_Column <= Scope.Table (Scope.Last).Ecol
+ or else (End_Type = Scope.Table (Scope.Last).Etyp
+ and then End_Type = E_Loop)
+ then
+ Output_End_Expected (Ins => False);
+ Pop_Scope_Stack;
+ End_Action := Skip_And_Accept;
+ return;
+
+ -- Here we have the case where the END is to the right of the
+ -- expected column and does not have a correct label to convince
+ -- us that it nevertheless belongs to the current scope. For this
+ -- we consider that it probably belongs not to the current context,
+ -- but to some inner context that was not properly recognized (due to
+ -- other syntax errors), and for which no proper scope stack entry
+ -- was made. The proper action in this case is to delete the END text
+ -- and return False to the caller as a signal to keep on looking for
+ -- an acceptable END. This is action 1 from the discussion above.
+
+ else
+ Output_End_Deleted;
+ End_Action := Skip_And_Reject;
+ return;
+ end if;
+ end if;
+ end Pop_End_Context;
+
+ ----------------
+ -- Same_Label --
+ ----------------
+
+ function Same_Label (Label1, Label2 : Node_Id) return Boolean is
+ begin
+ if Nkind (Label1) in N_Has_Chars
+ and then Nkind (Label2) in N_Has_Chars
+ then
+ return Chars (Label1) = Chars (Label2);
+
+ elsif Nkind (Label1) = N_Selected_Component
+ and then Nkind (Label2) = N_Selected_Component
+ then
+ return Same_Label (Prefix (Label1), Prefix (Label2)) and then
+ Same_Label (Selector_Name (Label1), Selector_Name (Label2));
+
+ elsif Nkind (Label1) = N_Designator
+ and then Nkind (Label2) = N_Defining_Program_Unit_Name
+ then
+ return Same_Label (Name (Label1), Name (Label2)) and then
+ Same_Label (Identifier (Label1), Defining_Identifier (Label2));
+
+ else
+ return False;
+ end if;
+ end Same_Label;
+
+end Endh;