@@ -1339,11 +1339,39 @@ package body Exp_Disp is
Opnd := Designated_Type (Opnd);
end if;
+ Opnd := Underlying_Record_Type (Opnd);
+
if not Is_Interface (Opnd)
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
+ -- 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)).
+
+ -- At this stage we cannot identify whether the underlying object is
+ -- a BIP object and hence we cannot skip generating the code to try
+ -- displacing the pointer to the object. However, under configurable
+ -- runtime it is safe to skip generating code to displace the pointer
+ -- to the object, because generic dispatching constructors are not
+ -- supported.
+
+ if Opnd = Iface_Typ
+ and then not RTE_Available (RE_Displace)
+ then
+ return;
+ end if;
end;
-- Evaluate if we can statically displace the pointer to the object
@@ -402,7 +402,10 @@ package body Exp_Intr is
end if;
-- Rewrite and analyze the call to the instance as a class-wide
- -- conversion of the call to the actual constructor.
+ -- conversion of the call to the actual constructor. When the result
+ -- type is a class-wide interface type this conversion is required to
+ -- force the displacement of the pointer to the object to reference the
+ -- corresponding dispatch table.
Rewrite (N, Convert_To (Result_Typ, Cnstr_Call));
new file mode 100644
@@ -0,0 +1,9 @@
+-- { dg-do compile }
+
+package body Interface8 is
+ function Get_Iface (This : Child) return not null access Iface'Class
+ is
+ begin
+ return This.Interface_1;
+ end;
+end;
new file mode 100644
@@ -0,0 +1,11 @@
+package Interface8 is
+ type Iface is interface;
+
+ type Root is abstract tagged null record;
+
+ type Child is new Root and Iface with record
+ Interface_1 : access Iface'Class;
+ end record;
+
+ function Get_Iface (This : Child) return not null access Iface'Class;
+end;