From 8d09902f8ab324b254e871caf06cf990736f52d3 Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Sun, 15 Jun 2025 16:16:27 -0700 Subject: [PATCH 01/14] feat: rm diagnostic_data arg & related types This commit 1. Removes the diagnostic_data argument from the assert subroutine 2. Removes the types that existed solely to support that argument: a. characterizable_t b. intrinsic_array_t 3. Edits or deletes examples that referenced the removed entities 4. Edits or deletes documentation that referenced removed entities --- .github/workflows/deploy-docs.yml | 2 +- README.md | 35 ++- doc/assert_class_diagram.puml | 21 -- doc/example_class_diagram.puml | 29 --- example/README.md | 54 +---- example/derived-type_diagnostic.F90 | 152 ------------ example/invoke-via-macro.F90 | 6 +- example/simple-assertions.f90 | 20 +- doc-generator.md => ford.md | 0 include/assert_features.h | 2 +- include/assert_macros.h | 3 - src/assert/assert_subroutine_m.F90 | 11 +- src/assert/assert_subroutine_s.F90 | 41 +--- src/assert/characterizable_m.f90 | 24 -- src/assert/intrinsic_array_m.F90 | 90 ------- src/assert/intrinsic_array_s.F90 | 227 ------------------ src/assert_m.f90 | 2 - test/test-assert-macro.F90 | 60 +---- ...t-assert-subroutine-normal-termination.F90 | 33 +-- test/test-intrinsic_array.F90 | 226 ----------------- 20 files changed, 49 insertions(+), 989 deletions(-) delete mode 100644 doc/assert_class_diagram.puml delete mode 100644 doc/example_class_diagram.puml delete mode 100644 example/derived-type_diagnostic.F90 rename doc-generator.md => ford.md (100%) delete mode 100644 src/assert/characterizable_m.f90 delete mode 100644 src/assert/intrinsic_array_m.F90 delete mode 100644 src/assert/intrinsic_array_s.F90 delete mode 100644 test/test-intrinsic_array.F90 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..b23c22e 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 @@ -208,9 +203,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 +213,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 +232,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 +242,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 +252,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..913d775 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 @@ -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..cdaadfe 100644 --- a/src/assert/assert_subroutine_m.F90 +++ b/src/assert/assert_subroutine_m.F90 @@ -68,24 +68,21 @@ pure subroutine assert_error_stop_interface(stop_code_char) 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 + pure module 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) + pure module 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 end interface diff --git a/src/assert/assert_subroutine_s.F90 b/src/assert/assert_subroutine_s.F90 index 159693a..d73901f 100644 --- a/src/assert/assert_subroutine_s.F90 +++ b/src/assert/assert_subroutine_s.F90 @@ -16,16 +16,14 @@ toggle_assertions: & if (enforce_assertions) then - call assert_always(assertion, description, diagnostic_data) + call assert_always(assertion, description) end if toggle_assertions end procedure module procedure assert_always - use characterizable_m, only : characterizable_t - - character(len=:), allocatable :: header, trailer, message - integer :: me + character(len=:), allocatable :: message + integer me check_assertion: & if (.not. assertion) then @@ -36,41 +34,12 @@ # else me = this_image() # endif - header = 'Assertion "' // description // '" failed on image ' // string(me) + message = 'Assertion failure on image ' // string(me) // ':' // description #else - header = 'Assertion "' // description // '" failed.' + message = 'Assertion failure: ' // description 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 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..1ab1a4d 100644 --- a/test/test-assert-macro.F90 +++ b/test/test-assert-macro.F90 @@ -3,87 +3,44 @@ 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 *,"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('') + print '(a)'," 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" + print '(a)',"The call_assert_* macros" block logical :: foo foo = check_assert(.true.) - print *," pass on invocation from a pure function" + print '(a)'," pass on invocation from a pure function" end block contains @@ -94,7 +51,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-normal-termination.F90 b/test/test-assert-subroutine-normal-termination.F90 index e647e19..cb8495f 100644 --- a/test/test-assert-subroutine-normal-termination.F90 +++ b/test/test-assert-subroutine-normal-termination.F90 @@ -3,41 +3,18 @@ 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" ) + call assert(assertion = .true., description = "3 keyword arguments ") + call assert( .true., description = "2 keyword arguments ") + 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" - + print *," passes on not error-terminating when assertion=.true." - 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 +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 From 873f48d46949c1d60740ad7f7a33c2514f50989d Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Tue, 17 Jun 2025 20:11:48 -0700 Subject: [PATCH 02/14] build(lfortran): use stringify workaround in macro --- include/assert_macros.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/include/assert_macros.h b/include/assert_macros.h index 913d775..ba32723 100644 --- a/include/assert_macros.h +++ b/include/assert_macros.h @@ -13,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 From 6192f4e858e4bc4f9a2ebbf416316f220933217e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C4=8Cert=C3=ADk?= Date: Tue, 17 Jun 2025 23:30:14 -0500 Subject: [PATCH 03/14] Remove submodule --- src/assert/assert_subroutine_m.F90 | 69 ++++++++++++++++++++++++++ src/assert/assert_subroutine_s.F90 | 79 ------------------------------ 2 files changed, 69 insertions(+), 79 deletions(-) delete mode 100644 src/assert/assert_subroutine_s.F90 diff --git a/src/assert/assert_subroutine_m.F90 b/src/assert/assert_subroutine_m.F90 index cdaadfe..d799b42 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: @@ -87,4 +89,71 @@ pure module subroutine assert_always(assertion, description) end interface +contains + + module procedure assert + + toggle_assertions: & + if (enforce_assertions) then + call assert_always(assertion, description) + end if toggle_assertions + + end procedure + + module procedure assert_always + character(len=:), allocatable :: 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 + message = 'Assertion failure on image ' // string(me) // ':' // description +#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 + + 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 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 d73901f..0000000 --- a/src/assert/assert_subroutine_s.F90 +++ /dev/null @@ -1,79 +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) - end if toggle_assertions - - end procedure - - module procedure assert_always - character(len=:), allocatable :: 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 - message = 'Assertion failure on image ' // string(me) // ':' // description -#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 - - 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 From aed7bc4f63d4377eabfb7945283087aaefbd5912 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C4=8Cert=C3=ADk?= Date: Tue, 17 Jun 2025 23:41:26 -0500 Subject: [PATCH 04/14] Get rid of an interface --- src/assert/assert_subroutine_m.F90 | 29 ++++++++++------------------- 1 file changed, 10 insertions(+), 19 deletions(-) diff --git a/src/assert/assert_subroutine_m.F90 b/src/assert/assert_subroutine_m.F90 index d799b42..98cedfd 100644 --- a/src/assert/assert_subroutine_m.F90 +++ b/src/assert/assert_subroutine_m.F90 @@ -68,9 +68,10 @@ pure subroutine assert_error_stop_interface(stop_code_char) #endif logical, parameter :: enforce_assertions=USE_ASSERTIONS - interface - pure module subroutine assert(assertion, description) +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 @@ -78,29 +79,19 @@ pure module subroutine assert(assertion, description) !! 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" - end subroutine - - pure module 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 - end subroutine - - end interface - -contains - - module procedure assert toggle_assertions: & if (enforce_assertions) then call assert_always(assertion, description) end if toggle_assertions - end procedure + end subroutine - module procedure assert_always + pure module 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 character(len=:), allocatable :: message integer me @@ -153,7 +144,7 @@ pure function string(numeric) result(number_as_string) end function string - end procedure + end subroutine end module assert_subroutine_m From 399ed80c5ccfea435d3dcec7362b74e694f5e003 Mon Sep 17 00:00:00 2001 From: Pranavchiku Date: Thu, 19 Jun 2025 20:30:22 +0530 Subject: [PATCH 05/14] XX: direcly use exit_status value --- test/test-assert-subroutine-error-termination.F90 | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/test/test-assert-subroutine-error-termination.F90 b/test/test-assert-subroutine-error-termination.F90 index 07ac2d3..547df84 100644 --- a/test/test-assert-subroutine-error-termination.F90 +++ b/test/test-assert-subroutine-error-termination.F90 @@ -27,7 +27,8 @@ program test_assert_subroutine_error_termination #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", & + ! For all other compilers, we assume that the default fpm command works + command = "fpm run --example false-assertion --profile release --flag '-DASSERTIONS -ffree-line-length-0' > /dev/null 2>&1", & #endif wait = .true., & exitstat = exit_status & @@ -49,11 +50,11 @@ program test_assert_subroutine_error_termination end block #else block - integer unit - open(newunit=unit, file="build/exit_status", status="old") - read(unit,*) exit_status + ! 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) + ! close(unit) end block #endif From 5f0e0ef3e4d346ed817eee796eec823d3ff0d79e Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Thu, 19 Jun 2025 14:18:56 -0700 Subject: [PATCH 06/14] fix(test): rm module in proc interf Also manually inline string function. --- src/assert/assert_subroutine_m.F90 | 34 ++++--------------- ...st-assert-subroutine-error-termination.F90 | 13 ++++--- 2 files changed, 14 insertions(+), 33 deletions(-) diff --git a/src/assert/assert_subroutine_m.F90 b/src/assert/assert_subroutine_m.F90 index 98cedfd..8fd0a68 100644 --- a/src/assert/assert_subroutine_m.F90 +++ b/src/assert/assert_subroutine_m.F90 @@ -87,7 +87,7 @@ pure subroutine assert(assertion, description) end subroutine - pure module subroutine assert_always(assertion, description) + pure subroutine assert_always(assertion, description) !! Same as above but always enforces the assertion (regardless of ASSERTIONS) implicit none logical, intent(in) :: assertion @@ -104,7 +104,11 @@ pure module subroutine assert_always(assertion, description) # else me = this_image() # endif - message = 'Assertion failure on image ' // string(me) // ':' // description + 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 @@ -118,32 +122,6 @@ pure module subroutine assert_always(assertion, description) 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 subroutine end module assert_subroutine_m diff --git a/test/test-assert-subroutine-error-termination.F90 b/test/test-assert-subroutine-error-termination.F90 index 547df84..ea94fbd 100644 --- a/test/test-assert-subroutine-error-termination.F90 +++ b/test/test-assert-subroutine-error-termination.F90 @@ -48,15 +48,18 @@ program test_assert_subroutine_error_termination end if end if end block +#else +#ifdef __LFORTRAN__ + print *,trim(merge("passes","FAILS ",exit_status/=0)) // " on error-terminating when assertion = .false." #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) + integer unit + open(newunit=unit, file="build/exit_status", status="old") + read(unit,*) exit_status + close(unit) end block #endif +#endif contains From 54771261389bb3054642efecbe99533eb49fa09c Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Thu, 19 Jun 2025 15:48:06 -0700 Subject: [PATCH 07/14] doc(README): reorg, update commands, add lfortran --- README.md | 99 +++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 63 insertions(+), 36 deletions(-) diff --git a/README.md b/README.md index b23c22e..d26b372 100644 --- a/README.md +++ b/README.md @@ -58,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 $@ +``` +Then build and test Assert with the command ``` -git clone git@github.com:berkeleylab/assert -cd assert +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 ``` @@ -88,60 +110,65 @@ 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 +#### Multi-image (parallel) execution +With `flang-new` version 21 built from the SiPearl llvm-project fork's +[prif branch](https://github.com/SiPearl/llvm-project/tree/prif), use ``` -fpm test --compiler nagfor --profile release --flag "-fpp -coarray=cosmp" +fpm test --compiler -caffeine -L -l -L ``` +where, for example, `` might be `gasnet-smp-seq` for +shared-memory execution. -### 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 +### LFortran `lfortran` -ftn $@ -``` -Then build and test Assert with the command +#### Single-image (serial) execution ``` -fpm test --compiler crayftn.sh --profile release +fpm test --compiler lfortran --profile release --flag --cpp ``` +### Numerical Algorithms Group (NAG) `nagfor` -### Building and testing with other compilers -To use Assert with other compilers, please submit an issue or pull request. +#### Single-image (serial) execution +With `nagfor` version 7.1 or later, use +``` +fpm test --compiler nagfor --profile release --flag -fpp +``` -### Running the examples -See the [./example](./example) subdirectory. +#### Multi-image execution +With `nagfor` 7.1, use +``` +fpm test --compiler nagfor --profile release --flag "-fpp -coarray=cosmp -f2018" +``` +With `nagfor` 7.2 or later, use +``` +fpm test --compiler nagfor --profile release --flag -fpp +``` Documentation ------------- From b0f43cc8a215b3e9f4c10d56e47578330d6382e3 Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Thu, 19 Jun 2025 20:02:17 -0700 Subject: [PATCH 08/14] fix(test): restrict output to image 1 --- ...est-assert-subroutine-error-termination.F90 | 11 +++++++++-- ...st-assert-subroutine-normal-termination.F90 | 18 ++++++++++++++---- 2 files changed, 23 insertions(+), 6 deletions(-) diff --git a/test/test-assert-subroutine-error-termination.F90 b/test/test-assert-subroutine-error-termination.F90 index ea94fbd..ab81de4 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, diff --git a/test/test-assert-subroutine-normal-termination.F90 b/test/test-assert-subroutine-normal-termination.F90 index cb8495f..2eab32e 100644 --- a/test/test-assert-subroutine-normal-termination.F90 +++ b/test/test-assert-subroutine-normal-termination.F90 @@ -5,16 +5,26 @@ program test_assert_subroutine_normal_termination use assert_m, only : assert implicit none - 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 + sync all +#endif call assert(assertion = .true., description = "3 keyword arguments ") call assert( .true., description = "2 keyword arguments ") call assert( .true., "no optional argument") + #if ASSERT_MULTI_IMAGE - sync all - if (this_image()==1) & + 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 From c736489c2a319dc42ccd49554f9b5aea0d6bd8e6 Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Thu, 3 Jul 2025 15:32:19 -0700 Subject: [PATCH 09/14] doc(README): address PR feedback --- README.md | 9 --------- 1 file changed, 9 deletions(-) diff --git a/README.md b/README.md index d26b372..6cbcf93 100644 --- a/README.md +++ b/README.md @@ -136,15 +136,6 @@ With `flang-new` version 20 or later, use fpm test --compiler flang-new --flag "-O3" ``` -#### Multi-image (parallel) execution -With `flang-new` version 21 built from the SiPearl llvm-project fork's -[prif branch](https://github.com/SiPearl/llvm-project/tree/prif), use -``` -fpm test --compiler -caffeine -L -l -L -``` -where, for example, `` might be `gasnet-smp-seq` for -shared-memory execution. - ### LFortran `lfortran` #### Single-image (serial) execution From 0c58e6613233e3670410cd0d39f2462ba9f10cb8 Mon Sep 17 00:00:00 2001 From: Dan Bonachea Date: Thu, 17 Jul 2025 13:06:06 -0700 Subject: [PATCH 10/14] Cleanup test-assert-subroutine-error-termination * Fix defects introduced while adding LFortran support that broke several other configurations. * Disentangle file-passing of exit status from multi-image, so that it's properly compiler-specific * Use co_max in place of co_reduce for multi-image (cherry picked from commit f1d96ff673cee9eba2ae012262ccc1b3026fbf3a) --- ...st-assert-subroutine-error-termination.F90 | 53 +++++++------------ 1 file changed, 18 insertions(+), 35 deletions(-) diff --git a/test/test-assert-subroutine-error-termination.F90 b/test/test-assert-subroutine-error-termination.F90 index ab81de4..b7386ea 100644 --- a/test/test-assert-subroutine-error-termination.F90 +++ b/test/test-assert-subroutine-error-termination.F90 @@ -29,58 +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", & -#else - ! For all other compilers, we assume that the default fpm command works +#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 -#ifdef __LFORTRAN__ - print *,trim(merge("passes","FAILS ",exit_status/=0)) // " on error-terminating when assertion = .false." -#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 close(unit) - end block + end block #endif -#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 From 1b7aa0a0d0fbb6a89a63e0c766025608937e0fc8 Mon Sep 17 00:00:00 2001 From: Dan Bonachea Date: Thu, 17 Jul 2025 15:07:29 -0700 Subject: [PATCH 11/14] test-assert-macro: Restore testing of examples from README.md --- test/test-assert-macro.F90 | 35 +++++++++++++++++++++++++++++++++++ 1 file changed, 35 insertions(+) diff --git a/test/test-assert-macro.F90 b/test/test-assert-macro.F90 index 1ab1a4d..321289f 100644 --- a/test/test-assert-macro.F90 +++ b/test/test-assert-macro.F90 @@ -43,6 +43,41 @@ program test_assert_macros print '(a)'," pass on invocation from a pure function" end block + !------------------------------------------ +#undef ASSERTIONS +#define ASSERTIONS 1 +#include "assert_macros.h" + + ! 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) + ! Cray Fortran uses different line continuations in macro invocations + 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_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 + !------------------------------------------ + contains pure function check_assert(cond) result(ok) From bc15b7f1613e8184f188b6bddabe2b726c254119 Mon Sep 17 00:00:00 2001 From: Dan Bonachea Date: Thu, 17 Jul 2025 18:18:04 -0400 Subject: [PATCH 12/14] Update test/test-assert-subroutine-normal-termination.F90 --- test/test-assert-subroutine-normal-termination.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/test/test-assert-subroutine-normal-termination.F90 b/test/test-assert-subroutine-normal-termination.F90 index 2eab32e..6c51d3c 100644 --- a/test/test-assert-subroutine-normal-termination.F90 +++ b/test/test-assert-subroutine-normal-termination.F90 @@ -14,9 +14,9 @@ program test_assert_subroutine_normal_termination sync all #endif - call assert(assertion = .true., description = "3 keyword arguments ") - call assert( .true., description = "2 keyword arguments ") - call assert( .true., "no optional argument") + call assert(assertion = .true., description = "2 keyword arguments") + call assert( .true., description = "1 keyword arguments") + call assert( .true., "0 keyword arguments") #if ASSERT_MULTI_IMAGE sync all From a4f77355a25d2c7e1560d25b6878cc26cbd03511 Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Thu, 17 Jul 2025 15:34:31 -0700 Subject: [PATCH 13/14] Apply suggestions from code review rm fpm profile with nagfor --- README.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 6cbcf93..9503f8e 100644 --- a/README.md +++ b/README.md @@ -148,7 +148,7 @@ fpm test --compiler lfortran --profile release --flag --cpp #### Single-image (serial) execution With `nagfor` version 7.1 or later, use ``` -fpm test --compiler nagfor --profile release --flag -fpp +fpm test --compiler nagfor --flag -fpp ``` #### Multi-image execution @@ -158,7 +158,7 @@ fpm test --compiler nagfor --profile release --flag "-fpp -coarray=cosmp -f2018" ``` With `nagfor` 7.2 or later, use ``` -fpm test --compiler nagfor --profile release --flag -fpp +fpm test --compiler nagfor --flag -fpp ``` Documentation From 4c1b2dfb99bcd61db64684b7329d472b1b613758 Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Thu, 17 Jul 2025 15:38:04 -0700 Subject: [PATCH 14/14] fix(test-macro): match lfortran behavior to cray --- test/test-assert-macro.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/test-assert-macro.F90 b/test/test-assert-macro.F90 index 321289f..633cc5e 100644 --- a/test/test-assert-macro.F90 +++ b/test/test-assert-macro.F90 @@ -52,7 +52,7 @@ program test_assert_macros 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_describe( computed_checksum == expected_checksum, & "Checksum mismatch failure!" &