2018-01-15 Louis Krupp <[email protected]>

	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  <[email protected]>

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


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@256720 138bc75d-0d04-0410-961f-82ee72b054a4

Author: lkrupp

gcc/fortran/ChangeLog

@@ -1,3 +1,12 @@
+2018-01-15  Louis Krupp  <[email protected]>
+
+	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  <[email protected]>
 
 	PR fortran/54613

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;

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

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

gcc/testsuite/ChangeLog

@@ -1,3 +1,8 @@
+2018-01-15  Louis Krupp  <[email protected]>
+
+	PR fortran/82257
+	* gfortran.dg/unlimited_polymorphic_28.f90: New test.
+
 2018-01-15  Martin Sebor  <[email protected]>
 
 	PR testsuite/83869

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