re PR fortran/78800 ([OOP] ICE in compare_parameter, at fortran/interface.c:2246)

2016-12-15  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/78800
	* interface.c (compare_allocatable): Avoid additional errors on bad
	class declarations.
	(compare_parameter): Put the result of gfc_expr_attr into a variable,
	in order to avoid calling it multiple times. Exit early on bad class
	declarations to avoid ICE.

2016-12-15  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/78800
	* gfortran.dg/unlimited_polymorphic_27.f90: New test case.

From-SVN: r243691

4 files changed, 40 insertions, 9 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 17bc404..604c4d4 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,12 @@
+2016-12-15  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/78800
+	* interface.c (compare_allocatable): Avoid additional errors on bad
+	class declarations.
+	(compare_parameter): Put the result of gfc_expr_attr into a variable,
+	in order to avoid calling it multiple times. Exit early on bad class
+	declarations to avoid ICE.
+
 2016-12-14  Martin Jambor  <mjambor@suse.cz>
 
 	* trans-openmp.c: Include omp-general.h.
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index a6f4e72..8c09b90 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -2075,13 +2075,13 @@ done:
 static int
 compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
 {
-  symbol_attribute attr;
-
   if (formal->attr.allocatable
       || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)->attr.allocatable))
     {
-      attr = gfc_expr_attr (actual);
-      if (!attr.allocatable)
+      symbol_attribute attr = gfc_expr_attr (actual);
+      if (actual->ts.type == BT_CLASS && !attr.class_ok)
+	return 1;
+      else if (!attr.allocatable)
 	return 0;
     }
 
@@ -2237,6 +2237,10 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
       return 0;
     }
 
+  symbol_attribute actual_attr = gfc_expr_attr (actual);
+  if (actual->ts.type == BT_CLASS && !actual_attr.class_ok)
+    return 1;
+
   if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
       && actual->ts.type != BT_HOLLERITH
       && formal->ts.type != BT_ASSUMED
@@ -2278,9 +2282,6 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 	  return 0;
 	}
 
-      if (!gfc_expr_attr (actual).class_ok)
-	return 0;
-
       if ((!UNLIMITED_POLY (formal) || !UNLIMITED_POLY(actual))
 	  && !gfc_compare_derived_types (CLASS_DATA (actual)->ts.u.derived,
 					 CLASS_DATA (formal)->ts.u.derived))
@@ -2345,7 +2346,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
       /* F2015, 12.5.2.8.  */
       if (formal->attr.dimension
 	  && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE)
-	  && gfc_expr_attr (actual).dimension
+	  && actual_attr.dimension
 	  && !gfc_is_simply_contiguous (actual, true, true))
 	{
 	  if (where)
@@ -2406,7 +2407,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
     }
 
   if (formal->attr.allocatable && !formal->attr.codimension
-      && gfc_expr_attr (actual).codimension)
+      && actual_attr.codimension)
     {
       if (formal->attr.intent == INTENT_OUT)
 	{
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 081bfe1..9a95e01 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2016-12-15  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/78800
+	* gfortran.dg/unlimited_polymorphic_27.f90: New test case.
+
 2016-12-15  Toma Tabacu  <toma.tabacu@imgtec.com>
 
 	* gcc.target/mips/mips.exp (mips-dg-options): Upgrade to R2 for
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_27.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_27.f90
new file mode 100644
index 0000000..c16831e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_27.f90
@@ -0,0 +1,16 @@
+! { dg-do compile }
+!
+! PR 78800: [OOP] ICE in compare_parameter, at fortran/interface.c:2246
+!
+! Contributed by Gerhard Steinmetz <gerhard.steinmetz.fortran@t-online.de>
+
+program p
+   type t
+   end type
+   class(*) :: z  ! { dg-error "must be dummy, allocatable or pointer" }
+   call s(z)
+contains
+   subroutine s(x)
+      type(t) :: x
+   end
+end