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