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;
c->where = gfc_current_locus;
c->ts.type = BT_UNKNOWN;
new_st.ext.case_list = c;
+ select_type_set_tmp (NULL);
return MATCH_YES;
}
--- /dev/null
+! { 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" } }