Skip to content

Commit 34248e5

Browse files
zozihazoziha
committed
Add array checking support for check 
1 parent 68e22b8 commit 34248e5

File tree

5 files changed

+1723
-0
lines changed

5 files changed

+1723
-0
lines changed

‎src/testdrive.F90‎

Lines changed: 238 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -212,6 +212,8 @@ module testdrive
212212
module procedure :: check_int_i8
213213
module procedure :: check_bool
214214
module procedure :: check_string
215+
module procedure :: check_single_array
216+
module procedure :: check_double_array
215217
end interface check
216218

217219

@@ -1969,4 +1971,240 @@ end function is_nan_qp
19691971
#endif
19701972

19711973

1974+
subroutine error_wrap(error, more)
1975+
!> Error handling
1976+
type(error_type), intent(inout) :: error
1977+
!> Error message
1978+
character(len=*), intent(in) :: more
1979+
1980+
character(len=*), parameter :: skip = new_line("a") // repeat(" ", 11)
1981+
1982+
error%message = error%message // skip // more
1983+
1984+
end subroutine error_wrap
1985+
1986+
1987+
subroutine check_single_array(error, array, message, more)
1988+
1989+
!> Error handing
1990+
type(error_type), allocatable, intent(out) :: error
1991+
1992+
!> The array to be checked
1993+
class(*), intent(in), target :: array(:)
1994+
1995+
!> A detailed message describing the error
1996+
character(len=*), intent(in), optional :: message
1997+
1998+
!> Another line of error message
1999+
character(len=*), intent(in), optional :: more
2000+
2001+
integer :: i
2002+
class(*), pointer :: item(:) ! @note gfortran <=10 does not support syntax: associate(item => array(i))
2003+
2004+
item => array
2005+
do i = 1, size(array)
2006+
select type (item)
2007+
type is (integer)
2008+
call check(error, item(i), message, more)
2009+
type is (logical)
2010+
call check(error, item(i), message, more)
2011+
type is (real(sp))
2012+
call check(error, item(i), message, more)
2013+
type is (real(dp))
2014+
call check(error, item(i), message, more)
2015+
type is (complex(sp))
2016+
call check(error, item(i), message, more)
2017+
type is (complex(dp))
2018+
call check(error, item(i), message, more)
2019+
#if WITH_XDP
2020+
type is (real(xdp))
2021+
call check(error, item(i), message, more)
2022+
type is (complex(xdp))
2023+
call check(error, item(i), message, more)
2024+
#endif
2025+
#if WITH_QP
2026+
type is (real(qp))
2027+
call check(error, item(i), message, more)
2028+
type is (complex(qp))
2029+
call check(error, item(i), message, more)
2030+
#endif
2031+
end select
2032+
if (allocated(error)) then
2033+
call error_wrap(error, "Array check failed at element index "//trim(ch(i)))
2034+
return
2035+
end if
2036+
end do
2037+
2038+
end subroutine check_single_array
2039+
2040+
2041+
subroutine check_double_array(error, actual, expected, message, more, thr, rel)
2042+
2043+
!> Error handling
2044+
type(error_type), allocatable, intent(out) :: error
2045+
2046+
!> Found values
2047+
class(*), intent(in), target :: actual(:)
2048+
2049+
!> Expected values
2050+
class(*), intent(in), target :: expected(:)
2051+
2052+
!> A detailed message describing the error
2053+
character(len=*), intent(in), optional :: message
2054+
2055+
!> Another line of error message
2056+
character(len=*), intent(in), optional :: more
2057+
2058+
!> Allowed threshold for matching floating point values
2059+
class(*), intent(in), optional :: thr
2060+
2061+
!> Check for relative errors instead
2062+
logical, intent(in), optional :: rel
2063+
2064+
integer :: i
2065+
class(*), pointer :: item1(:), item2(:)
2066+
2067+
item1 => actual
2068+
item2 => expected
2069+
do i = 1, size(expected)
2070+
select type (item1)
2071+
type is (integer(i1))
2072+
select type (item2)
2073+
type is (integer(i1))
2074+
call check(error, item1(i), item2(i), message, more)
2075+
end select
2076+
type is (integer(i2))
2077+
select type (item2)
2078+
type is (integer(i2))
2079+
call check(error, item1(i), item2(i), message, more)
2080+
end select
2081+
type is (integer(i4))
2082+
select type (item2)
2083+
type is (integer(i4))
2084+
call check(error, item1(i), item2(i), message, more)
2085+
end select
2086+
type is (integer(i8))
2087+
select type (item2)
2088+
type is (integer(i8))
2089+
call check(error, item1(i), item2(i), message, more)
2090+
end select
2091+
type is (logical)
2092+
select type (item2)
2093+
type is (logical)
2094+
call check(error, item1(i), item2(i), message, more)
2095+
end select
2096+
type is (character(*))
2097+
select type (item2)
2098+
type is (character(*))
2099+
call check(error, item1(i), item2(i), message, more)
2100+
end select
2101+
type is (real(sp))
2102+
select type (item2)
2103+
type is (real(sp))
2104+
if (present(thr)) then
2105+
select type (thr)
2106+
type is (real(sp))
2107+
call check(error, item1(i), item2(i), message, more, thr, rel)
2108+
end select
2109+
else
2110+
call check(error, item1(i), item2(i), message, more, rel=rel)
2111+
end if
2112+
end select
2113+
type is (real(dp))
2114+
select type (item2)
2115+
type is (real(dp))
2116+
if (present(thr)) then
2117+
select type (thr)
2118+
type is (real(dp))
2119+
call check(error, item1(i), item2(i), message, more, thr, rel)
2120+
end select
2121+
else
2122+
call check(error, item1(i), item2(i), message, more, rel=rel)
2123+
end if
2124+
end select
2125+
type is (complex(sp))
2126+
select type (item2)
2127+
type is (complex(sp))
2128+
if (present(thr)) then
2129+
select type (thr)
2130+
type is (real(sp))
2131+
call check(error, item1(i), item2(i), message, more, thr, rel)
2132+
end select
2133+
else
2134+
call check(error, item1(i), item2(i), message, more, rel=rel)
2135+
end if
2136+
end select
2137+
type is (complex(dp))
2138+
select type (item2)
2139+
type is (complex(dp))
2140+
if (present(thr)) then
2141+
select type (thr)
2142+
type is (real(dp))
2143+
call check(error, item1(i), item2(i), message, more, thr, rel)
2144+
end select
2145+
else
2146+
call check(error, item1(i), item2(i), message, more, rel=rel)
2147+
end if
2148+
end select
2149+
#if WITH_XDP
2150+
type is (real(xdp))
2151+
select type (item2)
2152+
type is (real(xdp))
2153+
if (present(thr)) then
2154+
select type (thr)
2155+
type is (real(xdp))
2156+
call check(error, item1(i), item2(i), message, more, thr, rel)
2157+
end select
2158+
else
2159+
call check(error, item1(i), item2(i), message, more, rel=rel)
2160+
end if
2161+
end select
2162+
type is (complex(xdp))
2163+
select type (item2)
2164+
type is (complex(xdp))
2165+
if (present(thr)) then
2166+
select type (thr)
2167+
type is (real(xdp))
2168+
call check(error, item1(i), item2(i), message, more, thr, rel)
2169+
end select
2170+
else
2171+
call check(error, item1(i), item2(i), message, more, rel=rel)
2172+
end if
2173+
end select
2174+
#endif
2175+
#if WITH_QP
2176+
type is (real(qp))
2177+
select type (item2)
2178+
type is (real(qp))
2179+
if (present(thr)) then
2180+
select type (thr)
2181+
type is (real(qp))
2182+
call check(error, item1(i), item2(i), message, more, thr, rel)
2183+
end select
2184+
else
2185+
call check(error, item1(i), item2(i), message, more, rel=rel)
2186+
end if
2187+
end select
2188+
type is (complex(qp))
2189+
select type (item2)
2190+
type is (complex(qp))
2191+
if (present(thr)) then
2192+
select type (thr)
2193+
type is (real(qp))
2194+
call check(error, item1(i), item2(i), message, more, thr, rel)
2195+
end select
2196+
else
2197+
call check(error, item1(i), item2(i), message, more, rel=rel)
2198+
end if
2199+
end select
2200+
#endif
2201+
end select
2202+
if (allocated(error)) then
2203+
call error_wrap(error, "Array check failed at element index "//trim(ch(i)))
2204+
return
2205+
end if
2206+
end do
2207+
2208+
end subroutine check_double_array
2209+
19722210
end module testdrive

‎test/CMakeLists.txt‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -15,6 +15,7 @@
1515
set(
1616
tests
1717
"check"
18+
"check_array"
1819
"select"
1920
)
2021
set(

‎test/main.f90‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,7 @@ program tester
1717
use testdrive, only : run_testsuite, new_testsuite, testsuite_type, &
1818
& select_suite, run_selected, get_argument
1919
use test_check, only : collect_check
20+
use test_check_array, only: collect_check_array
2021
use test_select, only : collect_select
2122
implicit none
2223
integer :: stat, is
@@ -28,6 +29,7 @@ program tester
2829

2930
testsuites = [ &
3031
new_testsuite("check", collect_check), &
32+
new_testsuite("check-array", collect_check_array), &
3133
new_testsuite("select", collect_select) &
3234
]
3335

‎test/meson.build‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -13,6 +13,7 @@
1313

1414
tests = [
1515
'check',
16+
'check_array',
1617
'select',
1718
]
1819

0 commit comments

Comments
 (0)