re PR fortran/82257 (f951: Internal compiler error segmentation fault)

2018-01-15  Louis Krupp  <louis.krupp@zoho.com>

	PR fortran/82257
	* interface.c (compare_rank): Don't try to retrieve CLASS_DATA
	from symbol marked unlimited polymorphic.
	* resolve.c (resolve_structure_cons): Likewise.
	* misc.c (gfc_typename): Don't dereference derived->components
	if it's NULL.

2018-01-15  Louis Krupp  <louis.krupp@zoho.com>

	PR fortran/82257
	* gfortran.dg/unlimited_polymorphic_28.f90: New test.

From-SVN: r256720

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 453dc74ed66b33b9debe8e3ac3d11221bfc342f0..0806ecd2ec76ec734ff11259d4dcfa26fad496b8 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,12 @@
+2018-01-15  Louis Krupp  <louis.krupp@zoho.com>
+
+       PR fortran/82257
+       * interface.c (compare_rank): Don't try to retrieve CLASS_DATA
+       from symbol marked unlimited polymorphic.
+       * resolve.c (resolve_structure_cons): Likewise.
+       * misc.c (gfc_typename): Don't dereference derived->components
+       if it's NULL.
+
 2018-01-15  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
        PR fortran/54613

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index caa719e3ad5bc224c0688182c2570741b8bdae40..9e55e9dc310a96ac1a6ae289dc219d85ac409f1c 100644 (file)
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -754,8 +754,12 @@ compare_rank (gfc_symbol *s1, gfc_symbol *s2)
   if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
     return true;
 
-  as1 = (s1->ts.type == BT_CLASS) ? CLASS_DATA (s1)->as : s1->as;
-  as2 = (s2->ts.type == BT_CLASS) ? CLASS_DATA (s2)->as : s2->as;
+  as1 = (s1->ts.type == BT_CLASS
+        && !s1->ts.u.derived->attr.unlimited_polymorphic)
+       ? CLASS_DATA (s1)->as : s1->as;
+  as2 = (s2->ts.type == BT_CLASS
+        && !s2->ts.u.derived->attr.unlimited_polymorphic)
+       ? CLASS_DATA (s2)->as : s2->as;
 
   r1 = as1 ? as1->rank : 0;
   r2 = as2 ? as2->rank : 0;

diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
index 80d282efd07d9527965c2f5bb48789aea2517588..ec1f548123addd5335bdeae222e5cdf92680609a 100644 (file)
--- a/gcc/fortran/misc.c
+++ b/gcc/fortran/misc.c
@@ -156,7 +156,8 @@ gfc_typename (gfc_typespec *ts)
       sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
       break;
     case BT_CLASS:
-      ts = &ts->u.derived->components->ts;
+      if (ts->u.derived->components)
+       ts = &ts->u.derived->components->ts;
       if (ts->u.derived->attr.unlimited_polymorphic)
        sprintf (buffer, "CLASS(*)");
       else

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 67568710b05a330eb5ef9fa818dc9a4cec6d8ab4..1ecfe05ed797ec7415012ee1c3d9d5c1fb2f8f8d 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1289,7 +1289,9 @@ resolve_structure_cons (gfc_expr *expr, int init)
        }
 
       rank = comp->as ? comp->as->rank : 0;
-      if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->as)
+      if (comp->ts.type == BT_CLASS
+         && !comp->ts.u.derived->attr.unlimited_polymorphic
+         && CLASS_DATA (comp)->as)
        rank = CLASS_DATA (comp)->as->rank;
 
       if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index aae8d1a68fcd81dd2ef05531ec97e57232247d14..2933f83c32f9d5ae2651841063f9327203921187 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2018-01-15  Louis Krupp  <louis.krupp@zoho.com>
+
+       PR fortran/82257
+       * gfortran.dg/unlimited_polymorphic_28.f90: New test.
+
 2018-01-15  Martin Sebor  <msebor@redhat.com>
 
        PR testsuite/83869

diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_28.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_28.f90
new file mode 100644 (file)
index 0000000..b474a24
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_28.f90
@@ -0,0 +1,51 @@
+! { dg-do compile }
+!
+! PR 82257: ICE in gfc_typename(), compare_rank(), resolve_structure_cons()
+
+module m1
+
+implicit none
+
+  type,abstract :: c_base
+  contains
+    procedure(i1),private,deferred :: f_base
+  end type c_base
+
+  abstract interface
+    function i1(this) result(res)
+      import
+      class(c_base),intent(IN) :: this
+      class(c_base), pointer :: res
+    end function i1
+  end interface
+
+  type,abstract,extends(c_base) :: c_derived
+  contains
+    procedure :: f_base => f_derived ! { dg-error "Type mismatch in function result \\(CLASS\\(\\*\\)/CLASS\\(c_base\\)\\)" }
+  end type c_derived
+
+contains
+
+  function f_derived(this) result(res) ! { dg-error "must be dummy, allocatable or pointer" }
+    class(c_derived), intent(IN) :: this
+    class(*) :: res
+  end function f_derived
+
+end module m1
+
+module m2
+
+implicit none
+
+  type :: t
+  contains
+    procedure :: p
+  end type t
+
+contains
+
+  class(*) function p(this) ! { dg-error "must be dummy, allocatable or pointer" }
+    class(t), intent(IN) :: this
+  end function p
+
+end module m2