2010-05-10 Janus Weil <janus@gcc.gnu.org>

	PR fortran/44044
	* match.c (gfc_match_select_type): Move error message to
	resolve_select_type.
	* resolve.c (resolve_select_type): Error message moved here from
	gfc_match_select_type. Correctly set type of temporary.


2010-05-10  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/44044
	* gfortran.dg/class_7.f03: Modified.
	* gfortran.dg/select_type_1.f03: Modified.
	* gfortran.dg/select_type_12.f03: New.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159217 138bc75d-0d04-0410-961f-82ee72b054a4

7 files changed, 87 insertions, 12 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 2b488fc7ac0..d168a3b44aa 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2010-05-10  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44044
+	* match.c (gfc_match_select_type): Move error message to
+	resolve_select_type.
+	* resolve.c (resolve_select_type): Error message moved here from
+	gfc_match_select_type. Correctly set type of temporary.
+
 2010-05-10  Richard Guenther  <rguenther@suse.de>
 
 	* trans-decl.c (gfc_build_library_function_decl): Split out
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 5f25e9661e5..3dfe0880bfe 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -4314,7 +4314,10 @@ gfc_match_select_type (void)
       expr1->expr_type = EXPR_VARIABLE;
       if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
 	return MATCH_ERROR;
-      expr1->symtree->n.sym->ts = expr2->ts;
+      if (expr2->ts.type == BT_UNKNOWN)
+	expr1->symtree->n.sym->attr.untyped = 1;
+      else
+	expr1->symtree->n.sym->ts = expr2->ts;
       expr1->symtree->n.sym->attr.referenced = 1;
       expr1->symtree->n.sym->attr.class_ok = 1;
     }
@@ -4337,14 +4340,6 @@ gfc_match_select_type (void)
       return MATCH_ERROR;
     }
 
-  /* Check for F03:C813.  */
-  if (expr1->ts.type != BT_CLASS && !(expr2 && expr2->ts.type == BT_CLASS))
-    {
-      gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
-		 "at %C");
-      return MATCH_ERROR;
-    }
-
   new_st.op = EXEC_SELECT_TYPE;
   new_st.expr1 = expr1;
   new_st.expr2 = expr2;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 9852af8eac1..5afb08d516f 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -7078,8 +7078,21 @@ resolve_select_type (gfc_code *code)
   ns = code->ext.ns;
   gfc_resolve (ns);
 
+  /* Check for F03:C813.  */
+  if (code->expr1->ts.type != BT_CLASS
+      && !(code->expr2 && code->expr2->ts.type == BT_CLASS))
+    {
+      gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
+		 "at %L", &code->loc);
+      return;
+    }
+
   if (code->expr2)
-    selector_type = code->expr2->ts.u.derived->components->ts.u.derived;
+    {
+      if (code->expr1->symtree->n.sym->attr.untyped)
+	code->expr1->symtree->n.sym->ts = code->expr2->ts;
+      selector_type = code->expr2->ts.u.derived->components->ts.u.derived;
+    }
   else
     selector_type = code->expr1->ts.u.derived->components->ts.u.derived;
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 3fc716486c9..e9ab06abbb5 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2010-05-10  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44044
+	* gfortran.dg/class_7.f03: Modified.
+	* gfortran.dg/select_type_1.f03: Modified.
+	* gfortran.dg/select_type_12.f03: New.
+
 2010-05-10  Richard Guenther  <rguenther@suse.de>
 
 	PR tree-optimization/44050
diff --git a/gcc/testsuite/gfortran.dg/class_7.f03 b/gcc/testsuite/gfortran.dg/class_7.f03
index ed4eeba9340..99fbf6fc69b 100644
--- a/gcc/testsuite/gfortran.dg/class_7.f03
+++ b/gcc/testsuite/gfortran.dg/class_7.f03
@@ -16,6 +16,6 @@
   class(t1), pointer :: c  ! { dg-error "before it is defined" }
 
   select type (c)          ! { dg-error "shall be polymorphic" }
-    type is (t1)           ! { dg-error "Unexpected" }
-  end select               ! { dg-error "Expecting END PROGRAM" }
+    type is (t0)
+  end select
 end
diff --git a/gcc/testsuite/gfortran.dg/select_type_1.f03 b/gcc/testsuite/gfortran.dg/select_type_1.f03
index 0214c51a04f..840dde922f2 100644
--- a/gcc/testsuite/gfortran.dg/select_type_1.f03
+++ b/gcc/testsuite/gfortran.dg/select_type_1.f03
@@ -33,6 +33,7 @@
   select type (3.5)  ! { dg-error "is not a named variable" }
   select type (a%cp) ! { dg-error "is not a named variable" }
   select type (b)    ! { dg-error "Selector shall be polymorphic" }
+  end select
 
   select type (a)
     print *,"hello world!"  ! { dg-error "Expected TYPE IS, CLASS IS or END SELECT" }
diff --git a/gcc/testsuite/gfortran.dg/select_type_12.f03 b/gcc/testsuite/gfortran.dg/select_type_12.f03
new file mode 100644
index 00000000000..eb942d1e13b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/select_type_12.f03
@@ -0,0 +1,51 @@
+! { dg-do compile }
+!
+! PR 44044: [OOP] SELECT TYPE with class-valued function
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+implicit none
+
+type :: t1
+  integer :: i
+end type
+
+type, extends(t1) :: t2
+end type
+
+type(t1),target :: x1
+type(t2),target :: x2
+
+select type ( y => fun(1) )
+type is (t1)
+  print *,"t1"
+type is (t2)
+  print *,"t2"
+class default
+  print *,"default"
+end select
+
+select type ( y => fun(-1) )
+type is (t1)
+  print *,"t1"
+type is (t2)
+  print *,"t2"
+class default
+  print *,"default"
+end select
+
+contains
+
+  function fun(i)
+    class(t1),pointer :: fun
+    integer :: i
+    if (i>0) then
+      fun => x1
+    else if (i<0) then
+      fun => x2
+    else
+      fun => NULL()
+    end if
+  end function
+
+end