diff options
| -rw-r--r-- | gcc/ada/exp_disp.adb | 32 | ||||
| -rw-r--r-- | gcc/ada/sem_disp.adb | 15 |
2 files changed, 33 insertions, 14 deletions
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 43ae2e0..d8a45ff 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -1304,17 +1304,24 @@ package body Exp_Disp is and then Is_Ancestor (Iface_Typ, Opnd, Use_Full_View => True) then return; - end if; - -- When the type of the operand and the target interface type match, - -- it is generally safe to skip generating code to displace the - -- pointer to the object to reference the secondary dispatch table - -- associated with the target interface type. The exception to this - -- general rule is when the underlying object of the type conversion - -- is an object built by means of a dispatching constructor (since in - -- such case the expansion of the constructor call is a direct call - -- to an object primitive, i.e. without thunks, and the expansion of - -- the constructor call adds an explicit conversion to the target + -- When the target type is an interface type that is an ancestor of + -- the operand type, it is generally safe to skip generating code to + -- displace the pointer to the object to reference the secondary + -- dispatch table of the target interface type. Two scenaries are + -- possible here: + -- 1) The operand type is a regular tagged type + -- 2) The operand type is an interface type + -- In the former case the target interface and the regular tagged + -- type share the primary dispatch table of the object; in the latter + -- case the operand interface has all the primitives of the ancestor + -- interface type (and exactly in the same dispatch table slots). + -- + -- The exception to this general rule is when the underlying object + -- is built by means of a dispatching constructor (since in such case + -- the expansion of the constructor call is a direct call to an + -- object primitive, i.e. without thunks, and the expansion of + -- the constructor call adds this explicit conversion to the target -- interface type to force the displacement of the pointer to the -- object to reference the corresponding secondary dispatch table -- (cf. Make_DT and Expand_Dispatching_Constructor_Call)). @@ -1326,7 +1333,10 @@ package body Exp_Disp is -- to the object, because generic dispatching constructors are not -- supported. - if Opnd = Iface_Typ and then not RTE_Available (RE_Displace) then + elsif Is_Interface (Iface_Typ) + and then Is_Ancestor (Iface_Typ, Opnd, Use_Full_View => True) + and then not RTE_Available (RE_Displace) + then return; end if; end; diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index ee1d96e..af26013 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -3072,18 +3072,27 @@ package body Sem_Disp is if Tagged_Type_Expansion then declare - Call_Typ : constant Entity_Id := Etype (Call_Node); + Call_Typ : Entity_Id := Etype (Call_Node); + Ctrl_Typ : Entity_Id := Etype (Control); begin Expand_Dispatching_Call (Call_Node); + if Is_Class_Wide_Type (Call_Typ) then + Call_Typ := Root_Type (Call_Typ); + end if; + + if Is_Class_Wide_Type (Ctrl_Typ) then + Ctrl_Typ := Root_Type (Ctrl_Typ); + end if; + -- If the controlling argument is an interface type and the type -- of Call_Node differs then we must add an implicit conversion to -- force displacement of the pointer to the object to reference -- the secondary dispatch table of the interface. - if Is_Interface (Etype (Control)) - and then Etype (Control) /= Call_Typ + if Is_Interface (Ctrl_Typ) + and then Ctrl_Typ /= Call_Typ then -- Cannot use Convert_To because the previous call to -- Expand_Dispatching_Call leaves decorated the Call_Node |