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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 2b488fc..d168a3b 100644 (file)
--- 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 5f25e96..3dfe088 100644 (file)
--- 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 9852af8..5afb08d 100644 (file)
--- 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 3fc7164..e9ab06a 100644 (file)
--- 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 ed4eeba..99fbf6f 100644 (file)
--- 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 0214c51..840dde9 100644 (file)
--- 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 (file)
index 0000000..eb942d1
--- /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