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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 8c2cb3cc4b185c24bd7501c5e020aee861360212..72661108e4f24a3d8d82c80dff58117fcbff9655 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+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

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index b81f2319aa64be625bac16b25076e5398c8482bd..70bfae614b3f84119a6e199b3ac3876a8cf229d5 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/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;
        }

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 217e40fc7da455a6bc3f0b4d3c6e23d6009654e5..0d36ca2cf39afdbcdb1ad9dc236dfe37461a332e 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+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

diff --git a/gcc/testsuite/gfortran.dg/select_type_32.f90 b/gcc/testsuite/gfortran.dg/select_type_32.f90
new file mode 100644 (file)
index 0000000..5e36639
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/select_type_32.f90
@@ -0,0 +1,25 @@
+! { 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