From e176da3b7c4db01c83759c6a086e93bd5dd37a55 Mon Sep 17 00:00:00 2001 From: Katherine Rasmussen Date: Tue, 12 Dec 2023 19:33:39 -0800 Subject: [PATCH] Update interface of `prif_stop` and `prif_error_stop` based on latest design doc choices. --- example/hello.f90 | 2 +- .../error_stop_character_code.f90 | 2 +- src/caffeine/assert/assert_s.f90 | 4 +- src/caffeine/assert/intrinsic_array_s.F90 | 10 +-- .../collective_subroutines/co_max_s.f90 | 2 +- .../collective_subroutines/co_min_s.f90 | 2 +- .../collective_subroutines/co_reduce_s.f90 | 2 +- src/caffeine/program_startup_s.F90 | 2 +- src/caffeine/program_termination_m.f90 | 45 +++++------ src/caffeine/program_termination_s.f90 | 75 ++++++++++++++----- 10 files changed, 86 insertions(+), 60 deletions(-) diff --git a/example/hello.f90 b/example/hello.f90 index 573ddba99..989ff68a6 100644 --- a/example/hello.f90 +++ b/example/hello.f90 @@ -6,6 +6,6 @@ program hello_world print *, "Hello from image", this_image(), "of", num_images() - call prif_stop(stop_code=0) ! normal termination + call prif_stop(stop_code_int=0) ! normal termination end program diff --git a/example/support-test/error_stop_character_code.f90 b/example/support-test/error_stop_character_code.f90 index c100b5914..01bf6e143 100644 --- a/example/support-test/error_stop_character_code.f90 +++ b/example/support-test/error_stop_character_code.f90 @@ -4,7 +4,7 @@ program error_stop_character_code if (prif_init() /= 0) error stop "caffeinate returned a non-zero exit_code" - call prif_error_stop("Oh snap!") + call prif_error_stop(stop_code_char="Oh snap!") stop 0 ! ../../test/caf_error_stop_test.f90 will report a test failure if this line runs end program diff --git a/src/caffeine/assert/assert_s.f90 b/src/caffeine/assert/assert_s.f90 index c1e410fca..a00a9bb79 100644 --- a/src/caffeine/assert/assert_s.f90 +++ b/src/caffeine/assert/assert_s.f90 @@ -52,7 +52,7 @@ end if represent_diagnostics_as_string - call prif_error_stop(header // ' with diagnostic data "' // trailer // '"') + call prif_error_stop(stop_code_char=header // ' with diagnostic data "' // trailer // '"') end if check_assertion @@ -77,7 +77,7 @@ pure function string(numeric) result(number_as_string) type is(real) write(untrimmed_string, *) numeric class default - call prif_error_stop("Internal error in subroutine 'assert': unsupported type in function 'string'.") + call prif_error_stop(stop_code_char="Internal error in subroutine 'assert': unsupported type in function 'string'.") end select number_as_string = trim(adjustl(untrimmed_string)) diff --git a/src/caffeine/assert/intrinsic_array_s.F90 b/src/caffeine/assert/intrinsic_array_s.F90 index 059b2c553..90bf17976 100644 --- a/src/caffeine/assert/intrinsic_array_s.F90 +++ b/src/caffeine/assert/intrinsic_array_s.F90 @@ -22,7 +22,7 @@ type is(double precision) intrinsic_array%double_precision_1D = array class default - call prif_error_stop("intrinsic_array_t construct: unsupported rank-2 type") + call prif_error_stop(stop_code_char="intrinsic_array_t construct: unsupported rank-2 type") end select #ifndef NAGFOR rank(2) @@ -38,7 +38,7 @@ type is(double precision) intrinsic_array%double_precision_2D = array class default - call prif_error_stop("intrinsic_array_t construct: unsupported rank-2 type") + call prif_error_stop(stop_code_char="intrinsic_array_t construct: unsupported rank-2 type") end select rank(3) @@ -54,11 +54,11 @@ type is(double precision) intrinsic_array%double_precision_3D = array class default - call prif_error_stop("intrinsic_array_t construct: unsupported rank-3 type") + call prif_error_stop(stop_code_char="intrinsic_array_t construct: unsupported rank-3 type") end select rank default - call prif_error_stop("intrinsic_array_t construct: unsupported rank") + call prif_error_stop(stop_code_char="intrinsic_array_t construct: unsupported rank") end select #endif @@ -74,7 +74,7 @@ allocated(self%logical_2D), allocated(self%real_2D), & allocated(self%complex_3D), allocated(self%complex_double_3D), allocated(self%integer_3D), & allocated(self%logical_3D), allocated(self%real_3D) & - ])) call prif_error_stop("intrinsic_array_t as_character: ambiguous component allocation status.") + ])) call prif_error_stop(stop_code_char="intrinsic_array_t as_character: ambiguous component allocation status.") if (allocated(self%complex_1D)) then character_self = repeat(" ", ncopies = single_number_width*size(self%complex_1D)) diff --git a/src/caffeine/collective_subroutines/co_max_s.f90 b/src/caffeine/collective_subroutines/co_max_s.f90 index 514b15603..0d8922d1c 100644 --- a/src/caffeine/collective_subroutines/co_max_s.f90 +++ b/src/caffeine/collective_subroutines/co_max_s.f90 @@ -29,7 +29,7 @@ else if (caf_is_f_string(a)) then call prif_co_reduce(a, c_funloc(reverse_alphabetize), optional_value(result_image), stat, errmsg) else - call prif_error_stop("caf_co_max: unsupported type") + call prif_error_stop(stop_code_char="caf_co_max: unsupported type") end if contains diff --git a/src/caffeine/collective_subroutines/co_min_s.f90 b/src/caffeine/collective_subroutines/co_min_s.f90 index c6f2062eb..68848b87f 100644 --- a/src/caffeine/collective_subroutines/co_min_s.f90 +++ b/src/caffeine/collective_subroutines/co_min_s.f90 @@ -29,7 +29,7 @@ else if (caf_is_f_string(a)) then call prif_co_reduce(a, c_funloc(alphabetize), optional_value(result_image), stat, errmsg) else - call prif_error_stop("prif_co_min: unsupported type") + call prif_error_stop(stop_code_char="prif_co_min: unsupported type") end if contains diff --git a/src/caffeine/collective_subroutines/co_reduce_s.f90 b/src/caffeine/collective_subroutines/co_reduce_s.f90 index ac1d25cba..662a86fd1 100644 --- a/src/caffeine/collective_subroutines/co_reduce_s.f90 +++ b/src/caffeine/collective_subroutines/co_reduce_s.f90 @@ -69,7 +69,7 @@ call caf_co_reduce(a, optional_value(result_image), stat_ptr, errmsg_ptr, & int(product(shape(a)), c_size_t), c_funloc(Coll_ReduceSub_c_double_complex), c_null_ptr) else - call prif_error_stop("caf_co_reduce: unsupported type") + call prif_error_stop(stop_code_char="caf_co_reduce: unsupported type") end if contains diff --git a/src/caffeine/program_startup_s.F90 b/src/caffeine/program_startup_s.F90 index 69db1d3e6..f2a4f2aab 100644 --- a/src/caffeine/program_startup_s.F90 +++ b/src/caffeine/program_startup_s.F90 @@ -39,7 +39,7 @@ function c_interop_arg(argnum) result(arg) arg => targ #endif call get_command_argument(argnum, arg, arglen) - if (arglen+1>max_arg_len) call prif_error_stop("maximum argument length exceeded") + if (arglen+1>max_arg_len) call prif_error_stop(stop_code_char="maximum argument length exceeded") arg(arglen+1:arglen+1) = c_null_char end function diff --git a/src/caffeine/program_termination_m.f90 b/src/caffeine/program_termination_m.f90 index a623eb791..ac4e7798a 100644 --- a/src/caffeine/program_termination_m.f90 +++ b/src/caffeine/program_termination_m.f90 @@ -1,36 +1,25 @@ ! Copyright (c), The Regents of the University of California ! Terms of use are as specified in LICENSE.txt module program_termination_m + use iso_c_binding, only: c_int implicit none private - public :: prif_stop - public :: prif_error_stop - - interface prif_stop - - module subroutine prif_stop_integer(stop_code) - !! synchronize, stop the executing image, and provide the stop_code, or 0 if not present, as the process exit status - integer, intent(in), optional :: stop_code - end subroutine - - module subroutine prif_stop_character(stop_code) - !! synchronize, stop the executing image, and provide the stop_code as the process exit status - character(len=*), intent(in) :: stop_code - end subroutine - - end interface - - interface prif_error_stop - - pure module subroutine prif_error_stop_integer(stop_code) - !! stop all images and provide the stop_code, or 0 if not present, as the process exit status - integer, intent(in), optional :: stop_code - end subroutine - - pure module subroutine prif_error_stop_character(stop_code) - !! stop all images and provide the stop_code as the process exit status - character(len=*), intent(in) :: stop_code - end subroutine + public :: prif_stop, prif_error_stop + + interface + + module subroutine prif_stop(stop_code_int, stop_code_char, quiet) + implicit none + integer(c_int), intent(in), optional :: stop_code_int + character(len=*), intent(in), optional :: stop_code_char + logical, intent(in), optional :: quiet + end subroutine + + module pure subroutine prif_error_stop(stop_code_int, stop_code_char, quiet) + integer(c_int), intent(in), optional :: stop_code_int + character(len=*), intent(in), optional :: stop_code_char + logical, intent(in), optional :: quiet + end subroutine end interface diff --git a/src/caffeine/program_termination_s.f90 b/src/caffeine/program_termination_s.f90 index e015c7694..a593d0cd1 100644 --- a/src/caffeine/program_termination_s.f90 +++ b/src/caffeine/program_termination_s.f90 @@ -2,39 +2,71 @@ ! Terms of use are as specified in LICENSE.txt submodule(program_termination_m) program_termination_s use iso_fortran_env, only : output_unit, error_unit - use iso_c_binding, only : c_char, c_int + use iso_c_binding, only : c_char use caffeine_h_m, only : caf_decaffeinate implicit none contains - module procedure prif_stop_integer + module procedure prif_stop - sync all + !TODO: deal with optional argument `quiet` + if (present(stop_code_char)) then + call prif_stop_character(stop_code_char) + else if (present(stop_code_int)) then + call prif_stop_integer(stop_code_int) + else + call prif_stop_integer() + end if + + contains + + subroutine prif_stop_integer(stop_code) + !! synchronize, stop the executing image, and provide the stop_code, or 0 if not present, as the process exit status + integer, intent(in), optional :: stop_code - !write(output_unit, *) "caf_stop: stop code '", stop_code, "'" - write(output_unit, *) stop_code - flush output_unit + sync all - if (.not. present(stop_code)) call caf_decaffeinate(exit_code=0_c_int) ! does not return - call caf_decaffeinate(stop_code) + !write(output_unit, *) "caf_stop: stop code '", stop_code, "'" + write(output_unit, *) stop_code + flush output_unit - end procedure + if (.not. present(stop_code)) call caf_decaffeinate(exit_code=0_c_int) ! does not return + call caf_decaffeinate(stop_code) - module procedure prif_stop_character + end subroutine prif_stop_integer - sync all + subroutine prif_stop_character(stop_code) + !! synchronize, stop the executing image, and provide the stop_code as the process exit status + character(len=*), intent(in) :: stop_code - write(output_unit, *) "caf_stop: stop code '" // stop_code // "'" - flush output_unit + sync all - call caf_decaffeinate(exit_code=0_c_int) ! does not return + write(output_unit, *) "caf_stop: stop code '" // stop_code // "'" + flush output_unit - end procedure + call caf_decaffeinate(exit_code=0_c_int) ! does not return + end subroutine prif_stop_character + end procedure prif_stop + + module procedure prif_error_stop + + !TODO: deal with optional argument `quiet` + if (present(stop_code_char)) then + call prif_error_stop_character(stop_code_char) + else if (present(stop_code_int)) then + call prif_error_stop_integer(stop_code_int) + else + call prif_error_stop_integer() + end if + end procedure prif_error_stop + + pure subroutine prif_error_stop_character(stop_code) + !! stop all images and provide the stop_code as the process exit status + character(len=*), intent(in) :: stop_code - module procedure prif_error_stop_character interface pure subroutine caf_error_stop_character_c(stop_code, length) bind(C, name = "caf_error_stop_character_c") use, intrinsic :: iso_c_binding, only: c_char, c_int @@ -43,8 +75,9 @@ pure subroutine caf_error_stop_character_c(stop_code, length) bind(C, name = "ca character(len=1,kind=c_char), intent(in) :: stop_code(length) end subroutine end interface + call caf_error_stop_character_c(f_c_string(stop_code), len(stop_code)) - end procedure + end subroutine subroutine inner_caf_error_stop_character(stop_code, length) bind(C, name = "inner_caf_error_stop_character") integer(c_int), intent(in) :: length @@ -59,7 +92,10 @@ subroutine inner_caf_error_stop_character(stop_code, length) bind(C, name = "inn end subroutine - module procedure prif_error_stop_integer + pure subroutine prif_error_stop_integer(stop_code) + !! stop all images and provide the stop_code, or 0 if not present, as the process exit status + integer, intent(in), optional :: stop_code + interface pure subroutine caf_error_stop_integer_c(stop_code) bind(C, name = "caf_error_stop_integer_c") use, intrinsic :: iso_c_binding, only: c_int @@ -67,8 +103,9 @@ pure subroutine caf_error_stop_integer_c(stop_code) bind(C, name = "caf_error_st integer(c_int), intent(in) :: stop_code end subroutine end interface + call caf_error_stop_integer_c(stop_code) - end procedure + end subroutine subroutine inner_caf_error_stop_integer(stop_code) bind(C, name = "inner_caf_error_stop_integer") integer, intent(in), optional :: stop_code