pax_global_header00006660000000000000000000000064150315770440014520gustar00rootroot0000000000000052 comment=5a65f5defc19e190756a8bcc6a87a8e396292ff2 assert-2.1.2/000077500000000000000000000000001503157704400130235ustar00rootroot00000000000000assert-2.1.2/.github/000077500000000000000000000000001503157704400143635ustar00rootroot00000000000000assert-2.1.2/.github/workflows/000077500000000000000000000000001503157704400164205ustar00rootroot00000000000000assert-2.1.2/.github/workflows/build.yml000066400000000000000000000114451503157704400202470ustar00rootroot00000000000000name: Build on: [push, pull_request] jobs: build: name: ${{ matrix.compiler }}-${{ matrix.version }} (${{ matrix.os }}) runs-on: ${{ matrix.os }} strategy: fail-fast: false matrix: os: [macos-13, macos-14, ubuntu-22.04, ubuntu-24.04] compiler: [ gfortran ] version: [ 12, 13, 14 ] extra_flags: [ -ffree-line-length-0 ] include: # https://hub.docker.com/r/phhargrove/llvm-flang/tags - os: ubuntu-24.04 compiler: flang version: 20 extra_flags: -g container: phhargrove/llvm-flang:20.1.0-1 - os: ubuntu-24.04 compiler: flang version: 19 extra_flags: -g -mmlir -allow-assumed-rank container: phhargrove/llvm-flang:19.1.1-1 # - os: ubuntu-24.04 # compiler: flang # version: new # container: gmao/llvm-flang:latest # extra_flags: -g - os: ubuntu-24.04 compiler: ifx version: 2025.1.0 error_stop_code: 128 extra_flags: -g container: intel/fortran-essentials:2025.1.0-0-devel-ubuntu24.04 #container: intel/oneapi-hpckit:2025.1.0-0-devel-ubuntu24.04 - os: ubuntu-22.04 compiler: ifx version: 2025.0.0 error_stop_code: 128 extra_flags: -g container: intel/fortran-essentials:2025.0.0-0-devel-ubuntu22.04 exclude: - os: ubuntu-22.04 version: 13 # no package available - os: ubuntu-22.04 version: 14 # no package available container: image: ${{ matrix.container }} env: GCC_VERSION: ${{ matrix.version }} FC: ${{ matrix.compiler }} FPM_FLAGS: --profile release --verbose steps: - name: Checkout code uses: actions/checkout@v4 - name: Install Dependencies Ubuntu if: ${{ contains(matrix.os, 'ubuntu') && matrix.compiler == 'gfortran' && 0 }} run: | sudo apt-get update sudo apt list -a 'gfortran-*' sudo apt install -y gfortran-${GCC_VERSION} build-essential sudo update-alternatives --install /usr/bin/gcc gcc /usr/bin/gcc-${GCC_VERSION} 100 \ --slave /usr/bin/gfortran gfortran /usr/bin/gfortran-${GCC_VERSION} - name: Setup Compilers run: | set -x if test "$FC" = "flang" ; then \ echo "FPM_FC=flang-new" >> "$GITHUB_ENV" ; \ elif test "$FC" = "ifx" ; then \ echo "FPM_FC=ifx" >> "$GITHUB_ENV" ; \ else \ echo "FPM_FC=gfortran-${GCC_VERSION}" >> "$GITHUB_ENV" ; \ fi if test -n "${{ matrix.error_stop_code }}" ; then \ echo "ERROR_STOP_CODE=${{ matrix.error_stop_code }}" >> "$GITHUB_ENV" ; \ else \ echo "ERROR_STOP_CODE=1" >> "$GITHUB_ENV" ; \ fi - name: Setup FPM uses: fortran-lang/setup-fpm@main if: ${{ matrix.os != 'macos-14' }} with: github-token: ${{ secrets.GITHUB_TOKEN }} - name: Build FPM if: ${{ matrix.os == 'macos-14' }} # no arm64 fpm distro, build from source run: | set -x curl --retry 5 -LOsS https://github.com/fortran-lang/fpm/releases/download/v0.11.0/fpm-0.11.0.F90 mkdir fpm-temp gfortran-14 -o fpm-temp/fpm fpm-0.11.0.F90 echo "PATH=`pwd`/fpm-temp:${PATH}" >> "$GITHUB_ENV" - name: Version info run: | set -x echo == TOOL VERSIONS == uname -a if test -r /etc/os-release ; then cat /etc/os-release ; fi ${FPM_FC} --version fpm --version - name: Build and Test (Assertions OFF) run: | set -x fpm test ${FPM_FLAGS} --flag "${{ matrix.EXTRA_FLAGS }}" fpm run --example false-assertion ${FPM_FLAGS} --flag "${{ matrix.EXTRA_FLAGS }}" fpm run --example invoke-via-macro ${FPM_FLAGS} --flag "${{ matrix.EXTRA_FLAGS }}" - name: Build and Test (Assertions ON) env: FPM_FLAGS: ${{ env.FPM_FLAGS }} --flag -DASSERTIONS run: | set -x fpm test ${FPM_FLAGS} --flag "${{ matrix.EXTRA_FLAGS }}" ( set +e ; fpm run --example false-assertion ${FPM_FLAGS} --flag "${{ matrix.EXTRA_FLAGS }}" ; test $? = $ERROR_STOP_CODE ) ( set +e ; fpm run --example invoke-via-macro ${FPM_FLAGS} --flag "${{ matrix.EXTRA_FLAGS }}" ; test $? = $ERROR_STOP_CODE ) - name: Test Assertions w/ Parallel Callbacks env: FPM_FLAGS: ${{ env.FPM_FLAGS }} --flag -DASSERTIONS --flag -DASSERT_MULTI_IMAGE --flag -DASSERT_PARALLEL_CALLBACKS run: | set -x ( set +e ; fpm run --example false-assertion ${FPM_FLAGS} --flag "${{ matrix.EXTRA_FLAGS }}" ; test $? = $ERROR_STOP_CODE ) assert-2.1.2/.github/workflows/deploy-docs.yml000066400000000000000000000026471503157704400213760ustar00rootroot00000000000000name: Build and Deploy Documentation on: [push, pull_request] jobs: build: name: Build and Deploy Documentation runs-on: ubuntu-22.04 env: FC: gfortran GCC_V: 12 steps: - name: Checkout code uses: actions/checkout@v4 - name: Install Dependencies Ubuntu run: | sudo apt-get update sudo apt install -y gfortran-${GCC_V} python3-dev python3 build-essential numdiff graphviz sudo pip install ford markdown==3.3.4 - name: Build Developer Documentation run: | ford -I include doc-generator.md > ford_output.txt # Turn warnings into errors cat ford_output.txt; if grep -q -i Warning ford_output.txt; then exit 1; fi cp ./README.md ./doc/html - name: Upload Documentation uses: actions/upload-artifact@v4 with: name: documentation path: doc/html if-no-files-found: error - name: Broken Link Check if: ${{ github.ref == 'refs/heads/main'}} uses: technote-space/broken-link-checker-action@v2.3.1 with: TARGET: file://${{ github.workspace }}/doc/html/index.html RECURSIVE: true ASSIGNEES: ${{ github.actor }} - name: Deploy API Documentation uses: JamesIves/github-pages-deploy-action@v4.6.4 if: ${{ github.event_name == 'push' && github.ref == 'refs/heads/main' }} with: branch: gh-pages folder: doc/html assert-2.1.2/.gitignore000066400000000000000000000005341503157704400150150ustar00rootroot00000000000000# Build tree build # Prerequisites *.d # Compiled Object files *.slo *.lo *.o *.obj # Precompiled Headers *.gch *.pch # Compiled Dynamic libraries *.so *.dylib *.dll # Fortran (sub)module files *.mod *.smod *.sub # Compiled Static libraries *.lai *.la *.a *.lib # Executables *.exe *.out *.app # FORD-generated documentation files doc/html assert-2.1.2/LICENSE000066400000000000000000000121611503157704400140310ustar00rootroot00000000000000***************************** *** Assert LICENSE file *** ***************************** All files in this directory and all sub-directories (except where otherwise noted) are subject to the following copyright and licensing terms. *** Copyright Notice *** Assert v2.0.0 Copyright (c) 2024-2025, The Regents of the University of California, through Lawrence Berkeley National Laboratory (subject to receipt of any required approvals from the U.S. Dept. of Energy) and Sourcery Institute. All rights reserved. If you have questions about your rights to use or distribute this software, please contact Berkeley Lab's Intellectual Property Office at IPO@lbl.gov. NOTICE. This Software was developed under funding from the U.S. Department of Energy and the U.S. Government consequently retains certain rights. As such, the U.S. Government has been granted for itself and others acting on its behalf a paid-up, nonexclusive, irrevocable, worldwide license in the Software to reproduce, distribute copies to the public, prepare derivative works, and perform publicly and display publicly, and to permit others to do so. *** License Agreement *** Assert v2.0.0 Copyright (c) 2024-2025, The Regents of the University of California, through Lawrence Berkeley National Laboratory (subject to receipt of any required approvals from the U.S. Dept. of Energy) and Sourcery Institute. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: (1) Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. (2) Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. (3) Neither the name of the University of California, Lawrence Berkeley National Laboratory, U.S. Dept. of Energy, Sourcery Institute, nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. You are under no obligation whatsoever to provide any bug fixes, patches, or upgrades to the features, functionality or performance of the source code ("Enhancements") to anyone; however, if you choose to make your Enhancements available either publicly, or directly to Lawrence Berkeley National Laboratory, without imposing a separate written license agreement for such Enhancements, then you hereby grant the following license: a non-exclusive, royalty-free perpetual license to install, use, modify, prepare derivative works, incorporate into other computer software, distribute, and sublicense such enhancements or derivative works thereof, in binary and source code form. *** Prior Licenses *** Prior versions of assert were distributed under the following license: BSD 3-Clause License Copyright (c) 2021, Sourcery Institute All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. assert-2.1.2/README.md000066400000000000000000000275471503157704400143210ustar00rootroot00000000000000Assert ====== An assertion utility that combines variable stop codes and error termination in `pure` procedures to produce descriptive messages when a program detects violations of the requirements for correct execution. Motivations ----------- 1. To mitigate against a reason developers often cite for not writing `pure` procedures: their inability to produce output in normal execution. 2. To promote the enforcement of programming contracts. Overview -------- This assertion utility contains four public entities: 1. An `assert` subroutine, 2. A `characterizable_t` abstract type supporting `assert`, and 3. An `intrinsic_array_t` non-abstract type extending `characterizable_t`. 4. An `assert_macros.h` header file containing C-preprocessor macros. The `assert` subroutine * Error-terminates with a variable stop code when a caller-provided logical assertion fails, * Includes user-supplied diagnostic data in the output if provided by the calling procedure, * Is callable inside `pure` procedures, and * Can be eliminated at compile-time, as controlled by the `ASSERTIONS` preprocessor define. Assertion enforcement is controlled via the `ASSERTIONS` preprocessor macro, which can be defined to non-zero or zero at compilation time to respectively enable or disable run-time assertion enforcement. When the `ASSERTIONS` preprocessor macro is not defined to any value, the default is that assertions are *disabled* and will not check the condition. To enable assertion enforcement (e.g., for a debug build), define the preprocessor ASSERTIONS to non-zero, eg: ``` fpm build --flag "-DASSERTIONS" ``` The program [example/invoke-via-macro.F90] demonstrates the preferred way to invoke assertions via the three provided macros. Invoking assertions this way ensures such calls will be completely removed whenever the `ASSERTIONS` macro is undefined (or defined to zero) during compilation. Due to a limitation of `fpm`, this approach works best if the project using Assert is also a `fpm` project. If instead `fpm install` is used, then either the user must copy `include/assert_macros.h` to the installation directory (default: `~/.local/include`) or the user must invoke `assert` directly (via `call assert(...)`). In the latter approach when the assertions are disabled, the `assert` procedure will start and end with `if (.false.) then ... end if`, which might facilitate automatic removal of `assert` during the dead-code removal phase of optimizing compilers. The `characterizable_t` type defines an `as_character()` deferred binding that produces `character` strings for use as diagnostic output from a user-defined derived type that extends `characterizable_t` and implements the deferred binding. The `intrinsic_array_t` type that extends `characterizable_t` provides a convenient mechanism for producing diagnostic output from arrays of intrinsic type `complex`, `integer`, `logical`, or `real`. Use Cases --------- Two common use cases include 1. [Enforcing programming contracts] throughout a project via runtime checks. 2. Producing output in `pure` procedures for debugging purposes. ### Enforcing programming contracts Programming can be thought of as requirements for correct execution of a procedure and assurances for the result of correct execution. The requirements and assurances might be constraints of three kinds: 1. **Preconditions (requirements):** `logical` expressions that must evaluate to `.true.` when a procedure starts execution, 2. **Postconditions (assurances):** expressions that must evaluate to `.true.` when a procedure finishes execution, and 3. **Invariants:** universal pre- and postconditions that must always be true when all procedures in a class start or finish executing. The [example/README.md] file shows examples of writing constraints in notes on class diagrams using the formal syntax of the Object Constraint Language ([OCL]). Downloading, Building, and Running Examples ------------------------------------------- ### Downloading Assert ``` git clone git@github.com:berkeleylab/assert cd assert ``` ### Building and testing with `gfortran` #### Single-image (serial) execution The command below builds Assert and runs the full test suite in a single image. For `gfortran` 14 or later, use ``` fpm test --profile release ``` For `gfortran` 13 or earlier, use ``` fpm test --profile release --flag "-ffree-line-length-0" ``` The above commands build the Assert library (with the default of assertion enforcement disabled) and runs the test suite. #### Multi-image (parallel) execution With `gfortran` 14 or later versions and OpenCoarrays installed, use ``` fpm test --compiler caf --profile release --runner "cafrun -n 2" ``` With `gfortran` 13 or earlier versions and OpenCoarrays installed, ``` fpm test --compiler caf --profile release --runner "cafrun -n 2" --flag "-ffree-line-length-0" ``` To build and test with the Numerical Algorithms Group (NAG) Fortran compiler version 7.1 or later, use ``` fpm test --compiler=nagfor --profile release --flag "-coarray=cosmp -fpp -f2018" ``` ### Building and testing with the Intel `ifx` compiler #### Single-image (serial) execution ``` fpm test --compiler ifx --profile release ``` #### Multi-image (parallel) execution With Intel Fortran and Intel MPI installed, ``` fpm test --compiler ifx --profile release --flag "-coarray -DASSERT_MULTI_IMAGE" ``` ### Building and testing with the LLVM `flang-new` compiler #### LLVM version 19 ``` fpm test --compiler flang-new --flag "-mmlir -allow-assumed-rank -O3" ``` #### LLVM version 20 or later ``` fpm test --compiler flang-new --flag "-O3" ``` ### Building and testing with the Numerical Algorithms Group (NAG) compiler ``` fpm test --compiler nagfor --profile release --flag "-fpp -coarray=cosmp" ``` ### Building and testing with the Cray Compiler Environment (CCE) Because `fpm` uses the compiler name to determine the compiler identity and because CCE provides one compiler wrapper, `ftn`, for invoking all compilers, you will need to invoke `ftn` in a shell script named to identify CCE compiler. For example, place a script named `crayftn.sh` in your path with the following contents and with executable privileges set appropriately: ``` #!/bin/bash ftn $@ ``` Then build and test Assert with the command ``` fpm test --compiler crayftn.sh --profile release ``` ### Building and testing with other compilers To use Assert with other compilers, please submit an issue or pull request. ### Running the examples See the [./example](./example) subdirectory. Documentation ------------- See [Assert's GitHub Pages site] for HTML documentation generated with [`ford`]. For further documentation, please see [example/README.md] and the [tests]. Also, the code in [src] has comments formatted for generating HTML documentation using [FORD]. ### Potential pitfalls of `call_assert` macros: The `call_assert*` macros from the `assert_macros.h` header file provide the attractive guarantee that they will always compile *completely* away when assertions are disabled, regardless of compiler analyses and optimization level. This means users can reap the maintainability and correctness benefits of aggressively asserting invariants throughout their code, without needing to balance any potential performance cost associated with such assertions when the code runs in production. Unfortunately, C-preprocessor macros do not integrate cleanly with some aspects of the Fortran language. As such, you might encounter one or more of the following pitfalls when using these macros. #### Line length limit Up to and including the Fortran 2018 language standard, compilers were only required to support up to 132 characters per free-form source line. Preprocessor macro invocations are always expanded to a single line during compilation, so when passing non-trivial arguments to macros including `call_assert*` it becomes easy for the expansion to exceed this line length limit. This can result in compile-time errors like the following from gfortran: ``` Error: Line truncated at (1) [-Werror=line-truncation] ``` Some compilers offer a command-line argument that can be used to workaround this legacy limit, eg: * `gfortran -ffree-line-length-0` aka `gfortran -ffree-line-length-none` When using `fpm`, one can pass such a flag to the compiler using the `fpm --flag` option, eg: ```shell $ fpm test --profile release --flag -ffree-line-length-0 ``` Thankfully Fortran 2023 raised this obscolecent line limit to 10,000 characters, so by using newer compilers you might never encounter this problem. In the case of gfortran, this appears to have been resolved by default starting in release 14.1.0. #### Line breaks in macro invocations The preprocessor is not currently specified by any Fortran standard, and as of 2024 its operation differs in subtle ways between compilers. One way in which compilers differ is how macro invocations can safely be broken across multiple lines. For example, gfortran and flang-new both accept backslash `\` continuation character for line-breaks in a macro invocation: ```fortran ! OK for flang-new and gfortran call_assert_diagnose( computed_checksum == expected_checksum, \ "Checksum mismatch failure!", \ expected_checksum ) ``` Whereas Cray Fortran wants `&` line continuation characters, even inside a macro invocation: ```fortran ! OK for Cray Fortran call_assert_diagnose( computed_checksum == expected_checksum, & "Checksum mismatch failure!", & expected_checksum ) ``` There appears to be no syntax acceptable to all compilers, so when writing portable code it's probably best to avoid line breaks inside a macro invocation. #### Comments in macro invocations Fortran does not support comments with an end delimiter, only to-end-of-line comments. As such, there is no portable way to safely insert a Fortran comment into the middle of a macro invocation. For example, the following seemingly reasonable code results in a syntax error after macro expansion (on gfortran and flang-new): ```fortran ! INCORRECT: cannot use Fortran comments inside macro invocation call_assert_diagnose( computed_checksum == expected_checksum, ! ensured since version 3.14 "Checksum mismatch failure!", ! TODO: write a better message here computed_checksum ) ``` Depending on your compiler it *might* be possible to use a C-style block comment (because they are often removed by the preprocessor), for example with gfortran one can instead write the following: ```fortran call_assert_diagnose( computed_checksum == expected_checksum, /* ensured since version 3.14 */ \ "Checksum mismatch failure!", /* TODO: write a better message here */ \ computed_checksum ) ``` However that capability might not be portable to other Fortran compilers. When in doubt, one can always move the comment outside the macro invocation: ```fortran ! assert a property ensured since version 3.14 call_assert_diagnose( computed_checksum == expected_checksum, \ "Checksum mismatch failure!", \ computed_checksum ) ! TODO: write a better message above ``` Legal Information ----------------- See the [LICENSE](LICENSE) file for copyright and licensing information. [Hyperlinks]:# [OpenCoarrays]: https://github.com/sourceryinstitute/opencoarrays [Enforcing programming contracts]: #enforcing-programming-contracts [Single-image execution]: #single-image-execution [example/README.md]: ./example/README.md [tests]: ./tests [src]: ./src [FORD]: https://github.com/Fortran-FOSS-Programmers/ford [Fortran Package Manager]: https://github.com/fortran-lang/fpm [OCL]: https://en.wikipedia.org/wiki/Object_Constraint_Language [Assert's GitHub Pages site]: https://berkeleylab.github.io/assert/ [`ford`]: https://github.com/Fortran-FOSS-Programmers/ford [example/invoke-via-macro.F90]: ./example/invoke-via-macro.F90 assert-2.1.2/doc-generator.md000066400000000000000000000004601503157704400160760ustar00rootroot00000000000000--- project: Assert library summary: A toolkit for checking runtime assertions. src_dir: src/ exclude_dir: doc output_dir: doc/html preprocess: true macro: FORD preprocessor: gfortran -E display: public protected private source: true graph: true md_extensions: markdown.extensions.toc assert-2.1.2/doc/000077500000000000000000000000001503157704400135705ustar00rootroot00000000000000assert-2.1.2/doc/assert_class_diagram.puml000066400000000000000000000006551503157704400206470ustar00rootroot00000000000000@startuml Title Classes in the Assert Library hide empty members abstract class characterizable_t{ {abstract} as_character() : character(len=:), allocatable } class intrinsic_array_t{ c[] : complex i[] : integer l[] : logical r[]: real intrinsic_arry_t(array[..] : class(*)) : intrinsic_array_t as_character() : character(len=:), allocatable } intrinsic_array_t .up.|> characterizable_t : implements @enduml assert-2.1.2/doc/example_class_diagram.puml000066400000000000000000000012711503157704400207740ustar00rootroot00000000000000@startuml Title Classes in the Derived-Type Diagnostic Data Example hide empty members class stuff_t{ z_ : complex defined_ : logical z() : complex defined() : logical stuff_t(z : complex) : stuff_t } note right: context stuff_t(z : complex)\npost: stuff_t%defined()\n\ncontext z() \npre: self%defined() abstract class characterizable_t{ {abstract} as_character() : character(len=:), allocatable } class characterizable_stuff_t{ stuff_ : stuff_t as_character() : character(len=:), allocatable characterizable_t(stuff_t) : characterizable_stuff_t } characterizable_stuff_t *-down- stuff_t : aggregates characterizable_stuff_t .up.|> characterizable_t : implements @enduml assert-2.1.2/example/000077500000000000000000000000001503157704400144565ustar00rootroot00000000000000assert-2.1.2/example/README.md000066400000000000000000000106501503157704400157370ustar00rootroot00000000000000Examples ======== This directory contains two example programs. Simple examples --------------- The [simple_assertions.f90] example demonstrates a precondition and a postcondition, each with an assertion that checks the truth of a logical expression based on scalar, real values. Derived type diagnostic data ---------------------------- See [derived_type_diagnostic.f90]. For reasons related to runtime performance, it is desirable to ensure that any computation required to extract diagnostic data from an object only take place if the assertion fails. This is one of the main motivations for allowing objects to be passed to the `diagnostic_data` argument of `assert`. The generic programming facilities planned for "Fortran 202y" (two standards after Fortran 2018) will ultimately provide the best way to facilitate the extraction of diagnostic data from objects by empowering developers to express requirements on types such as that the types must support a specific procedure binding that can be used to extract output in character form, the form that `assert` uses for its error stop code. For now, we impose such a requirement through an `as_character` deferred binding on the provided `characterizable_t` abstract type. Because it might prove problematic to require that a user type to extend the `characterizable_t` abstract type, the [derived_type_diagnostic.f90] example shows a workaround based on the class hierarchy described in the figure below. The figure shows a Unified Modeling Language ([UML]) class diagram with the `characterizable_t` abstract class, an example user's `stuff_t` class, and a `characterizable_stuff_t` class. The pattern expressed in the workaround aggregates the example user type, `stuff_t`, as a component inside the encapsulating `characterizable_stuff_t` type defined to extend `characterizable_t` for purposes of implementing `characterizable_t` parent type's deferred `as_character()` binding. The figure below also shows two constraints written in UML's Object Constraint Language ([OCL]). The constraints describe the precondition and postcondition checked in [derived_type_diagnostic.f90] and the context for those constraints. The UML diagram below was generated in the [Atom] editor [PlantUML] package from the PlantUML script in this repository's [doc] folder. ![Classes involved in Derived-Type Diagnostic Example](https://user-images.githubusercontent.com/13108868/130385757-6b79e5f1-5dec-440c-98f5-0f659c538754.png) Running the examples -------------------- ### Single-image execution ``` fpm run --example simple_assertions fpm run --example derived_type_diagnostic ``` where `fpm run` automatically invokes `fpm build` if necessary, .e.g., if the package's source code has changed since the most recent build. If `assert` is working correctly, the first `fpm run` above will error-terminate with the character stop code ``` Assertion "reciprocal: abs(error) < tolerance" failed on image 1 with diagnostic data "-1.00000000" ``` and the second `fpm run` above will error-terminate with the character stop code ``` Assertion "stuff_t%z(): self%defined()" failed on image 1 with diagnostic data "(none provided)" ``` ### Multi-image execution with `gfortran` and OpenCoarrays ``` git clone git@github.com/sourceryinstitute/assert cd assert fpm run --compiler caf --runner "cafrun -n 2" --example simple_assertions fpm run --compiler caf --runner "cafrun -n 2" --example derived_type_diagnostic ``` Replace either instance of `2` above with the desired number of images to run for parallel execution. If `assert` is working correctly, both of the latter `fpm run` commands will error-terminate with one or more images providing stop codes analogous to those quoted in the [Single-image execution] section. ## Derived-type diagnostic data output To demonstrate the derived-type diagnostic data output capability, try replacing the `i%defined()` assertion in the [derived_type_diagnostic.f90](./derived_type_diagnostic.f90) with `.false.`. [Hyperlinks]:# [OpenCoarrays]: https://github.com/sourceryinstitute/opencoarrays [Enforcing programming contracts]: #enforcing-programming-contracts [Single-image execution]: #single-image-execution [derived_type_diagnostic.f90]: ./derived_type_diagnostic.f90 [simple_assertions.f90]: ./simple_assertions.f90 [UML]: https://en.wikipedia.org/wiki/Unified_Modeling_Language [OCL]: https://en.wikipedia.org/wiki/Object_Constraint_Language [Atom]: https://atom.io [PlantUML]: https://plantuml.com [doc]: ../doc/ assert-2.1.2/example/derived-type_diagnostic.F90000066400000000000000000000103601503157704400215430ustar00rootroot00000000000000module stuff_m !! Example module with a type that does not extend characterizable_t. use assert_m, only : assert implicit none private public :: stuff_t type stuff_t !! Example type demonstrating how to get diagnostic data from a type !! that does not extend characterizable_t. private complex z_ logical :: defined_=.false. contains procedure z procedure defined end type interface pure module function z(self) result(self_z) !! Accessor: returns z_ component value class(stuff_t), intent(in) :: self complex self_z end function pure module function defined(self) result(self_defined) !! Result is true if the object has been marked as user-defined. class(stuff_t), intent(in) :: self logical self_defined end function end interface interface stuff_t pure module function construct(z) result(new_stuff_t) !! Constructor: result is a new stuff_t object. complex, intent(in) :: z type(stuff_t) new_stuff_t end function end interface contains pure module function defined(self) result(self_defined) class(stuff_t), intent(in) :: self logical self_defined self_defined = self%defined_ end function module procedure construct new_stuff_t%z_ = z new_stuff_t%defined_ = .true. call assert(new_stuff_t%defined(), "stuff_t construct(): new_stuff_t%defined()", new_stuff_t%defined_) ! Postcondition end procedure module procedure z call assert(self%defined(), "stuff_t%z(): self%defined()") ! Precondition self_z = self%z_ end procedure end module module characterizable_stuff_m !! Demonstrate a pattern for getting derived-type diagnostic data output from a type that !! does not extend characterizable_t. use stuff_m, only : stuff_t use characterizable_m, only : characterizable_t implicit none private public :: characterizable_stuff_t type, extends(characterizable_t) :: characterizable_stuff_t !! Encapsulate the example type and extend characterizable_t to enable diagnostic-data !! output in assertions. private type(stuff_t) stuff_ contains procedure as_character end type interface pure module function as_character(self) result(character_self) !! Produce a character representation of the encapsulated type implicit none class(characterizable_stuff_t), intent(in) :: self character(len=:), allocatable :: character_self end function end interface interface characterizable_stuff_t pure module function construct(stuff) result(new_characterizable_stuff) !! Result is a new characterizable_stuff_t object implicit none type(stuff_t), intent(in) :: stuff type(characterizable_stuff_t) :: new_characterizable_stuff end function end interface contains pure module function as_character(self) result(character_self) class(characterizable_stuff_t), intent(in) :: self character(len=:), allocatable :: character_self integer, parameter :: max_len=256 character(len=max_len) untrimmed_string write(untrimmed_string,*) self%stuff_%z() character_self = trim(adjustl(untrimmed_string)) end function module procedure construct new_characterizable_stuff%stuff_ = stuff end procedure end module program diagnostic_data_pattern !! Demonstrate !! 1. A successful assertion with a derived-type diagnostic_data argument, !! 2. A failing internal assertion that prevents the use of undefined data. !! Item 1 also demonstrates the usefulness of a constructor postcondition. !! Item 2 also demonstrates the usefulness of an accessor precondition. use assert_m, only : assert use stuff_m, only : stuff_t use characterizable_stuff_m, only : characterizable_stuff_t implicit none type(stuff_t) stuff #ifndef _CRAYFTN associate (i => stuff_t(z=(0.,1.))) call assert(i%defined(), "main: i%defined()", characterizable_stuff_t(i))!Passes: constructor postcondition ensures defined data end associate #else block type(stuff_t) stuff stuff = stuff_t(z=(0.,1.)) call assert(stuff%defined(), "main: i%defined()", characterizable_stuff_t(stuff)) end block #endif print *, stuff%z() ! Fails: accessor precondition catches use of undefined data end program assert-2.1.2/example/false-assertion.F90000066400000000000000000000025021503157704400200340ustar00rootroot00000000000000program false_assertion use assert_m implicit none #if ASSERT_PARALLEL_CALLBACKS assert_this_image => assert_callback_this_image assert_error_stop => assert_callback_error_stop #endif call assert(.false., "false-assertion: unconditionally failing test") #if ASSERT_PARALLEL_CALLBACKS ! By default, assert uses `THIS_IMAGE()` in multi-image mode while ! composing assertion output, and invokes `ERROR STOP` to print the ! assertion and terminate execution. ! ! The ASSERT_PARALLEL_CALLBACKS preprocessor flag enables the client to replace ! the default use of these two Fortran features with client-provided callbacks. ! To use this feature, the client must build the library with `-DASSERT_PARALLEL_CALLBACKS`, ! and then at startup set the `assert_this_image` and `assert_error_stop` ! procedure pointers to reference the desired callbacks. contains pure function assert_callback_this_image() result(this_image_id) implicit none integer :: this_image_id this_image_id = 42 end function pure subroutine assert_callback_error_stop(stop_code_char) implicit none character(len=*), intent(in) :: stop_code_char error stop "Hello from assert_callback_error_stop!" // NEW_LINE('a') // & "Your assertion: " // NEW_LINE('a') // stop_code_char end subroutine #endif end program assert-2.1.2/example/invoke-via-macro.F90000066400000000000000000000031771503157704400201150ustar00rootroot00000000000000#include "assert_macros.h" program invoke_via_macro !! Demonstrate how to invoke the 'assert' subroutine using a preprocessor macro that facilitates !! the complete removal of the call in the absence of the compiler flag: -DASSERTIONS use assert_m ! <--- this is the recommended use statement !! If an "only" clause is employed above, the symbols required by the !! macro expansion are subject to change without notice between versions. !! You have been warned! implicit none #if !ASSERTIONS print * print *,'To enable the "call_assert" invocations, define the ASSERTIONS macro. e.g.:' print *,' fpm run --example invoke-via-macro --flag "-DASSERTIONS -fcoarray=single -ffree-line-length-0"' print * #endif ! The C preprocessor will convert each call_assert* macro below into calls that enforce the assertion ! whenever the ASSERTIONS macro is defined to non-zero (e.g. via the -DASSERTIONS compiler flag). ! Whenever the ASSERTIONS macro is undefined or defined to zero (e.g. via the -DASSERTIONS=0 compiler flag), ! these calls will be entirely removed by the preprocessor. call_assert(1==1) ! true assertion call_assert_describe(2>0, "example assertion invocation via macro") ! true assertion call_assert_diagnose(1+1==2, "example with scalar diagnostic data", 1+1) ! true assertion #if ASSERTIONS print * print *,'Here comes the expected assertion failure:' print * #endif !call_assert(1+1>2) !call_assert_describe(1+1>2, "Mathematics is broken!") call_assert_diagnose(1+1>2, "example with array diagnostic data" , intrinsic_array_t([1,1,2])) ! false assertion end program invoke_via_macro assert-2.1.2/example/simple-assertions.f90000066400000000000000000000023361503157704400204630ustar00rootroot00000000000000program assertion_examples !! Demonstrate the use of assertions as runtime checks on the satisfaction of !! of two kinds of constraints: !! 1. Preconditions: requirements for correct execution at the start of a procedure and !! 2. Postconditions: requirements for correct execution at the end of a procedure. use assert_m, only : assert use intrinsic_array_m, only : intrinsic_array_t implicit none print *, "roots: ", roots(a=1.,b=0.,c=-4.) contains pure function roots(a,b,c) result(zeros) !! Calculate the roots of a quadratic polynomial real, intent(in) :: a, b, c real zeros(2) associate(discriminant => b**2 - 4*a*c) call assert(assertion = (discriminant >= 0.), description = "roots: nonnegative discriminant", diagnostic_data = discriminant) associate(radical => sqrt(discriminant)) zeros = [-b + radical, -b - radical]/(2*a) block real, parameter :: tolerance = 1.E-06 associate(errors => a*zeros**2 + b*zeros + c) call assert(maxval(abs(errors)) < tolerance, "roots: |max(error)| > tolerance", intrinsic_array_t([errors])) end associate end block end associate end associate end function end program assert-2.1.2/fpm.toml000066400000000000000000000000521503157704400144770ustar00rootroot00000000000000name = "assert" [install] library = true assert-2.1.2/include/000077500000000000000000000000001503157704400144465ustar00rootroot00000000000000assert-2.1.2/include/assert_features.h000066400000000000000000000007411503157704400200200ustar00rootroot00000000000000#ifndef _ASSERT_FEATURES_H #define _ASSERT_FEATURES_H ! Whether or not the assert library may use multi-image features ! Default is compiler-dependent #ifndef ASSERT_MULTI_IMAGE # if defined(__flang__) || defined(__INTEL_COMPILER) # define ASSERT_MULTI_IMAGE 0 # else # define ASSERT_MULTI_IMAGE 1 # endif #endif ! Whether the library should use client callbacks for parallel features #ifndef ASSERT_PARALLEL_CALLBACKS #define ASSERT_PARALLEL_CALLBACKS 0 #endif #endif assert-2.1.2/include/assert_macros.h000066400000000000000000000026101503157704400174630ustar00rootroot00000000000000! assert_macros.h: provides preprocessor-based assertion macros ! that are guaranteed to compile away statically when disabled. ! Enable repeated includes to toggle assertions based on current settings: #undef call_assert #undef call_assert_describe #undef call_assert_diagnose #ifndef ASSERTIONS ! Assertions are off by default #define ASSERTIONS 0 #endif ! Deal with stringification issues: ! https://gcc.gnu.org/legacy-ml/fortran/2009-06/msg00131.html #ifndef CPP_STRINGIFY_SOURCE # if defined(__GFORTRAN__) || defined(_CRAYFTN) || defined(NAGFOR) # define CPP_STRINGIFY_SOURCE(x) "x" # else # define CPP_STRINGIFY_SOURCE(x) #x # endif #endif #if ASSERTIONS # define call_assert(assertion) call assert_always(assertion, "call_assert(" // CPP_STRINGIFY_SOURCE(assertion) // ") in file " // __FILE__ // ", line " // fortran_stringify_integer(__LINE__)) # define call_assert_describe(assertion, description) call assert_always(assertion, description // " in file " // __FILE__ // ", line " // fortran_stringify_integer(__LINE__)) # define call_assert_diagnose(assertion, description, diagnostic_data) call assert_always(assertion, description // " in file " // __FILE__ // ", line " // fortran_stringify_integer(__LINE__), diagnostic_data) #else # define call_assert(assertion) # define call_assert_describe(assertion, description) # define call_assert_diagnose(assertion, description, diagnostic_data) #endif assert-2.1.2/src/000077500000000000000000000000001503157704400136125ustar00rootroot00000000000000assert-2.1.2/src/assert/000077500000000000000000000000001503157704400151135ustar00rootroot00000000000000assert-2.1.2/src/assert/assert_subroutine_m.F90000066400000000000000000000070701503157704400214730ustar00rootroot00000000000000! (c) 2024-2025 UC Regents, see LICENSE file for detailed terms. ! ! (c) 2019-2020 Guide Star Engineering, LLC ! This Software was developed for the US Nuclear Regulatory Commission (US NRC) under contract ! "Multi-Dimensional Physics Implementation into Fuel Analysis under Steady-state and Transients (FAST)", ! contract # NRC-HQ-60-17-C-0007 ! #include "assert_macros.h" module assert_subroutine_m !! summary: Utility for runtime enforcement of logical assertions. !! usage: error-terminate if the assertion fails: !! !! use assertions_m, only : assert !! call assert( 2 > 1, "2 > 1") !! !! Assertion enforcement is controlled via the `ASSERTIONS` preprocessor macro, !! which can be defined to non-zero or zero at compilation time to !! respectively enable or disable runtime assertion enforcement. !! !! When the `ASSERTIONS` preprocessor macro is not defined to any value, !! the default is that assertions are *disabled* and will not check the condition. !! !! Disabling assertion enforcement may eliminate any associated runtime !! overhead by enabling optimizing compilers to ignore the assertion procedure !! body during a dead-code-removal phase of optimization. !! !! To enable assertion enforcement (e.g., for a debug build), define the preprocessor ASSERTIONS to non-zero. !! This file's capitalized .F90 extension causes most Fortran compilers to preprocess this file so !! that building as follows enables assertion enforcement: !! !! fpm build --flag "-DASSERTIONS" !! implicit none private public :: assert, assert_always #if ASSERT_PARALLEL_CALLBACKS public :: assert_this_image_interface, assert_this_image public :: assert_error_stop_interface, assert_error_stop abstract interface pure function assert_this_image_interface() result(this_image_id) implicit none integer :: this_image_id end function end interface procedure(assert_this_image_interface), pointer :: assert_this_image abstract interface pure subroutine assert_error_stop_interface(stop_code_char) implicit none character(len=*), intent(in) :: stop_code_char end subroutine end interface procedure(assert_error_stop_interface), pointer :: assert_error_stop #endif #ifndef USE_ASSERTIONS # if ASSERTIONS # define USE_ASSERTIONS .true. # else # define USE_ASSERTIONS .false. # endif #endif logical, parameter :: enforce_assertions=USE_ASSERTIONS interface pure module subroutine assert(assertion, description, diagnostic_data) !! If assertion is .false. and enforcement is enabled (e.g. via -DASSERTIONS=1), !! then error-terminate with a character stop code that contains diagnostic_data if present implicit none logical, intent(in) :: assertion !! Most assertions will be expressions such as i>0 character(len=*), intent(in) :: description !! A brief statement of what is being asserted such as "i>0" or "positive i" class(*), intent(in), optional :: diagnostic_data !! Data to include in an error ouptput: may be of an intrinsic type or a type that extends characterizable_t end subroutine pure module subroutine assert_always(assertion, description, diagnostic_data) !! Same as above but always enforces the assertion (regardless of ASSERTIONS) implicit none logical, intent(in) :: assertion character(len=*), intent(in) :: description class(*), intent(in), optional :: diagnostic_data end subroutine end interface end module assert_subroutine_m assert-2.1.2/src/assert/assert_subroutine_s.F90000066400000000000000000000060601503157704400214770ustar00rootroot00000000000000! ! (c) 2019-2020 Guide Star Engineering, LLC ! This Software was developed for the US Nuclear Regulatory Commission (US NRC) under contract ! "Multi-Dimensional Physics Implementation into Fuel Analysis under Steady-state and Transients (FAST)", ! contract # NRC-HQ-60-17-C-0007 ! #include "assert_features.h" submodule(assert_subroutine_m) assert_subroutine_s implicit none contains module procedure assert toggle_assertions: & if (enforce_assertions) then call assert_always(assertion, description, diagnostic_data) end if toggle_assertions end procedure module procedure assert_always use characterizable_m, only : characterizable_t character(len=:), allocatable :: header, trailer, message integer :: me check_assertion: & if (.not. assertion) then #if ASSERT_MULTI_IMAGE # if ASSERT_PARALLEL_CALLBACKS me = assert_this_image() # else me = this_image() # endif header = 'Assertion "' // description // '" failed on image ' // string(me) #else header = 'Assertion "' // description // '" failed.' me = 0 ! avoid a harmless warning #endif represent_diagnostics_as_string: & if (.not. present(diagnostic_data)) then trailer = "" else select type(diagnostic_data) type is(character(len=*)) trailer = diagnostic_data type is(complex) trailer = string(diagnostic_data) type is(integer) trailer = string(diagnostic_data) type is(logical) trailer = string(diagnostic_data) type is(real) trailer = string(diagnostic_data) class is(characterizable_t) trailer = diagnostic_data%as_character() class default trailer = "of unsupported type." end select trailer = ' with diagnostic data "' // trailer // '"' end if represent_diagnostics_as_string message = header // trailer #if ASSERT_PARALLEL_CALLBACKS call assert_error_stop(message) #else error stop message, QUIET=.false. #endif end if check_assertion contains pure function string(numeric) result(number_as_string) !! Result is a string represention of the numeric argument class(*), intent(in) :: numeric integer, parameter :: max_len=128 character(len=max_len) :: untrimmed_string character(len=:), allocatable :: number_as_string select type(numeric) type is(complex) write(untrimmed_string, *) numeric type is(integer) write(untrimmed_string, *) numeric type is(logical) write(untrimmed_string, *) numeric type is(real) write(untrimmed_string, *) numeric class default error stop "Internal error in subroutine 'assert': unsupported type in function 'string'." end select number_as_string = trim(adjustl(untrimmed_string)) end function string end procedure end submodule assert_subroutine_s assert-2.1.2/src/assert/characterizable_m.f90000066400000000000000000000011241503157704400210700ustar00rootroot00000000000000module characterizable_m !! Define an abstract class that supports object representation in character form implicit none private public :: characterizable_t type, abstract :: characterizable_t contains procedure(as_character_i), deferred :: as_character end type abstract interface pure function as_character_i(self) result(character_self) import characterizable_t implicit none class(characterizable_t), intent(in) :: self character(len=:), allocatable :: character_self end function end interface end module characterizable_m assert-2.1.2/src/assert/fortran_stringify_integer_m.f90000066400000000000000000000006661503157704400232450ustar00rootroot00000000000000module fortran_stringify_integer_m implicit none contains pure function fortran_stringify_integer(number) result(number_as_string) integer, intent(in) :: number integer, parameter :: max_len=128 character(len=max_len) :: untrimmed_string character(len=:), allocatable :: number_as_string write(untrimmed_string, '(i0)') number number_as_string = trim(adjustl(untrimmed_string)) end function end module assert-2.1.2/src/assert/intrinsic_array_m.F90000066400000000000000000000055341503157704400211160ustar00rootroot00000000000000module intrinsic_array_m !! Define an abstract class that supports object representation in character form use characterizable_m, only : characterizable_t implicit none private public :: intrinsic_array_t type, extends(characterizable_t) :: intrinsic_array_t complex, allocatable :: complex_1D(:) complex(kind(1.D0)), allocatable :: complex_double_1D(:) integer, allocatable :: integer_1D(:) logical, allocatable :: logical_1D(:) real, allocatable :: real_1D(:) double precision, allocatable :: double_precision_1D(:) complex, allocatable :: complex_2D(:,:) complex(kind(1.D0)), allocatable :: complex_double_2D(:,:) integer, allocatable :: integer_2D(:,:) logical, allocatable :: logical_2D(:,:) real, allocatable :: real_2D(:,:) double precision, allocatable :: double_precision_2D(:,:) complex, allocatable :: complex_3D(:,:,:) complex(kind(1.D0)), allocatable :: complex_double_3D(:,:,:) integer, allocatable :: integer_3D(:,:,:) logical, allocatable :: logical_3D(:,:,:) real, allocatable :: real_3D(:,:,:) double precision, allocatable :: double_precision_3D(:,:,:) contains procedure :: as_character end type interface intrinsic_array_t #ifndef _CRAYFTN pure module function construct(array) result(intrinsic_array) implicit none class(*), intent(in) :: array(..) type(intrinsic_array_t) intrinsic_array end function #else pure module function complex_array(array) result(intrinsic_array) implicit none complex, intent(in) :: array(..) type(intrinsic_array_t) intrinsic_array end function pure module function integer_array(array) result(intrinsic_array) implicit none integer, intent(in) :: array(..) type(intrinsic_array_t) intrinsic_array end function pure module function logical_array(array) result(intrinsic_array) implicit none logical, intent(in) :: array(..) type(intrinsic_array_t) intrinsic_array end function pure module function real_array(array) result(intrinsic_array) implicit none real, intent(in) :: array(..) type(intrinsic_array_t) intrinsic_array end function pure module function double_precision_array(array) result(intrinsic_array) implicit none double precision, intent(in) :: array(..) type(intrinsic_array_t) intrinsic_array end function #endif end interface interface pure module function as_character(self) result(character_self) implicit none class(intrinsic_array_t), intent(in) :: self character(len=:), allocatable :: character_self end function end interface end module intrinsic_array_m assert-2.1.2/src/assert/intrinsic_array_s.F90000066400000000000000000000216211503157704400211170ustar00rootroot00000000000000submodule(intrinsic_array_m) intrinsic_array_s use assert_m, only : assert implicit none contains #ifndef _CRAYFTN module procedure construct select rank(array) rank(1) select type(array) type is(complex) allocate(intrinsic_array%complex_1D, source = array) type is(complex(kind(1.D0))) allocate(intrinsic_array%complex_double_1D, source = array) type is(integer) allocate(intrinsic_array%integer_1D, source = array) type is(logical) allocate(intrinsic_array%logical_1D, source = array) type is(real) allocate(intrinsic_array%real_1D, source = array) type is(double precision) intrinsic_array%double_precision_1D = array class default error stop "intrinsic_array_s(construct): unsupported rank-1 type" end select rank(2) select type(array) type is(complex) allocate(intrinsic_array%complex_2D, source = array) type is(complex(kind(1.D0))) allocate(intrinsic_array%complex_double_2D, source = array) type is(integer) allocate(intrinsic_array%integer_2D, source = array) type is(logical) allocate(intrinsic_array%logical_2D, source = array) type is(real) allocate(intrinsic_array%real_2D, source = array) type is(double precision) allocate(intrinsic_array%double_precision_2D, source = array) class default error stop "intrinsic_array_s(construct): unsupported rank-2 type" end select rank(3) select type(array) type is(complex) allocate(intrinsic_array%complex_3D, source = array) type is(complex(kind(1.D0))) allocate(intrinsic_array%complex_double_3D, source = array) type is(integer) allocate(intrinsic_array%integer_3D, source = array) type is(logical) allocate(intrinsic_array%logical_3D, source = array) type is(real) allocate(intrinsic_array%real_3D, source = array) type is(double precision) allocate(intrinsic_array%double_precision_3D, source = array) class default error stop "intrinsic_array_s(construct): unsupported rank-3 type" end select rank default error stop "intrinsic_array_s(construct): unsupported rank" end select end procedure #else module procedure complex_array select rank(array) rank(1) allocate(intrinsic_array%complex_1D, source = array) rank(2) allocate(intrinsic_array%complex_2D, source = array) rank(3) allocate(intrinsic_array%complex_3D, source = array) rank default error stop "intrinsic_array_s(complex_array): unsupported rank" end select end procedure module procedure integer_array select rank(array) rank(1) allocate(intrinsic_array%integer_1D, source = array) rank(2) allocate(intrinsic_array%integer_2D, source = array) rank(3) allocate(intrinsic_array%integer_3D, source = array) rank default error stop "intrinsic_array_s(integer_array): unsupported rank" end select end procedure module procedure logical_array select rank(array) rank(1) allocate(intrinsic_array%logical_1D, source = array) rank(2) allocate(intrinsic_array%logical_2D, source = array) rank(3) allocate(intrinsic_array%logical_3D, source = array) rank default error stop "intrinsic_array_s(logical_array): unsupported rank" end select end procedure module procedure real_array select rank(array) rank(1) allocate(intrinsic_array%real_1D, source = array) rank(2) allocate(intrinsic_array%real_2D, source = array) rank(3) allocate(intrinsic_array%real_3D, source = array) rank default error stop "intrinsic_array_s(real_array): unsupported rank" end select end procedure module procedure double_precision_array select rank(array) rank(1) allocate(intrinsic_array%double_precision_1D, source = array) rank(2) allocate(intrinsic_array%double_precision_2D, source = array) rank(3) allocate(intrinsic_array%double_precision_3D, source = array) rank default error stop "intrinsic_array_s(double_precision_array): unsupported rank" end select end procedure #endif pure function allocated_components(self) type(intrinsic_array_t), intent(in) :: self logical, allocatable :: allocated_components(:) allocated_components = [ & allocated(self%complex_1D), allocated(self%real_1D), allocated(self%integer_1D), allocated(self%complex_double_1D) & ,allocated(self%complex_2D), allocated(self%real_2D), allocated(self%integer_2D), allocated(self%complex_double_2D) & ,allocated(self%complex_3D), allocated(self%real_3D), allocated(self%integer_3D), allocated(self%complex_double_3D) & ,allocated(self%logical_1D), allocated(self%double_precision_1D) & ,allocated(self%logical_2D), allocated(self%double_precision_2D) & ,allocated(self%logical_3D), allocated(self%double_precision_3D) & ] end function module procedure as_character integer, parameter :: single_number_width=64 associate(a => allocated_components(self)) call assert(count(a) == 1, "intrinsic_array_s(as_character): invalid number of allocated components", intrinsic_array_t(a)) end associate if (allocated(self%complex_1D)) then character_self = repeat(" ", ncopies = single_number_width*size(self%complex_1D)) write(character_self, *) self%complex_1D else if (allocated(self%complex_double_1D)) then character_self = repeat(" ", ncopies = single_number_width*size(self%complex_double_1D)) write(character_self, *) self%complex_double_1D else if (allocated(self%integer_1D)) then character_self = repeat(" ", ncopies = single_number_width*size(self%integer_1D)) write(character_self, *) self%integer_1D else if (allocated(self%logical_1D)) then character_self = repeat(" ", ncopies = single_number_width*size(self%logical_1D)) write(character_self, *) self%logical_1D else if (allocated(self%real_1D)) then character_self = repeat(" ", ncopies = single_number_width*size(self%real_1D)) write(character_self, *) self%real_1D else if (allocated(self%double_precision_1D)) then character_self = repeat(" ", ncopies = single_number_width*size(self%double_precision_1D)) write(character_self, *) self%double_precision_1D else if (allocated(self%complex_2D)) then character_self = repeat(" ", ncopies = single_number_width*size(self%complex_2D)) write(character_self, *) self%complex_2D else if (allocated(self%complex_double_2D)) then character_self = repeat(" ", ncopies = single_number_width*size(self%complex_double_2D)) write(character_self, *) self%complex_double_2D else if (allocated(self%integer_2D)) then character_self = repeat(" ", ncopies = single_number_width*size(self%integer_2D)) write(character_self, *) self%integer_2D else if (allocated(self%logical_2D)) then character_self = repeat(" ", ncopies = single_number_width*size(self%logical_2D)) write(character_self, *) self%logical_2D else if (allocated(self%real_2D)) then character_self = repeat(" ", ncopies = single_number_width*size(self%real_2D)) write(character_self, *) self%real_2D else if (allocated(self%double_precision_2D)) then character_self = repeat(" ", ncopies = single_number_width*size(self%double_precision_2D)) write(character_self, *) self%double_precision_2D else if (allocated(self%complex_3D)) then character_self = repeat(" ", ncopies = single_number_width*size(self%complex_3D)) write(character_self, *) self%complex_3D else if (allocated(self%complex_double_3D)) then character_self = repeat(" ", ncopies = single_number_width*size(self%complex_double_3D)) write(character_self, *) self%complex_double_3D else if (allocated(self%integer_3D)) then character_self = repeat(" ", ncopies = single_number_width*size(self%integer_3D)) write(character_self, *) self%integer_3D else if (allocated(self%logical_3D)) then character_self = repeat(" ", ncopies = single_number_width*size(self%logical_3D)) write(character_self, *) self%logical_3D else if (allocated(self%real_3D)) then character_self = repeat(" ", ncopies = single_number_width*size(self%real_3D)) write(character_self, *) self%real_3D else if (allocated(self%double_precision_3D)) then character_self = repeat(" ", ncopies = single_number_width*size(self%double_precision_3D)) write(character_self, *) self%double_precision_3D end if character_self = trim(adjustl(character_self)) end procedure end submodule intrinsic_array_s assert-2.1.2/src/assert_m.f90000066400000000000000000000013301503157704400157440ustar00rootroot00000000000000module assert_m !! Public interface use assert_subroutine_m ! DO NOT PLACE AN ONLY CLAUSE HERE! ! All public members of assert_subroutine_m are exported use intrinsic_array_m, only : intrinsic_array_t use characterizable_m, only : characterizable_t ! The function below is public only to support automated ! invocation via `assert_macros.h`. For a more broadly useful ! function to convert numeric data to string format, please ! consider using the functions that can be accessed via the ! `string_t` generic interface in the Julienne framework at ! https://go.lbl.gov/julienne. use fortran_stringify_integer_m, only : fortran_stringify_integer implicit none end module assert-2.1.2/test/000077500000000000000000000000001503157704400140025ustar00rootroot00000000000000assert-2.1.2/test/run-false-assertion-intel.sh000077500000000000000000000002161503157704400213520ustar00rootroot00000000000000#!/bin/bash output=$(fpm run --example false-assertion --compiler ifx --flag '-O3 -DASSERTIONS' > /dev/null 2>&1) echo $? > build/exit_status assert-2.1.2/test/run-false-assertion.sh000077500000000000000000000002571503157704400202460ustar00rootroot00000000000000#!/bin/bash output=$(fpm run --example false-assertion --compiler flang-new --flag '-mmlir -allow-assumed-rank -O3 -DASSERTIONS' > /dev/null 2>&1) echo $? > build/exit_status assert-2.1.2/test/test-assert-macro.F90000066400000000000000000000063001503157704400176360ustar00rootroot00000000000000program test_assert_macros use assert_m implicit none print * print *,"The call_assert macro" #undef ASSERTIONS #define ASSERTIONS 1 #include "assert_macros.h" call_assert(1==1) print *," passes on not error-terminating when an assertion expression evaluating to .true. is the only argument" #undef ASSERTIONS #include "assert_macros.h" call_assert(.false.) print *," passes on being removed by the preprocessor when ASSERTIONS is undefined" // new_line('') !------------------------------------------ print *,"The call_assert_describe macro" #undef ASSERTIONS #define ASSERTIONS 1 #include "assert_macros.h" call_assert_describe(.true., ".true.") print *," passes on not error-terminating when assertion = .true. and a description is present" #undef ASSERTIONS #include "assert_macros.h" call_assert_describe(.false., "") print *," passes on being removed by the preprocessor when ASSERTIONS is undefined" // new_line('') !------------------------------------------ print *,"The call_assert_diagnose macro" #undef ASSERTIONS #define ASSERTIONS 1 #include "assert_macros.h" call_assert_diagnose(.true., ".true.", diagnostic_data=1) print *," passes on not error-terminating when assertion = .true. and description and diagnostic_data are present" block integer :: computed_checksum = 37, expected_checksum = 37 #if defined(_CRAYFTN) ! Cray Fortran uses different line continuations in macro invocations call_assert_diagnose( computed_checksum == expected_checksum, & "Checksum mismatch failure!", & expected_checksum ) print *," passes with macro-style line breaks" call_assert_diagnose( computed_checksum == expected_checksum, & ! ensured since version 3.14 "Checksum mismatch failure!", & ! TODO: write a better message here computed_checksum ) print *," passes with C block comments embedded in macro" #else call_assert_diagnose( computed_checksum == expected_checksum, \ "Checksum mismatch failure!", \ expected_checksum ) print *," passes with macro-style line breaks" call_assert_diagnose( computed_checksum == expected_checksum, /* ensured since version 3.14 */ \ "Checksum mismatch failure!", /* TODO: write a better message here */ \ computed_checksum ) print *," passes with C block comments embedded in macro" #endif end block #undef ASSERTIONS #include "assert_macros.h" call_assert_diagnose(.false., "", "") print *," passes on being removed by the preprocessor when ASSERTIONS is undefined" // new_line('') !------------------------------------------ #undef ASSERTIONS #define ASSERTIONS 1 #include "assert_macros.h" print *,"The call_assert_* macros" block logical :: foo foo = check_assert(.true.) print *," pass on invocation from a pure function" end block contains pure function check_assert(cond) result(ok) logical, intent(in) :: cond logical ok call_assert(cond) call_assert_describe(cond, "check_assert") call_assert_diagnose(cond, "check_assert", "") ok = .true. end function end program assert-2.1.2/test/test-assert-subroutine-error-termination.F90000066400000000000000000000045551503157704400244240ustar00rootroot00000000000000#include "assert_features.h" program test_assert_subroutine_error_termination !! Test "assert" subroutine calls that are intended to error terminate use assert_m, only : assert implicit none integer exit_status print * print *,"The assert subroutine" ! TODO: The following is a HORRIBLY fragile test. ! Specifically, it encodes a bunch of compiler-specific flags into an fpm command, ! and if fpm fails for any unrelated reason (broken command, compile error, I/O error, etc) ! we will mistakenly interpret that as a passing test! call execute_command_line( & #ifdef __GFORTRAN__ command = "fpm run --example false-assertion --profile release --flag '-DASSERTIONS -ffree-line-length-0' > /dev/null 2>&1", & #elif NAGFOR command = "fpm run --example false-assertion --compiler nagfor --flag '-DASSERTIONS -fpp' > /dev/null 2>&1", & #elif __flang__ command = "./test/run-false-assertion.sh", & #elif __INTEL_COMPILER command = "./test/run-false-assertion-intel.sh", & #elif _CRAYFTN command = "fpm run --example false-assertion --profile release --compiler crayftn.sh --flag '-DASSERTIONS' > /dev/null 2>&1", & #else command = "echo 'example/false_assertion.F90: unsupported compiler' && exit 1", & #endif wait = .true., & exitstat = exit_status & ) #if ASSERT_MULTI_IMAGE block logical error_termination error_termination = exit_status /=0 call co_all(error_termination) if (this_image()==1) then if (error_termination) then print *," passes on error-terminating when assertion = .false." else print *," FAILS to error-terminate when assertion = .false. (Yikes! Who designed this OS?)" end if end if end block #else block integer unit open(newunit=unit, file="build/exit_status", status="old") read(unit,*) exit_status print *,trim(merge("passes","FAILS ",exit_status/=0)) // " on error-terminating when assertion = .false." close(unit) end block #endif contains pure function and_operation(lhs,rhs) result(lhs_and_rhs) logical, intent(in) :: lhs, rhs logical lhs_and_rhs lhs_and_rhs = lhs .and. rhs end function #if ASSERT_MULTI_IMAGE subroutine co_all(boolean) logical, intent(inout) :: boolean call co_reduce(boolean, and_operation) end subroutine #endif end program test_assert_subroutine_error_termination assert-2.1.2/test/test-assert-subroutine-normal-termination.F90000066400000000000000000000036221503157704400245550ustar00rootroot00000000000000#include "assert_features.h" program test_assert_subroutine_normal_termination !! Test direct calls to the "assert" subroutine that don't error-terminate use assert_m, only : assert use intrinsic_array_m, only : intrinsic_array_t implicit none print * print *,"The assert subroutine" call assert(assertion = .true., description = "3 keyword arguments ", diagnostic_data=0) call assert( .true., description = "2 keyword arguments ", diagnostic_data=0) call assert( .true., "1 keyword argument ", diagnostic_data=0) call assert( .true., "0 keyword arguments ", 0) call assert( .true., "no optional argument" ) #if ASSERT_MULTI_IMAGE sync all if (this_image()==1) & #endif print *," passes on not error-terminating when assertion=.true. + combos of (non-)keyword and (non-)present optional arguments" array_1D_diagnostic_data: & block complex, parameter :: complex_1D(*) = [(1.,0.), (0.,1.)] integer, parameter :: integer_1D(*) = [1, 2] logical, parameter :: logical_1D(*) = [.true., .true.] real, parameter :: real_1D(*) = [1., 2.] call assert(all(abs(complex_1D) < 2.), "all(abs(complex_array) < 2.)", intrinsic_array_t(complex_1D)) call assert(all(integer_1D < 3 ), "all(int_array < 3 )", intrinsic_array_t(integer_1D)) call assert(all(logical_1D ), "all(logical_array )", intrinsic_array_t(logical_1D)) call assert(all(real_1D < 3.), "all(real_array < 3.)", intrinsic_array_t( real_1D)) #if ASSERT_MULTI_IMAGE sync all if (this_image()==1) & #endif print *," passes on not error-terminating when diagnostic_data = intrinsic_array_t({complex|integer|logical|real} 1D arrays)" end block array_1D_diagnostic_data end program test_assert_subroutine_normal_termination assert-2.1.2/test/test-intrinsic_array.F90000066400000000000000000000267521503157704400204530ustar00rootroot00000000000000program test_intrinsinc_array_t !! Test direct intrinsic_array_t derive type construction and conversion to srings use intrinsic_array_m, only : intrinsic_array_t implicit none integer j complex, parameter :: z = (-1., -1.) complex, parameter :: complex_1D(*) = [(z, j=1,2 )] complex, parameter :: complex_2D(*,*) = reshape([(z, j=1,2*2 )], [2, 2 ]) complex, parameter :: complex_3D(*,*,*) = reshape([(z, j=1,2*2*2)], [2, 2, 2]) complex(kind(1.D0)), parameter :: z_double = (-1.D0, -2.D0) complex(kind(z_double)), parameter :: complex_double_1D(*) = [(z_double, j=1, 2 )] complex(kind(z_double)), parameter :: complex_double_2D(*,*) = reshape([(z_double, j=1, 2*2 )], [2, 2 ]) complex(kind(z_double)), parameter :: complex_double_3D(*,*,*) = reshape([(z_double, j=1, 2*2*2)], [2, 2, 2]) integer, parameter :: integer_1D(*) = [(0, j=1,2 )] integer, parameter :: integer_2D(*,*) = reshape([(1, j=1,2*2 )], [2, 2 ]) integer, parameter :: integer_3D(*,*,*) = reshape([(2, j=1,2*2*2 )], [2, 2, 2]) logical, parameter :: logical_1D(*) = [(.true., j=1,2 )] logical, parameter :: logical_2D(*,*) = reshape([(.true., j=1,2*2 )], [2, 2 ]) logical, parameter :: logical_3D(*,*,*) = reshape([(.true., j=1,2*2*2)], [2, 2, 2]) #ifndef __flang__ if (this_image()==1) then #endif print* print*,"An intrinsic_array_t object" print*," "//pass_fail(dble(integer_1D)) //" on construction from a 1D double-precision array and conversion to a string" print*," "//pass_fail(dble(integer_2D)) //" on construction from a 2D double-precision array and conversion to a string" print*," "//pass_fail(dble(integer_3D)) //" on construction from a 3D double-precision array and conversion to a string" print*," "//pass_fail(integer_1D) //" on construction from a 1D integer array and conversion to a string" print*," "//pass_fail(integer_2D) //" on construction from a 2D integer array and conversion to a string" print*," "//pass_fail(integer_3D) //" on construction from a 3D integer array and conversion to a string" print*," "//pass_fail(logical_1D) //" on construction from a 1D logical array and conversion to a string" print*," "//pass_fail(logical_2D) //" on construction from a 2D logical array and conversion to a string" print*," "//pass_fail(logical_3D) //" on construction from a 3D logical array and conversion to a string" print*," "//pass_fail(real(integer_1D)) //" on construction from a 1D real array and conversion to a string" print*," "//pass_fail(real(integer_2D)) //" on construction from a 2D real array and conversion to a string" print*," "//pass_fail(real(integer_3D)) //" on construction from a 3D real array and conversion to a string" print*," "//pass_fail(complex_1D) //" on construction from a 1D complex array and conversion to a string" print*," "//pass_fail(complex_2D) //" on construction from a 2D complex array and conversion to a string" print*," "//pass_fail(complex_3D) //" on construction from a 3D complex array and conversion to a string" print*," "//pass_fail(complex_double_1D)//" on construction from a 1D double-precision complex array and conversion to a string" print*," "//pass_fail(complex_double_2D)//" on construction from a 2D double-precision complex array and conversion to a string" print*," "//pass_fail(complex_double_3D)//" on construction from a 3D double-precision complex array and conversion to a string" #ifndef __flang__ end if #endif contains pure function pass_fail(to_write) class(*), intent(in) :: to_write(..) character(len=:), allocatable :: pass_fail integer, parameter :: max_length = 2048 character(len=max_length) array_as_string type(intrinsic_array_t) intrinsic_array select rank(to_write) rank(1) select type(to_write) type is(complex) intrinsic_array = intrinsic_array_t(to_write) write(array_as_string,*) intrinsic_array%as_character() block complex from_read(size(to_write,1)) read(array_as_string,*) from_read pass_fail = trim(merge("passes", "FAILS ", all(from_read == to_write))) end block type is(complex(kind(0.D0))) intrinsic_array = intrinsic_array_t(to_write) write(array_as_string,*) intrinsic_array%as_character() block complex from_read(size(to_write,1)) read(array_as_string,*) from_read pass_fail = trim(merge("passes", "FAILS ", all(from_read == to_write))) end block type is(double precision) intrinsic_array = intrinsic_array_t(to_write) write(array_as_string,*) intrinsic_array%as_character() block double precision from_read(size(to_write,1)) read(array_as_string,*) from_read pass_fail = trim(merge("passes", "FAILS ", all(from_read == to_write))) end block type is(integer) intrinsic_array = intrinsic_array_t(to_write) write(array_as_string,*) intrinsic_array%as_character() block integer from_read(size(to_write,1)) read(array_as_string,*) from_read pass_fail = trim(merge("passes", "FAILS ", all(from_read == to_write))) end block type is(logical) intrinsic_array = intrinsic_array_t(to_write) write(array_as_string,*) intrinsic_array%as_character() block logical from_read(size(to_write,1)) read(array_as_string,*) from_read pass_fail = trim(merge("passes", "FAILS ", all(from_read .eqv. to_write))) end block type is(real) intrinsic_array = intrinsic_array_t(to_write) write(array_as_string, *) intrinsic_array%as_character() block real from_read(size(to_write,1)) read(array_as_string,*) from_read pass_fail = trim(merge("passes", "FAILS ", all(from_read == to_write))) end block class default error stop "test_intrinsic_array_t: unrecognized rank-1 type" end select rank(2) select type(to_write) type is(complex) intrinsic_array = intrinsic_array_t(to_write) write(array_as_string,*) intrinsic_array%as_character() block complex from_read(size(to_write,1), size(to_write,2)) read(array_as_string,*) from_read pass_fail = trim(merge("passes", "FAILS ", all(from_read == to_write))) end block type is(complex(kind(1.D0))) intrinsic_array = intrinsic_array_t(to_write) write(array_as_string,*) intrinsic_array%as_character() block complex from_read(size(to_write,1), size(to_write,2)) read(array_as_string,*) from_read pass_fail = trim(merge("passes", "FAILS ", all(from_read == to_write))) end block type is(double precision) intrinsic_array = intrinsic_array_t(to_write) write(array_as_string,*) intrinsic_array%as_character() block double precision from_read(size(to_write,1), size(to_write,2)) read(array_as_string,*) from_read pass_fail = trim(merge("passes", "FAILS ", all(from_read == to_write))) end block type is(integer) intrinsic_array = intrinsic_array_t(to_write) write(array_as_string,*) intrinsic_array%as_character() block integer from_read(size(to_write,1), size(to_write,2)) read(array_as_string,*) from_read pass_fail = trim(merge("passes", "FAILS ", all(from_read == to_write))) end block type is(logical) intrinsic_array = intrinsic_array_t(to_write) write(array_as_string,*) intrinsic_array%as_character() block logical from_read(size(to_write,1), size(to_write,2)) read(array_as_string,*) from_read pass_fail = trim(merge("passes", "FAILS ", all(from_read .eqv. to_write))) end block type is(real) intrinsic_array = intrinsic_array_t(to_write) write(array_as_string,*) intrinsic_array%as_character() block real from_read(size(to_write,1), size(to_write,2)) read(array_as_string,*) from_read pass_fail = trim(merge("passes", "FAILS ", all(from_read == to_write))) end block class default error stop "test_intrinsic_array_t: unrecognized rank-2 type" end select rank(3) select type(to_write) type is(complex) intrinsic_array = intrinsic_array_t(to_write) write(array_as_string,*) intrinsic_array%as_character() block complex from_read(size(to_write,1), size(to_write,2), size(to_write,3)) read(array_as_string,*) from_read pass_fail = trim(merge("passes", "FAILS ", all(from_read == to_write))) end block type is(complex(kind(0.D0))) intrinsic_array = intrinsic_array_t(to_write) write(array_as_string,*) intrinsic_array%as_character() block complex from_read(size(to_write,1), size(to_write,2), size(to_write,3)) read(array_as_string,*) from_read pass_fail = trim(merge("passes", "FAILS ", all(from_read == to_write))) end block type is(double precision) intrinsic_array = intrinsic_array_t(to_write) write(array_as_string,*) intrinsic_array%as_character() block double precision from_read(size(to_write,1), size(to_write,2), size(to_write,3)) read(array_as_string,*) from_read pass_fail = trim(merge("passes", "FAILS ", all(from_read == to_write))) end block type is(integer) intrinsic_array = intrinsic_array_t(to_write) write(array_as_string,*) intrinsic_array%as_character() block integer from_read(size(to_write,1), size(to_write,2), size(to_write,3)) read(array_as_string,*) from_read pass_fail = trim(merge("passes", "FAILS ", all(from_read == to_write))) end block type is(logical) intrinsic_array = intrinsic_array_t(to_write) write(array_as_string,*) intrinsic_array%as_character() block logical from_read(size(to_write,1), size(to_write,2), size(to_write,3)) read(array_as_string,*) from_read pass_fail = trim(merge("passes", "FAILS ", all(from_read .eqv. to_write))) end block type is(real) intrinsic_array = intrinsic_array_t(to_write) write(array_as_string,*) intrinsic_array%as_character() block real from_read(size(to_write,1), size(to_write,2), size(to_write,3)) read(array_as_string,*) from_read pass_fail = trim(merge("passes", "FAILS ", all(from_read == to_write))) end block class default error stop "test_intrinsic_array_t: unrecognized rank-3 type" end select rank default error stop "test_intrinsic_array_t: unsupported rank (3)" end select end function end program test_intrinsinc_array_t