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.
Tested on x86_64-pc-linux-gnu, committed on trunk
2019-07-08 Javier Miranda <mira...@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.--- gcc/ada/exp_ch4.adb
+++ 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))
--- /dev/null
new file mode 100644
+++ 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;
