re PR fortran/45420 ([OOP] polymorphic TBP call in a CLASS DEFAULT clause)
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 Janus Weil <janus@gcc.gnu.org> PR fortran/45420 * gfortran.dg/select_type_15.f03: New. From-SVN: r163594
This commit is contained in:
parent
ee1e5e63ec
commit
cbadd64af4
|
@ -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>
|
2010-08-27 Thomas Koenig <tkoenig@gcc.gnu.org>
|
||||||
|
|
||||||
PR fortran/45159
|
PR fortran/45159
|
||||||
|
|
|
@ -4460,6 +4460,12 @@ select_type_set_tmp (gfc_typespec *ts)
|
||||||
char name[GFC_MAX_SYMBOL_LEN];
|
char name[GFC_MAX_SYMBOL_LEN];
|
||||||
gfc_symtree *tmp;
|
gfc_symtree *tmp;
|
||||||
|
|
||||||
|
if (!ts)
|
||||||
|
{
|
||||||
|
select_type_stack->tmp = NULL;
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
|
||||||
if (!gfc_type_is_extensible (ts->u.derived))
|
if (!gfc_type_is_extensible (ts->u.derived))
|
||||||
return;
|
return;
|
||||||
|
|
||||||
|
@ -4708,6 +4714,7 @@ gfc_match_class_is (void)
|
||||||
c->where = gfc_current_locus;
|
c->where = gfc_current_locus;
|
||||||
c->ts.type = BT_UNKNOWN;
|
c->ts.type = BT_UNKNOWN;
|
||||||
new_st.ext.case_list = c;
|
new_st.ext.case_list = c;
|
||||||
|
select_type_set_tmp (NULL);
|
||||||
return MATCH_YES;
|
return MATCH_YES;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
|
@ -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>
|
2010-08-27 Jerry DeLisle <jvdelisle@gcc.gnu.org>
|
||||||
|
|
||||||
PR libfortran/43217
|
PR libfortran/43217
|
||||||
|
|
|
@ -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" } }
|
Loading…
Reference in New Issue