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
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
|
module dealloc_01_testdrive
use, intrinsic :: iso_fortran_env, only : error_unit
implicit none
private
public :: run_testsuite, new_unittest, unittest_type, testsuite_type, &
error_type, skip_test
integer, parameter :: success = 0, fatal = 1, skipped = 77
type :: error_type
integer :: stat = success
character(len=:), allocatable :: message
end type error_type
abstract interface
subroutine test_interface(error)
import :: error_type
type(error_type), allocatable, intent(out) :: error
end subroutine test_interface
end interface
type :: unittest_type
character(len=:), allocatable :: name
procedure(test_interface), pointer, nopass :: test => null()
logical :: should_fail = .false.
end type unittest_type
abstract interface
subroutine collect_interface(testsuite)
import :: unittest_type
type(unittest_type), allocatable, intent(out) :: testsuite(:)
end subroutine collect_interface
end interface
type :: testsuite_type
character(len=:), allocatable :: name
procedure(collect_interface), pointer, nopass :: collect => null()
end type testsuite_type
character(len=*), parameter :: fmt = '(1x, *(1x, a))'
contains
recursive subroutine run_testsuite(collect, unit, stat, parallel)
procedure(collect_interface) :: collect
integer, intent(in) :: unit
integer, intent(inout) :: stat
logical, intent(in), optional :: parallel
type(unittest_type), allocatable :: testsuite(:)
integer :: it
logical :: parallel_
parallel_ = .true.
if(present(parallel)) parallel_ = parallel
call collect(testsuite)
do it = 1, size(testsuite)
write(unit, '(1x, 3(1x, a), 1x, "(", i0, "/", i0, ")")') &
& "Starting", testsuite(it)%name, "...", it, size(testsuite)
call run_unittest(testsuite(it), unit, stat)
end do
end subroutine run_testsuite
recursive subroutine run_unittest(test_var, unit, stat)
type(unittest_type), intent(in) :: test_var
integer, intent(in) :: unit
integer, intent(inout) :: stat
type(error_type), allocatable :: error
character(len=:), allocatable :: message
call test_var%test(error)
if (.not.test_skipped(error)) then
if (allocated(error) .neqv. test_var%should_fail) stat = stat + 1
end if
call make_output(message, test_var, error)
write(unit, '(a)') message
end subroutine run_unittest
pure function test_skipped(error) result(is_skipped)
type(error_type), intent(in), optional :: error
logical :: is_skipped
is_skipped = .false.
if (present(error)) then
is_skipped = error%stat == skipped
end if
end function test_skipped
pure subroutine make_output(output, test, error)
character(len=:), allocatable, intent(out) :: output
type(unittest_type), intent(in) :: test
type(error_type), intent(in), optional :: error
character(len=:), allocatable :: label
character(len=*), parameter :: indent = " " // "..." // " "
if (test_skipped(error)) then
output = indent // test%name // " [SKIPPED]" &
& // new_line("a") // " Message: " // error%message
return
end if
if (present(error) .neqv. test%should_fail) then
if (test%should_fail) then
label = " [UNEXPECTED PASS]"
else
label = " [FAILED]"
end if
else
if (test%should_fail) then
label = " [EXPECTED FAIL]"
else
label = " [PASSED]"
end if
end if
output = indent // test%name // label
if (present(error)) then
output = output // new_line("a") // " Message: " // error%message
end if
end subroutine make_output
function new_unittest(name, test, should_fail) result(self)
character(len=*), intent(in) :: name
procedure(test_interface) :: test
logical, intent(in), optional :: should_fail
type(unittest_type) :: self
self%name = name
self%test => test
if (present(should_fail)) self%should_fail = should_fail
end function new_unittest
subroutine test_failed(error, message, more, and_more)
type(error_type), allocatable, intent(out) :: error
character(len=*), intent(in) :: message
character(len=*), intent(in), optional :: more
character(len=*), intent(in), optional :: and_more
character(len=*), parameter :: skip = new_line("a") // " "
allocate(error)
error%stat = fatal
error%message = message
if (present(more)) then
error%message = error%message // skip // more
end if
if (present(and_more)) then
error%message = error%message // skip // and_more
end if
end subroutine test_failed
subroutine skip_test(error, message, more, and_more)
type(error_type), allocatable, intent(out) :: error
character(len=*), intent(in) :: message
character(len=*), intent(in), optional :: more
character(len=*), intent(in), optional :: and_more
call test_failed(error, message, more, and_more)
error%stat = skipped
end subroutine skip_test
end module
module dealloc_01_linalg
use dealloc_01_testdrive, only : new_unittest, unittest_type, error_type, skip_test
implicit none
contains
subroutine collect_linalg(testsuite)
type(unittest_type), allocatable, intent(out) :: testsuite(:)
testsuite = [ &
new_unittest("diag_rqp", test_diag_rqp) &
]
end subroutine collect_linalg
subroutine test_diag_rqp(error)
type(error_type), allocatable, intent(out) :: error
call skip_test(error, "Quadruple precision is not enabled")
end subroutine test_diag_rqp
end module
program dealloc_01
use, intrinsic :: iso_fortran_env, only : error_unit
use dealloc_01_testdrive, only : run_testsuite, testsuite_type
use dealloc_01_linalg, only : collect_linalg
implicit none
integer :: stat
type(testsuite_type), allocatable :: testsuites(:)
stat = 0
call run_testsuite(collect_linalg, error_unit, stat)
print *, "stat: ", stat
if (stat > 0) error stop
end program
|
