From 7a70164e16251a9b48d57bad37cce328754e6e72 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?B=C3=A1lint=20Aradi?= Date: Fri, 8 Nov 2024 18:38:51 +0100 Subject: [PATCH] Implement equal/close checkers for integers/reals (#20) --- .github/workflows/ci.yml | 19 +- CMakeLists.txt | 4 + example/coarray-fpp/test_simple_fpp.F90 | 4 +- example/coarray-fypp/test_simple_fypp.fypp | 4 +- example/coarray/test_simple.f90 | 6 +- example/mpi-fpp/test_simple_fpp.F90 | 4 +- example/mpi-fypp/test_simple_fypp.fypp | 4 +- example/mpi/test_simple.f90 | 4 +- example/serial-fpp/test_fixtured_fpp.F90 | 12 +- .../serial-fpp/test_fixtured_suite_fpp.F90 | 12 +- example/serial-fpp/test_parametrized_fpp.F90 | 4 +- example/serial-fypp/mylib.f90 | 1 + example/serial-fypp/test_fixtured_fypp.fypp | 12 +- .../serial-fypp/test_parametrized_fypp.fypp | 4 +- example/serial/mylib.f90 | 18 +- example/serial/test_fixtured.f90 | 14 +- example/serial/test_fixtured_suite.f90 | 14 +- example/serial/test_parametrized.f90 | 4 +- example/serial/test_simple.f90 | 33 +- src/fortuno.f90 | 8 +- src/fortuno/CMakeLists.txt | 4 + src/fortuno/argumentparser.f90 | 25 +- src/fortuno/chartypes.f90 | 414 +++++++-- src/fortuno/checkers.f90 | 57 +- src/fortuno/checkers/CMakeLists.txt | 15 + src/fortuno/checkers/helpers.f90 | 103 +++ src/fortuno/checkers/int32.f90 | 38 + src/fortuno/checkers/int64.f90 | 38 + src/fortuno/checkers/int_template.inc | 204 +++++ src/fortuno/checkers/meson.build | 11 + src/fortuno/checkers/real32.f90 | 38 + src/fortuno/checkers/real64.f90 | 38 + src/fortuno/checkers/real_template.inc | 247 ++++++ src/fortuno/checkfuncs.f90 | 81 ++ src/fortuno/cmdapp.f90 | 10 +- src/fortuno/consolelogger.f90 | 13 +- src/fortuno/env.f90 | 40 + src/fortuno/meson.build | 4 + src/fortuno/testcontext.f90 | 8 +- src/fortuno/testdriver.f90 | 18 +- src/fortuno/testinfo.f90 | 20 +- src/fortuno/utils.f90 | 231 ++++- src/fortuno/version.f90 | 6 +- src/fortuno_coarray/coaconlogger.f90 | 8 +- src/fortuno_coarray/coatestinfo.f90 | 14 +- src/fortuno_mpi/mpiconlogger.f90 | 12 +- src/fortuno_mpi/mpitestinfo.f90 | 14 +- src/fortuno_serial/serialglobalctx.f90 | 4 +- test/CMakeLists.txt | 7 + test/unit/CMakeLists.txt | 18 + test/unit/test_checkers.f90 | 836 ++++++++++++++++++ test/unit/testapp.f90 | 15 + 52 files changed, 2474 insertions(+), 302 deletions(-) create mode 100644 src/fortuno/checkers/CMakeLists.txt create mode 100644 src/fortuno/checkers/helpers.f90 create mode 100644 src/fortuno/checkers/int32.f90 create mode 100644 src/fortuno/checkers/int64.f90 create mode 100644 src/fortuno/checkers/int_template.inc create mode 100644 src/fortuno/checkers/meson.build create mode 100644 src/fortuno/checkers/real32.f90 create mode 100644 src/fortuno/checkers/real64.f90 create mode 100644 src/fortuno/checkers/real_template.inc create mode 100644 src/fortuno/checkfuncs.f90 create mode 100644 src/fortuno/env.f90 create mode 100644 test/CMakeLists.txt create mode 100644 test/unit/CMakeLists.txt create mode 100644 test/unit/test_checkers.f90 create mode 100644 test/unit/testapp.f90 diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 3208a6a..4676c08 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -70,10 +70,11 @@ jobs: if: ${{ contains(matrix.compiler, 'intel') }} uses: rscohn2/setup-oneapi@v0 with: + # Restricting to 2024 as fpm fails to build MPI-programs with oneAPI 2025.0 components: | - ifx - icx - impi + ifx@2024.2.1 + icx@2024.2.1 + impi@2021.13.1 - name: Setup Intel environment if: ${{ contains(matrix.compiler, 'intel') }} @@ -98,7 +99,12 @@ jobs: run: | echo "FC=${{ env.FC }}" >> ${GITHUB_ENV} echo "FPM_FC=${{ env.FC }}" >> ${GITHUB_ENV} - echo "FFLAGS=-ffree-line-length-none" >> ${GITHUB_ENV} + if [[ ${{ matrix.interface }} == serial ]] && [[ ${{ matrix.os }} == ubuntu-* ]]; then + echo "FFLAGS=-ffree-line-length-none -Og -fsanitize=address" >> ${GITHUB_ENV} + echo "LDFLAGS=-fsanitize=address" >> ${GITHUB_ENV} + else + echo "FFLAGS=-ffree-line-length-none" >> ${GITHUB_ENV} + fi echo "FPM_FFLAGS=-ffree-line-length-none" >> ${GITHUB_ENV} - name: Setup MPICH on Ubuntu @@ -162,8 +168,9 @@ jobs: - name: Build Fortuno run: | cmake ${CMAKE_OPTIONS} -DCMAKE_INSTALL_PREFIX=${INSTALL_DIR} -B ${BUILD_DIR} -G Ninja - cmake --build ${BUILD_DIR} - cmake --install ${BUILD_DIR} + cmake --build ${BUILD_DIR} --verbose + cmake --install ${BUILD_DIR} --verbose + ctest --test-dir ${BUILD_DIR} --verbose rm -rf ${BUILD_DIR} - name: Test CMake export diff --git a/CMakeLists.txt b/CMakeLists.txt index 89e1336..0d2b7bf 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -60,6 +60,10 @@ add_subdirectory(src) if (FORTUNO_WITH_EXAMPLES) add_subdirectory(example) endif () +if (FORTUNO_WITH_TESTS) + enable_testing() + add_subdirectory(test) +endif () #[=================================================================================================[ # Install or Export # diff --git a/example/coarray-fpp/test_simple_fpp.F90 b/example/coarray-fpp/test_simple_fpp.F90 index f9d8827..bf92d6f 100644 --- a/example/coarray-fpp/test_simple_fpp.F90 +++ b/example/coarray-fpp/test_simple_fpp.F90 @@ -6,7 +6,7 @@ module test_simple_fpp use mylib, only : broadcast - use fortuno_coarray, only : as_char, test => coa_pure_case_item, context => coa_context,& + use fortuno_coarray, only : str, test => coa_pure_case_item, context => coa_context,& & is_equal, test_list implicit none @@ -46,7 +46,7 @@ subroutine test_broadcast(ctx) ! Make every third rank fail for demonstration purposes if (mod(this_image() - 1, 3) == 2) then buffer = sourceval + 1 - msg = "Failing on image " // as_char(this_image()) // " on purpose" + msg = "Failing on image " // str(this_image()) // " on purpose" end if ! THEN each rank must contain source rank's value diff --git a/example/coarray-fypp/test_simple_fypp.fypp b/example/coarray-fypp/test_simple_fypp.fypp index 8b5cd2a..1adf679 100644 --- a/example/coarray-fypp/test_simple_fypp.fypp +++ b/example/coarray-fypp/test_simple_fypp.fypp @@ -6,7 +6,7 @@ module test_simple_fypp use mylib, only : broadcast - use fortuno_coarray, only : as_char, context => coa_context, is_equal,& + use fortuno_coarray, only : str, context => coa_context, is_equal,& & suite => coa_pure_suite_item, test_list $:FORTUNO_COARRAY_IMPORTS() implicit none @@ -57,7 +57,7 @@ contains ! Make every third image fail for demonstration purposes if (mod(this_image() - 1, 3) == 2) then buffer = sourceval + 1 - msg = "Failing on image " // as_char(this_image()) // " on purpose" + msg = "Failing on image " // str(this_image()) // " on purpose" end if ! THEN each image must contain source image's value diff --git a/example/coarray/test_simple.f90 b/example/coarray/test_simple.f90 index b9c27aa..0220e29 100644 --- a/example/coarray/test_simple.f90 +++ b/example/coarray/test_simple.f90 @@ -4,8 +4,8 @@ module test_simple use mylib, only : broadcast - use fortuno_coarray, only : as_char, test => coa_pure_case_item, context => coa_context,& - & is_equal, test_list + use fortuno_coarray, only : test => coa_pure_case_item, context => coa_context, is_equal, str,& + & test_list implicit none contains @@ -44,7 +44,7 @@ subroutine test_broadcast(ctx) ! Make every third rank fail for demonstration purposes if (mod(this_image() - 1, 3) == 2) then buffer = sourceval + 1 - msg = "Failing on image " // as_char(this_image()) // " on purpose" + msg = "Failing on image " // str(this_image()) // " on purpose" end if ! THEN each rank must contain source rank's value diff --git a/example/mpi-fpp/test_simple_fpp.F90 b/example/mpi-fpp/test_simple_fpp.F90 index 7a63991..78afb41 100644 --- a/example/mpi-fpp/test_simple_fpp.F90 +++ b/example/mpi-fpp/test_simple_fpp.F90 @@ -6,7 +6,7 @@ module test_simple_fpp use mylib, only : broadcast - use fortuno_mpi, only : as_char, global_comm, is_equal, test => mpi_case_item,& + use fortuno_mpi, only : str, global_comm, is_equal, test => mpi_case_item,& & test_list, this_rank implicit none @@ -44,7 +44,7 @@ subroutine test_broadcast() ! Make every third rank fail for demonstration purposes if (mod(this_rank(), 3) == 2) then buffer = sourceval + 1 - msg = "Failing on rank " // as_char(this_rank()) // " on purpose" + msg = "Failing on rank " // str(this_rank()) // " on purpose" end if ! THEN each rank must contain source rank's value diff --git a/example/mpi-fypp/test_simple_fypp.fypp b/example/mpi-fypp/test_simple_fypp.fypp index 35c5e29..5106436 100644 --- a/example/mpi-fypp/test_simple_fypp.fypp +++ b/example/mpi-fypp/test_simple_fypp.fypp @@ -6,7 +6,7 @@ module test_simple_fypp use mylib, only : broadcast - use fortuno_mpi, only : as_char, global_comm, is_equal, suite => mpi_suite_item, test_list,& + use fortuno_mpi, only : str, global_comm, is_equal, suite => mpi_suite_item, test_list,& & this_rank $:FORTUNO_MPI_IMPORTS() implicit none @@ -55,7 +55,7 @@ contains ! Make every third rank fail for demonstration purposes if (mod(this_rank(), 3) == 2) then buffer = sourceval + 1 - msg = "Failing on rank " // as_char(this_rank()) // " on purpose" + msg = "Failing on rank " // str(this_rank()) // " on purpose" end if ! THEN each rank must contain source rank's value diff --git a/example/mpi/test_simple.f90 b/example/mpi/test_simple.f90 index d44d728..a4996ef 100644 --- a/example/mpi/test_simple.f90 +++ b/example/mpi/test_simple.f90 @@ -4,7 +4,7 @@ module test_simple use mylib, only : broadcast - use fortuno_mpi, only : as_char, global_comm, is_equal, test => mpi_case_item,& + use fortuno_mpi, only : str, global_comm, is_equal, test => mpi_case_item,& & check => mpi_check, test_list, this_rank implicit none @@ -42,7 +42,7 @@ subroutine test_broadcast() ! Make every third rank fail for demonstration purposes if (mod(this_rank(), 3) == 2) then buffer = sourceval + 1 - msg = "Failing on rank " // as_char(this_rank()) // " on purpose" + msg = "Failing on rank " // str(this_rank()) // " on purpose" end if ! THEN each rank must contain source rank's value diff --git a/example/serial-fpp/test_fixtured_fpp.F90 b/example/serial-fpp/test_fixtured_fpp.F90 index f58efd7..b5c365b 100644 --- a/example/serial-fpp/test_fixtured_fpp.F90 +++ b/example/serial-fpp/test_fixtured_fpp.F90 @@ -7,7 +7,7 @@ !> Demo for realizing fixtured tests by overriding the run() method of the test_case object. module test_fixtured_fpp use mylib, only : factorial - use fortuno_serial, only : char_rep_int, is_equal, named_state, named_item,& + use fortuno_serial, only : is_equal, state_dict, dict_item,& & suite => serial_suite_item, store_state => serial_store_state, serial_case_base, test_item,& & test_list implicit none @@ -91,15 +91,15 @@ subroutine random_test_case_run(this) ! Omit array expression to avoid memory leak ! {- ! call store_state(& - ! named_state([& - ! named_item("n", char_rep_int(nn))& + ! state_dict([& + ! dict_item("n", nn)& ! &])& ! ) ! -}{+ block - type(named_item) :: nameditems(1) - nameditems(1) = named_item("n", char_rep_int(nn)) - call store_state(named_state(nameditems)) + type(dict_item) :: dictitems(1) + dictitems(1) = dict_item("n", nn) + call store_state(state_dict(dictitems)) end block call this%proc(nn) ! +} diff --git a/example/serial-fpp/test_fixtured_suite_fpp.F90 b/example/serial-fpp/test_fixtured_suite_fpp.F90 index f813201..2ebfdb0 100644 --- a/example/serial-fpp/test_fixtured_suite_fpp.F90 +++ b/example/serial-fpp/test_fixtured_suite_fpp.F90 @@ -7,7 +7,7 @@ !> Demo for realizing fixtured suites providing common data for all tests within the suite. module test_fixtured_suite_fpp use mylib, only : factorial - use fortuno_serial, only : char_rep_int, is_equal, named_state, named_item, serial_case_base,& + use fortuno_serial, only : is_equal, state_dict, dict_item, serial_case_base,& & scope_pointers => serial_scope_pointers, store_state => serial_store_state,& & serial_suite_base, test_item, test_list, test_ptr_item implicit none @@ -95,15 +95,15 @@ subroutine random_test_suite_set_up(this) ! Omit array expression to avoid memory leak ! {- ! call store_state(& - ! named_state([& - ! named_item("n", char_rep_int(this%nn))& + ! state_dict([& + ! dict_item("n", this%nn)& ! &])& ! ) ! -}{+ block - type(named_item) :: nameditems(1) - nameditems(1) = named_item("n", char_rep_int(this%nn)) - call store_state(named_state(nameditems)) + type(dict_item) :: dictitems(1) + dictitems(1) = dict_item("n", this%nn) + call store_state(state_dict(dictitems)) end block ! +} diff --git a/example/serial-fpp/test_parametrized_fpp.F90 b/example/serial-fpp/test_parametrized_fpp.F90 index 8335852..2aa0b3f 100644 --- a/example/serial-fpp/test_parametrized_fpp.F90 +++ b/example/serial-fpp/test_parametrized_fpp.F90 @@ -7,7 +7,7 @@ !> Demonstrates a possible realization of parametrized tests. module test_parametrized_fpp use mylib, only : factorial - use fortuno_serial, only : as_char, is_equal, serial_case_base, suite => serial_suite_item,& + use fortuno_serial, only : str, is_equal, serial_case_base, suite => serial_suite_item,& & test_item, test_list implicit none @@ -59,7 +59,7 @@ function parametrized_test(prefix, argres) result(testitem) character(:), allocatable :: name - name = prefix // "_" // as_char(argres%arg) + name = prefix // "_" // str(argres%arg) testitem = test_item(parametrized_test_case(name=name, argres=argres)) end function parametrized_test diff --git a/example/serial-fypp/mylib.f90 b/example/serial-fypp/mylib.f90 index 4347937..d48f4fe 100644 --- a/example/serial-fypp/mylib.f90 +++ b/example/serial-fypp/mylib.f90 @@ -11,6 +11,7 @@ module mylib_fypp contains + !> Calculates the factorial of a number function factorial(nn) result(fact) diff --git a/example/serial-fypp/test_fixtured_fypp.fypp b/example/serial-fypp/test_fixtured_fypp.fypp index 21f6514..01eecb2 100644 --- a/example/serial-fypp/test_fixtured_fypp.fypp +++ b/example/serial-fypp/test_fixtured_fypp.fypp @@ -7,7 +7,7 @@ !> Demonstrates the relization of fixtured tests using Fypp macros. module test_fixtured_fypp use mylib_fypp, only : factorial - use fortuno_serial, only : char_rep_int, is_equal, named_state, named_item,& + use fortuno_serial, only : is_equal, state_dict, dict_item,& & suite => serial_suite_item, store_state => serial_store_state,& & serial_case_base, test_item, test_list $:FORTUNO_SERIAL_IMPORTS() @@ -91,15 +91,15 @@ contains ! Omit array expression to avoid memory leak ! {- ! call store_state(& - ! named_state([& - ! named_item("n", char_rep_int(nn))& + ! state_dict([& + ! dict_item("n", nn)& ! &])& ! ) ! -}{+ block - type(named_item) :: nameditems(1) - nameditems(1) = named_item("n", char_rep_int(nn)) - call store_state(named_state(nameditems)) + type(dict_item) :: dictitems(1) + dictitems(1) = dict_item("n", nn) + call store_state(state_dict(dictitems)) end block call this%proc(nn) ! +} diff --git a/example/serial-fypp/test_parametrized_fypp.fypp b/example/serial-fypp/test_parametrized_fypp.fypp index b6911bb..283150a 100644 --- a/example/serial-fypp/test_parametrized_fypp.fypp +++ b/example/serial-fypp/test_parametrized_fypp.fypp @@ -7,7 +7,7 @@ !> Demonstrates a possible realization of parametrized tests using Fypp macros. module test_parametrized_fypp use mylib_fypp, only : factorial - use fortuno_serial, only : as_char, is_equal, serial_case_base, suite => serial_suite_item,& + use fortuno_serial, only : str, is_equal, serial_case_base, suite => serial_suite_item,& & test_item, test_list $:FORTUNO_SERIAL_IMPORTS() implicit none @@ -69,7 +69,7 @@ contains character(:), allocatable :: name - name = prefix // "_" // as_char(argres%arg) + name = prefix // "_" // str(argres%arg) testitem = test_item(parametrized_test_case(name=name, argres=argres)) end function parametrized_test diff --git a/example/serial/mylib.f90 b/example/serial/mylib.f90 index 7b8dbd5..2e808a3 100644 --- a/example/serial/mylib.f90 +++ b/example/serial/mylib.f90 @@ -4,10 +4,12 @@ !> Demo module/library to be tested module mylib + use iso_fortran_env, only : r32 => real32 implicit none private - public :: factorial + public :: r32 + public :: factorial, cotan contains @@ -31,4 +33,18 @@ function factorial(nn) result(fact) end function factorial + + !> Calculates the cotangent of an angle + elemental function cotan(xx) + + !> Argument to calculate the cotangent of + real(r32), intent(in) :: xx + + !> Cotangent of the argument + real(r32) :: cotan + + cotan = 1.0_r32 / tan(xx) + + end function cotan + end module mylib diff --git a/example/serial/test_fixtured.f90 b/example/serial/test_fixtured.f90 index 86d27a9..7a8d157 100644 --- a/example/serial/test_fixtured.f90 +++ b/example/serial/test_fixtured.f90 @@ -5,8 +5,8 @@ !> Demo for realizing fixtured tests by overriding the run() method of the test_case object. module test_fixtured use mylib, only : factorial - use fortuno_serial, only : char_rep_int, check => serial_check, is_equal, named_state,& - & named_item, suite => serial_suite_item, store_state => serial_store_state,& + use fortuno_serial, only : check => serial_check, is_equal, state_dict,& + & dict_item, suite => serial_suite_item, store_state => serial_store_state,& & serial_case_base, test_item, test_list implicit none @@ -89,15 +89,15 @@ subroutine random_test_case_run(this) ! Omit array expression to avoid memory leak ! {- ! call store_state(& - ! named_state([& - ! named_item("n", char_rep_int(nn))& + ! state_dict([& + ! dict_item("n", nn)& ! &])& ! ) ! -}{+ block - type(named_item) :: nameditems(1) - nameditems(1) = named_item("n", char_rep_int(nn)) - call store_state(named_state(nameditems)) + type(dict_item) :: dictitems(1) + dictitems(1) = dict_item("n", nn) + call store_state(state_dict(dictitems)) end block call this%proc(nn) ! +} diff --git a/example/serial/test_fixtured_suite.f90 b/example/serial/test_fixtured_suite.f90 index 52ad505..6d1dac7 100644 --- a/example/serial/test_fixtured_suite.f90 +++ b/example/serial/test_fixtured_suite.f90 @@ -5,8 +5,8 @@ !> Demo for realizing fixtured suites providing common data for all tests within the suite. module test_fixtured_suite use mylib, only : factorial - use fortuno_serial, only : char_rep_int, check => serial_check, is_equal, named_state,& - & named_item, serial_case_base, scope_pointers => serial_scope_pointers,& + use fortuno_serial, only : check => serial_check, is_equal, state_dict,& + & dict_item, serial_case_base, scope_pointers => serial_scope_pointers,& & store_state => serial_store_state, serial_suite_base, test_item, test_list, test_ptr_item implicit none @@ -93,15 +93,15 @@ subroutine random_test_suite_set_up(this) ! Omit array expression to avoid memory leak ! {- ! call store_state(& - ! named_state([& - ! named_item("n", char_rep_int(this%nn))& + ! state_dict([& + ! dict_item("n", this%nn)& ! &])& ! ) ! -}{+ block - type(named_item) :: nameditems(1) - nameditems(1) = named_item("n", char_rep_int(this%nn)) - call store_state(named_state(nameditems)) + type(dict_item) :: dictitems(1) + dictitems(1) = dict_item("n", this%nn) + call store_state(state_dict(dictitems)) end block ! +} diff --git a/example/serial/test_parametrized.f90 b/example/serial/test_parametrized.f90 index dc403fb..54eb54b 100644 --- a/example/serial/test_parametrized.f90 +++ b/example/serial/test_parametrized.f90 @@ -5,7 +5,7 @@ !> Demonstrates a possible realization of parametrized tests. module test_parametrized use mylib, only : factorial - use fortuno_serial, only : as_char, is_equal, serial_case_base, check => serial_check,& + use fortuno_serial, only : str, is_equal, serial_case_base, check => serial_check,& & suite => serial_suite_item, test_item, test_list implicit none @@ -57,7 +57,7 @@ function parametrized_test(prefix, argres) result(testitem) character(:), allocatable :: name - name = prefix // "_" // as_char(argres%arg) + name = prefix // "_" // str(argres%arg) testitem = test_item(parametrized_test_case(name=name, argres=argres)) end function parametrized_test diff --git a/example/serial/test_simple.f90 b/example/serial/test_simple.f90 index cf79c6b..3ad1a92 100644 --- a/example/serial/test_simple.f90 +++ b/example/serial/test_simple.f90 @@ -4,8 +4,8 @@ !> Demonstrates the simplest possible testing scenario module test_simple - use mylib, only : factorial - use fortuno_serial, only : is_equal, test => serial_case_item, check => serial_check,& + use mylib, only : cotan, factorial, r32 + use fortuno_serial, only : all_close, is_equal, test => serial_case_item, check => serial_check,& & suite => serial_suite_item, test_list implicit none @@ -20,25 +20,31 @@ function tests() type(test_list) :: tests tests = test_list([& - test("factorial_0", test_factorial_0),& + ! Best practice is to create at least one suite with the name of the module and put the + ! tests in it, like below. You might further structure your test sets by nesting suites... suite("simple", test_list([& + test("factorial_0", test_factorial_0),& test("factorial_1", test_factorial_1),& - test("factorial_2", test_factorial_2)& + test("factorial_2", test_factorial_2),& + test("cotan", test_cotan)& ]))& ]) end function tests + ! Test: 0! = 1 subroutine test_factorial_0() call check(factorial(0) == 1) end subroutine test_factorial_0 + ! Test: 1! = 1 subroutine test_factorial_1() call check(factorial(1) == 1) end subroutine test_factorial_1 + ! Test: 2! = 2 (will fail due to the bug in the implementation of the factorial function) subroutine test_factorial_2() ! Two failing checks, you should see info about both in the output @@ -49,4 +55,23 @@ subroutine test_factorial_2() call check(factorial(2) == 2) end subroutine test_factorial_2 + + ! Test specific values for a rank-2 cotangent calculation. + subroutine test_cotan() + real(r32), parameter :: xvals(2, 2) = reshape(& + & [1.47112767_r32, 1.23412151_r32, 1.03037683_r32, 0.86630226_r32], [2, 2]) + real(r32), parameter :: cotanvals(2, 2) = reshape(& + & [0.1000000_r32, 0.3500000_r32, 0.6000000_r32, 0.8500000_r32], [2, 2]) + + real(r32), allocatable :: yvals(:,:) + + yvals = cotanvals + ! We add a "bug" for the 3rd element to demonstrate the failure + yvals(1, 2) = yvals(1, 2) + 0.1_r32 + + ! This will fail and print information about the first failing value pair and its position + call check(all_close(cotan(xvals), yvals, rtol=1e-5, atol=0.0)) + + end subroutine test_cotan + end module test_simple diff --git a/src/fortuno.f90 b/src/fortuno.f90 index 097684a..8ce4995 100644 --- a/src/fortuno.f90 +++ b/src/fortuno.f90 @@ -6,15 +6,17 @@ module fortuno use fortuno_basetypes, only : test_base, test_case_base, test_item, test_list, test_ptr_item,& & test_suite_base - use fortuno_chartypes, only : char_rep, char_rep_int, named_details, named_item, named_state + use fortuno_chartypes, only : stringable, details_dict, dict_item, state_dict,& + & matches_type_value, get_ptr_to use fortuno_consolelogger, only : console_logger + use fortuno_env, only : nl use fortuno_testcontext, only : context_factory, test_context - use fortuno_checkers, only : is_equal + use fortuno_checkers, only : all_close, all_equal, is_close, is_equal use fortuno_cmdapp, only : cmd_app use fortuno_testdriver, only : init_test_driver, test_driver, test_runner, test_selection use fortuno_testinfo, only : check_result, drive_result, failure_info, failure_location,& & init_drive_result, init_failure_location, test_result, teststatus - use fortuno_utils, only : as_char, nl + use fortuno_utils, only : str implicit none end module fortuno diff --git a/src/fortuno/CMakeLists.txt b/src/fortuno/CMakeLists.txt index 7a6f2bd..2d041bf 100644 --- a/src/fortuno/CMakeLists.txt +++ b/src/fortuno/CMakeLists.txt @@ -8,8 +8,10 @@ target_sources( basetypes.f90 chartypes.f90 checkers.f90 + checkfuncs.f90 cmdapp.f90 consolelogger.f90 + env.f90 testcontext.f90 testdriver.f90 testinfo.f90 @@ -17,3 +19,5 @@ target_sources( utils.f90 version.f90 ) + +add_subdirectory(checkers) \ No newline at end of file diff --git a/src/fortuno/argumentparser.f90 b/src/fortuno/argumentparser.f90 index 99dcaa3..7adbfac 100644 --- a/src/fortuno/argumentparser.f90 +++ b/src/fortuno/argumentparser.f90 @@ -4,8 +4,9 @@ !> Implements a simple command line argument parser module fortuno_argumentparser + use fortuno_env, only : nl use fortuno_testlogger, only : test_logger - use fortuno_utils, only : basename, nl, string, string_list + use fortuno_utils, only : basename, string_item, string_item_list implicit none private @@ -125,7 +126,7 @@ subroutine argument_parser_parse_args(this, argumentvalues, logger, exitcode) !> Exit code (-1, if processing can continue, >= 0 if processing should stop) integer, intent(out) :: exitcode - type(string), allocatable :: cmdargs(:), posargs(:) + type(string_item), allocatable :: cmdargs(:), posargs(:) logical, allocatable :: processed(:) character(:), allocatable :: argname integer :: nargs, nargdefs, iarg, iargdef @@ -146,13 +147,13 @@ subroutine argument_parser_parse_args(this, argumentvalues, logger, exitcode) iarg = 0 argloop: do while (iarg < nargs) iarg = iarg + 1 - associate (arg => cmdargs(iarg)%content) + associate (arg => cmdargs(iarg)%value) if (arg == "--") then optionsallowed = .false. cycle end if if (.not. optionsallowed .or. arg(1:1) /= "-") then - posargs = [posargs, string(arg)] + posargs = [posargs, string_item(arg)] cycle end if islong = arg(1:min(len(arg), 2)) == "--" @@ -161,12 +162,12 @@ subroutine argument_parser_parse_args(this, argumentvalues, logger, exitcode) else if (len(arg) == 2) then argname = arg(2:2) else - call logger%log_error("Invalid short option '" // cmdargs(iarg)%content // "'") + call logger%log_error("Invalid short option '" // cmdargs(iarg)%value // "'") exitcode = 1 return end if if ((islong .and. argname == "help") .or. (.not. islong .and. argname == "h")) then - call print_help_(logger, cmdargs(0)%content, this%description, this%argdefs) + call print_help_(logger, cmdargs(0)%value, this%description, this%argdefs) exitcode = 0 return end if @@ -228,7 +229,7 @@ subroutine argument_parser_parse_args(this, argumentvalues, logger, exitcode) nn = size(argumentvalues%argvals) allocate(argvalbuffer(nn + 1)) argvalbuffer(1 : nn) = argumentvalues%argvals - argvalbuffer(nn + 1) = argument_value(argdef%name, argval=string_list(posargs)) + argvalbuffer(nn + 1) = argument_value(argdef%name, argval=string_item_list(posargs)) call move_alloc(argvalbuffer, argumentvalues%argvals) end block ! +} @@ -276,7 +277,7 @@ subroutine argument_values_get_value_stringlist(this, name, val) character(*), intent(in) :: name !> Value on exit - type(string), allocatable, intent(out) :: val(:) + type(string_item), allocatable, intent(out) :: val(:) logical :: found integer :: iargval @@ -288,7 +289,7 @@ subroutine argument_values_get_value_stringlist(this, name, val) end do if (found) then select type (argval => this%argvals(iargval)%argval) - type is (string_list) + type is (string_item_list) val = argval%items class default error stop "Invalid argument type for argument '" // name // "'" @@ -316,7 +317,7 @@ end function new_argument_value !! Returns the command line arguments as an array of strings. subroutine get_command_line_args_(cmdargs) - type(string), allocatable :: cmdargs(:) + type(string_item), allocatable :: cmdargs(:) integer :: nargs, iarg, arglen @@ -324,8 +325,8 @@ subroutine get_command_line_args_(cmdargs) allocate(cmdargs(0:nargs)) do iarg = 0, nargs call get_command_argument(iarg, length=arglen) - allocate(character(arglen) :: cmdargs(iarg)%content) - call get_command_argument(iarg, value=cmdargs(iarg)%content) + allocate(character(arglen) :: cmdargs(iarg)%value) + call get_command_argument(iarg, value=cmdargs(iarg)%value) end do end subroutine get_command_line_args_ diff --git a/src/fortuno/chartypes.f90 b/src/fortuno/chartypes.f90 index fe673bf..66a571a 100644 --- a/src/fortuno/chartypes.f90 +++ b/src/fortuno/chartypes.f90 @@ -4,42 +4,48 @@ !> Contains various types related to character representations. module fortuno_chartypes - use fortuno_utils, only : as_char, as_upper, nl, string + use fortuno_env, only : i32, i64, r32, r64, nl + use fortuno_checkfuncs, only : is_close_elem + use fortuno_utils, only : str, upper, string_item implicit none private - public :: char_rep - public :: char_rep_int - public :: named_item, named_details, named_state + public :: stringable + public :: int32_item, int64_item + public :: int32_r1_item, int64_r1_item + public :: real32_item, real64_item + public :: dict_item, details_dict, state_dict + public :: matches_type_value + public :: get_ptr_to - !> Character representable object. - type, abstract :: char_rep + !> Interface of a character representable object. + type, abstract :: stringable contains - procedure(char_rep_as_char), deferred :: as_char - end type char_rep + procedure(stringable_as_string), deferred :: as_string + end type stringable abstract interface - !> Character representation of the char_rep object. - function char_rep_as_char(this) result(repr) - import :: char_rep + !> Character representation of the stringable object. + function stringable_as_string(this) result(repr) + import :: stringable implicit none !> Instance - class(char_rep), intent(in) :: this + class(stringable), intent(in) :: this !> Character representation of the object. character(:), allocatable :: repr - end function char_rep_as_char + end function stringable_as_string end interface !> Implements a named item of arbitrary type - type :: named_item + type :: dict_item !> Name character(:), allocatable :: name @@ -47,56 +53,130 @@ end function char_rep_as_char !> Value associated with the name class(*), allocatable :: value - end type named_item + end type dict_item ! Workaround:gfortran:13.2 ! Needs user defined structure constructor as default constructor can not deal with class(*) field - interface named_item - module procedure new_named_item + interface dict_item + module procedure new_dict_item end interface !> Represents failure details with an array of named items. - type, extends(char_rep) :: named_details + type, extends(stringable) :: details_dict !> Items containing the information about the failure details - type(named_item), allocatable :: items(:) + type(dict_item), allocatable :: items(:) contains - procedure :: as_char => named_details_as_char - end type named_details + procedure :: as_string => details_dict_as_string + end type details_dict !> Represents test internal state with an array of named items. - type, extends(char_rep) :: named_state + type, extends(stringable) :: state_dict !> Items containing the information about the failure details - type(named_item), allocatable :: items(:) + type(dict_item), allocatable :: items(:) contains - procedure :: as_char => named_state_as_char - end type named_state + procedure :: as_string => state_dict_as_string + end type state_dict - !> Character representable integer. - type, extends(char_rep) :: char_rep_int + !> Character representable 32 bit integer. + type, extends(stringable) :: int32_item !> Value - integer :: value + integer(i32), allocatable :: value contains - procedure :: as_char => char_rep_int_as_char - end type char_rep_int + procedure :: as_string => int32_item_as_string + end type int32_item + + + !> Character representable 32 bit integer rank 1 array. + type, extends(stringable) :: int32_r1_item + + !> Value + integer(i32), allocatable :: value(:) + + contains + procedure :: as_string => int32_r1_item_as_string + end type int32_r1_item + + + !> Character representable 64 bit integer. + type, extends(stringable) :: int64_item + + !> Value + integer(i64), allocatable :: value + + contains + procedure :: as_string => int64_item_as_string + end type int64_item + + + !> Character representable 64 bit integer rank 1 array. + type, extends(stringable) :: int64_r1_item + + !> Value + integer(i64), allocatable :: value(:) + + contains + procedure :: as_string => int64_r1_item_as_string + end type int64_r1_item + + + !> Character representable 32 bit float. + type, extends(stringable) :: real32_item + + !> Value + real(r32), allocatable :: value + + contains + procedure :: as_string => real32_item_as_string + + end type real32_item + + + !> Character representable 64 bit float. + type, extends(stringable) :: real64_item + + !> Value + real(r64), allocatable :: value + + contains + procedure :: as_string => real64_item_as_string + + end type real64_item + + + interface get_ptr_to + module procedure get_ptr_to_details_dict + module procedure get_ptr_to_state_dict + end interface get_ptr_to + + + interface matches_type_value + module procedure matches_type_value_int32_item + module procedure matches_type_value_int32_r1_item + module procedure matches_type_value_int64_item + module procedure matches_type_value_int64_r1_item + module procedure matches_type_value_real32_item + module procedure matches_type_value_real64_item + module procedure matches_type_value_string + end interface matches_type_value contains !> Returns the character representation of the failure details. - function named_details_as_char(this) result(repr) + function details_dict_as_string(this) result(repr) !> Instance - class(named_details), intent(in) :: this + class(details_dict), intent(in) :: this !> Character representation character(:), allocatable :: repr @@ -105,17 +185,17 @@ function named_details_as_char(this) result(repr) repr = "" return end if - call get_named_items_as_char_(this%items, repr, itemsep=nl, namesep=": ",& - & capitalizename=.true.) + call get_dict_items_as_string(this%items, repr, itemsep=nl, namesep=": ",& + & capitalizenames=.true.) - end function named_details_as_char + end function details_dict_as_string !> Returns the character representation of an internal test state. - function named_state_as_char(this) result(repr) + function state_dict_as_string(this) result(repr) !> Instance - class(named_state), intent(in) :: this + class(state_dict), intent(in) :: this !> Character representation character(:), allocatable :: repr @@ -124,28 +204,98 @@ function named_state_as_char(this) result(repr) repr = "" return end if - call get_named_items_as_char_(this%items, repr, itemsep=nl, namesep=":",& - & capitalizename=.false.) + call get_dict_items_as_string(this%items, repr, itemsep=", ", namesep=": ",& + & capitalizenames=.false.) + + end function state_dict_as_string + + + !> String representation of an integer rank 1 array. + function int32_item_as_string(this) result(repr) + + !> Instance + class(int32_item), intent(in) :: this + + !> Character representation + character(:), allocatable :: repr + + repr = str(this%value) - end function named_state_as_char + end function int32_item_as_string - !> Integer with string representation. - function char_rep_int_as_char(this) result(repr) + !> String representation of an integer rank 1 array. + function int32_r1_item_as_string(this) result(repr) !> Instance - class(char_rep_int), intent(in) :: this + class(int32_r1_item), intent(in) :: this !> Character representation character(:), allocatable :: repr - repr = as_char(this%value) + repr = str(this%value) - end function char_rep_int_as_char + end function int32_r1_item_as_string - !> Explicit constructor for named_item (to avoid gfortran compilation problems) - function new_named_item(name, val) result(this) + !> String representation of an integer rank 1 array. + function int64_item_as_string(this) result(repr) + + !> Instance + class(int64_item), intent(in) :: this + + !> Character representation + character(:), allocatable :: repr + + repr = str(this%value) + + end function int64_item_as_string + + + !> String representation of an integer rank 1 array. + function int64_r1_item_as_string(this) result(repr) + + !> Instance + class(int64_r1_item), intent(in) :: this + + !> Character representation + character(:), allocatable :: repr + + repr = str(this%value) + + end function int64_r1_item_as_string + + + !> String representation of a 32 bit real. + function real32_item_as_string(this) result(repr) + + !> Instance + class(real32_item), intent(in) :: this + + !> Character representation + character(:), allocatable :: repr + + repr = str(this%value) + + end function real32_item_as_string + + + !> String representation of a 32 bit real. + function real64_item_as_string(this) result(repr) + + !> Instance + class(real64_item), intent(in) :: this + + !> Character representation + character(:), allocatable :: repr + + repr = str(this%value) + + end function real64_item_as_string + + + !> Explicit constructor for dict_item (to avoid gfortran compilation problems) + function new_dict_item(name, val) result(this) !> Name of the item character(*), intent(in) :: name @@ -154,23 +304,151 @@ function new_named_item(name, val) result(this) class(*), intent(in) :: val !> Initialized instance - type(named_item) :: this + type(dict_item) :: this this%name = name allocate(this%value, source=val) - end function new_named_item + end function new_dict_item + + + subroutine get_ptr_to_details_dict(obj, ptr) + class(stringable), pointer, intent(in) :: obj + type(details_dict), pointer, intent(out) :: ptr + + ptr => null() + select type (obj) + type is (details_dict) + ptr => obj + end select + + end subroutine get_ptr_to_details_dict + + + subroutine get_ptr_to_state_dict(obj, ptr) + class(stringable), pointer, intent(in) :: obj + type(state_dict), pointer, intent(out) :: ptr + + ptr => null() + select type (obj) + type is (state_dict) + ptr => obj + end select + + end subroutine get_ptr_to_state_dict + + + function matches_type_value_int32_item(obj, val) result(matches) + class(*), intent(in) :: obj + integer(i32), intent(in) :: val + logical :: matches + + matches = .false. + select type (obj) + type is (int32_item) + matches = obj%value == val + end select + + end function matches_type_value_int32_item + + + function matches_type_value_int32_r1_item(obj, val) result(matches) + class(*), intent(in) :: obj + integer(i32), intent(in) :: val(:) + logical :: matches + + matches = .false. + select type (obj) + type is (int32_r1_item) + if (.not. all(shape(obj%value, kind=i64) == shape(val, kind=i64))) return + matches = all(obj%value == val) + end select + + end function matches_type_value_int32_r1_item + + + function matches_type_value_int64_item(obj, val) result(matches) + class(*), intent(in) :: obj + integer(i64), intent(in) :: val + logical :: matches + + matches = .false. + select type (obj) + type is (int64_item) + matches = obj%value == val + end select + + end function matches_type_value_int64_item + + + function matches_type_value_int64_r1_item(obj, val) result(matches) + class(*), intent(in) :: obj + integer(i64), intent(in) :: val(:) + logical :: matches + + matches = .false. + select type (obj) + type is (int64_r1_item) + if (.not. all(shape(obj%value, kind=i64) == shape(val, kind=i64))) return + matches = all(obj%value == val) + end select + + end function matches_type_value_int64_r1_item + + + function matches_type_value_real32_item(obj, val, rtol, atol) result(matches) + class(*), intent(in) :: obj + real(r32), intent(in) :: val + real(r32), optional, intent(in) :: rtol, atol + logical :: matches + + matches = .false. + select type (obj) + type is (real32_item) + matches = is_close_elem(obj%value, val, rtol, atol) + end select + + end function matches_type_value_real32_item + + + function matches_type_value_real64_item(obj, val, rtol, atol) result(matches) + class(*), intent(in) :: obj + real(r64), intent(in) :: val + real(r64), optional, intent(in) :: rtol, atol + logical :: matches + + matches = .false. + select type (obj) + type is (real64_item) + matches = is_close_elem(obj%value, val, rtol, atol) + end select + + end function matches_type_value_real64_item + + + function matches_type_value_string(obj, val) result(matches) + class(*), intent(in) :: obj + type(character(*)), intent(in) :: val + logical :: matches + + matches = .false. + select type (obj) + type is (character(*)) + matches = obj == val + end select + + end function matches_type_value_string !! Returns the character representation of an array of named items. - subroutine get_named_items_as_char_(items, repr, itemsep, namesep, capitalizename) - type(named_item), intent(in) :: items(:) + subroutine get_dict_items_as_string(items, repr, itemsep, namesep, capitalizenames) + type(dict_item), intent(in) :: items(:) character(:), allocatable, intent(out) :: repr character(*), intent(in) :: itemsep, namesep - logical, intent(in) :: capitalizename + logical, intent(in) :: capitalizenames integer :: nitems, iitem, pos, reprlen, itemseplen, nameseplen - type(string), allocatable :: valuestrings(:) + type(string_item), allocatable :: valuestrings(:) nitems = size(items) if (nitems == 0) then @@ -181,17 +459,25 @@ subroutine get_named_items_as_char_(items, repr, itemsep, namesep, capitalizenam allocate(valuestrings(size(items))) do iitem = 1, nitems reprlen = reprlen + len(items(iitem)%name) - select type (namedvalue => items(iitem)%value) + select type (itemvalue => items(iitem)%value) type is (character(*)) - valuestrings(iitem)%content = namedvalue - class is (string) - valuestrings(iitem)%content = namedvalue%content - class is (char_rep) - valuestrings(iitem)%content = namedvalue%as_char() + valuestrings(iitem)%value = itemvalue + type is (logical) + valuestrings(iitem)%value = str(itemvalue) + type is (integer(i32)) + valuestrings(iitem)%value = str(itemvalue) + type is (integer(i64)) + valuestrings(iitem)%value = str(itemvalue) + type is (real(r32)) + valuestrings(iitem)%value = str(itemvalue) + type is (real(r64)) + valuestrings(iitem)%value = str(itemvalue) + class is (stringable) + valuestrings(iitem)%value = itemvalue%as_string() class default - valuestrings(iitem)%content = "???" + valuestrings(iitem)%value = "???" end select - reprlen = reprlen + len(valuestrings(iitem)%content) + reprlen = reprlen + len(valuestrings(iitem)%value) end do nameseplen = len(namesep) @@ -201,10 +487,10 @@ subroutine get_named_items_as_char_(items, repr, itemsep, namesep, capitalizenam pos = 1 do iitem = 1, nitems - associate(name => items(iitem)%name, valstr => valuestrings(iitem)%content) + associate(name => items(iitem)%name, valstr => valuestrings(iitem)%value) reprlen = len(name) repr(pos : pos + reprlen - 1) = name - if (capitalizename) repr(pos:pos) = as_upper(repr(pos:pos)) + if (capitalizenames) repr(pos:pos) = upper(repr(pos:pos)) pos = pos + reprlen repr(pos : pos + nameseplen - 1) = namesep pos = pos + nameseplen @@ -218,6 +504,6 @@ subroutine get_named_items_as_char_(items, repr, itemsep, namesep, capitalizenam end associate end do - end subroutine get_named_items_as_char_ + end subroutine get_dict_items_as_string end module fortuno_chartypes diff --git a/src/fortuno/checkers.f90 b/src/fortuno/checkers.f90 index c8f763f..561dddf 100644 --- a/src/fortuno/checkers.f90 +++ b/src/fortuno/checkers.f90 @@ -4,59 +4,14 @@ !> Contains some built-in checkers module fortuno_checkers - use fortuno_chartypes, only : char_rep_int, named_details, named_item - use fortuno_testinfo, only : check_result + use fortuno_checkers_int32, only : is_equal, all_equal + use fortuno_checkers_int64, only : is_equal, all_equal + use fortuno_checkers_real32, only : is_close, all_close + use fortuno_checkers_real64, only : is_close, all_close implicit none private - public :: is_equal - - - !> Checks whether two entities are equal - interface is_equal - module procedure is_equal_i0_i0 - end interface is_equal - -contains - - - !> Checks whether two integer values are equal - function is_equal_i0_i0(obtained, expected) result(checkresult) - - !> Obtained value - integer, intent(in) :: obtained - - !> Expected value - integer, intent(in) :: expected - - !> Result of the check - type(check_result) :: checkresult - - checkresult%success = (obtained == expected) - if (.not. checkresult%success) then - ! Workaround:gfortran:14.1 (bug 116679) - ! Omit array expression to avoid memory leak - ! {- - ! checkresult%details = named_details([& - ! & named_item("failure", "mismatching integer values"),& - ! & named_item("expected", char_rep_int(expected)),& - ! & named_item("obtained", char_rep_int(obtained))& - ! & ]) - ! -}{+ - block - type(named_details), allocatable :: nameddetails - allocate(nameddetails) - allocate(nameddetails%items(3)) - associate (items => nameddetails%items) - items(1) = named_item("failure", "mismatching integer values") - items(2) = named_item("expected", char_rep_int(expected)) - items(3) = named_item("obtained", char_rep_int(obtained)) - end associate - call move_alloc(nameddetails, checkresult%details) - end block - ! +} - end if - - end function is_equal_i0_i0 + public :: is_equal, all_equal + public :: is_close, all_close end module fortuno_checkers \ No newline at end of file diff --git a/src/fortuno/checkers/CMakeLists.txt b/src/fortuno/checkers/CMakeLists.txt new file mode 100644 index 0000000..50f8ec8 --- /dev/null +++ b/src/fortuno/checkers/CMakeLists.txt @@ -0,0 +1,15 @@ +# This file is part of Fortuno. +# Licensed under the BSD-2-Clause Plus Patent license. +# SPDX-License-Identifier: BSD-2-Clause-Patent + +target_sources( + fortuno PRIVATE + helpers.f90 + int32.f90 + int64.f90 + real32.f90 + real64.f90 +) + +# Make sure all compilers find the include files used in this directory +target_include_directories(fortuno PRIVATE ${CMAKE_CURRENT_SOURCE_DIR}) \ No newline at end of file diff --git a/src/fortuno/checkers/helpers.f90 b/src/fortuno/checkers/helpers.f90 new file mode 100644 index 0000000..17b5f75 --- /dev/null +++ b/src/fortuno/checkers/helpers.f90 @@ -0,0 +1,103 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Contains some helper functions for the built-in checkers +module fortuno_checkers_helpers + use fortuno_chartypes, only : stringable, details_dict, dict_item, int64_r1_item + use fortuno_env, only : i64 + use fortuno_testinfo, only : check_result + implicit none + + private + public :: add_shape_mismatch_details, add_value_mismatch_details + +contains + + + subroutine add_shape_mismatch_details(shape1, shape2, checkresult) + integer(i64), intent(in) :: shape1(:), shape2(:) + type(check_result), intent(inout) :: checkresult + + ! Workaround:gfortran:14.1 (bug 116679) + ! Omit array expression to avoid memory leak + ! {- + ! checkresult%details = details_dict([& + ! & dict_item("failure", "mismatching array shapes"),& + ! & dict_item("shape1", int64_r1_item(shape1)),& + ! & dict_item("shape2", int64_r1_item(shape2))& + ! & ]) + ! -}{+ + block + type(details_dict), allocatable :: nameddetails + allocate(nameddetails) + allocate(nameddetails%items(3)) + associate (items => nameddetails%items) + items(1) = dict_item("failure", "mismatching array shapes") + items(2) = dict_item("shape1", int64_r1_item(shape1)) + items(3) = dict_item("shape2", int64_r1_item(shape2)) + end associate + call move_alloc(nameddetails, checkresult%details) + end block + ! +} + + end subroutine add_shape_mismatch_details + + + subroutine add_value_mismatch_details(msg, value1, value2, checkresult, mismatchloc) + character(*), intent(in) :: msg + class(stringable), intent(in) :: value1, value2 + type(check_result), intent(inout) :: checkresult + integer(i64), optional, intent(in) :: mismatchloc(:) + + if (present(mismatchloc)) then + ! Workaround:gfortran:14.1 (bug 116679) + ! Omit array expression to avoid memory leak + ! {- + ! checkresult%details = details_dict([& + ! & dict_item("failure", msg),& + ! & dict_item("location", int64_r1_item(mismatchloc)),& + ! & dict_item("value1", value1),& + ! & dict_item("value2", value2)& + ! & ]) + ! -}{+ + block + type(details_dict), allocatable :: nameddetails + allocate(nameddetails) + allocate(nameddetails%items(4)) + associate (items => nameddetails%items) + items(1) = dict_item("failure", msg) + items(2) = dict_item("location", int64_r1_item(mismatchloc)) + items(3) = dict_item("value1", value1) + items(4) = dict_item("value2", value2) + end associate + call move_alloc(nameddetails, checkresult%details) + end block + ! +} + else + ! Workaround:gfortran:14.1 (bug 116679) + ! Omit array expression to avoid memory leak + ! {- + ! checkresult%details = details_dict([& + ! & dict_item("failure", msg),& + ! & dict_item("value1", value1),& + ! & dict_item("value2", value2)& + ! & ]) + ! -}{+ + block + type(details_dict), allocatable :: nameddetails + allocate(nameddetails) + allocate(nameddetails%items(3)) + associate (items => nameddetails%items) + items(1) = dict_item("failure", msg) + items(2) = dict_item("value1", value1) + items(3) = dict_item("value2", value2) + end associate + call move_alloc(nameddetails, checkresult%details) + end block + ! +} + end if + + end subroutine add_value_mismatch_details + +end module fortuno_checkers_helpers diff --git a/src/fortuno/checkers/int32.f90 b/src/fortuno/checkers/int32.f90 new file mode 100644 index 0000000..f5dc76f --- /dev/null +++ b/src/fortuno/checkers/int32.f90 @@ -0,0 +1,38 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Contains some built-in checkers instantiations (32 bit integer) +module fortuno_checkers_int32 + ! Template parameters + use fortuno_env, only : ik => i32 + use fortuno_chartypes, only : value_item => int32_item + ! Template dependencies + use fortuno_env, only : i64 + use fortuno_checkers_helpers, only : add_shape_mismatch_details, add_value_mismatch_details + use fortuno_testinfo, only : check_result + implicit none + + private + public :: is_equal, all_equal + + + !> Checks whether two entities are equal + interface is_equal + module procedure is_equal_r0_r0 + end interface is_equal + + !> Checks whether all entities in an array are equal + interface all_equal + module procedure is_equal_r0_r0 + module procedure all_equal_r1_r1 + module procedure all_equal_r2_r2 + module procedure all_equal_r1_r0, all_equal_r0_r1 + module procedure all_equal_r2_r0, all_equal_r0_r2 + end interface all_equal + +contains + + include 'int_template.inc' + +end module fortuno_checkers_int32 \ No newline at end of file diff --git a/src/fortuno/checkers/int64.f90 b/src/fortuno/checkers/int64.f90 new file mode 100644 index 0000000..331cc11 --- /dev/null +++ b/src/fortuno/checkers/int64.f90 @@ -0,0 +1,38 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Contains some built-in checkers instantiations (64 bit real) +module fortuno_checkers_int64 + ! Template parameters + use fortuno_env, only : ik => i64 + use fortuno_chartypes, only : value_item => int64_item + ! Template dependencies + use fortuno_env, only : i64 + use fortuno_checkers_helpers, only : add_shape_mismatch_details, add_value_mismatch_details + use fortuno_testinfo, only : check_result + implicit none + + private + public :: is_equal, all_equal + + + !> Checks whether two entities are equal + interface is_equal + module procedure is_equal_r0_r0 + end interface is_equal + + !> Checks whether all entities in an array are equal + interface all_equal + module procedure is_equal_r0_r0 + module procedure all_equal_r1_r1 + module procedure all_equal_r2_r2 + module procedure all_equal_r1_r0, all_equal_r0_r1 + module procedure all_equal_r2_r0, all_equal_r0_r2 + end interface all_equal + +contains + + include 'int_template.inc' + +end module fortuno_checkers_int64 \ No newline at end of file diff --git a/src/fortuno/checkers/int_template.inc b/src/fortuno/checkers/int_template.inc new file mode 100644 index 0000000..043cc7c --- /dev/null +++ b/src/fortuno/checkers/int_template.inc @@ -0,0 +1,204 @@ + + !> Checks whether two integer values are equal + function is_equal_r0_r0(value1, value2) result(checkresult) + + !> First value to check + integer(ik), intent(in) :: value1 + + !> Second value to check + integer(ik), intent(in) :: value2 + + !> Result of the check + type(check_result) :: checkresult + + logical :: match + + match = value1 == value2 + if (.not. match) then + call add_value_mismatch_details("mismatching integer values",& + & value_item(value1), value_item(value2), checkresult) + return + end if + checkresult%success = .true. + + end function is_equal_r0_r0 + + + !> Checks whether two integer rank 1 arrays are equal. + function all_equal_r1_r1(value1, value2) result(checkresult) + + !> First value to check + integer(ik), intent(in) :: value1(:) + + !> Second value to check + integer(ik), intent(in) :: value2(:) + + !> Result of the check + type(check_result) :: checkresult + + logical, allocatable :: match(:) + integer(i64) :: mismatchloc(1) + + if (any(shape(value1, kind=i64) /= shape(value2, kind=i64))) then + call add_shape_mismatch_details(shape(value1, kind=i64), shape(value2, kind=i64),& + & checkresult) + return + end if + match = value1 == value2 + mismatchloc = findloc(match, .false., kind=i64) + if (all(mismatchloc /= 0)) then + call add_value_mismatch_details("mismatching integer values",& + & value_item(value1(mismatchloc(1))), value_item(value2(mismatchloc(1))),& + & checkresult, mismatchloc=mismatchloc) + return + end if + checkresult%success = .true. + + end function all_equal_r1_r1 + + + !> Checks whether two integer rank 1 arrays are equal. + function all_equal_r2_r2(value1, value2) result(checkresult) + + !> First value to check + integer(ik), intent(in) :: value1(:,:) + + !> Second value to check + integer(ik), intent(in) :: value2(:,:) + + !> Result of the check + type(check_result) :: checkresult + + logical, allocatable :: match(:,:) + integer(i64) :: mismatchloc(2) + + if (any(shape(value1, kind=i64) /= shape(value2, kind=i64))) then + call add_shape_mismatch_details(shape(value1, kind=i64), shape(value2, kind=i64),& + & checkresult) + return + end if + match = value1 == value2 + mismatchloc = findloc(match, .false., kind=i64) + if (all(mismatchloc /= 0)) then + call add_value_mismatch_details("mismatching integer values",& + & value_item(value1(mismatchloc(1), mismatchloc(2))),& + & value_item(value2(mismatchloc(1), mismatchloc(2))),& + & checkresult, mismatchloc=mismatchloc) + return + end if + checkresult%success = .true. + + end function all_equal_r2_r2 + + + !> Checks whether an integer rank 1 arrays is equal to a scalar. + function all_equal_r1_r0(value1, value2) result(checkresult) + + !> First value to check + integer(ik), intent(in) :: value1(:) + + !> Second value to check + integer(ik), intent(in) :: value2 + + !> Result of the check + type(check_result) :: checkresult + + logical, allocatable :: match(:) + integer(i64) :: mismatchloc(1) + + match = value1 == value2 + mismatchloc = findloc(match, .false., kind=i64) + if (all(mismatchloc /= 0)) then + call add_value_mismatch_details("mismatching integer values",& + & value_item(value1(mismatchloc(1))), value_item(value2),& + & checkresult, mismatchloc=mismatchloc) + return + end if + checkresult%success = .true. + + end function all_equal_r1_r0 + + + !> Checks whether a scalar integer is equal to an integer rank 1 array. + function all_equal_r0_r1(value1, value2) result(checkresult) + + !> First value to check + integer(ik), intent(in) :: value1 + + !> Second value to check + integer(ik), intent(in) :: value2(:) + + !> Result of the check + type(check_result) :: checkresult + + logical, allocatable :: match(:) + integer(i64) :: mismatchloc(1) + + match = value1 == value2 + mismatchloc = findloc(match, .false., kind=i64) + if (all(mismatchloc /= 0)) then + call add_value_mismatch_details("mismatching integer values",& + & value_item(value1), value_item(value2(mismatchloc(1))),& + & checkresult, mismatchloc=mismatchloc) + return + end if + checkresult%success = .true. + + end function all_equal_r0_r1 + + + !> Checks whether two integer rank 1 arrays are equal. + function all_equal_r2_r0(value1, value2) result(checkresult) + + !> First value to check + integer(ik), intent(in) :: value1(:,:) + + !> Second value to check + integer(ik), intent(in) :: value2 + + !> Result of the check + type(check_result) :: checkresult + + logical, allocatable :: match(:,:) + integer(i64) :: mismatchloc(2) + + match = value1 == value2 + mismatchloc = findloc(match, .false., kind=i64) + if (all(mismatchloc /= 0)) then + call add_value_mismatch_details("mismatching integer values",& + & value_item(value1(mismatchloc(1), mismatchloc(2))),& + & value_item(value2), checkresult, mismatchloc=mismatchloc) + return + end if + checkresult%success = .true. + + end function all_equal_r2_r0 + + + !> Checks whether two integer rank 1 arrays are equal. + function all_equal_r0_r2(value1, value2) result(checkresult) + + !> First value to check + integer(ik), intent(in) :: value1 + + !> Second value to check + integer(ik), intent(in) :: value2(:,:) + + !> Result of the check + type(check_result) :: checkresult + + logical, allocatable :: match(:,:) + integer(i64) :: mismatchloc(2) + + match = value1 == value2 + mismatchloc = findloc(match, .false., kind=i64) + if (all(mismatchloc /= 0)) then + call add_value_mismatch_details("mismatching integer values",& + & value_item(value1),& + & value_item(value2(mismatchloc(1), mismatchloc(2))),& + & checkresult, mismatchloc=mismatchloc) + return + end if + checkresult%success = .true. + + end function all_equal_r0_r2 diff --git a/src/fortuno/checkers/meson.build b/src/fortuno/checkers/meson.build new file mode 100644 index 0000000..5f22fe1 --- /dev/null +++ b/src/fortuno/checkers/meson.build @@ -0,0 +1,11 @@ +# This file is part of Fortuno. +# Licensed under the BSD-2-Clause Plus Patent license. +# SPDX-License-Identifier: BSD-2-Clause-Patent + +fortuno_sources += files( + 'helpers.f90', + 'int32.f90', + 'int64.f90', + 'real32.f90', + 'real64.f90', +) diff --git a/src/fortuno/checkers/real32.f90 b/src/fortuno/checkers/real32.f90 new file mode 100644 index 0000000..5e93952 --- /dev/null +++ b/src/fortuno/checkers/real32.f90 @@ -0,0 +1,38 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Contains some built-in checkers instantiations (32 bit real) +module fortuno_checkers_real32 + ! Template parameters + use fortuno_env, only : rk => r32 + use fortuno_chartypes, only : value_item => real32_item + ! Template dependencies + use fortuno_env, only : i64 + use fortuno_checkfuncs, only : is_close_elem + use fortuno_checkers_helpers, only : add_shape_mismatch_details, add_value_mismatch_details + use fortuno_testinfo, only : check_result + implicit none + + private + public :: is_close, all_close + + !> Checks whether two entities are close each other + interface is_close + module procedure is_close_r0_r0 + end interface is_close + + !> Checks whether all entities in an array are close to each other + interface all_close + module procedure is_close_r0_r0 + module procedure all_close_r1_r1 + module procedure all_close_r2_r2 + module procedure all_close_r1_r0, all_close_r0_r1 + module procedure all_close_r2_r0, all_close_r0_r2 + end interface all_close + +contains + + include 'real_template.inc' + +end module fortuno_checkers_real32 \ No newline at end of file diff --git a/src/fortuno/checkers/real64.f90 b/src/fortuno/checkers/real64.f90 new file mode 100644 index 0000000..127e406 --- /dev/null +++ b/src/fortuno/checkers/real64.f90 @@ -0,0 +1,38 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Contains some built-in checkers instantiations (64 bit real) +module fortuno_checkers_real64 + ! Template parameters + use fortuno_env, only : rk => r64 + use fortuno_chartypes, only : value_item => real64_item + ! Template dependencies + use fortuno_env, only : i64 + use fortuno_checkfuncs, only : is_close_elem + use fortuno_checkers_helpers, only : add_shape_mismatch_details, add_value_mismatch_details + use fortuno_testinfo, only : check_result + implicit none + + private + public :: is_close, all_close + + !> Checks whether two entities are close each other + interface is_close + module procedure is_close_r0_r0 + end interface is_close + + !> Checks whether all entities in an array are close to each other + interface all_close + module procedure is_close_r0_r0 + module procedure all_close_r1_r1 + module procedure all_close_r2_r2 + module procedure all_close_r1_r0, all_close_r0_r1 + module procedure all_close_r2_r0, all_close_r0_r2 + end interface all_close + +contains + + include 'real_template.inc' + +end module fortuno_checkers_real64 \ No newline at end of file diff --git a/src/fortuno/checkers/real_template.inc b/src/fortuno/checkers/real_template.inc new file mode 100644 index 0000000..b3925b4 --- /dev/null +++ b/src/fortuno/checkers/real_template.inc @@ -0,0 +1,247 @@ + + !> Checks whether two real numbers are close to each other. + function is_close_r0_r0(value1, value2, rtol, atol) result(checkresult) + + !> First value to check + real(rk), intent(in) :: value1 + + !> Second value to check + real(rk), intent(in) :: value2 + + !> Relative tolerance for the comparison + real(rk), optional, intent(in) :: rtol + + !> Absolute tolerance for the comparison + real(rk), optional, intent(in) :: atol + + !> Result of the check + type(check_result) :: checkresult + + logical :: match + + match = is_close_elem(value1, value2, atol=atol, rtol=rtol) + if (.not. match) then + call add_value_mismatch_details("real values differing beyond tolerance",& + & value_item(value1), value_item(value2), checkresult) + return + end if + checkresult%success = .true. + + end function is_close_r0_r0 + + + !> Checks whether all elements of two real rank one arrays are close to each other. + function all_close_r1_r1(value1, value2, rtol, atol) result(checkresult) + + !> First value to check + real(rk), intent(in) :: value1(:) + + !> Second value to check + real(rk), intent(in) :: value2(:) + + !> Relative tolerance for the comparison + real(rk), optional, intent(in) :: rtol + + !> Absolute tolerance for the comparison + real(rk), optional, intent(in) :: atol + + !> Result of the check + type(check_result) :: checkresult + + logical, allocatable :: match(:) + integer(i64) :: mismatchloc(1) + + if (any(shape(value1, kind=i64) /= shape(value2, kind=i64))) then + call add_shape_mismatch_details(shape(value1, kind=i64), shape(value2, kind=i64),& + & checkresult) + return + end if + match = is_close_elem(value1, value2, atol=atol, rtol=rtol) + mismatchloc(:) = findloc(match, .false., kind=i64) + if (all(mismatchloc /= 0)) then + call add_value_mismatch_details("real values differing beyond tolerance",& + & value_item(value1(mismatchloc(1))), value_item(value2(mismatchloc(1))), checkresult,& + & mismatchloc=mismatchloc) + return + end if + checkresult%success = .true. + + end function all_close_r1_r1 + + + !> Checks whether all elements of two real rank one arrays are close to each other. + function all_close_r2_r2(value1, value2, rtol, atol) result(checkresult) + + !> First value to check + real(rk), intent(in) :: value1(:,:) + + !> Second value to check + real(rk), intent(in) :: value2(:,:) + + !> Relative tolerance for the comparison + real(rk), optional, intent(in) :: rtol + + !> Absolute tolerance for the comparison + real(rk), optional, intent(in) :: atol + + !> Result of the check + type(check_result) :: checkresult + + logical, allocatable :: match(:,:) + integer(i64) :: mismatchloc(2) + + if (any(shape(value1, kind=i64) /= shape(value2, kind=i64))) then + call add_shape_mismatch_details(shape(value1, kind=i64), shape(value2, kind=i64),& + & checkresult) + return + end if + match = is_close_elem(value1, value2, atol=atol, rtol=rtol) + mismatchloc(:) = findloc(match, .false., kind=i64) + if (all(mismatchloc /= 0)) then + call add_value_mismatch_details("real values differing beyond tolerance",& + & value_item(value1(mismatchloc(1), mismatchloc(2))),& + & value_item(value2(mismatchloc(1), mismatchloc(2))),& + & checkresult, mismatchloc=mismatchloc) + return + end if + checkresult%success = .true. + + end function all_close_r2_r2 + + + !> Checks whether all elements of a rank1 real array and a scalar are close + function all_close_r1_r0(value1, value2, rtol, atol) result(checkresult) + + !> First value to check + real(rk), intent(in) :: value1(:) + + !> Second value to check + real(rk), intent(in) :: value2 + + !> Relative tolerance for the comparison + real(rk), optional, intent(in) :: rtol + + !> Absolute tolerance for the comparison + real(rk), optional, intent(in) :: atol + + !> Result of the check + type(check_result) :: checkresult + + logical, allocatable :: match(:) + integer(i64) :: mismatchloc(1) + + match = is_close_elem(value1, value2, atol=atol, rtol=rtol) + mismatchloc(:) = findloc(match, .false., kind=i64) + if (all(mismatchloc /= 0)) then + call add_value_mismatch_details("real values differing beyond tolerance",& + & value_item(value1(mismatchloc(1))), value_item(value2), checkresult,& + & mismatchloc=mismatchloc) + return + end if + checkresult%success = .true. + + end function all_close_r1_r0 + + + !> Checks whether a scalar and all elements of a rank1 real array are close + function all_close_r0_r1(value1, value2, rtol, atol) result(checkresult) + + !> First value to check + real(rk), intent(in) :: value1 + + !> Second value to check + real(rk), intent(in) :: value2(:) + + !> Relative tolerance for the comparison + real(rk), optional, intent(in) :: rtol + + !> Absolute tolerance for the comparison + real(rk), optional, intent(in) :: atol + + !> Result of the check + type(check_result) :: checkresult + + logical, allocatable :: match(:) + integer(i64) :: mismatchloc(1) + + match = is_close_elem(value1, value2, atol=atol, rtol=rtol) + mismatchloc(:) = findloc(match, .false., kind=i64) + if (all(mismatchloc /= 0)) then + call add_value_mismatch_details("real values differing beyond tolerance",& + & value_item(value1), value_item(value2(mismatchloc(1))), checkresult,& + & mismatchloc=mismatchloc) + return + end if + checkresult%success = .true. + + end function all_close_r0_r1 + + + !> Checks whether all elements of a rank2 real array and a scalar are close + function all_close_r2_r0(value1, value2, rtol, atol) result(checkresult) + + !> First value to check + real(rk), intent(in) :: value1(:,:) + + !> Second value to check + real(rk), intent(in) :: value2 + + !> Relative tolerance for the comparison + real(rk), optional, intent(in) :: rtol + + !> Absolute tolerance for the comparison + real(rk), optional, intent(in) :: atol + + !> Result of the check + type(check_result) :: checkresult + + logical, allocatable :: match(:,:) + integer(i64) :: mismatchloc(2) + + match = is_close_elem(value1, value2, atol=atol, rtol=rtol) + mismatchloc(:) = findloc(match, .false., kind=i64) + if (all(mismatchloc /= 0)) then + call add_value_mismatch_details("real values differing beyond tolerance",& + & value_item(value1(mismatchloc(1), mismatchloc(2))),& + & value_item(value2),& + & checkresult, mismatchloc=mismatchloc) + return + end if + checkresult%success = .true. + + end function all_close_r2_r0 + + + !> Checks whether a scalar and all elements of a rank2 real array are close + function all_close_r0_r2(value1, value2, rtol, atol) result(checkresult) + + !> First value to check + real(rk), intent(in) :: value1 + + !> Second value to check + real(rk), intent(in) :: value2(:,:) + + !> Relative tolerance for the comparison + real(rk), optional, intent(in) :: rtol + + !> Absolute tolerance for the comparison + real(rk), optional, intent(in) :: atol + + !> Result of the check + type(check_result) :: checkresult + + logical, allocatable :: match(:,:) + integer(i64) :: mismatchloc(2) + + match = is_close_elem(value1, value2, atol=atol, rtol=rtol) + mismatchloc(:) = findloc(match, .false., kind=i64) + if (all(mismatchloc /= 0)) then + call add_value_mismatch_details("real values differing beyond tolerance",& + & value_item(value1),& + & value_item(value2(mismatchloc(1), mismatchloc(2))),& + & checkresult, mismatchloc=mismatchloc) + return + end if + checkresult%success = .true. + + end function all_close_r0_r2 diff --git a/src/fortuno/checkfuncs.f90 b/src/fortuno/checkfuncs.f90 new file mode 100644 index 0000000..2257ff8 --- /dev/null +++ b/src/fortuno/checkfuncs.f90 @@ -0,0 +1,81 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Contains some supporting functions for checks. +module fortuno_checkfuncs + use fortuno_env, only : r32, r64 + implicit none + + private + public :: is_close_elem + + !> Whether two elements are close to each other + interface is_close_elem + module procedure is_close_elem_real32 + module procedure is_close_elem_real64 + end interface is_close_elem + +contains + + + elemental function is_close_elem_real32(value1, value2, rtol, atol) result(isclose) + + !> First value to check + real(r32), intent(in) :: value1 + + !> Second value to check + real(r32), intent(in) :: value2 + + !> Relative tolerance for the comparison (default: 1e-4) + real(r32), optional, intent(in) :: rtol + + !> Absolute tolerance for the comparison (default: 0.0) + real(r32), optional, intent(in) :: atol + + !> Whether the two values are close to each other + logical :: isclose + + real(r32), parameter :: atoldef = 0.0_r32, rtoldef = 1e-4_r32 + real(r32) :: rtol_, atol_ + + atol_ = atoldef + if (present(atol)) atol_ = atol + rtol_ = rtoldef + if (present(rtol)) rtol_ = rtol + + isclose = abs(value1 - value2) <= max(rtol_ * max(abs(value1), abs(value2)), atol_) + + end function is_close_elem_real32 + + + elemental function is_close_elem_real64(value1, value2, rtol, atol) result(isclose) + + !> First value to check + real(r64), intent(in) :: value1 + + !> Second value to check + real(r64), intent(in) :: value2 + + !> Relative tolerance for the comparison (default: 1e-10) + real(r64), optional, intent(in) :: rtol + + !> Absolute tolerance for the comparison (default: 0.0) + real(r64), optional, intent(in) :: atol + + !> Whether the two values are close to each other + logical :: isclose + + real(r64), parameter :: atoldef = 0.0_r64, rtoldef = 1e-10_r64 + real(r64) :: rtol_, atol_ + + atol_ = atoldef + if (present(atol)) atol_ = atol + rtol_ = rtoldef + if (present(rtol)) rtol_ = rtol + + isclose = abs(value1 - value2) <= max(rtol_ * max(abs(value1), abs(value2)), atol_) + + end function is_close_elem_real64 + +end module fortuno_checkfuncs diff --git a/src/fortuno/cmdapp.f90 b/src/fortuno/cmdapp.f90 index b6ca0a1..cc4f3e9 100644 --- a/src/fortuno/cmdapp.f90 +++ b/src/fortuno/cmdapp.f90 @@ -7,7 +7,7 @@ module fortuno_cmdapp use fortuno_argumentparser, only : argtypes, argument_def, argument_values, argument_parser,& & init_argument_parser use fortuno_basetypes, only : test_list - use fortuno_utils, only : string + use fortuno_utils, only : string_item use fortuno_testdriver, only : test_driver, test_selection use fortuno_testlogger, only : test_logger implicit none @@ -87,7 +87,7 @@ subroutine cmd_app_register_tests(this, testitems, exitcode) integer, intent(out) :: exitcode type(test_selection), allocatable :: selections(:) - type(string), allocatable :: selectors(:), testnames(:) + type(string_item), allocatable :: selectors(:), testnames(:) integer :: itest exitcode = -1 @@ -100,7 +100,7 @@ subroutine cmd_app_register_tests(this, testitems, exitcode) if (this%argvals%has("list")) then call this%driver%get_test_names(testnames) do itest = 1, size(testnames) - call this%logger%log_message(testnames(itest)%content) + call this%logger%log_message(testnames(itest)%value) end do exitcode = 0 return @@ -132,7 +132,7 @@ end subroutine cmd_app_run_tests subroutine get_selections(selectors, selections) !> Selector expressions - type(string), intent(in) :: selectors(:) + type(string_item), intent(in) :: selectors(:) !> Array of selections on exit type(test_selection), allocatable, intent(out) :: selections(:) @@ -141,7 +141,7 @@ subroutine get_selections(selectors, selections) allocate(selections(size(selectors))) do ii = 1, size(selectors) - associate(selector => selectors(ii)%content, selection => selections(ii)) + associate(selector => selectors(ii)%value, selection => selections(ii)) if (selector(1:1) == "~") then selection%name = selector(2:) selection%selectiontype = "-" diff --git a/src/fortuno/consolelogger.f90 b/src/fortuno/consolelogger.f90 index 6d6e63e..debcd96 100644 --- a/src/fortuno/consolelogger.f90 +++ b/src/fortuno/consolelogger.f90 @@ -4,9 +4,10 @@ !> Contains the implementation of the test logger for logging on the console module fortuno_consolelogger + use fortuno_env, only : ansicolors, stderr, stdout use fortuno_testinfo, only : drive_result, failure_info, test_result, teststatus use fortuno_testlogger, only : test_logger - use fortuno_utils, only : ansicolors, as_char, stderr, stdout + use fortuno_utils, only : str implicit none private @@ -90,9 +91,9 @@ subroutine console_logger_get_failure_info_repr(this, failureinfo, location, mes !> Details string (unallocated if not available or not relevant) character(:), allocatable, intent(out) :: details - location = failureinfo%location%as_char() + location = failureinfo%location%as_string() if (allocated(failureinfo%message)) message = failureinfo%message - if (allocated(failureinfo%details)) details = failureinfo%details%as_char() + if (allocated(failureinfo%details)) details = failureinfo%details%as_string() end subroutine console_logger_get_failure_info_repr @@ -206,7 +207,7 @@ subroutine console_logger_log_drive_result(this, driveresult) if (.not. this%is_active()) return maxitems = maxval([sum(driveresult%suitestats, dim=1), sum(driveresult%teststats)]) - numfieldwidth = len(as_char(maxitems)) + numfieldwidth = len(str(maxitems)) call log_summary_("# Suite set-ups", driveresult%suiteresults(1, :),& & driveresult%suitestats(:, 1), numfieldwidth) call log_summary_("# Suite tear-downs", driveresult%suiteresults(2, :),& @@ -358,7 +359,7 @@ recursive subroutine write_failure_info_(this, failureinfo) if (this%is_active()) then if (allocated(location)) write(stdout, "(a)") location if (allocated(message)) write(stdout, "(2a)") "Msg: ", message - if (allocated(details)) write(stdout, "(a, /, a)") "::", details + if (allocated(details)) write(stdout, "(a)") details end if end subroutine write_failure_info_ @@ -383,7 +384,7 @@ subroutine log_summary_(header, testresults, teststats, numfieldwidth) nignored = teststats(teststatus%ignored) ntotal2 = ntotal - nskipped - numfieldwidthstr = as_char(numfieldwidth) + numfieldwidthstr = str(numfieldwidth) formatstr1 = "(a, 2x, i" // numfieldwidthstr // ")" formatstr2 = "(a, 2x, i" // numfieldwidthstr // ", 1x, a, f5.1, a)" diff --git a/src/fortuno/env.f90 b/src/fortuno/env.f90 new file mode 100644 index 0000000..31b9b3e --- /dev/null +++ b/src/fortuno/env.f90 @@ -0,0 +1,40 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Various helper utilities for the different modules +module fortuno_env + use iso_fortran_env, only : stderr => error_unit, stdout => output_unit, i32 => int32,& + & i64 => int64, r32 => real32, r64 => real64 + implicit none + + private + public :: stderr, stdout + public :: r32, r64, i32, i64 + public :: ansicolors + public :: nl + + + !! Helper type for listing ansi terminal colors + type :: ansi_colors_enum_ + character(4) :: default = char(27) // "[0m" + character(5) :: red = char(27) // "[31m" + character(5) :: green = char(27) // "[32m" + character(5) :: yellow = char(27) // "[33m" + character(5) :: blue = char(27) // "[34m" + character(5) :: magenta = char(27) // "[35m" + character(5) :: cyan = char(27) // "[36m" + character(5) :: white = char(27) // "[37m" + end type ansi_colors_enum_ + + !> Contains a list of ansi colors to use in Fortuno + !! + !! Supports currently (default, red, green, yellow, magenta, cyan and white) + !! + type(ansi_colors_enum_), parameter :: ansicolors = ansi_colors_enum_() + + + !> New line character + character(*), parameter :: nl = new_line("") + +end module fortuno_env diff --git a/src/fortuno/meson.build b/src/fortuno/meson.build index df6e17e..325f347 100644 --- a/src/fortuno/meson.build +++ b/src/fortuno/meson.build @@ -7,8 +7,10 @@ fortuno_sources += files( 'basetypes.f90', 'chartypes.f90', 'checkers.f90', + 'checkfuncs.f90', 'cmdapp.f90', 'consolelogger.f90', + 'env.f90', 'testcontext.f90', 'testdriver.f90', 'testinfo.f90', @@ -16,3 +18,5 @@ fortuno_sources += files( 'utils.f90', 'version.f90', ) + +subdir('checkers') \ No newline at end of file diff --git a/src/fortuno/testcontext.f90 b/src/fortuno/testcontext.f90 index c3524a3..e1402d5 100644 --- a/src/fortuno/testcontext.f90 +++ b/src/fortuno/testcontext.f90 @@ -5,7 +5,7 @@ !> Contains the base context definition module fortuno_testcontext use fortuno_basetypes, only : test_base, test_ptr_item - use fortuno_chartypes, only : char_rep + use fortuno_chartypes, only : stringable use fortuno_testinfo, only : check_result, failure_info, failure_location, init_failure_location,& & teststatus implicit none @@ -25,7 +25,7 @@ module fortuno_testcontext type(failure_info), allocatable :: failureinfo_ !> Info about the internal state of the test - class(char_rep), allocatable :: state_ + class(stringable), allocatable :: state_ !> Status of the context integer :: status_ = teststatus%succeeded @@ -325,7 +325,7 @@ subroutine test_context_store_state(this, state) class(test_context), intent(inout) :: this !> Arbitrary (character representable) state object - class(char_rep), intent(in) :: state + class(stringable), intent(in) :: state this%state_ = state @@ -339,7 +339,7 @@ subroutine test_context_pop_state(this, state) class(test_context), intent(inout) :: this !> Popped state object - class(char_rep), allocatable, intent(out) :: state + class(stringable), allocatable, intent(out) :: state if (allocated(this%state_)) call move_alloc(this%state_, state) diff --git a/src/fortuno/testdriver.f90 b/src/fortuno/testdriver.f90 index 35c794c..8c2e513 100644 --- a/src/fortuno/testdriver.f90 +++ b/src/fortuno/testdriver.f90 @@ -5,11 +5,11 @@ !> Implements a generic test driver module fortuno_testdriver use fortuno_basetypes, only : test_base, test_case_base, test_list, test_suite_base - use fortuno_chartypes, only : char_rep + use fortuno_chartypes, only : stringable use fortuno_testcontext, only : context_factory, test_context use fortuno_testinfo, only : drive_result, init_drive_result, test_result, teststatus use fortuno_testlogger, only : test_logger, testtypes - use fortuno_utils, only : basename, string + use fortuno_utils, only : basename, string_item implicit none private @@ -250,14 +250,14 @@ subroutine test_driver_get_test_names(this, testnames) class(test_driver), intent(in) :: this !> Name of all tests - type(string), allocatable :: testnames(:) + type(string_item), allocatable :: testnames(:) integer :: nselect, iselect nselect = size(this%testselection%fwd) allocate(testnames(nselect)) do iselect = 1, nselect - testnames(iselect)%content = this%testdatacont%items(this%testselection%fwd(iselect))%ptr%name + testnames(iselect)%value = this%testdatacont%items(this%testselection%fwd(iselect))%ptr%name end do end subroutine test_driver_get_test_names @@ -477,7 +477,7 @@ recursive subroutine run_test_(testlist, identifier, ctx, runner, repr) character(:), allocatable, intent(out) :: repr class(test_base), pointer :: scopeptr, item - class(char_rep), allocatable :: state + class(stringable), allocatable :: state scopeptr => testlist%view(identifier(1)) call ctx%push_scope_ptr(scopeptr) @@ -487,7 +487,7 @@ recursive subroutine run_test_(testlist, identifier, ctx, runner, repr) class is (test_case_base) call runner%run_test(item, ctx) call ctx%pop_state(state) - if (allocated(state)) repr = state%as_char() + if (allocated(state)) repr = state%as_string() class default error stop "Internal error, unexpected test type in run_test_" end select @@ -514,7 +514,7 @@ recursive subroutine initialize_finalize_suite_(testlist, identifier, init, ctx, character(:), allocatable, intent(out) :: repr class(test_base), pointer :: scopeptr, item - class(char_rep), allocatable :: state + class(stringable), allocatable :: state scopeptr => testlist%view(identifier(1)) call ctx%push_scope_ptr(scopeptr) @@ -525,7 +525,7 @@ recursive subroutine initialize_finalize_suite_(testlist, identifier, init, ctx, if (init) then call runner%set_up_suite(item, ctx) call ctx%pop_state(state) - if (allocated(state)) repr = state%as_char() + if (allocated(state)) repr = state%as_string() else call runner%tear_down_suite(item, ctx) end if @@ -557,7 +557,7 @@ subroutine set_repr_name_(testresults, ind, repr, dependencyresults) associate (testresult => testresults(ind)) name = basename(testresult%name) - if (allocated(repr)) name = name // "{" // repr // "}" + if (allocated(repr)) name = name // " {" // repr // "}" if (size(testresult%dependencies) > 0) then testresult%reprname = depresults(testresult%dependencies(1))%reprname // "/" // name else diff --git a/src/fortuno/testinfo.f90 b/src/fortuno/testinfo.f90 index 0e4c0ec..53afb13 100644 --- a/src/fortuno/testinfo.f90 +++ b/src/fortuno/testinfo.f90 @@ -4,8 +4,8 @@ !> Types containing informations about tests and checks module fortuno_testinfo - use fortuno_chartypes, only : char_rep - use fortuno_utils, only : as_char + use fortuno_chartypes, only : stringable + use fortuno_utils, only : str implicit none private @@ -45,7 +45,7 @@ module fortuno_testinfo logical :: success = .false. !> Further character representable information about the check (reason of failure) - class(char_rep), allocatable :: details + class(stringable), allocatable :: details end type check_result @@ -63,7 +63,7 @@ module fortuno_testinfo integer :: checknr = 0 contains - procedure :: as_char => failure_location_as_char + procedure :: as_string => failure_location_as_string end type failure_location @@ -77,7 +77,7 @@ module fortuno_testinfo class(failure_location), allocatable :: location !> Character representable internal details of the check - class(char_rep), allocatable :: details + class(stringable), allocatable :: details !> Contains previous failure_info (to be able to chain check infos) type(failure_info), allocatable :: previous @@ -156,7 +156,7 @@ end subroutine init_failure_location !> Character representation of the failure location - function failure_location_as_char(this) result(repr) + function failure_location_as_string(this) result(repr) !> Instance class(failure_location), intent(in) :: this @@ -167,17 +167,17 @@ function failure_location_as_char(this) result(repr) if (allocated(this%file)) then repr = "File: " // this%file if (this%line /= 0) then - repr = repr // " (line " // as_char(this%line) // ")" + repr = repr // " (line " // str(this%line) // ")" else if (this%checknr /= 0) then - repr = repr // " (check " // as_char(this%checknr) // ")" + repr = repr // " (check " // str(this%checknr) // ")" end if else if (this%checknr /= 0) then - repr = "Check: " // as_char(this%checknr) + repr = "Check: " // str(this%checknr) else repr = "" end if - end function failure_location_as_char + end function failure_location_as_string !> Initializes the fields of an drive result instance diff --git a/src/fortuno/utils.f90 b/src/fortuno/utils.f90 index 0dc4500..c980743 100644 --- a/src/fortuno/utils.f90 +++ b/src/fortuno/utils.f90 @@ -4,80 +4,217 @@ !> Various helper utilities for the different modules module fortuno_utils - use iso_fortran_env, only : stderr => error_unit, stdout => output_unit + use fortuno_env, only : r32, r64, i32, i64 implicit none private - public :: ansicolors - public :: as_char + public :: str public :: basename - public :: nl - public :: stderr, stdout - public :: string, string_list - public :: as_upper - - !> New line character - character(*), parameter :: nl = new_line("") - - !! Helper type for listing ansi terminal colors - type :: ansi_colors_enum_ - character(4) :: default = char(27) // "[0m" - character(5) :: red = char(27) // "[31m" - character(5) :: green = char(27) // "[32m" - character(5) :: yellow = char(27) // "[33m" - character(5) :: blue = char(27) // "[34m" - character(5) :: magenta = char(27) // "[35m" - character(5) :: cyan = char(27) // "[36m" - character(5) :: white = char(27) // "[37m" - end type ansi_colors_enum_ - - !> Contains a list of ansi colors to use in Fortuno - !! - !! Supports currently (default, red, green, yellow, magenta, cyan and white) - !! - type(ansi_colors_enum_), parameter :: ansicolors = ansi_colors_enum_() - - - interface as_char - module procedure integer_as_char - end interface as_char + public :: upper + public :: string_item, string_item_list + + + interface str + module procedure str_int32 + module procedure str_int32_r1 + module procedure str_int64 + module procedure str_int64_r1 + module procedure str_real32 + module procedure str_real64 + module procedure str_logical + end interface str !> Minimalistic string type - type :: string + type :: string_item !> Actual content of the string - character(:), allocatable :: content + character(:), allocatable :: value - end type string + end type string_item !> Minimalistic string list type - type :: string_list + type :: string_item_list !> Actual items in the list - type(string), allocatable :: items(:) + type(string_item), allocatable :: items(:) - end type string_list + end type string_item_list contains + + !> Returns the character representation of an integer value + pure function str_int32(val) result(repr) + + !> Integer value to represent + integer(i32), intent(in) :: val + + !> Character representation + character(:), allocatable :: repr + + character(11) :: buffer + + write(buffer, "(i11)") val + repr = trim(adjustl(buffer)) + + end function str_int32 + + + !> Returns the character representation of an integer rank 1 array. + pure function str_int32_r1(val) result(repr) + + !> Integer array to represent + integer(i32), intent(in) :: val(:) + + !> Character representation + character(:), allocatable :: repr + + character(*), parameter :: separator = ", " + type(string_item) :: reps(size(val)) + integer :: replens(size(val)) + integer :: ii, nn, replen, pos + + if (size(val) == 0) then + repr = "[]" + return + end if + + nn = size(val) + do ii = 1, nn + reps(ii)%value = str(val(ii)) + replens(ii) = len(reps(ii)%value) + end do + + ! take delimiting braces and ", " separator into account + replen = sum(replens) + 2 + (nn - 1) * len(separator) + allocate(character(replen) :: repr) + repr(1:1) = "[" + pos = 2 + do ii = 1, nn + repr(pos : pos + replens(ii) - 1) = reps(ii)%value + pos = pos + replens(ii) + if (ii /= nn) then + repr(pos : pos + len(separator) - 1) = separator + pos = pos + len(separator) + end if + end do + repr(pos:pos) = "]" + + end function str_int32_r1 + + + !> Returns the character representation of an integer value + pure function str_int64(val) result(repr) + + !> Integer value to represent + integer(i64), intent(in) :: val + + !> Character representation + character(:), allocatable :: repr + + character(20) :: buffer + + write(buffer, "(i20)") val + repr = trim(adjustl(buffer)) + + end function str_int64 + + + !> Returns the character representation of an integer rank 1 array. + pure function str_int64_r1(val) result(repr) + + !> Integer array to represent + integer(i64), intent(in) :: val(:) + + !> Character representation + character(:), allocatable :: repr + + character(*), parameter :: separator = ", " + type(string_item) :: reps(size(val)) + integer :: replens(size(val)) + integer :: ii, nn, replen, pos + + if (size(val) == 0) then + repr = "[]" + return + end if + + nn = size(val) + do ii = 1, nn + reps(ii)%value = str(val(ii)) + replens(ii) = len(reps(ii)%value) + end do + + ! take delimiting braces and ", " separator into account + replen = sum(replens) + 2 + (nn - 1) * len(separator) + allocate(character(replen) :: repr) + repr(1:1) = "[" + pos = 2 + do ii = 1, nn + repr(pos : pos + replens(ii) - 1) = reps(ii)%value + pos = pos + replens(ii) + if (ii /= nn) then + repr(pos : pos + len(separator) - 1) = separator + pos = pos + len(separator) + end if + end do + repr(pos:pos) = "]" + + end function str_int64_r1 + + !> Returns the character representation of an integer value - pure function integer_as_char(val) result(repr) + pure function str_real32(val) result(repr) !> Integer value to represent - integer, intent(in) :: val + real(r32), intent(in) :: val !> Character representation character(:), allocatable :: repr - ! should be enough to represent up to 128 bit integers with sign - character(40) :: buffer + character(16) :: buffer + + write(buffer, "(g16.7)") val + repr = trim(adjustl(buffer)) + + end function str_real32 + - write(buffer, "(i0)") val + !> Returns the character representation of an integer value + pure function str_real64(val) result(repr) + + !> Integer value to represent + real(r64), intent(in) :: val + + !> Character representation + character(:), allocatable :: repr + + character(26) :: buffer + + write(buffer, "(g26.16)") val repr = trim(buffer) - end function integer_as_char + end function str_real64 + + + !> Returns the character representation of an integer value + pure function str_logical(val) result(repr) + + !> Integer value to represent + logical, intent(in) :: val + + !> Character representation + character(:), allocatable :: repr + + if (val) then + repr = "T" + else + repr = "F" + end if + + end function str_logical !> Returns the last component (base name) of a slash ("/") separated path @@ -98,7 +235,7 @@ end function basename !> Converts a string to upper-case. - pure function as_upper(str) result(upperstr) + pure function upper(str) result(upperstr) !> String to convert character(*), intent(in) :: str @@ -121,6 +258,6 @@ pure function as_upper(str) result(upperstr) end if end do - end function as_upper + end function upper end module fortuno_utils \ No newline at end of file diff --git a/src/fortuno/version.f90 b/src/fortuno/version.f90 index 3b05ace..cba1a81 100644 --- a/src/fortuno/version.f90 +++ b/src/fortuno/version.f90 @@ -4,7 +4,7 @@ !> Contains version information module fortuno_version - use fortuno_utils, only : as_char + use fortuno_utils, only : str implicit none private @@ -22,8 +22,8 @@ function version_string() result(versionstr) !> Character representation of the version character(:), allocatable :: versionstr - versionstr = as_char(versions(1)) // "." // as_char(versions(2)) - if (versions(3) /= 0) versionstr = versionstr // "." // as_char(versions(3)) + versionstr = str(versions(1)) // "." // str(versions(2)) + if (versions(3) /= 0) versionstr = versionstr // "." // str(versions(3)) end function version_string diff --git a/src/fortuno_coarray/coaconlogger.f90 b/src/fortuno_coarray/coaconlogger.f90 index 1dd1292..3fc1ffb 100644 --- a/src/fortuno_coarray/coaconlogger.f90 +++ b/src/fortuno_coarray/coaconlogger.f90 @@ -4,7 +4,7 @@ !> Contains the implementation of the test logger for the coarray driver module fortuno_coarray_coaconlogger - use fortuno, only : as_char, console_logger, failure_info, nl + use fortuno, only : str, console_logger, failure_info, nl use fortuno_coarray_coaenv, only : coa_env use fortuno_coarray_coatestinfo, only : coa_failure_location implicit none @@ -60,7 +60,7 @@ subroutine coa_console_logger_start_drive(this) if (.not. this%is_active()) return call this%console_logger%start_drive() - call this%log_message(nl // "Nr. of images: " // as_char(this%coaenv%nimages)) + call this%log_message(nl // "Nr. of images: " // str(this%coaenv%nimages)) end subroutine coa_console_logger_start_drive @@ -95,10 +95,10 @@ subroutine coa_console_logger_get_failure_info_repr(this, failureinfo, location, end select if (this%coaenv%image == failedimages(1)) then - location = failureinfo%location%as_char() + location = failureinfo%location%as_string() if (len(location) == 0) deallocate(location) if (allocated(failureinfo%message)) message = failureinfo%message - if (allocated(failureinfo%details)) details = failureinfo%details%as_char() + if (allocated(failureinfo%details)) details = failureinfo%details%as_string() end if call this%coaenv%broadcast_alloc_char(location, failedimages(1)) call this%coaenv%broadcast_alloc_char(message, failedimages(1)) diff --git a/src/fortuno_coarray/coatestinfo.f90 b/src/fortuno_coarray/coatestinfo.f90 index 9a27dbf..142cc49 100644 --- a/src/fortuno_coarray/coatestinfo.f90 +++ b/src/fortuno_coarray/coatestinfo.f90 @@ -4,7 +4,7 @@ !> Contains the coarray-extensions of test info structures module fortuno_coarray_coatestinfo - use fortuno, only : as_char, init_failure_location, failure_location, nl + use fortuno, only : str, init_failure_location, failure_location, nl implicit none private @@ -18,7 +18,7 @@ module fortuno_coarray_coatestinfo integer, allocatable :: failedimages(:) contains - procedure :: as_char => coa_failure_location_as_char + procedure :: str => coa_failure_location_str end type coa_failure_location contains @@ -49,7 +49,7 @@ end subroutine init_coa_failure_location !> Character representation of the failure location - function coa_failure_location_as_char(this) result(repr) + function coa_failure_location_str(this) result(repr) !> Instance class(coa_failure_location), intent(in) :: this @@ -59,17 +59,17 @@ function coa_failure_location_as_char(this) result(repr) integer :: firstfailed, totalfailed - repr = this%failure_location%as_char() + repr = this%failure_location%as_string() if (.not. allocated(this%failedimages)) return firstfailed = this%failedimages(1) totalfailed = size(this%failedimages) if (totalfailed > 1) then - repr = "Image: " // as_char(firstfailed) // " (+ " // as_char(totalfailed - 1) // " more)"& + repr = "Image: " // str(firstfailed) // " (+ " // str(totalfailed - 1) // " more)"& & // nl // repr else - repr = "Image: " // as_char(firstfailed) // nl // repr + repr = "Image: " // str(firstfailed) // nl // repr end if - end function coa_failure_location_as_char + end function coa_failure_location_str end module fortuno_coarray_coatestinfo diff --git a/src/fortuno_mpi/mpiconlogger.f90 b/src/fortuno_mpi/mpiconlogger.f90 index fbcc9de..562816c 100644 --- a/src/fortuno_mpi/mpiconlogger.f90 +++ b/src/fortuno_mpi/mpiconlogger.f90 @@ -4,7 +4,7 @@ !> Contains the implementation of the test logger for the mpi driver module fortuno_mpi_mpiconlogger - use fortuno, only : as_char, console_logger, failure_info, nl + use fortuno, only : str, console_logger, failure_info, nl use fortuno_mpi_mpienv, only : mpi_env use fortuno_mpi_mpitestinfo, only : mpi_failure_location implicit none @@ -60,7 +60,7 @@ subroutine mpi_console_logger_start_drive(this) if (.not. this%is_active()) return call this%console_logger%start_drive() - call this%log_message(nl // "Nr. of ranks: " // as_char(this%mpienv%nranks)) + call this%log_message(nl // "Nr. of ranks: " // str(this%mpienv%nranks)) end subroutine mpi_console_logger_start_drive @@ -96,22 +96,22 @@ subroutine mpi_console_logger_get_failure_info_repr(this, failureinfo, location, if (failedranks(1) == 0) then if (this%mpienv%rank == 0) then - buffer = failureinfo%location%as_char() + buffer = failureinfo%location%as_string() if (len(buffer) > 0) call move_alloc(buffer, location) if (allocated(failureinfo%message)) message = failureinfo%message - if (allocated(failureinfo%details)) details = failureinfo%details%as_char() + if (allocated(failureinfo%details)) details = failureinfo%details%as_string() end if else if (this%mpienv%rank == 0) then call this%mpienv%recv_alloc_char(location, failedranks(1)) call this%mpienv%recv_alloc_char(message, failedranks(1)) call this%mpienv%recv_alloc_char(details, failedranks(1)) else if (this%mpienv%rank == failedranks(1)) then - buffer = failureinfo%location%as_char() + buffer = failureinfo%location%as_string() if (len(buffer) == 0) deallocate(buffer) call this%mpienv%send_alloc_char(buffer, 0) call this%mpienv%send_alloc_char(failureinfo%message, 0) if (allocated(buffer)) deallocate(buffer) - if (allocated(failureinfo%details)) buffer = failureinfo%details%as_char() + if (allocated(failureinfo%details)) buffer = failureinfo%details%as_string() call this%mpienv%send_alloc_char(buffer, 0) end if diff --git a/src/fortuno_mpi/mpitestinfo.f90 b/src/fortuno_mpi/mpitestinfo.f90 index 52d9227..18fdcd0 100644 --- a/src/fortuno_mpi/mpitestinfo.f90 +++ b/src/fortuno_mpi/mpitestinfo.f90 @@ -4,7 +4,7 @@ !> Contains the MPI-extensions of test info structures module fortuno_mpi_mpitestinfo - use fortuno, only : as_char, init_failure_location, failure_location, nl + use fortuno, only : str, init_failure_location, failure_location, nl implicit none private @@ -18,7 +18,7 @@ module fortuno_mpi_mpitestinfo integer, allocatable :: failedranks(:) contains - procedure :: as_char => mpi_failure_location_as_char + procedure :: str => mpi_failure_location_str end type mpi_failure_location contains @@ -49,7 +49,7 @@ end subroutine init_mpi_failure_location !> Character representation of the failure location - function mpi_failure_location_as_char(this) result(repr) + function mpi_failure_location_str(this) result(repr) !> Instance class(mpi_failure_location), intent(in) :: this @@ -59,17 +59,17 @@ function mpi_failure_location_as_char(this) result(repr) integer :: firstfailed, totalfailed - repr = this%failure_location%as_char() + repr = this%failure_location%as_string() if (.not. allocated(this%failedranks)) return firstfailed = this%failedranks(1) totalfailed = size(this%failedranks) if (totalfailed > 1) then - repr = "Rank: " // as_char(firstfailed) // " (+ " // as_char(totalfailed - 1) // " more)"& + repr = "Rank: " // str(firstfailed) // " (+ " // str(totalfailed - 1) // " more)"& & // nl // repr else - repr = "Rank: " // as_char(firstfailed) // nl // repr + repr = "Rank: " // str(firstfailed) // nl // repr end if - end function mpi_failure_location_as_char + end function mpi_failure_location_str end module fortuno_mpi_mpitestinfo diff --git a/src/fortuno_serial/serialglobalctx.f90 b/src/fortuno_serial/serialglobalctx.f90 index 4b87558..37ad834 100644 --- a/src/fortuno_serial/serialglobalctx.f90 +++ b/src/fortuno_serial/serialglobalctx.f90 @@ -4,7 +4,7 @@ !> Global serial context to avoid explicit passing of context when using non-threaded serial driver module fortuno_serial_serialglobalctx - use fortuno, only : check_result, char_rep, test_ptr_item + use fortuno, only : check_result, stringable, test_ptr_item use fortuno_serial_serialcontext, only : serial_context implicit none @@ -126,7 +126,7 @@ end function serial_scope_pointers subroutine serial_store_state(state) !> State to store - class(char_rep), intent(in) :: state + class(stringable), intent(in) :: state call serialglobalctx%store_state(state) diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt new file mode 100644 index 0000000..a5c5472 --- /dev/null +++ b/test/CMakeLists.txt @@ -0,0 +1,7 @@ +# This file is part of Fortuno. +# Licensed under the BSD-2-Clause Plus Patent license. +# SPDX-License-Identifier: BSD-2-Clause-Patent + +list(APPEND CMAKE_MESSAGE_CONTEXT Test) + +add_subdirectory(unit) diff --git a/test/unit/CMakeLists.txt b/test/unit/CMakeLists.txt new file mode 100644 index 0000000..488a00c --- /dev/null +++ b/test/unit/CMakeLists.txt @@ -0,0 +1,18 @@ +# This file is part of Fortuno. +# Licensed under the BSD-2-Clause Plus Patent license. +# SPDX-License-Identifier: BSD-2-Clause-Patent + +list(APPEND CMAKE_MESSAGE_CONTEXT Unit) + +add_executable(fortuno_test_unit_testapp) +set_target_properties( + fortuno_test_unit_testapp PROPERTIES + OUTPUT_NAME testapp +) +target_sources( + fortuno_test_unit_testapp PRIVATE + test_checkers.f90 + testapp.f90 +) +target_link_libraries(fortuno_test_unit_testapp PRIVATE Fortuno::fortuno_serial) +add_test(NAME unit COMMAND testapp) diff --git a/test/unit/test_checkers.f90 b/test/unit/test_checkers.f90 new file mode 100644 index 0000000..7ec4a25 --- /dev/null +++ b/test/unit/test_checkers.f90 @@ -0,0 +1,836 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +module test_checkers + use iso_fortran_env, only : i32 => int32, i64 => int64, r32 => real32 + use fortuno_checkers, only : all_close, all_equal, is_close, is_equal + use fortuno_serial, only : check_result, details_dict, get_ptr_to, matches_type_value,& + & test => serial_case_item, check => serial_check, failed => serial_failed,& + & suite => serial_suite_item, test_list + implicit none + + private + public :: tests + + character(*), parameter :: mismatch_shape_msg_ = "mismatching array shapes" + character(*), parameter :: mismatch_value_msg_int_ = "mismatching integer values" + character(*), parameter :: mismatch_value_msg_real_ = "real values differing beyond tolerance" + +contains + + + subroutine test_equal_i32_i32_success() + integer(i32), parameter :: value1 = 9, value2 = 9 + type(check_result) :: res + + res = is_equal(value1, value2) + call check(res%success) + call check(.not. allocated(res%details)) + + end subroutine test_equal_i32_i32_success + + + subroutine test_equal_i32_i32_mismatch() + integer(i32), parameter :: value1 = 7, value2 = 9 + type(check_result), target :: res + type(details_dict), pointer :: pdict + + res = is_equal(value1, value2) + + call check(.not. res%success) + call check(allocated(res%details)) + if (failed()) return + + call get_ptr_to(res%details, pdict) + call check(associated(pdict)) + if (failed()) return + + call check(size(pdict%items) == 3) + if (failed()) return + + call check(pdict%items(1)%name == "failure") + call check(matches_type_value(pdict%items(1)%value, mismatch_value_msg_int_)) + + call check(pdict%items(2)%name == "value1") + call check(matches_type_value(pdict%items(2)%value, value1)) + + call check(pdict%items(3)%name == "value2") + call check(matches_type_value(pdict%items(3)%value, value2)) + + end subroutine test_equal_i32_i32_mismatch + + + subroutine test_equal_i32r1_i32r1_success() + integer(i32), parameter :: value1(2) = [1, 2], value2(2) = [1, 2] + type(check_result) :: res + + res = all_equal(value1, value2) + call check(res%success) + call check(.not. allocated(res%details)) + + end subroutine test_equal_i32r1_i32r1_success + + + subroutine test_equal_i32r1_i32r1_mismatch_shape() + integer(i32), parameter :: value1(2) = [3, 4], value2(3) = [3, 4, -1] + type(check_result), target :: res + type(details_dict), pointer :: pdict + + res = all_equal(value1, value2) + + call check(.not. res%success) + call check(allocated(res%details)) + if (failed()) return + + call get_ptr_to(res%details, pdict) + call check(associated(pdict)) + if (failed()) return + + call check(size(pdict%items) == 3) + if (failed()) return + + call check(pdict%items(1)%name == "failure") + call check(matches_type_value(pdict%items(1)%value, mismatch_shape_msg_)) + + call check(pdict%items(2)%name == "shape1") + call check(matches_type_value(pdict%items(2)%value, shape(value1, kind=i64))) + + call check(pdict%items(3)%name == "shape2") + call check(matches_type_value(pdict%items(3)%value, shape(value2, kind=i64))) + + end subroutine test_equal_i32r1_i32r1_mismatch_shape + + + subroutine test_equal_i32r1_i32r1_mismatch_value() + integer(i32), parameter :: value1(2) = [3, 4], value2(2) = [3, -4] + integer(i64), parameter :: mismatchloc(1) = [2] + type(check_result), target :: res + type(details_dict), pointer :: pdict + + res = all_equal(value1, value2) + + call check(.not. res%success) + call check(allocated(res%details)) + if (failed()) return + + call get_ptr_to(res%details, pdict) + call check(associated(pdict)) + if (failed()) return + + call check(size(pdict%items) == 4) + if (failed()) return + + call check(pdict%items(1)%name == "failure") + call check(matches_type_value(pdict%items(1)%value, mismatch_value_msg_int_)) + + call check(pdict%items(2)%name == "location") + call check(matches_type_value(pdict%items(2)%value, mismatchloc)) + + call check(pdict%items(3)%name == "value1") + call check(matches_type_value(pdict%items(3)%value, value1(mismatchloc(1)))) + + call check(pdict%items(4)%name == "value2") + call check(matches_type_value(pdict%items(4)%value, value2(mismatchloc(1)))) + + end subroutine test_equal_i32r1_i32r1_mismatch_value + + + subroutine test_equal_i32r2_i32r2_success() + integer(i32), parameter :: value1(2, 2) = reshape([1, 2, 3, 4], [2, 2]) + integer(i32), parameter :: value2(2, 2) = value1 + type(check_result) :: res + + res = all_equal(value1, value2) + call check(res%success) + call check(.not. allocated(res%details)) + + end subroutine test_equal_i32r2_i32r2_success + + + subroutine test_equal_i32r2_i32r2_mismatch_shape() + integer(i32), parameter :: value1(2, 2) = reshape([1, 2, 3, 4], [2, 2]) + integer(i32), parameter :: value2(2, 3) = reshape([1, 2, 3, 4, 5, 6], [2, 3]) + type(check_result), target :: res + type(details_dict), pointer :: pdict + + res = all_equal(value1, value2) + + call check(.not. res%success) + call check(allocated(res%details)) + if (failed()) return + + call get_ptr_to(res%details, pdict) + call check(associated(pdict)) + if (failed()) return + + call check(size(pdict%items) == 3) + if (failed()) return + + call check(pdict%items(1)%name == "failure") + call check(matches_type_value(pdict%items(1)%value, mismatch_shape_msg_)) + + call check(pdict%items(2)%name == "shape1") + call check(matches_type_value(pdict%items(2)%value, shape(value1, kind=i64))) + + call check(pdict%items(3)%name == "shape2") + call check(matches_type_value(pdict%items(3)%value, shape(value2, kind=i64))) + + end subroutine test_equal_i32r2_i32r2_mismatch_shape + + + subroutine test_equal_i32r2_i32r2_mismatch_value() + integer(i32), parameter :: value1(2, 2) = reshape([1, 2, 3, 4], [2, 2]) + integer(i32), parameter :: value2(2, 2) = reshape([1, 2, -3, 4], [2, 2]) + integer(i64), parameter :: mismatchloc(2) = [1, 2] + type(check_result), target :: res + type(details_dict), pointer :: pdict + + res = all_equal(value1, value2) + + call check(.not. res%success) + call check(allocated(res%details)) + if (failed()) return + + call get_ptr_to(res%details, pdict) + call check(associated(pdict)) + if (failed()) return + + call check(size(pdict%items) == 4) + if (failed()) return + + call check(pdict%items(1)%name == "failure") + call check(matches_type_value(pdict%items(1)%value, mismatch_value_msg_int_)) + + call check(pdict%items(2)%name == "location") + call check(matches_type_value(pdict%items(2)%value, mismatchloc)) + + call check(pdict%items(3)%name == "value1") + call check(matches_type_value(pdict%items(3)%value, value1(mismatchloc(1), mismatchloc(2)))) + + call check(pdict%items(4)%name == "value2") + call check(matches_type_value(pdict%items(4)%value, value2(mismatchloc(1), mismatchloc(2)))) + + end subroutine test_equal_i32r2_i32r2_mismatch_value + + + subroutine test_equal_i32r1_i32r0_success() + integer(i32), parameter :: value1(2) = [2, 2], value2 = 2 + type(check_result) :: res + + res = all_equal(value1, value2) + call check(res%success) + call check(.not. allocated(res%details)) + + end subroutine test_equal_i32r1_i32r0_success + + + subroutine test_equal_i32r0_i32r1_success() + integer(i32), parameter :: value1 = 2, value2(2) = [2, 2] + type(check_result) :: res + + res = all_equal(value1, value2) + call check(res%success) + call check(.not. allocated(res%details)) + + end subroutine test_equal_i32r0_i32r1_success + + + subroutine test_equal_i32r1_i32r0_mismatch() + integer(i32), parameter :: value1(2) = [3, 4], value2 = 3 + integer(i64), parameter :: mismatchloc(1) = [2] + type(check_result), target :: res + type(details_dict), pointer :: pdict + + res = all_equal(value1, value2) + + call check(.not. res%success) + call check(allocated(res%details)) + if (failed()) return + + call get_ptr_to(res%details, pdict) + call check(associated(pdict)) + if (failed()) return + + call check(size(pdict%items) == 4) + if (failed()) return + + call check(pdict%items(1)%name == "failure") + call check(matches_type_value(pdict%items(1)%value, mismatch_value_msg_int_)) + + call check(pdict%items(2)%name == "location") + call check(matches_type_value(pdict%items(2)%value, mismatchloc)) + + call check(pdict%items(3)%name == "value1") + call check(matches_type_value(pdict%items(3)%value, value1(mismatchloc(1)))) + + call check(pdict%items(4)%name == "value2") + call check(matches_type_value(pdict%items(4)%value, value2)) + + end subroutine test_equal_i32r1_i32r0_mismatch + + + subroutine test_equal_i32r0_i32r1_mismatch + integer(i32), parameter :: value1 = 3, value2(2) = [3, 4] + integer(i64), parameter :: mismatchloc(1) = [2] + type(check_result), target :: res + type(details_dict), pointer :: pdict + + res = all_equal(value1, value2) + + call check(.not. res%success) + call check(allocated(res%details)) + if (failed()) return + + call get_ptr_to(res%details, pdict) + call check(associated(pdict)) + if (failed()) return + + call check(size(pdict%items) == 4) + if (failed()) return + + call check(pdict%items(1)%name == "failure") + call check(matches_type_value(pdict%items(1)%value, mismatch_value_msg_int_)) + + call check(pdict%items(2)%name == "location") + call check(matches_type_value(pdict%items(2)%value, mismatchloc)) + + call check(pdict%items(3)%name == "value1") + call check(matches_type_value(pdict%items(3)%value, value1)) + + call check(pdict%items(4)%name == "value2") + call check(matches_type_value(pdict%items(4)%value, value2(mismatchloc(1)))) + + end subroutine test_equal_i32r0_i32r1_mismatch + + + subroutine test_equal_i32r2_i32r0_success() + integer(i32), parameter :: value1(2, 2) = reshape([9, 9, 9, 9], [2, 2]), value2 = 9 + type(check_result) :: res + + res = all_equal(value1, value2) + call check(res%success) + call check(.not. allocated(res%details)) + + end subroutine test_equal_i32r2_i32r0_success + + + subroutine test_equal_i32r0_i32r2_success() + integer(i32), parameter :: value1 = 9, value2(2, 2) = reshape([9, 9, 9, 9], [2, 2]) + type(check_result) :: res + + res = all_equal(value1, value2) + call check(res%success) + call check(.not. allocated(res%details)) + + end subroutine test_equal_i32r0_i32r2_success + + + subroutine test_equal_i32r2_i32r0_mismatch() + integer(i32), parameter :: value1(2, 2) = reshape([3, 3, 4, 3], [2, 2]), value2 = 3 + integer(i64), parameter :: mismatchloc(2) = [1, 2] + type(check_result), target :: res + type(details_dict), pointer :: pdict + + res = all_equal(value1, value2) + + call check(.not. res%success) + call check(allocated(res%details)) + if (failed()) return + + call get_ptr_to(res%details, pdict) + call check(associated(pdict)) + if (failed()) return + + call check(size(pdict%items) == 4) + if (failed()) return + + call check(pdict%items(1)%name == "failure") + call check(matches_type_value(pdict%items(1)%value, mismatch_value_msg_int_)) + + call check(pdict%items(2)%name == "location") + call check(matches_type_value(pdict%items(2)%value, mismatchloc)) + + call check(pdict%items(3)%name == "value1") + call check(matches_type_value(pdict%items(3)%value, value1(mismatchloc(1), mismatchloc(2)))) + + call check(pdict%items(4)%name == "value2") + call check(matches_type_value(pdict%items(4)%value, value2)) + + end subroutine test_equal_i32r2_i32r0_mismatch + + + subroutine test_equal_i32r0_i32r2_mismatch + integer(i32), parameter :: value1 = 3, value2(2, 2) = reshape([3, 3, 4, 3], [2, 2]) + integer(i64), parameter :: mismatchloc(2) = [1, 2] + type(check_result), target :: res + type(details_dict), pointer :: pdict + + res = all_equal(value1, value2) + + call check(.not. res%success) + call check(allocated(res%details)) + if (failed()) return + + call get_ptr_to(res%details, pdict) + call check(associated(pdict)) + if (failed()) return + + call check(size(pdict%items) == 4) + if (failed()) return + + call check(pdict%items(1)%name == "failure") + call check(matches_type_value(pdict%items(1)%value, mismatch_value_msg_int_)) + + call check(pdict%items(2)%name == "location") + call check(matches_type_value(pdict%items(2)%value, mismatchloc)) + + call check(pdict%items(3)%name == "value1") + call check(matches_type_value(pdict%items(3)%value, value1)) + + call check(pdict%items(4)%name == "value2") + call check(matches_type_value(pdict%items(4)%value, value2(mismatchloc(1), mismatchloc(2)))) + + end subroutine test_equal_i32r0_i32r2_mismatch + + + subroutine test_close_r32_r32_success() + real(r32), parameter :: value1 = 0.1_r32, value2 = value1 + 1.0e-5_r32 + type(check_result) :: res + + res = is_close(value1, value2) + call check(res%success) + call check(.not. allocated(res%details)) + + end subroutine test_close_r32_r32_success + + + subroutine test_close_r32_r32_mismatch() + real(r32), parameter :: value1 = 0.1_r32, value2 = value1 + 1.0e-3_r32 + type(check_result), target :: res + type(details_dict), pointer :: pdict + + res = is_close(value1, value2) + + call check(.not. res%success) + call check(allocated(res%details)) + if (failed()) return + + call get_ptr_to(res%details, pdict) + call check(associated(pdict)) + if (failed()) return + + call check(size(pdict%items) == 3) + if (failed()) return + + call check(pdict%items(1)%name == "failure") + call check(matches_type_value(pdict%items(1)%value, mismatch_value_msg_real_)) + + call check(pdict%items(2)%name == "value1") + call check(matches_type_value(pdict%items(2)%value, value1, rtol=1e-6_r32, atol=1e-6_r32)) + + call check(pdict%items(3)%name == "value2") + call check(matches_type_value(pdict%items(3)%value, value2, rtol=1e-6_r32, atol=1e-6_r32)) + + end subroutine test_close_r32_r32_mismatch + + + subroutine test_close_r32r1_r32r1_success() + real(r32), parameter :: value1(2) = [0.1_r32, 2.2e-12_r32] + real(r32), parameter :: value2(2) = value1 + [1.0e-5_r32, 5e-17_r32] + type(check_result) :: res + + res = all_close(value1, value2) + call check(res%success) + call check(.not. allocated(res%details)) + + end subroutine test_close_r32r1_r32r1_success + + + subroutine test_close_r32r1_r32r1_mismatch_shape() + real(r32), parameter :: value1(2) = [0.1_r32, 2.2e-12_r32] + real(r32), parameter :: value2(1) = [0.1_r32] + type(check_result), target :: res + type(details_dict), pointer :: pdict + + res = all_close(value1, value2) + + call check(.not. res%success) + call check(allocated(res%details)) + if (failed()) return + + call get_ptr_to(res%details, pdict) + call check(associated(pdict)) + if (failed()) return + + call check(size(pdict%items) == 3) + if (failed()) return + + call check(pdict%items(1)%name == "failure") + call check(matches_type_value(pdict%items(1)%value, mismatch_shape_msg_)) + + call check(pdict%items(2)%name == "shape1") + call check(matches_type_value(pdict%items(2)%value, shape(value1, kind=i64))) + + call check(pdict%items(3)%name == "shape2") + call check(matches_type_value(pdict%items(3)%value, shape(value2, kind=i64))) + + end subroutine test_close_r32r1_r32r1_mismatch_shape + + + subroutine test_close_r32r1_r32r1_mismatch_value() + real(r32), parameter :: value1(2) = [0.1_r32, 2.2e-12_r32] + real(r32), parameter :: value2(2) = value1 + [1.0e-5_r32, 5e-14_r32] + integer(i64), parameter :: mismatchloc(1) = [2] + type(check_result), target :: res + type(details_dict), pointer :: pdict + + res = all_close(value1, value2) + + call check(.not. res%success) + call check(allocated(res%details)) + if (failed()) return + + call get_ptr_to(res%details, pdict) + call check(associated(pdict)) + if (failed()) return + + call check(size(pdict%items) == 4) + if (failed()) return + + call check(pdict%items(1)%name == "failure") + call check(matches_type_value(pdict%items(1)%value, mismatch_value_msg_real_)) + + call check(pdict%items(2)%name == "location") + call check(matches_type_value(pdict%items(2)%value, mismatchloc)) + + call check(pdict%items(3)%name == "value1") + call check(matches_type_value(pdict%items(3)%value, value1(mismatchloc(1)), rtol=1e-6_r32,& + & atol=1e-6_r32)) + + call check(pdict%items(4)%name == "value2") + call check(matches_type_value(pdict%items(4)%value, value2(mismatchloc(1)), rtol=1e-6_r32,& + & atol=1e-6_r32)) + + end subroutine test_close_r32r1_r32r1_mismatch_value + + + subroutine test_close_r32r2_r32r2_success() + real(r32), parameter :: value1(1, 2) = reshape([-5.0e20_r32, 128.0_r32], [1, 2]) + real(r32), parameter :: value2(1, 2) = value1 + reshape([1e-25_r32, 0.002_r32], [1, 2]) + type(check_result) :: res + + res = all_close(value1, value2) + call check(res%success) + call check(.not. allocated(res%details)) + + end subroutine test_close_r32r2_r32r2_success + + + subroutine test_close_r32r2_r32r2_mismatch_shape() + real(r32), parameter :: value1(1, 2) = reshape([-5.0e20_r32, 128.0_r32], [1, 2]) + real(r32), parameter :: value2(1, 1) = reshape([1.0_r32], [1, 1]) + type(check_result), target :: res + type(details_dict), pointer :: pdict + + res = all_close(value1, value2) + + call check(.not. res%success) + call check(allocated(res%details)) + if (failed()) return + + call get_ptr_to(res%details, pdict) + call check(associated(pdict)) + if (failed()) return + + call check(size(pdict%items) == 3) + if (failed()) return + + call check(pdict%items(1)%name == "failure") + call check(matches_type_value(pdict%items(1)%value, mismatch_shape_msg_)) + + call check(pdict%items(2)%name == "shape1") + call check(matches_type_value(pdict%items(2)%value, shape(value1, kind=i64))) + + call check(pdict%items(3)%name == "shape2") + call check(matches_type_value(pdict%items(3)%value, shape(value2, kind=i64))) + + end subroutine test_close_r32r2_r32r2_mismatch_shape + + + subroutine test_close_r32r2_r32r2_mismatch_value() + real(r32), parameter :: value1(1, 2) = reshape([-5.0e20_r32, 128.0_r32], [1, 2]) + real(r32), parameter :: value2(1, 2) = value1 + reshape([1e-25_r32, 0.02_r32], [1, 2]) + integer(i64), parameter :: mismatchloc(2) = [1, 2] + type(check_result), target :: res + type(details_dict), pointer :: pdict + + res = all_close(value1, value2) + + call check(.not. res%success) + call check(allocated(res%details)) + if (failed()) return + + call get_ptr_to(res%details, pdict) + call check(associated(pdict)) + if (failed()) return + + call check(size(pdict%items) == 4) + if (failed()) return + + call check(pdict%items(1)%name == "failure") + call check(matches_type_value(pdict%items(1)%value, mismatch_value_msg_real_)) + + call check(pdict%items(2)%name == "location") + call check(matches_type_value(pdict%items(2)%value, mismatchloc)) + + call check(pdict%items(3)%name == "value1") + call check(matches_type_value(pdict%items(3)%value, value1(mismatchloc(1), mismatchloc(2)),& + & rtol=1e-6_r32, atol=1e-6_r32)) + + call check(pdict%items(4)%name == "value2") + call check(matches_type_value(pdict%items(4)%value, value2(mismatchloc(1), mismatchloc(2)),& + & rtol=1e-6_r32, atol=1e-6_r32)) + + end subroutine test_close_r32r2_r32r2_mismatch_value + + + subroutine test_close_r32r1_r32r0_success() + real(r32), parameter :: value1(2) = [0.1_r32, 0.100001_r32] + real(r32), parameter :: value2 = 0.1_r32 + type(check_result) :: res + + res = all_close(value1, value2) + call check(res%success) + call check(.not. allocated(res%details)) + + end subroutine test_close_r32r1_r32r0_success + + + subroutine test_close_r32r1_r32r0_mismatch() + real(r32), parameter :: value1(2) = [0.1_r32, 2.2e-12_r32] + real(r32), parameter :: value2 = 0.100001_r32 + integer(i64), parameter :: mismatchloc(1) = [2] + type(check_result), target :: res + type(details_dict), pointer :: pdict + + res = all_close(value1, value2) + + call check(.not. res%success) + call check(allocated(res%details)) + if (failed()) return + + call get_ptr_to(res%details, pdict) + call check(associated(pdict)) + if (failed()) return + + call check(size(pdict%items) == 4) + if (failed()) return + + call check(pdict%items(1)%name == "failure") + call check(matches_type_value(pdict%items(1)%value, mismatch_value_msg_real_)) + + call check(pdict%items(2)%name == "location") + call check(matches_type_value(pdict%items(2)%value, mismatchloc)) + + call check(pdict%items(3)%name == "value1") + call check(matches_type_value(pdict%items(3)%value, value1(mismatchloc(1)), rtol=1e-6_r32,& + & atol=1e-6_r32)) + + call check(pdict%items(4)%name == "value2") + call check(matches_type_value(pdict%items(4)%value, value2, rtol=1e-6_r32, atol=1e-6_r32)) + + end subroutine test_close_r32r1_r32r0_mismatch + + + subroutine test_close_r32r0_r32r1_success() + real(r32), parameter :: value1 = 0.1_r32 + real(r32), parameter :: value2(2) = [0.1_r32, 0.100001_r32] + type(check_result) :: res + + res = all_close(value1, value2) + call check(res%success) + call check(.not. allocated(res%details)) + + end subroutine test_close_r32r0_r32r1_success + + + subroutine test_close_r32r0_r32r1_mismatch() + real(r32), parameter :: value1 = 0.100001_r32 + real(r32), parameter :: value2(2) = [0.1_r32, 2.2e-12_r32] + integer(i64), parameter :: mismatchloc(1) = [2] + type(check_result), target :: res + type(details_dict), pointer :: pdict + + res = all_close(value1, value2) + + call check(.not. res%success) + call check(allocated(res%details)) + if (failed()) return + + call get_ptr_to(res%details, pdict) + call check(associated(pdict)) + if (failed()) return + + call check(size(pdict%items) == 4) + if (failed()) return + + call check(pdict%items(1)%name == "failure") + call check(matches_type_value(pdict%items(1)%value, mismatch_value_msg_real_)) + + call check(pdict%items(2)%name == "location") + call check(matches_type_value(pdict%items(2)%value, mismatchloc)) + + call check(pdict%items(3)%name == "value1") + call check(matches_type_value(pdict%items(3)%value, value1, rtol=1e-6_r32, atol=1e-6_r32)) + + call check(pdict%items(4)%name == "value2") + call check(matches_type_value(pdict%items(4)%value, value2(mismatchloc(1)), rtol=1e-6_r32,& + & atol=1e-6_r32)) + + end subroutine test_close_r32r0_r32r1_mismatch + + + subroutine test_close_r32r2_r32r0_success() + real(r32), parameter :: value1(2, 1) = reshape([0.1_r32, 0.100001_r32], [2, 1]) + real(r32), parameter :: value2 = 0.1_r32 + type(check_result) :: res + + res = all_close(value1, value2) + call check(res%success) + call check(.not. allocated(res%details)) + + end subroutine test_close_r32r2_r32r0_success + + + subroutine test_close_r32r2_r32r0_mismatch() + real(r32), parameter :: value1(2, 1) = reshape([0.1_r32, 2.2e-12_r32], [2, 1]) + real(r32), parameter :: value2 = 0.100001_r32 + integer(i64), parameter :: mismatchloc(2) = [2, 1] + type(check_result), target :: res + type(details_dict), pointer :: pdict + + res = all_close(value1, value2) + + call check(.not. res%success) + call check(allocated(res%details)) + if (failed()) return + + call get_ptr_to(res%details, pdict) + call check(associated(pdict)) + if (failed()) return + + call check(size(pdict%items) == 4) + if (failed()) return + + call check(pdict%items(1)%name == "failure") + call check(matches_type_value(pdict%items(1)%value, mismatch_value_msg_real_)) + + call check(pdict%items(2)%name == "location") + call check(matches_type_value(pdict%items(2)%value, mismatchloc)) + + call check(pdict%items(3)%name == "value1") + call check(matches_type_value(pdict%items(3)%value, value1(mismatchloc(1), mismatchloc(2)),& + & rtol=1e-6_r32, atol=1e-6_r32)) + + call check(pdict%items(4)%name == "value2") + call check(matches_type_value(pdict%items(4)%value, value2, rtol=1e-6_r32, atol=1e-6_r32)) + + end subroutine test_close_r32r2_r32r0_mismatch + + + subroutine test_close_r32r0_r32r2_success() + real(r32), parameter :: value1 = 0.1_r32 + real(r32), parameter :: value2(2, 1) = reshape([0.1_r32, 0.100001_r32], [2, 1]) + type(check_result) :: res + + res = all_close(value1, value2) + call check(res%success) + call check(.not. allocated(res%details)) + + end subroutine test_close_r32r0_r32r2_success + + + subroutine test_close_r32r0_r32r2_mismatch() + real(r32), parameter :: value1 = 0.100001_r32 + real(r32), parameter :: value2(2, 1) = reshape([0.1_r32, 2.2e-12_r32], [2, 1]) + integer(i64), parameter :: mismatchloc(2) = [2, 1] + type(check_result), target :: res + type(details_dict), pointer :: pdict + + res = all_close(value1, value2) + + call check(.not. res%success) + call check(allocated(res%details)) + if (failed()) return + + call get_ptr_to(res%details, pdict) + call check(associated(pdict)) + if (failed()) return + + call check(size(pdict%items) == 4) + if (failed()) return + + call check(pdict%items(1)%name == "failure") + call check(matches_type_value(pdict%items(1)%value, mismatch_value_msg_real_)) + + call check(pdict%items(2)%name == "location") + call check(matches_type_value(pdict%items(2)%value, mismatchloc)) + + call check(pdict%items(3)%name == "value1") + call check(matches_type_value(pdict%items(3)%value, value1, rtol=1e-6_r32, atol=1e-6_r32)) + + call check(pdict%items(4)%name == "value2") + call check(matches_type_value(pdict%items(4)%value, value2(mismatchloc(1), mismatchloc(2)),& + & rtol=1e-6_r32, atol=1e-6_r32)) + + end subroutine test_close_r32r0_r32r2_mismatch + + + function tests() + type(test_list) :: tests + + tests = test_list([& + suite("checkers", test_list([& + suite("equal", test_list([& + test("i32_i32_success", test_equal_i32_i32_success),& + test("i32_i32_mismatch", test_equal_i32_i32_mismatch),& + test("i32r1_i32r1_success", test_equal_i32r1_i32r1_success),& + test("i32r1_i32r1_mismatch_shape", test_equal_i32r1_i32r1_mismatch_shape),& + test("i32r1_i32r1_mismatch_value", test_equal_i32r1_i32r1_mismatch_value),& + test("i32r2_i32r2_success", test_equal_i32r2_i32r2_success),& + test("i32r2_i32r2_mismatch_shape", test_equal_i32r2_i32r2_mismatch_shape),& + test("i32r2_i32r2_mismatch_value", test_equal_i32r2_i32r2_mismatch_value),& + test("i32r1_i32r0_success", test_equal_i32r1_i32r0_success),& + test("i32r1_i32r0_mismatch", test_equal_i32r1_i32r0_mismatch),& + test("i32r0_i32r1_success", test_equal_i32r0_i32r1_success),& + test("i32r0_i32r1_mismatch", test_equal_i32r0_i32r1_mismatch),& + test("i32r2_i32r0_success", test_equal_i32r2_i32r0_success),& + test("i32r2_i32r0_mismatch", test_equal_i32r2_i32r0_mismatch),& + test("i32r0_i32r2_success", test_equal_i32r0_i32r2_success),& + test("i32r0_i32r2_mismatch", test_equal_i32r0_i32r2_mismatch)& + ])),& + suite("close", test_list([& + test("r32_r32_success", test_close_r32_r32_success),& + test("r32_r32_mismatch", test_close_r32_r32_mismatch),& + test("r32r1_r32r1_success", test_close_r32r1_r32r1_success),& + test("r32r1_r32r1_mismatch_shape", test_close_r32r1_r32r1_mismatch_shape),& + test("r32r1_r32r1_mismatch_value", test_close_r32r1_r32r1_mismatch_value),& + test("r32r2_r32r2_success", test_close_r32r2_r32r2_success),& + test("r32r2_r32r2_mismatch_shape", test_close_r32r2_r32r2_mismatch_shape),& + test("r32r2_r32r2_mismatch_value", test_close_r32r2_r32r2_mismatch_value),& + test("r32r1_r32r0_success", test_close_r32r1_r32r0_success),& + test("r32r1_r32r0_mismatch", test_close_r32r1_r32r0_mismatch),& + test("r32r0_r32r1_success", test_close_r32r0_r32r1_success),& + test("r32r0_r32r1_mismatch", test_close_r32r0_r32r1_mismatch),& + test("r32r2_r32r0_success", test_close_r32r2_r32r0_success),& + test("r32r2_r32r0_mismatch", test_close_r32r2_r32r0_mismatch),& + test("r32r0_r32r2_success", test_close_r32r0_r32r2_success),& + test("r32r0_r32r2_mismatch", test_close_r32r0_r32r2_mismatch)& + ]))& + ]))& + ]) + + end function tests + +end module test_checkers diff --git a/test/unit/testapp.f90 b/test/unit/testapp.f90 new file mode 100644 index 0000000..5dc9fa2 --- /dev/null +++ b/test/unit/testapp.f90 @@ -0,0 +1,15 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Test app with command line interface, collecting and executing the tests. +program testapp + use fortuno_serial, only : execute_serial_cmd_app, test_list + use test_checkers, only : checkers_tests => tests + implicit none + + call execute_serial_cmd_app(test_list([& + checkers_tests()& + ])) + +end program testapp