re PR fortran/44044 ([OOP] SELECT TYPE with class-valued function)

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.

From-SVN: r159217

gcc/fortran/ChangeLog

+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

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;

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;
 

gcc/testsuite/ChangeLog

+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

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

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" }

gcc/testsuite/gfortran.dg/select_type_12.f03

+! { 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