diff --git a/.github/workflows/deploy-docs.yml b/.github/workflows/deploy-docs.yml index e586409..9b251eb 100644 --- a/.github/workflows/deploy-docs.yml +++ b/.github/workflows/deploy-docs.yml @@ -24,7 +24,7 @@ jobs: - name: Build Developer Documentation run: | - ford -I include doc-generator.md > ford_output.txt + ford -I include ford.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 diff --git a/README.md b/README.md index e2d847d..9503f8e 100644 --- a/README.md +++ b/README.md @@ -19,7 +19,6 @@ This assertion utility contains four public entities: 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. @@ -42,10 +41,6 @@ If instead `fpm install` is used, then either the user must copy `include/assert 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 @@ -63,27 +58,49 @@ The requirements and assurances might be constraints of three kinds: 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 -------------------------------------------- +Running the Examples +-------------------- +See the [./example](./example) subdirectory. + +Building and Testing +-------------------- + +- [Cray Compiler Environment (CCE) `ftn`](#cray-compiler-environment-cce-ftn) +- [GNU Compiler Collection (GCC) `gfortran`](#gnu-compiler-collection-gcc-gfortran)) +- [Intel `ifx`](#intel-ifx)) +- [LFortran `lfortran`](#lfortran-lfortran) +- [LLVM `flang-new`](#llvm-flang-new) +- [Numerical Algorithms Group (NAG) `nagfor`](#numerical-algorithms-group-nag-nagfor) + +### Cray Compiler Environment (CCE) `ftn` +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 -### Downloading Assert +ftn $@ ``` -git clone git@github.com:berkeleylab/assert -cd assert +Then build and test Assert with the command +``` +fpm test --compiler crayftn.sh --profile release ``` -### Building and testing with `gfortran` +### GNU Compiler Collection (GCC) `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 +With `gfortran` 14 or later, use ``` fpm test --profile release ``` -For `gfortran` 13 or earlier, use +With `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 ``` @@ -93,60 +110,56 @@ 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 +### Intel `ifx` + #### 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 +### LLVM `flang-new` + +#### Single-image (serial) execution +With `flang-new` version 19, use ``` fpm test --compiler flang-new --flag "-mmlir -allow-assumed-rank -O3" ``` -#### LLVM version 20 or later +With `flang-new` version 20 or later, use ``` fpm test --compiler flang-new --flag "-O3" ``` -### Building and testing with the Numerical Algorithms Group (NAG) compiler +### LFortran `lfortran` + +#### Single-image (serial) execution ``` -fpm test --compiler nagfor --profile release --flag "-fpp -coarray=cosmp" +fpm test --compiler lfortran --profile release --flag --cpp ``` -### 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: +### Numerical Algorithms Group (NAG) `nagfor` + +#### Single-image (serial) execution +With `nagfor` version 7.1 or later, use +``` +fpm test --compiler nagfor --flag -fpp ``` -#!/bin/bash -ftn $@ +#### Multi-image execution +With `nagfor` 7.1, use ``` -Then build and test Assert with the command +fpm test --compiler nagfor --profile release --flag "-fpp -coarray=cosmp -f2018" ``` -fpm test --compiler crayftn.sh --profile release +With `nagfor` 7.2 or later, use +``` +fpm test --compiler nagfor --flag -fpp ``` - - -### 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 ------------- @@ -208,9 +221,9 @@ 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 ) +call_assert_describe( computed_checksum == expected_checksum, \ + "Checksum mismatch failure!" \ + ) ``` Whereas Cray Fortran wants `&` line continuation characters, even inside @@ -218,9 +231,9 @@ a macro invocation: ```fortran ! OK for Cray Fortran -call_assert_diagnose( computed_checksum == expected_checksum, & - "Checksum mismatch failure!", & - expected_checksum ) +call_assert_describe( computed_checksum == expected_checksum, & + "Checksum mismatch failure!" & + ) ``` There appears to be no syntax acceptable to all compilers, so when writing @@ -237,9 +250,9 @@ 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 ) +call_assert_describe( computed_checksum == expected_checksum, ! ensured since version 3.14 + "Checksum mismatch failure!" ! TODO: write a better message here + ) ``` Depending on your compiler it *might* be possible to use a C-style block @@ -247,9 +260,9 @@ 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 ) +call_assert_describe( computed_checksum == expected_checksum, /* ensured since version 3.14 */ \ + "Checksum mismatch failure!" /* TODO: write a better message here */ \ + ) ``` However that capability might not be portable to other Fortran compilers. @@ -257,9 +270,9 @@ 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 +call_assert_describe( computed_checksum == expected_checksum, \ + "Checksum mismatch failure!" \ + ) ! TODO: write a better message above ``` Legal Information diff --git a/doc/assert_class_diagram.puml b/doc/assert_class_diagram.puml deleted file mode 100644 index 856bf4c..0000000 --- a/doc/assert_class_diagram.puml +++ /dev/null @@ -1,21 +0,0 @@ -@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 diff --git a/doc/example_class_diagram.puml b/doc/example_class_diagram.puml deleted file mode 100644 index 741248c..0000000 --- a/doc/example_class_diagram.puml +++ /dev/null @@ -1,29 +0,0 @@ -@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 diff --git a/example/README.md b/example/README.md index 8a7a096..8891d9a 100644 --- a/example/README.md +++ b/example/README.md @@ -10,59 +10,18 @@ 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" +has changed since the most recent build. If `assert` is working correctly, the `fpm run` above +will error-terminate with the character stop code similar to the following ``` -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)" +Assertion failure on image 1: reciprocal: abs(error) < tolerance ``` ### Multi-image execution with `gfortran` and OpenCoarrays @@ -70,22 +29,15 @@ Assertion "stuff_t%z(): self%defined()" failed on image 1 with diagnostic data " 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 diff --git a/example/derived-type_diagnostic.F90 b/example/derived-type_diagnostic.F90 deleted file mode 100644 index 4d5feab..0000000 --- a/example/derived-type_diagnostic.F90 +++ /dev/null @@ -1,152 +0,0 @@ -module 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 diff --git a/example/invoke-via-macro.F90 b/example/invoke-via-macro.F90 index d4dc895..9ee3fd1 100644 --- a/example/invoke-via-macro.F90 +++ b/example/invoke-via-macro.F90 @@ -23,14 +23,12 @@ program invoke_via_macro 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 + !call_assert(1+1>2) ! example false assertion without description + call_assert_describe(1+1>2, "Mathematics is broken!") ! false assertion with description end program invoke_via_macro diff --git a/example/simple-assertions.f90 b/example/simple-assertions.f90 index 8925847..da9dfd7 100644 --- a/example/simple-assertions.f90 +++ b/example/simple-assertions.f90 @@ -4,7 +4,6 @@ program assertion_examples !! 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.) @@ -14,24 +13,15 @@ program assertion_examples pure function roots(a,b,c) result(zeros) !! Calculate the roots of a quadratic polynomial real, intent(in) :: a, b, c - real zeros(2) + real, allocatable :: zeros(:) + real, parameter :: tolerance = 1E-06 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 + call assert(assertion = discriminant >= 0., description = "discriminant >= 0") ! precondition + zeros = -b + [sqrt(discriminant), -sqrt(discriminant)] end associate + call assert(all(abs(a*zeros**2 + b*zeros + c) < tolerance), "All residuals within tolerance.") ! postcondition end function end program diff --git a/doc-generator.md b/ford.md similarity index 100% rename from doc-generator.md rename to ford.md diff --git a/include/assert_features.h b/include/assert_features.h index d8ccdc1..f5bd4e5 100644 --- a/include/assert_features.h +++ b/include/assert_features.h @@ -4,7 +4,7 @@ ! 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) +# if defined(__flang__) || defined(__INTEL_COMPILER) || defined(__LFORTRAN__) # define ASSERT_MULTI_IMAGE 0 # else # define ASSERT_MULTI_IMAGE 1 diff --git a/include/assert_macros.h b/include/assert_macros.h index 43ee1a5..ba32723 100644 --- a/include/assert_macros.h +++ b/include/assert_macros.h @@ -4,7 +4,6 @@ ! 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 @@ -14,7 +13,7 @@ ! 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) +# if defined(__GFORTRAN__) || defined(_CRAYFTN) || defined(NAGFOR) || defined(__LFORTRAN__) # define CPP_STRINGIFY_SOURCE(x) "x" # else # define CPP_STRINGIFY_SOURCE(x) #x @@ -24,9 +23,7 @@ #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 diff --git a/src/assert/assert_subroutine_m.F90 b/src/assert/assert_subroutine_m.F90 index 5e2d7ae..8fd0a68 100644 --- a/src/assert/assert_subroutine_m.F90 +++ b/src/assert/assert_subroutine_m.F90 @@ -7,6 +7,8 @@ ! #include "assert_macros.h" +#include "assert_features.h" + module assert_subroutine_m !! summary: Utility for runtime enforcement of logical assertions. !! usage: error-terminate if the assertion fails: @@ -66,28 +68,61 @@ pure subroutine assert_error_stop_interface(stop_code_char) #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 +contains + + pure subroutine assert(assertion, description) + !! If assertion is .false. and enforcement is enabled (e.g. via -DASSERTIONS=1), + !! then error-terminate with a character stop code that contains the description argument 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) + toggle_assertions: & + if (enforce_assertions) then + call assert_always(assertion, description) + end if toggle_assertions + + end subroutine + + pure subroutine assert_always(assertion, description) !! 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 + character(len=:), allocatable :: message + integer me - end interface + check_assertion: & + if (.not. assertion) then + +#if ASSERT_MULTI_IMAGE +# if ASSERT_PARALLEL_CALLBACKS + me = assert_this_image() +# else + me = this_image() +# endif + block + character(len=128) image_number + write(image_number, *) me + message = 'Assertion failure on image ' // trim(adjustl(image_number)) // ':' // description + end block +#else + message = 'Assertion failure: ' // description + me = 0 ! avoid a harmless warning +#endif + +#if ASSERT_PARALLEL_CALLBACKS + call assert_error_stop(message) +#else + error stop message, QUIET=.false. +#endif + + end if check_assertion + + end subroutine end module assert_subroutine_m + diff --git a/src/assert/assert_subroutine_s.F90 b/src/assert/assert_subroutine_s.F90 deleted file mode 100644 index 159693a..0000000 --- a/src/assert/assert_subroutine_s.F90 +++ /dev/null @@ -1,110 +0,0 @@ -! -! (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 diff --git a/src/assert/characterizable_m.f90 b/src/assert/characterizable_m.f90 deleted file mode 100644 index f335348..0000000 --- a/src/assert/characterizable_m.f90 +++ /dev/null @@ -1,24 +0,0 @@ -module 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 diff --git a/src/assert/intrinsic_array_m.F90 b/src/assert/intrinsic_array_m.F90 deleted file mode 100644 index 339c22c..0000000 --- a/src/assert/intrinsic_array_m.F90 +++ /dev/null @@ -1,90 +0,0 @@ -module 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 diff --git a/src/assert/intrinsic_array_s.F90 b/src/assert/intrinsic_array_s.F90 deleted file mode 100644 index 9a7bd01..0000000 --- a/src/assert/intrinsic_array_s.F90 +++ /dev/null @@ -1,227 +0,0 @@ -submodule(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 diff --git a/src/assert_m.f90 b/src/assert_m.f90 index 14aeb81..f9b75cb 100644 --- a/src/assert_m.f90 +++ b/src/assert_m.f90 @@ -2,8 +2,6 @@ module 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 diff --git a/test/test-assert-macro.F90 b/test/test-assert-macro.F90 index 609377b..633cc5e 100644 --- a/test/test-assert-macro.F90 +++ b/test/test-assert-macro.F90 @@ -3,89 +3,81 @@ program test_assert_macros implicit none print * - print *,"The call_assert macro" + print '(a)',"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" + print '(a)'," 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 '(a)'," passes on being removed by the preprocessor when ASSERTIONS is undefined" // new_line('') !------------------------------------------ - print *,"The call_assert_describe macro" + print '(a)',"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" + print '(a)'," 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 '(a)'," 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" + print '(a)',"The call_assert_* macros" + block + logical :: foo + foo = check_assert(.true.) + print '(a)'," pass on invocation from a pure function" + end block + !------------------------------------------ #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" + ! The following examples are taken from README.md and should be kept in sync with that document: block integer :: computed_checksum = 37, expected_checksum = 37 -#if defined(_CRAYFTN) +#if defined(_CRAYFTN) || defined(__LFORTRAN__) ! 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" + call_assert_describe( computed_checksum == expected_checksum, & + "Checksum mismatch failure!" & + ) + print *," passes with line breaks inside macro invocation" + + call_assert_describe( computed_checksum == expected_checksum, & ! ensured since version 3.14 + "Checksum mismatch failure!" & ! TODO: write a better message here + ) + print *," passes with C block comments embedded in macro invocation" #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" + call_assert_describe( computed_checksum == expected_checksum, \ + "Checksum mismatch failure!" \ + ) + print *," passes with line breaks inside macro invocation" + + call_assert_describe( computed_checksum == expected_checksum, /* ensured since version 3.14 */ \ + "Checksum mismatch failure!" /* TODO: write a better message here */ \ + ) + print *," passes with C block comments embedded in macro invocation" #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) @@ -94,7 +86,6 @@ pure function check_assert(cond) result(ok) call_assert(cond) call_assert_describe(cond, "check_assert") - call_assert_diagnose(cond, "check_assert", "") ok = .true. end function diff --git a/test/test-assert-subroutine-error-termination.F90 b/test/test-assert-subroutine-error-termination.F90 index 07ac2d3..b7386ea 100644 --- a/test/test-assert-subroutine-error-termination.F90 +++ b/test/test-assert-subroutine-error-termination.F90 @@ -7,8 +7,15 @@ program test_assert_subroutine_error_termination integer exit_status - print * - print *,"The assert subroutine" +#if ASSERT_MULTI_IMAGE + if (this_image()==1) then +#endif + + print *, new_line(''), "The assert subroutine" + +#if ASSERT_MULTI_IMAGE + end if +#endif ! TODO: The following is a HORRIBLY fragile test. ! Specifically, it encodes a bunch of compiler-specific flags into an fpm command, @@ -22,54 +29,41 @@ program test_assert_subroutine_error_termination command = "fpm run --example false-assertion --compiler nagfor --flag '-DASSERTIONS -fpp' > /dev/null 2>&1", & #elif __flang__ command = "./test/run-false-assertion.sh", & +# define RESULT_FROM_FILE 1 #elif __INTEL_COMPILER command = "./test/run-false-assertion-intel.sh", & +# define RESULT_FROM_FILE 1 #elif _CRAYFTN command = "fpm run --example false-assertion --profile release --compiler crayftn.sh --flag '-DASSERTIONS' > /dev/null 2>&1", & +#elif __LFORTRAN__ + command = "fpm run --example false-assertion --profile release --flag '-DASSERTIONS -ffree-line-length-0' > /dev/null 2>&1", & #else + ! All other compilers need their command manually validated and added to the list above 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 +#if RESULT_FROM_FILE + ! some compilers don't provide a reliable exitstat for the command above, + ! so for those we write it to a file and retrieve it here + 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 + 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 + exit_status = abs(exit_status) + call co_max(exit_status) + if (this_image()==1) then + print *,trim(merge("passes","FAILS ",exit_status/=0)) // " on error-terminating when assertion = .false." + end if +#else + print *,trim(merge("passes","FAILS ",exit_status/=0)) // " on error-terminating when assertion = .false." #endif end program test_assert_subroutine_error_termination diff --git a/test/test-assert-subroutine-normal-termination.F90 b/test/test-assert-subroutine-normal-termination.F90 index e647e19..6c51d3c 100644 --- a/test/test-assert-subroutine-normal-termination.F90 +++ b/test/test-assert-subroutine-normal-termination.F90 @@ -3,41 +3,28 @@ 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) & + if (this_image()==1) then #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)) + print *, new_line(''), "The assert subroutine" #if ASSERT_MULTI_IMAGE - sync all - if (this_image()==1) & + end if + sync all #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 + call assert(assertion = .true., description = "2 keyword arguments") + call assert( .true., description = "1 keyword arguments") + call assert( .true., "0 keyword arguments") -end program test_assert_subroutine_normal_termination +#if ASSERT_MULTI_IMAGE + sync all + if (this_image()==1) then +#endif + print *," passes on not error-terminating when assertion=.true." +#if ASSERT_MULTI_IMAGE + end if +#endif + +end program diff --git a/test/test-intrinsic_array.F90 b/test/test-intrinsic_array.F90 deleted file mode 100644 index bc55159..0000000 --- a/test/test-intrinsic_array.F90 +++ /dev/null @@ -1,226 +0,0 @@ -program 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