fortran-testdrive-0.6.0/0000775000175000017500000000000015201524527015366 5ustar alastairalastairfortran-testdrive-0.6.0/LICENSE-MIT0000664000175000017500000000206615201524466017030 0ustar alastairalastairMIT License Copyright (c) 2020-2021 Sebastian Ehlert Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. fortran-testdrive-0.6.0/requirements.txt0000664000175000017500000000002115201524466020645 0ustar alastairalastairmeson ninja gcovrfortran-testdrive-0.6.0/src/0000775000175000017500000000000015201524466016157 5ustar alastairalastairfortran-testdrive-0.6.0/src/testdrive_version.f900000664000175000017500000000352615201524466022263 0ustar alastairalastair! This file is part of test-drive. ! SPDX-Identifier: Apache-2.0 OR MIT ! ! Licensed under either of Apache License, Version 2.0 or MIT license ! at your option; you may not use this file except in compliance with ! the License. ! ! Unless required by applicable law or agreed to in writing, software ! distributed under the License is distributed on an "AS IS" BASIS, ! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ! See the License for the specific language governing permissions and ! limitations under the License. module testdrive_version implicit none private public :: testdrive_version_string, testdrive_version_compact public :: get_testdrive_version !> String representation of the test-drive version character(len=*), parameter :: testdrive_version_string = "0.6.0" !> Numeric representation of the test-drive version integer, parameter :: testdrive_version_compact(3) = [0, 6, 0] contains !> Getter function to retrieve test-drive version subroutine get_testdrive_version(major, minor, patch, string) !> Major version number of the test-drive version integer, intent(out), optional :: major !> Minor version number of the test-drive version integer, intent(out), optional :: minor !> Patch version number of the test-drive version integer, intent(out), optional :: patch !> String representation of the test-drive version character(len=:), allocatable, intent(out), optional :: string if (present(major)) then major = testdrive_version_compact(1) end if if (present(minor)) then minor = testdrive_version_compact(2) end if if (present(patch)) then patch = testdrive_version_compact(3) end if if (present(string)) then string = testdrive_version_string end if end subroutine get_testdrive_version end module testdrive_version fortran-testdrive-0.6.0/src/meson.build0000664000175000017500000000114315201524466020320 0ustar alastairalastair# This file is part of test-drive. # SPDX-Identifier: Apache-2.0 OR MIT # # Licensed under either of Apache License, Version 2.0 or MIT license # at your option; you may not use this file except in compliance with # the License. # # Unless required by applicable law or agreed to in writing, software # distributed under the License is distributed on an "AS IS" BASIS, # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. # See the License for the specific language governing permissions and # limitations under the License. srcs += files( 'testdrive.F90', 'testdrive_version.f90', ) fortran-testdrive-0.6.0/src/CMakeLists.txt0000664000175000017500000000127615201524466020725 0ustar alastairalastair# This file is part of test-drive. # SPDX-Identifier: Apache-2.0 OR MIT # # Licensed under either of Apache License, Version 2.0 or MIT license # at your option; you may not use this file except in compliance with # the License. # # Unless required by applicable law or agreed to in writing, software # distributed under the License is distributed on an "AS IS" BASIS, # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. # See the License for the specific language governing permissions and # limitations under the License. set(dir "${CMAKE_CURRENT_SOURCE_DIR}") list( APPEND srcs "${dir}/testdrive.F90" "${dir}/testdrive_version.f90" ) set(srcs "${srcs}" PARENT_SCOPE) fortran-testdrive-0.6.0/src/testdrive.F900000664000175000017500000023301415201524466020453 0ustar alastairalastair! This file is part of test-drive. ! SPDX-Identifier: Apache-2.0 OR MIT ! ! Licensed under either of Apache License, Version 2.0 or MIT license ! at your option; you may not use this file except in compliance with ! the License. ! ! Unless required by applicable law or agreed to in writing, software ! distributed under the License is distributed on an "AS IS" BASIS, ! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ! See the License for the specific language governing permissions and ! limitations under the License. !# Enable support for quadruple precision #ifndef WITH_QP #define WITH_QP 0 #endif !# Enable support for extended double precision #ifndef WITH_XDP #define WITH_XDP 0 #endif !# Enable ieee_is_nan for NaN detection #ifndef WITH_IEEE_IS_NAN #define WITH_IEEE_IS_NAN 0 #endif !> Provides a light-weight procedural testing framework for Fortran projects. !> !> Testsuites are defined by a [[collect_interface]] returning a set of !> [[unittest_type]] objects. To create a new test use the [[new_unittest]] !> constructor, which requires a test identifier and a procedure with a !> [[test_interface]] compatible signature. The error status is communicated !> by the allocation status of an [[error_type]]. !> !> The necessary boilerplate code to setup the test entry point is just !> !>```fortran !>program tester !> use, intrinsic :: iso_fortran_env, only : error_unit !> use testdrive, only : run_testsuite, new_testsuite, testsuite_type !> use test_suite1, only : collect_suite1 !> use test_suite2, only : collect_suite2 !> implicit none !> integer :: stat, is !> type(testsuite_type), allocatable :: testsuites(:) !> character(len=*), parameter :: fmt = '("#", *(1x, a))' !> !> stat = 0 !> !> testsuites = [ & !> new_testsuite("suite1", collect_suite1), & !> new_testsuite("suite2", collect_suite2) & !> ] !> !> do is = 1, size(testsuites) !> write(error_unit, fmt) "Testing:", testsuites(is)%name !> call run_testsuite(testsuites(is)%collect, error_unit, stat) !> end do !> !> if (stat > 0) then !> write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" !> error stop !> end if !> !>end program tester !>``` !> !> Every test is defined in a separate module using a ``collect`` function, which !> is exported and added to the ``testsuites`` array in the test runner. !> All test have a simple interface with just an allocatable [[error_type]] as !> output to provide the test results. !> !>```fortran !>module test_suite1 !> use testdrive, only : new_unittest, unittest_type, error_type, check !> implicit none !> private !> !> public :: collect_suite1 !> !>contains !> !>!> Collect all exported unit tests !>subroutine collect_suite1(testsuite) !> !> Collection of tests !> type(unittest_type), allocatable, intent(out) :: testsuite(:) !> !> testsuite = [ & !> new_unittest("valid", test_valid), & !> new_unittest("invalid", test_invalid, should_fail=.true.) & !> ] !> !>end subroutine collect_suite1 !> !>subroutine test_valid(error) !> type(error_type), allocatable, intent(out) :: error !> ! ... !>end subroutine test_valid !> !>subroutine test_invalid(error) !> type(error_type), allocatable, intent(out) :: error !> ! ... !>end subroutine test_invalid !> !>end module test_suite1 !>``` !> !> For an example setup checkout the ``test/`` directory in this project. module testdrive use, intrinsic :: iso_fortran_env, only : error_unit implicit none private public :: run_testsuite, run_selected, new_unittest, new_testsuite public :: select_test, select_suite public :: unittest_type, testsuite_type, error_type public :: check, test_failed, skip_test public :: test_interface, collect_interface public :: get_argument, get_variable, to_string public :: junit_output, junit_header public :: init_color_output !> Single precision real numbers integer, parameter :: sp = selected_real_kind(6) !> Double precision real numbers integer, parameter :: dp = selected_real_kind(15) #if WITH_XDP !> Extended double precision real numbers integer, parameter :: xdp = selected_real_kind(18) #endif #if WITH_QP !> Quadruple precision real numbers integer, parameter :: qp = selected_real_kind(33) #endif !> Char length for integers integer, parameter :: i1 = selected_int_kind(2) !> Short length for integers integer, parameter :: i2 = selected_int_kind(4) !> Length of default integers integer, parameter :: i4 = selected_int_kind(9) !> Long length for integers integer, parameter :: i8 = selected_int_kind(18) !> Error code for success integer, parameter :: success = 0 !> Error code for failure integer, parameter :: fatal = 1 !> Error code for skipped test integer, parameter :: skipped = 77 !> Error message type :: error_type !> Error code integer :: stat = success !> Payload of the error character(len=:), allocatable :: message contains !> Escalate uncaught errors final :: escalate_error end type error_type interface check module procedure :: check_stat module procedure :: check_logical module procedure :: check_float_sp module procedure :: check_float_dp #if WITH_XDP module procedure :: check_float_xdp #endif #if WITH_QP module procedure :: check_float_qp #endif module procedure :: check_float_exceptional_sp module procedure :: check_float_exceptional_dp #if WITH_XDP module procedure :: check_float_exceptional_xdp #endif #if WITH_QP module procedure :: check_float_exceptional_qp #endif module procedure :: check_complex_sp module procedure :: check_complex_dp #if WITH_XDP module procedure :: check_complex_xdp #endif #if WITH_QP module procedure :: check_complex_qp #endif module procedure :: check_complex_exceptional_sp module procedure :: check_complex_exceptional_dp #if WITH_XDP module procedure :: check_complex_exceptional_xdp #endif #if WITH_QP module procedure :: check_complex_exceptional_qp #endif module procedure :: check_float_absrel_sp module procedure :: check_float_absrel_dp #if WITH_XDP module procedure :: check_float_absrel_xdp #endif #if WITH_QP module procedure :: check_float_absrel_qp #endif module procedure :: check_complex_absrel_sp module procedure :: check_complex_absrel_dp #if WITH_XDP module procedure :: check_complex_absrel_xdp #endif #if WITH_QP module procedure :: check_complex_absrel_qp #endif module procedure :: check_int_i1 module procedure :: check_int_i2 module procedure :: check_int_i4 module procedure :: check_int_i8 module procedure :: check_bool module procedure :: check_string end interface check interface to_string module procedure :: integer_i1_to_string module procedure :: integer_i2_to_string module procedure :: integer_i4_to_string module procedure :: integer_i8_to_string module procedure :: real_sp_to_string module procedure :: real_dp_to_string #if WITH_XDP module procedure :: real_xdp_to_string #endif #if WITH_QP module procedure :: real_qp_to_string #endif module procedure :: complex_sp_to_string module procedure :: complex_dp_to_string #if WITH_XDP module procedure :: complex_xdp_to_string #endif #if WITH_QP module procedure :: complex_qp_to_string #endif end interface to_string !> Check for not-a-number (NaN) values. Uses the IEEE intrinsic !> `ieee_is_nan` when available, and falls back to a portable !> comparison-based implementation (using `HUGE`/`ABS`) when IEEE !> arithmetic is disabled. interface is_nan module procedure :: is_nan_sp module procedure :: is_nan_dp #if WITH_XDP module procedure :: is_nan_xdp #endif #if WITH_QP module procedure :: is_nan_qp #endif end interface is_nan abstract interface !> Entry point for tests subroutine test_interface(error) import :: error_type !> Error handling type(error_type), allocatable, intent(out) :: error end subroutine test_interface end interface !> Declaration of a unit test type :: unittest_type !> Name of the test character(len=:), allocatable :: name !> Entry point of the test procedure(test_interface), pointer, nopass :: test => null() !> Whether test is supposed to fail logical :: should_fail = .false. contains !> Deallocate unittest's internal data final :: destroy_unittest end type unittest_type abstract interface !> Collect all tests subroutine collect_interface(testsuite) import :: unittest_type #ifdef __NVCOMPILER_LLVM__ ! this is only an issue with nvhpc 25.9, possibly a bug in the compiler ! verify in next release import :: test_interface #endif !> Collection of tests type(unittest_type), allocatable, intent(out) :: testsuite(:) end subroutine collect_interface end interface !> Collection of unit tests type :: testsuite_type !> Name of the testsuite character(len=:), allocatable :: name !> Entry point of the test procedure(collect_interface), pointer, nopass :: collect => null() contains !> Deallocate testsuite's internal data final :: destroy_testsuite end type testsuite_type !> Output JUnit.xml for discovering unit tests by other tools type :: junit_output !> XML output string (initial block) character(len=:), allocatable :: xml_start !> XML output string (current block) character(len=:), allocatable :: xml_block !> XML output string (final block) character(len=:), allocatable :: xml_final !> Unique identifier integer :: uid = 0 !> Timestamp character(len=19) :: timestamp = '1970-01-01T00:00:00' !> Hostname character(len=:), allocatable :: hostname !> Package name character(len=:), allocatable :: package !> Testsuite name character(len=:), allocatable :: testsuite !> Number of tests integer :: tests = 0 !> Number of failures integer :: failures = 0 !> Number of errors integer :: errors = 0 !> Number of skipped tests integer :: skipped = 0 !> Running time real(sp) :: time = 0.0_sp contains final :: destroy_junit_output end type junit_output !> Container for terminal escape code type :: color_code !> Style descriptor integer(i1) :: style = -1_i1 !> Background color descriptor integer(i1) :: bg = -1_i1 !> Foreground color descriptor integer(i1) :: fg = -1_i1 end type color_code interface operator(+) module procedure :: add_color end interface operator(+) interface operator(//) module procedure :: concat_color_left module procedure :: concat_color_right end interface operator(//) !> Colorizer class for handling colorful output in the terminal type, public :: color_output type(color_code) :: & reset = color_code(), & bold = color_code(), & dim = color_code(), & italic = color_code(), & underline = color_code(), & blink = color_code(), & reverse = color_code(), & hidden = color_code() type(color_code) :: & black = color_code(), & red = color_code(), & green = color_code(), & yellow = color_code(), & blue = color_code(), & magenta = color_code(), & cyan = color_code(), & white = color_code() type(color_code) :: & bg_black = color_code(), & bg_red = color_code(), & bg_green = color_code(), & bg_yellow = color_code(), & bg_blue = color_code(), & bg_magenta = color_code(), & bg_cyan = color_code(), & bg_white = color_code() end type color_output interface color_output module procedure :: new_color_output end interface color_output type(color_output), protected :: color character(len=*), parameter :: fmt = '(1x, *(1x, a))' character(len=*), parameter :: newline = new_line("a") contains !> Driver for testsuite recursive subroutine run_testsuite(collect, unit, stat, parallel, junit) !> Collect tests procedure(collect_interface) :: collect !> Unit for IO integer, intent(in) :: unit !> Number of failed tests integer, intent(inout) :: stat !> Run the tests in parallel logical, intent(in), optional :: parallel !> Produce junit output type(junit_output), intent(inout), optional :: junit type(unittest_type), allocatable :: testsuite(:) integer :: it logical :: parallel_ parallel_ = .true. if(present(parallel)) parallel_ = parallel call collect(testsuite) call junit_push_suite(junit, "testdrive") !$omp parallel do schedule(dynamic) shared(testsuite, unit) reduction(+:stat) & !$omp if (parallel_) do it = 1, size(testsuite) !$omp critical(testdrive_testsuite) write(unit, '(1x, 4(1x, a))') & & "Starting", (color%blue)//testsuite(it)%name//color%reset, & & color%dim//"..."//color%reset, & & color%bold//"(" // color%cyan//to_string(it)//color%bold // & & "/" // color%cyan//to_string(size(testsuite))//color%bold // ")"//color%reset !$omp end critical(testdrive_testsuite) call run_unittest(testsuite(it), unit, stat, junit) end do call junit_pop_suite(junit) end subroutine run_testsuite !> Driver for selective testing recursive subroutine run_selected(collect, name, unit, stat, junit) !> Collect tests procedure(collect_interface) :: collect !> Name of the selected test character(len=*), intent(in) :: name !> Unit for IO integer, intent(in) :: unit !> Number of failed tests integer, intent(inout) :: stat !> Produce junit output type(junit_output), intent(inout), optional :: junit type(unittest_type), allocatable :: testsuite(:) integer :: it call collect(testsuite) call junit_push_suite(junit, "testdrive") it = select_test(testsuite, name) if (it > 0 .and. it <= size(testsuite)) then call run_unittest(testsuite(it), unit, stat, junit) else write(unit, fmt) "Available tests:" do it = 1, size(testsuite) write(unit, fmt) "-", testsuite(it)%name end do stat = -huge(it) end if call junit_pop_suite(junit) end subroutine run_selected !> Run a selected unit test recursive subroutine run_unittest(test, unit, stat, junit) !> Unit test type(unittest_type), intent(in) :: test !> Unit for IO integer, intent(in) :: unit !> Number of failed tests integer, intent(inout) :: stat !> Produce junit output type(junit_output), intent(inout), optional :: junit type(error_type), allocatable :: error character(len=:), allocatable :: message call test%test(error) if (.not.test_skipped(error)) then if (allocated(error) .neqv. test%should_fail) stat = stat + 1 end if call junit_push_test(junit, test, error, 0.0_sp) call make_output(message, test, error) !$omp critical(testdrive_testsuite) write(unit, '(a)') message !$omp end critical(testdrive_testsuite) if (allocated(error)) then call clear_error(error) end if end subroutine run_unittest pure function test_skipped(error) result(is_skipped) !> Error handling type(error_type), intent(in), optional :: error !> Test was skipped logical :: is_skipped is_skipped = .false. if (present(error)) then is_skipped = error%stat == skipped end if end function test_skipped !> Create output message for test (this procedure is pure and therefore cannot launch tests) pure subroutine make_output(output, test, error) !> Output message for display character(len=:), allocatable, intent(out) :: output !> Unit test type(unittest_type), intent(in) :: test !> Error handling type(error_type), intent(in), optional :: error character(len=:), allocatable :: label type(color_code) :: label_color if (test_skipped(error)) then label_color = color%yellow + color%bold label = "SKIPPED" else if (present(error) .neqv. test%should_fail) then if (test%should_fail) then label_color = color%magenta + color%bold label = "UNEXPECTED PASS" else label_color = color%red + color%bold label = "FAILED" end if else if (test%should_fail) then label_color = color%cyan + color%bold label = "EXPECTED FAIL" else label_color = color%green + color%bold label = "PASSED" end if end if output = " " // color%dim//"..."//color%reset // " " // & & color%blue//test%name//color%reset // & & " "//color%bold//"["//label_color//label//color%bold//"]"//color%reset if (present(error)) then output = output // newline // " "//color%bold//"Message:"//color%reset//" " // error%message end if end subroutine make_output !> Initialize output for JUnit.xml pure subroutine junit_header(junit, package) !> JUnit output type(junit_output), intent(inout), optional :: junit !> Package name character(len=*), intent(in) :: package if (.not.present(junit)) return junit%xml_start = & & '' // newline // & & '' // newline junit%xml_block = '' junit%xml_final = & & '' junit%hostname = 'localhost' junit%package = package end subroutine junit_header !> Register a test suite in JUnit.xml subroutine junit_push_suite(junit, name) !> JUnit output type(junit_output), intent(inout), optional :: junit !> Name of the test suite character(len=*), intent(in) :: name if (.not.present(junit)) return junit%timestamp = get_timestamp() junit%testsuite = name junit%uid = junit%uid + 1 end subroutine junit_push_suite !> Finalize a test suite in JUnit.xml subroutine junit_pop_suite(junit) !> JUnit output type(junit_output), intent(inout), optional :: junit if (.not.present(junit)) return junit%xml_start = & & junit%xml_start // & & ' ' // newline // & & ' ' // newline // & & ' ' // newline // & & junit%xml_block // newline // & & ' ' // newline junit%xml_block = '' junit%tests = 0 junit%failures = 0 junit%errors = 0 junit%skipped = 0 junit%time = 0.0_sp call junit_write(junit) end subroutine junit_pop_suite !> Register a new unit test subroutine junit_push_test(junit, test, error, time) !> JUnit output type(junit_output), intent(inout), optional :: junit !> Unit test type(unittest_type), intent(in) :: test !> Error handling type(error_type), intent(in), optional :: error !> Running time real(sp), intent(in) :: time if (.not.present(junit)) return !$omp critical(testdrive_junit) junit%tests = junit%tests + 1 junit%time = junit%time + time junit%xml_block = & & junit%xml_block // & & ' ' // newline if (test_skipped(error)) then junit%xml_block = & & junit%xml_block // & & ' ' // newline junit%skipped = junit%skipped + 1 elseif (present(error)) then if (test%should_fail) then junit%xml_block = & & junit%xml_block // & & ' ' // newline // & & ' "'//error%message//'"' // newline // & & ' ' // newline else junit%xml_block = & & junit%xml_block // & & ' ' // newline junit%failures = junit%failures + 1 end if else if (test%should_fail) then junit%xml_block = & & junit%xml_block // & & ' ' // newline junit%failures = junit%failures + 1 else junit%xml_block = & & junit%xml_block // & & ' ' // newline // & & ' "Test passed successfully"' // newline // & & ' ' // newline end if end if junit%xml_block = & & junit%xml_block // & & ' ' // newline !$omp end critical(testdrive_junit) end subroutine junit_push_test !> Write results to JUnit.xml subroutine junit_write(junit) !> JUnit output type(junit_output), intent(inout), optional :: junit integer :: io if (.not.present(junit)) return open( & & newunit=io, & & file='JUnit'//junit%package//'.xml', & & status='replace', & & action='write') write(io, '(a)') junit%xml_start // junit%xml_final close(io) end subroutine junit_write !> deallocate internal data of junit_output subroutine destroy_junit_output(self) !> JUnit output type(junit_output), intent(inout) :: self if (allocated(self%xml_start)) deallocate(self%xml_start) if (allocated(self%xml_block)) deallocate(self%xml_block) if (allocated(self%xml_final)) deallocate(self%xml_final) if (allocated(self%hostname)) deallocate(self%hostname) if (allocated(self%package)) deallocate(self%package) if (allocated(self%testsuite)) deallocate(self%testsuite) end subroutine destroy_junit_output !> Create ISO 8601 formatted timestamp function get_timestamp() result(timestamp) !> ISO 8601 formatted timestamp character(len=19) :: timestamp character(len=8) :: date character(len=10) :: time call date_and_time(date=date, time=time) timestamp = date(1:4) // "-" // date(5:6) // "-" // date(7:8) // "T" // & & time(1:2) // ":" // time(3:4) // ":" // time(5:6) end function get_timestamp !> Select a unit test from all available tests function select_test(tests, name) result(pos) !> Name identifying the test suite character(len=*), intent(in) :: name !> Available unit tests type(unittest_type) :: tests(:) !> Selected test suite integer :: pos integer :: it pos = 0 do it = 1, size(tests) if (name == tests(it)%name) then pos = it exit end if end do end function select_test !> Select a test suite from all available suites function select_suite(suites, name) result(pos) !> Name identifying the test suite character(len=*), intent(in) :: name !> Available test suites type(testsuite_type) :: suites(:) !> Selected test suite integer :: pos integer :: it pos = 0 do it = 1, size(suites) if (name == suites(it)%name) then pos = it exit end if end do end function select_suite !> Register a new unit test function new_unittest(name, test, should_fail) result(self) !> Name of the test character(len=*), intent(in) :: name !> Entry point for the test procedure(test_interface) :: test !> Whether test is supposed to error or not logical, intent(in), optional :: should_fail !> Newly registered test type(unittest_type) :: self self%name = name self%test => test if (present(should_fail)) self%should_fail = should_fail end function new_unittest !> Finalize unit test subroutine destroy_unittest(self) !> unittest to destroy type(unittest_type), intent(inout) :: self if (allocated(self%name)) deallocate(self%name) self%test => null() end subroutine destroy_unittest !> Register a new testsuite function new_testsuite(name, collect) result(self) !> Name of the testsuite character(len=*), intent(in) :: name !> Entry point to collect tests procedure(collect_interface) :: collect !> Newly registered testsuite type(testsuite_type) :: self self%name = name self%collect => collect end function new_testsuite !> Finalize testsuite subroutine destroy_testsuite(self) !> testsuite to destroy type(testsuite_type), intent(inout) :: self if (allocated(self%name)) deallocate(self%name) self%collect => null() end subroutine destroy_testsuite subroutine check_stat(error, stat, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error !> Status of operation integer, intent(in) :: stat !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more if (stat /= success) then if (present(message)) then call test_failed(error, message, more) else call test_failed(error, "Non-zero exit code encountered", more) end if end if end subroutine check_stat subroutine check_logical(error, expression, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error !> Result of logical operator logical, intent(in) :: expression !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more if (.not.expression) then if (present(message)) then call test_failed(error, message, more) else call test_failed(error, "Condition not fullfilled", more) end if end if end subroutine check_logical subroutine check_float_dp(error, actual, expected, message, more, thr, rel) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found floating point value real(dp), intent(in) :: actual !> Expected floating point value real(dp), intent(in) :: expected !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more !> Allowed threshold for matching floating point values real(dp), intent(in), optional :: thr !> Check for relative errors instead logical, intent(in), optional :: rel logical :: relative real(dp) :: diff, threshold call check(error, actual, message, more) if (allocated(error)) return if (present(thr)) then threshold = thr else threshold = epsilon(expected) end if if (present(rel)) then relative = rel else relative = .false. end if if (relative) then diff = abs(actual - expected) / abs(expected) else diff = abs(actual - expected) end if if (diff > threshold) then if (present(message)) then call test_failed(error, message, more) else if (relative) then call test_failed(error, & "Floating point value mismatch", & "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& "(difference: "//to_string(int(diff*100))//"%)", & more) else call test_failed(error, & "Floating point value mismatch", & "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& "(difference: "//to_string(diff)//")", & more) end if end if end if end subroutine check_float_dp subroutine check_float_exceptional_dp(error, actual, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found floating point value real(dp), intent(in) :: actual !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more if (is_nan(actual)) then if (present(message)) then call test_failed(error, message, more) else call test_failed(error, "Exceptional value 'not a number' found", more) end if end if end subroutine check_float_exceptional_dp subroutine check_float_sp(error, actual, expected, message, more, thr, rel) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found floating point value real(sp), intent(in) :: actual !> Expected floating point value real(sp), intent(in) :: expected !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more !> Allowed threshold for matching floating point values real(sp), intent(in), optional :: thr !> Check for relative errors instead logical, intent(in), optional :: rel logical :: relative real(sp) :: diff, threshold call check(error, actual, message, more) if (allocated(error)) return if (present(thr)) then threshold = thr else threshold = epsilon(expected) end if if (present(rel)) then relative = rel else relative = .false. end if if (relative) then diff = abs(actual - expected) / abs(expected) else diff = abs(actual - expected) end if if (diff > threshold) then if (present(message)) then call test_failed(error, message, more) else if (relative) then call test_failed(error, & "Floating point value mismatch", & "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& "(difference: "//to_string(int(diff*100))//"%)", & more) else call test_failed(error, & "Floating point value mismatch", & "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& "(difference: "//to_string(diff)//")", & more) end if end if end if end subroutine check_float_sp subroutine check_float_exceptional_sp(error, actual, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found floating point value real(sp), intent(in) :: actual !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more if (is_nan(actual)) then if (present(message)) then call test_failed(error, message, more) else call test_failed(error, "Exceptional value 'not a number' found", more) end if end if end subroutine check_float_exceptional_sp #if WITH_XDP subroutine check_float_xdp(error, actual, expected, message, more, thr, rel) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found floating point value real(xdp), intent(in) :: actual !> Expected floating point value real(xdp), intent(in) :: expected !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more !> Allowed threshold for matching floating point values real(xdp), intent(in), optional :: thr !> Check for relative errors instead logical, intent(in), optional :: rel logical :: relative real(xdp) :: diff, threshold call check(error, actual, message, more) if (allocated(error)) return if (present(thr)) then threshold = thr else threshold = epsilon(expected) end if if (present(rel)) then relative = rel else relative = .false. end if if (relative) then diff = abs(actual - expected) / abs(expected) else diff = abs(actual - expected) end if if (diff > threshold) then if (present(message)) then call test_failed(error, message, more) else if (relative) then call test_failed(error, & "Floating point value mismatch", & "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& "(difference: "//to_string(int(diff*100))//"%)", & more) else call test_failed(error, & "Floating point value mismatch", & "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& "(difference: "//to_string(diff)//")", & more) end if end if end if end subroutine check_float_xdp subroutine check_float_exceptional_xdp(error, actual, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found floating point value real(xdp), intent(in) :: actual !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more if (is_nan(actual)) then if (present(message)) then call test_failed(error, message, more) else call test_failed(error, "Exceptional value 'not a number' found", more) end if end if end subroutine check_float_exceptional_xdp #endif #if WITH_QP subroutine check_float_qp(error, actual, expected, message, more, thr, rel) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found floating point value real(qp), intent(in) :: actual !> Expected floating point value real(qp), intent(in) :: expected !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more !> Allowed threshold for matching floating point values real(qp), intent(in), optional :: thr !> Check for relative errors instead logical, intent(in), optional :: rel logical :: relative real(qp) :: diff, threshold call check(error, actual, message, more) if (allocated(error)) return if (present(thr)) then threshold = thr else threshold = epsilon(expected) end if if (present(rel)) then relative = rel else relative = .false. end if if (relative) then diff = abs(actual - expected) / abs(expected) else diff = abs(actual - expected) end if if (diff > threshold) then if (present(message)) then call test_failed(error, message, more) else if (relative) then call test_failed(error, & "Floating point value mismatch", & "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& "(difference: "//to_string(int(diff*100))//"%)", & more) else call test_failed(error, & "Floating point value mismatch", & "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& "(difference: "//to_string(diff)//")", & more) end if end if end if end subroutine check_float_qp subroutine check_float_exceptional_qp(error, actual, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found floating point value real(qp), intent(in) :: actual !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more if (is_nan(actual)) then if (present(message)) then call test_failed(error, message, more) else call test_failed(error, "Exceptional value 'not a number' found", more) end if end if end subroutine check_float_exceptional_qp #endif subroutine check_complex_dp(error, actual, expected, message, more, thr, rel) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found floating point value complex(dp), intent(in) :: actual !> Expected floating point value complex(dp), intent(in) :: expected !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more !> Allowed threshold for matching floating point values real(dp), intent(in), optional :: thr !> Check for relative errors instead logical, intent(in), optional :: rel logical :: relative real(dp) :: diff, threshold call check(error, actual, message, more) if (allocated(error)) return if (present(thr)) then threshold = thr else threshold = epsilon(abs(expected)) end if if (present(rel)) then relative = rel else relative = .false. end if if (relative) then diff = abs(actual - expected) / abs(expected) else diff = abs(actual - expected) end if if (diff > threshold) then if (present(message)) then call test_failed(error, message, more) else if (relative) then call test_failed(error, & "Floating point value mismatch", & "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& "(difference: "//to_string(int(diff*100))//"%)", & more) else call test_failed(error, & "Floating point value mismatch", & "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& "(difference: "//to_string(diff)//")", & more) end if end if end if end subroutine check_complex_dp subroutine check_complex_exceptional_dp(error, actual, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found floating point value complex(dp), intent(in) :: actual !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more if (is_nan(real(actual)) .or. is_nan(aimag(actual))) then if (present(message)) then call test_failed(error, message, more) else call test_failed(error, "Exceptional value 'not a number' found", more) end if end if end subroutine check_complex_exceptional_dp subroutine check_complex_sp(error, actual, expected, message, more, thr, rel) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found floating point value complex(sp), intent(in) :: actual !> Expected floating point value complex(sp), intent(in) :: expected !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more !> Allowed threshold for matching floating point values real(sp), intent(in), optional :: thr !> Check for relative errors instead logical, intent(in), optional :: rel logical :: relative real(sp) :: diff, threshold call check(error, actual, message, more) if (allocated(error)) return if (present(thr)) then threshold = thr else threshold = epsilon(abs(expected)) end if if (present(rel)) then relative = rel else relative = .false. end if if (relative) then diff = abs(actual - expected) / abs(expected) else diff = abs(actual - expected) end if if (diff > threshold) then if (present(message)) then call test_failed(error, message, more) else if (relative) then call test_failed(error, & "Floating point value mismatch", & "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& "(difference: "//to_string(int(diff*100))//"%)", & more) else call test_failed(error, & "Floating point value mismatch", & "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& "(difference: "//to_string(diff)//")", & more) end if end if end if end subroutine check_complex_sp subroutine check_complex_exceptional_sp(error, actual, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found floating point value complex(sp), intent(in) :: actual !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more if (is_nan(real(actual)) .or. is_nan(aimag(actual))) then if (present(message)) then call test_failed(error, message, more) else call test_failed(error, "Exceptional value 'not a number' found", more) end if end if end subroutine check_complex_exceptional_sp #if WITH_XDP subroutine check_complex_xdp(error, actual, expected, message, more, thr, rel) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found floating point value complex(xdp), intent(in) :: actual !> Expected floating point value complex(xdp), intent(in) :: expected !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more !> Allowed threshold for matching floating point values real(xdp), intent(in), optional :: thr !> Check for relative errors instead logical, intent(in), optional :: rel logical :: relative real(xdp) :: diff, threshold call check(error, actual, message, more) if (allocated(error)) return if (present(thr)) then threshold = thr else threshold = epsilon(abs(expected)) end if if (present(rel)) then relative = rel else relative = .false. end if if (relative) then diff = abs(actual - expected) / abs(expected) else diff = abs(actual - expected) end if if (diff > threshold) then if (present(message)) then call test_failed(error, message, more) else if (relative) then call test_failed(error, & "Floating point value mismatch", & "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& "(difference: "//to_string(int(diff*100))//"%)", & more) else call test_failed(error, & "Floating point value mismatch", & "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& "(difference: "//to_string(diff)//")", & more) end if end if end if end subroutine check_complex_xdp subroutine check_complex_exceptional_xdp(error, actual, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found floating point value complex(xdp), intent(in) :: actual !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more if (is_nan(real(actual)) .or. is_nan(aimag(actual))) then if (present(message)) then call test_failed(error, message, more) else call test_failed(error, "Exceptional value 'not a number' found", more) end if end if end subroutine check_complex_exceptional_xdp #endif #if WITH_QP subroutine check_complex_qp(error, actual, expected, message, more, thr, rel) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found floating point value complex(qp), intent(in) :: actual !> Expected floating point value complex(qp), intent(in) :: expected !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more !> Allowed threshold for matching floating point values real(qp), intent(in), optional :: thr !> Check for relative errors instead logical, intent(in), optional :: rel logical :: relative real(qp) :: diff, threshold call check(error, actual, message, more) if (allocated(error)) return if (present(thr)) then threshold = thr else threshold = epsilon(abs(expected)) end if if (present(rel)) then relative = rel else relative = .false. end if if (relative) then diff = abs(actual - expected) / abs(expected) else diff = abs(actual - expected) end if if (diff > threshold) then if (present(message)) then call test_failed(error, message, more) else if (relative) then call test_failed(error, & "Floating point value mismatch", & "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& "(difference: "//to_string(int(diff*100))//"%)", & more) else call test_failed(error, & "Floating point value mismatch", & "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& "(difference: "//to_string(diff)//")", & more) end if end if end if end subroutine check_complex_qp subroutine check_complex_exceptional_qp(error, actual, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found floating point value complex(qp), intent(in) :: actual !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more if (is_nan(real(actual)) .or. is_nan(aimag(actual))) then if (present(message)) then call test_failed(error, message, more) else call test_failed(error, "Exceptional value 'not a number' found", more) end if end if end subroutine check_complex_exceptional_qp #endif subroutine check_float_absrel_dp(error, actual, expected, thr_abs, thr_rel, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found floating point value real(dp), intent(in) :: actual !> Expected floating point value real(dp), intent(in) :: expected !> Absolute threshold for matching floating point values real(dp), intent(in) :: thr_abs !> Relative threshold for matching floating point values real(dp), intent(in) :: thr_rel !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more real(dp) :: diff, threshold call check(error, actual, message, more) if (allocated(error)) return diff = abs(actual - expected) threshold = max(thr_abs, abs(thr_rel * expected)) if (diff > threshold) then if (present(message)) then call test_failed(error, message, more) else call test_failed(error, & "Floating point value mismatch", & "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& "(difference: "//to_string(diff)//")", & more) end if end if end subroutine check_float_absrel_dp subroutine check_float_absrel_sp(error, actual, expected, thr_abs, thr_rel, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found floating point value real(sp), intent(in) :: actual !> Expected floating point value real(sp), intent(in) :: expected !> Absolute threshold for matching floating point values real(sp), intent(in) :: thr_abs !> Relative threshold for matching floating point values real(sp), intent(in) :: thr_rel !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more real(sp) :: diff, threshold call check(error, actual, message, more) if (allocated(error)) return diff = abs(actual - expected) threshold = max(thr_abs, abs(thr_rel * expected)) if (diff > threshold) then if (present(message)) then call test_failed(error, message, more) else call test_failed(error, & "Floating point value mismatch", & "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& "(difference: "//to_string(diff)//")", & more) end if end if end subroutine check_float_absrel_sp #if WITH_XDP subroutine check_float_absrel_xdp(error, actual, expected, thr_abs, thr_rel, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found floating point value real(xdp), intent(in) :: actual !> Expected floating point value real(xdp), intent(in) :: expected !> Absolute threshold for matching floating point values real(xdp), intent(in) :: thr_abs !> Relative threshold for matching floating point values real(xdp), intent(in) :: thr_rel !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more real(xdp) :: diff, threshold call check(error, actual, message, more) if (allocated(error)) return diff = abs(actual - expected) threshold = max(thr_abs, abs(thr_rel * expected)) if (diff > threshold) then if (present(message)) then call test_failed(error, message, more) else call test_failed(error, & "Floating point value mismatch", & "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& "(difference: "//to_string(diff)//")", & more) end if end if end subroutine check_float_absrel_xdp #endif #if WITH_QP subroutine check_float_absrel_qp(error, actual, expected, thr_abs, thr_rel, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found floating point value real(qp), intent(in) :: actual !> Expected floating point value real(qp), intent(in) :: expected !> Absolute threshold for matching floating point values real(qp), intent(in) :: thr_abs !> Relative threshold for matching floating point values real(qp), intent(in) :: thr_rel !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more real(qp) :: diff, threshold call check(error, actual, message, more) if (allocated(error)) return diff = abs(actual - expected) threshold = max(thr_abs, abs(thr_rel * expected)) if (diff > threshold) then if (present(message)) then call test_failed(error, message, more) else call test_failed(error, & "Floating point value mismatch", & "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& "(difference: "//to_string(diff)//")", & more) end if end if end subroutine check_float_absrel_qp #endif subroutine check_complex_absrel_dp(error, actual, expected, thr_abs, thr_rel, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found floating point value complex(dp), intent(in) :: actual !> Expected floating point value complex(dp), intent(in) :: expected !> Absolute threshold for matching floating point values real(dp), intent(in) :: thr_abs !> Relative threshold for matching floating point values real(dp), intent(in) :: thr_rel !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more real(dp) :: diff, threshold call check(error, actual, message, more) if (allocated(error)) return diff = abs(actual - expected) threshold = max(thr_abs, abs(thr_rel * expected)) if (diff > threshold) then if (present(message)) then call test_failed(error, message, more) else call test_failed(error, & "Floating point value mismatch", & "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& "(difference: "//to_string(diff)//")", & more) end if end if end subroutine check_complex_absrel_dp subroutine check_complex_absrel_sp(error, actual, expected, thr_abs, thr_rel, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found floating point value complex(sp), intent(in) :: actual !> Expected floating point value complex(sp), intent(in) :: expected !> Absolute threshold for matching floating point values real(sp), intent(in) :: thr_abs !> Relative threshold for matching floating point values real(sp), intent(in) :: thr_rel !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more real(sp) :: diff, threshold call check(error, actual, message, more) if (allocated(error)) return diff = abs(actual - expected) threshold = max(thr_abs, abs(thr_rel * expected)) if (diff > threshold) then if (present(message)) then call test_failed(error, message, more) else call test_failed(error, & "Floating point value mismatch", & "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& "(difference: "//to_string(diff)//")", & more) end if end if end subroutine check_complex_absrel_sp #if WITH_XDP subroutine check_complex_absrel_xdp(error, actual, expected, thr_abs, thr_rel, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found floating point value complex(xdp), intent(in) :: actual !> Expected floating point value complex(xdp), intent(in) :: expected !> Absolute threshold for matching floating point values real(xdp), intent(in) :: thr_abs !> Relative threshold for matching floating point values real(xdp), intent(in) :: thr_rel !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more real(xdp) :: diff, threshold call check(error, actual, message, more) if (allocated(error)) return diff = abs(actual - expected) threshold = max(thr_abs, abs(thr_rel * expected)) if (diff > threshold) then if (present(message)) then call test_failed(error, message, more) else call test_failed(error, & "Floating point value mismatch", & "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& "(difference: "//to_string(diff)//")", & more) end if end if end subroutine check_complex_absrel_xdp #endif #if WITH_QP subroutine check_complex_absrel_qp(error, actual, expected, thr_abs, thr_rel, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found floating point value complex(qp), intent(in) :: actual !> Expected floating point value complex(qp), intent(in) :: expected !> Absolute threshold for matching floating point values real(qp), intent(in) :: thr_abs !> Relative threshold for matching floating point values real(qp), intent(in) :: thr_rel !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more real(qp) :: diff, threshold call check(error, actual, message, more) if (allocated(error)) return diff = abs(actual - expected) threshold = max(thr_abs, abs(thr_rel * expected)) if (diff > threshold) then if (present(message)) then call test_failed(error, message, more) else call test_failed(error, & "Floating point value mismatch", & "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& "(difference: "//to_string(diff)//")", & more) end if end if end subroutine check_complex_absrel_qp #endif subroutine check_int_i1(error, actual, expected, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found integer value integer(i1), intent(in) :: actual !> Expected integer value integer(i1), intent(in) :: expected !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more if (expected /= actual) then if (present(message)) then call test_failed(error, message, more) else call test_failed(error, & "Integer value mismatch", & "expected "//to_string(expected)//" but got "//to_string(actual), & more) end if end if end subroutine check_int_i1 subroutine check_int_i2(error, actual, expected, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found integer value integer(i2), intent(in) :: actual !> Expected integer value integer(i2), intent(in) :: expected !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more if (expected /= actual) then if (present(message)) then call test_failed(error, message, more) else call test_failed(error, & "Integer value mismatch", & "expected "//to_string(expected)//" but got "//to_string(actual), & more) end if end if end subroutine check_int_i2 subroutine check_int_i4(error, actual, expected, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found integer value integer(i4), intent(in) :: actual !> Expected integer value integer(i4), intent(in) :: expected !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more if (expected /= actual) then if (present(message)) then call test_failed(error, message, more) else call test_failed(error, & "Integer value mismatch", & "expected "//to_string(expected)//" but got "//to_string(actual), & more) end if end if end subroutine check_int_i4 subroutine check_int_i8(error, actual, expected, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found integer value integer(i8), intent(in) :: actual !> Expected integer value integer(i8), intent(in) :: expected !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more if (expected /= actual) then if (present(message)) then call test_failed(error, message, more) else call test_failed(error, & "Integer value mismatch", & "expected "//to_string(expected)//" but got "//to_string(actual), & more) end if end if end subroutine check_int_i8 subroutine check_bool(error, actual, expected, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found boolean value logical, intent(in) :: actual !> Expected boolean value logical, intent(in) :: expected !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more if (expected .neqv. actual) then if (present(message)) then call test_failed(error, message, more) else call test_failed(error, & "Logical value mismatch", & "expected "//merge("T", "F", expected)//" but got "//merge("T", "F", actual), & more) end if end if end subroutine check_bool subroutine check_string(error, actual, expected, message, more) !> Error handling type(error_type), allocatable, intent(out) :: error !> Found boolean value character(len=*), intent(in) :: actual !> Expected boolean value character(len=*), intent(in) :: expected !> A detailed message describing the error character(len=*), intent(in), optional :: message !> Another line of error message character(len=*), intent(in), optional :: more if (expected /= actual) then if (present(message)) then call test_failed(error, message, more) else call test_failed(error, & "Character value mismatch", & "expected '"//expected//"' but got '"//actual//"'", & more) end if end if end subroutine check_string subroutine test_failed(error, message, more, and_more) !> Error handling type(error_type), allocatable, intent(out) :: error !> A detailed message describing the error character(len=*), intent(in) :: message !> Another line of error message character(len=*), intent(in), optional :: more !> Another line of error message character(len=*), intent(in), optional :: and_more character(len=*), parameter :: skip = newline // repeat(" ", 11) allocate(error) error%stat = fatal error%message = message if (present(more)) then error%message = error%message // skip // more end if if (present(and_more)) then error%message = error%message // skip // and_more end if end subroutine test_failed !> A test is skipped because certain requirements are not met to run the actual test subroutine skip_test(error, message, more, and_more) !> Error handling type(error_type), allocatable, intent(out) :: error !> A detailed message describing the error character(len=*), intent(in) :: message !> Another line of error message character(len=*), intent(in), optional :: more !> Another line of error message character(len=*), intent(in), optional :: and_more call test_failed(error, message, more, and_more) error%stat = skipped end subroutine skip_test !> Obtain the command line argument at a given index subroutine get_argument(idx, arg) !> Index of command line argument, range [0:command_argument_count()] integer, intent(in) :: idx !> Command line argument character(len=:), allocatable, intent(out) :: arg integer :: length, stat call get_command_argument(idx, length=length, status=stat) if (stat /= success) return allocate(character(len=length) :: arg, stat=stat) if (stat /= success) return if (length > 0) then call get_command_argument(idx, arg, status=stat) if (stat /= success) deallocate(arg) end if end subroutine get_argument !> Obtain the value of an environment variable subroutine get_variable(var, val) !> Name of variable character(len=*), intent(in) :: var !> Value of variable character(len=:), allocatable, intent(out) :: val integer :: length, stat call get_environment_variable(var, length=length, status=stat) if (stat /= success) return allocate(character(len=length) :: val, stat=stat) if (stat /= success) return if (length > 0) then call get_environment_variable(var, val, status=stat) if (stat /= success) deallocate(val) end if end subroutine get_variable pure function integer_i1_to_string(val) result(string) integer, parameter :: ik = i1 !> Integer value to create string from integer(ik), intent(in) :: val !> String representation of integer character(len=:), allocatable :: string integer, parameter :: buffer_len = range(val)+2 character(len=buffer_len) :: buffer integer :: pos integer(ik) :: n character(len=1), parameter :: numbers(-9:0) = & ["9", "8", "7", "6", "5", "4", "3", "2", "1", "0"] if (val == 0_ik) then string = numbers(0) return end if n = sign(val, -1_ik) buffer = "" pos = buffer_len + 1 do while (n < 0_ik) pos = pos - 1 buffer(pos:pos) = numbers(mod(n, 10_ik)) n = n/10_ik end do if (val < 0_ik) then pos = pos - 1 buffer(pos:pos) = '-' end if string = buffer(pos:) end function integer_i1_to_string pure function integer_i2_to_string(val) result(string) integer, parameter :: ik = i2 !> Integer value to create string from integer(ik), intent(in) :: val !> String representation of integer character(len=:), allocatable :: string integer, parameter :: buffer_len = range(val)+2 character(len=buffer_len) :: buffer integer :: pos integer(ik) :: n character(len=1), parameter :: numbers(-9:0) = & ["9", "8", "7", "6", "5", "4", "3", "2", "1", "0"] if (val == 0_ik) then string = numbers(0) return end if n = sign(val, -1_ik) buffer = "" pos = buffer_len + 1 do while (n < 0_ik) pos = pos - 1 buffer(pos:pos) = numbers(mod(n, 10_ik)) n = n/10_ik end do if (val < 0_ik) then pos = pos - 1 buffer(pos:pos) = '-' end if string = buffer(pos:) end function integer_i2_to_string pure function integer_i4_to_string(val) result(string) integer, parameter :: ik = i4 !> Integer value to create string from integer(ik), intent(in) :: val !> String representation of integer character(len=:), allocatable :: string integer, parameter :: buffer_len = range(val)+2 character(len=buffer_len) :: buffer integer :: pos integer(ik) :: n character(len=1), parameter :: numbers(-9:0) = & ["9", "8", "7", "6", "5", "4", "3", "2", "1", "0"] if (val == 0_ik) then string = numbers(0) return end if n = sign(val, -1_ik) buffer = "" pos = buffer_len + 1 do while (n < 0_ik) pos = pos - 1 buffer(pos:pos) = numbers(mod(n, 10_ik)) n = n/10_ik end do if (val < 0_ik) then pos = pos - 1 buffer(pos:pos) = '-' end if string = buffer(pos:) end function integer_i4_to_string pure function integer_i8_to_string(val) result(string) integer, parameter :: ik = i8 !> Integer value to create string from integer(ik), intent(in) :: val !> String representation of integer character(len=:), allocatable :: string integer, parameter :: buffer_len = range(val)+2 character(len=buffer_len) :: buffer integer :: pos integer(ik) :: n character(len=1), parameter :: numbers(-9:0) = & ["9", "8", "7", "6", "5", "4", "3", "2", "1", "0"] if (val == 0_ik) then string = numbers(0) return end if n = sign(val, -1_ik) buffer = "" pos = buffer_len + 1 do while (n < 0_ik) pos = pos - 1 buffer(pos:pos) = numbers(mod(n, 10_ik)) n = n/10_ik end do if (val < 0_ik) then pos = pos - 1 buffer(pos:pos) = '-' end if string = buffer(pos:) end function integer_i8_to_string pure function real_sp_to_string(val) result(string) real(sp), intent(in) :: val character(len=:), allocatable :: string integer, parameter :: buffer_len = 128 character(len=buffer_len) :: buffer write(buffer, '(g0)') val string = trim(buffer) end function real_sp_to_string pure function real_dp_to_string(val) result(string) real(dp), intent(in) :: val character(len=:), allocatable :: string integer, parameter :: buffer_len = 128 character(len=buffer_len) :: buffer write(buffer, '(g0)') val string = trim(buffer) end function real_dp_to_string #if WITH_XDP pure function real_xdp_to_string(val) result(string) real(xdp), intent(in) :: val character(len=:), allocatable :: string integer, parameter :: buffer_len = 128 character(len=buffer_len) :: buffer write(buffer, '(g0)') val string = trim(buffer) end function real_xdp_to_string #endif #if WITH_QP pure function real_qp_to_string(val) result(string) real(qp), intent(in) :: val character(len=:), allocatable :: string integer, parameter :: buffer_len = 128 character(len=buffer_len) :: buffer write(buffer, '(g0)') val string = trim(buffer) end function real_qp_to_string #endif pure function complex_sp_to_string(val) result(string) complex(sp), intent(in) :: val character(len=:), allocatable :: string string = "("//to_string(real(val))//", "//to_string(aimag(val))//")" end function complex_sp_to_string pure function complex_dp_to_string(val) result(string) complex(dp), intent(in) :: val character(len=:), allocatable :: string string = "("//to_string(real(val))//", "//to_string(aimag(val))//")" end function complex_dp_to_string #if WITH_XDP pure function complex_xdp_to_string(val) result(string) complex(xdp), intent(in) :: val character(len=:), allocatable :: string string = "("//to_string(real(val))//", "//to_string(aimag(val))//")" end function complex_xdp_to_string #endif #if WITH_QP pure function complex_qp_to_string(val) result(string) complex(qp), intent(in) :: val character(len=:), allocatable :: string string = "("//to_string(real(val))//", "//to_string(aimag(val))//")" end function complex_qp_to_string #endif !> Clear error type after it has been handled. subroutine clear_error(error) !> Error handling type(error_type), intent(inout) :: error if (error%stat /= success) then error%stat = success end if if (allocated(error%message)) then deallocate(error%message) end if end subroutine clear_error !> Finalizer of the error type, in case the error is not correctly cleared it will !> be escalated at runtime in a fatal way subroutine escalate_error(error) !> Error handling type(error_type), intent(inout) :: error if (error%stat /= success) then write(error_unit, '(a)') "[Fatal] Uncaught error" if (allocated(error%message)) then write(error_unit, '(a, 1x, i0, *(1x, a))') & "Code:", error%stat, "Message:", error%message end if error stop end if end subroutine escalate_error !> Determine whether a value is not a number elemental function is_nan_sp(val) result(is_nan) #if WITH_IEEE_IS_NAN use, intrinsic :: ieee_arithmetic, only : ieee_is_nan #endif !> Value to check real(sp), intent(in) :: val !> Value is not a number logical :: is_nan #if WITH_IEEE_IS_NAN is_nan = ieee_is_nan(val) #else is_nan = .not.((val <= huge(val) .and. val >= -huge(val)) .or. abs(val) > huge(val)) #endif end function is_nan_sp !> Determine whether a value is not a number elemental function is_nan_dp(val) result(is_nan) #if WITH_IEEE_IS_NAN use, intrinsic :: ieee_arithmetic, only : ieee_is_nan #endif !> Value to check real(dp), intent(in) :: val !> Value is not a number logical :: is_nan #if WITH_IEEE_IS_NAN is_nan = ieee_is_nan(val) #else is_nan = .not.((val <= huge(val) .and. val >= -huge(val)) .or. abs(val) > huge(val)) #endif end function is_nan_dp #if WITH_XDP !> Determine whether a value is not a number elemental function is_nan_xdp(val) result(is_nan) #if WITH_IEEE_IS_NAN use, intrinsic :: ieee_arithmetic, only : ieee_is_nan #endif !> Value to check real(xdp), intent(in) :: val !> Value is not a number logical :: is_nan #if WITH_IEEE_IS_NAN is_nan = ieee_is_nan(val) #else is_nan = .not.((val <= huge(val) .and. val >= -huge(val)) .or. abs(val) > huge(val)) #endif end function is_nan_xdp #endif #if WITH_QP !> Determine whether a value is not a number elemental function is_nan_qp(val) result(is_nan) #if WITH_IEEE_IS_NAN use, intrinsic :: ieee_arithmetic, only : ieee_is_nan #endif !> Value to check real(qp), intent(in) :: val !> Value is not a number logical :: is_nan #if WITH_IEEE_IS_NAN is_nan = ieee_is_nan(val) #else is_nan = .not.((val <= huge(val) .and. val >= -huge(val)) .or. abs(val) > huge(val)) #endif end function is_nan_qp #endif !> Initialize color output subroutine init_color_output(use_color) !> Enable color output logical, intent(in) :: use_color color = new_color_output(use_color) end subroutine init_color_output !> Create a new colorizer object function new_color_output(use_color) result(new) !> Enable color output logical, intent(in) :: use_color !> New instance of the colorizer type(color_output) :: new type(color_code), parameter :: & reset = color_code(style=0_i1), & bold = color_code(style=1_i1), & dim = color_code(style=2_i1), & italic = color_code(style=3_i1), & underline = color_code(style=4_i1), & blink = color_code(style=5_i1), & reverse = color_code(style=7_i1), & hidden = color_code(style=8_i1) type(color_code), parameter :: & black = color_code(fg=0_i1), & red = color_code(fg=1_i1), & green = color_code(fg=2_i1), & yellow = color_code(fg=3_i1), & blue = color_code(fg=4_i1), & magenta = color_code(fg=5_i1), & cyan = color_code(fg=6_i1), & white = color_code(fg=7_i1) type(color_code), parameter :: & bg_black = color_code(bg=0_i1), & bg_red = color_code(bg=1_i1), & bg_green = color_code(bg=2_i1), & bg_yellow = color_code(bg=3_i1), & bg_blue = color_code(bg=4_i1), & bg_magenta = color_code(bg=5_i1), & bg_cyan = color_code(bg=6_i1), & bg_white = color_code(bg=7_i1) if (use_color) then new%reset = reset new%bold = bold new%dim = dim new%italic = italic new%underline = underline new%blink = blink new%reverse = reverse new%hidden = hidden new%black = black new%red = red new%green = green new%yellow = yellow new%blue = blue new%magenta = magenta new%cyan = cyan new%white = white new%bg_black = bg_black new%bg_red = bg_red new%bg_green = bg_green new%bg_yellow = bg_yellow new%bg_blue = bg_blue new%bg_magenta = bg_magenta new%bg_cyan = bg_cyan new%bg_white = bg_white end if end function new_color_output !> Add two escape sequences, attributes in the right value override the left value ones. pure function add_color(lval, rval) result(code) !> First escape code type(color_code), intent(in) :: lval !> Second escape code type(color_code), intent(in) :: rval !> Combined escape code type(color_code) :: code code = color_code( & style=merge(rval%style, lval%style, rval%style >= 0), & fg=merge(rval%fg, lval%fg, rval%fg >= 0), & bg=merge(rval%bg, lval%bg, rval%bg >= 0)) end function add_color !> Concatenate an escape code with a string and turn it into an actual escape sequence pure function concat_color_left(lval, code) result(str) !> String to add the escape code to character(len=*), intent(in) :: lval !> Escape sequence type(color_code), intent(in) :: code !> Concatenated string character(len=:), allocatable :: str str = lval // escape_color(code) end function concat_color_left !> Concatenate an escape code with a string and turn it into an actual escape sequence pure function concat_color_right(code, rval) result(str) !> String to add the escape code to character(len=*), intent(in) :: rval !> Escape sequence type(color_code), intent(in) :: code !> Concatenated string character(len=:), allocatable :: str str = escape_color(code) // rval end function concat_color_right !> Transform a color code into an actual ANSI escape sequence pure function escape_color(code) result(str) !> Color code to be used type(color_code), intent(in) :: code !> ANSI escape sequence representing the color code character(len=:), allocatable :: str character, parameter :: chars(0:9) = & ["0", "1", "2", "3", "4", "5", "6", "7", "8", "9"] if (anycolor(code)) then str = achar(27) // "[0" ! Always reset the style if (code%style > 0 .and. code%style < 10) str = str // ";" // chars(code%style) if (code%fg >= 0 .and. code%fg < 10) str = str // ";3" // chars(code%fg) if (code%bg >= 0 .and. code%bg < 10) str = str // ";4" // chars(code%bg) str = str // "m" else str = "" end if end function escape_color !> Check whether the code describes any color or is just a stub pure function anycolor(code) !> Escape sequence type(color_code), intent(in) :: code !> Any color / style is active logical :: anycolor anycolor = code%fg >= 0 .or. code%bg >= 0 .or. code%style >= 0 end function anycolor end module testdrive fortran-testdrive-0.6.0/meson.build0000664000175000017500000000641515201524466017540 0ustar alastairalastair# This file is part of test-drive. # SPDX-Identifier: Apache-2.0 OR MIT # # Licensed under either of Apache License, Version 2.0 or MIT license # at your option; you may not use this file except in compliance with # the License. # # Unless required by applicable law or agreed to in writing, software # distributed under the License is distributed on an "AS IS" BASIS, # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. # See the License for the specific language governing permissions and # limitations under the License. project( 'test-drive', 'fortran', version: '0.6.0', license: 'Apache-2.0 OR MIT', meson_version: '>=0.53', default_options: [ 'buildtype=debugoptimized', 'default_library=both', ], ) install = not (meson.is_subproject() and get_option('default_library') == 'static') # General configuration information lib_deps = [] subdir('config') # Collect source of the project srcs = [] subdir('src') # MCTC library target testdrive_lib = library( meson.project_name(), sources: srcs, version: meson.project_version(), dependencies: lib_deps, install: install, ) # Export dependency for other projects and test suite testdrive_inc = testdrive_lib.private_dir_include() testdrive_dep = declare_dependency( link_with: testdrive_lib, include_directories: testdrive_inc, dependencies: lib_deps, ) # Package the license files testdrive_lic = files( 'LICENSE-Apache', 'LICENSE-MIT', ) if install # Distribute the license files in share/licenses/ install_data( testdrive_lic, install_dir: get_option('datadir')/'licenses'/meson.project_name() ) module_id = meson.project_name() / fc_id + '-' + fc.version() meson.add_install_script( 'config'/'install-mod.py', get_option('includedir') / module_id, ) pkg = import('pkgconfig') pkg.generate( testdrive_lib, description: 'The simple testing framework', subdirs: ['', module_id], ) cmake_data = configuration_data({ 'PROJECT_NAME': meson.project_name(), 'PROJECT_VERSION': meson.project_version(), 'PACKAGE_INIT': 'cmake_minimum_required(VERSION 3.9...3.31 FATAL_ERROR)', 'CMAKE_SIZEOF_VOID_P': '8', 'CMAKE_INSTALL_PREFIX': get_option('prefix'), 'CMAKE_INSTALL_INCLUDEDIR': get_option('includedir'), 'CMAKE_INSTALL_LIBDIR': get_option('libdir'), 'TESTDRIVE_WITH_QP': with_qp ? 'ON' : 'OFF', 'TESTDRIVE_WITH_XDP': with_xdp ? 'ON' : 'OFF', 'TESTDRIVE_WITH_IEEE_IS_NAN': with_ieee_is_nan ? 'ON' : 'OFF', 'module-dir': module_id, }) cmake_files = [ configure_file( input: files('config'/'template-config.cmake'), output: meson.project_name() + '-config.cmake', configuration: cmake_data, ), configure_file( input: files('config'/'template-version.cmake'), output: meson.project_name() + '-config-version.cmake', configuration: cmake_data, ), configure_file( input: files('config'/'template-targets.cmake'), output: meson.project_name() + '-targets.cmake', configuration: cmake_data, ), ] install_data( cmake_files, install_dir: get_option('libdir')/'cmake'/meson.project_name() ) endif # add the testsuite if get_option('testing').auto() ? not meson.is_subproject() : get_option('testing').enabled() subdir('test') endif fortran-testdrive-0.6.0/test/0000775000175000017500000000000015201524466016347 5ustar alastairalastairfortran-testdrive-0.6.0/test/test_check.F900000664000175000017500000013356415201524466020757 0ustar alastairalastair! This file is part of test-drive. ! SPDX-Identifier: Apache-2.0 OR MIT ! ! Licensed under either of Apache License, Version 2.0 or MIT license ! at your option; you may not use this file except in compliance with ! the License. ! ! Unless required by applicable law or agreed to in writing, software ! distributed under the License is distributed on an "AS IS" BASIS, ! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ! See the License for the specific language governing permissions and ! limitations under the License. !# Enable support for quadruple precision #ifndef WITH_QP #define WITH_QP 0 #endif !# Enable support for extended double precision #ifndef WITH_XDP #define WITH_XDP 0 #endif module test_check use, intrinsic :: ieee_arithmetic, only : ieee_value, ieee_quiet_nan use testdrive, only : new_unittest, unittest_type, error_type, check, skip_test, to_string implicit none private public :: collect_check !> Single precision real numbers integer, parameter :: sp = selected_real_kind(6) !> Double precision real numbers integer, parameter :: dp = selected_real_kind(15) #if WITH_XDP !> Extended double precision real numbers integer, parameter :: xdp = selected_real_kind(18) #endif #if WITH_QP !> Quadruple precision real numbers integer, parameter :: qp = selected_real_kind(33) #endif !> Char length for integers integer, parameter :: i1 = selected_int_kind(2) !> Short length for integers integer, parameter :: i2 = selected_int_kind(4) !> Length of default integers integer, parameter :: i4 = selected_int_kind(9) !> Long length for integers integer, parameter :: i8 = selected_int_kind(18) contains !> Collect all exported unit tests subroutine collect_check(testsuite) !> Collection of tests type(unittest_type), allocatable, intent(out) :: testsuite(:) testsuite = [ & new_unittest("success", test_success), & new_unittest("failure", test_failure, should_fail=.true.), & new_unittest("failure-message", test_failure_message, should_fail=.true.), & new_unittest("failure-with-more", test_failure_with_more, should_fail=.true.), & new_unittest("skipped", test_skipped), & new_unittest("expression", test_expression), & new_unittest("expression-fail", test_expression_fail, should_fail=.true.), & new_unittest("expression-message", test_expression_message, should_fail=.true.), & new_unittest("expression-with-more", test_expression_with_more, should_fail=.true.), & new_unittest("real-single-abs", test_rsp_abs), & new_unittest("real-single-rel", test_rsp_rel), & new_unittest("real-single-nan", test_rsp_nan, should_fail=.true.), & new_unittest("real-single-abs-fail", test_rsp_abs_fail, should_fail=.true.), & new_unittest("real-single-rel-fail", test_rsp_rel_fail, should_fail=.true.), & new_unittest("real-single-abs-message", test_rsp_abs_message, should_fail=.true.), & new_unittest("real-single-nan-message", test_rsp_nan_message, should_fail=.true.), & new_unittest("real-double-abs", test_rdp_abs), & new_unittest("real-double-rel", test_rdp_rel), & new_unittest("real-double-nan", test_rdp_nan, should_fail=.true.), & new_unittest("real-double-abs-fail", test_rdp_abs_fail, should_fail=.true.), & new_unittest("real-double-rel-fail", test_rdp_rel_fail, should_fail=.true.), & new_unittest("real-double-abs-message", test_rdp_abs_message, should_fail=.true.), & new_unittest("real-double-nan-message", test_rdp_nan_message, should_fail=.true.), & new_unittest("real-xdouble-abs", test_rxdp_abs), & new_unittest("real-xdouble-rel", test_rxdp_rel), & new_unittest("real-xdouble-nan", test_rxdp_nan, should_fail=.true.), & new_unittest("real-xdouble-abs-fail", test_rxdp_abs_fail, should_fail=.true.), & new_unittest("real-xdouble-rel-fail", test_rxdp_rel_fail, should_fail=.true.), & new_unittest("real-xdouble-abs-message", test_rxdp_abs_message, should_fail=.true.), & new_unittest("real-xdouble-nan-message", test_rxdp_nan_message, should_fail=.true.), & new_unittest("real-quadruple-abs", test_rqp_abs), & new_unittest("real-quadruple-rel", test_rqp_rel), & new_unittest("real-quadruple-nan", test_rqp_nan, should_fail=.true.), & new_unittest("real-quadruple-abs-fail", test_rqp_abs_fail, should_fail=.true.), & new_unittest("real-quadruple-rel-fail", test_rqp_rel_fail, should_fail=.true.), & new_unittest("real-quadruple-abs-message", test_rqp_abs_message, should_fail=.true.), & new_unittest("real-quadruple-nan-message", test_rqp_nan_message, should_fail=.true.), & new_unittest("complex-single-abs", test_csp_abs), & new_unittest("complex-single-rel", test_csp_rel), & new_unittest("complex-single-nan", test_csp_nan, should_fail=.true.), & new_unittest("complex-single-abs-fail", test_csp_abs_fail, should_fail=.true.), & new_unittest("complex-single-rel-fail", test_csp_rel_fail, should_fail=.true.), & new_unittest("complex-single-abs-message", test_csp_abs_message, should_fail=.true.), & new_unittest("complex-single-nan-message", test_csp_nan_message, should_fail=.true.), & new_unittest("complex-double-abs", test_cdp_abs), & new_unittest("complex-double-rel", test_cdp_rel), & new_unittest("complex-double-nan", test_cdp_nan, should_fail=.true.), & new_unittest("complex-double-abs-fail", test_cdp_abs_fail, should_fail=.true.), & new_unittest("complex-double-rel-fail", test_cdp_rel_fail, should_fail=.true.), & new_unittest("complex-double-abs-message", test_cdp_abs_message, should_fail=.true.), & new_unittest("complex-double-nan-message", test_cdp_nan_message, should_fail=.true.), & new_unittest("complex-xdouble-abs", test_cxdp_abs), & new_unittest("complex-xdouble-rel", test_cxdp_rel), & new_unittest("complex-xdouble-nan", test_cxdp_nan, should_fail=.true.), & new_unittest("complex-xdouble-abs-fail", test_cxdp_abs_fail, should_fail=.true.), & new_unittest("complex-xdouble-rel-fail", test_cxdp_rel_fail, should_fail=.true.), & new_unittest("complex-xdouble-abs-message", test_cxdp_abs_message, should_fail=.true.), & new_unittest("complex-xdouble-nan-message", test_cxdp_nan_message, should_fail=.true.), & new_unittest("complex-quadruple-abs", test_cqp_abs), & new_unittest("complex-quadruple-rel", test_cqp_rel), & new_unittest("complex-quadruple-nan", test_cqp_nan, should_fail=.true.), & new_unittest("complex-quadruple-abs-fail", test_cqp_abs_fail, should_fail=.true.), & new_unittest("complex-quadruple-rel-fail", test_cqp_rel_fail, should_fail=.true.), & new_unittest("complex-quadruple-abs-message", test_cqp_abs_message, should_fail=.true.), & new_unittest("complex-quadruple-nan-message", test_cqp_nan_message, should_fail=.true.), & new_unittest("integer-char", test_i1), & new_unittest("integer-char-fail", test_i1_fail, should_fail=.true.), & new_unittest("integer-char-message", test_i1_message, should_fail=.true.), & new_unittest("integer-char-with-more", test_i1_with_more, should_fail=.true.), & new_unittest("integer-short", test_i2), & new_unittest("integer-short-fail", test_i2_fail, should_fail=.true.), & new_unittest("integer-short-message", test_i2_message, should_fail=.true.), & new_unittest("integer-short-with-more", test_i2_with_more, should_fail=.true.), & new_unittest("integer-default", test_i4), & new_unittest("integer-default-fail", test_i4_fail, should_fail=.true.), & new_unittest("integer-default-message", test_i4_message, should_fail=.true.), & new_unittest("integer-default-with-more", test_i4_with_more, should_fail=.true.), & new_unittest("integer-long", test_i8), & new_unittest("integer-long-fail", test_i8_fail, should_fail=.true.), & new_unittest("integer-long-message", test_i8_message, should_fail=.true.), & new_unittest("integer-long-with-more", test_i8_with_more, should_fail=.true.), & new_unittest("logical-default-true", test_l4_true), & new_unittest("logical-default-false", test_l4_false), & new_unittest("logical-default-fail", test_l4_fail, should_fail=.true.), & new_unittest("logical-default-message", test_l4_message, should_fail=.true.), & new_unittest("logical-default-with-more", test_l4_with_more, should_fail=.true.), & new_unittest("character", test_char), & new_unittest("character-fail", test_char_fail, should_fail=.true.), & new_unittest("character-message", test_char_message, should_fail=.true.), & new_unittest("character-with-more", test_char_with_more, should_fail=.true.), & new_unittest("character-with-more", test_char_with_more, should_fail=.true.), & new_unittest("string-i1", test_string_i1), & new_unittest("string-i2", test_string_i2), & new_unittest("string-i4", test_string_i4), & new_unittest("string-i8", test_string_i8), & new_unittest("real-single-absrel-relpass-absfail", test_rsp_absrel_relpass_absfail), & new_unittest("real-single-absrel-relfail-abspass", test_rsp_absrel_relfail_abspass), & new_unittest("real-single-absrel-fail", test_rsp_absrel_fail, should_fail=.true.), & new_unittest("real-double-absrel-relpass-absfail", test_rdp_absrel_relpass_absfail), & new_unittest("real-double-absrel-relfail-abspass", test_rdp_absrel_relfail_abspass), & new_unittest("real-double-absrel-fail", test_rdp_absrel_fail, should_fail=.true.), & new_unittest("complex-single-absrel-relpass-absfail", test_csp_absrel_relpass_absfail), & new_unittest("complex-single-absrel-relfail-abspass", test_csp_absrel_relfail_abspass), & new_unittest("complex-single-absrel-fail", test_csp_absrel_fail, should_fail=.true.), & new_unittest("complex-double-absrel-relpass-absfail", test_cdp_absrel_relpass_absfail), & new_unittest("complex-double-absrel-relfail-abspass", test_cdp_absrel_relfail_abspass), & new_unittest("complex-double-absrel-fail", test_cdp_absrel_fail, should_fail=.true.), & new_unittest("real-xdouble-absrel-relpass-absfail", test_rxdp_absrel_relpass_absfail), & new_unittest("real-xdouble-absrel-relfail-abspass", test_rxdp_absrel_relfail_abspass), & new_unittest("real-xdouble-absrel-fail", test_rxdp_absrel_fail, should_fail=.true.), & new_unittest("real-quadruple-absrel-relpass-absfail", test_rqp_absrel_relpass_absfail), & new_unittest("real-quadruple-absrel-relfail-abspass", test_rqp_absrel_relfail_abspass), & new_unittest("real-quadruple-absrel-fail", test_rqp_absrel_fail, should_fail=.true.), & new_unittest("complex-xdouble-absrel-relpass-absfail", test_cxdp_absrel_relpass_absfail), & new_unittest("complex-xdouble-absrel-relfail-abspass", test_cxdp_absrel_relfail_abspass), & new_unittest("complex-xdouble-absrel-fail", test_cxdp_absrel_fail, should_fail=.true.), & new_unittest("complex-quadruple-absrel-relpass-absfail", test_cqp_absrel_relpass_absfail), & new_unittest("complex-quadruple-absrel-relfail-abspass", test_cqp_absrel_relfail_abspass), & new_unittest("complex-quadruple-absrel-fail", test_cqp_absrel_fail, should_fail=.true.) & ] end subroutine collect_check subroutine test_success(error) !> Error handling type(error_type), allocatable, intent(out) :: error call check(error, 0) end subroutine test_success subroutine test_failure(error) !> Error handling type(error_type), allocatable, intent(out) :: error call check(error, 7) end subroutine test_failure subroutine test_failure_message(error) !> Error handling type(error_type), allocatable, intent(out) :: error call check(error, 4, "Custom message describing the error") end subroutine test_failure_message subroutine test_failure_with_more(error) !> Error handling type(error_type), allocatable, intent(out) :: error call check(error, 3, more="with an additional descriptive message here") end subroutine test_failure_with_more subroutine test_skipped(error) !> Error handling type(error_type), allocatable, intent(out) :: error call skip_test(error, "This test is always skipped") end subroutine test_skipped subroutine test_expression(error) !> Error handling type(error_type), allocatable, intent(out) :: error call check(error, index("info!", "!") > 0) end subroutine test_expression subroutine test_expression_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error call check(error, index("info!", "?") > 0) end subroutine test_expression_fail subroutine test_expression_message(error) !> Error handling type(error_type), allocatable, intent(out) :: error call check(error, index("info!", "!") == 0, 'index("info!", "!") == 0') end subroutine test_expression_message subroutine test_expression_with_more(error) !> Error handling type(error_type), allocatable, intent(out) :: error call check(error, index("info!", "?") /= 0, more='index("info!", "?")') end subroutine test_expression_with_more subroutine test_rsp_abs(error) !> Error handling type(error_type), allocatable, intent(out) :: error real(sp) :: val val = 3.3_sp call check(error, val, 3.3_sp, thr=sqrt(epsilon(val))) end subroutine test_rsp_abs subroutine test_rsp_nan(error) !> Error handling type(error_type), allocatable, intent(out) :: error real(sp) :: val val = ieee_value(val, ieee_quiet_nan) call check(error, val, 3.3_sp, rel=.true.) end subroutine test_rsp_nan subroutine test_rsp_rel(error) !> Error handling type(error_type), allocatable, intent(out) :: error real(sp) :: val val = 3.3_sp call check(error, val, 3.3_sp, rel=.true.) end subroutine test_rsp_rel subroutine test_rsp_abs_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error real(sp) :: val val = 1.0_sp call check(error, val, 2.0_sp) end subroutine test_rsp_abs_fail subroutine test_rsp_rel_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error real(sp) :: val val = 1.0_sp call check(error, val, 1.5_sp, rel=.true.) end subroutine test_rsp_rel_fail subroutine test_rsp_abs_message(error) !> Error handling type(error_type), allocatable, intent(out) :: error real(sp) :: val val = 1.0_sp call check(error, val, 1.5_sp, message="Actual value is not 1.5") end subroutine test_rsp_abs_message subroutine test_rsp_nan_message(error) !> Error handling type(error_type), allocatable, intent(out) :: error real(sp) :: val val = ieee_value(val, ieee_quiet_nan) call check(error, val, message="Actual value is not a number") end subroutine test_rsp_nan_message subroutine test_rdp_abs(error) !> Error handling type(error_type), allocatable, intent(out) :: error real(dp) :: val val = 3.3_dp call check(error, val, 3.3_dp, thr=sqrt(epsilon(val))) end subroutine test_rdp_abs subroutine test_rdp_rel(error) !> Error handling type(error_type), allocatable, intent(out) :: error real(dp) :: val val = 3.3_dp call check(error, val, 3.3_dp, rel=.true.) end subroutine test_rdp_rel subroutine test_rdp_nan(error) !> Error handling type(error_type), allocatable, intent(out) :: error real(dp) :: val val = ieee_value(val, ieee_quiet_nan) call check(error, val, 3.3_dp, rel=.true.) end subroutine test_rdp_nan subroutine test_rdp_abs_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error real(dp) :: val val = 1.0_dp call check(error, val, 2.0_dp) end subroutine test_rdp_abs_fail subroutine test_rdp_rel_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error real(dp) :: val val = 1.0_dp call check(error, val, 1.5_dp, rel=.true.) end subroutine test_rdp_rel_fail subroutine test_rdp_abs_message(error) !> Error handling type(error_type), allocatable, intent(out) :: error real(dp) :: val val = 1.0_dp call check(error, val, 1.5_dp, message="Actual value is not 1.5") end subroutine test_rdp_abs_message subroutine test_rdp_nan_message(error) !> Error handling type(error_type), allocatable, intent(out) :: error real(dp) :: val val = ieee_value(val, ieee_quiet_nan) call check(error, val, message="Actual value is not a number") end subroutine test_rdp_nan_message subroutine test_rxdp_abs(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_XDP real(xdp) :: val val = 3.3_xdp call check(error, val, 3.3_xdp, thr=sqrt(epsilon(val))) #else call skip_test(error, "Extended double precision is not enabled") #endif end subroutine test_rxdp_abs subroutine test_rxdp_rel(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_XDP real(xdp) :: val val = 3.3_xdp call check(error, val, 3.3_xdp, rel=.true.) #else call skip_test(error, "Extended double precision is not enabled") #endif end subroutine test_rxdp_rel subroutine test_rxdp_nan(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_XDP real(xdp) :: val val = ieee_value(val, ieee_quiet_nan) call check(error, val, 3.3_xdp, rel=.true.) #else call skip_test(error, "Extended double precision is not enabled") #endif end subroutine test_rxdp_nan subroutine test_rxdp_abs_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_XDP real(xdp) :: val val = 1.0_xdp call check(error, val, 2.0_xdp) #else call skip_test(error, "Extended double precision is not enabled") #endif end subroutine test_rxdp_abs_fail subroutine test_rxdp_rel_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_XDP real(xdp) :: val val = 1.0_xdp call check(error, val, 1.5_xdp, rel=.true.) #else call skip_test(error, "Extended double precision is not enabled") #endif end subroutine test_rxdp_rel_fail subroutine test_rxdp_abs_message(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_XDP real(xdp) :: val val = 1.0_xdp call check(error, val, 1.5_xdp, message="Actual value is not 1.5") #else call skip_test(error, "Extended double precision is not enabled") #endif end subroutine test_rxdp_abs_message subroutine test_rxdp_nan_message(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_XDP real(xdp) :: val val = ieee_value(val, ieee_quiet_nan) call check(error, val, message="Actual value is not a number") #else call skip_test(error, "Extended double precision is not enabled") #endif end subroutine test_rxdp_nan_message subroutine test_rqp_abs(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_QP real(qp) :: val val = 3.3_qp call check(error, val, 3.3_qp, thr=sqrt(epsilon(val))) #else call skip_test(error, "Quadruple precision is not enabled") #endif end subroutine test_rqp_abs subroutine test_rqp_rel(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_QP real(qp) :: val val = 3.3_qp call check(error, val, 3.3_qp, rel=.true.) #else call skip_test(error, "Quadruple precision is not enabled") #endif end subroutine test_rqp_rel subroutine test_rqp_nan(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_QP real(qp) :: val val = ieee_value(val, ieee_quiet_nan) call check(error, val, 3.3_qp, rel=.true.) #else call skip_test(error, "Quadruple precision is not enabled") #endif end subroutine test_rqp_nan subroutine test_rqp_abs_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_QP real(qp) :: val val = 1.0_qp call check(error, val, 2.0_qp) #else call skip_test(error, "Quadruple precision is not enabled") #endif end subroutine test_rqp_abs_fail subroutine test_rqp_rel_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_QP real(qp) :: val val = 1.0_qp call check(error, val, 1.5_qp, rel=.true.) #else call skip_test(error, "Quadruple precision is not enabled") #endif end subroutine test_rqp_rel_fail subroutine test_rqp_abs_message(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_QP real(qp) :: val val = 1.0_qp call check(error, val, 1.5_qp, message="Actual value is not 1.5") #else call skip_test(error, "Quadruple precision is not enabled") #endif end subroutine test_rqp_abs_message subroutine test_rqp_nan_message(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_QP real(qp) :: val val = ieee_value(val, ieee_quiet_nan) call check(error, val, message="Actual value is not a number") #else call skip_test(error, "Quadruple precision is not enabled") #endif end subroutine test_rqp_nan_message subroutine test_csp_abs(error) !> Error handling type(error_type), allocatable, intent(out) :: error complex(sp) :: val val = cmplx(3.3_sp, 1.0_sp, sp) call check(error, val, cmplx(3.3_sp, 1.0_sp, sp), thr=sqrt(epsilon(abs(val)))) end subroutine test_csp_abs subroutine test_csp_nan(error) !> Error handling type(error_type), allocatable, intent(out) :: error complex(sp) :: val val = cmplx(ieee_value(0.0_sp, ieee_quiet_nan), & & ieee_value(0.0_sp, ieee_quiet_nan), sp) call check(error, val, cmplx(3.3_sp, 1.0_sp, sp), rel=.true.) end subroutine test_csp_nan subroutine test_csp_rel(error) !> Error handling type(error_type), allocatable, intent(out) :: error complex(sp) :: val val = cmplx(3.3_sp, 1.0_sp, sp) call check(error, val, cmplx(3.3_sp, 1.0_sp, sp), rel=.true.) end subroutine test_csp_rel subroutine test_csp_abs_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error complex(sp) :: val val = cmplx(1.0_sp, 2.0_sp, sp) call check(error, val, cmplx(2.0_sp, 1.0_sp, sp)) end subroutine test_csp_abs_fail subroutine test_csp_rel_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error complex(sp) :: val val = cmplx(1.0_sp, 1.5_sp, sp) call check(error, val, cmplx(1.5_sp, 1.0_sp, sp), rel=.true.) end subroutine test_csp_rel_fail subroutine test_csp_abs_message(error) !> Error handling type(error_type), allocatable, intent(out) :: error complex(sp) :: val val = cmplx(1.0_sp, 1.5_sp, sp) call check(error, val, cmplx(1.5_sp, 1.0_sp, sp), message="Actual value is not 1.5+1.0i") end subroutine test_csp_abs_message subroutine test_csp_nan_message(error) !> Error handling type(error_type), allocatable, intent(out) :: error complex(sp) :: val val = cmplx(ieee_value(0.0_sp, ieee_quiet_nan), 0.0_sp, sp) call check(error, val, message="Actual value is not a number") end subroutine test_csp_nan_message subroutine test_cdp_abs(error) !> Error handling type(error_type), allocatable, intent(out) :: error complex(dp) :: val val = cmplx(3.3_dp, 1.0_dp, dp) call check(error, val, cmplx(3.3_dp, 1.0_dp, dp), thr=sqrt(epsilon(real(val)))) end subroutine test_cdp_abs subroutine test_cdp_rel(error) !> Error handling type(error_type), allocatable, intent(out) :: error complex(dp) :: val val = cmplx(3.3_dp, 1.0_dp, dp) call check(error, val, cmplx(3.3_dp, 1.0_dp, dp), rel=.true.) end subroutine test_cdp_rel subroutine test_cdp_nan(error) !> Error handling type(error_type), allocatable, intent(out) :: error complex(dp) :: val val = cmplx(ieee_value(0.0_dp, ieee_quiet_nan), 0.0_dp, dp) call check(error, val, cmplx(3.3_dp, 1.0_dp, dp), rel=.true.) end subroutine test_cdp_nan subroutine test_cdp_abs_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error complex(dp) :: val val = cmplx(1.0_dp, 2.0_dp, dp) call check(error, val, cmplx(2.0_dp, 1.0_dp, dp)) end subroutine test_cdp_abs_fail subroutine test_cdp_rel_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error complex(dp) :: val val = cmplx(1.0_dp, 1.5_dp, dp) call check(error, val, cmplx(1.5_dp, 1.0_dp, dp), rel=.true.) end subroutine test_cdp_rel_fail subroutine test_cdp_abs_message(error) !> Error handling type(error_type), allocatable, intent(out) :: error complex(dp) :: val val = cmplx(1.0_dp, 1.5_dp, dp) call check(error, val, cmplx(1.5_dp, 1.0_dp, dp), message="Actual value is not 1.5+1.0i") end subroutine test_cdp_abs_message subroutine test_cdp_nan_message(error) !> Error handling type(error_type), allocatable, intent(out) :: error complex(dp) :: val val = cmplx(ieee_value(0.0_dp, ieee_quiet_nan), 0.0_dp, dp) call check(error, val, message="Actual value is not a number") end subroutine test_cdp_nan_message subroutine test_cxdp_abs(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_XDP complex(xdp) :: val val = cmplx(3.3_xdp, 1.0_xdp, xdp) call check(error, val, cmplx(3.3_xdp, 1.0_xdp, xdp), thr=sqrt(epsilon(real(val)))) #else call skip_test(error, "Extended double precision is not enabled") #endif end subroutine test_cxdp_abs subroutine test_cxdp_rel(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_XDP complex(xdp) :: val val = cmplx(3.3_xdp, 1.0_xdp, xdp) call check(error, val, cmplx(3.3_xdp, 1.0_xdp, xdp), rel=.true.) #else call skip_test(error, "Extended double precision is not enabled") #endif end subroutine test_cxdp_rel subroutine test_cxdp_nan(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_XDP complex(xdp) :: val val = cmplx(ieee_value(0.0_xdp, ieee_quiet_nan), 0.0_xdp, xdp) call check(error, val, cmplx(3.3_xdp, 1.0_xdp, xdp), rel=.true.) #else call skip_test(error, "Extended double precision is not enabled") #endif end subroutine test_cxdp_nan subroutine test_cxdp_abs_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_XDP complex(xdp) :: val val = cmplx(1.0_xdp, 2.0_xdp, xdp) call check(error, val, cmplx(2.0_xdp, 1.0_xdp, xdp)) #else call skip_test(error, "Extended double precision is not enabled") #endif end subroutine test_cxdp_abs_fail subroutine test_cxdp_rel_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_XDP complex(xdp) :: val val = cmplx(1.0_xdp, 1.5_xdp, xdp) call check(error, val, cmplx(1.5_xdp, 1.0_xdp, xdp), rel=.true.) #else call skip_test(error, "Extended double precision is not enabled") #endif end subroutine test_cxdp_rel_fail subroutine test_cxdp_abs_message(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_XDP complex(xdp) :: val val = cmplx(1.0_xdp, 1.5_xdp, xdp) call check(error, val, cmplx(1.5_xdp, 1.0_xdp, xdp), message="Actual value is not 1.5+1.0i") #else call skip_test(error, "Extended double precision is not enabled") #endif end subroutine test_cxdp_abs_message subroutine test_cxdp_nan_message(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_XDP complex(xdp) :: val val = cmplx(ieee_value(0.0_xdp, ieee_quiet_nan), 0.0_xdp, xdp) call check(error, val, message="Actual value is not a number") #else call skip_test(error, "Extended double precision is not enabled") #endif end subroutine test_cxdp_nan_message subroutine test_cqp_abs(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_QP complex(qp) :: val val = cmplx(3.3_qp, 1.0_qp, qp) call check(error, val, cmplx(3.3_qp, 1.0_qp, qp), thr=sqrt(epsilon(real(val)))) #else call skip_test(error, "Quadruple precision is not enabled") #endif end subroutine test_cqp_abs subroutine test_cqp_rel(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_QP complex(qp) :: val val = cmplx(3.3_qp, 1.0_qp, qp) call check(error, val, cmplx(3.3_qp, 1.0_qp, qp), rel=.true.) #else call skip_test(error, "Quadruple precision is not enabled") #endif end subroutine test_cqp_rel subroutine test_cqp_nan(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_QP complex(qp) :: val val = cmplx(ieee_value(0.0_qp, ieee_quiet_nan), 0.0_qp, qp) call check(error, val, cmplx(3.3_qp, 1.0_qp, qp), rel=.true.) #else call skip_test(error, "Quadruple precision is not enabled") #endif end subroutine test_cqp_nan subroutine test_cqp_abs_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_QP complex(qp) :: val val = cmplx(1.0_qp, 2.0_qp, qp) call check(error, val, cmplx(2.0_qp, 1.0_qp, qp)) #else call skip_test(error, "Quadruple precision is not enabled") #endif end subroutine test_cqp_abs_fail subroutine test_cqp_rel_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_QP complex(qp) :: val val = cmplx(1.0_qp, 1.5_qp, qp) call check(error, val, cmplx(1.5_qp, 1.0_qp, qp), rel=.true.) #else call skip_test(error, "Quadruple precision is not enabled") #endif end subroutine test_cqp_rel_fail subroutine test_cqp_abs_message(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_QP complex(qp) :: val val = cmplx(1.0_qp, 1.5_qp, qp) call check(error, val, cmplx(1.5_qp, 1.0_qp, qp), message="Actual value is not 1.5+1.0i") #else call skip_test(error, "Quadruple precision is not enabled") #endif end subroutine test_cqp_abs_message subroutine test_cqp_nan_message(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_QP complex(qp) :: val val = cmplx(ieee_value(0.0_qp, ieee_quiet_nan), 0.0_qp, qp) call check(error, val, message="Actual value is not a number") #else call skip_test(error, "Quadruple precision is not enabled") #endif end subroutine test_cqp_nan_message subroutine test_i1(error) !> Error handling type(error_type), allocatable, intent(out) :: error integer(i1) :: val val = 3_i1 call check(error, val, 3_i1) end subroutine test_i1 subroutine test_i1_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error integer(i1) :: val val = 3_i1 call check(error, val, -4_i1) end subroutine test_i1_fail subroutine test_i1_message(error) !> Error handling type(error_type), allocatable, intent(out) :: error integer(i1) :: val val = -3_i1 call check(error, val, 7_i1, "Actual value is not seven") end subroutine test_i1_message subroutine test_i1_with_more(error) !> Error handling type(error_type), allocatable, intent(out) :: error integer(i1) :: val val = 0_i1 call check(error, val, 3_i1, more="with an additional descriptive message here") end subroutine test_i1_with_more subroutine test_i2(error) !> Error handling type(error_type), allocatable, intent(out) :: error integer(i2) :: val val = 3_i2 call check(error, val, 3_i2) end subroutine test_i2 subroutine test_i2_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error integer(i2) :: val val = 3_i2 call check(error, val, -4_i2) end subroutine test_i2_fail subroutine test_i2_message(error) !> Error handling type(error_type), allocatable, intent(out) :: error integer(i2) :: val val = -3_i2 call check(error, val, 7_i2, "Actual value is not seven") end subroutine test_i2_message subroutine test_i2_with_more(error) !> Error handling type(error_type), allocatable, intent(out) :: error integer(i2) :: val val = 0_i2 call check(error, val, 3_i2, more="with an additional descriptive message here") end subroutine test_i2_with_more subroutine test_i4(error) !> Error handling type(error_type), allocatable, intent(out) :: error integer(i4) :: val val = 3_i4 call check(error, val, 3_i4) end subroutine test_i4 subroutine test_i4_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error integer(i4) :: val val = 3_i4 call check(error, val, -4_i4) end subroutine test_i4_fail subroutine test_i4_message(error) !> Error handling type(error_type), allocatable, intent(out) :: error integer(i4) :: val val = -3_i4 call check(error, val, 7_i4, "Actual value is not seven") end subroutine test_i4_message subroutine test_i4_with_more(error) !> Error handling type(error_type), allocatable, intent(out) :: error integer(i4) :: val val = 0_i4 call check(error, val, 3_i4, more="with an additional descriptive message here") end subroutine test_i4_with_more subroutine test_i8(error) !> Error handling type(error_type), allocatable, intent(out) :: error integer(i8) :: val val = 3_i8 call check(error, val, 3_i8) end subroutine test_i8 subroutine test_i8_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error integer(i8) :: val val = 3_i8 call check(error, val, -4_i8) end subroutine test_i8_fail subroutine test_i8_message(error) !> Error handling type(error_type), allocatable, intent(out) :: error integer(i8) :: val val = -3_i8 call check(error, val, 7_i8, "Actual value is not seven") end subroutine test_i8_message subroutine test_i8_with_more(error) !> Error handling type(error_type), allocatable, intent(out) :: error integer(i8) :: val val = 0_i8 call check(error, val, 3_i8, more="with an additional descriptive message here") end subroutine test_i8_with_more subroutine test_l4_true(error) !> Error handling type(error_type), allocatable, intent(out) :: error call check(error, .true., .true.) end subroutine test_l4_true subroutine test_l4_false(error) !> Error handling type(error_type), allocatable, intent(out) :: error call check(error, .false., .false.) end subroutine test_l4_false subroutine test_l4_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error call check(error, .true., .false.) end subroutine test_l4_fail subroutine test_l4_message(error) !> Error handling type(error_type), allocatable, intent(out) :: error call check(error, .false., .true., "Logical value is not true") end subroutine test_l4_message subroutine test_l4_with_more(error) !> Error handling type(error_type), allocatable, intent(out) :: error call check(error, .true., .false., more="with an additional descriptive message") end subroutine test_l4_with_more subroutine test_char(error) !> Error handling type(error_type), allocatable, intent(out) :: error character(len=:), allocatable :: val val = "positive" call check(error, val, "positive") end subroutine test_char subroutine test_char_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error character(len=:), allocatable :: val val = "positive" call check(error, val, "negative") end subroutine test_char_fail subroutine test_char_message(error) !> Error handling type(error_type), allocatable, intent(out) :: error character(len=:), allocatable :: val val = "positive" call check(error, val, "negative", "Character string should be negative") end subroutine test_char_message subroutine test_char_with_more(error) !> Error handling type(error_type), allocatable, intent(out) :: error character(len=:), allocatable :: val val = "positive" call check(error, val, "negative", more="with an additional descriptive message") end subroutine test_char_with_more subroutine test_string_i1(error) !> Error handling type(error_type), allocatable, intent(out) :: error call check(error, to_string(-huge(1_i1) - 1_i1), "-128") end subroutine test_string_i1 subroutine test_string_i2(error) !> Error handling type(error_type), allocatable, intent(out) :: error call check(error, to_string(-huge(1_i2) - 1_i2), "-32768") end subroutine test_string_i2 subroutine test_string_i4(error) !> Error handling type(error_type), allocatable, intent(out) :: error call check(error, to_string(-huge(1_i4) - 1_i4), "-2147483648") end subroutine test_string_i4 subroutine test_string_i8(error) !> Error handling type(error_type), allocatable, intent(out) :: error call check(error, to_string(-huge(1_i8) - 1_i8), "-9223372036854775808") end subroutine test_string_i8 subroutine test_rsp_absrel_relpass_absfail(error) !> Error handling type(error_type), allocatable, intent(out) :: error real(sp) :: val val = 1.005_sp call check(error, val, 1.0_sp, thr_abs=1.0e-4_sp, thr_rel=1.0e-2_sp) end subroutine test_rsp_absrel_relpass_absfail subroutine test_rsp_absrel_relfail_abspass(error) !> Error handling type(error_type), allocatable, intent(out) :: error real(sp) :: val val = 1.05e-3_sp call check(error, val, 1.0e-3_sp, thr_abs=1.0e-4_sp, thr_rel=1.0e-2_sp) end subroutine test_rsp_absrel_relfail_abspass subroutine test_rsp_absrel_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error real(sp) :: val val = 1.02_sp call check(error, val, 1.0_sp, thr_abs=1.0e-4_sp, thr_rel=1.0e-2_sp) end subroutine test_rsp_absrel_fail subroutine test_rdp_absrel_relpass_absfail(error) !> Error handling type(error_type), allocatable, intent(out) :: error real(dp) :: val val = 1.005_dp call check(error, val, 1.0_dp, thr_abs=1.0e-8_dp, thr_rel=1.0e-2_dp) end subroutine test_rdp_absrel_relpass_absfail subroutine test_rdp_absrel_relfail_abspass(error) !> Error handling type(error_type), allocatable, intent(out) :: error real(dp) :: val val = 1.05e-3_dp call check(error, val, 1.0e-3_dp, thr_abs=1.0e-4_dp, thr_rel=1.0e-2_dp) end subroutine test_rdp_absrel_relfail_abspass subroutine test_rdp_absrel_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error real(dp) :: val val = 1.02_dp call check(error, val, 1.0_dp, thr_abs=1.0e-8_dp, thr_rel=1.0e-2_dp) end subroutine test_rdp_absrel_fail subroutine test_csp_absrel_relpass_absfail(error) !> Error handling type(error_type), allocatable, intent(out) :: error complex(sp) :: val val = cmplx(1.004_sp, 1.003_sp, sp) call check(error, val, cmplx(1.0_sp, 1.0_sp, sp), thr_abs=1.0e-4_sp, thr_rel=1.0e-2_sp) end subroutine test_csp_absrel_relpass_absfail subroutine test_csp_absrel_relfail_abspass(error) !> Error handling type(error_type), allocatable, intent(out) :: error complex(sp) :: val val = cmplx(1.05e-3_sp, 1.05e-3_sp, sp) call check(error, val, cmplx(1.0e-3_sp, 1.0e-3_sp, sp), thr_abs=1.0e-4_sp, thr_rel=1.0e-2_sp) end subroutine test_csp_absrel_relfail_abspass subroutine test_csp_absrel_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error complex(sp) :: val val = cmplx(1.02_sp, 1.02_sp, sp) call check(error, val, cmplx(1.0_sp, 1.0_sp, sp), thr_abs=1.0e-4_sp, thr_rel=1.0e-2_sp) end subroutine test_csp_absrel_fail subroutine test_cdp_absrel_relpass_absfail(error) !> Error handling type(error_type), allocatable, intent(out) :: error complex(dp) :: val val = cmplx(1.004_dp, 1.003_dp, dp) call check(error, val, cmplx(1.0_dp, 1.0_dp, dp), thr_abs=1.0e-8_dp, thr_rel=1.0e-2_dp) end subroutine test_cdp_absrel_relpass_absfail subroutine test_cdp_absrel_relfail_abspass(error) !> Error handling type(error_type), allocatable, intent(out) :: error complex(dp) :: val val = cmplx(1.05e-3_dp, 1.05e-3_dp, dp) call check(error, val, cmplx(1.0e-3_dp, 1.0e-3_dp, dp), thr_abs=1.0e-4_dp, thr_rel=1.0e-2_dp) end subroutine test_cdp_absrel_relfail_abspass subroutine test_cdp_absrel_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error complex(dp) :: val val = cmplx(1.02_dp, 1.02_dp, dp) call check(error, val, cmplx(1.0_dp, 1.0_dp, dp), thr_abs=1.0e-8_dp, thr_rel=1.0e-2_dp) end subroutine test_cdp_absrel_fail subroutine test_rxdp_absrel_relpass_absfail(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_XDP real(xdp) :: val val = 1.005_xdp call check(error, val, 1.0_xdp, thr_abs=1.0e-8_xdp, thr_rel=1.0e-2_xdp) #else call skip_test(error, "Extended double precision is not enabled") #endif end subroutine test_rxdp_absrel_relpass_absfail subroutine test_rxdp_absrel_relfail_abspass(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_XDP real(xdp) :: val val = 1.05e-3_xdp call check(error, val, 1.0e-3_xdp, thr_abs=1.0e-4_xdp, thr_rel=1.0e-2_xdp) #else call skip_test(error, "Extended double precision is not enabled") #endif end subroutine test_rxdp_absrel_relfail_abspass subroutine test_rxdp_absrel_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_XDP real(xdp) :: val val = 1.02_xdp call check(error, val, 1.0_xdp, thr_abs=1.0e-8_xdp, thr_rel=1.0e-2_xdp) #else call skip_test(error, "Extended double precision is not enabled") #endif end subroutine test_rxdp_absrel_fail subroutine test_rqp_absrel_relpass_absfail(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_QP real(qp) :: val val = 1.005_qp call check(error, val, 1.0_qp, thr_abs=1.0e-8_qp, thr_rel=1.0e-2_qp) #else call skip_test(error, "Quadruple precision is not enabled") #endif end subroutine test_rqp_absrel_relpass_absfail subroutine test_rqp_absrel_relfail_abspass(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_QP real(qp) :: val val = 1.05e-3_qp call check(error, val, 1.0e-3_qp, thr_abs=1.0e-4_qp, thr_rel=1.0e-2_qp) #else call skip_test(error, "Quadruple precision is not enabled") #endif end subroutine test_rqp_absrel_relfail_abspass subroutine test_rqp_absrel_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_QP real(qp) :: val val = 1.02_qp call check(error, val, 1.0_qp, thr_abs=1.0e-8_qp, thr_rel=1.0e-2_qp) #else call skip_test(error, "Quadruple precision is not enabled") #endif end subroutine test_rqp_absrel_fail subroutine test_cxdp_absrel_relpass_absfail(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_XDP complex(xdp) :: val val = cmplx(1.004_xdp, 1.003_xdp, xdp) call check(error, val, cmplx(1.0_xdp, 1.0_xdp, xdp), thr_abs=1.0e-8_xdp, thr_rel=1.0e-2_xdp) #else call skip_test(error, "Extended double precision is not enabled") #endif end subroutine test_cxdp_absrel_relpass_absfail subroutine test_cxdp_absrel_relfail_abspass(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_XDP complex(xdp) :: val val = cmplx(1.05e-3_xdp, 1.05e-3_xdp, xdp) call check(error, val, cmplx(1.0e-3_xdp, 1.0e-3_xdp, xdp), thr_abs=1.0e-4_xdp, thr_rel=1.0e-2_xdp) #else call skip_test(error, "Extended double precision is not enabled") #endif end subroutine test_cxdp_absrel_relfail_abspass subroutine test_cxdp_absrel_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_XDP complex(xdp) :: val val = cmplx(1.02_xdp, 1.02_xdp, xdp) call check(error, val, cmplx(1.0_xdp, 1.0_xdp, xdp), thr_abs=1.0e-8_xdp, thr_rel=1.0e-2_xdp) #else call skip_test(error, "Extended double precision is not enabled") #endif end subroutine test_cxdp_absrel_fail subroutine test_cqp_absrel_relpass_absfail(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_QP complex(qp) :: val val = cmplx(1.004_qp, 1.003_qp, qp) call check(error, val, cmplx(1.0_qp, 1.0_qp, qp), thr_abs=1.0e-8_qp, thr_rel=1.0e-2_qp) #else call skip_test(error, "Quadruple precision is not enabled") #endif end subroutine test_cqp_absrel_relpass_absfail subroutine test_cqp_absrel_relfail_abspass(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_QP complex(qp) :: val val = cmplx(1.05e-3_qp, 1.05e-3_qp, qp) call check(error, val, cmplx(1.0e-3_qp, 1.0e-3_qp, qp), thr_abs=1.0e-4_qp, thr_rel=1.0e-2_qp) #else call skip_test(error, "Quadruple precision is not enabled") #endif end subroutine test_cqp_absrel_relfail_abspass subroutine test_cqp_absrel_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error #if WITH_QP complex(qp) :: val val = cmplx(1.02_qp, 1.02_qp, qp) call check(error, val, cmplx(1.0_qp, 1.0_qp, qp), thr_abs=1.0e-8_qp, thr_rel=1.0e-2_qp) #else call skip_test(error, "Quadruple precision is not enabled") #endif end subroutine test_cqp_absrel_fail end module test_check fortran-testdrive-0.6.0/test/meson.build0000664000175000017500000000156315201524466020516 0ustar alastairalastair# This file is part of test-drive. # SPDX-Identifier: Apache-2.0 OR MIT # # Licensed under either of Apache License, Version 2.0 or MIT license # at your option; you may not use this file except in compliance with # the License. # # Unless required by applicable law or agreed to in writing, software # distributed under the License is distributed on an "AS IS" BASIS, # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. # See the License for the specific language governing permissions and # limitations under the License. tests = [ 'check', 'select', ] test_srcs = files( 'main.f90', ) foreach t : tests test_srcs += files('test_@0@.F90'.format(t.underscorify())) endforeach tester = executable( 'tester', sources: test_srcs, dependencies: testdrive_dep, ) test('all tests', tester) foreach t : tests test(t, tester, args: t) endforeach fortran-testdrive-0.6.0/test/main.f900000664000175000017500000000466615201524466017627 0ustar alastairalastair! This file is part of test-drive. ! SPDX-Identifier: Apache-2.0 OR MIT ! ! Licensed under either of Apache License, Version 2.0 or MIT license ! at your option; you may not use this file except in compliance with ! the License. ! ! Unless required by applicable law or agreed to in writing, software ! distributed under the License is distributed on an "AS IS" BASIS, ! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ! See the License for the specific language governing permissions and ! limitations under the License. !> Driver for unit testing program tester use, intrinsic :: iso_fortran_env, only : error_unit use testdrive, only : run_testsuite, new_testsuite, testsuite_type, & & select_suite, run_selected, get_argument, junit_output, junit_header, & & init_color_output use test_check, only : collect_check use test_select, only : collect_select implicit none integer :: stat, is character(len=:), allocatable :: suite_name, test_name type(testsuite_type), allocatable :: testsuites(:) character(len=*), parameter :: fmt = '("#", *(1x, a))' type(junit_output) :: junit stat = 0 call junit_header(junit, "testdrive") testsuites = [ & new_testsuite("check", collect_check), & new_testsuite("select", collect_select) & ] call get_argument(1, suite_name) call get_argument(2, test_name) call init_color_output(.true.) if (allocated(suite_name)) then is = select_suite(testsuites, suite_name) if (is > 0 .and. is <= size(testsuites)) then if (allocated(test_name)) then write(error_unit, fmt) "Suite:", testsuites(is)%name call run_selected(testsuites(is)%collect, test_name, error_unit, stat, junit=junit) if (stat < 0) then error stop 1 end if else write(error_unit, fmt) "Testing:", testsuites(is)%name call run_testsuite(testsuites(is)%collect, error_unit, stat, junit=junit) end if else write(error_unit, fmt) "Available testsuites" do is = 1, size(testsuites) write(error_unit, fmt) "-", testsuites(is)%name end do error stop 1 end if else do is = 1, size(testsuites) write(error_unit, fmt) "Testing:", testsuites(is)%name call run_testsuite(testsuites(is)%collect, error_unit, stat, junit=junit) end do end if if (stat > 0) then write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" error stop 1 end if end program tester fortran-testdrive-0.6.0/test/export/0000775000175000017500000000000015201524466017670 5ustar alastairalastairfortran-testdrive-0.6.0/test/export/meson.build0000664000175000017500000000020515201524466022027 0ustar alastairalastairproject('test-test', 'fortran') executable( 'test-test', sources: ['example.f90'], dependencies: [dependency('test-drive')], )fortran-testdrive-0.6.0/test/export/example.f900000664000175000017500000000115115201524466021641 0ustar alastairalastairprogram tester use, intrinsic :: iso_fortran_env, only : error_unit use testdrive, only : run_testsuite, new_testsuite, testsuite_type implicit none integer :: stat, is type(testsuite_type), allocatable :: testsuites(:) character(len=*), parameter :: fmt = '("#", *(1x, a))' stat = 0 allocate(testsuites(0)) do is = 1, size(testsuites) write(error_unit, fmt) "Testing:", testsuites(is)%name call run_testsuite(testsuites(is)%collect, error_unit, stat) end do if (stat > 0) then write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" error stop end if end program tester fortran-testdrive-0.6.0/test/export/CMakeLists.txt0000664000175000017500000000032115201524466022424 0ustar alastairalastaircmake_minimum_required(VERSION 3.18) project(test-test Fortran) find_package(test-drive CONFIG REQUIRED) add_executable(test-test "example.f90") target_link_libraries(test-test PUBLIC test-drive::test-drive)fortran-testdrive-0.6.0/test/test_select.F900000664000175000017500000000756015201524466021155 0ustar alastairalastair! This file is part of test-drive. ! SPDX-Identifier: Apache-2.0 OR MIT ! ! Licensed under either of Apache License, Version 2.0 or MIT license ! at your option; you may not use this file except in compliance with ! the License. ! ! Unless required by applicable law or agreed to in writing, software ! distributed under the License is distributed on an "AS IS" BASIS, ! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ! See the License for the specific language governing permissions and ! limitations under the License. module test_select use, intrinsic :: ieee_arithmetic, only : ieee_value, ieee_quiet_nan use testdrive, only : new_unittest, unittest_type, error_type, check, & & run_testsuite, new_testsuite, testsuite_type, select_suite, run_selected implicit none private public :: collect_select contains !> Collect all exported unit tests subroutine collect_select(testsuite) !> Collection of tests type(unittest_type), allocatable, intent(out) :: testsuite(:) testsuite = [ & new_unittest("always-pass", always_pass), & new_unittest("always-fail", always_fail, should_fail=.true.), & new_unittest("run-good-suite", test_run_good_suite), & new_unittest("run-bad-suite", test_run_bad_suite), & new_unittest("run-selected", test_run_selected), & new_unittest("select-missing", test_select_missing) & ] end subroutine collect_select subroutine always_pass(error) !> Error handling type(error_type), allocatable, intent(out) :: error call check(error, 0) end subroutine always_pass subroutine always_fail(error) !> Error handling type(error_type), allocatable, intent(out) :: error call check(error, 1, "Always failing test") end subroutine always_fail !> Stub test suite collector defining passing unit tests subroutine stub_collect(testsuite) !> Collection of tests type(unittest_type), allocatable, intent(out) :: testsuite(:) testsuite = [ & new_unittest("always-pass", always_pass), & new_unittest("always-fail", always_fail, should_fail=.true.) & ] end subroutine stub_collect !> Bad test suite collector defining flaky unit tests subroutine stub_collect_bad(testsuite) !> Collection of tests type(unittest_type), allocatable, intent(out) :: testsuite(:) testsuite = [ & new_unittest("always-pass", always_pass, should_fail=.true.), & new_unittest("always-fail", always_fail) & ] end subroutine stub_collect_bad subroutine test_run_good_suite(error) !> Error handling type(error_type), allocatable, intent(out) :: error integer :: unit, stat open(status='scratch', newunit=unit) stat = 7 call run_testsuite(stub_collect, unit, stat) call check(error, stat, 7) close(unit) end subroutine test_run_good_suite subroutine test_run_bad_suite(error) !> Error handling type(error_type), allocatable, intent(out) :: error integer :: unit, stat open(status='scratch', newunit=unit) stat = 3 call run_testsuite(stub_collect_bad, unit, stat) call check(error, stat, 5) close(unit) end subroutine test_run_bad_suite subroutine test_run_selected(error) !> Error handling type(error_type), allocatable, intent(out) :: error integer :: unit, stat open(status='scratch', newunit=unit) stat = 1 call run_selected(stub_collect, "always-fail", unit, stat) call check(error, stat, 1) close(unit) end subroutine test_run_selected subroutine test_select_missing(error) !> Error handling type(error_type), allocatable, intent(out) :: error integer :: unit, stat open(status='scratch', newunit=unit) call run_selected(stub_collect, "not-available", unit, stat) call check(error, stat < 0) close(unit) end subroutine test_select_missing end module test_select fortran-testdrive-0.6.0/test/CMakeLists.txt0000664000175000017500000000225615201524466021114 0ustar alastairalastair# This file is part of test-drive. # SPDX-Identifier: Apache-2.0 OR MIT # # Licensed under either of Apache License, Version 2.0 or MIT license # at your option; you may not use this file except in compliance with # the License. # # Unless required by applicable law or agreed to in writing, software # distributed under the License is distributed on an "AS IS" BASIS, # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. # See the License for the specific language governing permissions and # limitations under the License. # Unit testing set( tests "check" "select" ) set( test-srcs "main.f90" ) foreach(t IN LISTS tests) string(MAKE_C_IDENTIFIER ${t} t) list(APPEND test-srcs "test_${t}.F90") endforeach() add_executable( "${PROJECT_NAME}-tester" "${test-srcs}" ) target_link_libraries( "${PROJECT_NAME}-tester" PRIVATE "${PROJECT_NAME}-lib" ) target_compile_definitions( "${PROJECT_NAME}-tester" PRIVATE "WITH_QP=$" "WITH_XDP=$" ) add_test("${PROJECT_NAME}/all-tests" "${PROJECT_NAME}-tester") foreach(t IN LISTS tests) add_test("${PROJECT_NAME}/${t}" "${PROJECT_NAME}-tester" "${t}") endforeach() fortran-testdrive-0.6.0/README.md0000664000175000017500000002611615201524466016655 0ustar alastairalastair# The simple testing framework [![License](https://img.shields.io/badge/license-MIT%7CApache%202.0-blue)](LICENSE-Apache) [![Latest Version](https://img.shields.io/github/v/release/fortran-lang/test-drive)](https://github.com/fortran-lang/test-drive/releases/latest) [![CI](https://github.com/fortran-lang/test-drive/workflows/CI/badge.svg)](https://github.com/fortran-lang/test-drive/actions) [![codecov](https://codecov.io/gh/fortran-lang/test-drive/branch/main/graph/badge.svg)](https://codecov.io/gh/fortran-lang/test-drive) This project offers a lightweight, procedural unit testing framework based on nothing but standard Fortran. Integration with [meson](https://mesonbuild.com), [cmake](https://cmake.org) and [Fortran package manager (fpm)](https://github.com/fortran-lang/fpm) is available. Alternatively, the [``testdrive.F90``](src/testdrive.F90) source file can be redistributed in the project's testsuite as well. ## Usage Testsuites are defined by a ``collect_interface`` returning a set of ``unittest_type`` objects. To create a new test use the ``new_unittest`` constructor, which requires a test identifier and a procedure with a ``test_interface`` compatible signature. The error status is communicated by the allocation status of an ``error_type``. The necessary boilerplate code to setup the test entry point is just ```fortran program tester use, intrinsic :: iso_fortran_env, only : error_unit use testdrive, only : run_testsuite, new_testsuite, testsuite_type use test_suite1, only : collect_suite1 use test_suite2, only : collect_suite2 implicit none integer :: stat, is type(testsuite_type), allocatable :: testsuites(:) character(len=*), parameter :: fmt = '("#", *(1x, a))' stat = 0 testsuites = [ & new_testsuite("suite1", collect_suite1), & new_testsuite("suite2", collect_suite2) & ] do is = 1, size(testsuites) write(error_unit, fmt) "Testing:", testsuites(is)%name call run_testsuite(testsuites(is)%collect, error_unit, stat) end do if (stat > 0) then write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" error stop end if end program tester ``` Every test is defined in a separate module using a ``collect`` function, which is exported and added to the ``testsuites`` array in the test runner. All tests have a simple interface with just an allocatable ``error_type`` as output to provide the test results. ```fortran module test_suite1 use testdrive, only : new_unittest, unittest_type, error_type, check implicit none private public :: collect_suite1 contains !> Collect all exported unit tests subroutine collect_suite1(testsuite) !> Collection of tests type(unittest_type), allocatable, intent(out) :: testsuite(:) testsuite = [ & new_unittest("valid", test_valid), & new_unittest("invalid", test_invalid, should_fail=.true.) & ] end subroutine collect_suite1 subroutine test_valid(error) type(error_type), allocatable, intent(out) :: error ! ... end subroutine test_valid subroutine test_invalid(error) type(error_type), allocatable, intent(out) :: error ! ... end subroutine test_invalid end module test_suite1 ``` ### Checking test conditions The procedures defining the tests can contain any Fortran code required for checking the correctness of the project. An easy way to do so is provided by the generic ``check`` function. ```f90 subroutine test_valid(error) type(error_type), allocatable, intent(out) :: error call check(error, 1 + 2 == 3) if (allocated(error)) return ! equivalent to the above call check(error, 1 + 2, 3) if (allocated(error)) return end subroutine test_valid ``` After each check, the status of the error should be checked. Uncaught errors will not be silently dropped, instead the error will be caught, its message displayed and the run aborted. Possible ways to use check are listed below | available checks | arguments | | -------------------- | -------------------------------------------------------------- | | logical check | *error*, *logical*, ... | | status check | *error*, *integer*, ... | | logical comparison | *error*, *logical*, *logical*, ... | | integer comparison | *error*, *integer*, ... | | character comparison | *error*, *character*, *character*, ... | | real comparison | *error*, *real*, *real*, ..., thr=*real*, rel=*logical* | | real combined check | *error*, *real*, *real*, *thr_abs*, *thr_rel*, ... | | real NaN check | *error*, *real*, ... | | complex comparison | *error*, *complex*, *complex*, ..., thr=*real*, rel=*logical* | | complex combined check | *error*, *complex*, *complex*, *thr_abs*, *thr_rel*, ... | | complex NaN check | *error*, *complex*, ... | Each check will generate a meaningful error message based on the available arguments, but can also be provided with a custom error message instead. The combined check uses a pytest-style tolerance: `|actual - expected| <= max(thr_abs, thr_rel * |expected|)`, where both the absolute and relative threshold should be positive tolerances. This passes if *either* the absolute or relative threshold is satisfied. To generate custom checks the ``test_failed`` procedure is available to generate error messages ```f90 subroutine test_custom(error) type(error_type), allocatable, intent(out) :: error ! ... if (.not.cond) then call test_failed(error, "Custom check failed") return end if ! ... if (.not.cond) then call test_failed(error, "Custom check failed", "Additional context") return end if end subroutine test_custom ``` To conditionally skip a test use the ``skip_test`` procedure. It uses the same signature as ``test_failed``, but will mark the respective test as skipped, this is useful to disable tests based on conditional compilation, *e.g.* by using a preprocessor or a different submodule. An uncaught skipped test will fail regardless, therefore make sure to not run any other checks afterwards. ### Integration in build systems Finally, for usage with *fpm* it is beneficial to have a single test driver which can run all tests. While this brings the disadvantage of always having to run the complete testsuite, the main driver can provide the flexibility to select the suite and also the unit test using the boilerplate code shown here: ```f90 !> Driver for unit testing program tester use, intrinsic :: iso_fortran_env, only : error_unit use testdrive, only : run_testsuite, new_testsuite, testsuite_type, & & select_suite, run_selected, get_argument use test_suite1, only : collect_suite1 use test_suite2, only : collect_suite2 implicit none integer :: stat, is character(len=:), allocatable :: suite_name, test_name type(testsuite_type), allocatable :: testsuites(:) character(len=*), parameter :: fmt = '("#", *(1x, a))' stat = 0 testsuites = [ & new_testsuite("suite1", collect_suite1), & new_testsuite("suite2", collect_suite2) & ] call get_argument(1, suite_name) call get_argument(2, test_name) if (allocated(suite_name)) then is = select_suite(testsuites, suite_name) if (is > 0 .and. is <= size(testsuites)) then if (allocated(test_name)) then write(error_unit, fmt) "Suite:", testsuites(is)%name call run_selected(testsuites(is)%collect, test_name, error_unit, stat) if (stat < 0) then error stop 1 end if else write(error_unit, fmt) "Testing:", testsuites(is)%name call run_testsuite(testsuites(is)%collect, error_unit, stat) end if else write(error_unit, fmt) "Available testsuites" do is = 1, size(testsuites) write(error_unit, fmt) "-", testsuites(is)%name end do error stop 1 end if else do is = 1, size(testsuites) write(error_unit, fmt) "Testing:", testsuites(is)%name call run_testsuite(testsuites(is)%collect, error_unit, stat) end do end if if (stat > 0) then write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" error stop 1 end if end program tester ``` From *fpm* this allows to run all tests using just the *fpm test* command, but also to debug an individual test in a debugger. For example to run *broken-test* in *large-suite* with ``gdb`` use ``` fpm test --runner gdb -- large-suite broken-test ``` To make this approach feasible for meson the tests can be created as individual suites. A usual layout of the test directory like ``` test ├── main.f90 ├── meson.build ├── test_suite1.f90 ├── test_suite2.f90 └── ... ``` Can use the following snippet to automatically create individual tests running complete suites inside the driver. Resolution to the unit tests is possible but usually not desired, because the individual runtime of the tests will be short compared to the overhead to start the actual test. ```meson testdrive_dep = dependency('test-drive', fallback: ['test-drive', 'testdrive_dep']) tests = [ 'suite1', 'suite2', # ... ] test_srcs = files( 'main.f90', ) foreach t : tests test_srcs += files('test_@0@.f90'.format(t.underscorify())) endforeach tester = executable( 'tester', sources: test_srcs, dependencies: [proj_dep, testdrive_dep], ) test('all tests', tester) foreach t : tests test(t, tester, args: t) endforeach ``` Similar for a CMake based build the tests can be generated automatically for the layout shown below. ``` test ├── CMakeLists.txt ├── main.f90 ├── test_suite1.f90 ├── test_suite2.f90 └── ... ``` The CMake file in the test directory should look similar to the one shown here ```cmake if(NOT TARGET "test-drive::test-drive") find_package("test-drive" REQUIRED) endif() # Unit testing set( tests "suite1" "suite2" ) set( test-srcs "main.f90" ) foreach(t IN LISTS tests) string(MAKE_C_IDENTIFIER ${t} t) list(APPEND test-srcs "test_${t}.f90") endforeach() add_executable( "${PROJECT_NAME}-tester" "${test-srcs}" ) target_link_libraries( "${PROJECT_NAME}-tester" PRIVATE "${PROJECT_NAME}-lib" "test-drive::test-drive" ) foreach(t IN LISTS tests) add_test("${PROJECT_NAME}/${t}" "${PROJECT_NAME}-tester" "${t}") endforeach() ``` ## License This project is free software: you can redistribute it and/or modify it under the terms of the [Apache License, Version 2.0](LICENSE-Apache) or [MIT license](LICENSE-MIT) at your opinion. Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an _as is_ basis, without warranties or conditions of any kind, either express or implied. See the License for the specific language governing permissions and limitations under the License. Unless you explicitly state otherwise, any contribution intentionally submitted for inclusion in this project by you, as defined in the Apache-2.0 license, shall be dual licensed as above, without any additional terms or conditions. fortran-testdrive-0.6.0/config/0000775000175000017500000000000015201524466016635 5ustar alastairalastairfortran-testdrive-0.6.0/config/meson.build0000664000175000017500000000435315201524466021004 0ustar alastairalastair# This file is part of test-drive. # SPDX-Identifier: Apache-2.0 OR MIT # # Licensed under either of Apache License, Version 2.0 or MIT license # at your option; you may not use this file except in compliance with # the License. # # Unless required by applicable law or agreed to in writing, software # distributed under the License is distributed on an "AS IS" BASIS, # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. # See the License for the specific language governing permissions and # limitations under the License. os = host_machine.system() fc = meson.get_compiler('fortran') fc_id = fc.get_id() ca = [] # compile args la = [] # link args if fc_id == 'gcc' ca += [ '-ffree-line-length-none', '-fbacktrace', ] if os == 'windows' la += ['-Wl,--allow-multiple-definition'] endif elif fc_id == 'intel-cl' or fc_id == 'intel-llvm-cl' ca += [ '/traceback', '/fpp', ] elif fc_id == 'intel' or fc_id == 'intel-llvm' ca += [ '-traceback', ] elif fc_id == 'pgi' or fc_id == 'nvidia_hpc' ca += [ '-Mbackslash', '-Mallocatable=03', '-traceback', ] elif fc_id == 'flang' ca += [ '-Mbackslash', '-Mallocatable=03', ] endif add_project_arguments(fc.get_supported_arguments(ca), language: 'fortran') add_project_link_arguments(fc.get_supported_arguments(la), language: 'fortran') if get_option('openmp') omp_dep = dependency('openmp') lib_deps += omp_dep endif if get_option('qp').auto() with_qp = fc.compiles(''' integer, parameter :: qp = selected_real_kind(33) complex(qp) :: x end ''') else with_qp = get_option('qp').allowed() endif if get_option('xdp').auto() with_xdp = fc.compiles(''' integer, parameter :: xdp = & & merge(-1, selected_real_kind(18), & & selected_real_kind(18) == selected_real_kind(33)) complex(xdp) :: x end ''') else with_xdp = get_option('xdp').allowed() endif with_ieee_is_nan = fc.compiles(''' use, intrinsic :: ieee_arithmetic, only : ieee_is_nan logical :: x x = ieee_is_nan(0.0) end ''') add_project_arguments( '-DWITH_QP=@0@'.format(with_qp.to_int()), '-DWITH_XDP=@0@'.format(with_xdp.to_int()), '-DWITH_IEEE_IS_NAN=@0@'.format(with_ieee_is_nan.to_int()), language: 'fortran', ) fortran-testdrive-0.6.0/config/template-targets.cmake0000664000175000017500000000122215201524466023116 0ustar alastairalastairset(CMAKE_IMPORT_FILE_VERSION 1) set( TESTDRIVE_INCLUDEDIRS "@CMAKE_INSTALL_PREFIX@/@CMAKE_INSTALL_INCLUDEDIR@" "@CMAKE_INSTALL_PREFIX@/@CMAKE_INSTALL_INCLUDEDIR@/@module-dir@" ) find_library( TESTDRIVE_LIBRARIES "@PROJECT_NAME@" PATHS "@CMAKE_INSTALL_PREFIX@/@CMAKE_INSTALL_LIBDIR@" NO_DEFAULT_PATH ) add_library(@PROJECT_NAME@::@PROJECT_NAME@-lib INTERFACE IMPORTED) add_library(@PROJECT_NAME@::@PROJECT_NAME@ ALIAS @PROJECT_NAME@::@PROJECT_NAME@-lib) target_link_libraries(@PROJECT_NAME@::@PROJECT_NAME@-lib INTERFACE ${TESTDRIVE_LIBRARIES}) target_include_directories(@PROJECT_NAME@::@PROJECT_NAME@-lib INTERFACE ${TESTDRIVE_INCLUDEDIRS})fortran-testdrive-0.6.0/config/install-mod.py0000664000175000017500000000247715201524466021444 0ustar alastairalastair#!/usr/bin/env python3 # This file is part of test-drive. # SPDX-Identifier: Apache-2.0 OR MIT # # Licensed under either of Apache License, Version 2.0 or MIT license # at your option; you may not use this file except in compliance with # the License. # # Unless required by applicable law or agreed to in writing, software # distributed under the License is distributed on an "AS IS" BASIS, # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. # See the License for the specific language governing permissions and # limitations under the License. from os import environ, listdir, makedirs from os.path import join, isdir, exists from sys import argv from shutil import copy build_dir = environ["MESON_BUILD_ROOT"] if "MESON_INSTALL_DESTDIR_PREFIX" in environ: install_dir = environ["MESON_INSTALL_DESTDIR_PREFIX"] else: install_dir = environ["MESON_INSTALL_PREFIX"] include_dir = argv[1] if len(argv) > 1 else "include" module_dir = join(install_dir, include_dir) modules = [] for d in listdir(build_dir): bd = join(build_dir, d) if isdir(bd): for f in listdir(bd): if f.endswith(".mod"): modules.append(join(bd, f)) if not exists(module_dir): makedirs(module_dir) for mod in modules: print("Installing", mod, "to", module_dir) copy(mod, module_dir) fortran-testdrive-0.6.0/config/template-version.cmake0000664000175000017500000000431415201524466023137 0ustar alastairalastairset(PACKAGE_VERSION @PROJECT_VERSION@) if(PACKAGE_VERSION VERSION_LESS PACKAGE_FIND_VERSION) set(PACKAGE_VERSION_COMPATIBLE FALSE) else() if("@PROJECT_VERSION@" MATCHES "^([0-9]+)\\.") set(CVF_VERSION_MAJOR "${CMAKE_MATCH_1}") if(NOT CVF_VERSION_MAJOR VERSION_EQUAL 0) string(REGEX REPLACE "^0+" "" CVF_VERSION_MAJOR "${CVF_VERSION_MAJOR}") endif() else() set(CVF_VERSION_MAJOR "@PROJECT_VERSION@") endif() if(PACKAGE_FIND_VERSION_RANGE) # both endpoints of the range must have the expected major version math (EXPR CVF_VERSION_MAJOR_NEXT "${CVF_VERSION_MAJOR} + 1") if (NOT PACKAGE_FIND_VERSION_MIN_MAJOR STREQUAL CVF_VERSION_MAJOR OR ((PACKAGE_FIND_VERSION_RANGE_MAX STREQUAL "INCLUDE" AND NOT PACKAGE_FIND_VERSION_MAX_MAJOR STREQUAL CVF_VERSION_MAJOR) OR (PACKAGE_FIND_VERSION_RANGE_MAX STREQUAL "EXCLUDE" AND NOT PACKAGE_FIND_VERSION_MAX VERSION_LESS_EQUAL CVF_VERSION_MAJOR_NEXT))) set(PACKAGE_VERSION_COMPATIBLE FALSE) elseif(PACKAGE_FIND_VERSION_MIN_MAJOR STREQUAL CVF_VERSION_MAJOR AND ((PACKAGE_FIND_VERSION_RANGE_MAX STREQUAL "INCLUDE" AND PACKAGE_VERSION VERSION_LESS_EQUAL PACKAGE_FIND_VERSION_MAX) OR (PACKAGE_FIND_VERSION_RANGE_MAX STREQUAL "EXCLUDE" AND PACKAGE_VERSION VERSION_LESS PACKAGE_FIND_VERSION_MAX))) set(PACKAGE_VERSION_COMPATIBLE TRUE) else() set(PACKAGE_VERSION_COMPATIBLE FALSE) endif() else() if(PACKAGE_FIND_VERSION_MAJOR STREQUAL CVF_VERSION_MAJOR) set(PACKAGE_VERSION_COMPATIBLE TRUE) else() set(PACKAGE_VERSION_COMPATIBLE FALSE) endif() if(PACKAGE_FIND_VERSION STREQUAL PACKAGE_VERSION) set(PACKAGE_VERSION_EXACT TRUE) endif() endif() endif() # if the installed or the using project don't have CMAKE_SIZEOF_VOID_P set, ignore it: if("${CMAKE_SIZEOF_VOID_P}" STREQUAL "" OR "@CMAKE_SIZEOF_VOID_P@" STREQUAL "") return() endif() # check that the installed version has the same 32/64bit-ness as the one which is currently searching: if(NOT CMAKE_SIZEOF_VOID_P STREQUAL "@CMAKE_SIZEOF_VOID_P@") math(EXPR installedBits "8 * @CMAKE_SIZEOF_VOID_P@") set(PACKAGE_VERSION "${PACKAGE_VERSION} (${installedBits}bit)") set(PACKAGE_VERSION_UNSUITABLE TRUE) endif() fortran-testdrive-0.6.0/config/CMakeLists.txt0000664000175000017500000000637515201524466021410 0ustar alastairalastair# This file is part of test-drive. # SPDX-Identifier: Apache-2.0 OR MIT # # Licensed under either of Apache License, Version 2.0 or MIT license # at your option; you may not use this file except in compliance with # the License. # # Unless required by applicable law or agreed to in writing, software # distributed under the License is distributed on an "AS IS" BASIS, # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. # See the License for the specific language governing permissions and # limitations under the License. option(BUILD_SHARED_LIBS "Whether the libraries built should be shared" FALSE) option(TESTDRIVE_BUILD_TESTING "Enable testing for this project" ON) set( module-dir "${PROJECT_NAME}/${CMAKE_Fortran_COMPILER_ID}-${CMAKE_Fortran_COMPILER_VERSION}" ) set(module-dir "${module-dir}" PARENT_SCOPE) # Set build type as CMake does not provide defaults if(NOT CMAKE_BUILD_TYPE AND NOT CMAKE_CONFIGURATION_TYPES) set( CMAKE_BUILD_TYPE "RelWithDebInfo" CACHE STRING "Build type to be used." FORCE ) message( STATUS "Setting build type to '${CMAKE_BUILD_TYPE}' as none was specified." ) endif() if(NOT DEFINED TESTDRIVE_WITH_QP AND DEFINED WITH_QP) set(TESTDRIVE_WITH_QP ${WITH_QP}) endif() if(NOT DEFINED TESTDRIVE_WITH_XDP AND DEFINED WITH_XDP) set(TESTDRIVE_WITH_XDP ${WITH_XDP}) endif() if(NOT DEFINED TESTDRIVE_WITH_IEEE_IS_NAN AND DEFINED WITH_IEEE_IS_NAN) set(TESTDRIVE_WITH_IEEE_IS_NAN ${WITH_IEEE_IS_NAN}) endif() include(CheckFortranSourceCompiles) if(NOT DEFINED TESTDRIVE_WITH_QP) check_fortran_source_compiles( "integer, parameter :: qp = selected_real_kind(33); complex(qp) :: x; end" TESTDRIVE_WITH_QP SRC_EXT "F90" ) set(TESTDRIVE_WITH_QP ${TESTDRIVE_WITH_QP} PARENT_SCOPE) endif() if(NOT DEFINED TESTDRIVE_WITH_XDP) check_fortran_source_compiles( " integer, parameter :: xdp = merge(-1, selected_real_kind(18), selected_real_kind(18) == selected_real_kind(33)) complex(xdp) :: x end " TESTDRIVE_WITH_XDP SRC_EXT "F90" ) set(TESTDRIVE_WITH_XDP ${TESTDRIVE_WITH_XDP} PARENT_SCOPE) endif() if(NOT DEFINED TESTDRIVE_WITH_IEEE_IS_NAN) check_fortran_source_compiles( "use, intrinsic :: ieee_arithmetic, only : ieee_is_nan; logical :: x; x = ieee_is_nan(0.0); end" TESTDRIVE_WITH_IEEE_IS_NAN SRC_EXT "F90" ) set(TESTDRIVE_WITH_IEEE_IS_NAN ${TESTDRIVE_WITH_IEEE_IS_NAN} PARENT_SCOPE) endif() include(CMakePackageConfigHelpers) configure_package_config_file( "${CMAKE_CURRENT_SOURCE_DIR}/template-config.cmake" "${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}-config.cmake" INSTALL_DESTINATION "${CMAKE_INSTALL_LIBDIR}/cmake/${PROJECT_NAME}" ) write_basic_package_version_file( "${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}-config-version.cmake" VERSION "${PROJECT_VERSION}" COMPATIBILITY SameMinorVersion ) install( FILES "${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}-config.cmake" "${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}-config-version.cmake" DESTINATION "${CMAKE_INSTALL_LIBDIR}/cmake/${PROJECT_NAME}" ) configure_file( "${CMAKE_CURRENT_SOURCE_DIR}/template.pc" "${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}.pc" @ONLY ) install( FILES "${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}.pc" DESTINATION "${CMAKE_INSTALL_LIBDIR}/pkgconfig" ) fortran-testdrive-0.6.0/config/template-config.cmake0000664000175000017500000000050415201524466022714 0ustar alastairalastair@PACKAGE_INIT@ set("TESTDRIVE_WITH_QP" @TESTDRIVE_WITH_QP@) set("TESTDRIVE_WITH_XDP" @TESTDRIVE_WITH_XDP@) set("TESTDRIVE_WITH_IEEE_IS_NAN" @TESTDRIVE_WITH_IEEE_IS_NAN@) enable_language("Fortran") if(NOT TARGET "@PROJECT_NAME@::@PROJECT_NAME@") include("${CMAKE_CURRENT_LIST_DIR}/@PROJECT_NAME@-targets.cmake") endif() fortran-testdrive-0.6.0/config/template.pc0000664000175000017500000000044215201524466020774 0ustar alastairalastairprefix=@CMAKE_INSTALL_PREFIX@ libdir=${prefix}/@CMAKE_INSTALL_LIBDIR@ includedir=${prefix}/@CMAKE_INSTALL_INCLUDEDIR@ Name: @PROJECT_NAME@ Description: @PROJECT_DESCRIPTION@ Version: @PROJECT_VERSION@ Libs: -L${libdir} -l@PROJECT_NAME@ Cflags: -I${includedir} -I${includedir}/@module-dir@ fortran-testdrive-0.6.0/.codecov.yml0000664000175000017500000000011615201524466017611 0ustar alastairalastairfixes: - "/home/runner/work/test-drive/test-drive::" ignore: - "test/**" fortran-testdrive-0.6.0/fpm.toml0000664000175000017500000000040215201524466017043 0ustar alastairalastairname = "test-drive" version = "0.6.0" license = "Apache-2.0 OR MIT" maintainer = ["@awvwgk"] author = ["Sebastian Ehlert"] copyright = "2020-2021 Sebastian Ehlert" description = "The simple testing framework" keywords = ["testing-framework", "unit-testing"] fortran-testdrive-0.6.0/LICENSE-Apache0000664000175000017500000002613615201524466017564 0ustar alastairalastair Apache License Version 2.0, January 2004 http://www.apache.org/licenses/ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 1. Definitions. "License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. "Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. "Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. "You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. "Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. "Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. "Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). "Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. "Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." "Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. 2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. 3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. 4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: (a) You must give any other recipients of the Work or Derivative Works a copy of this License; and (b) You must cause any modified files to carry prominent notices stating that You changed the files; and (c) You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and (d) If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. 5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. 6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. 7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. 8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. 9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. END OF TERMS AND CONDITIONS APPENDIX: How to apply the Apache License to your work. To apply the Apache License to your work, attach the following boilerplate notice, with the fields enclosed by brackets "[]" replaced with your own identifying information. (Don't include the brackets!) The text should be enclosed in the appropriate comment syntax for the file format. We also recommend that a file or class name and description of purpose be included on the same "printed page" as the copyright notice for easier identification within third-party archives. Copyright [yyyy] [name of copyright owner] Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. fortran-testdrive-0.6.0/.gitignore0000664000175000017500000000046315201524466017363 0ustar alastairalastair# Prerequisites *.d # Compiled Object files *.slo *.lo *.o *.obj # Precompiled Headers *.gch *.pch # Compiled Dynamic libraries *.so *.dylib *.dll # Fortran module files *.mod *.smod # Compiled Static libraries *.lai *.la *.a *.lib # Executables *.exe *.out *.app # Directories /build*/ /_*/ /docs*/ fortran-testdrive-0.6.0/meson_options.txt0000664000175000017500000000173515201524466021033 0ustar alastairalastair# This file is part of test-drive. # SPDX-Identifier: Apache-2.0 OR MIT # # Licensed under either of Apache License, Version 2.0 or MIT license # at your option; you may not use this file except in compliance with # the License. # # Unless required by applicable law or agreed to in writing, software # distributed under the License is distributed on an "AS IS" BASIS, # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. # See the License for the specific language governing permissions and # limitations under the License. option( 'openmp', type: 'boolean', value: false, yield: true, description: 'use OpenMP parallelisation', ) option( 'xdp', type: 'feature', value: 'auto', description: 'Support extended double precision', ) option( 'qp', type: 'feature', value: 'auto', description: 'Support quadruple precision', ) option( 'testing', type: 'feature', value: 'auto', description: 'Enable testing of test-drive library', ) fortran-testdrive-0.6.0/CMakeLists.txt0000664000175000017500000000611115201524466020127 0ustar alastairalastair# This file is part of test-drive. # SPDX-Identifier: Apache-2.0 OR MIT # # Licensed under either of Apache License, Version 2.0 or MIT license # at your option; you may not use this file except in compliance with # the License. # # Unless required by applicable law or agreed to in writing, software # distributed under the License is distributed on an "AS IS" BASIS, # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. # See the License for the specific language governing permissions and # limitations under the License. cmake_minimum_required(VERSION 3.9...3.31) get_directory_property(is-subproject PARENT_DIRECTORY) project( "test-drive" LANGUAGES "Fortran" VERSION "0.6.0" DESCRIPTION "The simple testing framework" ) # Follow GNU conventions for installing directories include(GNUInstallDirs) # General configuration information add_subdirectory("config") # Collect source of the project set(srcs) add_subdirectory("src") # We need the module directory before we finish the configure stage if(NOT EXISTS "${PROJECT_BINARY_DIR}/include") make_directory("${PROJECT_BINARY_DIR}/include") endif() # Testing library target add_library( "${PROJECT_NAME}-lib" "${srcs}" ) set_target_properties( "${PROJECT_NAME}-lib" PROPERTIES POSITION_INDEPENDENT_CODE TRUE OUTPUT_NAME "${PROJECT_NAME}" VERSION "${PROJECT_VERSION}" SOVERSION "${PROJECT_VERSION_MAJOR}" Fortran_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/include" ) target_include_directories( "${PROJECT_NAME}-lib" PUBLIC $ $ ) target_compile_definitions( "${PROJECT_NAME}-lib" PRIVATE "WITH_QP=$" "WITH_XDP=$" "WITH_IEEE_IS_NAN=$" ) # Export targets for other projects add_library("${PROJECT_NAME}" INTERFACE) add_library("${PROJECT_NAME}:${PROJECT_NAME}" ALIAS "${PROJECT_NAME}") target_link_libraries("${PROJECT_NAME}" INTERFACE "${PROJECT_NAME}-lib") install( TARGETS "${PROJECT_NAME}" "${PROJECT_NAME}-lib" EXPORT "${PROJECT_NAME}-targets" LIBRARY DESTINATION "${CMAKE_INSTALL_LIBDIR}" ARCHIVE DESTINATION "${CMAKE_INSTALL_LIBDIR}" ) install( EXPORT "${PROJECT_NAME}-targets" NAMESPACE "${PROJECT_NAME}::" DESTINATION "${CMAKE_INSTALL_LIBDIR}/cmake/${PROJECT_NAME}" ) install( DIRECTORY "${PROJECT_BINARY_DIR}/include/" DESTINATION "${CMAKE_INSTALL_INCLUDEDIR}/${module-dir}" ) # Package license files install( FILES "LICENSE-Apache" "LICENSE-MIT" DESTINATION "${CMAKE_INSTALL_DATADIR}/licenses/${PROJECT_NAME}" ) # add the testsuite include(CTest) if(DEFINED TEST_DRIVE_BUILD_TESTING AND NOT DEFINED TESTDRIVE_BUILD_TESTING) message(WARNING "TEST_DRIVE_BUILD_TESTING is deprecated, use TESTDRIVE_BUILD_TESTING instead") set(TESTDRIVE_BUILD_TESTING ${TEST_DRIVE_BUILD_TESTING}) endif() if(NOT DEFINED TESTDRIVE_BUILD_TESTING AND DEFINED BUILD_TESTING) set(TESTDRIVE_BUILD_TESTING ${BUILD_TESTING}) endif() if(TESTDRIVE_BUILD_TESTING) add_subdirectory("test") endif() fortran-testdrive-0.6.0/.github/0000775000175000017500000000000015201524466016730 5ustar alastairalastairfortran-testdrive-0.6.0/.github/workflows/0000775000175000017500000000000015201524466020765 5ustar alastairalastairfortran-testdrive-0.6.0/.github/workflows/build.yml0000664000175000017500000001123315201524466022607 0ustar alastairalastairname: CI on: [push, pull_request] env: BUILD_DIR: _build jobs: build: runs-on: ${{ matrix.os }} strategy: fail-fast: false matrix: os: [ubuntu-24.04, macos-15, macos-15-intel] build: [meson, cmake] build-type: [debug] compiler: [gcc] version: [13] include: - os: ubuntu-latest build: fpm build-type: debug compiler: gcc version: 12 - os: ubuntu-latest build: meson build-type: coverage compiler: gcc version: 10 - os: ubuntu-latest build: meson build-type: debug compiler: gcc version: 9 - os: ubuntu-latest build: meson build-type: debug compiler: gcc version: 11 - os: ubuntu-latest build: meson build-type: debug compiler: intel-classic version: 2021.6 - os: macos-15-intel build: meson build-type: debug compiler: intel-classic version: 2021.6 defaults: run: shell: bash steps: - name: Checkout code uses: actions/checkout@v5 - name: Setup python uses: actions/setup-python@v5 with: python-version: '3.10' cache: 'pip' - name: Install python dependencies if: ${{ ! contains(matrix.os, 'windows') }} run: pip install -r requirements.txt - name: Setup fortran uses: fortran-lang/setup-fortran@v1 with: compiler: ${{ matrix.compiler }} version: ${{ matrix.version }} - name: Setup fpm if: ${{ matrix.build == 'fpm' }} uses: fortran-lang/setup-fpm@v3 with: fpm-version: 'v0.2.0' - name: Configure build (meson) if: ${{ matrix.build == 'meson' }} run: >- meson setup ${{ env.BUILD_DIR }} --buildtype=debug --prefix=$PWD/_dist --libdir=lib --warnlevel=0 -Db_coverage=${{ env.COVERAGE }} ${{ env.MESON_ARGS }} env: COVERAGE: ${{ matrix.build-type == 'coverage' }} MESON_ARGS: ${{ matrix.compiler == 'intel-classic' && '-Dfortran_link_args=-qopenmp' || '' }} - name: Configure build (CMake) if: ${{ matrix.build == 'cmake' }} run: >- cmake -B${{ env.BUILD_DIR }} -GNinja -DCMAKE_BUILD_TYPE=Debug -DCMAKE_INSTALL_PREFIX=$PWD/_dist -DCMAKE_INSTALL_LIBDIR=lib - name: Build library (fpm) if: ${{ matrix.build == 'fpm' }} run: fpm build - name: Build library if: ${{ matrix.build != 'fpm' }} run: ninja -C ${{ env.BUILD_DIR }} - name: Run unit tests (fpm) if: ${{ matrix.build == 'fpm' }} run: fpm test - name: Run unit tests (meson) if: ${{ matrix.build == 'meson' }} run: meson test -C ${{ env.BUILD_DIR }} --print-errorlogs --no-rebuild --num-processes 2 -t 2 - name: Run unit tests (ctest) if: ${{ matrix.build == 'cmake' }} run: ctest --output-on-failure --parallel 2 working-directory: ${{ env.BUILD_DIR }} - name: Create coverage report if: ${{ matrix.build == 'meson' && matrix.build-type == 'coverage' }} run: ninja -C ${{ env.BUILD_DIR }} coverage - name: Install project if: ${{ matrix.build != 'fpm' }} run: | ninja -C ${{ env.BUILD_DIR }} install echo "PROJECT_PREFIX=$PWD/_dist" >> $GITHUB_ENV - name: Discover installed files (CMake) if: ${{ matrix.build != 'fpm' }} run: | cmake -S test/export -B ${{ env.BUILD_DIR }}/discover-cmake -G Ninja -DCMAKE_PREFIX_PATH=$PWD/_dist/lib/cmake cmake --build ${{ env.BUILD_DIR }}/discover-cmake - name: Discover installed files (Meson) if: ${{ matrix.build != 'fpm' }} run: | meson setup ${{ env.BUILD_DIR }}/discover-meson test/export --pkg-config-path=$PWD/_dist/lib/pkgconfig meson compile -C ${{ env.BUILD_DIR }}/discover-meson - name: Create package if: ${{ matrix.build == 'meson' }} run: | tar cvf ${{ env.OUTPUT }} _dist xz -T0 ${{ env.OUTPUT }} echo "PROJECT_OUTPUT=${{ env.OUTPUT }}.xz" >> $GITHUB_ENV env: OUTPUT: test-drive-${{ matrix.compiler }}-${{ matrix.version }}-${{ matrix.os }}.tar - name: Upload package if: ${{ matrix.build == 'meson' && matrix.build-type != 'coverage' }} uses: actions/upload-artifact@v4 with: name: ${{ env.PROJECT_OUTPUT }} path: ${{ env.PROJECT_OUTPUT }} - name: Upload coverage report if: ${{ matrix.build == 'meson' && matrix.build-type == 'coverage' }} uses: codecov/codecov-action@v3