[Ada] Wrong evaluation of membership test

The code generated by the compiler erroneously evaluates to True
membership tests when their left operand is a a class-wide interface
object and the right operand is a tagged type that implements such
interface type.

2019-07-08  Javier Miranda  <miranda@adacore.com>

gcc/ada/

	* exp_ch4.adb (Tagged_Membership): Fix regression silently
	introduced in r260738 that erroneouslusy causes the evaluation
	to True of the membership test when the left operand of the
	membership test is a class-wide interface object and the right
	operand is a type that implements such interface type.

gcc/testsuite/

	* gnat.dg/interface10.adb: New testcase.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@273219 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index b1224281640920902bf8a39cfd2da30999467d34..26927316f9ee6b4f865c11f365df3f5156ba4d41 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,11 @@
+2019-07-08  Javier Miranda  <miranda@adacore.com>
+
+       * exp_ch4.adb (Tagged_Membership): Fix regression silently
+       introduced in r260738 that erroneouslusy causes the evaluation
+       to True of the membership test when the left operand of the
+       membership test is a class-wide interface object and the right
+       operand is a type that implements such interface type.
+
 2019-07-08  Hristian Kirtchev  <kirtchev@adacore.com>
 
        * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Do not

diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 78b5028d75ec1530bec22a50624ba75b83e9dc25..eb35845e53d5cc7a616127c01587e7daca32609a 100644 (file)
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -14156,7 +14156,8 @@ package body Exp_Ch4 is
          --    Obj1 in DT'Class;     --  Compile time error
          --    Obj1 in Iface'Class;  --  Compile time error
 
-         if not Is_Class_Wide_Type (Left_Type)
+         if not Is_Interface (Left_Type)
+           and then not Is_Class_Wide_Type (Left_Type)
            and then (Is_Ancestor (Etype (Right_Type), Left_Type,
                                   Use_Full_View => True)
                       or else (Is_Interface (Etype (Right_Type))

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 169c7a58193a490babedaebc2a15380c3928ba3c..ca899513c0a5f58701ad1199e12f518505a48165 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2019-07-08  Javier Miranda  <miranda@adacore.com>
+
+       * gnat.dg/interface10.adb: New testcase.
+
 2019-07-08  Hristian Kirtchev  <kirtchev@adacore.com>
 
        * gnat.dg/addr13.adb, gnat.dg/addr13.ads: New testcase.

diff --git a/gcc/testsuite/gnat.dg/interface10.adb b/gcc/testsuite/gnat.dg/interface10.adb
new file mode 100644 (file)
index 0000000..7433454
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/interface10.adb
@@ -0,0 +1,22 @@
+--  { dg-do run }
+--  { dg-options "-gnata" }
+
+with Ada.Text_IO;
+
+procedure Interface10 is
+
+   type Iface is interface;
+
+   type My_First_Type is new Iface with null record;
+   type My_Second_Type is new Iface with null record;
+
+   procedure Do_Test (Object : in Iface'Class) is
+   begin
+      pragma Assert
+        ((Object in My_First_Type) = (Object in My_First_Type'Class));
+   end;
+
+   V : My_Second_Type;
+begin
+   Do_Test (V);
+end Interface10;