From 41d8652cbe5af167ae7aeeeb4cfb81aa11a4d2ac Mon Sep 17 00:00:00 2001 From: zoziha Date: Mon, 20 Jun 2022 09:06:24 +0800 Subject: [PATCH 1/7] Add array checking support for `check` --- src/testdrive.F90 | 238 ++++++ test/CMakeLists.txt | 1 + test/main.f90 | 2 + test/meson.build | 1 + test/test_check_array.F90 | 1481 +++++++++++++++++++++++++++++++++++++ 5 files changed, 1723 insertions(+) create mode 100644 test/test_check_array.F90 diff --git a/src/testdrive.F90 b/src/testdrive.F90 index 0ac587e..e55a522 100644 --- a/src/testdrive.F90 +++ b/src/testdrive.F90 @@ -212,6 +212,8 @@ module testdrive module procedure :: check_int_i8 module procedure :: check_bool module procedure :: check_string + module procedure :: check_single_array + module procedure :: check_double_array end interface check @@ -1969,4 +1971,240 @@ end function is_nan_qp #endif + subroutine error_wrap(error, more) + !> Error handling + type(error_type), intent(inout) :: error + !> Error message + character(len=*), intent(in) :: more + + character(len=*), parameter :: skip = new_line("a") // repeat(" ", 11) + + error%message = error%message // skip // more + + end subroutine error_wrap + + + subroutine check_single_array(error, array, message, more) + + !> Error handing + type(error_type), allocatable, intent(out) :: error + + !> The array to be checked + class(*), intent(in), target :: array(:) + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + integer :: i + class(*), pointer :: item(:) ! @note gfortran <=10 does not support syntax: associate(item => array(i)) + + item => array + do i = 1, size(array) + select type (item) + type is (integer) + call check(error, item(i), message, more) + type is (logical) + call check(error, item(i), message, more) + type is (real(sp)) + call check(error, item(i), message, more) + type is (real(dp)) + call check(error, item(i), message, more) + type is (complex(sp)) + call check(error, item(i), message, more) + type is (complex(dp)) + call check(error, item(i), message, more) +#if WITH_XDP + type is (real(xdp)) + call check(error, item(i), message, more) + type is (complex(xdp)) + call check(error, item(i), message, more) +#endif +#if WITH_QP + type is (real(qp)) + call check(error, item(i), message, more) + type is (complex(qp)) + call check(error, item(i), message, more) +#endif + end select + if (allocated(error)) then + call error_wrap(error, "Array check failed at element index "//trim(ch(i))) + return + end if + end do + + end subroutine check_single_array + + + subroutine check_double_array(error, actual, expected, message, more, thr, rel) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found values + class(*), intent(in), target :: actual(:) + + !> Expected values + class(*), intent(in), target :: expected(:) + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + !> Allowed threshold for matching floating point values + class(*), intent(in), optional :: thr + + !> Check for relative errors instead + logical, intent(in), optional :: rel + + integer :: i + class(*), pointer :: item1(:), item2(:) + + item1 => actual + item2 => expected + do i = 1, size(expected) + select type (item1) + type is (integer(i1)) + select type (item2) + type is (integer(i1)) + call check(error, item1(i), item2(i), message, more) + end select + type is (integer(i2)) + select type (item2) + type is (integer(i2)) + call check(error, item1(i), item2(i), message, more) + end select + type is (integer(i4)) + select type (item2) + type is (integer(i4)) + call check(error, item1(i), item2(i), message, more) + end select + type is (integer(i8)) + select type (item2) + type is (integer(i8)) + call check(error, item1(i), item2(i), message, more) + end select + type is (logical) + select type (item2) + type is (logical) + call check(error, item1(i), item2(i), message, more) + end select + type is (character(*)) + select type (item2) + type is (character(*)) + call check(error, item1(i), item2(i), message, more) + end select + type is (real(sp)) + select type (item2) + type is (real(sp)) + if (present(thr)) then + select type (thr) + type is (real(sp)) + call check(error, item1(i), item2(i), message, more, thr, rel) + end select + else + call check(error, item1(i), item2(i), message, more, rel=rel) + end if + end select + type is (real(dp)) + select type (item2) + type is (real(dp)) + if (present(thr)) then + select type (thr) + type is (real(dp)) + call check(error, item1(i), item2(i), message, more, thr, rel) + end select + else + call check(error, item1(i), item2(i), message, more, rel=rel) + end if + end select + type is (complex(sp)) + select type (item2) + type is (complex(sp)) + if (present(thr)) then + select type (thr) + type is (real(sp)) + call check(error, item1(i), item2(i), message, more, thr, rel) + end select + else + call check(error, item1(i), item2(i), message, more, rel=rel) + end if + end select + type is (complex(dp)) + select type (item2) + type is (complex(dp)) + if (present(thr)) then + select type (thr) + type is (real(dp)) + call check(error, item1(i), item2(i), message, more, thr, rel) + end select + else + call check(error, item1(i), item2(i), message, more, rel=rel) + end if + end select +#if WITH_XDP + type is (real(xdp)) + select type (item2) + type is (real(xdp)) + if (present(thr)) then + select type (thr) + type is (real(xdp)) + call check(error, item1(i), item2(i), message, more, thr, rel) + end select + else + call check(error, item1(i), item2(i), message, more, rel=rel) + end if + end select + type is (complex(xdp)) + select type (item2) + type is (complex(xdp)) + if (present(thr)) then + select type (thr) + type is (real(xdp)) + call check(error, item1(i), item2(i), message, more, thr, rel) + end select + else + call check(error, item1(i), item2(i), message, more, rel=rel) + end if + end select +#endif +#if WITH_QP + type is (real(qp)) + select type (item2) + type is (real(qp)) + if (present(thr)) then + select type (thr) + type is (real(qp)) + call check(error, item1(i), item2(i), message, more, thr, rel) + end select + else + call check(error, item1(i), item2(i), message, more, rel=rel) + end if + end select + type is (complex(qp)) + select type (item2) + type is (complex(qp)) + if (present(thr)) then + select type (thr) + type is (real(qp)) + call check(error, item1(i), item2(i), message, more, thr, rel) + end select + else + call check(error, item1(i), item2(i), message, more, rel=rel) + end if + end select +#endif + end select + if (allocated(error)) then + call error_wrap(error, "Array check failed at element index "//trim(ch(i))) + return + end if + end do + + end subroutine check_double_array + end module testdrive diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt index 0c98279..bc2b320 100644 --- a/test/CMakeLists.txt +++ b/test/CMakeLists.txt @@ -15,6 +15,7 @@ set( tests "check" + "check-array" "select" ) set( diff --git a/test/main.f90 b/test/main.f90 index a155118..b26f89f 100644 --- a/test/main.f90 +++ b/test/main.f90 @@ -17,6 +17,7 @@ program tester use testdrive, only : run_testsuite, new_testsuite, testsuite_type, & & select_suite, run_selected, get_argument use test_check, only : collect_check + use test_check_array, only: collect_check_array use test_select, only : collect_select implicit none integer :: stat, is @@ -28,6 +29,7 @@ program tester testsuites = [ & new_testsuite("check", collect_check), & + new_testsuite("check-array", collect_check_array), & new_testsuite("select", collect_select) & ] diff --git a/test/meson.build b/test/meson.build index ae2956b..6e2be37 100644 --- a/test/meson.build +++ b/test/meson.build @@ -13,6 +13,7 @@ tests = [ 'check', + 'check-array', 'select', ] diff --git a/test/test_check_array.F90 b/test/test_check_array.F90 new file mode 100644 index 0000000..654a47b --- /dev/null +++ b/test/test_check_array.F90 @@ -0,0 +1,1481 @@ +! This file is part of test-drive. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!# Enable support for quadruple precision +#ifndef WITH_QP +#define WITH_QP 0 +#endif + +!# Enable support for extended double precision +#ifndef WITH_XDP +#define WITH_XDP 0 +#endif + +module test_check_array + use, intrinsic :: ieee_arithmetic, only : ieee_value, ieee_quiet_nan + use testdrive, only : new_unittest, unittest_type, error_type, check, skip_test + implicit none + private + + public :: collect_check_array + + + !> Single precision real numbers + integer, parameter :: sp = selected_real_kind(6) + + !> Double precision real numbers + integer, parameter :: dp = selected_real_kind(15) + +#if WITH_XDP + !> Extended double precision real numbers + integer, parameter :: xdp = selected_real_kind(18) +#endif + +#if WITH_QP + !> Quadruple precision real numbers + integer, parameter :: qp = selected_real_kind(33) +#endif + + !> Char length for integers + integer, parameter :: i1 = selected_int_kind(2) + + !> Short length for integers + integer, parameter :: i2 = selected_int_kind(4) + + !> Length of default integers + integer, parameter :: i4 = selected_int_kind(9) + + !> Long length for integers + integer, parameter :: i8 = selected_int_kind(18) + +contains + + + !> Collect all exported unit tests + subroutine collect_check_array(testsuite) + + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("success", test_success), & + new_unittest("failure", test_failure, should_fail=.true.), & + new_unittest("failure-message", test_failure_message, should_fail=.true.), & + new_unittest("failure-with-more", test_failure_with_more, should_fail=.true.), & + new_unittest("expression", test_expression), & + new_unittest("expression-fail", test_expression_fail, should_fail=.true.), & + new_unittest("expression-message", test_expression_message, should_fail=.true.), & + new_unittest("expression-with-more", test_expression_with_more, should_fail=.true.), & + new_unittest("real-single-abs", test_rsp_abs), & + new_unittest("real-single-rel", test_rsp_rel), & + new_unittest("real-single-nan", test_rsp_nan, should_fail=.true.), & + new_unittest("real-single-abs-fail", test_rsp_abs_fail, should_fail=.true.), & + new_unittest("real-single-rel-fail", test_rsp_rel_fail, should_fail=.true.), & + new_unittest("real-single-abs-message", test_rsp_abs_message, should_fail=.true.), & + new_unittest("real-single-nan-message", test_rsp_nan_message, should_fail=.true.), & + new_unittest("real-double-abs", test_rdp_abs), & + new_unittest("real-double-rel", test_rdp_rel), & + new_unittest("real-double-nan", test_rdp_nan, should_fail=.true.), & + new_unittest("real-double-abs-fail", test_rdp_abs_fail, should_fail=.true.), & + new_unittest("real-double-rel-fail", test_rdp_rel_fail, should_fail=.true.), & + new_unittest("real-double-abs-message", test_rdp_abs_message, should_fail=.true.), & + new_unittest("real-double-nan-message", test_rdp_nan_message, should_fail=.true.), & + new_unittest("real-xdouble-abs", test_rxdp_abs), & + new_unittest("real-xdouble-rel", test_rxdp_rel), & + new_unittest("real-xdouble-nan", test_rxdp_nan, should_fail=.true.), & + new_unittest("real-xdouble-abs-fail", test_rxdp_abs_fail, should_fail=.true.), & + new_unittest("real-xdouble-rel-fail", test_rxdp_rel_fail, should_fail=.true.), & + new_unittest("real-xdouble-abs-message", test_rxdp_abs_message, should_fail=.true.), & + new_unittest("real-xdouble-nan-message", test_rxdp_nan_message, should_fail=.true.), & + new_unittest("real-quadruple-abs", test_rqp_abs), & + new_unittest("real-quadruple-rel", test_rqp_rel), & + new_unittest("real-quadruple-nan", test_rqp_nan, should_fail=.true.), & + new_unittest("real-quadruple-abs-fail", test_rqp_abs_fail, should_fail=.true.), & + new_unittest("real-quadruple-rel-fail", test_rqp_rel_fail, should_fail=.true.), & + new_unittest("real-quadruple-abs-message", test_rqp_abs_message, should_fail=.true.), & + new_unittest("real-quadruple-nan-message", test_rqp_nan_message, should_fail=.true.), & + new_unittest("complex-single-abs", test_csp_abs), & + new_unittest("complex-single-rel", test_csp_rel), & + new_unittest("complex-single-nan", test_csp_nan, should_fail=.true.), & + new_unittest("complex-single-abs-fail", test_csp_abs_fail, should_fail=.true.), & + new_unittest("complex-single-rel-fail", test_csp_rel_fail, should_fail=.true.), & + new_unittest("complex-single-abs-message", test_csp_abs_message, should_fail=.true.), & + new_unittest("complex-single-nan-message", test_csp_nan_message, should_fail=.true.), & + new_unittest("complex-double-abs", test_cdp_abs), & + new_unittest("complex-double-rel", test_cdp_rel), & + new_unittest("complex-double-nan", test_cdp_nan, should_fail=.true.), & + new_unittest("complex-double-abs-fail", test_cdp_abs_fail, should_fail=.true.), & + new_unittest("complex-double-rel-fail", test_cdp_rel_fail, should_fail=.true.), & + new_unittest("complex-double-abs-message", test_cdp_abs_message, should_fail=.true.), & + new_unittest("complex-double-nan-message", test_cdp_nan_message, should_fail=.true.), & + new_unittest("complex-xdouble-abs", test_cxdp_abs), & + new_unittest("complex-xdouble-rel", test_cxdp_rel), & + new_unittest("complex-xdouble-nan", test_cxdp_nan, should_fail=.true.), & + new_unittest("complex-xdouble-abs-fail", test_cxdp_abs_fail, should_fail=.true.), & + new_unittest("complex-xdouble-rel-fail", test_cxdp_rel_fail, should_fail=.true.), & + new_unittest("complex-xdouble-abs-message", test_cxdp_abs_message, should_fail=.true.), & + new_unittest("complex-xdouble-nan-message", test_cxdp_nan_message, should_fail=.true.), & + new_unittest("complex-quadruple-abs", test_cqp_abs), & + new_unittest("complex-quadruple-rel", test_cqp_rel), & + new_unittest("complex-quadruple-nan", test_cqp_nan, should_fail=.true.), & + new_unittest("complex-quadruple-abs-fail", test_cqp_abs_fail, should_fail=.true.), & + new_unittest("complex-quadruple-rel-fail", test_cqp_rel_fail, should_fail=.true.), & + new_unittest("complex-quadruple-abs-message", test_cqp_abs_message, should_fail=.true.), & + new_unittest("complex-quadruple-nan-message", test_cqp_nan_message, should_fail=.true.), & + new_unittest("integer-char", test_i1), & + new_unittest("integer-char-fail", test_i1_fail, should_fail=.true.), & + new_unittest("integer-char-message", test_i1_message, should_fail=.true.), & + new_unittest("integer-char-with-more", test_i1_with_more, should_fail=.true.), & + new_unittest("integer-short", test_i2), & + new_unittest("integer-short-fail", test_i2_fail, should_fail=.true.), & + new_unittest("integer-short-message", test_i2_message, should_fail=.true.), & + new_unittest("integer-short-with-more", test_i2_with_more, should_fail=.true.), & + new_unittest("integer-default", test_i4), & + new_unittest("integer-default-fail", test_i4_fail, should_fail=.true.), & + new_unittest("integer-default-message", test_i4_message, should_fail=.true.), & + new_unittest("integer-default-with-more", test_i4_with_more, should_fail=.true.), & + new_unittest("integer-long", test_i8), & + new_unittest("integer-long-fail", test_i8_fail, should_fail=.true.), & + new_unittest("integer-long-message", test_i8_message, should_fail=.true.), & + new_unittest("integer-long-with-more", test_i8_with_more, should_fail=.true.), & + new_unittest("logical-default-true", test_l4_true), & + new_unittest("logical-default-false", test_l4_false), & + new_unittest("logical-default-fail", test_l4_fail, should_fail=.true.), & + new_unittest("logical-default-message", test_l4_message, should_fail=.true.), & + new_unittest("logical-default-with-more", test_l4_with_more, should_fail=.true.), & + new_unittest("character", test_char), & + new_unittest("character-fail", test_char_fail, should_fail=.true.), & + new_unittest("character-message", test_char_message, should_fail=.true.), & + new_unittest("character-with-more", test_char_with_more, should_fail=.true.) & + ] + + end subroutine collect_check_array + + + subroutine test_success(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, [0, 0]) + if (allocated(error)) return + + end subroutine test_success + + + subroutine test_failure(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, [7, 0]) + if (allocated(error)) return + + end subroutine test_failure + + + subroutine test_failure_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, [7, 7], "Custom message describing the error") + + end subroutine test_failure_message + + + subroutine test_failure_with_more(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, [7, 7], more="with an additional descriptive message here") + + end subroutine test_failure_with_more + + + subroutine test_expression(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, [.true., .true.], "Expression failed") + + end subroutine test_expression + + + subroutine test_expression_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, [.false., .false.], "Expression failed") + + end subroutine test_expression_fail + + + subroutine test_expression_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, [.false., .true.], 'Expression with message failed') + + end subroutine test_expression_message + + + subroutine test_expression_with_more(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, [.false., .true.], more='Expression with more failed') + + end subroutine test_expression_with_more + + + subroutine test_rsp_abs(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(sp) :: val(2) + + val = 3.3_sp + + call check(error, val, [3.3_sp, 3.3_sp], thr=sqrt(epsilon(val))) + + end subroutine test_rsp_abs + + + subroutine test_rsp_nan(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(sp) :: val(2) + + val = ieee_value(val, ieee_quiet_nan) + + call check(error, val, [3.3_sp, 3.3_sp], rel=.true.) + + end subroutine test_rsp_nan + + + subroutine test_rsp_rel(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(sp) :: val(2) + + val = 3.3_sp + + call check(error, val, [3.3_sp, 3.3_sp], rel=.true.) + + end subroutine test_rsp_rel + + + subroutine test_rsp_abs_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(sp) :: val(2) + + val = 1.0_sp + + call check(error, val, [2.0_sp, 2.0_sp]) + + end subroutine test_rsp_abs_fail + + + subroutine test_rsp_rel_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(sp) :: val(2) + + val = 1.0_sp + + call check(error, val, [1.5_sp, 1.5_sp], rel=.true.) + + end subroutine test_rsp_rel_fail + + + subroutine test_rsp_abs_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(sp) :: val(2) + + val = 1.0_sp + + call check(error, val, [1.5_sp, 1.5_sp], message="Actual value is not 1.5") + + end subroutine test_rsp_abs_message + + + subroutine test_rsp_nan_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(sp) :: val(2) + + val = ieee_value(val, ieee_quiet_nan) + + call check(error, val, message="Actual value is not a number") + + end subroutine test_rsp_nan_message + + + subroutine test_rdp_abs(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(dp) :: val(2) + + val = 3.3_dp + + call check(error, val, [3.3_dp, 3.3_dp], thr=sqrt(epsilon(val))) + + end subroutine test_rdp_abs + + + subroutine test_rdp_rel(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(dp) :: val(2) + + val = 3.3_dp + + call check(error, val, [3.3_dp, 3.3_dp], rel=.true.) + + end subroutine test_rdp_rel + + + subroutine test_rdp_nan(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(dp) :: val(2) + + val = ieee_value(val, ieee_quiet_nan) + + call check(error, val, [3.3_dp, 3.3_dp], rel=.true.) + + end subroutine test_rdp_nan + + + subroutine test_rdp_abs_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(dp) :: val(2) + + val = 1.0_dp + + call check(error, val, [2.0_dp, 2.0_dp]) + + end subroutine test_rdp_abs_fail + + + subroutine test_rdp_rel_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(dp) :: val(2) + + val = 1.0_dp + + call check(error, val, [1.5_dp, 1.5_dp], rel=.true.) + + end subroutine test_rdp_rel_fail + + + subroutine test_rdp_abs_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(dp) :: val(2) + + val = 1.0_dp + + call check(error, val, [1.5_dp, 1.0_dp], message="Actual value is not 1.5") + + end subroutine test_rdp_abs_message + + + subroutine test_rdp_nan_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(dp) :: val(2) + + val = ieee_value(val, ieee_quiet_nan) + + call check(error, val, message="Actual value is not a number") + + end subroutine test_rdp_nan_message + + + subroutine test_rxdp_abs(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + real(xdp) :: val(2) + + val = 3.3_xdp + + call check(error, val, [3.3_xdp, 3.3_xdp], thr=sqrt(epsilon(val))) +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_rxdp_abs + + + subroutine test_rxdp_rel(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + real(xdp) :: val(2) + + val = 3.3_xdp + + call check(error, val, [3.3_xdp, 3.3_xdp], rel=.true.) +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_rxdp_rel + + + subroutine test_rxdp_nan(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + real(xdp) :: val(2) + + val = ieee_value(val, ieee_quiet_nan) + + call check(error, val, [3.3_xdp, 3.3_xdp], rel=.true.) +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_rxdp_nan + + + subroutine test_rxdp_abs_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + real(xdp) :: val(2) + + val = 1.0_xdp + + call check(error, val, [2.0_xdp, 2.0_xdp]) +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_rxdp_abs_fail + + + subroutine test_rxdp_rel_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + real(xdp) :: val(2) + + val = 1.0_xdp + + call check(error, val, [1.5_xdp, 1.5_xdp], rel=.true.) +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_rxdp_rel_fail + + + subroutine test_rxdp_abs_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + real(xdp) :: val(2) + + val = 1.0_xdp + + call check(error, val, [1.5_xdp, 1.5_xdp], message="Actual value is not 1.5") +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_rxdp_abs_message + + + subroutine test_rxdp_nan_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + real(xdp) :: val(2) + + val = ieee_value(val, ieee_quiet_nan) + + call check(error, val, message="Actual value is not a number") +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_rxdp_nan_message + + + subroutine test_rqp_abs(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + real(qp) :: val(2) + + val = 3.3_qp + + call check(error, val, [3.3_qp, 3.3_qp], thr=sqrt(epsilon(val))) +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_rqp_abs + + + subroutine test_rqp_rel(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + real(qp) :: val(2) + + val = 3.3_qp + + call check(error, val, [3.3_qp, 3.3_qp], rel=.true.) +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_rqp_rel + + + subroutine test_rqp_nan(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + real(qp) :: val(2) + + val = ieee_value(val, ieee_quiet_nan) + + call check(error, val, [3.3_qp, 3.3_qp], rel=.true.) +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_rqp_nan + + + subroutine test_rqp_abs_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + real(qp) :: val(2) + + val = 1.0_qp + + call check(error, val, [2.0_qp, 2.0_qp]) +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_rqp_abs_fail + + + subroutine test_rqp_rel_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + real(qp) :: val(2) + + val = 1.0_qp + + call check(error, val, [1.5_qp, 1.5_qp], rel=.true.) +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_rqp_rel_fail + + + subroutine test_rqp_abs_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + real(qp) :: val(2) + + val = 1.0_qp + + call check(error, val, [1.5_qp, 1.5_qp], message="Actual value is not 1.5") +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_rqp_abs_message + + + subroutine test_rqp_nan_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + real(qp) :: val(2) + + val = ieee_value(val, ieee_quiet_nan) + + call check(error, val, message="Actual value is not a number") +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_rqp_nan_message + + + subroutine test_csp_abs(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(sp) :: val(2) + + val = cmplx(3.3_sp, 1.0_sp, sp) + + call check(error, val, [cmplx(3.3_sp, 1.0_sp, sp), cmplx(3.3_sp, 1.0_sp, sp)], thr=sqrt(epsilon(abs(val)))) + + end subroutine test_csp_abs + + + subroutine test_csp_nan(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(sp) :: val(2) + + val = cmplx(ieee_value(0.0_sp, ieee_quiet_nan), & + & ieee_value(0.0_sp, ieee_quiet_nan), sp) + + call check(error, val, [cmplx(3.3_sp, 1.0_sp, sp), cmplx(3.3_sp, 1.0_sp, sp)], rel=.true.) + + end subroutine test_csp_nan + + + subroutine test_csp_rel(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(sp) :: val(2) + + val = cmplx(3.3_sp, 1.0_sp, sp) + + call check(error, val, [cmplx(3.3_sp, 1.0_sp, sp), cmplx(3.3_sp, 1.0_sp, sp)], rel=.true.) + + end subroutine test_csp_rel + + + subroutine test_csp_abs_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(sp) :: val(2) + + val = cmplx(1.0_sp, 2.0_sp, sp) + + call check(error, val, [cmplx(2.0_sp, 1.0_sp, sp), cmplx(3.3_sp, 1.0_sp, sp)]) + + end subroutine test_csp_abs_fail + + + subroutine test_csp_rel_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(sp) :: val(2) + + val = cmplx(1.0_sp, 1.5_sp, sp) + + call check(error, val, [cmplx(1.5_sp, 1.0_sp, sp), cmplx(3.3_sp, 1.0_sp, sp)], rel=.true.) + + end subroutine test_csp_rel_fail + + + subroutine test_csp_abs_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(sp) :: val(2) + + val = cmplx(1.0_sp, 1.5_sp, sp) + + call check(error, val, [cmplx(1.5_sp, 1.0_sp, sp), cmplx(3.3_sp, 1.0_sp, sp)], & + message="Actual value is not 1.5+1.0i") + + end subroutine test_csp_abs_message + + + subroutine test_csp_nan_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(sp) :: val(2) + + val = cmplx(ieee_value(0.0_sp, ieee_quiet_nan), 0.0_sp, sp) + + call check(error, val, message="Actual value is not a number") + + end subroutine test_csp_nan_message + + + subroutine test_cdp_abs(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(dp) :: val(2) + + val = cmplx(3.3_dp, 1.0_dp, dp) + + call check(error, val, [cmplx(3.3_dp, 1.0_dp, dp), cmplx(3.3_dp, 1.0_dp, dp)], & + thr=sqrt(epsilon(real(val)))) + + end subroutine test_cdp_abs + + + subroutine test_cdp_rel(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(dp) :: val(2) + + val = cmplx(3.3_dp, 1.0_dp, dp) + + call check(error, val, [cmplx(3.3_dp, 1.0_dp, dp), cmplx(3.3_dp, 1.0_dp, dp)], rel=.true.) + + end subroutine test_cdp_rel + + + subroutine test_cdp_nan(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(dp) :: val(2) + + val = cmplx(ieee_value(0.0_dp, ieee_quiet_nan), 0.0_dp, dp) + + call check(error, val, [cmplx(3.3_dp, 1.0_dp, dp), cmplx(3.3_dp, 1.0_dp, dp)], rel=.true.) + + end subroutine test_cdp_nan + + + subroutine test_cdp_abs_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(dp) :: val(2) + + val = cmplx(1.0_dp, 2.0_dp, dp) + + call check(error, val, [cmplx(2.0_dp, 1.0_dp, dp), cmplx(3.3_dp, 1.0_dp, dp)]) + + end subroutine test_cdp_abs_fail + + + subroutine test_cdp_rel_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(dp) :: val(2) + + val = cmplx(1.0_dp, 1.5_dp, dp) + + call check(error, val, [cmplx(1.5_dp, 1.0_dp, dp), cmplx(3.3_dp, 1.0_dp, dp)], rel=.true.) + + end subroutine test_cdp_rel_fail + + + subroutine test_cdp_abs_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(dp) :: val(2) + + val = cmplx(1.0_dp, 1.5_dp, dp) + + call check(error, val, [cmplx(1.5_dp, 1.0_dp, dp), cmplx(3.3_dp, 1.0_dp, dp)], & + message="Actual value is not 1.5+1.0i") + + end subroutine test_cdp_abs_message + + + subroutine test_cdp_nan_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(dp) :: val(2) + + val = cmplx(ieee_value(0.0_dp, ieee_quiet_nan), 0.0_dp, dp) + + call check(error, val, message="Actual value is not a number") + + end subroutine test_cdp_nan_message + + + subroutine test_cxdp_abs(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + complex(xdp) :: val(2) + + val = cmplx(3.3_xdp, 1.0_xdp, xdp) + + call check(error, val, [cmplx(3.3_xdp, 1.0_xdp, xdp), cmplx(3.3_xdp, 1.0_xdp, xdp)], & + thr=sqrt(epsilon(real(val)))) +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_cxdp_abs + + + subroutine test_cxdp_rel(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + complex(xdp) :: val(2) + + val = cmplx(3.3_xdp, 1.0_xdp, xdp) + + call check(error, val, [cmplx(3.3_xdp, 1.0_xdp, xdp), cmplx(3.3_xdp, 1.0_xdp, xdp)], rel=.true.) +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_cxdp_rel + + + subroutine test_cxdp_nan(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + complex(xdp) :: val(2) + + val = cmplx(ieee_value(0.0_xdp, ieee_quiet_nan), 0.0_xdp, xdp) + + call check(error, val, [cmplx(3.3_xdp, 1.0_xdp, xdp), cmplx(3.3_xdp, 1.0_xdp, xdp)], rel=.true.) +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_cxdp_nan + + + subroutine test_cxdp_abs_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + complex(xdp) :: val(2) + + val = cmplx(1.0_xdp, 2.0_xdp, xdp) + + call check(error, val, [cmplx(2.0_xdp, 1.0_xdp, xdp), cmplx(3.3_xdp, 1.0_xdp, xdp)]) +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_cxdp_abs_fail + + + subroutine test_cxdp_rel_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + complex(xdp) :: val(2) + + val = cmplx(1.0_xdp, 1.5_xdp, xdp) + + call check(error, val, [cmplx(1.5_xdp, 1.0_xdp, xdp), cmplx(3.3_xdp, 1.0_xdp, xdp)], rel=.true.) +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_cxdp_rel_fail + + + subroutine test_cxdp_abs_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + complex(xdp) :: val(2) + + val = cmplx(1.0_xdp, 1.5_xdp, xdp) + + call check(error, val, [cmplx(1.5_xdp, 1.0_xdp, xdp), cmplx(3.3_xdp, 1.0_xdp, xdp)], & + message="Actual value is not 1.5+1.0i") +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_cxdp_abs_message + + + subroutine test_cxdp_nan_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + complex(xdp) :: val(2) + + val = cmplx(ieee_value(0.0_xdp, ieee_quiet_nan), 0.0_xdp, xdp) + + call check(error, val, message="Actual value is not a number") +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_cxdp_nan_message + + + subroutine test_cqp_abs(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + complex(qp) :: val(2) + + val = cmplx(3.3_qp, 1.0_qp, qp) + + call check(error, val, [cmplx(3.3_qp, 1.0_qp, qp), cmplx(3.3_qp, 1.0_qp, qp)], & + thr=sqrt(epsilon(real(val)))) +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_cqp_abs + + + subroutine test_cqp_rel(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + complex(qp) :: val(2) + + val = cmplx(3.3_qp, 1.0_qp, qp) + + call check(error, val, [cmplx(3.3_qp, 1.0_qp, qp), cmplx(3.3_qp, 1.0_qp, qp)], rel=.true.) +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_cqp_rel + + + subroutine test_cqp_nan(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + complex(qp) :: val(2) + + val = cmplx(ieee_value(0.0_qp, ieee_quiet_nan), 0.0_qp, qp) + + call check(error, val, [cmplx(3.3_qp, 1.0_qp, qp), cmplx(3.3_qp, 1.0_qp, qp)], rel=.true.) +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_cqp_nan + + + subroutine test_cqp_abs_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + complex(qp) :: val(2) + + val = cmplx(1.0_qp, 2.0_qp, qp) + + call check(error, val, [cmplx(2.0_qp, 1.0_qp, qp), cmplx(3.3_qp, 1.0_qp, qp)]) +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_cqp_abs_fail + + + subroutine test_cqp_rel_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + complex(qp) :: val(2) + + val = cmplx(1.0_qp, 1.5_qp, qp) + + call check(error, val, [cmplx(1.5_qp, 1.0_qp, qp), cmplx(1.5_qp, 1.0_qp, qp)], rel=.true.) +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_cqp_rel_fail + + + subroutine test_cqp_abs_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + complex(qp) :: val(2) + + val = cmplx(1.0_qp, 1.5_qp, qp) + + call check(error, val, [cmplx(1.5_qp, 1.0_qp, qp), cmplx(1.5_qp, 1.0_qp, qp)], & + message="Actual value is not 1.5+1.0i") +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_cqp_abs_message + + + subroutine test_cqp_nan_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + complex(qp) :: val(2) + + val = cmplx(ieee_value(0.0_qp, ieee_quiet_nan), 0.0_qp, qp) + + call check(error, val, message="Actual value is not a number") +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_cqp_nan_message + + + subroutine test_i1(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i1) :: val(2) + + val = 3_i1 + + call check(error, val, [3_i1, 3_i1]) + + end subroutine test_i1 + + + subroutine test_i1_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i1) :: val(2) + + val = 3_i1 + + call check(error, val, [-4_i1, -4_i1]) + + end subroutine test_i1_fail + + + subroutine test_i1_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i1) :: val(2) + + val = -3_i1 + + call check(error, val, [7_i1, 7_i1], "Actual value is not seven") + + end subroutine test_i1_message + + + subroutine test_i1_with_more(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i1) :: val(2) + + val = 0_i1 + + call check(error, val, [3_i1, 3_i1], more="with an additional descriptive message here") + + end subroutine test_i1_with_more + + + subroutine test_i2(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i2) :: val(2) + + val = 3_i2 + + call check(error, val, [3_i2, 3_i2]) + + end subroutine test_i2 + + + subroutine test_i2_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i2) :: val(2) + + val = 3_i2 + + call check(error, val, [-4_i2, -4_i2]) + + end subroutine test_i2_fail + + + subroutine test_i2_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i2) :: val(2) + + val = -3_i2 + + call check(error, val, [7_i2, 7_i2], "Actual value is not seven") + + end subroutine test_i2_message + + + subroutine test_i2_with_more(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i2) :: val(2) + + val = 0_i2 + + call check(error, val, [3_i2, 3_i2], more="with an additional descriptive message here") + + end subroutine test_i2_with_more + + + subroutine test_i4(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i4) :: val(2) + + val = 3_i4 + + call check(error, val, [3_i4, 3_i4]) + + end subroutine test_i4 + + + subroutine test_i4_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i4) :: val(2) + + val = 3_i4 + + call check(error, val, [-4_i4, -4_i4]) + + end subroutine test_i4_fail + + + subroutine test_i4_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i4) :: val(2) + + val = -3_i4 + + call check(error, val, [7_i4, 7_i4], "Actual value is not seven") + + end subroutine test_i4_message + + + subroutine test_i4_with_more(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i4) :: val(2) + + val = 0_i4 + + call check(error, val, [3_i4, 3_i4], more="with an additional descriptive message here") + + end subroutine test_i4_with_more + + + subroutine test_i8(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i8) :: val(2) + + val = 3_i8 + + call check(error, val, [3_i8, 3_i8]) + + end subroutine test_i8 + + + subroutine test_i8_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i8) :: val(2) + + val = 3_i8 + + call check(error, val, [-4_i8, -4_i8]) + + end subroutine test_i8_fail + + + subroutine test_i8_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i8) :: val(2) + + val = -3_i8 + + call check(error, val, [7_i8, 7_i8], "Actual value is not seven") + + end subroutine test_i8_message + + + subroutine test_i8_with_more(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i8) :: val(2) + + val = 0_i8 + + call check(error, val, [3_i8, 3_i8], more="with an additional descriptive message here") + + end subroutine test_i8_with_more + + + subroutine test_l4_true(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, [.true., .true.], [.true., .true.]) + + end subroutine test_l4_true + + + subroutine test_l4_false(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, [.false., .false.], [.false., .false.]) + + end subroutine test_l4_false + + + subroutine test_l4_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, [.true.], [.false.]) + + end subroutine test_l4_fail + + + subroutine test_l4_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, [.false.], [.true.], "Logical value is not true") + + end subroutine test_l4_message + + + subroutine test_l4_with_more(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, [.true.], [.false.], more="with an additional descriptive message") + + end subroutine test_l4_with_more + + + subroutine test_char(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=:), allocatable :: val(:) + + val = ["positive"] + + call check(error, val, ["positive"]) + + end subroutine test_char + + + subroutine test_char_fail(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=:), allocatable :: val(:) + + val = ["positive"] + + call check(error, val, ["negative"]) + + end subroutine test_char_fail + + + subroutine test_char_message(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=:), allocatable :: val(:) + + val = ["positive"] + + call check(error, val, ["negative"], "Character string should be negative") + + end subroutine test_char_message + + + subroutine test_char_with_more(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=:), allocatable :: val(:) + + val = ["positive"] + + call check(error, val, ["negative"], more="with an additional descriptive message") + + end subroutine test_char_with_more + + +end module test_check_array From 1b74f51a3c7a6f93e03018a36f0d144e5cfa6e10 Mon Sep 17 00:00:00 2001 From: zoziha Date: Mon, 20 Jun 2022 21:11:56 +0800 Subject: [PATCH 2/7] Use multiple procedures for two array checks --- src/testdrive.F90 | 633 +++++++++++++++++++++++++++++--------- test/test_check_array.F90 | 8 +- 2 files changed, 486 insertions(+), 155 deletions(-) diff --git a/src/testdrive.F90 b/src/testdrive.F90 index e55a522..d001776 100644 --- a/src/testdrive.F90 +++ b/src/testdrive.F90 @@ -152,6 +152,9 @@ module testdrive !> Error code for skipped test integer, parameter :: skipped = 77 + + !> Goto next line + character(len=*), parameter :: skip = new_line("a") // repeat(" ", 11) !> Error message @@ -212,8 +215,32 @@ module testdrive module procedure :: check_int_i8 module procedure :: check_bool module procedure :: check_string + end interface check + + interface check ! check for rank-1 array module procedure :: check_single_array - module procedure :: check_double_array + module procedure :: check_float_sp_r1 + module procedure :: check_float_dp_r1 +#if WITH_XDP + module procedure :: check_float_xdp_r1 +#endif +#if WITH_QP + module procedure :: check_float_qp_r1 +#endif + module procedure :: check_complex_sp_r1 + module procedure :: check_complex_dp_r1 +#if WITH_XDP + module procedure :: check_complex_xdp_r1 +#endif +#if WITH_QP + module procedure :: check_complex_qp_r1 +#endif + module procedure :: check_int_i1_r1 + module procedure :: check_int_i2_r1 + module procedure :: check_int_i4_r1 + module procedure :: check_int_i8_r1 + module procedure :: check_bool_r1 + module procedure :: check_string_r1 end interface check @@ -1579,8 +1606,6 @@ subroutine test_failed(error, message, more, and_more) !> Another line of error message character(len=*), intent(in), optional :: and_more - character(len=*), parameter :: skip = new_line("a") // repeat(" ", 11) - allocate(error) error%stat = fatal @@ -1971,17 +1996,16 @@ end function is_nan_qp #endif - subroutine error_wrap(error, more) + subroutine error_index(error, i) !> Error handling - type(error_type), intent(inout) :: error - !> Error message - character(len=*), intent(in) :: more - - character(len=*), parameter :: skip = new_line("a") // repeat(" ", 11) + type(error_type), intent(inout), allocatable :: error + !> Error index + integer, intent(in) :: i - error%message = error%message // skip // more + error%message = error%message // skip // & + "Array check failed at element index "//trim(ch(i)) - end subroutine error_wrap + end subroutine error_index subroutine check_single_array(error, array, message, more) @@ -2030,7 +2054,7 @@ subroutine check_single_array(error, array, message, more) #endif end select if (allocated(error)) then - call error_wrap(error, "Array check failed at element index "//trim(ch(i))) + call error_index(error, i) return end if end do @@ -2038,16 +2062,16 @@ subroutine check_single_array(error, array, message, more) end subroutine check_single_array - subroutine check_double_array(error, actual, expected, message, more, thr, rel) + subroutine check_float_sp_r1(error, actual, expected, message, more, thr, rel) !> Error handling type(error_type), allocatable, intent(out) :: error - !> Found values - class(*), intent(in), target :: actual(:) + !> Found floating point value + real(sp), intent(in) :: actual(:) - !> Expected values - class(*), intent(in), target :: expected(:) + !> Expected floating point value + real(sp), intent(in) :: expected(:) !> A detailed message describing the error character(len=*), intent(in), optional :: message @@ -2056,155 +2080,462 @@ subroutine check_double_array(error, actual, expected, message, more, thr, rel) character(len=*), intent(in), optional :: more !> Allowed threshold for matching floating point values - class(*), intent(in), optional :: thr + real(sp), intent(in), optional :: thr !> Check for relative errors instead logical, intent(in), optional :: rel integer :: i - class(*), pointer :: item1(:), item2(:) - item1 => actual - item2 => expected do i = 1, size(expected) - select type (item1) - type is (integer(i1)) - select type (item2) - type is (integer(i1)) - call check(error, item1(i), item2(i), message, more) - end select - type is (integer(i2)) - select type (item2) - type is (integer(i2)) - call check(error, item1(i), item2(i), message, more) - end select - type is (integer(i4)) - select type (item2) - type is (integer(i4)) - call check(error, item1(i), item2(i), message, more) - end select - type is (integer(i8)) - select type (item2) - type is (integer(i8)) - call check(error, item1(i), item2(i), message, more) - end select - type is (logical) - select type (item2) - type is (logical) - call check(error, item1(i), item2(i), message, more) - end select - type is (character(*)) - select type (item2) - type is (character(*)) - call check(error, item1(i), item2(i), message, more) - end select - type is (real(sp)) - select type (item2) - type is (real(sp)) - if (present(thr)) then - select type (thr) - type is (real(sp)) - call check(error, item1(i), item2(i), message, more, thr, rel) - end select - else - call check(error, item1(i), item2(i), message, more, rel=rel) - end if - end select - type is (real(dp)) - select type (item2) - type is (real(dp)) - if (present(thr)) then - select type (thr) - type is (real(dp)) - call check(error, item1(i), item2(i), message, more, thr, rel) - end select - else - call check(error, item1(i), item2(i), message, more, rel=rel) - end if - end select - type is (complex(sp)) - select type (item2) - type is (complex(sp)) - if (present(thr)) then - select type (thr) - type is (real(sp)) - call check(error, item1(i), item2(i), message, more, thr, rel) - end select - else - call check(error, item1(i), item2(i), message, more, rel=rel) - end if - end select - type is (complex(dp)) - select type (item2) - type is (complex(dp)) - if (present(thr)) then - select type (thr) - type is (real(dp)) - call check(error, item1(i), item2(i), message, more, thr, rel) - end select - else - call check(error, item1(i), item2(i), message, more, rel=rel) - end if - end select + call check(error, actual(i), expected(i), message, more, thr, rel) + if (allocated(error)) then + call error_index(error, i) + return + end if + end do + + end subroutine check_float_sp_r1 + + + subroutine check_float_dp_r1(error, actual, expected, message, more, thr, rel) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + real(dp), intent(in) :: actual(:) + + !> Expected floating point value + real(dp), intent(in) :: expected(:) + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + !> Allowed threshold for matching floating point values + real(dp), intent(in), optional :: thr + + !> Check for relative errors instead + logical, intent(in), optional :: rel + + integer :: i + + do i = 1, size(expected) + call check(error, actual(i), expected(i), message, more, thr, rel) + if (allocated(error)) then + call error_index(error, i) + return + end if + end do + + end subroutine check_float_dp_r1 + + #if WITH_XDP - type is (real(xdp)) - select type (item2) - type is (real(xdp)) - if (present(thr)) then - select type (thr) - type is (real(xdp)) - call check(error, item1(i), item2(i), message, more, thr, rel) - end select - else - call check(error, item1(i), item2(i), message, more, rel=rel) - end if - end select - type is (complex(xdp)) - select type (item2) - type is (complex(xdp)) - if (present(thr)) then - select type (thr) - type is (real(xdp)) - call check(error, item1(i), item2(i), message, more, thr, rel) - end select - else - call check(error, item1(i), item2(i), message, more, rel=rel) - end if - end select + subroutine check_float_xdp_r1(error, actual, expected, message, more, thr, rel) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + real(xdp), intent(in) :: actual(:) + + !> Expected floating point value + real(xdp), intent(in) :: expected(:) + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + !> Allowed threshold for matching floating point values + real(xdp), intent(in), optional :: thr + + !> Check for relative errors instead + logical, intent(in), optional :: rel + + integer :: i + + do i = 1, size(expected) + call check(error, actual(i), expected(i), message, more, thr, rel) + if (allocated(error)) then + call error_index(error, i) + return + end if + end do + + end subroutine check_float_xdp_r1 #endif + + #if WITH_QP - type is (real(qp)) - select type (item2) - type is (real(qp)) - if (present(thr)) then - select type (thr) - type is (real(qp)) - call check(error, item1(i), item2(i), message, more, thr, rel) - end select - else - call check(error, item1(i), item2(i), message, more, rel=rel) - end if - end select - type is (complex(qp)) - select type (item2) - type is (complex(qp)) - if (present(thr)) then - select type (thr) - type is (real(qp)) - call check(error, item1(i), item2(i), message, more, thr, rel) - end select - else - call check(error, item1(i), item2(i), message, more, rel=rel) - end if - end select + subroutine check_float_qp_r1(error, actual, expected, message, more, thr, rel) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + real(qp), intent(in) :: actual(:) + + !> Expected floating point value + real(qp), intent(in) :: expected(:) + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + !> Allowed threshold for matching floating point values + real(qp), intent(in), optional :: thr + + !> Check for relative errors instead + logical, intent(in), optional :: rel + + integer :: i + + do i = 1, size(expected) + call check(error, actual(i), expected(i), message, more, thr, rel) + if (allocated(error)) then + call error_index(error, i) + return + end if + end do + + end subroutine check_float_qp_r1 #endif - end select + + + subroutine check_complex_sp_r1(error, actual, expected, message, more, thr, rel) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + complex(sp), intent(in) :: actual(:) + + !> Expected floating point value + complex(sp), intent(in) :: expected(:) + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + !> Allowed threshold for matching floating point values + real(sp), intent(in), optional :: thr + + !> Check for relative errors instead + logical, intent(in), optional :: rel + + integer :: i + + do i = 1, size(expected) + call check(error, actual(i), expected(i), message, more, thr, rel) + if (allocated(error)) then + call error_index(error, i) + return + end if + end do + + end subroutine check_complex_sp_r1 + + + subroutine check_complex_dp_r1(error, actual, expected, message, more, thr, rel) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + complex(dp), intent(in) :: actual(:) + + !> Expected floating point value + complex(dp), intent(in) :: expected(:) + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + !> Allowed threshold for matching floating point values + real(dp), intent(in), optional :: thr + + !> Check for relative errors instead + logical, intent(in), optional :: rel + + integer :: i + + do i = 1, size(expected) + call check(error, actual(i), expected(i), message, more, thr, rel) + if (allocated(error)) then + call error_index(error, i) + return + end if + end do + + end subroutine check_complex_dp_r1 + + +#if WITH_XDP + subroutine check_complex_xdp_r1(error, actual, expected, message, more, thr, rel) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + complex(xdp), intent(in) :: actual(:) + + !> Expected floating point value + complex(xdp), intent(in) :: expected(:) + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + !> Allowed threshold for matching floating point values + real(xdp), intent(in), optional :: thr + + !> Check for relative errors instead + logical, intent(in), optional :: rel + + integer :: i + + do i = 1, size(expected) + call check(error, actual(i), expected(i), message, more, thr, rel) + if (allocated(error)) then + call error_index(error, i) + return + end if + end do + + end subroutine check_complex_xdp_r1 +#endif + + +#if WITH_QP + subroutine check_complex_qp_r1(error, actual, expected, message, more, thr, rel) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + complex(qp), intent(in) :: actual(:) + + !> Expected floating point value + complex(qp), intent(in) :: expected(:) + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + !> Allowed threshold for matching floating point values + real(qp), intent(in), optional :: thr + + !> Check for relative errors instead + logical, intent(in), optional :: rel + + integer :: i + + do i = 1, size(expected) + call check(error, actual(i), expected(i), message, more, thr, rel) + if (allocated(error)) then + call error_index(error, i) + return + end if + end do + + end subroutine check_complex_qp_r1 +#endif + + + subroutine check_int_i1_r1(error, actual, expected, message, more) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found integer value + integer(i1), intent(in) :: actual(:) + + !> Expected integer value + integer(i1), intent(in) :: expected(:) + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + integer :: i + + do i = 1, size(expected) + call check(error, actual(i), expected(i), message, more) + if (allocated(error)) then + call error_index(error, i) + return + end if + end do + + end subroutine check_int_i1_r1 + + + subroutine check_int_i2_r1(error, actual, expected, message, more) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found integer value + integer(i2), intent(in) :: actual(:) + + !> Expected integer value + integer(i2), intent(in) :: expected(:) + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + integer :: i + + do i = 1, size(expected) + call check(error, actual(i), expected(i), message, more) if (allocated(error)) then - call error_wrap(error, "Array check failed at element index "//trim(ch(i))) + call error_index(error, i) return end if end do - end subroutine check_double_array + end subroutine check_int_i2_r1 + + + subroutine check_int_i4_r1(error, actual, expected, message, more) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found integer value + integer(i4), intent(in) :: actual(:) + + !> Expected integer value + integer(i4), intent(in) :: expected(:) + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + integer :: i + + do i = 1, size(expected) + call check(error, actual(i), expected(i), message, more) + if (allocated(error)) then + call error_index(error, i) + return + end if + end do + + end subroutine check_int_i4_r1 + + + subroutine check_int_i8_r1(error, actual, expected, message, more) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found integer value + integer(i8), intent(in) :: actual(:) + + !> Expected integer value + integer(i8), intent(in) :: expected(:) + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + integer :: i + + do i = 1, size(expected) + call check(error, actual(i), expected(i), message, more) + if (allocated(error)) then + call error_index(error, i) + return + end if + end do + + end subroutine check_int_i8_r1 + + + subroutine check_bool_r1(error, actual, expected, message, more) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found boolean value + logical, intent(in) :: actual(:) + + !> Expected boolean value + logical, intent(in) :: expected(:) + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + integer :: i + + do i = 1, size(expected) + call check(error, actual(i), expected(i), message, more) + if (allocated(error)) then + call error_index(error, i) + return + end if + end do + + end subroutine check_bool_r1 + + + subroutine check_string_r1(error, actual, expected, message, more) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found string value + character(len=*), intent(in) :: actual(:) + + !> Expected string value + character(len=*), intent(in) :: expected(:) + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + integer :: i + + do i = 1, size(expected) + call check(error, actual(i), expected(i), message, more) + if (allocated(error)) then + call error_index(error, i) + return + end if + end do + + end subroutine check_string_r1 + end module testdrive diff --git a/test/test_check_array.F90 b/test/test_check_array.F90 index 654a47b..f430c74 100644 --- a/test/test_check_array.F90 +++ b/test/test_check_array.F90 @@ -1427,7 +1427,7 @@ subroutine test_char(error) !> Error handling type(error_type), allocatable, intent(out) :: error - character(len=:), allocatable :: val(:) + character(len=8) :: val(1) val = ["positive"] @@ -1441,7 +1441,7 @@ subroutine test_char_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error - character(len=:), allocatable :: val(:) + character(len=8) :: val(1) val = ["positive"] @@ -1455,7 +1455,7 @@ subroutine test_char_message(error) !> Error handling type(error_type), allocatable, intent(out) :: error - character(len=:), allocatable :: val(:) + character(len=8) :: val(1) val = ["positive"] @@ -1469,7 +1469,7 @@ subroutine test_char_with_more(error) !> Error handling type(error_type), allocatable, intent(out) :: error - character(len=:), allocatable :: val(:) + character(len=8) :: val(1) val = ["positive"] From 6b021218167b431c5fc274118393ab8b69e2cc16 Mon Sep 17 00:00:00 2001 From: zoziha Date: Tue, 21 Jun 2022 09:20:32 +0800 Subject: [PATCH 3/7] Check array size --- README.md | 4 + src/testdrive.F90 | 130 ++++++++++++++++++---- test/test_check_array.F90 | 223 +++++++++++++++++++++++++++++++++++++- 3 files changed, 333 insertions(+), 24 deletions(-) diff --git a/README.md b/README.md index 4784a49..d645120 100644 --- a/README.md +++ b/README.md @@ -103,6 +103,10 @@ subroutine test_valid(error) ! equivalent to the above call check(error, 1 + 2, 3) if (allocated(error)) return + + ! array check + call check(error, [1 + 2, 6], [3, 6]) + if (allocated(error)) return end subroutine test_valid ``` diff --git a/src/testdrive.F90 b/src/testdrive.F90 index d001776..9345d7c 100644 --- a/src/testdrive.F90 +++ b/src/testdrive.F90 @@ -152,7 +152,7 @@ module testdrive !> Error code for skipped test integer, parameter :: skipped = 77 - + !> Goto next line character(len=*), parameter :: skip = new_line("a") // repeat(" ", 11) @@ -216,7 +216,8 @@ module testdrive module procedure :: check_bool module procedure :: check_string end interface check - + + interface check ! check for rank-1 array module procedure :: check_single_array module procedure :: check_float_sp_r1 @@ -1996,16 +1997,15 @@ end function is_nan_qp #endif - subroutine error_index(error, i) + subroutine wrap_error(error, and_more) !> Error handling type(error_type), intent(inout), allocatable :: error - !> Error index - integer, intent(in) :: i + !> Another line of error message + character(*), intent(in) :: and_more - error%message = error%message // skip // & - "Array check failed at element index "//trim(ch(i)) + error%message = error%message // skip // and_more - end subroutine error_index + end subroutine wrap_error subroutine check_single_array(error, array, message, more) @@ -2054,7 +2054,7 @@ subroutine check_single_array(error, array, message, more) #endif end select if (allocated(error)) then - call error_index(error, i) + call wrap_error(error, "array mismatch at element index "//trim(ch(i))) return end if end do @@ -2087,10 +2087,16 @@ subroutine check_float_sp_r1(error, actual, expected, message, more, thr, rel) integer :: i + call check(error, size(actual), size(expected), message, more) + if (allocated(error)) then + call wrap_error(error, "array mismatch with inconsistent size") + return + end if + do i = 1, size(expected) call check(error, actual(i), expected(i), message, more, thr, rel) if (allocated(error)) then - call error_index(error, i) + call wrap_error(error, "array mismatch at element index "//trim(ch(i))) return end if end do @@ -2123,10 +2129,16 @@ subroutine check_float_dp_r1(error, actual, expected, message, more, thr, rel) integer :: i + call check(error, size(actual), size(expected), message, more) + if (allocated(error)) then + call wrap_error(error, "array mismatch with inconsistent size") + return + end if + do i = 1, size(expected) call check(error, actual(i), expected(i), message, more, thr, rel) if (allocated(error)) then - call error_index(error, i) + call wrap_error(error, "array mismatch at element index "//trim(ch(i))) return end if end do @@ -2160,10 +2172,16 @@ subroutine check_float_xdp_r1(error, actual, expected, message, more, thr, rel) integer :: i + call check(error, size(actual), size(expected), message, more) + if (allocated(error)) then + call wrap_error(error, "array mismatch with inconsistent size") + return + end if + do i = 1, size(expected) call check(error, actual(i), expected(i), message, more, thr, rel) if (allocated(error)) then - call error_index(error, i) + call wrap_error(error, "array mismatch at element index "//trim(ch(i))) return end if end do @@ -2198,10 +2216,16 @@ subroutine check_float_qp_r1(error, actual, expected, message, more, thr, rel) integer :: i + call check(error, size(actual), size(expected), message, more) + if (allocated(error)) then + call wrap_error(error, "array mismatch with inconsistent size") + return + end if + do i = 1, size(expected) call check(error, actual(i), expected(i), message, more, thr, rel) if (allocated(error)) then - call error_index(error, i) + call wrap_error(error, "array mismatch at element index "//trim(ch(i))) return end if end do @@ -2235,10 +2259,16 @@ subroutine check_complex_sp_r1(error, actual, expected, message, more, thr, rel) integer :: i + call check(error, size(actual), size(expected), message, more) + if (allocated(error)) then + call wrap_error(error, "array mismatch with inconsistent size") + return + end if + do i = 1, size(expected) call check(error, actual(i), expected(i), message, more, thr, rel) if (allocated(error)) then - call error_index(error, i) + call wrap_error(error, "array mismatch at element index "//trim(ch(i))) return end if end do @@ -2271,10 +2301,16 @@ subroutine check_complex_dp_r1(error, actual, expected, message, more, thr, rel) integer :: i + call check(error, size(actual), size(expected), message, more) + if (allocated(error)) then + call wrap_error(error, "array mismatch with inconsistent size") + return + end if + do i = 1, size(expected) call check(error, actual(i), expected(i), message, more, thr, rel) if (allocated(error)) then - call error_index(error, i) + call wrap_error(error, "array mismatch at element index "//trim(ch(i))) return end if end do @@ -2308,10 +2344,16 @@ subroutine check_complex_xdp_r1(error, actual, expected, message, more, thr, rel integer :: i + call check(error, size(actual), size(expected), message, more) + if (allocated(error)) then + call wrap_error(error, "array mismatch with inconsistent size") + return + end if + do i = 1, size(expected) call check(error, actual(i), expected(i), message, more, thr, rel) if (allocated(error)) then - call error_index(error, i) + call wrap_error(error, "array mismatch at element index "//trim(ch(i))) return end if end do @@ -2346,10 +2388,16 @@ subroutine check_complex_qp_r1(error, actual, expected, message, more, thr, rel) integer :: i + call check(error, size(actual), size(expected), message, more) + if (allocated(error)) then + call wrap_error(error, "array mismatch with inconsistent size") + return + end if + do i = 1, size(expected) call check(error, actual(i), expected(i), message, more, thr, rel) if (allocated(error)) then - call error_index(error, i) + call wrap_error(error, "array mismatch at element index "//trim(ch(i))) return end if end do @@ -2377,10 +2425,16 @@ subroutine check_int_i1_r1(error, actual, expected, message, more) integer :: i + call check(error, size(actual), size(expected), message, more) + if (allocated(error)) then + call wrap_error(error, "array mismatch with inconsistent size") + return + end if + do i = 1, size(expected) call check(error, actual(i), expected(i), message, more) if (allocated(error)) then - call error_index(error, i) + call wrap_error(error, "array mismatch at element index "//trim(ch(i))) return end if end do @@ -2407,10 +2461,16 @@ subroutine check_int_i2_r1(error, actual, expected, message, more) integer :: i + call check(error, size(actual), size(expected), message, more) + if (allocated(error)) then + call wrap_error(error, "array mismatch with inconsistent size") + return + end if + do i = 1, size(expected) call check(error, actual(i), expected(i), message, more) if (allocated(error)) then - call error_index(error, i) + call wrap_error(error, "array mismatch at element index "//trim(ch(i))) return end if end do @@ -2437,10 +2497,16 @@ subroutine check_int_i4_r1(error, actual, expected, message, more) integer :: i + call check(error, size(actual), size(expected), message, more) + if (allocated(error)) then + call wrap_error(error, "array mismatch with inconsistent size") + return + end if + do i = 1, size(expected) call check(error, actual(i), expected(i), message, more) if (allocated(error)) then - call error_index(error, i) + call wrap_error(error, "array mismatch at element index "//trim(ch(i))) return end if end do @@ -2467,10 +2533,16 @@ subroutine check_int_i8_r1(error, actual, expected, message, more) integer :: i + call check(error, size(actual), size(expected), message, more) + if (allocated(error)) then + call wrap_error(error, "array mismatch with inconsistent size") + return + end if + do i = 1, size(expected) call check(error, actual(i), expected(i), message, more) if (allocated(error)) then - call error_index(error, i) + call wrap_error(error, "array mismatch at element index "//trim(ch(i))) return end if end do @@ -2497,10 +2569,16 @@ subroutine check_bool_r1(error, actual, expected, message, more) integer :: i + call check(error, size(actual), size(expected), message, more) + if (allocated(error)) then + call wrap_error(error, "array mismatch with inconsistent size") + return + end if + do i = 1, size(expected) call check(error, actual(i), expected(i), message, more) if (allocated(error)) then - call error_index(error, i) + call wrap_error(error, "array mismatch at element index "//trim(ch(i))) return end if end do @@ -2527,10 +2605,16 @@ subroutine check_string_r1(error, actual, expected, message, more) integer :: i + call check(error, size(actual), size(expected), message, more) + if (allocated(error)) then + call wrap_error(error, "array mismatch with inconsistent size") + return + end if + do i = 1, size(expected) call check(error, actual(i), expected(i), message, more) if (allocated(error)) then - call error_index(error, i) + call wrap_error(error, "array mismatch at element index "//trim(ch(i))) return end if end do diff --git a/test/test_check_array.F90 b/test/test_check_array.F90 index f430c74..e1f7f27 100644 --- a/test/test_check_array.F90 +++ b/test/test_check_array.F90 @@ -83,6 +83,7 @@ subroutine collect_check_array(testsuite) new_unittest("real-single-rel-fail", test_rsp_rel_fail, should_fail=.true.), & new_unittest("real-single-abs-message", test_rsp_abs_message, should_fail=.true.), & new_unittest("real-single-nan-message", test_rsp_nan_message, should_fail=.true.), & + new_unittest("real-single-inconsistent-size", test_rsp_inconsistent_size, should_fail=.true.), & new_unittest("real-double-abs", test_rdp_abs), & new_unittest("real-double-rel", test_rdp_rel), & new_unittest("real-double-nan", test_rdp_nan, should_fail=.true.), & @@ -90,6 +91,7 @@ subroutine collect_check_array(testsuite) new_unittest("real-double-rel-fail", test_rdp_rel_fail, should_fail=.true.), & new_unittest("real-double-abs-message", test_rdp_abs_message, should_fail=.true.), & new_unittest("real-double-nan-message", test_rdp_nan_message, should_fail=.true.), & + new_unittest("real-double-inconsistent-size", test_rdp_inconsistent_size, should_fail=.true.), & new_unittest("real-xdouble-abs", test_rxdp_abs), & new_unittest("real-xdouble-rel", test_rxdp_rel), & new_unittest("real-xdouble-nan", test_rxdp_nan, should_fail=.true.), & @@ -97,6 +99,7 @@ subroutine collect_check_array(testsuite) new_unittest("real-xdouble-rel-fail", test_rxdp_rel_fail, should_fail=.true.), & new_unittest("real-xdouble-abs-message", test_rxdp_abs_message, should_fail=.true.), & new_unittest("real-xdouble-nan-message", test_rxdp_nan_message, should_fail=.true.), & + new_unittest("real-xdouble-inconsistent-size", test_rxdp_inconsistent_size, should_fail=.true.), & new_unittest("real-quadruple-abs", test_rqp_abs), & new_unittest("real-quadruple-rel", test_rqp_rel), & new_unittest("real-quadruple-nan", test_rqp_nan, should_fail=.true.), & @@ -104,6 +107,7 @@ subroutine collect_check_array(testsuite) new_unittest("real-quadruple-rel-fail", test_rqp_rel_fail, should_fail=.true.), & new_unittest("real-quadruple-abs-message", test_rqp_abs_message, should_fail=.true.), & new_unittest("real-quadruple-nan-message", test_rqp_nan_message, should_fail=.true.), & + new_unittest("real-quadruple-inconsistent-size", test_rqp_inconsistent_size, should_fail=.true.), & new_unittest("complex-single-abs", test_csp_abs), & new_unittest("complex-single-rel", test_csp_rel), & new_unittest("complex-single-nan", test_csp_nan, should_fail=.true.), & @@ -111,6 +115,7 @@ subroutine collect_check_array(testsuite) new_unittest("complex-single-rel-fail", test_csp_rel_fail, should_fail=.true.), & new_unittest("complex-single-abs-message", test_csp_abs_message, should_fail=.true.), & new_unittest("complex-single-nan-message", test_csp_nan_message, should_fail=.true.), & + new_unittest("complex-single-inconsistent-size", test_csp_inconsistent_size, should_fail=.true.), & new_unittest("complex-double-abs", test_cdp_abs), & new_unittest("complex-double-rel", test_cdp_rel), & new_unittest("complex-double-nan", test_cdp_nan, should_fail=.true.), & @@ -118,6 +123,7 @@ subroutine collect_check_array(testsuite) new_unittest("complex-double-rel-fail", test_cdp_rel_fail, should_fail=.true.), & new_unittest("complex-double-abs-message", test_cdp_abs_message, should_fail=.true.), & new_unittest("complex-double-nan-message", test_cdp_nan_message, should_fail=.true.), & + new_unittest("complex-double-inconsistent-size", test_cdp_inconsistent_size, should_fail=.true.), & new_unittest("complex-xdouble-abs", test_cxdp_abs), & new_unittest("complex-xdouble-rel", test_cxdp_rel), & new_unittest("complex-xdouble-nan", test_cxdp_nan, should_fail=.true.), & @@ -125,6 +131,7 @@ subroutine collect_check_array(testsuite) new_unittest("complex-xdouble-rel-fail", test_cxdp_rel_fail, should_fail=.true.), & new_unittest("complex-xdouble-abs-message", test_cxdp_abs_message, should_fail=.true.), & new_unittest("complex-xdouble-nan-message", test_cxdp_nan_message, should_fail=.true.), & + new_unittest("complex-xdouble-inconsistent-size", test_cxdp_inconsistent_size, should_fail=.true.), & new_unittest("complex-quadruple-abs", test_cqp_abs), & new_unittest("complex-quadruple-rel", test_cqp_rel), & new_unittest("complex-quadruple-nan", test_cqp_nan, should_fail=.true.), & @@ -132,31 +139,38 @@ subroutine collect_check_array(testsuite) new_unittest("complex-quadruple-rel-fail", test_cqp_rel_fail, should_fail=.true.), & new_unittest("complex-quadruple-abs-message", test_cqp_abs_message, should_fail=.true.), & new_unittest("complex-quadruple-nan-message", test_cqp_nan_message, should_fail=.true.), & + new_unittest("complex-quadruple-inconsistent-size", test_cqp_inconsistent_size, should_fail=.true.), & new_unittest("integer-char", test_i1), & new_unittest("integer-char-fail", test_i1_fail, should_fail=.true.), & new_unittest("integer-char-message", test_i1_message, should_fail=.true.), & new_unittest("integer-char-with-more", test_i1_with_more, should_fail=.true.), & + new_unittest("integer-char-inconsistent-size", test_i1_inconsistent_size, should_fail=.true.), & new_unittest("integer-short", test_i2), & new_unittest("integer-short-fail", test_i2_fail, should_fail=.true.), & new_unittest("integer-short-message", test_i2_message, should_fail=.true.), & new_unittest("integer-short-with-more", test_i2_with_more, should_fail=.true.), & + new_unittest("integer-short-inconsistent-size", test_i2_inconsistent_size, should_fail=.true.), & new_unittest("integer-default", test_i4), & new_unittest("integer-default-fail", test_i4_fail, should_fail=.true.), & new_unittest("integer-default-message", test_i4_message, should_fail=.true.), & new_unittest("integer-default-with-more", test_i4_with_more, should_fail=.true.), & + new_unittest("integer-default-inconsistent-size", test_i4_inconsistent_size, should_fail=.true.), & new_unittest("integer-long", test_i8), & new_unittest("integer-long-fail", test_i8_fail, should_fail=.true.), & new_unittest("integer-long-message", test_i8_message, should_fail=.true.), & new_unittest("integer-long-with-more", test_i8_with_more, should_fail=.true.), & + new_unittest("integer-long-inconsistent-size", test_i8_inconsistent_size, should_fail=.true.), & new_unittest("logical-default-true", test_l4_true), & new_unittest("logical-default-false", test_l4_false), & new_unittest("logical-default-fail", test_l4_fail, should_fail=.true.), & new_unittest("logical-default-message", test_l4_message, should_fail=.true.), & new_unittest("logical-default-with-more", test_l4_with_more, should_fail=.true.), & + new_unittest("logical-default-inconsistent-size", test_l4_inconsistent_size, should_fail=.true.), & new_unittest("character", test_char), & new_unittest("character-fail", test_char_fail, should_fail=.true.), & new_unittest("character-message", test_char_message, should_fail=.true.), & - new_unittest("character-with-more", test_char_with_more, should_fail=.true.) & + new_unittest("character-with-more", test_char_with_more, should_fail=.true.), & + new_unittest("character-inconsistent-size", test_char_inconsistent_size, should_fail=.true.) & ] end subroutine collect_check_array @@ -342,6 +356,19 @@ subroutine test_rsp_nan_message(error) end subroutine test_rsp_nan_message + subroutine test_rsp_inconsistent_size(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(sp) :: val(2) + + val = 1.0_sp + + call check(error, val, [1.5_sp]) + + end subroutine test_rsp_inconsistent_size + subroutine test_rdp_abs(error) !> Error handling @@ -440,6 +467,20 @@ subroutine test_rdp_nan_message(error) end subroutine test_rdp_nan_message + subroutine test_rdp_inconsistent_size(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + real(dp) :: val(2) + + val = 1.0_dp + + call check(error, val, [1.5_dp]) + + end subroutine test_rdp_inconsistent_size + + subroutine test_rxdp_abs(error) !> Error handling @@ -566,6 +607,24 @@ subroutine test_rxdp_nan_message(error) end subroutine test_rxdp_nan_message + subroutine test_rxdp_inconsistent_size(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + real(xdp) :: val(2) + + val = 1.0_xdp + + call check(error, val, [1.5_xdp]) +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_rxdp_inconsistent_size + + subroutine test_rqp_abs(error) !> Error handling @@ -692,6 +751,24 @@ subroutine test_rqp_nan_message(error) end subroutine test_rqp_nan_message + subroutine test_rqp_inconsistent_size(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + real(qp) :: val(2) + + val = 1.0_qp + + call check(error, val, [1.5_qp]) +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_rqp_inconsistent_size + + subroutine test_csp_abs(error) !> Error handling @@ -792,6 +869,20 @@ subroutine test_csp_nan_message(error) end subroutine test_csp_nan_message + subroutine test_csp_inconsistent_size(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(sp) :: val(2) + + val = cmplx(1.0_sp, 2.0_sp, sp) + + call check(error, val, [cmplx(2.0_sp, 1.0_sp, sp)]) + + end subroutine test_csp_inconsistent_size + + subroutine test_cdp_abs(error) !> Error handling @@ -892,6 +983,20 @@ subroutine test_cdp_nan_message(error) end subroutine test_cdp_nan_message + subroutine test_cdp_inconsistent_size(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + complex(dp) :: val(2) + + val = cmplx(1.0_dp, 2.0_dp, dp) + + call check(error, val, [cmplx(2.0_dp, 1.0_dp, dp)]) + + end subroutine test_cdp_inconsistent_size + + subroutine test_cxdp_abs(error) !> Error handling @@ -1020,6 +1125,24 @@ subroutine test_cxdp_nan_message(error) end subroutine test_cxdp_nan_message + subroutine test_cxdp_inconsistent_size(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_XDP + complex(xdp) :: val(2) + + val = cmplx(1.0_xdp, 2.0_xdp, xdp) + + call check(error, val, [cmplx(2.0_xdp, 1.0_xdp, xdp)]) +#else + call skip_test(error, "Extended double precision is not enabled") +#endif + + end subroutine test_cxdp_inconsistent_size + + subroutine test_cqp_abs(error) !> Error handling @@ -1148,6 +1271,24 @@ subroutine test_cqp_nan_message(error) end subroutine test_cqp_nan_message + subroutine test_cqp_inconsistent_size(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + +#if WITH_QP + complex(qp) :: val(2) + + val = cmplx(1.0_qp, 2.0_qp, qp) + + call check(error, val, [cmplx(2.0_qp, 1.0_qp, qp)]) +#else + call skip_test(error, "Quadruple precision is not enabled") +#endif + + end subroutine test_cqp_inconsistent_size + + subroutine test_i1(error) !> Error handling @@ -1204,6 +1345,20 @@ subroutine test_i1_with_more(error) end subroutine test_i1_with_more + subroutine test_i1_inconsistent_size(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i1) :: val(2) + + val = 3_i1 + + call check(error, val, [4_i1]) + + end subroutine test_i1_inconsistent_size + + subroutine test_i2(error) !> Error handling @@ -1260,6 +1415,20 @@ subroutine test_i2_with_more(error) end subroutine test_i2_with_more + subroutine test_i2_inconsistent_size(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i2) :: val(2) + + val = 3_i2 + + call check(error, val, [4_i2]) + + end subroutine test_i2_inconsistent_size + + subroutine test_i4(error) !> Error handling @@ -1316,6 +1485,20 @@ subroutine test_i4_with_more(error) end subroutine test_i4_with_more + subroutine test_i4_inconsistent_size(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i4) :: val(2) + + val = 3_i4 + + call check(error, val, [4_i4]) + + end subroutine test_i4_inconsistent_size + + subroutine test_i8(error) !> Error handling @@ -1372,6 +1555,20 @@ subroutine test_i8_with_more(error) end subroutine test_i8_with_more + subroutine test_i8_inconsistent_size(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer(i8) :: val(2) + + val = 3_i8 + + call check(error, val, [4_i8]) + + end subroutine test_i8_inconsistent_size + + subroutine test_l4_true(error) !> Error handling @@ -1422,6 +1619,16 @@ subroutine test_l4_with_more(error) end subroutine test_l4_with_more + subroutine test_l4_inconsistent_size(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + call check(error, [.true.], [.false., .false.]) + + end subroutine test_l4_inconsistent_size + + subroutine test_char(error) !> Error handling @@ -1478,4 +1685,18 @@ subroutine test_char_with_more(error) end subroutine test_char_with_more + subroutine test_char_inconsistent_size(error) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=8) :: val(1) + + val = ["positive"] + + call check(error, val, ["negative", "negative"]) + + end subroutine test_char_inconsistent_size + + end module test_check_array From 49c27591cb3cd10e6061f1864f2e8850115dc1af Mon Sep 17 00:00:00 2001 From: zoziha Date: Tue, 21 Jun 2022 09:23:17 +0800 Subject: [PATCH 4/7] Typo correction: missmatch -> mismatch --- src/testdrive.F90 | 44 ++++++++++++++++++++++---------------------- 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/src/testdrive.F90 b/src/testdrive.F90 index 9345d7c..34ddea1 100644 --- a/src/testdrive.F90 +++ b/src/testdrive.F90 @@ -692,13 +692,13 @@ subroutine check_float_dp(error, actual, expected, message, more, thr, rel) else if (relative) then call test_failed(error, & - "Floating point value missmatch", & + "Floating point value mismatch", & "expected "//ch(expected)//" but got "//ch(actual)//" "//& "(difference: "//ch(int(diff*100))//"%)", & more) else call test_failed(error, & - "Floating point value missmatch", & + "Floating point value mismatch", & "expected "//ch(expected)//" but got "//ch(actual)//" "//& "(difference: "//ch(diff)//")", & more) @@ -787,13 +787,13 @@ subroutine check_float_sp(error, actual, expected, message, more, thr, rel) else if (relative) then call test_failed(error, & - "Floating point value missmatch", & + "Floating point value mismatch", & "expected "//ch(expected)//" but got "//ch(actual)//" "//& "(difference: "//ch(int(diff*100))//"%)", & more) else call test_failed(error, & - "Floating point value missmatch", & + "Floating point value mismatch", & "expected "//ch(expected)//" but got "//ch(actual)//" "//& "(difference: "//ch(diff)//")", & more) @@ -883,13 +883,13 @@ subroutine check_float_xdp(error, actual, expected, message, more, thr, rel) else if (relative) then call test_failed(error, & - "Floating point value missmatch", & + "Floating point value mismatch", & "expected "//ch(expected)//" but got "//ch(actual)//" "//& "(difference: "//ch(int(diff*100))//"%)", & more) else call test_failed(error, & - "Floating point value missmatch", & + "Floating point value mismatch", & "expected "//ch(expected)//" but got "//ch(actual)//" "//& "(difference: "//ch(diff)//")", & more) @@ -980,13 +980,13 @@ subroutine check_float_qp(error, actual, expected, message, more, thr, rel) else if (relative) then call test_failed(error, & - "Floating point value missmatch", & + "Floating point value mismatch", & "expected "//ch(expected)//" but got "//ch(actual)//" "//& "(difference: "//ch(int(diff*100))//"%)", & more) else call test_failed(error, & - "Floating point value missmatch", & + "Floating point value mismatch", & "expected "//ch(expected)//" but got "//ch(actual)//" "//& "(difference: "//ch(diff)//")", & more) @@ -1076,13 +1076,13 @@ subroutine check_complex_dp(error, actual, expected, message, more, thr, rel) else if (relative) then call test_failed(error, & - "Floating point value missmatch", & + "Floating point value mismatch", & "expected "//ch(expected)//" but got "//ch(actual)//" "//& "(difference: "//ch(int(diff*100))//"%)", & more) else call test_failed(error, & - "Floating point value missmatch", & + "Floating point value mismatch", & "expected "//ch(expected)//" but got "//ch(actual)//" "//& "(difference: "//ch(diff)//")", & more) @@ -1171,13 +1171,13 @@ subroutine check_complex_sp(error, actual, expected, message, more, thr, rel) else if (relative) then call test_failed(error, & - "Floating point value missmatch", & + "Floating point value mismatch", & "expected "//ch(expected)//" but got "//ch(actual)//" "//& "(difference: "//ch(int(diff*100))//"%)", & more) else call test_failed(error, & - "Floating point value missmatch", & + "Floating point value mismatch", & "expected "//ch(expected)//" but got "//ch(actual)//" "//& "(difference: "//ch(diff)//")", & more) @@ -1267,13 +1267,13 @@ subroutine check_complex_xdp(error, actual, expected, message, more, thr, rel) else if (relative) then call test_failed(error, & - "Floating point value missmatch", & + "Floating point value mismatch", & "expected "//ch(expected)//" but got "//ch(actual)//" "//& "(difference: "//ch(int(diff*100))//"%)", & more) else call test_failed(error, & - "Floating point value missmatch", & + "Floating point value mismatch", & "expected "//ch(expected)//" but got "//ch(actual)//" "//& "(difference: "//ch(diff)//")", & more) @@ -1364,13 +1364,13 @@ subroutine check_complex_qp(error, actual, expected, message, more, thr, rel) else if (relative) then call test_failed(error, & - "Floating point value missmatch", & + "Floating point value mismatch", & "expected "//ch(expected)//" but got "//ch(actual)//" "//& "(difference: "//ch(int(diff*100))//"%)", & more) else call test_failed(error, & - "Floating point value missmatch", & + "Floating point value mismatch", & "expected "//ch(expected)//" but got "//ch(actual)//" "//& "(difference: "//ch(diff)//")", & more) @@ -1429,7 +1429,7 @@ subroutine check_int_i1(error, actual, expected, message, more) call test_failed(error, message, more) else call test_failed(error, & - "Integer value missmatch", & + "Integer value mismatch", & "expected "//ch(expected)//" but got "//ch(actual), & more) end if @@ -1460,7 +1460,7 @@ subroutine check_int_i2(error, actual, expected, message, more) call test_failed(error, message, more) else call test_failed(error, & - "Integer value missmatch", & + "Integer value mismatch", & "expected "//ch(expected)//" but got "//ch(actual), & more) end if @@ -1491,7 +1491,7 @@ subroutine check_int_i4(error, actual, expected, message, more) call test_failed(error, message, more) else call test_failed(error, & - "Integer value missmatch", & + "Integer value mismatch", & "expected "//ch(expected)//" but got "//ch(actual), & more) end if @@ -1522,7 +1522,7 @@ subroutine check_int_i8(error, actual, expected, message, more) call test_failed(error, message, more) else call test_failed(error, & - "Integer value missmatch", & + "Integer value mismatch", & "expected "//ch(expected)//" but got "//ch(actual), & more) end if @@ -1553,7 +1553,7 @@ subroutine check_bool(error, actual, expected, message, more) call test_failed(error, message, more) else call test_failed(error, & - "Logical value missmatch", & + "Logical value mismatch", & "expected "//merge("T", "F", expected)//" but got "//merge("T", "F", actual), & more) end if @@ -1584,7 +1584,7 @@ subroutine check_string(error, actual, expected, message, more) call test_failed(error, message, more) else call test_failed(error, & - "Character value missmatch", & + "Character value mismatch", & "expected '"//expected//"' but got '"//actual//"'", & more) end if From 937289eba470345fae9e5a3acaf02ed9ddb744a0 Mon Sep 17 00:00:00 2001 From: zoziha Date: Tue, 30 Aug 2022 22:47:06 +0800 Subject: [PATCH 5/7] Use module procedures instead of polymorphic interfaces --- src/testdrive.F90 | 78 +++++++++++++++++++++++------------------------ 1 file changed, 39 insertions(+), 39 deletions(-) diff --git a/src/testdrive.F90 b/src/testdrive.F90 index 34ddea1..abee787 100644 --- a/src/testdrive.F90 +++ b/src/testdrive.F90 @@ -1997,7 +1997,7 @@ end function is_nan_qp #endif - subroutine wrap_error(error, and_more) + pure subroutine wrap_error(error, and_more) !> Error handling type(error_type), intent(inout), allocatable :: error !> Another line of error message @@ -2029,28 +2029,28 @@ subroutine check_single_array(error, array, message, more) do i = 1, size(array) select type (item) type is (integer) - call check(error, item(i), message, more) + call check_stat(error, item(i), message, more) type is (logical) - call check(error, item(i), message, more) + call check_logical(error, item(i), message, more) type is (real(sp)) - call check(error, item(i), message, more) + call check_float_exceptional_sp(error, item(i), message, more) type is (real(dp)) - call check(error, item(i), message, more) + call check_float_exceptional_dp(error, item(i), message, more) type is (complex(sp)) - call check(error, item(i), message, more) + call check_complex_exceptional_sp(error, item(i), message, more) type is (complex(dp)) - call check(error, item(i), message, more) + call check_complex_exceptional_dp(error, item(i), message, more) #if WITH_XDP type is (real(xdp)) - call check(error, item(i), message, more) + call check_float_exceptional_xdp(error, item(i), message, more) type is (complex(xdp)) - call check(error, item(i), message, more) + call check_complex_exceptional_xdp(error, item(i), message, more) #endif #if WITH_QP type is (real(qp)) - call check(error, item(i), message, more) + call check_float_qp(error, item(i), message, more) type is (complex(qp)) - call check(error, item(i), message, more) + call check_complex_qp(error, item(i), message, more) #endif end select if (allocated(error)) then @@ -2087,14 +2087,14 @@ subroutine check_float_sp_r1(error, actual, expected, message, more, thr, rel) integer :: i - call check(error, size(actual), size(expected), message, more) + call check_int_i4(error, size(actual), size(expected), message, more) if (allocated(error)) then call wrap_error(error, "array mismatch with inconsistent size") return end if do i = 1, size(expected) - call check(error, actual(i), expected(i), message, more, thr, rel) + call check_float_sp(error, actual(i), expected(i), message, more, thr, rel) if (allocated(error)) then call wrap_error(error, "array mismatch at element index "//trim(ch(i))) return @@ -2129,14 +2129,14 @@ subroutine check_float_dp_r1(error, actual, expected, message, more, thr, rel) integer :: i - call check(error, size(actual), size(expected), message, more) + call check_int_i4(error, size(actual), size(expected), message, more) if (allocated(error)) then call wrap_error(error, "array mismatch with inconsistent size") return end if do i = 1, size(expected) - call check(error, actual(i), expected(i), message, more, thr, rel) + call check_float_dp(error, actual(i), expected(i), message, more, thr, rel) if (allocated(error)) then call wrap_error(error, "array mismatch at element index "//trim(ch(i))) return @@ -2172,14 +2172,14 @@ subroutine check_float_xdp_r1(error, actual, expected, message, more, thr, rel) integer :: i - call check(error, size(actual), size(expected), message, more) + call check_int_i4(error, size(actual), size(expected), message, more) if (allocated(error)) then call wrap_error(error, "array mismatch with inconsistent size") return end if do i = 1, size(expected) - call check(error, actual(i), expected(i), message, more, thr, rel) + call check_float_xdp(error, actual(i), expected(i), message, more, thr, rel) if (allocated(error)) then call wrap_error(error, "array mismatch at element index "//trim(ch(i))) return @@ -2216,14 +2216,14 @@ subroutine check_float_qp_r1(error, actual, expected, message, more, thr, rel) integer :: i - call check(error, size(actual), size(expected), message, more) + call check_int_i4(error, size(actual), size(expected), message, more) if (allocated(error)) then call wrap_error(error, "array mismatch with inconsistent size") return end if do i = 1, size(expected) - call check(error, actual(i), expected(i), message, more, thr, rel) + call check_float_qp(error, actual(i), expected(i), message, more, thr, rel) if (allocated(error)) then call wrap_error(error, "array mismatch at element index "//trim(ch(i))) return @@ -2259,14 +2259,14 @@ subroutine check_complex_sp_r1(error, actual, expected, message, more, thr, rel) integer :: i - call check(error, size(actual), size(expected), message, more) + call check_int_i4(error, size(actual), size(expected), message, more) if (allocated(error)) then call wrap_error(error, "array mismatch with inconsistent size") return end if do i = 1, size(expected) - call check(error, actual(i), expected(i), message, more, thr, rel) + call check_complex_sp(error, actual(i), expected(i), message, more, thr, rel) if (allocated(error)) then call wrap_error(error, "array mismatch at element index "//trim(ch(i))) return @@ -2301,14 +2301,14 @@ subroutine check_complex_dp_r1(error, actual, expected, message, more, thr, rel) integer :: i - call check(error, size(actual), size(expected), message, more) + call check_int_i4(error, size(actual), size(expected), message, more) if (allocated(error)) then call wrap_error(error, "array mismatch with inconsistent size") return end if do i = 1, size(expected) - call check(error, actual(i), expected(i), message, more, thr, rel) + call check_complex_dp(error, actual(i), expected(i), message, more, thr, rel) if (allocated(error)) then call wrap_error(error, "array mismatch at element index "//trim(ch(i))) return @@ -2344,14 +2344,14 @@ subroutine check_complex_xdp_r1(error, actual, expected, message, more, thr, rel integer :: i - call check(error, size(actual), size(expected), message, more) + call check_int_i4(error, size(actual), size(expected), message, more) if (allocated(error)) then call wrap_error(error, "array mismatch with inconsistent size") return end if do i = 1, size(expected) - call check(error, actual(i), expected(i), message, more, thr, rel) + call check_complex_xdp(error, actual(i), expected(i), message, more, thr, rel) if (allocated(error)) then call wrap_error(error, "array mismatch at element index "//trim(ch(i))) return @@ -2388,14 +2388,14 @@ subroutine check_complex_qp_r1(error, actual, expected, message, more, thr, rel) integer :: i - call check(error, size(actual), size(expected), message, more) + call check_int_i4(error, size(actual), size(expected), message, more) if (allocated(error)) then call wrap_error(error, "array mismatch with inconsistent size") return end if do i = 1, size(expected) - call check(error, actual(i), expected(i), message, more, thr, rel) + call check_complex_qp(error, actual(i), expected(i), message, more, thr, rel) if (allocated(error)) then call wrap_error(error, "array mismatch at element index "//trim(ch(i))) return @@ -2425,14 +2425,14 @@ subroutine check_int_i1_r1(error, actual, expected, message, more) integer :: i - call check(error, size(actual), size(expected), message, more) + call check_int_i4(error, size(actual), size(expected), message, more) if (allocated(error)) then call wrap_error(error, "array mismatch with inconsistent size") return end if do i = 1, size(expected) - call check(error, actual(i), expected(i), message, more) + call check_int_i1(error, actual(i), expected(i), message, more) if (allocated(error)) then call wrap_error(error, "array mismatch at element index "//trim(ch(i))) return @@ -2461,14 +2461,14 @@ subroutine check_int_i2_r1(error, actual, expected, message, more) integer :: i - call check(error, size(actual), size(expected), message, more) + call check_int_i4(error, size(actual), size(expected), message, more) if (allocated(error)) then call wrap_error(error, "array mismatch with inconsistent size") return end if do i = 1, size(expected) - call check(error, actual(i), expected(i), message, more) + call check_int_i2(error, actual(i), expected(i), message, more) if (allocated(error)) then call wrap_error(error, "array mismatch at element index "//trim(ch(i))) return @@ -2497,14 +2497,14 @@ subroutine check_int_i4_r1(error, actual, expected, message, more) integer :: i - call check(error, size(actual), size(expected), message, more) + call check_int_i4(error, size(actual), size(expected), message, more) if (allocated(error)) then call wrap_error(error, "array mismatch with inconsistent size") return end if do i = 1, size(expected) - call check(error, actual(i), expected(i), message, more) + call check_int_i4(error, actual(i), expected(i), message, more) if (allocated(error)) then call wrap_error(error, "array mismatch at element index "//trim(ch(i))) return @@ -2533,14 +2533,14 @@ subroutine check_int_i8_r1(error, actual, expected, message, more) integer :: i - call check(error, size(actual), size(expected), message, more) + call check_int_i4(error, size(actual), size(expected), message, more) if (allocated(error)) then call wrap_error(error, "array mismatch with inconsistent size") return end if do i = 1, size(expected) - call check(error, actual(i), expected(i), message, more) + call check_int_i8(error, actual(i), expected(i), message, more) if (allocated(error)) then call wrap_error(error, "array mismatch at element index "//trim(ch(i))) return @@ -2569,14 +2569,14 @@ subroutine check_bool_r1(error, actual, expected, message, more) integer :: i - call check(error, size(actual), size(expected), message, more) + call check_int_i4(error, size(actual), size(expected), message, more) if (allocated(error)) then call wrap_error(error, "array mismatch with inconsistent size") return end if do i = 1, size(expected) - call check(error, actual(i), expected(i), message, more) + call check_bool(error, actual(i), expected(i), message, more) if (allocated(error)) then call wrap_error(error, "array mismatch at element index "//trim(ch(i))) return @@ -2605,14 +2605,14 @@ subroutine check_string_r1(error, actual, expected, message, more) integer :: i - call check(error, size(actual), size(expected), message, more) + call check_int_i4(error, size(actual), size(expected), message, more) if (allocated(error)) then call wrap_error(error, "array mismatch with inconsistent size") return end if do i = 1, size(expected) - call check(error, actual(i), expected(i), message, more) + call check_string(error, actual(i), expected(i), message, more) if (allocated(error)) then call wrap_error(error, "array mismatch at element index "//trim(ch(i))) return From b6dcf94c5deb219416c87debffad091daadc0e95 Mon Sep 17 00:00:00 2001 From: zoziha Date: Tue, 30 Aug 2022 22:56:46 +0800 Subject: [PATCH 6/7] Add the pure keyword to pure functions --- src/testdrive.F90 | 98 +++++++++++++++++++++++------------------------ 1 file changed, 49 insertions(+), 49 deletions(-) diff --git a/src/testdrive.F90 b/src/testdrive.F90 index abee787..6b57487 100644 --- a/src/testdrive.F90 +++ b/src/testdrive.F90 @@ -500,14 +500,14 @@ end subroutine make_output !> Select a unit test from all available tests - function select_test(tests, name) result(pos) + pure function select_test(tests, name) result(pos) + + !> Available unit tests + type(unittest_type), intent(in) :: tests(:) !> Name identifying the test suite character(len=*), intent(in) :: name - !> Available unit tests - type(unittest_type) :: tests(:) - !> Selected test suite integer :: pos @@ -525,14 +525,14 @@ end function select_test !> Select a test suite from all available suites - function select_suite(suites, name) result(pos) + pure function select_suite(suites, name) result(pos) + + !> Available test suites + type(testsuite_type), intent(in) :: suites(:) !> Name identifying the test suite character(len=*), intent(in) :: name - !> Available test suites - type(testsuite_type) :: suites(:) - !> Selected test suite integer :: pos @@ -589,7 +589,7 @@ function new_testsuite(name, collect) result(self) end function new_testsuite - subroutine check_stat(error, stat, message, more) + pure subroutine check_stat(error, stat, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -614,7 +614,7 @@ subroutine check_stat(error, stat, message, more) end subroutine check_stat - subroutine check_logical(error, expression, message, more) + pure subroutine check_logical(error, expression, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -639,7 +639,7 @@ subroutine check_logical(error, expression, message, more) end subroutine check_logical - subroutine check_float_dp(error, actual, expected, message, more, thr, rel) + pure subroutine check_float_dp(error, actual, expected, message, more, thr, rel) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -709,7 +709,7 @@ subroutine check_float_dp(error, actual, expected, message, more, thr, rel) end subroutine check_float_dp - subroutine check_float_exceptional_dp(error, actual, message, more) + pure subroutine check_float_exceptional_dp(error, actual, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -734,7 +734,7 @@ subroutine check_float_exceptional_dp(error, actual, message, more) end subroutine check_float_exceptional_dp - subroutine check_float_sp(error, actual, expected, message, more, thr, rel) + pure subroutine check_float_sp(error, actual, expected, message, more, thr, rel) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -804,7 +804,7 @@ subroutine check_float_sp(error, actual, expected, message, more, thr, rel) end subroutine check_float_sp - subroutine check_float_exceptional_sp(error, actual, message, more) + pure subroutine check_float_exceptional_sp(error, actual, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -830,7 +830,7 @@ end subroutine check_float_exceptional_sp #if WITH_XDP - subroutine check_float_xdp(error, actual, expected, message, more, thr, rel) + pure subroutine check_float_xdp(error, actual, expected, message, more, thr, rel) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -900,7 +900,7 @@ subroutine check_float_xdp(error, actual, expected, message, more, thr, rel) end subroutine check_float_xdp - subroutine check_float_exceptional_xdp(error, actual, message, more) + pure subroutine check_float_exceptional_xdp(error, actual, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -927,7 +927,7 @@ end subroutine check_float_exceptional_xdp #if WITH_QP - subroutine check_float_qp(error, actual, expected, message, more, thr, rel) + pure subroutine check_float_qp(error, actual, expected, message, more, thr, rel) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -997,7 +997,7 @@ subroutine check_float_qp(error, actual, expected, message, more, thr, rel) end subroutine check_float_qp - subroutine check_float_exceptional_qp(error, actual, message, more) + pure subroutine check_float_exceptional_qp(error, actual, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -1023,7 +1023,7 @@ end subroutine check_float_exceptional_qp #endif - subroutine check_complex_dp(error, actual, expected, message, more, thr, rel) + pure subroutine check_complex_dp(error, actual, expected, message, more, thr, rel) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -1093,7 +1093,7 @@ subroutine check_complex_dp(error, actual, expected, message, more, thr, rel) end subroutine check_complex_dp - subroutine check_complex_exceptional_dp(error, actual, message, more) + pure subroutine check_complex_exceptional_dp(error, actual, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -1118,7 +1118,7 @@ subroutine check_complex_exceptional_dp(error, actual, message, more) end subroutine check_complex_exceptional_dp - subroutine check_complex_sp(error, actual, expected, message, more, thr, rel) + pure subroutine check_complex_sp(error, actual, expected, message, more, thr, rel) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -1188,7 +1188,7 @@ subroutine check_complex_sp(error, actual, expected, message, more, thr, rel) end subroutine check_complex_sp - subroutine check_complex_exceptional_sp(error, actual, message, more) + pure subroutine check_complex_exceptional_sp(error, actual, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -1214,7 +1214,7 @@ end subroutine check_complex_exceptional_sp #if WITH_XDP - subroutine check_complex_xdp(error, actual, expected, message, more, thr, rel) + pure subroutine check_complex_xdp(error, actual, expected, message, more, thr, rel) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -1284,7 +1284,7 @@ subroutine check_complex_xdp(error, actual, expected, message, more, thr, rel) end subroutine check_complex_xdp - subroutine check_complex_exceptional_xdp(error, actual, message, more) + pure subroutine check_complex_exceptional_xdp(error, actual, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -1311,7 +1311,7 @@ end subroutine check_complex_exceptional_xdp #if WITH_QP - subroutine check_complex_qp(error, actual, expected, message, more, thr, rel) + pure subroutine check_complex_qp(error, actual, expected, message, more, thr, rel) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -1381,7 +1381,7 @@ subroutine check_complex_qp(error, actual, expected, message, more, thr, rel) end subroutine check_complex_qp - subroutine check_complex_exceptional_qp(error, actual, message, more) + pure subroutine check_complex_exceptional_qp(error, actual, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -1407,7 +1407,7 @@ end subroutine check_complex_exceptional_qp #endif - subroutine check_int_i1(error, actual, expected, message, more) + pure subroutine check_int_i1(error, actual, expected, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -1438,7 +1438,7 @@ subroutine check_int_i1(error, actual, expected, message, more) end subroutine check_int_i1 - subroutine check_int_i2(error, actual, expected, message, more) + pure subroutine check_int_i2(error, actual, expected, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -1469,7 +1469,7 @@ subroutine check_int_i2(error, actual, expected, message, more) end subroutine check_int_i2 - subroutine check_int_i4(error, actual, expected, message, more) + pure subroutine check_int_i4(error, actual, expected, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -1500,7 +1500,7 @@ subroutine check_int_i4(error, actual, expected, message, more) end subroutine check_int_i4 - subroutine check_int_i8(error, actual, expected, message, more) + pure subroutine check_int_i8(error, actual, expected, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -1531,7 +1531,7 @@ subroutine check_int_i8(error, actual, expected, message, more) end subroutine check_int_i8 - subroutine check_bool(error, actual, expected, message, more) + pure subroutine check_bool(error, actual, expected, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -1562,7 +1562,7 @@ subroutine check_bool(error, actual, expected, message, more) end subroutine check_bool - subroutine check_string(error, actual, expected, message, more) + pure subroutine check_string(error, actual, expected, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -1593,7 +1593,7 @@ subroutine check_string(error, actual, expected, message, more) end subroutine check_string - subroutine test_failed(error, message, more, and_more) + pure subroutine test_failed(error, message, more, and_more) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -1622,7 +1622,7 @@ end subroutine test_failed !> A test is skipped because certain requirements are not met to run the actual test - subroutine skip_test(error, message, more, and_more) + pure subroutine skip_test(error, message, more, and_more) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -1917,7 +1917,7 @@ end function complex_qp_to_char !> Clear error type after it has been handled. - subroutine clear_error(error) + pure subroutine clear_error(error) !> Error handling type(error_type), intent(inout) :: error @@ -2062,7 +2062,7 @@ subroutine check_single_array(error, array, message, more) end subroutine check_single_array - subroutine check_float_sp_r1(error, actual, expected, message, more, thr, rel) + pure subroutine check_float_sp_r1(error, actual, expected, message, more, thr, rel) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -2104,7 +2104,7 @@ subroutine check_float_sp_r1(error, actual, expected, message, more, thr, rel) end subroutine check_float_sp_r1 - subroutine check_float_dp_r1(error, actual, expected, message, more, thr, rel) + pure subroutine check_float_dp_r1(error, actual, expected, message, more, thr, rel) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -2147,7 +2147,7 @@ end subroutine check_float_dp_r1 #if WITH_XDP - subroutine check_float_xdp_r1(error, actual, expected, message, more, thr, rel) + pure subroutine check_float_xdp_r1(error, actual, expected, message, more, thr, rel) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -2191,7 +2191,7 @@ end subroutine check_float_xdp_r1 #if WITH_QP - subroutine check_float_qp_r1(error, actual, expected, message, more, thr, rel) + pure subroutine check_float_qp_r1(error, actual, expected, message, more, thr, rel) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -2234,7 +2234,7 @@ end subroutine check_float_qp_r1 #endif - subroutine check_complex_sp_r1(error, actual, expected, message, more, thr, rel) + pure subroutine check_complex_sp_r1(error, actual, expected, message, more, thr, rel) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -2276,7 +2276,7 @@ subroutine check_complex_sp_r1(error, actual, expected, message, more, thr, rel) end subroutine check_complex_sp_r1 - subroutine check_complex_dp_r1(error, actual, expected, message, more, thr, rel) + pure subroutine check_complex_dp_r1(error, actual, expected, message, more, thr, rel) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -2319,7 +2319,7 @@ end subroutine check_complex_dp_r1 #if WITH_XDP - subroutine check_complex_xdp_r1(error, actual, expected, message, more, thr, rel) + pure subroutine check_complex_xdp_r1(error, actual, expected, message, more, thr, rel) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -2363,7 +2363,7 @@ end subroutine check_complex_xdp_r1 #if WITH_QP - subroutine check_complex_qp_r1(error, actual, expected, message, more, thr, rel) + pure subroutine check_complex_qp_r1(error, actual, expected, message, more, thr, rel) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -2406,7 +2406,7 @@ end subroutine check_complex_qp_r1 #endif - subroutine check_int_i1_r1(error, actual, expected, message, more) + pure subroutine check_int_i1_r1(error, actual, expected, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -2442,7 +2442,7 @@ subroutine check_int_i1_r1(error, actual, expected, message, more) end subroutine check_int_i1_r1 - subroutine check_int_i2_r1(error, actual, expected, message, more) + pure subroutine check_int_i2_r1(error, actual, expected, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -2478,7 +2478,7 @@ subroutine check_int_i2_r1(error, actual, expected, message, more) end subroutine check_int_i2_r1 - subroutine check_int_i4_r1(error, actual, expected, message, more) + pure subroutine check_int_i4_r1(error, actual, expected, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -2514,7 +2514,7 @@ subroutine check_int_i4_r1(error, actual, expected, message, more) end subroutine check_int_i4_r1 - subroutine check_int_i8_r1(error, actual, expected, message, more) + pure subroutine check_int_i8_r1(error, actual, expected, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -2550,7 +2550,7 @@ subroutine check_int_i8_r1(error, actual, expected, message, more) end subroutine check_int_i8_r1 - subroutine check_bool_r1(error, actual, expected, message, more) + pure subroutine check_bool_r1(error, actual, expected, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error @@ -2586,7 +2586,7 @@ subroutine check_bool_r1(error, actual, expected, message, more) end subroutine check_bool_r1 - subroutine check_string_r1(error, actual, expected, message, more) + pure subroutine check_string_r1(error, actual, expected, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error From 986fa4f1efbe60ec935545a51693cc639400eda8 Mon Sep 17 00:00:00 2001 From: zoziha Date: Tue, 30 Aug 2022 23:21:54 +0800 Subject: [PATCH 7/7] Minor fix for WITH_QP --- src/testdrive.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/testdrive.F90 b/src/testdrive.F90 index 1b2df0e..c890e07 100644 --- a/src/testdrive.F90 +++ b/src/testdrive.F90 @@ -2064,9 +2064,9 @@ subroutine check_single_array(error, array, message, more) #endif #if WITH_QP type is (real(qp)) - call check_float_qp(error, item(i), message, more) + call check_float_exceptional_qp(error, item(i), message, more) type is (complex(qp)) - call check_complex_qp(error, item(i), message, more) + call check_complex_exceptional_qp(error, item(i), message, more) #endif end select if (allocated(error)) then