diff options
Diffstat (limited to 'gcc/ada/sem_ch3.adb')
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 31 |
1 files changed, 20 insertions, 11 deletions
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 88ef267..9e31930 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -8897,17 +8897,27 @@ package body Sem_Ch3 is procedure Check_Pragma_Implemented (Subp : Entity_Id) is Iface_Alias : constant Entity_Id := Interface_Alias (Subp); Impl_Kind : constant Name_Id := Implementation_Kind (Iface_Alias); + Subp_Alias : constant Entity_Id := Alias (Subp); Contr_Typ : Entity_Id; + Impl_Subp : Entity_Id; begin -- Subp must have an alias since it is a hidden entity used to link -- an interface subprogram to its overriding counterpart. - pragma Assert (Present (Alias (Subp))); + pragma Assert (Present (Subp_Alias)); + + -- Handle aliases to synchronized wrappers + + Impl_Subp := Subp_Alias; + + if Is_Primitive_Wrapper (Impl_Subp) then + Impl_Subp := Wrapped_Entity (Impl_Subp); + end if; -- Extract the type of the controlling formal - Contr_Typ := Etype (First_Formal (Alias (Subp))); + Contr_Typ := Etype (First_Formal (Subp_Alias)); if Is_Concurrent_Record_Type (Contr_Typ) then Contr_Typ := Corresponding_Concurrent_Type (Contr_Typ); @@ -8917,12 +8927,12 @@ package body Sem_Ch3 is -- be implemented by an entry. if Impl_Kind = Name_By_Entry - and then Ekind (Wrapped_Entity (Alias (Subp))) /= E_Entry + and then Ekind (Impl_Subp) /= E_Entry then Error_Msg_Node_2 := Iface_Alias; Error_Msg_NE ("type & must implement abstract subprogram & with an entry", - Alias (Subp), Contr_Typ); + Subp_Alias, Contr_Typ); elsif Impl_Kind = Name_By_Protected_Procedure then @@ -8934,19 +8944,17 @@ package body Sem_Ch3 is Error_Msg_Node_2 := Contr_Typ; Error_Msg_NE ("interface subprogram & cannot be implemented by a " & - "primitive procedure of task type &", Alias (Subp), + "primitive procedure of task type &", Subp_Alias, Iface_Alias); -- An interface subprogram whose implementation kind is By_ -- Protected_Procedure must be implemented by a procedure. - elsif Is_Primitive_Wrapper (Alias (Subp)) - and then Ekind (Wrapped_Entity (Alias (Subp))) /= E_Procedure - then + elsif Ekind (Impl_Subp) /= E_Procedure then Error_Msg_Node_2 := Iface_Alias; Error_Msg_NE ("type & must implement abstract subprogram & with a " & - "procedure", Alias (Subp), Contr_Typ); + "procedure", Subp_Alias, Contr_Typ); end if; end if; end Check_Pragma_Implemented; @@ -8966,10 +8974,11 @@ package body Sem_Ch3 is -- Ada 2012 (AI05-0030): The implementation kinds of an overridden -- and overriding subprogram are different. In general this is an -- error except when the implementation kind of the overridden - -- subprograms is By_Any. + -- subprograms is By_Any or Optional. if Iface_Kind /= Subp_Kind and then Iface_Kind /= Name_By_Any + and then Iface_Kind /= Name_Optional then if Iface_Kind = Name_By_Entry then Error_Msg_N |