|
111
|
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
|
|
|
8 module 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
|
|
|
15 contains
|
|
|
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
|
|
|
24 end module base_mat_mod
|
|
|
25
|
|
|
26
|
|
|
27 module 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
|
|
|
41 contains
|
|
|
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
|
|
|
57 end module d_base_mat_mod
|
|
|
58
|
|
|
59
|
|
|
60 program bug20
|
|
|
61 use d_base_mat_mod
|
|
|
62 class(d_base_sparse_mat), allocatable :: a
|
|
|
63
|
|
|
64 allocate(x_base_sparse_mat :: a)
|
|
131
|
65 if (a%get_fmt()/="XBASE") STOP 1
|
|
111
|
66
|
|
|
67 select type(a)
|
|
|
68 type is (d_base_sparse_mat)
|
|
131
|
69 STOP 2
|
|
111
|
70 class default
|
|
131
|
71 if (a%get_fmt()/="XBASE") STOP 3
|
|
111
|
72 end select
|
|
|
73
|
|
|
74 end program bug20
|
