[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.

From-SVN: r273219

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index b122428..2692731 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 78b5028..eb35845 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 169c7a5..ca89951 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;