===================================================================
@@ -7570,7 +7570,11 @@ resolve_assoc_var (gfc_symbol* sym, bool
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
error++;
continue;
}
- else
- default_case = body;
+
+ default_case = body;
}
}
===================================================================
@@ -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" } }