From fa2538c77b94a62c657aee31a613ea29e6a46d4d Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Mon, 8 Jul 2019 08:14:32 +0000 Subject: [PATCH] [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 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 --- gcc/ada/ChangeLog | 8 ++++++++ gcc/ada/exp_ch4.adb | 3 ++- gcc/testsuite/ChangeLog | 4 ++++ gcc/testsuite/gnat.dg/interface10.adb | 22 ++++++++++++++++++++++ 4 files changed, 36 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gnat.dg/interface10.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b122428..2692731 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,11 @@ +2019-07-08 Javier Miranda + + * 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 * 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 --- 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 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2019-07-08 Javier Miranda + + * gnat.dg/interface10.adb: New testcase. + 2019-07-08 Hristian Kirtchev * 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 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; -- 2.7.4