[Ada] Spurious error on interface conversion under ZFP

The frontend reports an error under ZFP when performing the type
conversion of a tagged object to one of its covered interface types.

2018-09-26  Javier Miranda  <miranda@adacore.com>

gcc/ada/

	* exp_disp.adb (Expand_Interface_Conversion): No displacement of
	the pointer needed when the type of the operand is an interface
	type that maches the target type and we are compiling under
	configurable runtime. Adding also documentation explaining why
	this cannot be done when compiling with the full runtime.
	* exp_intr.adb: Update comment.

gcc/testsuite/

	* gnat.dg/interface8.adb, gnat.dg/interface8.ads: New testcase.

From-SVN: r264628

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index d6ce7847c368014740baa5b5cc398e157d308a01..16855a7d23f3ce76b42dc2d30cedd27b38929459 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,12 @@
+2018-09-26  Javier Miranda  <miranda@adacore.com>
+
+       * exp_disp.adb (Expand_Interface_Conversion): No displacement of
+       the pointer needed when the type of the operand is an interface
+       type that maches the target type and we are compiling under
+       configurable runtime. Adding also documentation explaining why
+       this cannot be done when compiling with the full runtime.
+       * exp_intr.adb: Update comment.
+
 2018-09-26  Hristian Kirtchev  <kirtchev@adacore.com>
 
        * sem_ch5.adb (Wrap_Loop_Statement): Annotate as No_Return.

diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index cf7ce4986a8148e426a931b5dd242ba5885568f2..2169b67419a2aed5e9916b67ed9f1c1394abcc35 100644 (file)
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -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

diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb
index 73981faa4c0e971dc2e4648cde1d23a984ed95ad..4f4584bad6a6b840f314bbd84135201a66c84af0 100644 (file)
--- a/gcc/ada/exp_intr.adb
+++ b/gcc/ada/exp_intr.adb
@@ -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));
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index e285be64939219686e5880660df6f270f1948781..ccebb8a56be176392460422d84603ca77d869167 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2018-09-26  Javier Miranda  <miranda@adacore.com>
+
+       * gnat.dg/interface8.adb, gnat.dg/interface8.ads: New testcase.
+
 2018-09-26  Ed Schonberg  <schonberg@adacore.com>
 
        * gnat.dg/predicate2-containers.ads,

diff --git a/gcc/testsuite/gnat.dg/interface8.adb b/gcc/testsuite/gnat.dg/interface8.adb
new file mode 100644 (file)
index 0000000..5537ddb
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/interface8.adb
@@ -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;

diff --git a/gcc/testsuite/gnat.dg/interface8.ads b/gcc/testsuite/gnat.dg/interface8.ads
new file mode 100644 (file)
index 0000000..d67b375
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/interface8.ads
@@ -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;