From 414e8be2b09d9a50d39d8c6d48ebc0a95f6e2040 Mon Sep 17 00:00:00 2001 From: Daniel Kraft Date: Sun, 26 Sep 2010 21:25:52 +0200 Subject: [PATCH] re PR fortran/45783 (ICE in gfc_add_component_ref, at fortran/class.c:77) 2010-09-26 Daniel Kraft 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 PR fortran/45783 PR fortran/45795 * gfortran.dg/select_type_18.f03: New test. From-SVN: r164638 --- gcc/fortran/ChangeLog | 7 ++ gcc/fortran/resolve.c | 10 ++- gcc/testsuite/ChangeLog | 6 ++ gcc/testsuite/gfortran.dg/select_type_18.f03 | 90 ++++++++++++++++++++ 4 files changed, 110 insertions(+), 3 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/select_type_18.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 33afd97171d..f6655005cab 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2010-09-26 Daniel Kraft + + 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 PR fortran/45793 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 0dce3f86b18..6b5bbfa742a 100644 --- a/gcc/fortran/resolve.c +++ b/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; } } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index d9853727d4f..536003f3718 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2010-09-26 Daniel Kraft + + PR fortran/45783 + PR fortran/45795 + * gfortran.dg/select_type_18.f03: New test. + 2010-09-25 Eric Botcazou * gnat.dg/return2.ad[sb]: New test. diff --git a/gcc/testsuite/gfortran.dg/select_type_18.f03 b/gcc/testsuite/gfortran.dg/select_type_18.f03 new file mode 100644 index 00000000000..e4bacd377e7 --- /dev/null +++ b/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" } } -- 2.30.2