From 7bf144153397eef496180dc03da0b712bc97799d 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 1/4] 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 37ed09d48bdf127c0a9aee9018b00c50f2ff0d99 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 2/4] 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 535434d2f44508aa06231c6c2fe95f9e11292769 Mon Sep 17 00:00:00 2001 From: Pranavchiku Date: Thu, 19 Jun 2025 20:30:22 +0530 Subject: [PATCH 3/4] 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 f6e1671517c1f1675088d28deb46c873cf451a26 Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Thu, 19 Jun 2025 14:18:56 -0700 Subject: [PATCH 4/4] 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