diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 7 | ||||
| -rw-r--r-- | gcc/fortran/match.c | 7 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 5 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/select_type_15.f03 | 77 |
4 files changed, 96 insertions, 0 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 9bd81c388b8..a15c13663ef 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2010-08-27 Janus Weil <janus@gcc.gnu.org> + + PR fortran/45420 + * match.c (select_type_set_tmp): Add the possibility to reset the + temporary to NULL. + (gfc_match_class_is): Reset the temporary in CLASS DEFAULT clauses. + 2010-08-27 Thomas Koenig <tkoenig@gcc.gnu.org> PR fortran/45159 diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 21dbcde8b7b..7c0dfc7478d 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -4460,6 +4460,12 @@ select_type_set_tmp (gfc_typespec *ts) char name[GFC_MAX_SYMBOL_LEN]; gfc_symtree *tmp; + if (!ts) + { + select_type_stack->tmp = NULL; + return; + } + if (!gfc_type_is_extensible (ts->u.derived)) return; @@ -4708,6 +4714,7 @@ gfc_match_class_is (void) c->where = gfc_current_locus; c->ts.type = BT_UNKNOWN; new_st.ext.case_list = c; + select_type_set_tmp (NULL); return MATCH_YES; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 734b2b7b213..bf917998c93 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2010-08-27 Janus Weil <janus@gcc.gnu.org> + + PR fortran/45420 + * gfortran.dg/select_type_15.f03: New. + 2010-08-27 Jerry DeLisle <jvdelisle@gcc.gnu.org> PR libfortran/43217 diff --git a/gcc/testsuite/gfortran.dg/select_type_15.f03 b/gcc/testsuite/gfortran.dg/select_type_15.f03 new file mode 100644 index 00000000000..6be045c097e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/select_type_15.f03 @@ -0,0 +1,77 @@ +! { dg-do run } +! +! PR 45420: [OOP] polymorphic TBP call in a CLASS DEFAULT clause +! +! Contributed by Salvatore Filippone <salvatore.filippone@uniroma2.it> + + +module base_mat_mod + + type :: base_sparse_mat + contains + procedure, pass(a) :: get_fmt => base_get_fmt + end type base_sparse_mat + +contains + + function base_get_fmt(a) result(res) + implicit none + class(base_sparse_mat), intent(in) :: a + character(len=5) :: res + res = 'NULL' + end function base_get_fmt + +end module base_mat_mod + + +module d_base_mat_mod + + use base_mat_mod + + type, extends(base_sparse_mat) :: d_base_sparse_mat + contains + procedure, pass(a) :: get_fmt => d_base_get_fmt + end type d_base_sparse_mat + + type, extends(d_base_sparse_mat) :: x_base_sparse_mat + contains + procedure, pass(a) :: get_fmt => x_base_get_fmt + end type x_base_sparse_mat + +contains + + function d_base_get_fmt(a) result(res) + implicit none + class(d_base_sparse_mat), intent(in) :: a + character(len=5) :: res + res = 'DBASE' + end function d_base_get_fmt + + function x_base_get_fmt(a) result(res) + implicit none + class(x_base_sparse_mat), intent(in) :: a + character(len=5) :: res + res = 'XBASE' + end function x_base_get_fmt + +end module d_base_mat_mod + + +program bug20 + use d_base_mat_mod + class(d_base_sparse_mat), allocatable :: a + + allocate(x_base_sparse_mat :: a) + if (a%get_fmt()/="XBASE") call abort() + + select type(a) + type is (d_base_sparse_mat) + call abort() + class default + if (a%get_fmt()/="XBASE") call abort() + end select + +end program bug20 + + +! { dg-final { cleanup-modules "base_mat_mod d_base_mat_mod" } } |
