re PR fortran/66366 ([OOP] ICE on invalid with non-allocatable CLASS variable)

2016-11-13  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/66366
	* resolve.c (resolve_component): Move check for C437
	to ...
	* decl.c (build_struct): ... here. Fix indentation.

2016-11-13  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/66366
	* gfortran.dg/class_57.f90: Changed error message.
	* gfortran.dg/class_60.f90: New test.

From-SVN: r242351

6 files changed, 58 insertions, 16 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 6e0b654..a9db062 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2016-11-13  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/66366
+	* resolve.c (resolve_component): Move check for C437
+	to ...
+	* decl.c (build_struct): ... here. Fix indentation.
+
 2016-11-12  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/77501
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index b17a8aa..4f5c0cf 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -1866,9 +1866,18 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
 	}
       else if (current_attr.allocatable == 0)
 	{
-      gfc_error ("Component at %C must have the POINTER attribute");
-      return false;
+	  gfc_error ("Component at %C must have the POINTER attribute");
+	  return false;
+	}
     }
+
+  /* F03:C437.  */
+  if (current_ts.type == BT_CLASS
+      && !(current_attr.pointer || current_attr.allocatable))
+    {
+      gfc_error ("Component %qs with CLASS at %C must be allocatable "
+                 "or pointer", name);
+      return false;
     }
 
   if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index faf7dde..c85525a 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -13587,19 +13587,6 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
       return false;
     }
 
-  /* C437.  */
-  if (c->ts.type == BT_CLASS && c->attr.flavor != FL_PROCEDURE
-      && (!c->attr.class_ok
-          || !(CLASS_DATA (c)->attr.class_pointer
-               || CLASS_DATA (c)->attr.allocatable)))
-    {
-      gfc_error ("Component %qs with CLASS at %L must be allocatable "
-                 "or pointer", c->name, &c->loc);
-      /* Prevent a recurrence of the error.  */
-      c->ts.type = BT_UNKNOWN;
-      return false;
-    }
-
   /* If an allocatable component derived type is of the same type as
      the enclosing derived type, we need a vtable generating so that
      the __deallocate procedure is created.  */
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 844b4b8..65fbaad 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2016-11-13  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/66366
+	* gfortran.dg/class_57.f90: Changed error message.
+	* gfortran.dg/class_60.f90: New test.
+
 2016-11-12  David Edelsohn  <dje.gcc@gmail.com>
 
 	* g++.dg/pr78112.C: XFAIL AIX.
diff --git a/gcc/testsuite/gfortran.dg/class_57.f90 b/gcc/testsuite/gfortran.dg/class_57.f90
index 7256dfc..8104338 100644
--- a/gcc/testsuite/gfortran.dg/class_57.f90
+++ b/gcc/testsuite/gfortran.dg/class_57.f90
@@ -18,7 +18,7 @@ contains
   function pc(pd)
     type(p) :: pc
     class(d), intent(in), target :: pd
-    pc%cc => pd   ! { dg-error "Non-POINTER in pointer association context" }
+    pc%cc => pd   ! { dg-error "is not a member of" }
   end function
 
 end
diff --git a/gcc/testsuite/gfortran.dg/class_60.f90 b/gcc/testsuite/gfortran.dg/class_60.f90
new file mode 100644
index 0000000..f51c483
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_60.f90
@@ -0,0 +1,33 @@
+! { dg-do compile }
+!
+! PR 66366: [OOP] ICE on invalid with non-allocatable CLASS variable
+!
+! Contributed by Andrew Benson <abensonca@gmail.com>
+
+module bug
+
+  type :: t1d
+   contains
+     procedure :: interpolate => interp
+  end type t1d
+
+  type :: tff
+     class(t1d) :: transfer  ! { dg-error "must be allocatable or pointer" }
+  end type tff
+
+contains
+
+  double precision function interp(self)
+    implicit none
+    class(t1d), intent(inout) :: self
+    return
+  end function interp
+
+  double precision function fvb(self)
+    implicit none
+    class(tff), intent(inout) :: self
+    fvb=self%transfer%interpolate()  ! { dg-error "is not a member of" }
+    return
+  end function fvb
+
+end module bug