From 4a0e6ac18f731f41f7ddfa05c370186cd32bef52 Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Mon, 8 Jul 2019 08:13:20 +0000 Subject: [PATCH] [Ada] Crash in interface derivation with null primitive The frontend crashes processing the derivation of a tagged type whose ultimate ancestor is an interface type I1 that has a null primitive, implements another interface I2 derived from I2, and does not override the null primitive. 2019-07-08 Javier Miranda gcc/ada/ * exp_disp.adb (Register_Primitive): When registering a primitive in the secondary dispatch table, handle primitive inherited through several levels of type derivation (required to properly handle inherited 'null' primitive). gcc/testsuite/ * gnat.dg/interface9.adb, gnat.dg/interface9_root-child.ads, gnat.dg/interface9_root.ads: New testcase. From-SVN: r273204 --- gcc/ada/ChangeLog | 7 +++++++ gcc/ada/exp_disp.adb | 2 +- gcc/testsuite/ChangeLog | 5 +++++ gcc/testsuite/gnat.dg/interface9.adb | 10 ++++++++++ gcc/testsuite/gnat.dg/interface9_root-child.ads | 7 +++++++ gcc/testsuite/gnat.dg/interface9_root.ads | 10 ++++++++++ 6 files changed, 40 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gnat.dg/interface9.adb create mode 100644 gcc/testsuite/gnat.dg/interface9_root-child.ads create mode 100644 gcc/testsuite/gnat.dg/interface9_root.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 72cb89296d1..969e9335e0f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,10 @@ +2019-07-08 Javier Miranda + + * exp_disp.adb (Register_Primitive): When registering a + primitive in the secondary dispatch table, handle primitive + inherited through several levels of type derivation (required to + properly handle inherited 'null' primitive). + 2019-07-08 Bob Duff * doc/gnat_ugn/gnat_utility_programs.rst: Document handling of diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 1b212347976..a6595948189 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -7637,7 +7637,7 @@ package body Exp_Disp is Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, Prefix => - New_Occurrence_Of (Alias (Prim), Loc), + New_Occurrence_Of (Ultimate_Alias (Prim), Loc), Attribute_Name => Name_Unrestricted_Access)))); end if; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 94ad86f9895..14d127fc607 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2019-07-08 Javier Miranda + + * gnat.dg/interface9.adb, gnat.dg/interface9_root-child.ads, + gnat.dg/interface9_root.ads: New testcase. + 2019-07-08 Ed Schonberg * gnat.dg/predicate9.adb: New testcase. diff --git a/gcc/testsuite/gnat.dg/interface9.adb b/gcc/testsuite/gnat.dg/interface9.adb new file mode 100644 index 00000000000..ec46e20349d --- /dev/null +++ b/gcc/testsuite/gnat.dg/interface9.adb @@ -0,0 +1,10 @@ +-- { dg-do compile } + +with Interface9_Root.Child; +procedure Interface9 is + package R is new Interface9_Root (Real => Float); + package RC is new R.Child; + +begin + null; +end Interface9; diff --git a/gcc/testsuite/gnat.dg/interface9_root-child.ads b/gcc/testsuite/gnat.dg/interface9_root-child.ads new file mode 100644 index 00000000000..0440ddb313a --- /dev/null +++ b/gcc/testsuite/gnat.dg/interface9_root-child.ads @@ -0,0 +1,7 @@ +generic +package Interface9_Root.Child is + type Base_Type is abstract new Base_Interface with null record; + + type Derived_Type is abstract new Base_Type and Derived_Interface + with null record; -- Test +end Interface9_Root.Child; diff --git a/gcc/testsuite/gnat.dg/interface9_root.ads b/gcc/testsuite/gnat.dg/interface9_root.ads new file mode 100644 index 00000000000..2e64e5b42c5 --- /dev/null +++ b/gcc/testsuite/gnat.dg/interface9_root.ads @@ -0,0 +1,10 @@ +generic + type Real is digits <>; +package Interface9_Root is + type Base_Interface is limited interface; + + procedure Primitive1 (B : in out Base_Interface) is abstract; + procedure Primitive2 (B : in out Base_Interface) is null; + + type Derived_Interface is limited interface and Base_Interface; +end Interface9_Root; -- 2.30.2