diff options
Diffstat (limited to 'gcc/ada/par-endh.adb')
| -rw-r--r-- | gcc/ada/par-endh.adb | 71 |
1 files changed, 56 insertions, 15 deletions
diff --git a/gcc/ada/par-endh.adb b/gcc/ada/par-endh.adb index 57561aab673..2aabe2f643c 100644 --- a/gcc/ada/par-endh.adb +++ b/gcc/ada/par-endh.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2002, 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- -- @@ -114,12 +114,17 @@ package body Endh is -- Local Subprograms -- ----------------------- - procedure Evaluate_End_Entry (SS_Index : Int); + 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. @@ -298,7 +303,7 @@ package body Endh is -- Case of child unit name if Nkind (End_Labl) = N_Defining_Program_Unit_Name then - declare + Child_End : declare Eref : constant Node_Id := Make_Identifier (Token_Ptr, Chars => @@ -307,6 +312,10 @@ package body Endh is 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; @@ -328,6 +337,8 @@ package body Endh is end if; end Copy_Name; + -- Start of processing for Child_End + begin Set_Comes_From_Source (Eref, False); @@ -335,7 +346,7 @@ package body Endh is Make_Designator (Token_Ptr, Name => Copy_Name (Name (End_Labl)), Identifier => Eref); - end; + end Child_End; -- Simple identifier case @@ -364,7 +375,7 @@ package body Endh is if Style_Check and then End_Type = E_Name - and then Present (Scope.Table (Scope.Last).Labl) + and then Explicit_Start_Label (Scope.Last) then Style.No_End_Name (Scope.Table (Scope.Last).Labl); end if; @@ -655,7 +666,7 @@ package body Endh is -- Evaluate End Entry -- ------------------------ - procedure Evaluate_End_Entry (SS_Index : Int) is + procedure Evaluate_End_Entry (SS_Index : Nat) is begin Column_OK := (End_Column = Scope.Table (SS_Index).Ecol); @@ -692,6 +703,7 @@ package body Endh is 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 @@ -701,7 +713,8 @@ package body Endh is if Error_Msg_Name_1 > Error_Name then declare - S : String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); + S : constant String (1 .. Name_Len) := + Name_Buffer (1 .. Name_Len); begin Get_Name_String (Error_Msg_Name_1); @@ -724,13 +737,14 @@ package body Endh is -- case, this is acceptable only if the loop is unlabeled. elsif End_Type = E_Loop then - Syntax_OK := (Scope.Table (SS_Index).Labl = Empty); + 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 := (Scope.Table (SS_Index).Labl = Empty or else - not Scope.Table (SS_Index).Lreq); + 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. @@ -740,6 +754,23 @@ package body Endh is 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; + + begin + if No (L) then + return False; + elsif Comes_From_Source (L) then + return True; + else + return False; + end if; + end Explicit_Start_Label; + ------------------------ -- Output End Deleted -- ------------------------ @@ -784,9 +815,14 @@ package body Endh is 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; + 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 @@ -853,9 +889,14 @@ package body Endh is 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 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#!"); @@ -1014,9 +1055,9 @@ package body Endh is and then (Scope.Last = 1 or else - (No (Scope.Table (Scope.Last - 1).Labl) - or else - not Same_Label + (not Explicit_Start_Label (Scope.Last - 1)) + or else + (not Same_Label (End_Labl, Scope.Table (Scope.Last - 1).Labl))) then |