3 ! PR 45420: [OOP] polymorphic TBP call in a CLASS DEFAULT clause
5 ! Contributed by Salvatore Filippone <salvatore.filippone@uniroma2.it>
10 type :: base_sparse_mat
12 procedure, pass(a) :: get_fmt => base_get_fmt
13 end type base_sparse_mat
17 function base_get_fmt(a) result(res)
19 class(base_sparse_mat), intent(in) :: a
20 character(len=5) :: res
22 end function base_get_fmt
24 end module base_mat_mod
31 type, extends(base_sparse_mat) :: d_base_sparse_mat
33 procedure, pass(a) :: get_fmt => d_base_get_fmt
34 end type d_base_sparse_mat
36 type, extends(d_base_sparse_mat) :: x_base_sparse_mat
38 procedure, pass(a) :: get_fmt => x_base_get_fmt
39 end type x_base_sparse_mat
43 function d_base_get_fmt(a) result(res)
45 class(d_base_sparse_mat), intent(in) :: a
46 character(len=5) :: res
48 end function d_base_get_fmt
50 function x_base_get_fmt(a) result(res)
52 class(x_base_sparse_mat), intent(in) :: a
53 character(len=5) :: res
55 end function x_base_get_fmt
57 end module d_base_mat_mod
62 class(d_base_sparse_mat), allocatable :: a
64 allocate(x_base_sparse_mat :: a)
65 if (a%get_fmt()/="XBASE") call abort()
68 type is (d_base_sparse_mat)
71 if (a%get_fmt()/="XBASE") call abort()