re PR fortran/45783 (ICE in gfc_add_component_ref, at fortran/class.c:77)

2010-09-26  Daniel Kraft  <d@domob.eu>

	PR fortran/45783
	PR fortran/45795
	* resolve.c (resolve_select_type): Clarify code.
	(resolve_assoc_var): Only set typespec if it is currently unknown.

2010-09-26  Daniel Kraft  <d@domob.eu>

	PR fortran/45783
	PR fortran/45795
	* gfortran.dg/select_type_18.f03: New test.

From-SVN: r164638

gcc/fortran/ChangeLog

@@ -1,3 +1,10 @@
+2010-09-26  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/45783
+	PR fortran/45795
+	* resolve.c (resolve_select_type): Clarify code.
+	(resolve_assoc_var): Only set typespec if it is currently unknown.
+
 2010-09-26  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR fortran/45793

gcc/fortran/resolve.c

@@ -7570,7 +7570,11 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
       sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
     }
 
-  sym->ts = target->ts;
+  /* Get type if this was not already set.  Note that it can be
+     some other type than the target in case this is a SELECT TYPE
+     selector!  So we must not update when the type is already there.  */
+  if (sym->ts.type == BT_UNKNOWN)
+    sym->ts = target->ts;
   gcc_assert (sym->ts.type != BT_UNKNOWN);
 
   /* See if this is a valid association-to-variable.  */
@@ -7673,8 +7677,8 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
 	      error++;
 	      continue;
 	    }
-	  else
-	    default_case = body;
+
+	  default_case = body;
 	}
     }
     

gcc/testsuite/ChangeLog

@@ -1,3 +1,9 @@
+2010-09-26  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/45783
+	PR fortran/45795
+	* gfortran.dg/select_type_18.f03: New test.
+
 2010-09-25  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* gnat.dg/return2.ad[sb]: New test.

gcc/testsuite/gfortran.dg/select_type_18.f03

@@ -0,0 +1,90 @@
+! { dg-do compile }
+
+! PR fortran/45783
+! PR fortran/45795
+! This used to fail because of incorrect compile-time typespec on the
+! SELECT TYPE selector.
+
+! This is the test-case from PR 45795.
+! Contributed by Salvatore Filippone, sfilippone@uniroma2.it.
+
+module base_mod
+  
+  type  :: base
+    integer     :: m, n
+  end type base
+
+end module base_mod
+
+module s_base_mod
+  
+  use base_mod
+
+  type, extends(base) :: s_base
+  contains
+    procedure, pass(a) :: cp_to_foo   => s_base_cp_to_foo   
+    
+  end type s_base
+  
+  
+  type, extends(s_base) :: s_foo
+    
+    integer              :: nnz
+    integer, allocatable :: ia(:), ja(:)
+    real, allocatable :: val(:)
+    
+  contains
+    
+    procedure, pass(a) :: cp_to_foo    => s_cp_foo_to_foo
+    
+  end type s_foo
+  
+  
+  interface 
+    subroutine s_base_cp_to_foo(a,b,info) 
+      import :: s_base, s_foo
+      class(s_base), intent(in) :: a
+      class(s_foo), intent(inout) :: b
+      integer, intent(out)            :: info
+    end subroutine s_base_cp_to_foo
+  end interface
+  
+  interface 
+    subroutine s_cp_foo_to_foo(a,b,info) 
+      import :: s_foo
+      class(s_foo), intent(in) :: a
+      class(s_foo), intent(inout) :: b
+      integer, intent(out)            :: info
+    end subroutine s_cp_foo_to_foo
+  end interface
+
+end module s_base_mod
+
+
+subroutine trans2(a,b)
+  use s_base_mod
+  implicit none 
+
+  class(s_base), intent(out) :: a
+  class(base), intent(in)   :: b
+
+  type(s_foo) :: tmp
+  integer err_act, info
+
+
+  info = 0
+  select type(b)
+  class is (s_base)
+    call b%cp_to_foo(tmp,info)
+  class default
+    info = -1
+    write(*,*) 'Invalid dynamic type'
+  end select
+  
+  if (info /= 0) write(*,*) 'Error code ',info
+
+  return
+
+end subroutine trans2
+
+! { dg-final { cleanup-modules "base_mod s_base_mod" } }