diff --git a/example/false-assertion.F90 b/example/false-assertion.F90 index 1d74cab..f8e8e86 100644 --- a/example/false-assertion.F90 +++ b/example/false-assertion.F90 @@ -1,7 +1,40 @@ program false_assertion - use assert_m, only : assert + use assert_m implicit none +#if ASSERT_PARALLEL_CALLBACKS + assert_this_image => assert_callback_this_image + assert_error_stop => assert_callback_error_stop +#endif + call assert(.false., "false-assertion: unconditionally failing test") +#if ASSERT_PARALLEL_CALLBACKS +! By default, assert uses `THIS_IMAGE()` in multi-image mode while +! composing assertion output, and invokes `ERROR STOP` to print the +! assertion and terminate execution. +! +! The ASSERT_PARALLEL_CALLBACKS preprocessor flag enables the client to replace +! the default use of these two Fortran features with client-provided callbacks. +! To use this feature, the client must build the library with `-DASSERT_PARALLEL_CALLBACKS`, +! and then at startup set the `assert_this_image` and `assert_error_stop` +! procedure pointers to reference the desired callbacks. +contains + + pure function assert_callback_this_image() result(this_image_id) + implicit none + integer :: this_image_id + + this_image_id = 42 + end function + + pure subroutine assert_callback_error_stop(stop_code_char) + implicit none + character(len=*), intent(in) :: stop_code_char + + error stop "Hello from assert_callback_error_stop!" // NEW_LINE('a') // & + "Your assertion: " // NEW_LINE('a') // stop_code_char + end subroutine +#endif + end program diff --git a/include/assert_features.h b/include/assert_features.h index c08c338..d8ccdc1 100644 --- a/include/assert_features.h +++ b/include/assert_features.h @@ -11,4 +11,9 @@ # endif #endif +! Whether the library should use client callbacks for parallel features +#ifndef ASSERT_PARALLEL_CALLBACKS +#define ASSERT_PARALLEL_CALLBACKS 0 +#endif + #endif diff --git a/src/assert/assert_subroutine_m.F90 b/src/assert/assert_subroutine_m.F90 index 40a14bd..5e2d7ae 100644 --- a/src/assert/assert_subroutine_m.F90 +++ b/src/assert/assert_subroutine_m.F90 @@ -35,6 +35,28 @@ module assert_subroutine_m private public :: assert, assert_always +#if ASSERT_PARALLEL_CALLBACKS + public :: assert_this_image_interface, assert_this_image + public :: assert_error_stop_interface, assert_error_stop + + abstract interface + pure function assert_this_image_interface() result(this_image_id) + implicit none + integer :: this_image_id + end function + end interface + procedure(assert_this_image_interface), pointer :: assert_this_image + + abstract interface + pure subroutine assert_error_stop_interface(stop_code_char) + implicit none + character(len=*), intent(in) :: stop_code_char + end subroutine + end interface + procedure(assert_error_stop_interface), pointer :: assert_error_stop + +#endif + #ifndef USE_ASSERTIONS # if ASSERTIONS # define USE_ASSERTIONS .true. diff --git a/src/assert/assert_subroutine_s.F90 b/src/assert/assert_subroutine_s.F90 index 54fc15b..1980639 100644 --- a/src/assert/assert_subroutine_s.F90 +++ b/src/assert/assert_subroutine_s.F90 @@ -25,16 +25,20 @@ use characterizable_m, only : characterizable_t character(len=:), allocatable :: header, trailer + integer :: me check_assertion: & if (.not. assertion) then #if ASSERT_MULTI_IMAGE - associate(me=>this_image()) ! work around gfortran bug - header = 'Assertion "' // description // '" failed on image ' // string(me) - end associate +# 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.' + header = 'Assertion "' // description // '" failed.' #endif represent_diagnostics_as_string: & @@ -64,7 +68,11 @@ end if represent_diagnostics_as_string - error stop header // trailer +#if ASSERT_PARALLEL_CALLBACKS + call assert_error_stop(header // trailer) +#else + error stop (header // trailer) +#endif end if check_assertion