Mercurial > hg > CbC > CbC_gcc
diff gcc/ada/par-endh.adb @ 111:04ced10e8804
gcc 7
| author | kono |
|---|---|
| date | Fri, 27 Oct 2017 22:46:09 +0900 |
| parents | |
| children | 84e7813d76e9 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gcc/ada/par-endh.adb Fri Oct 27 22:46:09 2017 +0900 @@ -0,0 +1,1347 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . E N D H -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2016, 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 3, 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 COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Namet.Sp; use Namet.Sp; +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 : Nat); + -- 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. + + function Explicit_Start_Label (SS_Index : Nat) return Boolean; + -- Determines whether the specified entry in the scope stack has an + -- explicit start label (i.e. one other than one that was created by + -- the parser when no explicit label was present). + + 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 + (Decl : Node_Id := Empty; + Is_Loc : Source_Ptr := No_Location) 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_Return then + End_Type := E_Return; + Scan; -- past RETURN + + 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 current token location. + + -- Case of child unit name + + if Nkind (End_Labl) = N_Defining_Program_Unit_Name then + Child_End : 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 + + --------------- + -- Copy_Name -- + --------------- + + 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 (N)); + Set_Comes_From_Source (N, False); + return R; + end if; + end Copy_Name; + + -- Start of processing for Child_End + + begin + Set_Comes_From_Source (Eref, False); + + End_Labl := + Make_Designator (Token_Ptr, + Name => Copy_Name (Name (End_Labl)), + Identifier => Eref); + end Child_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 (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 label permitted but not present. Note: + -- for the case of a block statement, the label is required + -- to be repeated, and this legality rule is enforced + -- independently. + + if Style_Check + and then End_Type = E_Name + and then Explicit_Start_Label (Scope.Last) + and then Nkind (Parent (Scope.Table (Scope.Last).Labl)) + /= N_Block_Statement + then + Style.No_End_Name (Scope.Table (Scope.Last).Labl); + end if; + end if; + end if; + end if; + + -- Deal with terminating aspect specifications and following semi- + -- colon. We skip this in the case of END RECORD, since in this + -- case the aspect specifications and semicolon are handled at + -- a higher level. + + if End_Type /= E_Record then + + -- Scan aspect specifications + + if Aspect_Specifications_Present then + + -- Aspect specifications not allowed + + if No (Decl) then + + -- Package declaration case + + if Is_Loc /= No_Location then + Error_Msg_SC + ("misplaced aspects for package declaration"); + Error_Msg + ("info: aspect specifications belong here??", Is_Loc); + P_Aspect_Specifications (Empty); + + -- Other cases where aspect specifications are not allowed + + else + P_Aspect_Specifications (Error); + end if; + + -- Aspect specifications allowed + + else + P_Aspect_Specifications (Decl); + end if; + + -- If no aspect specifications, must have a semicolon + + elsif 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 consider the END line to be dubious in this sense. + + else + End_OK := False; + end if; + 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_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; + Decl : Node_Id := Empty; + Is_Sloc : Source_Ptr := No_Location) + 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 (Decl, Is_Sloc) 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 : Nat) is + STE : Scope_Table_Entry renames Scope.Table (SS_Index); + + begin + Column_OK := (End_Column = STE.Ecol); + + Token_OK := (End_Type = STE.Etyp + or else (End_Type = E_Name and then STE.Etyp >= E_Name)); + + Label_OK := End_Labl_Present + and then (Same_Label (End_Labl, STE.Labl) + or else STE.Labl = Error); + + -- Special case to consider. Suppose we have the suspicious label case, + -- e.g. a situation like: + + -- My_Label; + -- declare + -- ... + -- begin + -- ... + -- end My_Label; + + -- This is the case where we want to use the entry in the suspicous + -- label table to flag the semicolon saying it should be a colon. + + -- Label_OK will be false because the label does not match (we have + -- My_Label on the end line, and the generated name for the scope). Also + -- End_Labl_Present will be True. + + if not Label_OK + and then End_Labl_Present + and then not Comes_From_Source (Scope.Table (SS_Index).Labl) + then + -- Here is where we will search the suspicious labels table + + for J in 1 .. Suspicious_Labels.Last loop + declare + SLE : Suspicious_Label_Entry renames + Suspicious_Labels.Table (J); + begin + -- See if character name of label matches + + if Chars (Name (SLE.Proc_Call)) = Chars (End_Labl) + + -- And first token of loop/block identifies this entry + + and then SLE.Start_Token = STE.Sloc + then + -- We have the special case, issue the error message + + Error_Msg -- CODEFIX + (""";"" should be "":""", SLE.Semicolon_Loc); + + -- And indicate we consider the Label OK after all + + Label_OK := True; + exit; + end if; + end; + end loop; + end if; + + -- 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 Comes_From_Source (Nam) + and then Nkind (Nam) in N_Has_Chars + and then Chars (End_Labl) > Error_Name + and then Chars (Nam) > Error_Name + then + Error_Msg_Name_1 := Chars (Nam); + + if Error_Msg_Name_1 > Error_Name then + if Is_Bad_Spelling_Of (Chars (Nam), Chars (End_Labl)) then + Error_Msg_Name_1 := Chars (Nam); + Error_Msg_N -- CODEFIX + ("misspelling of %", End_Labl); + Syntax_OK := True; + return; + end if; + 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 := not Explicit_Start_Label (SS_Index); + + -- Cases where a label is definitely allowed on the END line + + elsif End_Type = E_Name then + Syntax_OK := (not Explicit_Start_Label (SS_Index)) + 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; + + -------------------------- + -- Explicit_Start_Label -- + -------------------------- + + function Explicit_Start_Label (SS_Index : Nat) return Boolean is + L : constant Node_Id := Scope.Table (SS_Index).Labl; + Etyp : constant SS_End_Type := Scope.Table (SS_Index).Etyp; + + begin + if No (L) then + return False; + + -- In the following test we protect the call to Comes_From_Source + -- against lines containing previously reported syntax errors. + + elsif (Etyp = E_Loop or else + Etyp = E_Name or else + Etyp = E_Suspicious_Is or else + Etyp = E_Bad_Is) + and then Comes_From_Source (L) + then + return True; + + else + return False; + end if; + end Explicit_Start_Label; + + ------------------------ + -- 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_Return then + Error_Msg_SC ("no RETURN for this `END RETURN`!"); + + 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_Sloc := Scope.Table (Scope.Last).Sloc; + + if Explicit_Start_Label (Scope.Last) then + Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl; + else + Error_Msg_Node_1 := Empty; + end if; + + -- Suppress message if error was posted on opening label + + if Error_Msg_Node_1 > Empty_Or_Error + and then Error_Posted (Error_Msg_Node_1) + then + return; + end if; + + if End_Type = E_Case then + Error_Msg_SC -- CODEFIX + ("`END CASE;` expected@ for CASE#!"); + + elsif End_Type = E_If then + Error_Msg_SC -- CODEFIX + ("`END IF;` expected@ for IF#!"); + + elsif End_Type = E_Loop then + if Error_Msg_Node_1 = Empty then + Error_Msg_SC -- CODEFIX + ("`END LOOP;` expected@ for LOOP#!"); + else + Error_Msg_SC -- CODEFIX + ("`END LOOP &;` expected@!"); + end if; + + elsif End_Type = E_Record then + Error_Msg_SC -- CODEFIX + ("`END RECORD;` expected@ for RECORD#!"); + + elsif End_Type = E_Return then + Error_Msg_SC -- CODEFIX + ("`END RETURN;` expected@ for RETURN#!"); + + elsif End_Type = E_Select then + Error_Msg_SC -- CODEFIX + ("`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 -- CODEFIX + ("`END;` expected@ for BEGIN#!"); + else + Error_Msg_SC -- CODEFIX + ("`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_Sloc := Scope.Table (Scope.Last).Sloc; + + if Explicit_Start_Label (Scope.Last) then + Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl; + else + Error_Msg_Node_1 := Empty; + end if; + + 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_Return then + Error_Msg_SC + ("missing `END RETURN;` for RETURN#!"); + + 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 syntax 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 RM_Column_Check then + if End_Column /= Scope.Table (Scope.Last).Ecol + and then Current_Line_Start > Scope.Table (Scope.Last).Sloc + + -- A special case, for END RECORD, we are also allowed to + -- line up with the TYPE keyword opening the declaration. + + and then (Scope.Table (Scope.Last).Etyp /= E_Record + or else Get_Column_Number (End_Sloc) /= + Get_Column_Number (Type_Token_Location)) + 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 + (not Explicit_Start_Label (Scope.Last - 1)) + 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;