1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
|
module class_57_mod
implicit none
type, abstract, public :: dumper
contains
procedure(to_toml), deferred :: dump_to_toml
procedure, non_overridable, private :: dump_to_file
generic :: dump => dump_to_file, dump_to_toml
end type dumper
type, extends(dumper) :: wrapper
integer :: x
contains
procedure :: dump_to_toml => dump_x
end type
type :: toml_table
integer :: key
end type
abstract interface
subroutine to_toml(self, x)
import dumper, toml_table
class(dumper), intent(in) :: self
type(toml_table), intent(inout) :: x
end subroutine
end interface
contains
! Private target for generic
subroutine dump_to_file(self, x)
class(dumper), intent(inout) :: self
integer, intent(in) :: x
type(toml_table) ::table
call self%dump(table)
if (table%key /= 5) error stop
end subroutine
subroutine dump_x(self, x)
class(wrapper), intent(in) :: self
type(toml_table), intent(inout) :: x
x%key = 5
end subroutine
subroutine test_assign(self)
class(dumper), allocatable, intent(inout) :: self
self = wrapper(5)
end subroutine
logical function test_polymorphic_arg(self)
class(dumper), intent(inout) :: self
test_polymorphic_arg = .false.
select type(self)
type is (wrapper)
self%x = 10
test_polymorphic_arg = .true.
end select
end function
end module class_57_mod
program class_57
use class_57_mod
implicit none
class(wrapper), allocatable :: temp
class(dumper), allocatable :: temp2
type(wrapper) :: w1
logical :: l1 = .false.
allocate(temp)
call temp%dump(3)
allocate(wrapper :: temp2)
call test_assign(temp2)
select type(temp2)
type is (wrapper)
if (temp2%x /= 5) error stop
class default
error stop
end select
l1 = test_polymorphic_arg(w1)
if (l1 .neqv. .true.) error stop
if (w1%x /= 10) error stop
end program class_57
|
