From 5a6446841aa17a717f2f04ec22e507c86c864355 Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Wed, 10 Jul 2019 09:00:16 +0000 Subject: [PATCH] [Ada] Missing implicit interface type conversion The compiler skips adding an implicit type conversion when the interface type is visible through a limited-with clause. No small reproducer available. 2019-07-10 Javier Miranda gcc/ada/ * exp_ch6.adb (Is_Class_Wide_Interface_Type): New subprogram. (Expand_Call_Helper): Handle non-limited views when we check if any formal is a class-wide interface type. * exp_disp.adb (Expand_Interface_Actuals): Handle non-limited views when we look for interface type formals to force "this" displacement. From-SVN: r273328 --- gcc/ada/ChangeLog | 9 +++++++++ gcc/ada/exp_ch6.adb | 40 +++++++++++++++++++++++++++++++--------- gcc/ada/exp_disp.adb | 16 ++++++++++++++++ 3 files changed, 56 insertions(+), 9 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 762db94..389a12d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,12 @@ +2019-07-10 Javier Miranda + + * exp_ch6.adb (Is_Class_Wide_Interface_Type): New subprogram. + (Expand_Call_Helper): Handle non-limited views when we check if + any formal is a class-wide interface type. + * exp_disp.adb (Expand_Interface_Actuals): Handle non-limited + views when we look for interface type formals to force "this" + displacement. + 2019-07-10 Ed Schonberg * sem_res.adb (Resolve_Equality_Op): Do not replace the resolved diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 364acd9..448f981 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2331,6 +2331,10 @@ package body Exp_Ch6 is function In_Unfrozen_Instance (E : Entity_Id) return Boolean; -- Return true if E comes from an instance that is not yet frozen + function Is_Class_Wide_Interface_Type (E : Entity_Id) return Boolean; + -- Return True when E is a class-wide interface type or an access to + -- a class-wide interface type. + function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean; -- Determine if Subp denotes a non-dispatching call to a Deep routine @@ -2585,6 +2589,32 @@ package body Exp_Ch6 is return False; end In_Unfrozen_Instance; + ---------------------------------- + -- Is_Class_Wide_Interface_Type -- + ---------------------------------- + + function Is_Class_Wide_Interface_Type (E : Entity_Id) return Boolean is + Typ : Entity_Id := E; + DDT : Entity_Id; + + begin + if Has_Non_Limited_View (Typ) then + Typ := Non_Limited_View (Typ); + end if; + + if Ekind (Typ) = E_Anonymous_Access_Type then + DDT := Directly_Designated_Type (Typ); + + if Has_Non_Limited_View (DDT) then + DDT := Non_Limited_View (DDT); + end if; + + return Is_Class_Wide_Type (DDT) and then Is_Interface (DDT); + else + return Is_Class_Wide_Type (Typ) and then Is_Interface (Typ); + end if; + end Is_Class_Wide_Interface_Type; + ------------------------- -- Is_Direct_Deep_Call -- ------------------------- @@ -2919,15 +2949,7 @@ package body Exp_Ch6 is CW_Interface_Formals_Present := CW_Interface_Formals_Present - or else - (Is_Class_Wide_Type (Etype (Formal)) - and then Is_Interface (Etype (Etype (Formal)))) - or else - (Ekind (Etype (Formal)) = E_Anonymous_Access_Type - and then Is_Class_Wide_Type (Directly_Designated_Type - (Etype (Etype (Formal)))) - and then Is_Interface (Directly_Designated_Type - (Etype (Etype (Formal))))); + or else Is_Class_Wide_Interface_Type (Etype (Formal)); -- Create possible extra actual for constrained case. Usually, the -- extra actual is of the form actual'constrained, but since this diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index a659594..4fae37c 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -1682,18 +1682,34 @@ package body Exp_Disp is while Present (Formal) loop Formal_Typ := Etype (Formal); + if Has_Non_Limited_View (Formal_Typ) then + Formal_Typ := Non_Limited_View (Formal_Typ); + end if; + if Ekind (Formal_Typ) = E_Record_Type_With_Private then Formal_Typ := Full_View (Formal_Typ); end if; if Is_Access_Type (Formal_Typ) then Formal_DDT := Directly_Designated_Type (Formal_Typ); + + if Has_Non_Limited_View (Formal_DDT) then + Formal_DDT := Non_Limited_View (Formal_DDT); + end if; end if; Actual_Typ := Etype (Actual); + if Has_Non_Limited_View (Actual_Typ) then + Actual_Typ := Non_Limited_View (Actual_Typ); + end if; + if Is_Access_Type (Actual_Typ) then Actual_DDT := Directly_Designated_Type (Actual_Typ); + + if Has_Non_Limited_View (Actual_DDT) then + Actual_DDT := Non_Limited_View (Actual_DDT); + end if; end if; if Is_Interface (Formal_Typ) -- 2.7.4