├── .codecov.yml ├── .github └── workflows │ └── build.yml ├── .gitignore ├── CMakeLists.txt ├── LICENSE-Apache ├── LICENSE-MIT ├── README.md ├── config ├── CMakeLists.txt ├── install-mod.py ├── meson.build ├── template.cmake └── template.pc ├── fpm.toml ├── meson.build ├── meson_options.txt ├── requirements.txt ├── src ├── CMakeLists.txt ├── meson.build ├── testdrive.F90 └── testdrive_version.f90 └── test ├── CMakeLists.txt ├── main.f90 ├── meson.build ├── test_check.F90 └── test_select.F90 /.codecov.yml: -------------------------------------------------------------------------------- 1 | fixes: 2 | - "/home/runner/work/test-drive/test-drive::" 3 | 4 | ignore: 5 | - "test/**" 6 | -------------------------------------------------------------------------------- /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: [push, pull_request] 4 | 5 | env: 6 | BUILD_DIR: _build 7 | 8 | jobs: 9 | build: 10 | runs-on: ${{ matrix.os }} 11 | strategy: 12 | fail-fast: false 13 | matrix: 14 | os: [ubuntu-latest, macos-13] 15 | build: [meson, cmake] 16 | build-type: [debug] 17 | compiler: [gcc] 18 | version: [12] 19 | 20 | include: 21 | - os: ubuntu-latest 22 | build: fpm 23 | build-type: debug 24 | compiler: gcc 25 | version: 10 26 | 27 | - os: ubuntu-latest 28 | build: meson 29 | build-type: coverage 30 | compiler: gcc 31 | version: 10 32 | 33 | - os: ubuntu-latest 34 | build: meson 35 | build-type: debug 36 | compiler: gcc 37 | version: 9 38 | 39 | - os: ubuntu-latest 40 | build: meson 41 | build-type: debug 42 | compiler: gcc 43 | version: 11 44 | 45 | - os: ubuntu-latest 46 | build: meson 47 | build-type: debug 48 | compiler: intel-classic 49 | version: 2021.6 50 | 51 | - os: macos-13 52 | build: meson 53 | build-type: debug 54 | compiler: intel-classic 55 | version: 2021.6 56 | 57 | defaults: 58 | run: 59 | shell: bash 60 | 61 | steps: 62 | - name: Checkout code 63 | uses: actions/checkout@v3 64 | 65 | - name: Setup python 66 | uses: actions/setup-python@v4 67 | with: 68 | python-version: 3.8 69 | cache: 'pip' 70 | 71 | - name: Install python dependencies 72 | if: ${{ ! contains(matrix.os, 'windows') }} 73 | run: pip install -r requirements.txt 74 | 75 | - name: Setup fortran 76 | uses: fortran-lang/setup-fortran@v1 77 | with: 78 | compiler: ${{ matrix.compiler }} 79 | version: ${{ matrix.version }} 80 | 81 | - name: Setup fpm 82 | if: ${{ matrix.build == 'fpm' }} 83 | uses: fortran-lang/setup-fpm@v3 84 | with: 85 | fpm-version: 'v0.2.0' 86 | 87 | - name: Configure build (meson) 88 | if: ${{ matrix.build == 'meson' }} 89 | run: >- 90 | meson setup ${{ env.BUILD_DIR }} 91 | --buildtype=debug 92 | --prefix=$PWD/_dist 93 | --libdir=lib 94 | --warnlevel=0 95 | -Db_coverage=${{ env.COVERAGE }} 96 | ${{ env.MESON_ARGS }} 97 | env: 98 | COVERAGE: ${{ matrix.build-type == 'coverage' }} 99 | MESON_ARGS: ${{ matrix.compiler == 'intel-classic' && '-Dfortran_link_args=-qopenmp' || '' }} 100 | 101 | - name: Configure build (CMake) 102 | if: ${{ matrix.build == 'cmake' }} 103 | run: >- 104 | cmake -B${{ env.BUILD_DIR }} 105 | -GNinja 106 | -DCMAKE_BUILD_TYPE=Debug 107 | -DCMAKE_INSTALL_PREFIX=$PWD/_dist 108 | -DCMAKE_INSTALL_LIBDIR=lib 109 | 110 | - name: Build library (fpm) 111 | if: ${{ matrix.build == 'fpm' }} 112 | run: fpm build 113 | 114 | - name: Build library 115 | if: ${{ matrix.build != 'fpm' }} 116 | run: ninja -C ${{ env.BUILD_DIR }} 117 | 118 | - name: Run unit tests (fpm) 119 | if: ${{ matrix.build == 'fpm' }} 120 | run: fpm test 121 | 122 | - name: Run unit tests (meson) 123 | if: ${{ matrix.build == 'meson' }} 124 | run: meson test -C ${{ env.BUILD_DIR }} --print-errorlogs --no-rebuild --num-processes 2 -t 2 125 | 126 | - name: Run unit tests (ctest) 127 | if: ${{ matrix.build == 'cmake' }} 128 | run: ctest --output-on-failure --parallel 2 129 | working-directory: ${{ env.BUILD_DIR }} 130 | 131 | - name: Create coverage report 132 | if: ${{ matrix.build == 'meson' && matrix.build-type == 'coverage' }} 133 | run: ninja -C ${{ env.BUILD_DIR }} coverage 134 | 135 | - name: Install project 136 | if: ${{ matrix.build != 'fpm' }} 137 | run: | 138 | ninja -C ${{ env.BUILD_DIR }} install 139 | echo "PROJECT_PREFIX=$PWD/_dist" >> $GITHUB_ENV 140 | 141 | - name: Create package 142 | if: ${{ matrix.build == 'meson' }} 143 | run: | 144 | tar cvf ${{ env.OUTPUT }} _dist 145 | xz -T0 ${{ env.OUTPUT }} 146 | echo "PROJECT_OUTPUT=${{ env.OUTPUT }}.xz" >> $GITHUB_ENV 147 | env: 148 | OUTPUT: test-drive-${{ matrix.compiler }}-${{ matrix.version }}-${{ matrix.os }}.tar 149 | 150 | - name: Upload package 151 | if: ${{ matrix.build == 'meson' && matrix.build-type != 'coverage' }} 152 | uses: actions/upload-artifact@v3 153 | with: 154 | name: ${{ env.PROJECT_OUTPUT }} 155 | path: ${{ env.PROJECT_OUTPUT }} 156 | 157 | - name: Upload coverage report 158 | if: ${{ matrix.build == 'meson' && matrix.build-type == 'coverage' }} 159 | uses: codecov/codecov-action@v3 160 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Prerequisites 2 | *.d 3 | 4 | # Compiled Object files 5 | *.slo 6 | *.lo 7 | *.o 8 | *.obj 9 | 10 | # Precompiled Headers 11 | *.gch 12 | *.pch 13 | 14 | # Compiled Dynamic libraries 15 | *.so 16 | *.dylib 17 | *.dll 18 | 19 | # Fortran module files 20 | *.mod 21 | *.smod 22 | 23 | # Compiled Static libraries 24 | *.lai 25 | *.la 26 | *.a 27 | *.lib 28 | 29 | # Executables 30 | *.exe 31 | *.out 32 | *.app 33 | 34 | # Directories 35 | /build*/ 36 | /_*/ 37 | /docs*/ 38 | -------------------------------------------------------------------------------- /CMakeLists.txt: -------------------------------------------------------------------------------- 1 | # This file is part of test-drive. 2 | # SPDX-Identifier: Apache-2.0 OR MIT 3 | # 4 | # Licensed under either of Apache License, Version 2.0 or MIT license 5 | # at your option; you may not use this file except in compliance with 6 | # the License. 7 | # 8 | # Unless required by applicable law or agreed to in writing, software 9 | # distributed under the License is distributed on an "AS IS" BASIS, 10 | # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 11 | # See the License for the specific language governing permissions and 12 | # limitations under the License. 13 | 14 | cmake_minimum_required(VERSION 3.9) 15 | get_directory_property(is-subproject PARENT_DIRECTORY) 16 | 17 | project( 18 | "test-drive" 19 | LANGUAGES "Fortran" 20 | VERSION "0.5.0" 21 | DESCRIPTION "The simple testing framework" 22 | ) 23 | 24 | # Follow GNU conventions for installing directories 25 | include(GNUInstallDirs) 26 | 27 | # General configuration information 28 | add_subdirectory("config") 29 | 30 | # Collect source of the project 31 | set(srcs) 32 | add_subdirectory("src") 33 | 34 | # We need the module directory before we finish the configure stage 35 | if(NOT EXISTS "${PROJECT_BINARY_DIR}/include") 36 | make_directory("${PROJECT_BINARY_DIR}/include") 37 | endif() 38 | 39 | # Testing library target 40 | add_library( 41 | "${PROJECT_NAME}-lib" 42 | "${srcs}" 43 | ) 44 | set_target_properties( 45 | "${PROJECT_NAME}-lib" 46 | PROPERTIES 47 | POSITION_INDEPENDENT_CODE TRUE 48 | OUTPUT_NAME "${PROJECT_NAME}" 49 | VERSION "${PROJECT_VERSION}" 50 | SOVERSION "${PROJECT_VERSION_MAJOR}" 51 | Fortran_MODULE_DIRECTORY "${PROJECT_BINARY_DIR}/include" 52 | ) 53 | target_include_directories( 54 | "${PROJECT_NAME}-lib" 55 | PUBLIC 56 | $ 57 | $ 58 | ) 59 | target_compile_definitions( 60 | "${PROJECT_NAME}-lib" 61 | PRIVATE 62 | "WITH_QP=$" 63 | "WITH_XDP=$" 64 | ) 65 | 66 | # Export targets for other projects 67 | add_library("${PROJECT_NAME}" INTERFACE) 68 | target_link_libraries("${PROJECT_NAME}" INTERFACE "${PROJECT_NAME}-lib") 69 | install( 70 | TARGETS 71 | "${PROJECT_NAME}" 72 | "${PROJECT_NAME}-lib" 73 | EXPORT 74 | "${PROJECT_NAME}-targets" 75 | LIBRARY DESTINATION "${CMAKE_INSTALL_LIBDIR}" 76 | ARCHIVE DESTINATION "${CMAKE_INSTALL_LIBDIR}" 77 | ) 78 | install( 79 | EXPORT 80 | "${PROJECT_NAME}-targets" 81 | NAMESPACE 82 | "${PROJECT_NAME}::" 83 | DESTINATION "${CMAKE_INSTALL_LIBDIR}/cmake/${PROJECT_NAME}" 84 | ) 85 | install( 86 | DIRECTORY 87 | "${PROJECT_BINARY_DIR}/include/" 88 | DESTINATION "${CMAKE_INSTALL_INCLUDEDIR}/${module-dir}" 89 | ) 90 | # Package license files 91 | install( 92 | FILES 93 | "LICENSE-Apache" 94 | "LICENSE-MIT" 95 | DESTINATION "${CMAKE_INSTALL_DATADIR}/licenses/${PROJECT_NAME}" 96 | ) 97 | 98 | # add the testsuite 99 | include(CTest) 100 | if(BUILD_TESTING AND TEST_DRIVE_BUILD_TESTING) 101 | add_subdirectory("test") 102 | endif() 103 | -------------------------------------------------------------------------------- /LICENSE-Apache: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | 179 | APPENDIX: How to apply the Apache License to your work. 180 | 181 | To apply the Apache License to your work, attach the following 182 | boilerplate notice, with the fields enclosed by brackets "[]" 183 | replaced with your own identifying information. (Don't include 184 | the brackets!) The text should be enclosed in the appropriate 185 | comment syntax for the file format. We also recommend that a 186 | file or class name and description of purpose be included on the 187 | same "printed page" as the copyright notice for easier 188 | identification within third-party archives. 189 | 190 | Copyright [yyyy] [name of copyright owner] 191 | 192 | Licensed under the Apache License, Version 2.0 (the "License"); 193 | you may not use this file except in compliance with the License. 194 | You may obtain a copy of the License at 195 | 196 | http://www.apache.org/licenses/LICENSE-2.0 197 | 198 | Unless required by applicable law or agreed to in writing, software 199 | distributed under the License is distributed on an "AS IS" BASIS, 200 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 201 | See the License for the specific language governing permissions and 202 | limitations under the License. 203 | -------------------------------------------------------------------------------- /LICENSE-MIT: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020-2021 Sebastian Ehlert 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # The simple testing framework 2 | 3 | [![License](https://img.shields.io/badge/license-MIT%7CApache%202.0-blue)](LICENSE-Apache) 4 | [![Latest Version](https://img.shields.io/github/v/release/fortran-lang/test-drive)](https://github.com/fortran-lang/test-drive/releases/latest) 5 | [![CI](https://github.com/fortran-lang/test-drive/workflows/CI/badge.svg)](https://github.com/fortran-lang/test-drive/actions) 6 | [![codecov](https://codecov.io/gh/fortran-lang/test-drive/branch/main/graph/badge.svg)](https://codecov.io/gh/fortran-lang/test-drive) 7 | 8 | This project offers a lightweight, procedural unit testing framework based on nothing but standard Fortran. 9 | Integration with [meson](https://mesonbuild.com), [cmake](https://cmake.org) and [Fortran package manager (fpm)](https://github.com/fortran-lang/fpm) is available. 10 | Alternatively, the [``testdrive.F90``](src/testdrive.F90) source file can be redistributed in the project's testsuite as well. 11 | 12 | 13 | ## Usage 14 | 15 | Testsuites are defined by a ``collect_interface`` returning a set of ``unittest_type`` objects. 16 | To create a new test use the ``new_unittest`` constructor, which requires a test identifier and a procedure with a ``test_interface`` compatible signature. 17 | The error status is communicated by the allocation status of an ``error_type``. 18 | 19 | The necessary boilerplate code to setup the test entry point is just 20 | 21 | ```fortran 22 | program tester 23 | use, intrinsic :: iso_fortran_env, only : error_unit 24 | use testdrive, only : run_testsuite, new_testsuite, testsuite_type 25 | use test_suite1, only : collect_suite1 26 | use test_suite2, only : collect_suite2 27 | implicit none 28 | integer :: stat, is 29 | type(testsuite_type), allocatable :: testsuites(:) 30 | character(len=*), parameter :: fmt = '("#", *(1x, a))' 31 | 32 | stat = 0 33 | 34 | testsuites = [ & 35 | new_testsuite("suite1", collect_suite1), & 36 | new_testsuite("suite2", collect_suite2) & 37 | ] 38 | 39 | do is = 1, size(testsuites) 40 | write(error_unit, fmt) "Testing:", testsuites(is)%name 41 | call run_testsuite(testsuites(is)%collect, error_unit, stat) 42 | end do 43 | 44 | if (stat > 0) then 45 | write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" 46 | error stop 47 | end if 48 | 49 | end program tester 50 | ``` 51 | 52 | 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. 53 | All tests have a simple interface with just an allocatable ``error_type`` as output to provide the test results. 54 | 55 | ```fortran 56 | module test_suite1 57 | use testdrive, only : new_unittest, unittest_type, error_type, check 58 | implicit none 59 | private 60 | 61 | public :: collect_suite1 62 | 63 | contains 64 | 65 | !> Collect all exported unit tests 66 | subroutine collect_suite1(testsuite) 67 | !> Collection of tests 68 | type(unittest_type), allocatable, intent(out) :: testsuite(:) 69 | 70 | testsuite = [ & 71 | new_unittest("valid", test_valid), & 72 | new_unittest("invalid", test_invalid, should_fail=.true.) & 73 | ] 74 | 75 | end subroutine collect_suite1 76 | 77 | subroutine test_valid(error) 78 | type(error_type), allocatable, intent(out) :: error 79 | ! ... 80 | end subroutine test_valid 81 | 82 | subroutine test_invalid(error) 83 | type(error_type), allocatable, intent(out) :: error 84 | ! ... 85 | end subroutine test_invalid 86 | 87 | end module test_suite1 88 | ``` 89 | 90 | 91 | ### Checking test conditions 92 | 93 | The procedures defining the tests can contain any Fortran code required for checking the correctness of the project. 94 | An easy way to do so is provided by the generic ``check`` function. 95 | 96 | ```f90 97 | subroutine test_valid(error) 98 | type(error_type), allocatable, intent(out) :: error 99 | 100 | call check(error, 1 + 2 == 3) 101 | if (allocated(error)) return 102 | 103 | ! equivalent to the above 104 | call check(error, 1 + 2, 3) 105 | if (allocated(error)) return 106 | end subroutine test_valid 107 | ``` 108 | 109 | After each check, the status of the error should be checked. 110 | Uncaught errors will not be silently dropped, instead the error will be caught, its message displayed and the run aborted. 111 | Possible ways to use check are listed below 112 | 113 | | available checks | arguments | 114 | | -------------------- | -------------------------------------------------------------- | 115 | | logical check | *error*, *logical*, ... | 116 | | status check | *error*, *integer*, ... | 117 | | logical comparison | *error*, *logical*, *logical*, ... | 118 | | integer comparison | *error*, *integer*, ... | 119 | | character comparison | *error*, *character*, *character*, ... | 120 | | real comparison | *error*, *real*, *real*, ..., thr=*real*, rel=*logical* | 121 | | real NaN check | *error*, *real*, ... | 122 | | complex comparison | *error*, *complex*, *complex*, ..., thr=*real*, rel=*logical* | 123 | | complex NaN check | *error*, *complex*, ... | 124 | 125 | Each check will generate a meaningful error message based on the available arguments, but can also be provided with a custom error message instead. 126 | 127 | To generate custom checks the ``test_failed`` procedure is available to generate error messages 128 | 129 | ```f90 130 | subroutine test_custom(error) 131 | type(error_type), allocatable, intent(out) :: error 132 | 133 | ! ... 134 | 135 | if (.not.cond) then 136 | call test_failed(error, "Custom check failed") 137 | return 138 | end if 139 | 140 | ! ... 141 | 142 | if (.not.cond) then 143 | call test_failed(error, "Custom check failed", "Additional context") 144 | return 145 | end if 146 | 147 | end subroutine test_custom 148 | ``` 149 | 150 | To conditionally skip a test use the ``skip_test`` procedure. 151 | 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. 152 | An uncaught skipped test will fail regardless, therefore make sure to not run any other checks afterwards. 153 | 154 | 155 | ### Integration in build systems 156 | 157 | Finally, for usage with *fpm* it is beneficial to have a single test driver which can run all tests. 158 | 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: 159 | 160 | ```f90 161 | !> Driver for unit testing 162 | program tester 163 | use, intrinsic :: iso_fortran_env, only : error_unit 164 | use testdrive, only : run_testsuite, new_testsuite, testsuite_type, & 165 | & select_suite, run_selected, get_argument 166 | use test_suite1, only : collect_suite1 167 | use test_suite2, only : collect_suite2 168 | implicit none 169 | integer :: stat, is 170 | character(len=:), allocatable :: suite_name, test_name 171 | type(testsuite_type), allocatable :: testsuites(:) 172 | character(len=*), parameter :: fmt = '("#", *(1x, a))' 173 | 174 | stat = 0 175 | 176 | testsuites = [ & 177 | new_testsuite("suite1", collect_suite1), & 178 | new_testsuite("suite2", collect_suite2) & 179 | ] 180 | 181 | call get_argument(1, suite_name) 182 | call get_argument(2, test_name) 183 | 184 | if (allocated(suite_name)) then 185 | is = select_suite(testsuites, suite_name) 186 | if (is > 0 .and. is <= size(testsuites)) then 187 | if (allocated(test_name)) then 188 | write(error_unit, fmt) "Suite:", testsuites(is)%name 189 | call run_selected(testsuites(is)%collect, test_name, error_unit, stat) 190 | if (stat < 0) then 191 | error stop 1 192 | end if 193 | else 194 | write(error_unit, fmt) "Testing:", testsuites(is)%name 195 | call run_testsuite(testsuites(is)%collect, error_unit, stat) 196 | end if 197 | else 198 | write(error_unit, fmt) "Available testsuites" 199 | do is = 1, size(testsuites) 200 | write(error_unit, fmt) "-", testsuites(is)%name 201 | end do 202 | error stop 1 203 | end if 204 | else 205 | do is = 1, size(testsuites) 206 | write(error_unit, fmt) "Testing:", testsuites(is)%name 207 | call run_testsuite(testsuites(is)%collect, error_unit, stat) 208 | end do 209 | end if 210 | 211 | if (stat > 0) then 212 | write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" 213 | error stop 1 214 | end if 215 | 216 | end program tester 217 | ``` 218 | 219 | From *fpm* this allows to run all tests using just the *fpm test* command, but also to debug an individual test in a debugger. 220 | For example to run *broken-test* in *large-suite* with ``gdb`` use 221 | 222 | ``` 223 | fpm test --runner gdb -- large-suite broken-test 224 | ``` 225 | 226 | To make this approach feasible for meson the tests can be created as individual suites. 227 | A usual layout of the test directory like 228 | 229 | ``` 230 | test 231 | ├── main.f90 232 | ├── meson.build 233 | ├── test_suite1.f90 234 | ├── test_suite2.f90 235 | └── ... 236 | ``` 237 | 238 | Can use the following snippet to automatically create individual tests running complete suites inside the driver. 239 | 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. 240 | 241 | ```meson 242 | testdrive_dep = dependency('test-drive', fallback: ['test-drive', 'testdrive_dep']) 243 | 244 | tests = [ 245 | 'suite1', 246 | 'suite2', 247 | # ... 248 | ] 249 | 250 | test_srcs = files( 251 | 'main.f90', 252 | ) 253 | foreach t : tests 254 | test_srcs += files('test_@0@.f90'.format(t.underscorify())) 255 | endforeach 256 | 257 | tester = executable( 258 | 'tester', 259 | sources: test_srcs, 260 | dependencies: [proj_dep, testdrive_dep], 261 | ) 262 | 263 | test('all tests', tester) 264 | 265 | foreach t : tests 266 | test(t, tester, args: t) 267 | endforeach 268 | ``` 269 | 270 | Similar for a CMake based build the tests can be generated automatically for the layout shown below. 271 | 272 | ``` 273 | test 274 | ├── CMakeLists.txt 275 | ├── main.f90 276 | ├── test_suite1.f90 277 | ├── test_suite2.f90 278 | └── ... 279 | ``` 280 | 281 | The CMake file in the test directory should look similar to the one shown here 282 | 283 | ```cmake 284 | if(NOT TARGET "test-drive::test-drive") 285 | find_package("test-drive" REQUIRED) 286 | endif() 287 | 288 | # Unit testing 289 | set( 290 | tests 291 | "suite1" 292 | "suite2" 293 | ) 294 | set( 295 | test-srcs 296 | "main.f90" 297 | ) 298 | foreach(t IN LISTS tests) 299 | string(MAKE_C_IDENTIFIER ${t} t) 300 | list(APPEND test-srcs "test_${t}.f90") 301 | endforeach() 302 | 303 | add_executable( 304 | "${PROJECT_NAME}-tester" 305 | "${test-srcs}" 306 | ) 307 | target_link_libraries( 308 | "${PROJECT_NAME}-tester" 309 | PRIVATE 310 | "${PROJECT_NAME}-lib" 311 | "test-drive::test-drive" 312 | ) 313 | 314 | foreach(t IN LISTS tests) 315 | add_test("${PROJECT_NAME}/${t}" "${PROJECT_NAME}-tester" "${t}") 316 | endforeach() 317 | ``` 318 | 319 |
320 | CMake module to find testing framework 321 | 322 | The following module allows to find or fetch an installation of this project in CMake 323 | 324 | ```cmake 325 | #[[.rst: 326 | Find test-drive 327 | --------------- 328 | 329 | Makes the test-drive project available. 330 | 331 | Imported Targets 332 | ^^^^^^^^^^^^^^^^ 333 | 334 | This module provides the following imported target, if found: 335 | 336 | ``test-drive::test-drive`` 337 | The test-drive library 338 | 339 | 340 | Result Variables 341 | ^^^^^^^^^^^^^^^^ 342 | 343 | This module will define the following variables: 344 | 345 | ``TEST_DRIVE_FOUND`` 346 | True if the test-drive library is available 347 | 348 | ``TEST_DRIVE_SOURCE_DIR`` 349 | Path to the source directory of the test-drive project, 350 | only set if the project is included as source. 351 | 352 | ``TEST_DRIVE_BINARY_DIR`` 353 | Path to the binary directory of the test-drive project, 354 | only set if the project is included as source. 355 | 356 | Cache variables 357 | ^^^^^^^^^^^^^^^ 358 | 359 | The following cache variables may be set to influence the library detection: 360 | 361 | ``TEST_DRIVE_FIND_METHOD`` 362 | Methods to find or make the project available. Available methods are 363 | - ``cmake``: Try to find via CMake config file 364 | - ``pkgconf``: Try to find via pkg-config file 365 | - ``subproject``: Use source in subprojects directory 366 | - ``fetch``: Fetch the source from upstream 367 | 368 | ``TEST_DRIVE_DIR`` 369 | Used for searching the CMake config file 370 | 371 | ``TEST_DRIVE_SUBPROJECT`` 372 | Directory to find the test-drive subproject, relative to the project root 373 | 374 | ``TEST_DRIVE_GIT_TAG`` 375 | The tag to use if fetching from git. 376 | 377 | #]] 378 | 379 | set(_lib "test-drive") 380 | set(_pkg "TEST_DRIVE") 381 | set(_url "https://github.com/fortran-lang/test-drive") 382 | 383 | if(NOT DEFINED "${_pkg}_FIND_METHOD") 384 | if(DEFINED "${PROJECT_NAME}-dependency-method") 385 | set("${_pkg}_FIND_METHOD" "${${PROJECT_NAME}-dependency-method}") 386 | else() 387 | set("${_pkg}_FIND_METHOD" "cmake" "pkgconf" "subproject" "fetch") 388 | endif() 389 | set("_${_pkg}_FIND_METHOD") 390 | endif() 391 | 392 | foreach(method ${${_pkg}_FIND_METHOD}) 393 | if(TARGET "${_lib}::${_lib}") 394 | break() 395 | endif() 396 | 397 | if("${method}" STREQUAL "cmake") 398 | message(STATUS "${_lib}: Find installed package") 399 | if(DEFINED "${_pkg}_DIR") 400 | set("_${_pkg}_DIR") 401 | set("${_lib}_DIR" "${_pkg}_DIR") 402 | endif() 403 | find_package("${_lib}" CONFIG) 404 | if("${_lib}_FOUND") 405 | message(STATUS "${_lib}: Found installed package") 406 | break() 407 | endif() 408 | endif() 409 | 410 | if("${method}" STREQUAL "pkgconf") 411 | find_package(PkgConfig QUIET) 412 | pkg_check_modules("${_pkg}" QUIET "${_lib}") 413 | if("${_pkg}_FOUND") 414 | message(STATUS "Found ${_lib} via pkg-config") 415 | 416 | add_library("${_lib}::${_lib}" INTERFACE IMPORTED) 417 | target_link_libraries( 418 | "${_lib}::${_lib}" 419 | INTERFACE 420 | "${${_pkg}_LINK_LIBRARIES}" 421 | ) 422 | target_include_directories( 423 | "${_lib}::${_lib}" 424 | INTERFACE 425 | "${${_pkg}_INCLUDE_DIRS}" 426 | ) 427 | 428 | break() 429 | endif() 430 | endif() 431 | 432 | if("${method}" STREQUAL "subproject") 433 | if(NOT DEFINED "${_pkg}_SUBPROJECT") 434 | set("_${_pkg}_SUBPROJECT") 435 | set("${_pkg}_SUBPROJECT" "subprojects/${_lib}") 436 | endif() 437 | set("${_pkg}_SOURCE_DIR" "${PROJECT_SOURCE_DIR}/${${_pkg}_SUBPROJECT}") 438 | set("${_pkg}_BINARY_DIR" "${PROJECT_BINARY_DIR}/${${_pkg}_SUBPROJECT}") 439 | if(EXISTS "${${_pkg}_SOURCE_DIR}/CMakeLists.txt") 440 | message(STATUS "Include ${_lib} from ${${_pkg}_SUBPROJECT}") 441 | add_subdirectory( 442 | "${${_pkg}_SOURCE_DIR}" 443 | "${${_pkg}_BINARY_DIR}" 444 | ) 445 | 446 | add_library("${_lib}::${_lib}" INTERFACE IMPORTED) 447 | target_link_libraries("${_lib}::${_lib}" INTERFACE "${_lib}") 448 | 449 | # We need the module directory in the subproject before we finish the configure stage 450 | if(NOT EXISTS "${${_pkg}_BINARY_DIR}/include") 451 | make_directory("${${_pkg}_BINARY_DIR}/include") 452 | endif() 453 | 454 | break() 455 | endif() 456 | endif() 457 | 458 | if("${method}" STREQUAL "fetch") 459 | if(NOT DEFINED "${_pkg}_GIT_TAG") 460 | set("_${_pkg}_GIT_TAG") 461 | set("${_pkg}_GIT_TAG" "HEAD") 462 | endif() 463 | message(STATUS "Retrieving ${_lib} from ${_url} with tag ${${_pkg}_GIT_TAG}") 464 | include(FetchContent) 465 | FetchContent_Declare( 466 | "${_lib}" 467 | GIT_REPOSITORY "${_url}" 468 | GIT_TAG "${${_pkg}_GIT_TAG}" 469 | ) 470 | FetchContent_MakeAvailable("${_lib}") 471 | 472 | add_library("${_lib}::${_lib}" INTERFACE IMPORTED) 473 | target_link_libraries("${_lib}::${_lib}" INTERFACE "${_lib}") 474 | 475 | # We need the module directory in the subproject before we finish the configure stage 476 | FetchContent_GetProperties("${_lib}" SOURCE_DIR "${_pkg}_SOURCE_DIR") 477 | FetchContent_GetProperties("${_lib}" BINARY_DIR "${_pkg}_BINARY_DIR") 478 | if(NOT EXISTS "${${_pkg}_BINARY_DIR}/include") 479 | make_directory("${${_pkg}_BINARY_DIR}/include") 480 | endif() 481 | 482 | break() 483 | endif() 484 | 485 | endforeach() 486 | 487 | if(TARGET "${_lib}::${_lib}") 488 | set("${_pkg}_FOUND" TRUE) 489 | else() 490 | set("${_pkg}_FOUND" FALSE) 491 | endif() 492 | 493 | if(DEFINED "_${_pkg}_GIT_TAG") 494 | unset("${_pkg}_GIT_TAG") 495 | unset("_${_pkg}_GIT_TAG") 496 | endif() 497 | if(DEFINED "_${_pkg}_SUBPROJECT") 498 | unset("${_pkg}_SUBPROJECT") 499 | unset("_${_pkg}_SUBPROJECT") 500 | endif() 501 | if(DEFINED "_${_pkg}_DIR") 502 | unset("${_lib}_DIR") 503 | unset("_${_pkg}_DIR") 504 | endif() 505 | if(DEFINED "_${_pkg}_FIND_METHOD") 506 | unset("${_pkg}_FIND_METHOD") 507 | unset("_${_pkg}_FIND_METHOD") 508 | endif() 509 | unset(_lib) 510 | unset(_pkg) 511 | unset(_url) 512 | ``` 513 |
514 | 515 | 516 | ## License 517 | 518 | 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. 519 | 520 | 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. 521 | 522 | 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. 523 | -------------------------------------------------------------------------------- /config/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | # This file is part of test-drive. 2 | # SPDX-Identifier: Apache-2.0 OR MIT 3 | # 4 | # Licensed under either of Apache License, Version 2.0 or MIT license 5 | # at your option; you may not use this file except in compliance with 6 | # the License. 7 | # 8 | # Unless required by applicable law or agreed to in writing, software 9 | # distributed under the License is distributed on an "AS IS" BASIS, 10 | # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 11 | # See the License for the specific language governing permissions and 12 | # limitations under the License. 13 | 14 | option(BUILD_SHARED_LIBS "Whether the libraries built should be shared" FALSE) 15 | option(TEST_DRIVE_BUILD_TESTING "Enable testing for this project" ON) 16 | 17 | set( 18 | module-dir 19 | "${PROJECT_NAME}/${CMAKE_Fortran_COMPILER_ID}-${CMAKE_Fortran_COMPILER_VERSION}" 20 | ) 21 | set(module-dir "${module-dir}" PARENT_SCOPE) 22 | 23 | # Set build type as CMake does not provide defaults 24 | if(NOT CMAKE_BUILD_TYPE AND NOT CMAKE_CONFIGURATION_TYPES) 25 | set( 26 | CMAKE_BUILD_TYPE "RelWithDebInfo" 27 | CACHE STRING "Build type to be used." 28 | FORCE 29 | ) 30 | message( 31 | STATUS 32 | "Setting build type to '${CMAKE_BUILD_TYPE}' as none was specified." 33 | ) 34 | endif() 35 | 36 | include(CheckFortranSourceCompiles) 37 | if(NOT DEFINED WITH_QP) 38 | check_fortran_source_compiles( 39 | "integer, parameter :: qp = selected_real_kind(33); complex(qp) :: x; end" 40 | WITH_QP 41 | ) 42 | set(WITH_QP ${WITH_QP} PARENT_SCOPE) 43 | endif() 44 | if(NOT DEFINED WITH_XDP) 45 | check_fortran_source_compiles( 46 | " 47 | integer, parameter :: xdp = merge(-1, selected_real_kind(18), selected_real_kind(18) == selected_real_kind(33)) 48 | complex(xdp) :: x 49 | end 50 | " 51 | WITH_XDP 52 | ) 53 | set(WITH_XDP ${WITH_XDP} PARENT_SCOPE) 54 | endif() 55 | 56 | include(CMakePackageConfigHelpers) 57 | configure_package_config_file( 58 | "${CMAKE_CURRENT_SOURCE_DIR}/template.cmake" 59 | "${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}-config.cmake" 60 | INSTALL_DESTINATION "${CMAKE_INSTALL_LIBDIR}/cmake/${PROJECT_NAME}" 61 | ) 62 | write_basic_package_version_file( 63 | "${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}-config-version.cmake" 64 | VERSION "${PROJECT_VERSION}" 65 | COMPATIBILITY SameMinorVersion 66 | ) 67 | install( 68 | FILES 69 | "${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}-config.cmake" 70 | "${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}-config-version.cmake" 71 | DESTINATION "${CMAKE_INSTALL_LIBDIR}/cmake/${PROJECT_NAME}" 72 | ) 73 | 74 | configure_file( 75 | "${CMAKE_CURRENT_SOURCE_DIR}/template.pc" 76 | "${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}.pc" 77 | @ONLY 78 | ) 79 | install( 80 | FILES 81 | "${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}.pc" 82 | DESTINATION "${CMAKE_INSTALL_LIBDIR}/pkgconfig" 83 | ) 84 | -------------------------------------------------------------------------------- /config/install-mod.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python3 2 | # This file is part of test-drive. 3 | # SPDX-Identifier: Apache-2.0 OR MIT 4 | # 5 | # Licensed under either of Apache License, Version 2.0 or MIT license 6 | # at your option; you may not use this file except in compliance with 7 | # the License. 8 | # 9 | # Unless required by applicable law or agreed to in writing, software 10 | # distributed under the License is distributed on an "AS IS" BASIS, 11 | # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | # See the License for the specific language governing permissions and 13 | # limitations under the License. 14 | 15 | from os import environ, listdir, makedirs 16 | from os.path import join, isdir, exists 17 | from sys import argv 18 | from shutil import copy 19 | 20 | build_dir = environ["MESON_BUILD_ROOT"] 21 | if "MESON_INSTALL_DESTDIR_PREFIX" in environ: 22 | install_dir = environ["MESON_INSTALL_DESTDIR_PREFIX"] 23 | else: 24 | install_dir = environ["MESON_INSTALL_PREFIX"] 25 | 26 | include_dir = argv[1] if len(argv) > 1 else "include" 27 | module_dir = join(install_dir, include_dir) 28 | 29 | modules = [] 30 | for d in listdir(build_dir): 31 | bd = join(build_dir, d) 32 | if isdir(bd): 33 | for f in listdir(bd): 34 | if f.endswith(".mod"): 35 | modules.append(join(bd, f)) 36 | 37 | if not exists(module_dir): 38 | makedirs(module_dir) 39 | 40 | for mod in modules: 41 | print("Installing", mod, "to", module_dir) 42 | copy(mod, module_dir) 43 | -------------------------------------------------------------------------------- /config/meson.build: -------------------------------------------------------------------------------- 1 | # This file is part of test-drive. 2 | # SPDX-Identifier: Apache-2.0 OR MIT 3 | # 4 | # Licensed under either of Apache License, Version 2.0 or MIT license 5 | # at your option; you may not use this file except in compliance with 6 | # the License. 7 | # 8 | # Unless required by applicable law or agreed to in writing, software 9 | # distributed under the License is distributed on an "AS IS" BASIS, 10 | # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 11 | # See the License for the specific language governing permissions and 12 | # limitations under the License. 13 | 14 | os = host_machine.system() 15 | fc = meson.get_compiler('fortran') 16 | fc_id = fc.get_id() 17 | ca = [] # compile args 18 | la = [] # link args 19 | 20 | if fc_id == 'gcc' 21 | ca += [ 22 | '-ffree-line-length-none', 23 | '-fbacktrace', 24 | ] 25 | if os == 'windows' 26 | la += ['-Wl,--allow-multiple-definition'] 27 | endif 28 | elif fc_id == 'intel-cl' or fc_id == 'intel-llvm-cl' 29 | ca += [ 30 | '/traceback', 31 | '/fpp', 32 | ] 33 | elif fc_id == 'intel' or fc_id == 'intel-llvm' 34 | ca += [ 35 | '-traceback', 36 | ] 37 | elif fc_id == 'pgi' or fc_id == 'nvidia_hpc' 38 | ca += [ 39 | '-Mbackslash', 40 | '-Mallocatable=03', 41 | '-traceback', 42 | ] 43 | elif fc_id == 'flang' 44 | ca += [ 45 | '-Mbackslash', 46 | '-Mallocatable=03', 47 | ] 48 | endif 49 | 50 | add_project_arguments(fc.get_supported_arguments(ca), language: 'fortran') 51 | add_project_link_arguments(fc.get_supported_arguments(la), language: 'fortran') 52 | 53 | if get_option('openmp') 54 | omp_dep = dependency('openmp') 55 | lib_deps += omp_dep 56 | endif 57 | 58 | if get_option('qp').auto() 59 | with_qp = fc.compiles(''' 60 | integer, parameter :: qp = selected_real_kind(33) 61 | complex(qp) :: x 62 | end 63 | ''') 64 | else 65 | with_qp = get_option('qp').allowed() 66 | endif 67 | 68 | if get_option('xdp').auto() 69 | with_xdp = fc.compiles(''' 70 | integer, parameter :: xdp = & 71 | & merge(-1, selected_real_kind(18), & 72 | & selected_real_kind(18) == selected_real_kind(33)) 73 | complex(xdp) :: x 74 | end 75 | ''') 76 | else 77 | with_xdp = get_option('xdp').allowed() 78 | endif 79 | 80 | add_project_arguments( 81 | '-DWITH_QP=@0@'.format(with_qp.to_int()), 82 | '-DWITH_XDP=@0@'.format(with_xdp.to_int()), 83 | language: 'fortran', 84 | ) 85 | -------------------------------------------------------------------------------- /config/template.cmake: -------------------------------------------------------------------------------- 1 | @PACKAGE_INIT@ 2 | 3 | set("@PROJECT_NAME@_WITH_QP" @WITH_QP@) 4 | set("@PROJECT_NAME@_WITH_XDP" @WITH_XDP@) 5 | 6 | if(NOT TARGET "@PROJECT_NAME@::@PROJECT_NAME@") 7 | include("${CMAKE_CURRENT_LIST_DIR}/@PROJECT_NAME@-targets.cmake") 8 | endif() 9 | -------------------------------------------------------------------------------- /config/template.pc: -------------------------------------------------------------------------------- 1 | prefix=@CMAKE_INSTALL_PREFIX@ 2 | libdir=${prefix}/@CMAKE_INSTALL_LIBDIR@ 3 | includedir=${prefix}/@CMAKE_INSTALL_INCLUDEDIR@ 4 | 5 | Name: @PROJECT_NAME@ 6 | Description: @PROJECT_DESCRIPTION@ 7 | Version: @PROJECT_VERSION@ 8 | Libs: -L${libdir} -l@PROJECT_NAME@ 9 | Cflags: -I${includedir} -I${includedir}/@module-dir@ 10 | -------------------------------------------------------------------------------- /fpm.toml: -------------------------------------------------------------------------------- 1 | name = "test-drive" 2 | version = "0.5.0" 3 | license = "Apache-2.0 OR MIT" 4 | maintainer = ["@awvwgk"] 5 | author = ["Sebastian Ehlert"] 6 | copyright = "2020-2021 Sebastian Ehlert" 7 | description = "The simple testing framework" 8 | keywords = ["testing-framework", "unit-testing"] 9 | -------------------------------------------------------------------------------- /meson.build: -------------------------------------------------------------------------------- 1 | # This file is part of test-drive. 2 | # SPDX-Identifier: Apache-2.0 OR MIT 3 | # 4 | # Licensed under either of Apache License, Version 2.0 or MIT license 5 | # at your option; you may not use this file except in compliance with 6 | # the License. 7 | # 8 | # Unless required by applicable law or agreed to in writing, software 9 | # distributed under the License is distributed on an "AS IS" BASIS, 10 | # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 11 | # See the License for the specific language governing permissions and 12 | # limitations under the License. 13 | 14 | project( 15 | 'test-drive', 16 | 'fortran', 17 | version: '0.5.0', 18 | license: 'Apache-2.0 OR MIT', 19 | meson_version: '>=0.53', 20 | default_options: [ 21 | 'buildtype=debugoptimized', 22 | 'default_library=both', 23 | ], 24 | ) 25 | install = not (meson.is_subproject() and get_option('default_library') == 'static') 26 | 27 | # General configuration information 28 | lib_deps = [] 29 | subdir('config') 30 | 31 | # Collect source of the project 32 | srcs = [] 33 | subdir('src') 34 | 35 | # MCTC library target 36 | testdrive_lib = library( 37 | meson.project_name(), 38 | sources: srcs, 39 | version: meson.project_version(), 40 | dependencies: lib_deps, 41 | install: install, 42 | ) 43 | 44 | # Export dependency for other projects and test suite 45 | testdrive_inc = testdrive_lib.private_dir_include() 46 | testdrive_dep = declare_dependency( 47 | link_with: testdrive_lib, 48 | include_directories: testdrive_inc, 49 | dependencies: lib_deps, 50 | ) 51 | 52 | # Package the license files 53 | testdrive_lic = files( 54 | 'LICENSE-Apache', 55 | 'LICENSE-MIT', 56 | ) 57 | 58 | if install 59 | # Distribute the license files in share/licenses/ 60 | install_data( 61 | testdrive_lic, 62 | install_dir: get_option('datadir')/'licenses'/meson.project_name() 63 | ) 64 | 65 | module_id = meson.project_name() / fc_id + '-' + fc.version() 66 | meson.add_install_script( 67 | 'config'/'install-mod.py', 68 | get_option('includedir') / module_id, 69 | ) 70 | 71 | pkg = import('pkgconfig') 72 | pkg.generate( 73 | testdrive_lib, 74 | description: 'The simple testing framework', 75 | subdirs: ['', module_id], 76 | ) 77 | endif 78 | 79 | # add the testsuite 80 | if get_option('testing').auto() ? not meson.is_subproject() : get_option('testing').enabled() 81 | subdir('test') 82 | endif 83 | -------------------------------------------------------------------------------- /meson_options.txt: -------------------------------------------------------------------------------- 1 | # This file is part of test-drive. 2 | # SPDX-Identifier: Apache-2.0 OR MIT 3 | # 4 | # Licensed under either of Apache License, Version 2.0 or MIT license 5 | # at your option; you may not use this file except in compliance with 6 | # the License. 7 | # 8 | # Unless required by applicable law or agreed to in writing, software 9 | # distributed under the License is distributed on an "AS IS" BASIS, 10 | # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 11 | # See the License for the specific language governing permissions and 12 | # limitations under the License. 13 | 14 | option( 15 | 'openmp', 16 | type: 'boolean', 17 | value: false, 18 | yield: true, 19 | description: 'use OpenMP parallelisation', 20 | ) 21 | 22 | option( 23 | 'xdp', 24 | type: 'feature', 25 | value: 'auto', 26 | description: 'Support extended double precision', 27 | ) 28 | 29 | option( 30 | 'qp', 31 | type: 'feature', 32 | value: 'auto', 33 | description: 'Support quadruple precision', 34 | ) 35 | 36 | option( 37 | 'testing', 38 | type: 'feature', 39 | value: 'auto', 40 | description: 'Enable testing of test-drive library', 41 | ) 42 | -------------------------------------------------------------------------------- /requirements.txt: -------------------------------------------------------------------------------- 1 | meson 2 | ninja 3 | gcovr -------------------------------------------------------------------------------- /src/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | # This file is part of test-drive. 2 | # SPDX-Identifier: Apache-2.0 OR MIT 3 | # 4 | # Licensed under either of Apache License, Version 2.0 or MIT license 5 | # at your option; you may not use this file except in compliance with 6 | # the License. 7 | # 8 | # Unless required by applicable law or agreed to in writing, software 9 | # distributed under the License is distributed on an "AS IS" BASIS, 10 | # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 11 | # See the License for the specific language governing permissions and 12 | # limitations under the License. 13 | 14 | set(dir "${CMAKE_CURRENT_SOURCE_DIR}") 15 | 16 | list( 17 | APPEND srcs 18 | "${dir}/testdrive.F90" 19 | "${dir}/testdrive_version.f90" 20 | ) 21 | 22 | set(srcs "${srcs}" PARENT_SCOPE) 23 | -------------------------------------------------------------------------------- /src/meson.build: -------------------------------------------------------------------------------- 1 | # This file is part of test-drive. 2 | # SPDX-Identifier: Apache-2.0 OR MIT 3 | # 4 | # Licensed under either of Apache License, Version 2.0 or MIT license 5 | # at your option; you may not use this file except in compliance with 6 | # the License. 7 | # 8 | # Unless required by applicable law or agreed to in writing, software 9 | # distributed under the License is distributed on an "AS IS" BASIS, 10 | # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 11 | # See the License for the specific language governing permissions and 12 | # limitations under the License. 13 | 14 | srcs += files( 15 | 'testdrive.F90', 16 | 'testdrive_version.f90', 17 | ) 18 | -------------------------------------------------------------------------------- /src/testdrive.F90: -------------------------------------------------------------------------------- 1 | ! This file is part of test-drive. 2 | ! SPDX-Identifier: Apache-2.0 OR MIT 3 | ! 4 | ! Licensed under either of Apache License, Version 2.0 or MIT license 5 | ! at your option; you may not use this file except in compliance with 6 | ! the License. 7 | ! 8 | ! Unless required by applicable law or agreed to in writing, software 9 | ! distributed under the License is distributed on an "AS IS" BASIS, 10 | ! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 11 | ! See the License for the specific language governing permissions and 12 | ! limitations under the License. 13 | 14 | !# Enable support for quadruple precision 15 | #ifndef WITH_QP 16 | #define WITH_QP 0 17 | #endif 18 | 19 | !# Enable support for extended double precision 20 | #ifndef WITH_XDP 21 | #define WITH_XDP 0 22 | #endif 23 | 24 | !> Provides a light-weight procedural testing framework for Fortran projects. 25 | !> 26 | !> Testsuites are defined by a [[collect_interface]] returning a set of 27 | !> [[unittest_type]] objects. To create a new test use the [[new_unittest]] 28 | !> constructor, which requires a test identifier and a procedure with a 29 | !> [[test_interface]] compatible signature. The error status is communicated 30 | !> by the allocation status of an [[error_type]]. 31 | !> 32 | !> The necessary boilerplate code to setup the test entry point is just 33 | !> 34 | !>```fortran 35 | !>program tester 36 | !> use, intrinsic :: iso_fortran_env, only : error_unit 37 | !> use testdrive, only : run_testsuite, new_testsuite, testsuite_type 38 | !> use test_suite1, only : collect_suite1 39 | !> use test_suite2, only : collect_suite2 40 | !> implicit none 41 | !> integer :: stat, is 42 | !> type(testsuite_type), allocatable :: testsuites(:) 43 | !> character(len=*), parameter :: fmt = '("#", *(1x, a))' 44 | !> 45 | !> stat = 0 46 | !> 47 | !> testsuites = [ & 48 | !> new_testsuite("suite1", collect_suite1), & 49 | !> new_testsuite("suite2", collect_suite2) & 50 | !> ] 51 | !> 52 | !> do is = 1, size(testsuites) 53 | !> write(error_unit, fmt) "Testing:", testsuites(is)%name 54 | !> call run_testsuite(testsuites(is)%collect, error_unit, stat) 55 | !> end do 56 | !> 57 | !> if (stat > 0) then 58 | !> write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" 59 | !> error stop 60 | !> end if 61 | !> 62 | !>end program tester 63 | !>``` 64 | !> 65 | !> Every test is defined in a separate module using a ``collect`` function, which 66 | !> is exported and added to the ``testsuites`` array in the test runner. 67 | !> All test have a simple interface with just an allocatable [[error_type]] as 68 | !> output to provide the test results. 69 | !> 70 | !>```fortran 71 | !>module test_suite1 72 | !> use testdrive, only : new_unittest, unittest_type, error_type, check 73 | !> implicit none 74 | !> private 75 | !> 76 | !> public :: collect_suite1 77 | !> 78 | !>contains 79 | !> 80 | !>!> Collect all exported unit tests 81 | !>subroutine collect_suite1(testsuite) 82 | !> !> Collection of tests 83 | !> type(unittest_type), allocatable, intent(out) :: testsuite(:) 84 | !> 85 | !> testsuite = [ & 86 | !> new_unittest("valid", test_valid), & 87 | !> new_unittest("invalid", test_invalid, should_fail=.true.) & 88 | !> ] 89 | !> 90 | !>end subroutine collect_suite1 91 | !> 92 | !>subroutine test_valid(error) 93 | !> type(error_type), allocatable, intent(out) :: error 94 | !> ! ... 95 | !>end subroutine test_valid 96 | !> 97 | !>subroutine test_invalid(error) 98 | !> type(error_type), allocatable, intent(out) :: error 99 | !> ! ... 100 | !>end subroutine test_invalid 101 | !> 102 | !>end module test_suite1 103 | !>``` 104 | !> 105 | !> For an example setup checkout the ``test/`` directory in this project. 106 | module testdrive 107 | use, intrinsic :: iso_fortran_env, only : error_unit 108 | implicit none 109 | private 110 | 111 | public :: run_testsuite, run_selected, new_unittest, new_testsuite 112 | public :: select_test, select_suite 113 | public :: unittest_type, testsuite_type, error_type 114 | public :: check, test_failed, skip_test 115 | public :: test_interface, collect_interface 116 | public :: get_argument, get_variable, to_string 117 | public :: junit_output, junit_header 118 | public :: init_color_output 119 | 120 | 121 | !> Single precision real numbers 122 | integer, parameter :: sp = selected_real_kind(6) 123 | 124 | !> Double precision real numbers 125 | integer, parameter :: dp = selected_real_kind(15) 126 | 127 | #if WITH_XDP 128 | !> Extended double precision real numbers 129 | integer, parameter :: xdp = selected_real_kind(18) 130 | #endif 131 | 132 | #if WITH_QP 133 | !> Quadruple precision real numbers 134 | integer, parameter :: qp = selected_real_kind(33) 135 | #endif 136 | 137 | !> Char length for integers 138 | integer, parameter :: i1 = selected_int_kind(2) 139 | 140 | !> Short length for integers 141 | integer, parameter :: i2 = selected_int_kind(4) 142 | 143 | !> Length of default integers 144 | integer, parameter :: i4 = selected_int_kind(9) 145 | 146 | !> Long length for integers 147 | integer, parameter :: i8 = selected_int_kind(18) 148 | 149 | !> Error code for success 150 | integer, parameter :: success = 0 151 | 152 | !> Error code for failure 153 | integer, parameter :: fatal = 1 154 | 155 | !> Error code for skipped test 156 | integer, parameter :: skipped = 77 157 | 158 | 159 | !> Error message 160 | type :: error_type 161 | 162 | !> Error code 163 | integer :: stat = success 164 | 165 | !> Payload of the error 166 | character(len=:), allocatable :: message 167 | 168 | contains 169 | 170 | !> Escalate uncaught errors 171 | final :: escalate_error 172 | 173 | end type error_type 174 | 175 | 176 | interface check 177 | module procedure :: check_stat 178 | module procedure :: check_logical 179 | module procedure :: check_float_sp 180 | module procedure :: check_float_dp 181 | #if WITH_XDP 182 | module procedure :: check_float_xdp 183 | #endif 184 | #if WITH_QP 185 | module procedure :: check_float_qp 186 | #endif 187 | module procedure :: check_float_exceptional_sp 188 | module procedure :: check_float_exceptional_dp 189 | #if WITH_XDP 190 | module procedure :: check_float_exceptional_xdp 191 | #endif 192 | #if WITH_QP 193 | module procedure :: check_float_exceptional_qp 194 | #endif 195 | module procedure :: check_complex_sp 196 | module procedure :: check_complex_dp 197 | #if WITH_XDP 198 | module procedure :: check_complex_xdp 199 | #endif 200 | #if WITH_QP 201 | module procedure :: check_complex_qp 202 | #endif 203 | module procedure :: check_complex_exceptional_sp 204 | module procedure :: check_complex_exceptional_dp 205 | #if WITH_XDP 206 | module procedure :: check_complex_exceptional_xdp 207 | #endif 208 | #if WITH_QP 209 | module procedure :: check_complex_exceptional_qp 210 | #endif 211 | module procedure :: check_int_i1 212 | module procedure :: check_int_i2 213 | module procedure :: check_int_i4 214 | module procedure :: check_int_i8 215 | module procedure :: check_bool 216 | module procedure :: check_string 217 | end interface check 218 | 219 | 220 | interface to_string 221 | module procedure :: integer_i1_to_string 222 | module procedure :: integer_i2_to_string 223 | module procedure :: integer_i4_to_string 224 | module procedure :: integer_i8_to_string 225 | module procedure :: real_sp_to_string 226 | module procedure :: real_dp_to_string 227 | #if WITH_XDP 228 | module procedure :: real_xdp_to_string 229 | #endif 230 | #if WITH_QP 231 | module procedure :: real_qp_to_string 232 | #endif 233 | module procedure :: complex_sp_to_string 234 | module procedure :: complex_dp_to_string 235 | #if WITH_XDP 236 | module procedure :: complex_xdp_to_string 237 | #endif 238 | #if WITH_QP 239 | module procedure :: complex_qp_to_string 240 | #endif 241 | end interface to_string 242 | 243 | 244 | !> Implementation of check for not a number value, in case a compiler does not 245 | !> provide the IEEE intrinsic ``ieee_is_nan`` (currently this is Intel oneAPI on MacOS) 246 | interface is_nan 247 | module procedure :: is_nan_sp 248 | module procedure :: is_nan_dp 249 | #if WITH_XDP 250 | module procedure :: is_nan_xdp 251 | #endif 252 | #if WITH_QP 253 | module procedure :: is_nan_qp 254 | #endif 255 | end interface is_nan 256 | 257 | 258 | abstract interface 259 | !> Entry point for tests 260 | subroutine test_interface(error) 261 | import :: error_type 262 | 263 | !> Error handling 264 | type(error_type), allocatable, intent(out) :: error 265 | 266 | end subroutine test_interface 267 | end interface 268 | 269 | 270 | !> Declaration of a unit test 271 | type :: unittest_type 272 | 273 | !> Name of the test 274 | character(len=:), allocatable :: name 275 | 276 | !> Entry point of the test 277 | procedure(test_interface), pointer, nopass :: test => null() 278 | 279 | !> Whether test is supposed to fail 280 | logical :: should_fail = .false. 281 | 282 | end type unittest_type 283 | 284 | 285 | abstract interface 286 | !> Collect all tests 287 | subroutine collect_interface(testsuite) 288 | import :: unittest_type 289 | 290 | !> Collection of tests 291 | type(unittest_type), allocatable, intent(out) :: testsuite(:) 292 | 293 | end subroutine collect_interface 294 | end interface 295 | 296 | 297 | !> Collection of unit tests 298 | type :: testsuite_type 299 | 300 | !> Name of the testsuite 301 | character(len=:), allocatable :: name 302 | 303 | !> Entry point of the test 304 | procedure(collect_interface), pointer, nopass :: collect => null() 305 | 306 | end type testsuite_type 307 | 308 | 309 | !> Output JUnit.xml for discovering unit tests by other tools 310 | type :: junit_output 311 | !> XML output string (initial block) 312 | character(len=:), allocatable :: xml_start 313 | !> XML output string (current block) 314 | character(len=:), allocatable :: xml_block 315 | !> XML output string (final block) 316 | character(len=:), allocatable :: xml_final 317 | !> Unique identifier 318 | integer :: uid = 0 319 | !> Timestamp 320 | character(len=19) :: timestamp = '1970-01-01T00:00:00' 321 | !> Hostname 322 | character(len=:), allocatable :: hostname 323 | !> Package name 324 | character(len=:), allocatable :: package 325 | !> Testsuite name 326 | character(len=:), allocatable :: testsuite 327 | !> Number of tests 328 | integer :: tests = 0 329 | !> Number of failures 330 | integer :: failures = 0 331 | !> Number of errors 332 | integer :: errors = 0 333 | !> Number of skipped tests 334 | integer :: skipped = 0 335 | !> Running time 336 | real(sp) :: time = 0.0_sp 337 | end type junit_output 338 | 339 | 340 | !> Container for terminal escape code 341 | type :: color_code 342 | !> Style descriptor 343 | integer(i1) :: style = -1_i1 344 | !> Background color descriptor 345 | integer(i1) :: bg = -1_i1 346 | !> Foreground color descriptor 347 | integer(i1) :: fg = -1_i1 348 | end type color_code 349 | 350 | interface operator(+) 351 | module procedure :: add_color 352 | end interface operator(+) 353 | 354 | interface operator(//) 355 | module procedure :: concat_color_left 356 | module procedure :: concat_color_right 357 | end interface operator(//) 358 | 359 | 360 | !> Colorizer class for handling colorful output in the terminal 361 | type, public :: color_output 362 | 363 | type(color_code) :: & 364 | reset = color_code(), & 365 | bold = color_code(), & 366 | dim = color_code(), & 367 | italic = color_code(), & 368 | underline = color_code(), & 369 | blink = color_code(), & 370 | reverse = color_code(), & 371 | hidden = color_code() 372 | 373 | type(color_code) :: & 374 | black = color_code(), & 375 | red = color_code(), & 376 | green = color_code(), & 377 | yellow = color_code(), & 378 | blue = color_code(), & 379 | magenta = color_code(), & 380 | cyan = color_code(), & 381 | white = color_code() 382 | 383 | type(color_code) :: & 384 | bg_black = color_code(), & 385 | bg_red = color_code(), & 386 | bg_green = color_code(), & 387 | bg_yellow = color_code(), & 388 | bg_blue = color_code(), & 389 | bg_magenta = color_code(), & 390 | bg_cyan = color_code(), & 391 | bg_white = color_code() 392 | end type color_output 393 | 394 | interface color_output 395 | module procedure :: new_color_output 396 | end interface color_output 397 | 398 | type(color_output), protected :: color 399 | 400 | character(len=*), parameter :: fmt = '(1x, *(1x, a))' 401 | character(len=*), parameter :: newline = new_line("a") 402 | 403 | 404 | contains 405 | 406 | 407 | !> Driver for testsuite 408 | recursive subroutine run_testsuite(collect, unit, stat, parallel, junit) 409 | 410 | !> Collect tests 411 | procedure(collect_interface) :: collect 412 | 413 | !> Unit for IO 414 | integer, intent(in) :: unit 415 | 416 | !> Number of failed tests 417 | integer, intent(inout) :: stat 418 | 419 | !> Run the tests in parallel 420 | logical, intent(in), optional :: parallel 421 | 422 | !> Produce junit output 423 | type(junit_output), intent(inout), optional :: junit 424 | 425 | type(unittest_type), allocatable :: testsuite(:) 426 | integer :: it 427 | logical :: parallel_ 428 | 429 | parallel_ = .true. 430 | if(present(parallel)) parallel_ = parallel 431 | 432 | call collect(testsuite) 433 | 434 | call junit_push_suite(junit, "testdrive") 435 | 436 | !$omp parallel do schedule(dynamic) shared(testsuite, unit) reduction(+:stat) & 437 | !$omp if (parallel_) 438 | do it = 1, size(testsuite) 439 | !$omp critical(testdrive_testsuite) 440 | write(unit, '(1x, 4(1x, a))') & 441 | & "Starting", (color%blue)//testsuite(it)%name//color%reset, & 442 | & color%dim//"..."//color%reset, & 443 | & color%bold//"(" // color%cyan//to_string(it)//color%bold // & 444 | & "/" // color%cyan//to_string(size(testsuite))//color%bold // ")"//color%reset 445 | !$omp end critical(testdrive_testsuite) 446 | call run_unittest(testsuite(it), unit, stat, junit) 447 | end do 448 | 449 | call junit_pop_suite(junit) 450 | 451 | end subroutine run_testsuite 452 | 453 | 454 | !> Driver for selective testing 455 | recursive subroutine run_selected(collect, name, unit, stat, junit) 456 | 457 | !> Collect tests 458 | procedure(collect_interface) :: collect 459 | 460 | !> Name of the selected test 461 | character(len=*), intent(in) :: name 462 | 463 | !> Unit for IO 464 | integer, intent(in) :: unit 465 | 466 | !> Number of failed tests 467 | integer, intent(inout) :: stat 468 | 469 | !> Produce junit output 470 | type(junit_output), intent(inout), optional :: junit 471 | 472 | type(unittest_type), allocatable :: testsuite(:) 473 | integer :: it 474 | 475 | call collect(testsuite) 476 | 477 | call junit_push_suite(junit, "testdrive") 478 | 479 | it = select_test(testsuite, name) 480 | 481 | if (it > 0 .and. it <= size(testsuite)) then 482 | call run_unittest(testsuite(it), unit, stat, junit) 483 | else 484 | write(unit, fmt) "Available tests:" 485 | do it = 1, size(testsuite) 486 | write(unit, fmt) "-", testsuite(it)%name 487 | end do 488 | stat = -huge(it) 489 | end if 490 | 491 | call junit_pop_suite(junit) 492 | 493 | end subroutine run_selected 494 | 495 | 496 | !> Run a selected unit test 497 | recursive subroutine run_unittest(test, unit, stat, junit) 498 | 499 | !> Unit test 500 | type(unittest_type), intent(in) :: test 501 | 502 | !> Unit for IO 503 | integer, intent(in) :: unit 504 | 505 | !> Number of failed tests 506 | integer, intent(inout) :: stat 507 | 508 | !> Produce junit output 509 | type(junit_output), intent(inout), optional :: junit 510 | 511 | type(error_type), allocatable :: error 512 | character(len=:), allocatable :: message 513 | 514 | call test%test(error) 515 | if (.not.test_skipped(error)) then 516 | if (allocated(error) .neqv. test%should_fail) stat = stat + 1 517 | end if 518 | call junit_push_test(junit, test, error, 0.0_sp) 519 | call make_output(message, test, error) 520 | !$omp critical(testdrive_testsuite) 521 | write(unit, '(a)') message 522 | !$omp end critical(testdrive_testsuite) 523 | if (allocated(error)) then 524 | call clear_error(error) 525 | end if 526 | 527 | end subroutine run_unittest 528 | 529 | 530 | pure function test_skipped(error) result(is_skipped) 531 | 532 | !> Error handling 533 | type(error_type), intent(in), optional :: error 534 | 535 | !> Test was skipped 536 | logical :: is_skipped 537 | 538 | is_skipped = .false. 539 | if (present(error)) then 540 | is_skipped = error%stat == skipped 541 | end if 542 | 543 | end function test_skipped 544 | 545 | 546 | !> Create output message for test (this procedure is pure and therefore cannot launch tests) 547 | pure subroutine make_output(output, test, error) 548 | 549 | !> Output message for display 550 | character(len=:), allocatable, intent(out) :: output 551 | 552 | !> Unit test 553 | type(unittest_type), intent(in) :: test 554 | 555 | !> Error handling 556 | type(error_type), intent(in), optional :: error 557 | 558 | character(len=:), allocatable :: label 559 | type(color_code) :: label_color 560 | 561 | if (test_skipped(error)) then 562 | label_color = color%yellow + color%bold 563 | label = "SKIPPED" 564 | else if (present(error) .neqv. test%should_fail) then 565 | if (test%should_fail) then 566 | label_color = color%magenta + color%bold 567 | label = "UNEXPECTED PASS" 568 | else 569 | label_color = color%red + color%bold 570 | label = "FAILED" 571 | end if 572 | else 573 | if (test%should_fail) then 574 | label_color = color%cyan + color%bold 575 | label = "EXPECTED FAIL" 576 | else 577 | label_color = color%green + color%bold 578 | label = "PASSED" 579 | end if 580 | end if 581 | output = " " // color%dim//"..."//color%reset // " " // & 582 | & color%blue//test%name//color%reset // & 583 | & " "//color%bold//"["//label_color//label//color%bold//"]"//color%reset 584 | if (present(error)) then 585 | output = output // newline // " "//color%bold//"Message:"//color%reset//" " // error%message 586 | end if 587 | end subroutine make_output 588 | 589 | 590 | !> Initialize output for JUnit.xml 591 | pure subroutine junit_header(junit, package) 592 | 593 | !> JUnit output 594 | type(junit_output), intent(inout), optional :: junit 595 | 596 | !> Package name 597 | character(len=*), intent(in) :: package 598 | 599 | if (.not.present(junit)) return 600 | 601 | junit%xml_start = & 602 | & '' // newline // & 603 | & '' // newline 607 | junit%xml_block = '' 608 | junit%xml_final = & 609 | & '' 610 | 611 | junit%hostname = 'localhost' 612 | junit%package = package 613 | 614 | end subroutine junit_header 615 | 616 | !> Register a test suite in JUnit.xml 617 | subroutine junit_push_suite(junit, name) 618 | 619 | !> JUnit output 620 | type(junit_output), intent(inout), optional :: junit 621 | 622 | !> Name of the test suite 623 | character(len=*), intent(in) :: name 624 | 625 | if (.not.present(junit)) return 626 | 627 | junit%timestamp = get_timestamp() 628 | junit%testsuite = name 629 | junit%uid = junit%uid + 1 630 | 631 | end subroutine junit_push_suite 632 | 633 | !> Finalize a test suite in JUnit.xml 634 | subroutine junit_pop_suite(junit) 635 | 636 | !> JUnit output 637 | type(junit_output), intent(inout), optional :: junit 638 | 639 | if (.not.present(junit)) return 640 | 641 | junit%xml_start = & 642 | & junit%xml_start // & 643 | & ' ' // newline // & 655 | & ' ' // newline // & 656 | & ' ' // newline // & 657 | & junit%xml_block // newline // & 658 | & ' ' // newline 659 | 660 | junit%xml_block = '' 661 | junit%tests = 0 662 | junit%failures = 0 663 | junit%errors = 0 664 | junit%skipped = 0 665 | junit%time = 0.0_sp 666 | 667 | call junit_write(junit) 668 | 669 | end subroutine junit_pop_suite 670 | 671 | !> Register a new unit test 672 | subroutine junit_push_test(junit, test, error, time) 673 | 674 | !> JUnit output 675 | type(junit_output), intent(inout), optional :: junit 676 | 677 | !> Unit test 678 | type(unittest_type), intent(in) :: test 679 | 680 | !> Error handling 681 | type(error_type), intent(in), optional :: error 682 | 683 | !> Running time 684 | real(sp), intent(in) :: time 685 | 686 | if (.not.present(junit)) return 687 | 688 | !$omp critical(testdrive_junit) 689 | junit%tests = junit%tests + 1 690 | junit%time = junit%time + time 691 | 692 | junit%xml_block = & 693 | & junit%xml_block // & 694 | & ' ' // newline 699 | 700 | if (test_skipped(error)) then 701 | junit%xml_block = & 702 | & junit%xml_block // & 703 | & ' ' // newline 704 | junit%skipped = junit%skipped + 1 705 | elseif (present(error)) then 706 | if (test%should_fail) then 707 | junit%xml_block = & 708 | & junit%xml_block // & 709 | & ' ' // newline // & 710 | & ' "'//error%message//'"' // newline // & 711 | & ' ' // newline 712 | else 713 | junit%xml_block = & 714 | & junit%xml_block // & 715 | & ' ' // newline 719 | junit%failures = junit%failures + 1 720 | end if 721 | else 722 | if (test%should_fail) then 723 | junit%xml_block = & 724 | & junit%xml_block // & 725 | & ' ' // newline 729 | junit%failures = junit%failures + 1 730 | else 731 | junit%xml_block = & 732 | & junit%xml_block // & 733 | & ' ' // newline // & 734 | & ' "Test passed successfully"' // newline // & 735 | & ' ' // newline 736 | end if 737 | end if 738 | 739 | junit%xml_block = & 740 | & junit%xml_block // & 741 | & ' ' // newline 742 | !$omp end critical(testdrive_junit) 743 | 744 | end subroutine junit_push_test 745 | 746 | 747 | !> Write results to JUnit.xml 748 | subroutine junit_write(junit) 749 | 750 | !> JUnit output 751 | type(junit_output), intent(inout), optional :: junit 752 | 753 | integer :: io 754 | 755 | if (.not.present(junit)) return 756 | open( & 757 | & newunit=io, & 758 | & file='JUnit'//junit%package//'.xml', & 759 | & status='replace', & 760 | & action='write') 761 | write(io, '(a)') junit%xml_start // junit%xml_final 762 | close(io) 763 | 764 | end subroutine junit_write 765 | 766 | 767 | !> Create ISO 8601 formatted timestamp 768 | function get_timestamp() result(timestamp) 769 | 770 | !> ISO 8601 formatted timestamp 771 | character(len=19) :: timestamp 772 | 773 | character(len=8) :: date 774 | character(len=10) :: time 775 | 776 | call date_and_time(date=date, time=time) 777 | 778 | timestamp = date(1:4) // "-" // date(5:6) // "-" // date(7:8) // "T" // & 779 | & time(1:2) // ":" // time(3:4) // ":" // time(5:6) 780 | 781 | end function get_timestamp 782 | 783 | 784 | !> Select a unit test from all available tests 785 | function select_test(tests, name) result(pos) 786 | 787 | !> Name identifying the test suite 788 | character(len=*), intent(in) :: name 789 | 790 | !> Available unit tests 791 | type(unittest_type) :: tests(:) 792 | 793 | !> Selected test suite 794 | integer :: pos 795 | 796 | integer :: it 797 | 798 | pos = 0 799 | do it = 1, size(tests) 800 | if (name == tests(it)%name) then 801 | pos = it 802 | exit 803 | end if 804 | end do 805 | 806 | end function select_test 807 | 808 | 809 | !> Select a test suite from all available suites 810 | function select_suite(suites, name) result(pos) 811 | 812 | !> Name identifying the test suite 813 | character(len=*), intent(in) :: name 814 | 815 | !> Available test suites 816 | type(testsuite_type) :: suites(:) 817 | 818 | !> Selected test suite 819 | integer :: pos 820 | 821 | integer :: it 822 | 823 | pos = 0 824 | do it = 1, size(suites) 825 | if (name == suites(it)%name) then 826 | pos = it 827 | exit 828 | end if 829 | end do 830 | 831 | end function select_suite 832 | 833 | 834 | !> Register a new unit test 835 | function new_unittest(name, test, should_fail) result(self) 836 | 837 | !> Name of the test 838 | character(len=*), intent(in) :: name 839 | 840 | !> Entry point for the test 841 | procedure(test_interface) :: test 842 | 843 | !> Whether test is supposed to error or not 844 | logical, intent(in), optional :: should_fail 845 | 846 | !> Newly registered test 847 | type(unittest_type) :: self 848 | 849 | self%name = name 850 | self%test => test 851 | if (present(should_fail)) self%should_fail = should_fail 852 | 853 | end function new_unittest 854 | 855 | 856 | !> Register a new testsuite 857 | function new_testsuite(name, collect) result(self) 858 | 859 | !> Name of the testsuite 860 | character(len=*), intent(in) :: name 861 | 862 | !> Entry point to collect tests 863 | procedure(collect_interface) :: collect 864 | 865 | !> Newly registered testsuite 866 | type(testsuite_type) :: self 867 | 868 | self%name = name 869 | self%collect => collect 870 | 871 | end function new_testsuite 872 | 873 | 874 | subroutine check_stat(error, stat, message, more) 875 | 876 | !> Error handling 877 | type(error_type), allocatable, intent(out) :: error 878 | 879 | !> Status of operation 880 | integer, intent(in) :: stat 881 | 882 | !> A detailed message describing the error 883 | character(len=*), intent(in), optional :: message 884 | 885 | !> Another line of error message 886 | character(len=*), intent(in), optional :: more 887 | 888 | if (stat /= success) then 889 | if (present(message)) then 890 | call test_failed(error, message, more) 891 | else 892 | call test_failed(error, "Non-zero exit code encountered", more) 893 | end if 894 | end if 895 | 896 | end subroutine check_stat 897 | 898 | 899 | subroutine check_logical(error, expression, message, more) 900 | 901 | !> Error handling 902 | type(error_type), allocatable, intent(out) :: error 903 | 904 | !> Result of logical operator 905 | logical, intent(in) :: expression 906 | 907 | !> A detailed message describing the error 908 | character(len=*), intent(in), optional :: message 909 | 910 | !> Another line of error message 911 | character(len=*), intent(in), optional :: more 912 | 913 | if (.not.expression) then 914 | if (present(message)) then 915 | call test_failed(error, message, more) 916 | else 917 | call test_failed(error, "Condition not fullfilled", more) 918 | end if 919 | end if 920 | 921 | end subroutine check_logical 922 | 923 | 924 | subroutine check_float_dp(error, actual, expected, message, more, thr, rel) 925 | 926 | !> Error handling 927 | type(error_type), allocatable, intent(out) :: error 928 | 929 | !> Found floating point value 930 | real(dp), intent(in) :: actual 931 | 932 | !> Expected floating point value 933 | real(dp), intent(in) :: expected 934 | 935 | !> A detailed message describing the error 936 | character(len=*), intent(in), optional :: message 937 | 938 | !> Another line of error message 939 | character(len=*), intent(in), optional :: more 940 | 941 | !> Allowed threshold for matching floating point values 942 | real(dp), intent(in), optional :: thr 943 | 944 | !> Check for relative errors instead 945 | logical, intent(in), optional :: rel 946 | 947 | logical :: relative 948 | real(dp) :: diff, threshold 949 | 950 | call check(error, actual, message, more) 951 | if (allocated(error)) return 952 | 953 | if (present(thr)) then 954 | threshold = thr 955 | else 956 | threshold = epsilon(expected) 957 | end if 958 | 959 | if (present(rel)) then 960 | relative = rel 961 | else 962 | relative = .false. 963 | end if 964 | 965 | if (relative) then 966 | diff = abs(actual - expected) / abs(expected) 967 | else 968 | diff = abs(actual - expected) 969 | end if 970 | 971 | if (diff > threshold) then 972 | if (present(message)) then 973 | call test_failed(error, message, more) 974 | else 975 | if (relative) then 976 | call test_failed(error, & 977 | "Floating point value missmatch", & 978 | "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& 979 | "(difference: "//to_string(int(diff*100))//"%)", & 980 | more) 981 | else 982 | call test_failed(error, & 983 | "Floating point value missmatch", & 984 | "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& 985 | "(difference: "//to_string(diff)//")", & 986 | more) 987 | end if 988 | end if 989 | end if 990 | 991 | end subroutine check_float_dp 992 | 993 | 994 | subroutine check_float_exceptional_dp(error, actual, message, more) 995 | 996 | !> Error handling 997 | type(error_type), allocatable, intent(out) :: error 998 | 999 | !> Found floating point value 1000 | real(dp), intent(in) :: actual 1001 | 1002 | !> A detailed message describing the error 1003 | character(len=*), intent(in), optional :: message 1004 | 1005 | !> Another line of error message 1006 | character(len=*), intent(in), optional :: more 1007 | 1008 | if (is_nan(actual)) then 1009 | if (present(message)) then 1010 | call test_failed(error, message, more) 1011 | else 1012 | call test_failed(error, "Exceptional value 'not a number' found", more) 1013 | end if 1014 | end if 1015 | 1016 | end subroutine check_float_exceptional_dp 1017 | 1018 | 1019 | subroutine check_float_sp(error, actual, expected, message, more, thr, rel) 1020 | 1021 | !> Error handling 1022 | type(error_type), allocatable, intent(out) :: error 1023 | 1024 | !> Found floating point value 1025 | real(sp), intent(in) :: actual 1026 | 1027 | !> Expected floating point value 1028 | real(sp), intent(in) :: expected 1029 | 1030 | !> A detailed message describing the error 1031 | character(len=*), intent(in), optional :: message 1032 | 1033 | !> Another line of error message 1034 | character(len=*), intent(in), optional :: more 1035 | 1036 | !> Allowed threshold for matching floating point values 1037 | real(sp), intent(in), optional :: thr 1038 | 1039 | !> Check for relative errors instead 1040 | logical, intent(in), optional :: rel 1041 | 1042 | logical :: relative 1043 | real(sp) :: diff, threshold 1044 | 1045 | call check(error, actual, message, more) 1046 | if (allocated(error)) return 1047 | 1048 | if (present(thr)) then 1049 | threshold = thr 1050 | else 1051 | threshold = epsilon(expected) 1052 | end if 1053 | 1054 | if (present(rel)) then 1055 | relative = rel 1056 | else 1057 | relative = .false. 1058 | end if 1059 | 1060 | if (relative) then 1061 | diff = abs(actual - expected) / abs(expected) 1062 | else 1063 | diff = abs(actual - expected) 1064 | end if 1065 | 1066 | if (diff > threshold) then 1067 | if (present(message)) then 1068 | call test_failed(error, message, more) 1069 | else 1070 | if (relative) then 1071 | call test_failed(error, & 1072 | "Floating point value missmatch", & 1073 | "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& 1074 | "(difference: "//to_string(int(diff*100))//"%)", & 1075 | more) 1076 | else 1077 | call test_failed(error, & 1078 | "Floating point value missmatch", & 1079 | "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& 1080 | "(difference: "//to_string(diff)//")", & 1081 | more) 1082 | end if 1083 | end if 1084 | end if 1085 | 1086 | end subroutine check_float_sp 1087 | 1088 | 1089 | subroutine check_float_exceptional_sp(error, actual, message, more) 1090 | 1091 | !> Error handling 1092 | type(error_type), allocatable, intent(out) :: error 1093 | 1094 | !> Found floating point value 1095 | real(sp), intent(in) :: actual 1096 | 1097 | !> A detailed message describing the error 1098 | character(len=*), intent(in), optional :: message 1099 | 1100 | !> Another line of error message 1101 | character(len=*), intent(in), optional :: more 1102 | 1103 | if (is_nan(actual)) then 1104 | if (present(message)) then 1105 | call test_failed(error, message, more) 1106 | else 1107 | call test_failed(error, "Exceptional value 'not a number' found", more) 1108 | end if 1109 | end if 1110 | 1111 | end subroutine check_float_exceptional_sp 1112 | 1113 | 1114 | #if WITH_XDP 1115 | subroutine check_float_xdp(error, actual, expected, message, more, thr, rel) 1116 | 1117 | !> Error handling 1118 | type(error_type), allocatable, intent(out) :: error 1119 | 1120 | !> Found floating point value 1121 | real(xdp), intent(in) :: actual 1122 | 1123 | !> Expected floating point value 1124 | real(xdp), intent(in) :: expected 1125 | 1126 | !> A detailed message describing the error 1127 | character(len=*), intent(in), optional :: message 1128 | 1129 | !> Another line of error message 1130 | character(len=*), intent(in), optional :: more 1131 | 1132 | !> Allowed threshold for matching floating point values 1133 | real(xdp), intent(in), optional :: thr 1134 | 1135 | !> Check for relative errors instead 1136 | logical, intent(in), optional :: rel 1137 | 1138 | logical :: relative 1139 | real(xdp) :: diff, threshold 1140 | 1141 | call check(error, actual, message, more) 1142 | if (allocated(error)) return 1143 | 1144 | if (present(thr)) then 1145 | threshold = thr 1146 | else 1147 | threshold = epsilon(expected) 1148 | end if 1149 | 1150 | if (present(rel)) then 1151 | relative = rel 1152 | else 1153 | relative = .false. 1154 | end if 1155 | 1156 | if (relative) then 1157 | diff = abs(actual - expected) / abs(expected) 1158 | else 1159 | diff = abs(actual - expected) 1160 | end if 1161 | 1162 | if (diff > threshold) then 1163 | if (present(message)) then 1164 | call test_failed(error, message, more) 1165 | else 1166 | if (relative) then 1167 | call test_failed(error, & 1168 | "Floating point value missmatch", & 1169 | "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& 1170 | "(difference: "//to_string(int(diff*100))//"%)", & 1171 | more) 1172 | else 1173 | call test_failed(error, & 1174 | "Floating point value missmatch", & 1175 | "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& 1176 | "(difference: "//to_string(diff)//")", & 1177 | more) 1178 | end if 1179 | end if 1180 | end if 1181 | 1182 | end subroutine check_float_xdp 1183 | 1184 | 1185 | subroutine check_float_exceptional_xdp(error, actual, message, more) 1186 | 1187 | !> Error handling 1188 | type(error_type), allocatable, intent(out) :: error 1189 | 1190 | !> Found floating point value 1191 | real(xdp), intent(in) :: actual 1192 | 1193 | !> A detailed message describing the error 1194 | character(len=*), intent(in), optional :: message 1195 | 1196 | !> Another line of error message 1197 | character(len=*), intent(in), optional :: more 1198 | 1199 | if (is_nan(actual)) then 1200 | if (present(message)) then 1201 | call test_failed(error, message, more) 1202 | else 1203 | call test_failed(error, "Exceptional value 'not a number' found", more) 1204 | end if 1205 | end if 1206 | 1207 | end subroutine check_float_exceptional_xdp 1208 | #endif 1209 | 1210 | 1211 | #if WITH_QP 1212 | subroutine check_float_qp(error, actual, expected, message, more, thr, rel) 1213 | 1214 | !> Error handling 1215 | type(error_type), allocatable, intent(out) :: error 1216 | 1217 | !> Found floating point value 1218 | real(qp), intent(in) :: actual 1219 | 1220 | !> Expected floating point value 1221 | real(qp), intent(in) :: expected 1222 | 1223 | !> A detailed message describing the error 1224 | character(len=*), intent(in), optional :: message 1225 | 1226 | !> Another line of error message 1227 | character(len=*), intent(in), optional :: more 1228 | 1229 | !> Allowed threshold for matching floating point values 1230 | real(qp), intent(in), optional :: thr 1231 | 1232 | !> Check for relative errors instead 1233 | logical, intent(in), optional :: rel 1234 | 1235 | logical :: relative 1236 | real(qp) :: diff, threshold 1237 | 1238 | call check(error, actual, message, more) 1239 | if (allocated(error)) return 1240 | 1241 | if (present(thr)) then 1242 | threshold = thr 1243 | else 1244 | threshold = epsilon(expected) 1245 | end if 1246 | 1247 | if (present(rel)) then 1248 | relative = rel 1249 | else 1250 | relative = .false. 1251 | end if 1252 | 1253 | if (relative) then 1254 | diff = abs(actual - expected) / abs(expected) 1255 | else 1256 | diff = abs(actual - expected) 1257 | end if 1258 | 1259 | if (diff > threshold) then 1260 | if (present(message)) then 1261 | call test_failed(error, message, more) 1262 | else 1263 | if (relative) then 1264 | call test_failed(error, & 1265 | "Floating point value missmatch", & 1266 | "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& 1267 | "(difference: "//to_string(int(diff*100))//"%)", & 1268 | more) 1269 | else 1270 | call test_failed(error, & 1271 | "Floating point value missmatch", & 1272 | "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& 1273 | "(difference: "//to_string(diff)//")", & 1274 | more) 1275 | end if 1276 | end if 1277 | end if 1278 | 1279 | end subroutine check_float_qp 1280 | 1281 | 1282 | subroutine check_float_exceptional_qp(error, actual, message, more) 1283 | 1284 | !> Error handling 1285 | type(error_type), allocatable, intent(out) :: error 1286 | 1287 | !> Found floating point value 1288 | real(qp), intent(in) :: actual 1289 | 1290 | !> A detailed message describing the error 1291 | character(len=*), intent(in), optional :: message 1292 | 1293 | !> Another line of error message 1294 | character(len=*), intent(in), optional :: more 1295 | 1296 | if (is_nan(actual)) then 1297 | if (present(message)) then 1298 | call test_failed(error, message, more) 1299 | else 1300 | call test_failed(error, "Exceptional value 'not a number' found", more) 1301 | end if 1302 | end if 1303 | 1304 | end subroutine check_float_exceptional_qp 1305 | #endif 1306 | 1307 | 1308 | subroutine check_complex_dp(error, actual, expected, message, more, thr, rel) 1309 | 1310 | !> Error handling 1311 | type(error_type), allocatable, intent(out) :: error 1312 | 1313 | !> Found floating point value 1314 | complex(dp), intent(in) :: actual 1315 | 1316 | !> Expected floating point value 1317 | complex(dp), intent(in) :: expected 1318 | 1319 | !> A detailed message describing the error 1320 | character(len=*), intent(in), optional :: message 1321 | 1322 | !> Another line of error message 1323 | character(len=*), intent(in), optional :: more 1324 | 1325 | !> Allowed threshold for matching floating point values 1326 | real(dp), intent(in), optional :: thr 1327 | 1328 | !> Check for relative errors instead 1329 | logical, intent(in), optional :: rel 1330 | 1331 | logical :: relative 1332 | real(dp) :: diff, threshold 1333 | 1334 | call check(error, actual, message, more) 1335 | if (allocated(error)) return 1336 | 1337 | if (present(thr)) then 1338 | threshold = thr 1339 | else 1340 | threshold = epsilon(abs(expected)) 1341 | end if 1342 | 1343 | if (present(rel)) then 1344 | relative = rel 1345 | else 1346 | relative = .false. 1347 | end if 1348 | 1349 | if (relative) then 1350 | diff = abs(actual - expected) / abs(expected) 1351 | else 1352 | diff = abs(actual - expected) 1353 | end if 1354 | 1355 | if (diff > threshold) then 1356 | if (present(message)) then 1357 | call test_failed(error, message, more) 1358 | else 1359 | if (relative) then 1360 | call test_failed(error, & 1361 | "Floating point value missmatch", & 1362 | "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& 1363 | "(difference: "//to_string(int(diff*100))//"%)", & 1364 | more) 1365 | else 1366 | call test_failed(error, & 1367 | "Floating point value missmatch", & 1368 | "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& 1369 | "(difference: "//to_string(diff)//")", & 1370 | more) 1371 | end if 1372 | end if 1373 | end if 1374 | 1375 | end subroutine check_complex_dp 1376 | 1377 | 1378 | subroutine check_complex_exceptional_dp(error, actual, message, more) 1379 | 1380 | !> Error handling 1381 | type(error_type), allocatable, intent(out) :: error 1382 | 1383 | !> Found floating point value 1384 | complex(dp), intent(in) :: actual 1385 | 1386 | !> A detailed message describing the error 1387 | character(len=*), intent(in), optional :: message 1388 | 1389 | !> Another line of error message 1390 | character(len=*), intent(in), optional :: more 1391 | 1392 | if (is_nan(real(actual)) .or. is_nan(aimag(actual))) then 1393 | if (present(message)) then 1394 | call test_failed(error, message, more) 1395 | else 1396 | call test_failed(error, "Exceptional value 'not a number' found", more) 1397 | end if 1398 | end if 1399 | 1400 | end subroutine check_complex_exceptional_dp 1401 | 1402 | 1403 | subroutine check_complex_sp(error, actual, expected, message, more, thr, rel) 1404 | 1405 | !> Error handling 1406 | type(error_type), allocatable, intent(out) :: error 1407 | 1408 | !> Found floating point value 1409 | complex(sp), intent(in) :: actual 1410 | 1411 | !> Expected floating point value 1412 | complex(sp), intent(in) :: expected 1413 | 1414 | !> A detailed message describing the error 1415 | character(len=*), intent(in), optional :: message 1416 | 1417 | !> Another line of error message 1418 | character(len=*), intent(in), optional :: more 1419 | 1420 | !> Allowed threshold for matching floating point values 1421 | real(sp), intent(in), optional :: thr 1422 | 1423 | !> Check for relative errors instead 1424 | logical, intent(in), optional :: rel 1425 | 1426 | logical :: relative 1427 | real(sp) :: diff, threshold 1428 | 1429 | call check(error, actual, message, more) 1430 | if (allocated(error)) return 1431 | 1432 | if (present(thr)) then 1433 | threshold = thr 1434 | else 1435 | threshold = epsilon(abs(expected)) 1436 | end if 1437 | 1438 | if (present(rel)) then 1439 | relative = rel 1440 | else 1441 | relative = .false. 1442 | end if 1443 | 1444 | if (relative) then 1445 | diff = abs(actual - expected) / abs(expected) 1446 | else 1447 | diff = abs(actual - expected) 1448 | end if 1449 | 1450 | if (diff > threshold) then 1451 | if (present(message)) then 1452 | call test_failed(error, message, more) 1453 | else 1454 | if (relative) then 1455 | call test_failed(error, & 1456 | "Floating point value missmatch", & 1457 | "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& 1458 | "(difference: "//to_string(int(diff*100))//"%)", & 1459 | more) 1460 | else 1461 | call test_failed(error, & 1462 | "Floating point value missmatch", & 1463 | "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& 1464 | "(difference: "//to_string(diff)//")", & 1465 | more) 1466 | end if 1467 | end if 1468 | end if 1469 | 1470 | end subroutine check_complex_sp 1471 | 1472 | 1473 | subroutine check_complex_exceptional_sp(error, actual, message, more) 1474 | 1475 | !> Error handling 1476 | type(error_type), allocatable, intent(out) :: error 1477 | 1478 | !> Found floating point value 1479 | complex(sp), intent(in) :: actual 1480 | 1481 | !> A detailed message describing the error 1482 | character(len=*), intent(in), optional :: message 1483 | 1484 | !> Another line of error message 1485 | character(len=*), intent(in), optional :: more 1486 | 1487 | if (is_nan(real(actual)) .or. is_nan(aimag(actual))) then 1488 | if (present(message)) then 1489 | call test_failed(error, message, more) 1490 | else 1491 | call test_failed(error, "Exceptional value 'not a number' found", more) 1492 | end if 1493 | end if 1494 | 1495 | end subroutine check_complex_exceptional_sp 1496 | 1497 | 1498 | #if WITH_XDP 1499 | subroutine check_complex_xdp(error, actual, expected, message, more, thr, rel) 1500 | 1501 | !> Error handling 1502 | type(error_type), allocatable, intent(out) :: error 1503 | 1504 | !> Found floating point value 1505 | complex(xdp), intent(in) :: actual 1506 | 1507 | !> Expected floating point value 1508 | complex(xdp), intent(in) :: expected 1509 | 1510 | !> A detailed message describing the error 1511 | character(len=*), intent(in), optional :: message 1512 | 1513 | !> Another line of error message 1514 | character(len=*), intent(in), optional :: more 1515 | 1516 | !> Allowed threshold for matching floating point values 1517 | real(xdp), intent(in), optional :: thr 1518 | 1519 | !> Check for relative errors instead 1520 | logical, intent(in), optional :: rel 1521 | 1522 | logical :: relative 1523 | real(xdp) :: diff, threshold 1524 | 1525 | call check(error, actual, message, more) 1526 | if (allocated(error)) return 1527 | 1528 | if (present(thr)) then 1529 | threshold = thr 1530 | else 1531 | threshold = epsilon(abs(expected)) 1532 | end if 1533 | 1534 | if (present(rel)) then 1535 | relative = rel 1536 | else 1537 | relative = .false. 1538 | end if 1539 | 1540 | if (relative) then 1541 | diff = abs(actual - expected) / abs(expected) 1542 | else 1543 | diff = abs(actual - expected) 1544 | end if 1545 | 1546 | if (diff > threshold) then 1547 | if (present(message)) then 1548 | call test_failed(error, message, more) 1549 | else 1550 | if (relative) then 1551 | call test_failed(error, & 1552 | "Floating point value missmatch", & 1553 | "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& 1554 | "(difference: "//to_string(int(diff*100))//"%)", & 1555 | more) 1556 | else 1557 | call test_failed(error, & 1558 | "Floating point value missmatch", & 1559 | "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& 1560 | "(difference: "//to_string(diff)//")", & 1561 | more) 1562 | end if 1563 | end if 1564 | end if 1565 | 1566 | end subroutine check_complex_xdp 1567 | 1568 | 1569 | subroutine check_complex_exceptional_xdp(error, actual, message, more) 1570 | 1571 | !> Error handling 1572 | type(error_type), allocatable, intent(out) :: error 1573 | 1574 | !> Found floating point value 1575 | complex(xdp), intent(in) :: actual 1576 | 1577 | !> A detailed message describing the error 1578 | character(len=*), intent(in), optional :: message 1579 | 1580 | !> Another line of error message 1581 | character(len=*), intent(in), optional :: more 1582 | 1583 | if (is_nan(real(actual)) .or. is_nan(aimag(actual))) then 1584 | if (present(message)) then 1585 | call test_failed(error, message, more) 1586 | else 1587 | call test_failed(error, "Exceptional value 'not a number' found", more) 1588 | end if 1589 | end if 1590 | 1591 | end subroutine check_complex_exceptional_xdp 1592 | #endif 1593 | 1594 | 1595 | #if WITH_QP 1596 | subroutine check_complex_qp(error, actual, expected, message, more, thr, rel) 1597 | 1598 | !> Error handling 1599 | type(error_type), allocatable, intent(out) :: error 1600 | 1601 | !> Found floating point value 1602 | complex(qp), intent(in) :: actual 1603 | 1604 | !> Expected floating point value 1605 | complex(qp), intent(in) :: expected 1606 | 1607 | !> A detailed message describing the error 1608 | character(len=*), intent(in), optional :: message 1609 | 1610 | !> Another line of error message 1611 | character(len=*), intent(in), optional :: more 1612 | 1613 | !> Allowed threshold for matching floating point values 1614 | real(qp), intent(in), optional :: thr 1615 | 1616 | !> Check for relative errors instead 1617 | logical, intent(in), optional :: rel 1618 | 1619 | logical :: relative 1620 | real(qp) :: diff, threshold 1621 | 1622 | call check(error, actual, message, more) 1623 | if (allocated(error)) return 1624 | 1625 | if (present(thr)) then 1626 | threshold = thr 1627 | else 1628 | threshold = epsilon(abs(expected)) 1629 | end if 1630 | 1631 | if (present(rel)) then 1632 | relative = rel 1633 | else 1634 | relative = .false. 1635 | end if 1636 | 1637 | if (relative) then 1638 | diff = abs(actual - expected) / abs(expected) 1639 | else 1640 | diff = abs(actual - expected) 1641 | end if 1642 | 1643 | if (diff > threshold) then 1644 | if (present(message)) then 1645 | call test_failed(error, message, more) 1646 | else 1647 | if (relative) then 1648 | call test_failed(error, & 1649 | "Floating point value missmatch", & 1650 | "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& 1651 | "(difference: "//to_string(int(diff*100))//"%)", & 1652 | more) 1653 | else 1654 | call test_failed(error, & 1655 | "Floating point value missmatch", & 1656 | "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& 1657 | "(difference: "//to_string(diff)//")", & 1658 | more) 1659 | end if 1660 | end if 1661 | end if 1662 | 1663 | end subroutine check_complex_qp 1664 | 1665 | 1666 | subroutine check_complex_exceptional_qp(error, actual, message, more) 1667 | 1668 | !> Error handling 1669 | type(error_type), allocatable, intent(out) :: error 1670 | 1671 | !> Found floating point value 1672 | complex(qp), intent(in) :: actual 1673 | 1674 | !> A detailed message describing the error 1675 | character(len=*), intent(in), optional :: message 1676 | 1677 | !> Another line of error message 1678 | character(len=*), intent(in), optional :: more 1679 | 1680 | if (is_nan(real(actual)) .or. is_nan(aimag(actual))) then 1681 | if (present(message)) then 1682 | call test_failed(error, message, more) 1683 | else 1684 | call test_failed(error, "Exceptional value 'not a number' found", more) 1685 | end if 1686 | end if 1687 | 1688 | end subroutine check_complex_exceptional_qp 1689 | #endif 1690 | 1691 | 1692 | subroutine check_int_i1(error, actual, expected, message, more) 1693 | 1694 | !> Error handling 1695 | type(error_type), allocatable, intent(out) :: error 1696 | 1697 | !> Found integer value 1698 | integer(i1), intent(in) :: actual 1699 | 1700 | !> Expected integer value 1701 | integer(i1), intent(in) :: expected 1702 | 1703 | !> A detailed message describing the error 1704 | character(len=*), intent(in), optional :: message 1705 | 1706 | !> Another line of error message 1707 | character(len=*), intent(in), optional :: more 1708 | 1709 | if (expected /= actual) then 1710 | if (present(message)) then 1711 | call test_failed(error, message, more) 1712 | else 1713 | call test_failed(error, & 1714 | "Integer value missmatch", & 1715 | "expected "//to_string(expected)//" but got "//to_string(actual), & 1716 | more) 1717 | end if 1718 | end if 1719 | 1720 | end subroutine check_int_i1 1721 | 1722 | 1723 | subroutine check_int_i2(error, actual, expected, message, more) 1724 | 1725 | !> Error handling 1726 | type(error_type), allocatable, intent(out) :: error 1727 | 1728 | !> Found integer value 1729 | integer(i2), intent(in) :: actual 1730 | 1731 | !> Expected integer value 1732 | integer(i2), intent(in) :: expected 1733 | 1734 | !> A detailed message describing the error 1735 | character(len=*), intent(in), optional :: message 1736 | 1737 | !> Another line of error message 1738 | character(len=*), intent(in), optional :: more 1739 | 1740 | if (expected /= actual) then 1741 | if (present(message)) then 1742 | call test_failed(error, message, more) 1743 | else 1744 | call test_failed(error, & 1745 | "Integer value missmatch", & 1746 | "expected "//to_string(expected)//" but got "//to_string(actual), & 1747 | more) 1748 | end if 1749 | end if 1750 | 1751 | end subroutine check_int_i2 1752 | 1753 | 1754 | subroutine check_int_i4(error, actual, expected, message, more) 1755 | 1756 | !> Error handling 1757 | type(error_type), allocatable, intent(out) :: error 1758 | 1759 | !> Found integer value 1760 | integer(i4), intent(in) :: actual 1761 | 1762 | !> Expected integer value 1763 | integer(i4), intent(in) :: expected 1764 | 1765 | !> A detailed message describing the error 1766 | character(len=*), intent(in), optional :: message 1767 | 1768 | !> Another line of error message 1769 | character(len=*), intent(in), optional :: more 1770 | 1771 | if (expected /= actual) then 1772 | if (present(message)) then 1773 | call test_failed(error, message, more) 1774 | else 1775 | call test_failed(error, & 1776 | "Integer value missmatch", & 1777 | "expected "//to_string(expected)//" but got "//to_string(actual), & 1778 | more) 1779 | end if 1780 | end if 1781 | 1782 | end subroutine check_int_i4 1783 | 1784 | 1785 | subroutine check_int_i8(error, actual, expected, message, more) 1786 | 1787 | !> Error handling 1788 | type(error_type), allocatable, intent(out) :: error 1789 | 1790 | !> Found integer value 1791 | integer(i8), intent(in) :: actual 1792 | 1793 | !> Expected integer value 1794 | integer(i8), intent(in) :: expected 1795 | 1796 | !> A detailed message describing the error 1797 | character(len=*), intent(in), optional :: message 1798 | 1799 | !> Another line of error message 1800 | character(len=*), intent(in), optional :: more 1801 | 1802 | if (expected /= actual) then 1803 | if (present(message)) then 1804 | call test_failed(error, message, more) 1805 | else 1806 | call test_failed(error, & 1807 | "Integer value missmatch", & 1808 | "expected "//to_string(expected)//" but got "//to_string(actual), & 1809 | more) 1810 | end if 1811 | end if 1812 | 1813 | end subroutine check_int_i8 1814 | 1815 | 1816 | subroutine check_bool(error, actual, expected, message, more) 1817 | 1818 | !> Error handling 1819 | type(error_type), allocatable, intent(out) :: error 1820 | 1821 | !> Found boolean value 1822 | logical, intent(in) :: actual 1823 | 1824 | !> Expected boolean value 1825 | logical, intent(in) :: expected 1826 | 1827 | !> A detailed message describing the error 1828 | character(len=*), intent(in), optional :: message 1829 | 1830 | !> Another line of error message 1831 | character(len=*), intent(in), optional :: more 1832 | 1833 | if (expected .neqv. actual) then 1834 | if (present(message)) then 1835 | call test_failed(error, message, more) 1836 | else 1837 | call test_failed(error, & 1838 | "Logical value missmatch", & 1839 | "expected "//merge("T", "F", expected)//" but got "//merge("T", "F", actual), & 1840 | more) 1841 | end if 1842 | end if 1843 | 1844 | end subroutine check_bool 1845 | 1846 | 1847 | subroutine check_string(error, actual, expected, message, more) 1848 | 1849 | !> Error handling 1850 | type(error_type), allocatable, intent(out) :: error 1851 | 1852 | !> Found boolean value 1853 | character(len=*), intent(in) :: actual 1854 | 1855 | !> Expected boolean value 1856 | character(len=*), intent(in) :: expected 1857 | 1858 | !> A detailed message describing the error 1859 | character(len=*), intent(in), optional :: message 1860 | 1861 | !> Another line of error message 1862 | character(len=*), intent(in), optional :: more 1863 | 1864 | if (expected /= actual) then 1865 | if (present(message)) then 1866 | call test_failed(error, message, more) 1867 | else 1868 | call test_failed(error, & 1869 | "Character value missmatch", & 1870 | "expected '"//expected//"' but got '"//actual//"'", & 1871 | more) 1872 | end if 1873 | end if 1874 | 1875 | end subroutine check_string 1876 | 1877 | 1878 | subroutine test_failed(error, message, more, and_more) 1879 | 1880 | !> Error handling 1881 | type(error_type), allocatable, intent(out) :: error 1882 | 1883 | !> A detailed message describing the error 1884 | character(len=*), intent(in) :: message 1885 | 1886 | !> Another line of error message 1887 | character(len=*), intent(in), optional :: more 1888 | 1889 | !> Another line of error message 1890 | character(len=*), intent(in), optional :: and_more 1891 | 1892 | character(len=*), parameter :: skip = newline // repeat(" ", 11) 1893 | 1894 | allocate(error) 1895 | error%stat = fatal 1896 | 1897 | error%message = message 1898 | if (present(more)) then 1899 | error%message = error%message // skip // more 1900 | end if 1901 | if (present(and_more)) then 1902 | error%message = error%message // skip // and_more 1903 | end if 1904 | 1905 | end subroutine test_failed 1906 | 1907 | 1908 | !> A test is skipped because certain requirements are not met to run the actual test 1909 | subroutine skip_test(error, message, more, and_more) 1910 | 1911 | !> Error handling 1912 | type(error_type), allocatable, intent(out) :: error 1913 | 1914 | !> A detailed message describing the error 1915 | character(len=*), intent(in) :: message 1916 | 1917 | !> Another line of error message 1918 | character(len=*), intent(in), optional :: more 1919 | 1920 | !> Another line of error message 1921 | character(len=*), intent(in), optional :: and_more 1922 | 1923 | call test_failed(error, message, more, and_more) 1924 | error%stat = skipped 1925 | 1926 | end subroutine skip_test 1927 | 1928 | 1929 | !> Obtain the command line argument at a given index 1930 | subroutine get_argument(idx, arg) 1931 | 1932 | !> Index of command line argument, range [0:command_argument_count()] 1933 | integer, intent(in) :: idx 1934 | 1935 | !> Command line argument 1936 | character(len=:), allocatable, intent(out) :: arg 1937 | 1938 | integer :: length, stat 1939 | 1940 | call get_command_argument(idx, length=length, status=stat) 1941 | if (stat /= success) return 1942 | 1943 | allocate(character(len=length) :: arg, stat=stat) 1944 | if (stat /= success) return 1945 | 1946 | if (length > 0) then 1947 | call get_command_argument(idx, arg, status=stat) 1948 | if (stat /= success) deallocate(arg) 1949 | end if 1950 | 1951 | end subroutine get_argument 1952 | 1953 | 1954 | !> Obtain the value of an environment variable 1955 | subroutine get_variable(var, val) 1956 | 1957 | !> Name of variable 1958 | character(len=*), intent(in) :: var 1959 | 1960 | !> Value of variable 1961 | character(len=:), allocatable, intent(out) :: val 1962 | 1963 | integer :: length, stat 1964 | 1965 | call get_environment_variable(var, length=length, status=stat) 1966 | if (stat /= success) return 1967 | 1968 | allocate(character(len=length) :: val, stat=stat) 1969 | if (stat /= success) return 1970 | 1971 | if (length > 0) then 1972 | call get_environment_variable(var, val, status=stat) 1973 | if (stat /= success) deallocate(val) 1974 | end if 1975 | 1976 | end subroutine get_variable 1977 | 1978 | 1979 | pure function integer_i1_to_string(val) result(string) 1980 | integer, parameter :: ik = i1 1981 | !> Integer value to create string from 1982 | integer(ik), intent(in) :: val 1983 | !> String representation of integer 1984 | character(len=:), allocatable :: string 1985 | 1986 | integer, parameter :: buffer_len = range(val)+2 1987 | character(len=buffer_len) :: buffer 1988 | integer :: pos 1989 | integer(ik) :: n 1990 | character(len=1), parameter :: numbers(-9:0) = & 1991 | ["9", "8", "7", "6", "5", "4", "3", "2", "1", "0"] 1992 | 1993 | if (val == 0_ik) then 1994 | string = numbers(0) 1995 | return 1996 | end if 1997 | 1998 | n = sign(val, -1_ik) 1999 | buffer = "" 2000 | pos = buffer_len + 1 2001 | do while (n < 0_ik) 2002 | pos = pos - 1 2003 | buffer(pos:pos) = numbers(mod(n, 10_ik)) 2004 | n = n/10_ik 2005 | end do 2006 | 2007 | if (val < 0_ik) then 2008 | pos = pos - 1 2009 | buffer(pos:pos) = '-' 2010 | end if 2011 | 2012 | string = buffer(pos:) 2013 | end function integer_i1_to_string 2014 | 2015 | 2016 | pure function integer_i2_to_string(val) result(string) 2017 | integer, parameter :: ik = i2 2018 | !> Integer value to create string from 2019 | integer(ik), intent(in) :: val 2020 | !> String representation of integer 2021 | character(len=:), allocatable :: string 2022 | 2023 | integer, parameter :: buffer_len = range(val)+2 2024 | character(len=buffer_len) :: buffer 2025 | integer :: pos 2026 | integer(ik) :: n 2027 | character(len=1), parameter :: numbers(-9:0) = & 2028 | ["9", "8", "7", "6", "5", "4", "3", "2", "1", "0"] 2029 | 2030 | if (val == 0_ik) then 2031 | string = numbers(0) 2032 | return 2033 | end if 2034 | 2035 | n = sign(val, -1_ik) 2036 | buffer = "" 2037 | pos = buffer_len + 1 2038 | do while (n < 0_ik) 2039 | pos = pos - 1 2040 | buffer(pos:pos) = numbers(mod(n, 10_ik)) 2041 | n = n/10_ik 2042 | end do 2043 | 2044 | if (val < 0_ik) then 2045 | pos = pos - 1 2046 | buffer(pos:pos) = '-' 2047 | end if 2048 | 2049 | string = buffer(pos:) 2050 | end function integer_i2_to_string 2051 | 2052 | 2053 | pure function integer_i4_to_string(val) result(string) 2054 | integer, parameter :: ik = i4 2055 | !> Integer value to create string from 2056 | integer(ik), intent(in) :: val 2057 | !> String representation of integer 2058 | character(len=:), allocatable :: string 2059 | 2060 | integer, parameter :: buffer_len = range(val)+2 2061 | character(len=buffer_len) :: buffer 2062 | integer :: pos 2063 | integer(ik) :: n 2064 | character(len=1), parameter :: numbers(-9:0) = & 2065 | ["9", "8", "7", "6", "5", "4", "3", "2", "1", "0"] 2066 | 2067 | if (val == 0_ik) then 2068 | string = numbers(0) 2069 | return 2070 | end if 2071 | 2072 | n = sign(val, -1_ik) 2073 | buffer = "" 2074 | pos = buffer_len + 1 2075 | do while (n < 0_ik) 2076 | pos = pos - 1 2077 | buffer(pos:pos) = numbers(mod(n, 10_ik)) 2078 | n = n/10_ik 2079 | end do 2080 | 2081 | if (val < 0_ik) then 2082 | pos = pos - 1 2083 | buffer(pos:pos) = '-' 2084 | end if 2085 | 2086 | string = buffer(pos:) 2087 | end function integer_i4_to_string 2088 | 2089 | 2090 | pure function integer_i8_to_string(val) result(string) 2091 | integer, parameter :: ik = i8 2092 | !> Integer value to create string from 2093 | integer(ik), intent(in) :: val 2094 | !> String representation of integer 2095 | character(len=:), allocatable :: string 2096 | 2097 | integer, parameter :: buffer_len = range(val)+2 2098 | character(len=buffer_len) :: buffer 2099 | integer :: pos 2100 | integer(ik) :: n 2101 | character(len=1), parameter :: numbers(-9:0) = & 2102 | ["9", "8", "7", "6", "5", "4", "3", "2", "1", "0"] 2103 | 2104 | if (val == 0_ik) then 2105 | string = numbers(0) 2106 | return 2107 | end if 2108 | 2109 | n = sign(val, -1_ik) 2110 | buffer = "" 2111 | pos = buffer_len + 1 2112 | do while (n < 0_ik) 2113 | pos = pos - 1 2114 | buffer(pos:pos) = numbers(mod(n, 10_ik)) 2115 | n = n/10_ik 2116 | end do 2117 | 2118 | if (val < 0_ik) then 2119 | pos = pos - 1 2120 | buffer(pos:pos) = '-' 2121 | end if 2122 | 2123 | string = buffer(pos:) 2124 | end function integer_i8_to_string 2125 | 2126 | 2127 | pure function real_sp_to_string(val) result(string) 2128 | real(sp), intent(in) :: val 2129 | character(len=:), allocatable :: string 2130 | integer, parameter :: buffer_len = 128 2131 | character(len=buffer_len) :: buffer 2132 | 2133 | write(buffer, '(g0)') val 2134 | string = trim(buffer) 2135 | 2136 | end function real_sp_to_string 2137 | 2138 | 2139 | pure function real_dp_to_string(val) result(string) 2140 | real(dp), intent(in) :: val 2141 | character(len=:), allocatable :: string 2142 | integer, parameter :: buffer_len = 128 2143 | character(len=buffer_len) :: buffer 2144 | 2145 | write(buffer, '(g0)') val 2146 | string = trim(buffer) 2147 | 2148 | end function real_dp_to_string 2149 | 2150 | 2151 | #if WITH_XDP 2152 | pure function real_xdp_to_string(val) result(string) 2153 | real(xdp), intent(in) :: val 2154 | character(len=:), allocatable :: string 2155 | integer, parameter :: buffer_len = 128 2156 | character(len=buffer_len) :: buffer 2157 | 2158 | write(buffer, '(g0)') val 2159 | string = trim(buffer) 2160 | 2161 | end function real_xdp_to_string 2162 | #endif 2163 | 2164 | 2165 | #if WITH_QP 2166 | pure function real_qp_to_string(val) result(string) 2167 | real(qp), intent(in) :: val 2168 | character(len=:), allocatable :: string 2169 | integer, parameter :: buffer_len = 128 2170 | character(len=buffer_len) :: buffer 2171 | 2172 | write(buffer, '(g0)') val 2173 | string = trim(buffer) 2174 | 2175 | end function real_qp_to_string 2176 | #endif 2177 | 2178 | 2179 | pure function complex_sp_to_string(val) result(string) 2180 | complex(sp), intent(in) :: val 2181 | character(len=:), allocatable :: string 2182 | 2183 | string = "("//to_string(real(val))//", "//to_string(aimag(val))//")" 2184 | 2185 | end function complex_sp_to_string 2186 | 2187 | 2188 | pure function complex_dp_to_string(val) result(string) 2189 | complex(dp), intent(in) :: val 2190 | character(len=:), allocatable :: string 2191 | 2192 | string = "("//to_string(real(val))//", "//to_string(aimag(val))//")" 2193 | 2194 | end function complex_dp_to_string 2195 | 2196 | 2197 | #if WITH_XDP 2198 | pure function complex_xdp_to_string(val) result(string) 2199 | complex(xdp), intent(in) :: val 2200 | character(len=:), allocatable :: string 2201 | 2202 | string = "("//to_string(real(val))//", "//to_string(aimag(val))//")" 2203 | 2204 | end function complex_xdp_to_string 2205 | #endif 2206 | 2207 | 2208 | #if WITH_QP 2209 | pure function complex_qp_to_string(val) result(string) 2210 | complex(qp), intent(in) :: val 2211 | character(len=:), allocatable :: string 2212 | 2213 | string = "("//to_string(real(val))//", "//to_string(aimag(val))//")" 2214 | 2215 | end function complex_qp_to_string 2216 | #endif 2217 | 2218 | 2219 | !> Clear error type after it has been handled. 2220 | subroutine clear_error(error) 2221 | 2222 | !> Error handling 2223 | type(error_type), intent(inout) :: error 2224 | 2225 | if (error%stat /= success) then 2226 | error%stat = success 2227 | end if 2228 | 2229 | if (allocated(error%message)) then 2230 | deallocate(error%message) 2231 | end if 2232 | 2233 | end subroutine clear_error 2234 | 2235 | 2236 | !> Finalizer of the error type, in case the error is not correctly cleared it will 2237 | !> be escalated at runtime in a fatal way 2238 | subroutine escalate_error(error) 2239 | 2240 | !> Error handling 2241 | type(error_type), intent(inout) :: error 2242 | 2243 | if (error%stat /= success) then 2244 | write(error_unit, '(a)') "[Fatal] Uncaught error" 2245 | if (allocated(error%message)) then 2246 | write(error_unit, '(a, 1x, i0, *(1x, a))') & 2247 | "Code:", error%stat, "Message:", error%message 2248 | end if 2249 | error stop 2250 | end if 2251 | 2252 | end subroutine escalate_error 2253 | 2254 | 2255 | !> Determine whether a value is not a number without requiring IEEE arithmetic support 2256 | elemental function is_nan_sp(val) result(is_nan) 2257 | !> Value to check 2258 | real(sp), intent(in) :: val 2259 | !> Value is not a number 2260 | logical :: is_nan 2261 | 2262 | is_nan = .not.((val <= huge(val) .and. val >= -huge(val)) .or. abs(val) > huge(val)) 2263 | end function is_nan_sp 2264 | 2265 | !> Determine whether a value is not a number without requiring IEEE arithmetic support 2266 | elemental function is_nan_dp(val) result(is_nan) 2267 | !> Value to check 2268 | real(dp), intent(in) :: val 2269 | !> Value is not a number 2270 | logical :: is_nan 2271 | 2272 | is_nan = .not.((val <= huge(val) .and. val >= -huge(val)) .or. abs(val) > huge(val)) 2273 | end function is_nan_dp 2274 | 2275 | #if WITH_XDP 2276 | !> Determine whether a value is not a number without requiring IEEE arithmetic support 2277 | elemental function is_nan_xdp(val) result(is_nan) 2278 | !> Value to check 2279 | real(xdp), intent(in) :: val 2280 | !> Value is not a number 2281 | logical :: is_nan 2282 | 2283 | is_nan = .not.((val <= huge(val) .and. val >= -huge(val)) .or. abs(val) > huge(val)) 2284 | end function is_nan_xdp 2285 | #endif 2286 | 2287 | #if WITH_QP 2288 | !> Determine whether a value is not a number without requiring IEEE arithmetic support 2289 | elemental function is_nan_qp(val) result(is_nan) 2290 | !> Value to check 2291 | real(qp), intent(in) :: val 2292 | !> Value is not a number 2293 | logical :: is_nan 2294 | 2295 | is_nan = .not.((val <= huge(val) .and. val >= -huge(val)) .or. abs(val) > huge(val)) 2296 | end function is_nan_qp 2297 | #endif 2298 | 2299 | !> Initialize color output 2300 | subroutine init_color_output(use_color) 2301 | !> Enable color output 2302 | logical, intent(in) :: use_color 2303 | 2304 | color = new_color_output(use_color) 2305 | end subroutine init_color_output 2306 | 2307 | !> Create a new colorizer object 2308 | function new_color_output(use_color) result(new) 2309 | !> Enable color output 2310 | logical, intent(in) :: use_color 2311 | !> New instance of the colorizer 2312 | type(color_output) :: new 2313 | 2314 | type(color_code), parameter :: & 2315 | reset = color_code(style=0_i1), & 2316 | bold = color_code(style=1_i1), & 2317 | dim = color_code(style=2_i1), & 2318 | italic = color_code(style=3_i1), & 2319 | underline = color_code(style=4_i1), & 2320 | blink = color_code(style=5_i1), & 2321 | reverse = color_code(style=7_i1), & 2322 | hidden = color_code(style=8_i1) 2323 | 2324 | type(color_code), parameter :: & 2325 | black = color_code(fg=0_i1), & 2326 | red = color_code(fg=1_i1), & 2327 | green = color_code(fg=2_i1), & 2328 | yellow = color_code(fg=3_i1), & 2329 | blue = color_code(fg=4_i1), & 2330 | magenta = color_code(fg=5_i1), & 2331 | cyan = color_code(fg=6_i1), & 2332 | white = color_code(fg=7_i1) 2333 | 2334 | type(color_code), parameter :: & 2335 | bg_black = color_code(bg=0_i1), & 2336 | bg_red = color_code(bg=1_i1), & 2337 | bg_green = color_code(bg=2_i1), & 2338 | bg_yellow = color_code(bg=3_i1), & 2339 | bg_blue = color_code(bg=4_i1), & 2340 | bg_magenta = color_code(bg=5_i1), & 2341 | bg_cyan = color_code(bg=6_i1), & 2342 | bg_white = color_code(bg=7_i1) 2343 | 2344 | if (use_color) then 2345 | new%reset = reset 2346 | new%bold = bold 2347 | new%dim = dim 2348 | new%italic = italic 2349 | new%underline = underline 2350 | new%blink = blink 2351 | new%reverse = reverse 2352 | new%hidden = hidden 2353 | new%black = black 2354 | new%red = red 2355 | new%green = green 2356 | new%yellow = yellow 2357 | new%blue = blue 2358 | new%magenta = magenta 2359 | new%cyan = cyan 2360 | new%white = white 2361 | new%bg_black = bg_black 2362 | new%bg_red = bg_red 2363 | new%bg_green = bg_green 2364 | new%bg_yellow = bg_yellow 2365 | new%bg_blue = bg_blue 2366 | new%bg_magenta = bg_magenta 2367 | new%bg_cyan = bg_cyan 2368 | new%bg_white = bg_white 2369 | end if 2370 | end function new_color_output 2371 | 2372 | !> Add two escape sequences, attributes in the right value override the left value ones. 2373 | pure function add_color(lval, rval) result(code) 2374 | !> First escape code 2375 | type(color_code), intent(in) :: lval 2376 | !> Second escape code 2377 | type(color_code), intent(in) :: rval 2378 | !> Combined escape code 2379 | type(color_code) :: code 2380 | 2381 | code = color_code( & 2382 | style=merge(rval%style, lval%style, rval%style >= 0), & 2383 | fg=merge(rval%fg, lval%fg, rval%fg >= 0), & 2384 | bg=merge(rval%bg, lval%bg, rval%bg >= 0)) 2385 | end function add_color 2386 | 2387 | !> Concatenate an escape code with a string and turn it into an actual escape sequence 2388 | pure function concat_color_left(lval, code) result(str) 2389 | !> String to add the escape code to 2390 | character(len=*), intent(in) :: lval 2391 | !> Escape sequence 2392 | type(color_code), intent(in) :: code 2393 | !> Concatenated string 2394 | character(len=:), allocatable :: str 2395 | 2396 | str = lval // escape_color(code) 2397 | end function concat_color_left 2398 | 2399 | !> Concatenate an escape code with a string and turn it into an actual escape sequence 2400 | pure function concat_color_right(code, rval) result(str) 2401 | !> String to add the escape code to 2402 | character(len=*), intent(in) :: rval 2403 | !> Escape sequence 2404 | type(color_code), intent(in) :: code 2405 | !> Concatenated string 2406 | character(len=:), allocatable :: str 2407 | 2408 | str = escape_color(code) // rval 2409 | end function concat_color_right 2410 | 2411 | !> Transform a color code into an actual ANSI escape sequence 2412 | pure function escape_color(code) result(str) 2413 | !> Color code to be used 2414 | type(color_code), intent(in) :: code 2415 | !> ANSI escape sequence representing the color code 2416 | character(len=:), allocatable :: str 2417 | character, parameter :: chars(0:9) = & 2418 | ["0", "1", "2", "3", "4", "5", "6", "7", "8", "9"] 2419 | 2420 | if (anycolor(code)) then 2421 | str = achar(27) // "[0" ! Always reset the style 2422 | if (code%style > 0 .and. code%style < 10) str = str // ";" // chars(code%style) 2423 | if (code%fg >= 0 .and. code%fg < 10) str = str // ";3" // chars(code%fg) 2424 | if (code%bg >= 0 .and. code%bg < 10) str = str // ";4" // chars(code%bg) 2425 | str = str // "m" 2426 | else 2427 | str = "" 2428 | end if 2429 | end function escape_color 2430 | 2431 | !> Check whether the code describes any color or is just a stub 2432 | pure function anycolor(code) 2433 | !> Escape sequence 2434 | type(color_code), intent(in) :: code 2435 | !> Any color / style is active 2436 | logical :: anycolor 2437 | 2438 | anycolor = code%fg >= 0 .or. code%bg >= 0 .or. code%style >= 0 2439 | end function anycolor 2440 | 2441 | end module testdrive 2442 | -------------------------------------------------------------------------------- /src/testdrive_version.f90: -------------------------------------------------------------------------------- 1 | ! This file is part of test-drive. 2 | ! SPDX-Identifier: Apache-2.0 OR MIT 3 | ! 4 | ! Licensed under either of Apache License, Version 2.0 or MIT license 5 | ! at your option; you may not use this file except in compliance with 6 | ! the License. 7 | ! 8 | ! Unless required by applicable law or agreed to in writing, software 9 | ! distributed under the License is distributed on an "AS IS" BASIS, 10 | ! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 11 | ! See the License for the specific language governing permissions and 12 | ! limitations under the License. 13 | 14 | module testdrive_version 15 | implicit none 16 | private 17 | 18 | public :: testdrive_version_string, testdrive_version_compact 19 | public :: get_testdrive_version 20 | 21 | 22 | !> String representation of the test-drive version 23 | character(len=*), parameter :: testdrive_version_string = "0.5.0" 24 | 25 | !> Numeric representation of the test-drive version 26 | integer, parameter :: testdrive_version_compact(3) = [0, 5, 0] 27 | 28 | 29 | contains 30 | 31 | 32 | !> Getter function to retrieve test-drive version 33 | subroutine get_testdrive_version(major, minor, patch, string) 34 | 35 | !> Major version number of the test-drive version 36 | integer, intent(out), optional :: major 37 | 38 | !> Minor version number of the test-drive version 39 | integer, intent(out), optional :: minor 40 | 41 | !> Patch version number of the test-drive version 42 | integer, intent(out), optional :: patch 43 | 44 | !> String representation of the test-drive version 45 | character(len=:), allocatable, intent(out), optional :: string 46 | 47 | if (present(major)) then 48 | major = testdrive_version_compact(1) 49 | end if 50 | if (present(minor)) then 51 | minor = testdrive_version_compact(2) 52 | end if 53 | if (present(patch)) then 54 | patch = testdrive_version_compact(3) 55 | end if 56 | if (present(string)) then 57 | string = testdrive_version_string 58 | end if 59 | 60 | end subroutine get_testdrive_version 61 | 62 | 63 | end module testdrive_version 64 | -------------------------------------------------------------------------------- /test/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | # This file is part of test-drive. 2 | # SPDX-Identifier: Apache-2.0 OR MIT 3 | # 4 | # Licensed under either of Apache License, Version 2.0 or MIT license 5 | # at your option; you may not use this file except in compliance with 6 | # the License. 7 | # 8 | # Unless required by applicable law or agreed to in writing, software 9 | # distributed under the License is distributed on an "AS IS" BASIS, 10 | # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 11 | # See the License for the specific language governing permissions and 12 | # limitations under the License. 13 | 14 | # Unit testing 15 | set( 16 | tests 17 | "check" 18 | "select" 19 | ) 20 | set( 21 | test-srcs 22 | "main.f90" 23 | ) 24 | foreach(t IN LISTS tests) 25 | string(MAKE_C_IDENTIFIER ${t} t) 26 | list(APPEND test-srcs "test_${t}.F90") 27 | endforeach() 28 | 29 | add_executable( 30 | "${PROJECT_NAME}-tester" 31 | "${test-srcs}" 32 | ) 33 | target_link_libraries( 34 | "${PROJECT_NAME}-tester" 35 | PRIVATE 36 | "${PROJECT_NAME}-lib" 37 | ) 38 | target_compile_definitions( 39 | "${PROJECT_NAME}-tester" 40 | PRIVATE 41 | "WITH_QP=$" 42 | "WITH_XDP=$" 43 | ) 44 | 45 | add_test("${PROJECT_NAME}/all-tests" "${PROJECT_NAME}-tester") 46 | 47 | foreach(t IN LISTS tests) 48 | add_test("${PROJECT_NAME}/${t}" "${PROJECT_NAME}-tester" "${t}") 49 | endforeach() 50 | -------------------------------------------------------------------------------- /test/main.f90: -------------------------------------------------------------------------------- 1 | ! This file is part of test-drive. 2 | ! SPDX-Identifier: Apache-2.0 OR MIT 3 | ! 4 | ! Licensed under either of Apache License, Version 2.0 or MIT license 5 | ! at your option; you may not use this file except in compliance with 6 | ! the License. 7 | ! 8 | ! Unless required by applicable law or agreed to in writing, software 9 | ! distributed under the License is distributed on an "AS IS" BASIS, 10 | ! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 11 | ! See the License for the specific language governing permissions and 12 | ! limitations under the License. 13 | 14 | !> Driver for unit testing 15 | program tester 16 | use, intrinsic :: iso_fortran_env, only : error_unit 17 | use testdrive, only : run_testsuite, new_testsuite, testsuite_type, & 18 | & select_suite, run_selected, get_argument, junit_output, junit_header, & 19 | & init_color_output 20 | use test_check, only : collect_check 21 | use test_select, only : collect_select 22 | implicit none 23 | integer :: stat, is 24 | character(len=:), allocatable :: suite_name, test_name 25 | type(testsuite_type), allocatable :: testsuites(:) 26 | character(len=*), parameter :: fmt = '("#", *(1x, a))' 27 | type(junit_output) :: junit 28 | 29 | stat = 0 30 | call junit_header(junit, "testdrive") 31 | 32 | testsuites = [ & 33 | new_testsuite("check", collect_check), & 34 | new_testsuite("select", collect_select) & 35 | ] 36 | 37 | call get_argument(1, suite_name) 38 | call get_argument(2, test_name) 39 | 40 | call init_color_output(.true.) 41 | 42 | if (allocated(suite_name)) then 43 | is = select_suite(testsuites, suite_name) 44 | if (is > 0 .and. is <= size(testsuites)) then 45 | if (allocated(test_name)) then 46 | write(error_unit, fmt) "Suite:", testsuites(is)%name 47 | call run_selected(testsuites(is)%collect, test_name, error_unit, stat, junit=junit) 48 | if (stat < 0) then 49 | error stop 1 50 | end if 51 | else 52 | write(error_unit, fmt) "Testing:", testsuites(is)%name 53 | call run_testsuite(testsuites(is)%collect, error_unit, stat, junit=junit) 54 | end if 55 | else 56 | write(error_unit, fmt) "Available testsuites" 57 | do is = 1, size(testsuites) 58 | write(error_unit, fmt) "-", testsuites(is)%name 59 | end do 60 | error stop 1 61 | end if 62 | else 63 | do is = 1, size(testsuites) 64 | write(error_unit, fmt) "Testing:", testsuites(is)%name 65 | call run_testsuite(testsuites(is)%collect, error_unit, stat, junit=junit) 66 | end do 67 | end if 68 | 69 | if (stat > 0) then 70 | write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" 71 | error stop 1 72 | end if 73 | 74 | 75 | end program tester 76 | -------------------------------------------------------------------------------- /test/meson.build: -------------------------------------------------------------------------------- 1 | # This file is part of test-drive. 2 | # SPDX-Identifier: Apache-2.0 OR MIT 3 | # 4 | # Licensed under either of Apache License, Version 2.0 or MIT license 5 | # at your option; you may not use this file except in compliance with 6 | # the License. 7 | # 8 | # Unless required by applicable law or agreed to in writing, software 9 | # distributed under the License is distributed on an "AS IS" BASIS, 10 | # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 11 | # See the License for the specific language governing permissions and 12 | # limitations under the License. 13 | 14 | tests = [ 15 | 'check', 16 | 'select', 17 | ] 18 | 19 | test_srcs = files( 20 | 'main.f90', 21 | ) 22 | foreach t : tests 23 | test_srcs += files('test_@0@.F90'.format(t.underscorify())) 24 | endforeach 25 | 26 | tester = executable( 27 | 'tester', 28 | sources: test_srcs, 29 | dependencies: testdrive_dep, 30 | ) 31 | 32 | test('all tests', tester) 33 | 34 | foreach t : tests 35 | test(t, tester, args: t) 36 | endforeach 37 | -------------------------------------------------------------------------------- /test/test_check.F90: -------------------------------------------------------------------------------- 1 | ! This file is part of test-drive. 2 | ! SPDX-Identifier: Apache-2.0 OR MIT 3 | ! 4 | ! Licensed under either of Apache License, Version 2.0 or MIT license 5 | ! at your option; you may not use this file except in compliance with 6 | ! the License. 7 | ! 8 | ! Unless required by applicable law or agreed to in writing, software 9 | ! distributed under the License is distributed on an "AS IS" BASIS, 10 | ! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 11 | ! See the License for the specific language governing permissions and 12 | ! limitations under the License. 13 | 14 | !# Enable support for quadruple precision 15 | #ifndef WITH_QP 16 | #define WITH_QP 0 17 | #endif 18 | 19 | !# Enable support for extended double precision 20 | #ifndef WITH_XDP 21 | #define WITH_XDP 0 22 | #endif 23 | 24 | module test_check 25 | use, intrinsic :: ieee_arithmetic, only : ieee_value, ieee_quiet_nan 26 | use testdrive, only : new_unittest, unittest_type, error_type, check, skip_test, to_string 27 | implicit none 28 | private 29 | 30 | public :: collect_check 31 | 32 | 33 | !> Single precision real numbers 34 | integer, parameter :: sp = selected_real_kind(6) 35 | 36 | !> Double precision real numbers 37 | integer, parameter :: dp = selected_real_kind(15) 38 | 39 | #if WITH_XDP 40 | !> Extended double precision real numbers 41 | integer, parameter :: xdp = selected_real_kind(18) 42 | #endif 43 | 44 | #if WITH_QP 45 | !> Quadruple precision real numbers 46 | integer, parameter :: qp = selected_real_kind(33) 47 | #endif 48 | 49 | !> Char length for integers 50 | integer, parameter :: i1 = selected_int_kind(2) 51 | 52 | !> Short length for integers 53 | integer, parameter :: i2 = selected_int_kind(4) 54 | 55 | !> Length of default integers 56 | integer, parameter :: i4 = selected_int_kind(9) 57 | 58 | !> Long length for integers 59 | integer, parameter :: i8 = selected_int_kind(18) 60 | 61 | contains 62 | 63 | 64 | !> Collect all exported unit tests 65 | subroutine collect_check(testsuite) 66 | 67 | !> Collection of tests 68 | type(unittest_type), allocatable, intent(out) :: testsuite(:) 69 | 70 | testsuite = [ & 71 | new_unittest("success", test_success), & 72 | new_unittest("failure", test_failure, should_fail=.true.), & 73 | new_unittest("failure-message", test_failure_message, should_fail=.true.), & 74 | new_unittest("failure-with-more", test_failure_with_more, should_fail=.true.), & 75 | new_unittest("skipped", test_skipped), & 76 | new_unittest("expression", test_expression), & 77 | new_unittest("expression-fail", test_expression_fail, should_fail=.true.), & 78 | new_unittest("expression-message", test_expression_message, should_fail=.true.), & 79 | new_unittest("expression-with-more", test_expression_with_more, should_fail=.true.), & 80 | new_unittest("real-single-abs", test_rsp_abs), & 81 | new_unittest("real-single-rel", test_rsp_rel), & 82 | new_unittest("real-single-nan", test_rsp_nan, should_fail=.true.), & 83 | new_unittest("real-single-abs-fail", test_rsp_abs_fail, should_fail=.true.), & 84 | new_unittest("real-single-rel-fail", test_rsp_rel_fail, should_fail=.true.), & 85 | new_unittest("real-single-abs-message", test_rsp_abs_message, should_fail=.true.), & 86 | new_unittest("real-single-nan-message", test_rsp_nan_message, should_fail=.true.), & 87 | new_unittest("real-double-abs", test_rdp_abs), & 88 | new_unittest("real-double-rel", test_rdp_rel), & 89 | new_unittest("real-double-nan", test_rdp_nan, should_fail=.true.), & 90 | new_unittest("real-double-abs-fail", test_rdp_abs_fail, should_fail=.true.), & 91 | new_unittest("real-double-rel-fail", test_rdp_rel_fail, should_fail=.true.), & 92 | new_unittest("real-double-abs-message", test_rdp_abs_message, should_fail=.true.), & 93 | new_unittest("real-double-nan-message", test_rdp_nan_message, should_fail=.true.), & 94 | new_unittest("real-xdouble-abs", test_rxdp_abs), & 95 | new_unittest("real-xdouble-rel", test_rxdp_rel), & 96 | new_unittest("real-xdouble-nan", test_rxdp_nan, should_fail=.true.), & 97 | new_unittest("real-xdouble-abs-fail", test_rxdp_abs_fail, should_fail=.true.), & 98 | new_unittest("real-xdouble-rel-fail", test_rxdp_rel_fail, should_fail=.true.), & 99 | new_unittest("real-xdouble-abs-message", test_rxdp_abs_message, should_fail=.true.), & 100 | new_unittest("real-xdouble-nan-message", test_rxdp_nan_message, should_fail=.true.), & 101 | new_unittest("real-quadruple-abs", test_rqp_abs), & 102 | new_unittest("real-quadruple-rel", test_rqp_rel), & 103 | new_unittest("real-quadruple-nan", test_rqp_nan, should_fail=.true.), & 104 | new_unittest("real-quadruple-abs-fail", test_rqp_abs_fail, should_fail=.true.), & 105 | new_unittest("real-quadruple-rel-fail", test_rqp_rel_fail, should_fail=.true.), & 106 | new_unittest("real-quadruple-abs-message", test_rqp_abs_message, should_fail=.true.), & 107 | new_unittest("real-quadruple-nan-message", test_rqp_nan_message, should_fail=.true.), & 108 | new_unittest("complex-single-abs", test_csp_abs), & 109 | new_unittest("complex-single-rel", test_csp_rel), & 110 | new_unittest("complex-single-nan", test_csp_nan, should_fail=.true.), & 111 | new_unittest("complex-single-abs-fail", test_csp_abs_fail, should_fail=.true.), & 112 | new_unittest("complex-single-rel-fail", test_csp_rel_fail, should_fail=.true.), & 113 | new_unittest("complex-single-abs-message", test_csp_abs_message, should_fail=.true.), & 114 | new_unittest("complex-single-nan-message", test_csp_nan_message, should_fail=.true.), & 115 | new_unittest("complex-double-abs", test_cdp_abs), & 116 | new_unittest("complex-double-rel", test_cdp_rel), & 117 | new_unittest("complex-double-nan", test_cdp_nan, should_fail=.true.), & 118 | new_unittest("complex-double-abs-fail", test_cdp_abs_fail, should_fail=.true.), & 119 | new_unittest("complex-double-rel-fail", test_cdp_rel_fail, should_fail=.true.), & 120 | new_unittest("complex-double-abs-message", test_cdp_abs_message, should_fail=.true.), & 121 | new_unittest("complex-double-nan-message", test_cdp_nan_message, should_fail=.true.), & 122 | new_unittest("complex-xdouble-abs", test_cxdp_abs), & 123 | new_unittest("complex-xdouble-rel", test_cxdp_rel), & 124 | new_unittest("complex-xdouble-nan", test_cxdp_nan, should_fail=.true.), & 125 | new_unittest("complex-xdouble-abs-fail", test_cxdp_abs_fail, should_fail=.true.), & 126 | new_unittest("complex-xdouble-rel-fail", test_cxdp_rel_fail, should_fail=.true.), & 127 | new_unittest("complex-xdouble-abs-message", test_cxdp_abs_message, should_fail=.true.), & 128 | new_unittest("complex-xdouble-nan-message", test_cxdp_nan_message, should_fail=.true.), & 129 | new_unittest("complex-quadruple-abs", test_cqp_abs), & 130 | new_unittest("complex-quadruple-rel", test_cqp_rel), & 131 | new_unittest("complex-quadruple-nan", test_cqp_nan, should_fail=.true.), & 132 | new_unittest("complex-quadruple-abs-fail", test_cqp_abs_fail, should_fail=.true.), & 133 | new_unittest("complex-quadruple-rel-fail", test_cqp_rel_fail, should_fail=.true.), & 134 | new_unittest("complex-quadruple-abs-message", test_cqp_abs_message, should_fail=.true.), & 135 | new_unittest("complex-quadruple-nan-message", test_cqp_nan_message, should_fail=.true.), & 136 | new_unittest("integer-char", test_i1), & 137 | new_unittest("integer-char-fail", test_i1_fail, should_fail=.true.), & 138 | new_unittest("integer-char-message", test_i1_message, should_fail=.true.), & 139 | new_unittest("integer-char-with-more", test_i1_with_more, should_fail=.true.), & 140 | new_unittest("integer-short", test_i2), & 141 | new_unittest("integer-short-fail", test_i2_fail, should_fail=.true.), & 142 | new_unittest("integer-short-message", test_i2_message, should_fail=.true.), & 143 | new_unittest("integer-short-with-more", test_i2_with_more, should_fail=.true.), & 144 | new_unittest("integer-default", test_i4), & 145 | new_unittest("integer-default-fail", test_i4_fail, should_fail=.true.), & 146 | new_unittest("integer-default-message", test_i4_message, should_fail=.true.), & 147 | new_unittest("integer-default-with-more", test_i4_with_more, should_fail=.true.), & 148 | new_unittest("integer-long", test_i8), & 149 | new_unittest("integer-long-fail", test_i8_fail, should_fail=.true.), & 150 | new_unittest("integer-long-message", test_i8_message, should_fail=.true.), & 151 | new_unittest("integer-long-with-more", test_i8_with_more, should_fail=.true.), & 152 | new_unittest("logical-default-true", test_l4_true), & 153 | new_unittest("logical-default-false", test_l4_false), & 154 | new_unittest("logical-default-fail", test_l4_fail, should_fail=.true.), & 155 | new_unittest("logical-default-message", test_l4_message, should_fail=.true.), & 156 | new_unittest("logical-default-with-more", test_l4_with_more, should_fail=.true.), & 157 | new_unittest("character", test_char), & 158 | new_unittest("character-fail", test_char_fail, should_fail=.true.), & 159 | new_unittest("character-message", test_char_message, should_fail=.true.), & 160 | new_unittest("character-with-more", test_char_with_more, should_fail=.true.), & 161 | new_unittest("character-with-more", test_char_with_more, should_fail=.true.), & 162 | new_unittest("string-i1", test_string_i1), & 163 | new_unittest("string-i2", test_string_i2), & 164 | new_unittest("string-i4", test_string_i4), & 165 | new_unittest("string-i8", test_string_i8) & 166 | ] 167 | 168 | end subroutine collect_check 169 | 170 | 171 | subroutine test_success(error) 172 | 173 | !> Error handling 174 | type(error_type), allocatable, intent(out) :: error 175 | 176 | call check(error, 0) 177 | 178 | end subroutine test_success 179 | 180 | 181 | subroutine test_failure(error) 182 | 183 | !> Error handling 184 | type(error_type), allocatable, intent(out) :: error 185 | 186 | call check(error, 7) 187 | 188 | end subroutine test_failure 189 | 190 | 191 | subroutine test_failure_message(error) 192 | 193 | !> Error handling 194 | type(error_type), allocatable, intent(out) :: error 195 | 196 | call check(error, 4, "Custom message describing the error") 197 | 198 | end subroutine test_failure_message 199 | 200 | 201 | subroutine test_failure_with_more(error) 202 | 203 | !> Error handling 204 | type(error_type), allocatable, intent(out) :: error 205 | 206 | call check(error, 3, more="with an additional descriptive message here") 207 | 208 | end subroutine test_failure_with_more 209 | 210 | 211 | subroutine test_skipped(error) 212 | 213 | !> Error handling 214 | type(error_type), allocatable, intent(out) :: error 215 | 216 | call skip_test(error, "This test is always skipped") 217 | 218 | end subroutine test_skipped 219 | 220 | 221 | subroutine test_expression(error) 222 | 223 | !> Error handling 224 | type(error_type), allocatable, intent(out) :: error 225 | 226 | call check(error, index("info!", "!") > 0) 227 | 228 | end subroutine test_expression 229 | 230 | 231 | subroutine test_expression_fail(error) 232 | 233 | !> Error handling 234 | type(error_type), allocatable, intent(out) :: error 235 | 236 | call check(error, index("info!", "?") > 0) 237 | 238 | end subroutine test_expression_fail 239 | 240 | 241 | subroutine test_expression_message(error) 242 | 243 | !> Error handling 244 | type(error_type), allocatable, intent(out) :: error 245 | 246 | call check(error, index("info!", "!") == 0, 'index("info!", "!") == 0') 247 | 248 | end subroutine test_expression_message 249 | 250 | 251 | subroutine test_expression_with_more(error) 252 | 253 | !> Error handling 254 | type(error_type), allocatable, intent(out) :: error 255 | 256 | call check(error, index("info!", "?") /= 0, more='index("info!", "?")') 257 | 258 | end subroutine test_expression_with_more 259 | 260 | 261 | subroutine test_rsp_abs(error) 262 | 263 | !> Error handling 264 | type(error_type), allocatable, intent(out) :: error 265 | 266 | real(sp) :: val 267 | 268 | val = 3.3_sp 269 | 270 | call check(error, val, 3.3_sp, thr=sqrt(epsilon(val))) 271 | 272 | end subroutine test_rsp_abs 273 | 274 | 275 | subroutine test_rsp_nan(error) 276 | 277 | !> Error handling 278 | type(error_type), allocatable, intent(out) :: error 279 | 280 | real(sp) :: val 281 | 282 | val = ieee_value(val, ieee_quiet_nan) 283 | 284 | call check(error, val, 3.3_sp, rel=.true.) 285 | 286 | end subroutine test_rsp_nan 287 | 288 | 289 | subroutine test_rsp_rel(error) 290 | 291 | !> Error handling 292 | type(error_type), allocatable, intent(out) :: error 293 | 294 | real(sp) :: val 295 | 296 | val = 3.3_sp 297 | 298 | call check(error, val, 3.3_sp, rel=.true.) 299 | 300 | end subroutine test_rsp_rel 301 | 302 | 303 | subroutine test_rsp_abs_fail(error) 304 | 305 | !> Error handling 306 | type(error_type), allocatable, intent(out) :: error 307 | 308 | real(sp) :: val 309 | 310 | val = 1.0_sp 311 | 312 | call check(error, val, 2.0_sp) 313 | 314 | end subroutine test_rsp_abs_fail 315 | 316 | 317 | subroutine test_rsp_rel_fail(error) 318 | 319 | !> Error handling 320 | type(error_type), allocatable, intent(out) :: error 321 | 322 | real(sp) :: val 323 | 324 | val = 1.0_sp 325 | 326 | call check(error, val, 1.5_sp, rel=.true.) 327 | 328 | end subroutine test_rsp_rel_fail 329 | 330 | 331 | subroutine test_rsp_abs_message(error) 332 | 333 | !> Error handling 334 | type(error_type), allocatable, intent(out) :: error 335 | 336 | real(sp) :: val 337 | 338 | val = 1.0_sp 339 | 340 | call check(error, val, 1.5_sp, message="Actual value is not 1.5") 341 | 342 | end subroutine test_rsp_abs_message 343 | 344 | 345 | subroutine test_rsp_nan_message(error) 346 | 347 | !> Error handling 348 | type(error_type), allocatable, intent(out) :: error 349 | 350 | real(sp) :: val 351 | 352 | val = ieee_value(val, ieee_quiet_nan) 353 | 354 | call check(error, val, message="Actual value is not a number") 355 | 356 | end subroutine test_rsp_nan_message 357 | 358 | 359 | subroutine test_rdp_abs(error) 360 | 361 | !> Error handling 362 | type(error_type), allocatable, intent(out) :: error 363 | 364 | real(dp) :: val 365 | 366 | val = 3.3_dp 367 | 368 | call check(error, val, 3.3_dp, thr=sqrt(epsilon(val))) 369 | 370 | end subroutine test_rdp_abs 371 | 372 | 373 | subroutine test_rdp_rel(error) 374 | 375 | !> Error handling 376 | type(error_type), allocatable, intent(out) :: error 377 | 378 | real(dp) :: val 379 | 380 | val = 3.3_dp 381 | 382 | call check(error, val, 3.3_dp, rel=.true.) 383 | 384 | end subroutine test_rdp_rel 385 | 386 | 387 | subroutine test_rdp_nan(error) 388 | 389 | !> Error handling 390 | type(error_type), allocatable, intent(out) :: error 391 | 392 | real(dp) :: val 393 | 394 | val = ieee_value(val, ieee_quiet_nan) 395 | 396 | call check(error, val, 3.3_dp, rel=.true.) 397 | 398 | end subroutine test_rdp_nan 399 | 400 | 401 | subroutine test_rdp_abs_fail(error) 402 | 403 | !> Error handling 404 | type(error_type), allocatable, intent(out) :: error 405 | 406 | real(dp) :: val 407 | 408 | val = 1.0_dp 409 | 410 | call check(error, val, 2.0_dp) 411 | 412 | end subroutine test_rdp_abs_fail 413 | 414 | 415 | subroutine test_rdp_rel_fail(error) 416 | 417 | !> Error handling 418 | type(error_type), allocatable, intent(out) :: error 419 | 420 | real(dp) :: val 421 | 422 | val = 1.0_dp 423 | 424 | call check(error, val, 1.5_dp, rel=.true.) 425 | 426 | end subroutine test_rdp_rel_fail 427 | 428 | 429 | subroutine test_rdp_abs_message(error) 430 | 431 | !> Error handling 432 | type(error_type), allocatable, intent(out) :: error 433 | 434 | real(dp) :: val 435 | 436 | val = 1.0_dp 437 | 438 | call check(error, val, 1.5_dp, message="Actual value is not 1.5") 439 | 440 | end subroutine test_rdp_abs_message 441 | 442 | 443 | subroutine test_rdp_nan_message(error) 444 | 445 | !> Error handling 446 | type(error_type), allocatable, intent(out) :: error 447 | 448 | real(dp) :: val 449 | 450 | val = ieee_value(val, ieee_quiet_nan) 451 | 452 | call check(error, val, message="Actual value is not a number") 453 | 454 | end subroutine test_rdp_nan_message 455 | 456 | 457 | subroutine test_rxdp_abs(error) 458 | 459 | !> Error handling 460 | type(error_type), allocatable, intent(out) :: error 461 | 462 | #if WITH_XDP 463 | real(xdp) :: val 464 | 465 | val = 3.3_xdp 466 | 467 | call check(error, val, 3.3_xdp, thr=sqrt(epsilon(val))) 468 | #else 469 | call skip_test(error, "Extended double precision is not enabled") 470 | #endif 471 | 472 | end subroutine test_rxdp_abs 473 | 474 | 475 | subroutine test_rxdp_rel(error) 476 | 477 | !> Error handling 478 | type(error_type), allocatable, intent(out) :: error 479 | 480 | #if WITH_XDP 481 | real(xdp) :: val 482 | 483 | val = 3.3_xdp 484 | 485 | call check(error, val, 3.3_xdp, rel=.true.) 486 | #else 487 | call skip_test(error, "Extended double precision is not enabled") 488 | #endif 489 | 490 | end subroutine test_rxdp_rel 491 | 492 | 493 | subroutine test_rxdp_nan(error) 494 | 495 | !> Error handling 496 | type(error_type), allocatable, intent(out) :: error 497 | 498 | #if WITH_XDP 499 | real(xdp) :: val 500 | 501 | val = ieee_value(val, ieee_quiet_nan) 502 | 503 | call check(error, val, 3.3_xdp, rel=.true.) 504 | #else 505 | call skip_test(error, "Extended double precision is not enabled") 506 | #endif 507 | 508 | end subroutine test_rxdp_nan 509 | 510 | 511 | subroutine test_rxdp_abs_fail(error) 512 | 513 | !> Error handling 514 | type(error_type), allocatable, intent(out) :: error 515 | 516 | #if WITH_XDP 517 | real(xdp) :: val 518 | 519 | val = 1.0_xdp 520 | 521 | call check(error, val, 2.0_xdp) 522 | #else 523 | call skip_test(error, "Extended double precision is not enabled") 524 | #endif 525 | 526 | end subroutine test_rxdp_abs_fail 527 | 528 | 529 | subroutine test_rxdp_rel_fail(error) 530 | 531 | !> Error handling 532 | type(error_type), allocatable, intent(out) :: error 533 | 534 | #if WITH_XDP 535 | real(xdp) :: val 536 | 537 | val = 1.0_xdp 538 | 539 | call check(error, val, 1.5_xdp, rel=.true.) 540 | #else 541 | call skip_test(error, "Extended double precision is not enabled") 542 | #endif 543 | 544 | end subroutine test_rxdp_rel_fail 545 | 546 | 547 | subroutine test_rxdp_abs_message(error) 548 | 549 | !> Error handling 550 | type(error_type), allocatable, intent(out) :: error 551 | 552 | #if WITH_XDP 553 | real(xdp) :: val 554 | 555 | val = 1.0_xdp 556 | 557 | call check(error, val, 1.5_xdp, message="Actual value is not 1.5") 558 | #else 559 | call skip_test(error, "Extended double precision is not enabled") 560 | #endif 561 | 562 | end subroutine test_rxdp_abs_message 563 | 564 | 565 | subroutine test_rxdp_nan_message(error) 566 | 567 | !> Error handling 568 | type(error_type), allocatable, intent(out) :: error 569 | 570 | #if WITH_XDP 571 | real(xdp) :: val 572 | 573 | val = ieee_value(val, ieee_quiet_nan) 574 | 575 | call check(error, val, message="Actual value is not a number") 576 | #else 577 | call skip_test(error, "Extended double precision is not enabled") 578 | #endif 579 | 580 | end subroutine test_rxdp_nan_message 581 | 582 | 583 | subroutine test_rqp_abs(error) 584 | 585 | !> Error handling 586 | type(error_type), allocatable, intent(out) :: error 587 | 588 | #if WITH_QP 589 | real(qp) :: val 590 | 591 | val = 3.3_qp 592 | 593 | call check(error, val, 3.3_qp, thr=sqrt(epsilon(val))) 594 | #else 595 | call skip_test(error, "Quadruple precision is not enabled") 596 | #endif 597 | 598 | end subroutine test_rqp_abs 599 | 600 | 601 | subroutine test_rqp_rel(error) 602 | 603 | !> Error handling 604 | type(error_type), allocatable, intent(out) :: error 605 | 606 | #if WITH_QP 607 | real(qp) :: val 608 | 609 | val = 3.3_qp 610 | 611 | call check(error, val, 3.3_qp, rel=.true.) 612 | #else 613 | call skip_test(error, "Quadruple precision is not enabled") 614 | #endif 615 | 616 | end subroutine test_rqp_rel 617 | 618 | 619 | subroutine test_rqp_nan(error) 620 | 621 | !> Error handling 622 | type(error_type), allocatable, intent(out) :: error 623 | 624 | #if WITH_QP 625 | real(qp) :: val 626 | 627 | val = ieee_value(val, ieee_quiet_nan) 628 | 629 | call check(error, val, 3.3_qp, rel=.true.) 630 | #else 631 | call skip_test(error, "Quadruple precision is not enabled") 632 | #endif 633 | 634 | end subroutine test_rqp_nan 635 | 636 | 637 | subroutine test_rqp_abs_fail(error) 638 | 639 | !> Error handling 640 | type(error_type), allocatable, intent(out) :: error 641 | 642 | #if WITH_QP 643 | real(qp) :: val 644 | 645 | val = 1.0_qp 646 | 647 | call check(error, val, 2.0_qp) 648 | #else 649 | call skip_test(error, "Quadruple precision is not enabled") 650 | #endif 651 | 652 | end subroutine test_rqp_abs_fail 653 | 654 | 655 | subroutine test_rqp_rel_fail(error) 656 | 657 | !> Error handling 658 | type(error_type), allocatable, intent(out) :: error 659 | 660 | #if WITH_QP 661 | real(qp) :: val 662 | 663 | val = 1.0_qp 664 | 665 | call check(error, val, 1.5_qp, rel=.true.) 666 | #else 667 | call skip_test(error, "Quadruple precision is not enabled") 668 | #endif 669 | 670 | end subroutine test_rqp_rel_fail 671 | 672 | 673 | subroutine test_rqp_abs_message(error) 674 | 675 | !> Error handling 676 | type(error_type), allocatable, intent(out) :: error 677 | 678 | #if WITH_QP 679 | real(qp) :: val 680 | 681 | val = 1.0_qp 682 | 683 | call check(error, val, 1.5_qp, message="Actual value is not 1.5") 684 | #else 685 | call skip_test(error, "Quadruple precision is not enabled") 686 | #endif 687 | 688 | end subroutine test_rqp_abs_message 689 | 690 | 691 | subroutine test_rqp_nan_message(error) 692 | 693 | !> Error handling 694 | type(error_type), allocatable, intent(out) :: error 695 | 696 | #if WITH_QP 697 | real(qp) :: val 698 | 699 | val = ieee_value(val, ieee_quiet_nan) 700 | 701 | call check(error, val, message="Actual value is not a number") 702 | #else 703 | call skip_test(error, "Quadruple precision is not enabled") 704 | #endif 705 | 706 | end subroutine test_rqp_nan_message 707 | 708 | 709 | subroutine test_csp_abs(error) 710 | 711 | !> Error handling 712 | type(error_type), allocatable, intent(out) :: error 713 | 714 | complex(sp) :: val 715 | 716 | val = cmplx(3.3_sp, 1.0_sp, sp) 717 | 718 | call check(error, val, cmplx(3.3_sp, 1.0_sp, sp), thr=sqrt(epsilon(abs(val)))) 719 | 720 | end subroutine test_csp_abs 721 | 722 | 723 | subroutine test_csp_nan(error) 724 | 725 | !> Error handling 726 | type(error_type), allocatable, intent(out) :: error 727 | 728 | complex(sp) :: val 729 | 730 | val = cmplx(ieee_value(0.0_sp, ieee_quiet_nan), & 731 | & ieee_value(0.0_sp, ieee_quiet_nan), sp) 732 | 733 | call check(error, val, cmplx(3.3_sp, 1.0_sp, sp), rel=.true.) 734 | 735 | end subroutine test_csp_nan 736 | 737 | 738 | subroutine test_csp_rel(error) 739 | 740 | !> Error handling 741 | type(error_type), allocatable, intent(out) :: error 742 | 743 | complex(sp) :: val 744 | 745 | val = cmplx(3.3_sp, 1.0_sp, sp) 746 | 747 | call check(error, val, cmplx(3.3_sp, 1.0_sp, sp), rel=.true.) 748 | 749 | end subroutine test_csp_rel 750 | 751 | 752 | subroutine test_csp_abs_fail(error) 753 | 754 | !> Error handling 755 | type(error_type), allocatable, intent(out) :: error 756 | 757 | complex(sp) :: val 758 | 759 | val = cmplx(1.0_sp, 2.0_sp, sp) 760 | 761 | call check(error, val, cmplx(2.0_sp, 1.0_sp, sp)) 762 | 763 | end subroutine test_csp_abs_fail 764 | 765 | 766 | subroutine test_csp_rel_fail(error) 767 | 768 | !> Error handling 769 | type(error_type), allocatable, intent(out) :: error 770 | 771 | complex(sp) :: val 772 | 773 | val = cmplx(1.0_sp, 1.5_sp, sp) 774 | 775 | call check(error, val, cmplx(1.5_sp, 1.0_sp, sp), rel=.true.) 776 | 777 | end subroutine test_csp_rel_fail 778 | 779 | 780 | subroutine test_csp_abs_message(error) 781 | 782 | !> Error handling 783 | type(error_type), allocatable, intent(out) :: error 784 | 785 | complex(sp) :: val 786 | 787 | val = cmplx(1.0_sp, 1.5_sp, sp) 788 | 789 | call check(error, val, cmplx(1.5_sp, 1.0_sp, sp), message="Actual value is not 1.5+1.0i") 790 | 791 | end subroutine test_csp_abs_message 792 | 793 | 794 | subroutine test_csp_nan_message(error) 795 | 796 | !> Error handling 797 | type(error_type), allocatable, intent(out) :: error 798 | 799 | complex(sp) :: val 800 | 801 | val = cmplx(ieee_value(0.0_sp, ieee_quiet_nan), 0.0_sp, sp) 802 | 803 | call check(error, val, message="Actual value is not a number") 804 | 805 | end subroutine test_csp_nan_message 806 | 807 | 808 | subroutine test_cdp_abs(error) 809 | 810 | !> Error handling 811 | type(error_type), allocatable, intent(out) :: error 812 | 813 | complex(dp) :: val 814 | 815 | val = cmplx(3.3_dp, 1.0_dp, dp) 816 | 817 | call check(error, val, cmplx(3.3_dp, 1.0_dp, dp), thr=sqrt(epsilon(real(val)))) 818 | 819 | end subroutine test_cdp_abs 820 | 821 | 822 | subroutine test_cdp_rel(error) 823 | 824 | !> Error handling 825 | type(error_type), allocatable, intent(out) :: error 826 | 827 | complex(dp) :: val 828 | 829 | val = cmplx(3.3_dp, 1.0_dp, dp) 830 | 831 | call check(error, val, cmplx(3.3_dp, 1.0_dp, dp), rel=.true.) 832 | 833 | end subroutine test_cdp_rel 834 | 835 | 836 | subroutine test_cdp_nan(error) 837 | 838 | !> Error handling 839 | type(error_type), allocatable, intent(out) :: error 840 | 841 | complex(dp) :: val 842 | 843 | val = cmplx(ieee_value(0.0_dp, ieee_quiet_nan), 0.0_dp, dp) 844 | 845 | call check(error, val, cmplx(3.3_dp, 1.0_dp, dp), rel=.true.) 846 | 847 | end subroutine test_cdp_nan 848 | 849 | 850 | subroutine test_cdp_abs_fail(error) 851 | 852 | !> Error handling 853 | type(error_type), allocatable, intent(out) :: error 854 | 855 | complex(dp) :: val 856 | 857 | val = cmplx(1.0_dp, 2.0_dp, dp) 858 | 859 | call check(error, val, cmplx(2.0_dp, 1.0_dp, dp)) 860 | 861 | end subroutine test_cdp_abs_fail 862 | 863 | 864 | subroutine test_cdp_rel_fail(error) 865 | 866 | !> Error handling 867 | type(error_type), allocatable, intent(out) :: error 868 | 869 | complex(dp) :: val 870 | 871 | val = cmplx(1.0_dp, 1.5_dp, dp) 872 | 873 | call check(error, val, cmplx(1.5_dp, 1.0_dp, dp), rel=.true.) 874 | 875 | end subroutine test_cdp_rel_fail 876 | 877 | 878 | subroutine test_cdp_abs_message(error) 879 | 880 | !> Error handling 881 | type(error_type), allocatable, intent(out) :: error 882 | 883 | complex(dp) :: val 884 | 885 | val = cmplx(1.0_dp, 1.5_dp, dp) 886 | 887 | call check(error, val, cmplx(1.5_dp, 1.0_dp, dp), message="Actual value is not 1.5+1.0i") 888 | 889 | end subroutine test_cdp_abs_message 890 | 891 | 892 | subroutine test_cdp_nan_message(error) 893 | 894 | !> Error handling 895 | type(error_type), allocatable, intent(out) :: error 896 | 897 | complex(dp) :: val 898 | 899 | val = cmplx(ieee_value(0.0_dp, ieee_quiet_nan), 0.0_dp, dp) 900 | 901 | call check(error, val, message="Actual value is not a number") 902 | 903 | end subroutine test_cdp_nan_message 904 | 905 | 906 | subroutine test_cxdp_abs(error) 907 | 908 | !> Error handling 909 | type(error_type), allocatable, intent(out) :: error 910 | 911 | #if WITH_XDP 912 | complex(xdp) :: val 913 | 914 | val = cmplx(3.3_xdp, 1.0_xdp, xdp) 915 | 916 | call check(error, val, cmplx(3.3_xdp, 1.0_xdp, xdp), thr=sqrt(epsilon(real(val)))) 917 | #else 918 | call skip_test(error, "Extended double precision is not enabled") 919 | #endif 920 | 921 | end subroutine test_cxdp_abs 922 | 923 | 924 | subroutine test_cxdp_rel(error) 925 | 926 | !> Error handling 927 | type(error_type), allocatable, intent(out) :: error 928 | 929 | #if WITH_XDP 930 | complex(xdp) :: val 931 | 932 | val = cmplx(3.3_xdp, 1.0_xdp, xdp) 933 | 934 | call check(error, val, cmplx(3.3_xdp, 1.0_xdp, xdp), rel=.true.) 935 | #else 936 | call skip_test(error, "Extended double precision is not enabled") 937 | #endif 938 | 939 | end subroutine test_cxdp_rel 940 | 941 | 942 | subroutine test_cxdp_nan(error) 943 | 944 | !> Error handling 945 | type(error_type), allocatable, intent(out) :: error 946 | 947 | #if WITH_XDP 948 | complex(xdp) :: val 949 | 950 | val = cmplx(ieee_value(0.0_xdp, ieee_quiet_nan), 0.0_xdp, xdp) 951 | 952 | call check(error, val, cmplx(3.3_xdp, 1.0_xdp, xdp), rel=.true.) 953 | #else 954 | call skip_test(error, "Extended double precision is not enabled") 955 | #endif 956 | 957 | end subroutine test_cxdp_nan 958 | 959 | 960 | subroutine test_cxdp_abs_fail(error) 961 | 962 | !> Error handling 963 | type(error_type), allocatable, intent(out) :: error 964 | 965 | #if WITH_XDP 966 | complex(xdp) :: val 967 | 968 | val = cmplx(1.0_xdp, 2.0_xdp, xdp) 969 | 970 | call check(error, val, cmplx(2.0_xdp, 1.0_xdp, xdp)) 971 | #else 972 | call skip_test(error, "Extended double precision is not enabled") 973 | #endif 974 | 975 | end subroutine test_cxdp_abs_fail 976 | 977 | 978 | subroutine test_cxdp_rel_fail(error) 979 | 980 | !> Error handling 981 | type(error_type), allocatable, intent(out) :: error 982 | 983 | #if WITH_XDP 984 | complex(xdp) :: val 985 | 986 | val = cmplx(1.0_xdp, 1.5_xdp, xdp) 987 | 988 | call check(error, val, cmplx(1.5_xdp, 1.0_xdp, xdp), rel=.true.) 989 | #else 990 | call skip_test(error, "Extended double precision is not enabled") 991 | #endif 992 | 993 | end subroutine test_cxdp_rel_fail 994 | 995 | 996 | subroutine test_cxdp_abs_message(error) 997 | 998 | !> Error handling 999 | type(error_type), allocatable, intent(out) :: error 1000 | 1001 | #if WITH_XDP 1002 | complex(xdp) :: val 1003 | 1004 | val = cmplx(1.0_xdp, 1.5_xdp, xdp) 1005 | 1006 | call check(error, val, cmplx(1.5_xdp, 1.0_xdp, xdp), message="Actual value is not 1.5+1.0i") 1007 | #else 1008 | call skip_test(error, "Extended double precision is not enabled") 1009 | #endif 1010 | 1011 | end subroutine test_cxdp_abs_message 1012 | 1013 | 1014 | subroutine test_cxdp_nan_message(error) 1015 | 1016 | !> Error handling 1017 | type(error_type), allocatable, intent(out) :: error 1018 | 1019 | #if WITH_XDP 1020 | complex(xdp) :: val 1021 | 1022 | val = cmplx(ieee_value(0.0_xdp, ieee_quiet_nan), 0.0_xdp, xdp) 1023 | 1024 | call check(error, val, message="Actual value is not a number") 1025 | #else 1026 | call skip_test(error, "Extended double precision is not enabled") 1027 | #endif 1028 | 1029 | end subroutine test_cxdp_nan_message 1030 | 1031 | 1032 | subroutine test_cqp_abs(error) 1033 | 1034 | !> Error handling 1035 | type(error_type), allocatable, intent(out) :: error 1036 | 1037 | #if WITH_QP 1038 | complex(qp) :: val 1039 | 1040 | val = cmplx(3.3_qp, 1.0_qp, qp) 1041 | 1042 | call check(error, val, cmplx(3.3_qp, 1.0_qp, qp), thr=sqrt(epsilon(real(val)))) 1043 | #else 1044 | call skip_test(error, "Quadruple precision is not enabled") 1045 | #endif 1046 | 1047 | end subroutine test_cqp_abs 1048 | 1049 | 1050 | subroutine test_cqp_rel(error) 1051 | 1052 | !> Error handling 1053 | type(error_type), allocatable, intent(out) :: error 1054 | 1055 | #if WITH_QP 1056 | complex(qp) :: val 1057 | 1058 | val = cmplx(3.3_qp, 1.0_qp, qp) 1059 | 1060 | call check(error, val, cmplx(3.3_qp, 1.0_qp, qp), rel=.true.) 1061 | #else 1062 | call skip_test(error, "Quadruple precision is not enabled") 1063 | #endif 1064 | 1065 | end subroutine test_cqp_rel 1066 | 1067 | 1068 | subroutine test_cqp_nan(error) 1069 | 1070 | !> Error handling 1071 | type(error_type), allocatable, intent(out) :: error 1072 | 1073 | #if WITH_QP 1074 | complex(qp) :: val 1075 | 1076 | val = cmplx(ieee_value(0.0_qp, ieee_quiet_nan), 0.0_qp, qp) 1077 | 1078 | call check(error, val, cmplx(3.3_qp, 1.0_qp, qp), rel=.true.) 1079 | #else 1080 | call skip_test(error, "Quadruple precision is not enabled") 1081 | #endif 1082 | 1083 | end subroutine test_cqp_nan 1084 | 1085 | 1086 | subroutine test_cqp_abs_fail(error) 1087 | 1088 | !> Error handling 1089 | type(error_type), allocatable, intent(out) :: error 1090 | 1091 | #if WITH_QP 1092 | complex(qp) :: val 1093 | 1094 | val = cmplx(1.0_qp, 2.0_qp, qp) 1095 | 1096 | call check(error, val, cmplx(2.0_qp, 1.0_qp, qp)) 1097 | #else 1098 | call skip_test(error, "Quadruple precision is not enabled") 1099 | #endif 1100 | 1101 | end subroutine test_cqp_abs_fail 1102 | 1103 | 1104 | subroutine test_cqp_rel_fail(error) 1105 | 1106 | !> Error handling 1107 | type(error_type), allocatable, intent(out) :: error 1108 | 1109 | #if WITH_QP 1110 | complex(qp) :: val 1111 | 1112 | val = cmplx(1.0_qp, 1.5_qp, qp) 1113 | 1114 | call check(error, val, cmplx(1.5_qp, 1.0_qp, qp), rel=.true.) 1115 | #else 1116 | call skip_test(error, "Quadruple precision is not enabled") 1117 | #endif 1118 | 1119 | end subroutine test_cqp_rel_fail 1120 | 1121 | 1122 | subroutine test_cqp_abs_message(error) 1123 | 1124 | !> Error handling 1125 | type(error_type), allocatable, intent(out) :: error 1126 | 1127 | #if WITH_QP 1128 | complex(qp) :: val 1129 | 1130 | val = cmplx(1.0_qp, 1.5_qp, qp) 1131 | 1132 | call check(error, val, cmplx(1.5_qp, 1.0_qp, qp), message="Actual value is not 1.5+1.0i") 1133 | #else 1134 | call skip_test(error, "Quadruple precision is not enabled") 1135 | #endif 1136 | 1137 | end subroutine test_cqp_abs_message 1138 | 1139 | 1140 | subroutine test_cqp_nan_message(error) 1141 | 1142 | !> Error handling 1143 | type(error_type), allocatable, intent(out) :: error 1144 | 1145 | #if WITH_QP 1146 | complex(qp) :: val 1147 | 1148 | val = cmplx(ieee_value(0.0_qp, ieee_quiet_nan), 0.0_qp, qp) 1149 | 1150 | call check(error, val, message="Actual value is not a number") 1151 | #else 1152 | call skip_test(error, "Quadruple precision is not enabled") 1153 | #endif 1154 | 1155 | end subroutine test_cqp_nan_message 1156 | 1157 | 1158 | subroutine test_i1(error) 1159 | 1160 | !> Error handling 1161 | type(error_type), allocatable, intent(out) :: error 1162 | 1163 | integer(i1) :: val 1164 | 1165 | val = 3_i1 1166 | 1167 | call check(error, val, 3_i1) 1168 | 1169 | end subroutine test_i1 1170 | 1171 | 1172 | subroutine test_i1_fail(error) 1173 | 1174 | !> Error handling 1175 | type(error_type), allocatable, intent(out) :: error 1176 | 1177 | integer(i1) :: val 1178 | 1179 | val = 3_i1 1180 | 1181 | call check(error, val, -4_i1) 1182 | 1183 | end subroutine test_i1_fail 1184 | 1185 | 1186 | subroutine test_i1_message(error) 1187 | 1188 | !> Error handling 1189 | type(error_type), allocatable, intent(out) :: error 1190 | 1191 | integer(i1) :: val 1192 | 1193 | val = -3_i1 1194 | 1195 | call check(error, val, 7_i1, "Actual value is not seven") 1196 | 1197 | end subroutine test_i1_message 1198 | 1199 | 1200 | subroutine test_i1_with_more(error) 1201 | 1202 | !> Error handling 1203 | type(error_type), allocatable, intent(out) :: error 1204 | 1205 | integer(i1) :: val 1206 | 1207 | val = 0_i1 1208 | 1209 | call check(error, val, 3_i1, more="with an additional descriptive message here") 1210 | 1211 | end subroutine test_i1_with_more 1212 | 1213 | 1214 | subroutine test_i2(error) 1215 | 1216 | !> Error handling 1217 | type(error_type), allocatable, intent(out) :: error 1218 | 1219 | integer(i2) :: val 1220 | 1221 | val = 3_i2 1222 | 1223 | call check(error, val, 3_i2) 1224 | 1225 | end subroutine test_i2 1226 | 1227 | 1228 | subroutine test_i2_fail(error) 1229 | 1230 | !> Error handling 1231 | type(error_type), allocatable, intent(out) :: error 1232 | 1233 | integer(i2) :: val 1234 | 1235 | val = 3_i2 1236 | 1237 | call check(error, val, -4_i2) 1238 | 1239 | end subroutine test_i2_fail 1240 | 1241 | 1242 | subroutine test_i2_message(error) 1243 | 1244 | !> Error handling 1245 | type(error_type), allocatable, intent(out) :: error 1246 | 1247 | integer(i2) :: val 1248 | 1249 | val = -3_i2 1250 | 1251 | call check(error, val, 7_i2, "Actual value is not seven") 1252 | 1253 | end subroutine test_i2_message 1254 | 1255 | 1256 | subroutine test_i2_with_more(error) 1257 | 1258 | !> Error handling 1259 | type(error_type), allocatable, intent(out) :: error 1260 | 1261 | integer(i2) :: val 1262 | 1263 | val = 0_i2 1264 | 1265 | call check(error, val, 3_i2, more="with an additional descriptive message here") 1266 | 1267 | end subroutine test_i2_with_more 1268 | 1269 | 1270 | subroutine test_i4(error) 1271 | 1272 | !> Error handling 1273 | type(error_type), allocatable, intent(out) :: error 1274 | 1275 | integer(i4) :: val 1276 | 1277 | val = 3_i4 1278 | 1279 | call check(error, val, 3_i4) 1280 | 1281 | end subroutine test_i4 1282 | 1283 | 1284 | subroutine test_i4_fail(error) 1285 | 1286 | !> Error handling 1287 | type(error_type), allocatable, intent(out) :: error 1288 | 1289 | integer(i4) :: val 1290 | 1291 | val = 3_i4 1292 | 1293 | call check(error, val, -4_i4) 1294 | 1295 | end subroutine test_i4_fail 1296 | 1297 | 1298 | subroutine test_i4_message(error) 1299 | 1300 | !> Error handling 1301 | type(error_type), allocatable, intent(out) :: error 1302 | 1303 | integer(i4) :: val 1304 | 1305 | val = -3_i4 1306 | 1307 | call check(error, val, 7_i4, "Actual value is not seven") 1308 | 1309 | end subroutine test_i4_message 1310 | 1311 | 1312 | subroutine test_i4_with_more(error) 1313 | 1314 | !> Error handling 1315 | type(error_type), allocatable, intent(out) :: error 1316 | 1317 | integer(i4) :: val 1318 | 1319 | val = 0_i4 1320 | 1321 | call check(error, val, 3_i4, more="with an additional descriptive message here") 1322 | 1323 | end subroutine test_i4_with_more 1324 | 1325 | 1326 | subroutine test_i8(error) 1327 | 1328 | !> Error handling 1329 | type(error_type), allocatable, intent(out) :: error 1330 | 1331 | integer(i8) :: val 1332 | 1333 | val = 3_i8 1334 | 1335 | call check(error, val, 3_i8) 1336 | 1337 | end subroutine test_i8 1338 | 1339 | 1340 | subroutine test_i8_fail(error) 1341 | 1342 | !> Error handling 1343 | type(error_type), allocatable, intent(out) :: error 1344 | 1345 | integer(i8) :: val 1346 | 1347 | val = 3_i8 1348 | 1349 | call check(error, val, -4_i8) 1350 | 1351 | end subroutine test_i8_fail 1352 | 1353 | 1354 | subroutine test_i8_message(error) 1355 | 1356 | !> Error handling 1357 | type(error_type), allocatable, intent(out) :: error 1358 | 1359 | integer(i8) :: val 1360 | 1361 | val = -3_i8 1362 | 1363 | call check(error, val, 7_i8, "Actual value is not seven") 1364 | 1365 | end subroutine test_i8_message 1366 | 1367 | 1368 | subroutine test_i8_with_more(error) 1369 | 1370 | !> Error handling 1371 | type(error_type), allocatable, intent(out) :: error 1372 | 1373 | integer(i8) :: val 1374 | 1375 | val = 0_i8 1376 | 1377 | call check(error, val, 3_i8, more="with an additional descriptive message here") 1378 | 1379 | end subroutine test_i8_with_more 1380 | 1381 | 1382 | subroutine test_l4_true(error) 1383 | 1384 | !> Error handling 1385 | type(error_type), allocatable, intent(out) :: error 1386 | 1387 | call check(error, .true., .true.) 1388 | 1389 | end subroutine test_l4_true 1390 | 1391 | 1392 | subroutine test_l4_false(error) 1393 | 1394 | !> Error handling 1395 | type(error_type), allocatable, intent(out) :: error 1396 | 1397 | call check(error, .false., .false.) 1398 | 1399 | end subroutine test_l4_false 1400 | 1401 | 1402 | subroutine test_l4_fail(error) 1403 | 1404 | !> Error handling 1405 | type(error_type), allocatable, intent(out) :: error 1406 | 1407 | call check(error, .true., .false.) 1408 | 1409 | end subroutine test_l4_fail 1410 | 1411 | 1412 | subroutine test_l4_message(error) 1413 | 1414 | !> Error handling 1415 | type(error_type), allocatable, intent(out) :: error 1416 | 1417 | call check(error, .false., .true., "Logical value is not true") 1418 | 1419 | end subroutine test_l4_message 1420 | 1421 | 1422 | subroutine test_l4_with_more(error) 1423 | 1424 | !> Error handling 1425 | type(error_type), allocatable, intent(out) :: error 1426 | 1427 | call check(error, .true., .false., more="with an additional descriptive message") 1428 | 1429 | end subroutine test_l4_with_more 1430 | 1431 | 1432 | subroutine test_char(error) 1433 | 1434 | !> Error handling 1435 | type(error_type), allocatable, intent(out) :: error 1436 | 1437 | character(len=:), allocatable :: val 1438 | 1439 | val = "positive" 1440 | 1441 | call check(error, val, "positive") 1442 | 1443 | end subroutine test_char 1444 | 1445 | 1446 | subroutine test_char_fail(error) 1447 | 1448 | !> Error handling 1449 | type(error_type), allocatable, intent(out) :: error 1450 | 1451 | character(len=:), allocatable :: val 1452 | 1453 | val = "positive" 1454 | 1455 | call check(error, val, "negative") 1456 | 1457 | end subroutine test_char_fail 1458 | 1459 | 1460 | subroutine test_char_message(error) 1461 | 1462 | !> Error handling 1463 | type(error_type), allocatable, intent(out) :: error 1464 | 1465 | character(len=:), allocatable :: val 1466 | 1467 | val = "positive" 1468 | 1469 | call check(error, val, "negative", "Character string should be negative") 1470 | 1471 | end subroutine test_char_message 1472 | 1473 | 1474 | subroutine test_char_with_more(error) 1475 | 1476 | !> Error handling 1477 | type(error_type), allocatable, intent(out) :: error 1478 | 1479 | character(len=:), allocatable :: val 1480 | 1481 | val = "positive" 1482 | 1483 | call check(error, val, "negative", more="with an additional descriptive message") 1484 | 1485 | end subroutine test_char_with_more 1486 | 1487 | 1488 | subroutine test_string_i1(error) 1489 | 1490 | !> Error handling 1491 | type(error_type), allocatable, intent(out) :: error 1492 | 1493 | call check(error, to_string(-huge(1_i1) - 1_i1), "-128") 1494 | end subroutine test_string_i1 1495 | 1496 | 1497 | subroutine test_string_i2(error) 1498 | 1499 | !> Error handling 1500 | type(error_type), allocatable, intent(out) :: error 1501 | 1502 | call check(error, to_string(-huge(1_i2) - 1_i2), "-32768") 1503 | end subroutine test_string_i2 1504 | 1505 | 1506 | subroutine test_string_i4(error) 1507 | 1508 | !> Error handling 1509 | type(error_type), allocatable, intent(out) :: error 1510 | 1511 | call check(error, to_string(-huge(1_i4) - 1_i4), "-2147483648") 1512 | end subroutine test_string_i4 1513 | 1514 | 1515 | subroutine test_string_i8(error) 1516 | 1517 | !> Error handling 1518 | type(error_type), allocatable, intent(out) :: error 1519 | 1520 | call check(error, to_string(-huge(1_i8) - 1_i8), "-9223372036854775808") 1521 | end subroutine test_string_i8 1522 | 1523 | 1524 | end module test_check 1525 | -------------------------------------------------------------------------------- /test/test_select.F90: -------------------------------------------------------------------------------- 1 | ! This file is part of test-drive. 2 | ! SPDX-Identifier: Apache-2.0 OR MIT 3 | ! 4 | ! Licensed under either of Apache License, Version 2.0 or MIT license 5 | ! at your option; you may not use this file except in compliance with 6 | ! the License. 7 | ! 8 | ! Unless required by applicable law or agreed to in writing, software 9 | ! distributed under the License is distributed on an "AS IS" BASIS, 10 | ! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 11 | ! See the License for the specific language governing permissions and 12 | ! limitations under the License. 13 | 14 | module test_select 15 | use, intrinsic :: ieee_arithmetic, only : ieee_value, ieee_quiet_nan 16 | use testdrive, only : new_unittest, unittest_type, error_type, check, & 17 | & run_testsuite, new_testsuite, testsuite_type, select_suite, run_selected 18 | implicit none 19 | private 20 | 21 | public :: collect_select 22 | 23 | 24 | contains 25 | 26 | 27 | !> Collect all exported unit tests 28 | subroutine collect_select(testsuite) 29 | 30 | !> Collection of tests 31 | type(unittest_type), allocatable, intent(out) :: testsuite(:) 32 | 33 | testsuite = [ & 34 | new_unittest("always-pass", always_pass), & 35 | new_unittest("always-fail", always_fail, should_fail=.true.), & 36 | new_unittest("run-good-suite", test_run_good_suite), & 37 | new_unittest("run-bad-suite", test_run_bad_suite), & 38 | new_unittest("run-selected", test_run_selected), & 39 | new_unittest("select-missing", test_select_missing) & 40 | ] 41 | 42 | end subroutine collect_select 43 | 44 | 45 | subroutine always_pass(error) 46 | 47 | !> Error handling 48 | type(error_type), allocatable, intent(out) :: error 49 | 50 | call check(error, 0) 51 | 52 | end subroutine always_pass 53 | 54 | 55 | subroutine always_fail(error) 56 | 57 | !> Error handling 58 | type(error_type), allocatable, intent(out) :: error 59 | 60 | call check(error, 1, "Always failing test") 61 | 62 | end subroutine always_fail 63 | 64 | 65 | !> Stub test suite collector defining passing unit tests 66 | subroutine stub_collect(testsuite) 67 | 68 | !> Collection of tests 69 | type(unittest_type), allocatable, intent(out) :: testsuite(:) 70 | 71 | testsuite = [ & 72 | new_unittest("always-pass", always_pass), & 73 | new_unittest("always-fail", always_fail, should_fail=.true.) & 74 | ] 75 | 76 | end subroutine stub_collect 77 | 78 | 79 | !> Bad test suite collector defining flaky unit tests 80 | subroutine stub_collect_bad(testsuite) 81 | 82 | !> Collection of tests 83 | type(unittest_type), allocatable, intent(out) :: testsuite(:) 84 | 85 | testsuite = [ & 86 | new_unittest("always-pass", always_pass, should_fail=.true.), & 87 | new_unittest("always-fail", always_fail) & 88 | ] 89 | 90 | end subroutine stub_collect_bad 91 | 92 | 93 | subroutine test_run_good_suite(error) 94 | 95 | !> Error handling 96 | type(error_type), allocatable, intent(out) :: error 97 | 98 | integer :: unit, stat 99 | 100 | open(status='scratch', newunit=unit) 101 | 102 | stat = 7 103 | call run_testsuite(stub_collect, unit, stat) 104 | call check(error, stat, 7) 105 | 106 | close(unit) 107 | 108 | end subroutine test_run_good_suite 109 | 110 | 111 | subroutine test_run_bad_suite(error) 112 | 113 | !> Error handling 114 | type(error_type), allocatable, intent(out) :: error 115 | 116 | integer :: unit, stat 117 | 118 | open(status='scratch', newunit=unit) 119 | 120 | stat = 3 121 | call run_testsuite(stub_collect_bad, unit, stat) 122 | call check(error, stat, 5) 123 | 124 | close(unit) 125 | 126 | end subroutine test_run_bad_suite 127 | 128 | 129 | subroutine test_run_selected(error) 130 | 131 | !> Error handling 132 | type(error_type), allocatable, intent(out) :: error 133 | 134 | integer :: unit, stat 135 | 136 | open(status='scratch', newunit=unit) 137 | 138 | stat = 1 139 | call run_selected(stub_collect, "always-fail", unit, stat) 140 | call check(error, stat, 1) 141 | 142 | close(unit) 143 | 144 | end subroutine test_run_selected 145 | 146 | 147 | subroutine test_select_missing(error) 148 | 149 | !> Error handling 150 | type(error_type), allocatable, intent(out) :: error 151 | 152 | integer :: unit, stat 153 | 154 | open(status='scratch', newunit=unit) 155 | 156 | call run_selected(stub_collect, "not-available", unit, stat) 157 | call check(error, stat < 0) 158 | 159 | close(unit) 160 | 161 | end subroutine test_select_missing 162 | 163 | 164 | end module test_select 165 | --------------------------------------------------------------------------------