diff --git a/example/support-test/register_stop_callback.f90 b/example/support-test/register_stop_callback.f90 new file mode 100644 index 000000000..137bbdbf5 --- /dev/null +++ b/example/support-test/register_stop_callback.f90 @@ -0,0 +1,28 @@ +program register_stop_callback + use iso_c_binding, only: c_bool, c_int + use prif, only : & + prif_init, & + prif_register_stop_callback, & + prif_stop, & + prif_stop_callback_interface + implicit none + + integer init_exit_code + logical(kind=c_bool), parameter :: false = .false._c_bool + ! use of the pointer is unnecessary according to the standard, + ! but gfortran complains without it + procedure(prif_stop_callback_interface), pointer :: callback_ptr + callback_ptr => callback + + call prif_init(init_exit_code) + call prif_register_stop_callback(callback_ptr) + call prif_stop(false) +contains + subroutine callback(is_error_stop, quiet, stop_code_int, stop_code_char) + logical(c_bool), intent(in) :: is_error_stop, quiet + integer(c_int), intent(in), optional :: stop_code_int + character(len=*), intent(in), optional :: stop_code_char + + print *, "callback invoked" + end subroutine +end program \ No newline at end of file diff --git a/src/prif.F90 b/src/prif.F90 index 26ee17886..e0f97006c 100644 --- a/src/prif.F90 +++ b/src/prif.F90 @@ -120,7 +120,7 @@ module subroutine prif_init(stat) module subroutine prif_register_stop_callback(callback) implicit none - procedure(prif_stop_callback_interface), pointer :: callback + procedure(prif_stop_callback_interface), pointer, intent(in) :: callback end subroutine module subroutine prif_stop(quiet, stop_code_int, stop_code_char) diff --git a/test/caf_stop_test.f90 b/test/caf_stop_test.f90 index 490fbba5c..e518ca9bb 100644 --- a/test/caf_stop_test.f90 +++ b/test/caf_stop_test.f90 @@ -15,6 +15,7 @@ function test_prif_this_image() result(tests) [ it("exits with a zero exitstat when the program omits the stop code", exit_with_no_stop_code) & ,it("prints an integer stop code and exits with exitstat equal to the stop code", exit_with_integer_stop_code) & ,it("prints a character stop code and exits with a non-zero exitstat", exit_with_character_stop_code) & + ,it("invokes a registered callback", check_callback_invocation) & ]) end function @@ -57,4 +58,17 @@ function exit_with_character_stop_code() result(result_) end function + function check_callback_invocation() result(result_) + type(result_t) :: result_ + + integer :: exit_status + + call execute_command_line( & + command = "./build/run-fpm.sh run --example register_stop_callback > /dev/null 2>&1", & + wait = .true., & + exitstat = exit_status & + ) + result_ = assert_equals(0, exit_status) + end function + end module caf_stop_test