Add ASSERT_PARALLEL_CALLBACKS define

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.

Author: bonachea

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

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

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.

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