1! { dg-do run } 2! 3! PR 45420: [OOP] polymorphic TBP call in a CLASS DEFAULT clause 4! 5! Contributed by Salvatore Filippone <salvatore.filippone@uniroma2.it> 6 7 8module base_mat_mod 9 10 type :: base_sparse_mat 11 contains 12 procedure, pass(a) :: get_fmt => base_get_fmt 13 end type base_sparse_mat 14 15contains 16 17 function base_get_fmt(a) result(res) 18 implicit none 19 class(base_sparse_mat), intent(in) :: a 20 character(len=5) :: res 21 res = 'NULL' 22 end function base_get_fmt 23 24end module base_mat_mod 25 26 27module d_base_mat_mod 28 29 use base_mat_mod 30 31 type, extends(base_sparse_mat) :: d_base_sparse_mat 32 contains 33 procedure, pass(a) :: get_fmt => d_base_get_fmt 34 end type d_base_sparse_mat 35 36 type, extends(d_base_sparse_mat) :: x_base_sparse_mat 37 contains 38 procedure, pass(a) :: get_fmt => x_base_get_fmt 39 end type x_base_sparse_mat 40 41contains 42 43 function d_base_get_fmt(a) result(res) 44 implicit none 45 class(d_base_sparse_mat), intent(in) :: a 46 character(len=5) :: res 47 res = 'DBASE' 48 end function d_base_get_fmt 49 50 function x_base_get_fmt(a) result(res) 51 implicit none 52 class(x_base_sparse_mat), intent(in) :: a 53 character(len=5) :: res 54 res = 'XBASE' 55 end function x_base_get_fmt 56 57end module d_base_mat_mod 58 59 60program bug20 61 use d_base_mat_mod 62 class(d_base_sparse_mat), allocatable :: a 63 64 allocate(x_base_sparse_mat :: a) 65 if (a%get_fmt()/="XBASE") STOP 1 66 67 select type(a) 68 type is (d_base_sparse_mat) 69 STOP 2 70 class default 71 if (a%get_fmt()/="XBASE") STOP 3 72 end select 73 74end program bug20 75