diff mbox

[Fortran] PR55763 - reject "type is(INTEGER)" with non-class(*) selector in SELECT TYPE

Message ID 50E99911.1030605@net-b.de
State New
Headers show

Commit Message

Tobias Burnus Jan. 6, 2013, 3:32 p.m. UTC 
A rather obvious fix, though one can think about the error wording.

Bootstrapped and regtested on x86-64-gnu-linux.
OK for the trunk?

Tobias

Comments

Paul Richard Thomas Jan. 7, 2013, 5:57 a.m. UTC | #1 
Dear Tobias,

This, as you say, is obvious.  OKfor trunk.

Thanks for the patch.

Paul

On 6 January 2013 16:32, Tobias Burnus <burnus@net-b.de> wrote:
> A rather obvious fix, though one can think about the error wording.
>
> Bootstrapped and regtested on x86-64-gnu-linux.
> OK for the trunk?
>
> Tobias
diff mbox

Patch

2012-01-06  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-06  Tobias Burnus  <burnus@net-b.de>

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

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 54ac3c6..a3f0485 100644
--- 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/gfortran.dg/select_type_32.f90 b/gcc/testsuite/gfortran.dg/select_type_32.f90
new file mode 100644
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