From fceeaab66b35f55d325e4b07b7e96b5a7d9a1656 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Tue, 27 May 2008 11:20:38 +0200 Subject: [PATCH] 2008-05-27 Ed Schonberg * sem_ch6.adb: (Is_Interface_Conformant): Handle properly a primitive operation that overrides an interface function with a controlling access result. (Type_Conformance): If Skip_Controlling_Formals is true, when matching inherited and overriding operations, omit as well the conformance check on result types, to prevent spurious errors. From-SVN: r135992 --- gcc/ada/sem_ch6.adb | 60 +++++++++++++++++++++++++-------------------- 1 file changed, 33 insertions(+), 27 deletions(-) diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 037ccf980da..8ba9f75df19 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -3142,7 +3142,18 @@ package body Sem_Ch6 is if Old_Type /= Standard_Void_Type and then New_Type /= Standard_Void_Type then - if not Conforming_Types (Old_Type, New_Type, Ctype, Get_Inst) then + + -- If we are checking interface conformance we omit controlling + -- arguments and result, because we are only checking the conformance + -- of the remaining parameters. + + if Has_Controlling_Result (Old_Id) + and then Has_Controlling_Result (New_Id) + and then Skip_Controlling_Formals + then + null; + + elsif not Conforming_Types (Old_Type, New_Type, Ctype, Get_Inst) then Conformance_Error ("\return type does not match!", New_Id); return; end if; @@ -5774,13 +5785,16 @@ package body Sem_Ch6 is Iface_Prim : Entity_Id; Prim : Entity_Id) return Boolean is + Iface : constant Entity_Id := Find_Dispatching_Type (Iface_Prim); + Typ : constant Entity_Id := Find_Dispatching_Type (Prim); + begin pragma Assert (Is_Subprogram (Iface_Prim) and then Is_Subprogram (Prim) and then Is_Dispatching_Operation (Iface_Prim) and then Is_Dispatching_Operation (Prim)); - pragma Assert (Is_Interface (Find_Dispatching_Type (Iface_Prim)) + pragma Assert (Is_Interface (Iface) or else (Present (Alias (Iface_Prim)) and then Is_Interface @@ -5791,48 +5805,40 @@ package body Sem_Ch6 is or else Ekind (Prim) /= Ekind (Iface_Prim) or else not Is_Dispatching_Operation (Prim) or else Scope (Prim) /= Scope (Tagged_Type) - or else No (Find_Dispatching_Type (Prim)) - or else Base_Type (Find_Dispatching_Type (Prim)) /= Tagged_Type + or else No (Typ) + or else Base_Type (Typ) /= Tagged_Type or else not Primitive_Names_Match (Iface_Prim, Prim) then return False; - -- Case of a procedure, or a function not returning an interface + -- Case of a procedure, or a function that does not have a controlling + -- result (I or access I). elsif Ekind (Iface_Prim) = E_Procedure or else Etype (Prim) = Etype (Iface_Prim) - or else not Is_Interface (Etype (Iface_Prim)) + or else not Has_Controlling_Result (Prim) then return Type_Conformant (Prim, Iface_Prim, Skip_Controlling_Formals => True); - -- Case of a function returning an interface - - elsif Implements_Interface (Etype (Prim), Etype (Iface_Prim)) then - declare - Ret_Typ : constant Entity_Id := Etype (Prim); - Is_Conformant : Boolean; - - begin - -- Temporarly set both entities returning exactly the same type to - -- be able to call Type_Conformant (because that routine has no - -- machinery to handle interfaces). + -- Case of a function returning an interface, or an access to one. + -- Check that the return types correspond. - Set_Etype (Prim, Etype (Iface_Prim)); + elsif Implements_Interface (Typ, Iface) then + if (Ekind (Etype (Prim)) = E_Anonymous_Access_Type) + /= (Ekind (Etype (Iface_Prim)) = E_Anonymous_Access_Type) + then + return False; - Is_Conformant := + else + return Type_Conformant (Prim, Iface_Prim, Skip_Controlling_Formals => True); + end if; - -- Restore proper decoration of returned type - - Set_Etype (Prim, Ret_Typ); - - return Is_Conformant; - end; + else + return False; end if; - - return False; end Is_Interface_Conformant; --------------------------------- -- 2.30.2