re PR fortran/55763 (Issues with some simpler CLASS(*) programs)

2012-01-07  Tobias Burnus  <burnus@net-b.de>

        PR fortran/55763
        * resolve.c (resolve_select_type): Reject intrinsic types for
        a non-unlimited-polymorphic selector.

2012-01-07  Tobias Burnus  <burnus@net-b.de>

        PR fortran/55763
        * gfortran.dg/select_type_32.f90: New.

From-SVN: r194962

gcc/fortran/ChangeLog

+2012-01-07  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/55763
+	* resolve.c (resolve_select_type): Reject intrinsic types for
+	a non-unlimited-polymorphic selector.
+
 2013-01-06  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/PR53876

gcc/fortran/resolve.c

@@ -8388,12 +8388,16 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
 	}
 
       /* Check F03:C816.  */
-      if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
-	  && !selector_type->attr.unlimited_polymorphic
-	  && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
+      if (c->ts.type != BT_UNKNOWN && !selector_type->attr.unlimited_polymorphic
+	  && ((c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
+	      || !gfc_type_is_extension_of (selector_type, c->ts.u.derived)))
 	{
-	  gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
-		     c->ts.u.derived->name, &c->where, selector_type->name);
+	  if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+	    gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
+		       c->ts.u.derived->name, &c->where, selector_type->name);
+	  else
+	    gfc_error ("Unexpected intrinsic type '%s' at %L",
+		       gfc_basic_typename (c->ts.type), &c->where);
 	  error++;
 	  continue;
 	}

gcc/testsuite/ChangeLog

+2012-01-07  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/55763
+	* gfortran.dg/select_type_32.f90: New.
+
 2013-01-04  Dodji Seketeli  <dodji@redhat.com>
 
 	PR c++/52343

gcc/testsuite/gfortran.dg/select_type_32.f90

+! { dg-do compile }
+!
+! PR fortran/55763
+!
+! Contributed by Harald Anlauf
+!
+
+module gfcbug122
+  implicit none
+  type myobj
+     class(*), allocatable :: x
+   contains
+     procedure :: print
+  end type myobj
+contains
+  subroutine print(this)
+    class(myobj) :: this
+    select type (this)
+    type is (integer) ! { dg-error "Unexpected intrinsic type 'INTEGER'" }
+    type is (real) ! { dg-error "Unexpected intrinsic type 'REAL'" }
+    type is (complex) ! { dg-error "Unexpected intrinsic type 'COMPLEX'" }
+    type is (character(len=*)) ! { dg-error "Unexpected intrinsic type 'CHARACTER'" }
+    end select
+  end subroutine print
+end module gfcbug122