diff --git a/src/julienne/julienne_test_description_m.f90 b/src/julienne/julienne_test_description_m.f90 index 50af0295c..8cb9b6e95 100644 --- a/src/julienne/julienne_test_description_m.f90 +++ b/src/julienne/julienne_test_description_m.f90 @@ -6,11 +6,13 @@ module julienne_test_description_m use julienne_string_m, only : string_t use julienne_test_result_m, only : test_result_t use julienne_test_diagnosis_m, only : test_diagnosis_t, diagnosis_function_i + use iso_c_binding, only: c_funptr implicit none private public :: test_description_t public :: filter + public :: bless type test_description_t !! Encapsulate test descriptions and test-functions @@ -25,6 +27,10 @@ module julienne_test_description_m procedure, private :: equals end type + type bless + procedure(diagnosis_function_i), pointer, nopass :: ptr => null() + end type + interface test_description_t module function construct_from_string(description, diagnosis_function) result(test_description) @@ -35,6 +41,22 @@ module function construct_from_string(description, diagnosis_function) result(te type(test_description_t) test_description end function + module function construct_from_string_funloc(description, diagnosis_function) result(test_description) + !! The result is a test_description_t object with the components defined by the dummy arguments + implicit none + type(string_t), intent(in) :: description + type(c_funptr), intent(in) :: diagnosis_function + type(test_description_t) test_description + end function + + module function construct_from_string_bless(description, diagnosis_function) result(test_description) + !! The result is a test_description_t object with the components defined by the dummy arguments + implicit none + type(string_t), intent(in) :: description + type(bless), intent(in) :: diagnosis_function + type(test_description_t) test_description + end function + module function construct_from_characters(description, diagnosis_function) result(test_description) !! The result is a test_description_t object with the components defined by the dummy arguments implicit none @@ -43,6 +65,22 @@ module function construct_from_characters(description, diagnosis_function) resul type(test_description_t) test_description end function + module function construct_from_characters_funloc(description, diagnosis_function) result(test_description) + !! The result is a test_description_t object with the components defined by the dummy arguments + implicit none + character(len=*), intent(in) :: description + type(c_funptr), intent(in) :: diagnosis_function + type(test_description_t) test_description + end function + + module function construct_from_characters_bless(description, diagnosis_function) result(test_description) + !! The result is a test_description_t object with the components defined by the dummy arguments + implicit none + character(len=*), intent(in) :: description + type(bless), intent(in) :: diagnosis_function + type(test_description_t) test_description + end function + end interface interface diff --git a/src/julienne/julienne_test_description_s.F90 b/src/julienne/julienne_test_description_s.F90 index 2a04ada8d..07d2317ef 100644 --- a/src/julienne/julienne_test_description_s.F90 +++ b/src/julienne/julienne_test_description_s.F90 @@ -9,6 +9,7 @@ use assert_m use julienne_assert_m, only : call_julienne_assert_ use julienne_command_line_m, only : command_line_t + use iso_c_binding, only: c_f_procpointer implicit none contains @@ -18,12 +19,36 @@ call_assert(allocated(test_description%description_)) end procedure + module procedure construct_from_characters_funloc + test_description%description_ = description + call c_f_procpointer(diagnosis_function, test_description%diagnosis_function_) + call_assert(allocated(test_description%description_)) + end procedure + + module procedure construct_from_characters_bless + test_description%description_ = description + test_description%diagnosis_function_ => diagnosis_function%ptr + call_assert(allocated(test_description%description_)) + end procedure + module procedure construct_from_string test_description%description_ = description if (present(diagnosis_function)) test_description%diagnosis_function_ => diagnosis_function call_assert(allocated(test_description%description_)) end procedure + module procedure construct_from_string_funloc + test_description%description_ = description + call c_f_procpointer(diagnosis_function, test_description%diagnosis_function_) + call_assert(allocated(test_description%description_)) + end procedure + + module procedure construct_from_string_bless + test_description%description_ = description + test_description%diagnosis_function_ => diagnosis_function%ptr + call_assert(allocated(test_description%description_)) + end procedure + module procedure run type(test_diagnosis_t) test_diagnosis diff --git a/src/julienne_m.f90 b/src/julienne_m.f90 index 93a45e308..1d86e7492 100644 --- a/src/julienne_m.f90 +++ b/src/julienne_m.f90 @@ -16,7 +16,7 @@ module julienne_m ,operator(.csv.) & ,operator(.separatedBy.) & ! same as operator(.sv.) ,operator(.sv.) - use julienne_test_description_m, only : test_description_t, filter + use julienne_test_description_m, only : test_description_t, filter, bless use julienne_test_diagnosis_m, only : test_diagnosis_t, diagnosis_function_i & ,operator(//) & ,operator(.all.) & diff --git a/test/modules/assert_test_m.F90 b/test/modules/assert_test_m.F90 index d1366d13d..f59ec9b6b 100644 --- a/test/modules/assert_test_m.F90 +++ b/test/modules/assert_test_m.F90 @@ -14,6 +14,7 @@ module assert_test_m ,operator(.equalsExpected.) & ,test_diagnosis_t & ,test_t & + ,bless & ,test_description_t & ,test_result_t & ,operator(.approximates.) & @@ -36,44 +37,19 @@ pure function subject() result(specimen) specimen = "The julienne_assert subroutine" end function -#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY - function results() result(test_results) type(test_result_t), allocatable :: test_results(:) type(test_description_t), allocatable :: test_descriptions(:) type(assert_test_t) assert_test test_descriptions = [ & - test_description_t("invocation via the call_julienne_assert macro", check_call_julienne_assert_macro) & - ,test_description_t("invocation via direct call", check_julienne_assert_call) & - ,test_description_t("invocation removal after undefining the ASSERTIONS macro", check_macro_removal) & + test_description_t("invocation via the call_julienne_assert macro", bless(check_call_julienne_assert_macro)) & + ,test_description_t("invocation via direct call", bless(check_julienne_assert_call)) & + ,test_description_t("invocation removal after undefining the ASSERTIONS macro", bless(check_macro_removal)) & ] test_results = assert_test%run(test_descriptions) end function -#else - - function results() result(test_results) - !! Work around missing Fortran 2008 feature: associating a procedure actual argument with a procedure pointer dummy argument - use julienne_m, only : diagnosis_function_i - type(test_result_t), allocatable :: test_results(:) - type(test_description_t), allocatable :: test_descriptions(:) - type(assert_test_t) assert_test - procedure(diagnosis_function_i), pointer :: & - check_call_julienne_assert_macro_ptr => check_call_julienne_assert_macro & - ,check_julienne_assert_call_ptr => check_julienne_assert_call & - ,check_macro_removal_ptr => check_macro_removal - - test_descriptions = [ & - test_description_t("invoking the call_julienne_assert macro", check_call_julienne_assert_macro_ptr) & - ,test_description_t("directly calling julienne_assert", check_julienne_assert_call_ptr) & - ,test_description_t("removal when the ASSERTIONS macro is defined as 0", check_macro_removal_ptr) & - ] - test_results = assert_test%run(test_descriptions) - end function - -#endif - function check_call_julienne_assert_macro() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis call_julienne_assert(1. .approximates. 2. .within. 3.) diff --git a/test/modules/bin_test_m.F90 b/test/modules/bin_test_m.F90 index 584ed137f..85c9b33ba 100644 --- a/test/modules/bin_test_m.F90 +++ b/test/modules/bin_test_m.F90 @@ -12,10 +12,8 @@ module bin_test_m ,test_description_t & ,test_diagnosis_t & ,test_result_t & - ,test_t -#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY - use julienne_m, only : diagnosis_function_i -#endif + ,test_t & + ,bless use assert_m, only : assert implicit none @@ -40,21 +38,10 @@ function results() result(test_results) type(test_description_t), allocatable :: test_descriptions(:) type(bin_test_t) bin_test -#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY test_descriptions = [ & - test_description_t(string_t("partitioning items nearly evenly across bins"), check_block_partitioning), & - test_description_t(string_t("partitioning all item across all bins without item loss"), check_all_items_partitioned) & + test_description_t(string_t("partitioning items nearly evenly across bins"), bless(check_block_partitioning)), & + test_description_t(string_t("partitioning all item across all bins without item loss"), bless(check_all_items_partitioned)) & ] -#else - ! Work around missing Fortran 2008 feature: associating a procedure actual argument with a procedure pointer dummy argument: - procedure(diagnosis_function_i), pointer :: check_block_partitioning_ptr, check_all_items_ptr - check_block_partitioning_ptr => check_block_partitioning - check_all_items_ptr => check_all_items_partitioned - test_descriptions = [ & - test_description_t(string_t("partitioning items nearly evenly across bins"), check_block_partitioning_ptr), & - test_description_t(string_t("partitioning all item across all bins without item loss"), check_all_items_ptr) & - ] -#endif test_results = bin_test%run(test_descriptions) end function diff --git a/test/modules/command_line_test_m.F90 b/test/modules/command_line_test_m.F90 index 3a13a6218..89e58fec3 100644 --- a/test/modules/command_line_test_m.F90 +++ b/test/modules/command_line_test_m.F90 @@ -14,10 +14,8 @@ module command_line_test_m ,test_description_t & ,test_diagnosis_t & ,test_result_t & + ,bless & ,test_t -#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY - use julienne_m, only : diagnosis_function_i -#endif implicit none @@ -43,20 +41,6 @@ function results() result(test_results) type(command_line_test_t) command_line_test type(command_line_t) command_line -#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY - procedure(diagnosis_function_i), pointer :: & - check_flag_value_ptr & - ,check_flag_value_missing_ptr & - ,check_flag_missing_ptr & - ,check_argument_missing_ptr & - ,check_argument_present_ptr - - check_flag_value_ptr => check_flag_value - check_flag_value_missing_ptr => check_flag_value_missing - check_flag_missing_ptr => check_flag_missing - check_argument_missing_ptr => check_argument_missing - check_argument_present_ptr => check_argument_present -#endif #if HAVE_MULTI_IMAGE_SUPPORT image_number: & @@ -97,23 +81,13 @@ function results() result(test_results) // new_line('') end if else ! run the tests -#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY - test_descriptions = [ & - test_description_t(string_t("flag_value() result is the value passed after a command-line flag"), check_flag_value) & - ,test_description_t(string_t("flag_value() result is an empty string if command-line flag value is missing"), check_flag_value_missing) & - ,test_description_t(string_t("flag_value() result is an empty string if command-line flag is missing"), check_flag_missing) & - ,test_description_t(string_t("argument_present() result is .false. if a command-line argument is missing"), check_argument_missing) & - ,test_description_t(string_t("argument_present() result is .true. if a command-line argument is present"), check_argument_present) & - ] -#else test_descriptions = [ & - test_description_t(string_t("flag_value() result is the value passed after a command-line flag"), check_flag_value_ptr) & - ,test_description_t(string_t("flag_value() result is an empty string if command-line flag value is missing"), check_flag_value_missing_ptr) & - ,test_description_t(string_t("flag_value() result is an empty string if command-line flag is missing"), check_flag_missing_ptr) & - ,test_description_t(string_t("argument_present() result is .false. if a command-line argument is missing"), check_argument_missing_ptr) & - ,test_description_t(string_t("argument_present() result is .true. if a command-line argument is present"), check_argument_present_ptr) & + test_description_t(string_t("flag_value() result is the value passed after a command-line flag"), bless(check_flag_value)) & + ,test_description_t(string_t("flag_value() result is an empty string if command-line flag value is missing"), bless(check_flag_value_missing)) & + ,test_description_t(string_t("flag_value() result is an empty string if command-line flag is missing"), bless(check_flag_missing)) & + ,test_description_t(string_t("argument_present() result is .false. if a command-line argument is missing"), bless(check_argument_missing)) & + ,test_description_t(string_t("argument_present() result is .true. if a command-line argument is present"), bless(check_argument_present)) & ] -#endif end if skip_all_tests_if_running_github_ci end associate image_number diff --git a/test/modules/formats_test_m.F90 b/test/modules/formats_test_m.F90 index 1c3db3656..5c28e5cf0 100644 --- a/test/modules/formats_test_m.F90 +++ b/test/modules/formats_test_m.F90 @@ -12,10 +12,8 @@ module formats_test_m ,test_description_t & ,test_diagnosis_t & ,test_result_t & + ,bless & ,test_t -#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY - use julienne_m, only : diagnosis_function_i -#endif implicit none @@ -40,33 +38,13 @@ function results() result(test_results) type(test_description_t), allocatable :: test_descriptions(:) type(formats_test_t) formats_test -#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY test_descriptions = [ & - test_description_t(string_t("yielding a comma-separated list of real numbers"), check_csv_reals), & - test_description_t(string_t("yielding a comma-separated list of double-precision numbers"), check_csv_double_precision), & - test_description_t(string_t("yielding a space-separated list of complex numbers"), check_space_separated_complex), & - test_description_t(string_t("yielding a comma- and space-separated list of character values"), check_csv_character), & - test_description_t(string_t("yielding a new-line-separated list of integer numbers"), check_new_line_separated_integers) & + test_description_t(string_t("yielding a comma-separated list of real numbers"), bless(check_csv_reals)), & + test_description_t(string_t("yielding a comma-separated list of double-precision numbers"), bless(check_csv_double_precision)), & + test_description_t(string_t("yielding a space-separated list of complex numbers"), bless(check_space_separated_complex)), & + test_description_t(string_t("yielding a comma- and space-separated list of character values"), bless(check_csv_character)), & + test_description_t(string_t("yielding a new-line-separated list of integer numbers"), bless(check_new_line_separated_integers)) & ] -#else - ! Work around missing Fortran 2008 feature: associating a procedure actual argument with a procedure pointer dummy argument: - procedure(diagnosis_function_i), pointer :: & - check_csv_reals_ptr, check_space_ptr, check_csv_char_ptr, check_new_line_ptr, check_csv_double_precision_ptr - - check_csv_reals_ptr => check_csv_reals - check_csv_double_precision_ptr => check_csv_double_precision - check_space_ptr => check_space_separated_complex - check_csv_char_ptr => check_csv_character - check_new_line_ptr => check_new_line_separated_integers - - test_descriptions = [ & - test_description_t(string_t("yielding a comma-separated list of real numbers"), check_csv_reals_ptr), & - test_description_t(string_t("yielding a comma-separated list of double-precision numbers"), check_csv_double_precision_ptr), & - test_description_t(string_t("yielding a space-separated list of complex numbers"), check_space_ptr), & - test_description_t(string_t("yielding a comma- and space-separated list of character values"), check_csv_char_ptr), & - test_description_t(string_t("yielding a new-line-separated list of integer numbers"), check_new_line_ptr) & - ] -#endif test_results = formats_test%run(test_descriptions) end function diff --git a/test/modules/string_test_m.F90 b/test/modules/string_test_m.F90 index b4f162401..88eae2c0c 100644 --- a/test/modules/string_test_m.F90 +++ b/test/modules/string_test_m.F90 @@ -12,6 +12,7 @@ module string_test_m ,test_result_t & ,test_description_t & ,test_diagnosis_t & + ,bless & ,string_t & ,operator(.all.) & ,operator(.also.) & @@ -21,9 +22,6 @@ module string_test_m ,operator(.equalsExpected.) & ,operator(.sv.) & ,operator(.within.) -#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY - use julienne_m, only : diagnosis_function_i -#endif implicit none @@ -48,103 +46,37 @@ function results() result(test_results) type(test_description_t), allocatable :: test_descriptions(:) type(string_test_t) string_test -#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY - test_descriptions = [ & - test_description_t("is_allocated() result .true. if & only if the string_t component(s) is/are allocated", check_allocation)& - ,test_description_t("extracting a key string from a colon-separated key/value pair", extracts_key)& - ,test_description_t("extracting double-precision value from colon-separated key/value pair", extracts_double_precision_value)& - ,test_description_t("extracting a real value from a colon-separated key/value pair", extracts_real_value)& - ,test_description_t("extracting a character value from a colon-separated key/value pair", extracts_character_value)& - ,test_description_t("extracting a string value from a colon-separated key/value pair", extracts_string_value)& - ,test_description_t("extracting an integer value from a colon-separated key/value pair", extracts_integer_value)& - ,test_description_t("extracting a logical value from a colon-separated key/value pair", extracts_logical_value)& - ,test_description_t("extracting an integer array value from a colon-separated key/value pair", extracts_integer_array_value)& - ,test_description_t("extracting an real array value from a colon-separated key/value pair", extracts_real_array_value)& - ,test_description_t("extracting a double-precision array from a colon-separated key/value pair", extracts_dp_array_value)& - ,test_description_t('supporting operator(==) for string_t and character operands', supports_equivalence_operator)& - ,test_description_t('supporting operator(/=) for string_t and character operands', supports_non_equivalence_operator)& - ,test_description_t('assigning a string_t object to a character variable', assigns_string_t_to_character)& - ,test_description_t('assigning a character variable to a string_t object', assigns_character_to_string_t)& - ,test_description_t('supporting operator(//) for string_t and character operands', supports_concatenation_operator)& - ,test_description_t('constructing from a default integer and an integer(c_size_t)', constructs_from_integers)& - ,test_description_t('constructing from a default real value', constructs_from_default_real)& - ,test_description_t('constructing from a double-precision value', constructs_from_double_precision)& - ,test_description_t('constructing from a default-precision complex value', constructs_from_default_complex)& - ,test_description_t('constructing from a default-kind logical value', constructs_from_default_logical)& - ,test_description_t('constructing from a logical(c_bool) value', constructs_from_logical_c_bool)& - ,test_description_t('extracting a file base name', extracts_file_base_name)& - ,test_description_t('extracting a file name extension', extracts_file_name_extension)& - ,test_description_t('supporting unary operator(.cat.) for array arguments', concatenates_elements)& - ,test_description_t('constructing bracketed strings', brackets_strings)& - ,test_description_t("extracting a string_t array value from a colon-separated key/value pair", extracts_string_array_value)& - ,test_description_t('constructing (comma-)separated values from character or string_t arrays', constructs_separated_values)& - ,test_description_t('constructing from a double-precision complex value', constructs_from_double_precision_complex)& - ] -#else - ! Work around missing Fortran 2008 feature: associating a procedure actual argument with a procedure pointer dummy argument: - procedure(diagnosis_function_i), pointer :: & - check_allocation_ptr => check_allocation & - ,extracts_key_ptr => extracts_key & - ,extracts_double_precision_value_ptr => extracts_double_precision_value & - ,extracts_real_value_ptr => extracts_real_value & - ,extracts_character_value_ptr => extracts_character_value & - ,extracts_string_value_ptr => extracts_string_value & - ,extracts_integer_value_ptr => extracts_integer_value & - ,extracts_logical_value_ptr => extracts_logical_value & - ,extracts_integer_array_value_ptr => extracts_integer_array_value & - ,extracts_real_array_value_ptr => extracts_real_array_value & - ,extracts_dp_array_value_ptr => extracts_dp_array_value & - ,supports_equivalence_operator_ptr => supports_equivalence_operator & - ,supports_non_equivalence_operator_ptr => supports_non_equivalence_operator & - ,assigns_string_t_to_character_ptr => assigns_string_t_to_character & - ,assigns_character_to_string_t_ptr => assigns_character_to_string_t & - ,supports_concatenation_operator_ptr => supports_concatenation_operator & - ,constructs_from_integers_ptr => constructs_from_integers & - ,constructs_from_default_real_ptr => constructs_from_default_real & - ,constructs_from_double_precision_ptr => constructs_from_double_precision & - ,constructs_from_default_complex_ptr => constructs_from_default_complex & - ,constructs_from_default_logical_ptr => constructs_from_default_logical & - ,constructs_from_logical_c_bool_ptr => constructs_from_logical_c_bool & - ,extracts_file_base_name_ptr => extracts_file_base_name & - ,extracts_file_name_extension_ptr => extracts_file_name_extension & - ,concatenates_elements_ptr => concatenates_elements & - ,brackets_strings_ptr => brackets_strings & - ,extracts_string_array_value_ptr => extracts_string_array_value & - ,constructs_separated_values_ptr => constructs_separated_values & - ,constructs_from_double_precision_complex_ptr => constructs_from_double_precision_complex - test_descriptions = [ & - test_description_t("is_allocated() result .true. if & only if the string_t component(s) is/are allocated", check_allocation_ptr)& - ,test_description_t("extracting a key string from a colon-separated key/value pair", extracts_key_ptr)& - ,test_description_t("extracting double-precision value from colon-separated key/value pair", extracts_double_precision_value_ptr)& - ,test_description_t("extracting a real value from a colon-separated key/value pair", extracts_real_value_ptr)& - ,test_description_t("extracting a character value from a colon-separated key/value pair", extracts_character_value_ptr)& - ,test_description_t("extracting a string value from a colon-separated key/value pair", extracts_string_value_ptr)& - ,test_description_t("extracting an integer value from a colon-separated key/value pair", extracts_integer_value_ptr)& - ,test_description_t("extracting a logical value from a colon-separated key/value pair", extracts_logical_value_ptr)& - ,test_description_t("extracting an integer array value from a colon-separated key/value pair", extracts_integer_array_value_ptr)& - ,test_description_t("extracting an real array value from a colon-separated key/value pair", extracts_real_array_value_ptr)& - ,test_description_t("extracting a double-precision array from a colon-separated key/value pair", extracts_dp_array_value_ptr)& - ,test_description_t('supporting operator(==) for string_t and character operands', supports_equivalence_operator_ptr)& - ,test_description_t('supporting operator(/=) for string_t and character operands', supports_non_equivalence_operator_ptr)& - ,test_description_t('assigning a string_t object to a character variable', assigns_string_t_to_character_ptr)& - ,test_description_t('assigning a character variable to a string_t object', assigns_character_to_string_t_ptr)& - ,test_description_t('supporting operator(//) for string_t and character operands', supports_concatenation_operator_ptr)& - ,test_description_t('constructing from a default integer and an integer(c_size_t)', constructs_from_integers_ptr)& - ,test_description_t('constructing from a default real value', constructs_from_default_real_ptr)& - ,test_description_t('constructing from a double-precision value', constructs_from_double_precision_ptr)& - ,test_description_t('constructing from a default-precision complex value', constructs_from_default_complex_ptr)& - ,test_description_t('constructing from a default-kind logical value', constructs_from_default_logical_ptr)& - ,test_description_t('constructing from a logical(c_bool) value', constructs_from_logical_c_bool_ptr)& - ,test_description_t('extracting a file base name', extracts_file_base_name_ptr)& - ,test_description_t('extracting a file name extension', extracts_file_name_extension_ptr)& - ,test_description_t('supporting unary operator(.cat.) for array arguments', concatenates_elements_ptr)& - ,test_description_t("extracting a string_t array value from a colon-separated key/value pair", extracts_string_array_value_ptr)& - ,test_description_t('constructing (comma-)separated values from character or string_t arrays', constructs_separated_values_ptr)& - ,test_description_t('constructing from a double-precision complex value', constructs_from_double_precision_complex_ptr)& - ,test_description_t('constructing bracketed strings', brackets_strings_ptr) & + test_description_t("is_allocated() result .true. if & only if the string_t component(s) is/are allocated", bless(check_allocation))& + ,test_description_t("extracting a key string from a colon-separated key/value pair", bless( extracts_key))& + ,test_description_t("extracting double-precision value from colon-separated key/value pair", bless(extracts_double_precision_value))& + ,test_description_t("extracting a real value from a colon-separated key/value pair", bless( extracts_real_value))& + ,test_description_t("extracting a character value from a colon-separated key/value pair", bless( extracts_character_value))& + ,test_description_t("extracting a string value from a colon-separated key/value pair", bless( extracts_string_value))& + ,test_description_t("extracting an integer value from a colon-separated key/value pair", bless( extracts_integer_value))& + ,test_description_t("extracting a logical value from a colon-separated key/value pair", bless( extracts_logical_value))& + ,test_description_t("extracting an integer array value from a colon-separated key/value pair", bless( extracts_integer_array_value))& + ,test_description_t("extracting an real array value from a colon-separated key/value pair", bless( extracts_real_array_value))& + ,test_description_t("extracting a double-precision array from a colon-separated key/value pair", bless( extracts_dp_array_value))& + ,test_description_t('supporting operator(==) for string_t and character operands', bless( supports_equivalence_operator))& + ,test_description_t('supporting operator(/=) for string_t and character operands', bless( supports_non_equivalence_operator))& + ,test_description_t('assigning a string_t object to a character variable', bless( assigns_string_t_to_character))& + ,test_description_t('assigning a character variable to a string_t object', bless( assigns_character_to_string_t))& + ,test_description_t('supporting operator(//) for string_t and character operands', bless( supports_concatenation_operator))& + ,test_description_t('constructing from a default integer and an integer(c_size_t)', bless( constructs_from_integers))& + ,test_description_t('constructing from a default real value', bless( constructs_from_default_real))& + ,test_description_t('constructing from a double-precision value', bless( constructs_from_double_precision))& + ,test_description_t('constructing from a default-precision complex value', bless( constructs_from_default_complex))& + ,test_description_t('constructing from a default-kind logical value', bless( constructs_from_default_logical))& + ,test_description_t('constructing from a logical(c_bool) value', bless( constructs_from_logical_c_bool))& + ,test_description_t('extracting a file base name', bless( extracts_file_base_name))& + ,test_description_t('extracting a file name extension', bless( extracts_file_name_extension))& + ,test_description_t('supporting unary operator(.cat.) for array arguments', bless( concatenates_elements))& + ,test_description_t('constructing bracketed strings', bless( brackets_strings))& + ,test_description_t("extracting a string_t array value from a colon-separated key/value pair", bless( extracts_string_array_value))& + ,test_description_t('constructing (comma-)separated values from character or string_t arrays', bless( constructs_separated_values))& + ,test_description_t('constructing from a double-precision complex value', bless( constructs_from_double_precision_complex))& ] -#endif test_results = string_test%run(test_descriptions) end function diff --git a/test/modules/test_description_test_m.F90 b/test/modules/test_description_test_m.F90 index 5b280b193..5b9c85e93 100644 --- a/test/modules/test_description_test_m.F90 +++ b/test/modules/test_description_test_m.F90 @@ -10,10 +10,8 @@ module test_description_test_m ,test_result_t & ,test_description_t & ,test_diagnosis_t & + ,bless & ,test_t -#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY - use julienne_m, only : diagnosis_function_i -#endif implicit none private @@ -37,38 +35,18 @@ function results() result(test_results) type(test_description_t), allocatable :: test_descriptions(:) type(test_description_test_t) test_description_test -#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY test_descriptions = [ & - test_description_t("identical construction from string_t or character argument", check_constructors_match) & + test_description_t("identical construction from string_t or character argument", bless(check_constructors_match)) & ] -#else - ! Work around missing Fortran 2008 feature: associating a procedure actual argument with a procedure pointer dummy argument: - procedure(diagnosis_function_i), pointer :: check_constructors_match_ptr - - check_constructors_match_ptr => check_constructors_match - test_descriptions = [ & - test_description_t("identical construction from string_t or character argument", check_constructors_match_ptr) & - ] -#endif test_results = test_description_test%run(test_descriptions) end function function check_constructors_match() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis -#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY test_diagnosis = test_diagnosis_t( & - test_passed = test_description_t("foo", tautology) == test_description_t(string_t("foo"), tautology) & + test_passed = test_description_t("foo", bless(tautology)) == test_description_t(string_t("foo"), bless(tautology)) & ,diagnostics_string = 'test_description_t("foo", tautology) /= test_description_t(string_t("foo"), tautology)' & ) -#else - procedure(diagnosis_function_i), pointer :: tautology_ptr - tautology_ptr => tautology - - test_diagnosis = test_diagnosis_t( & - test_passed = test_description_t("foo", tautology_ptr) == test_description_t(string_t("foo"), tautology_ptr) & - ,diagnostics_string= 'test_description_t("foo", tautology_ptr) /= test_description_t(string_t("foo"), tautology__ptr)'& - ) -#endif contains type(test_diagnosis_t) function tautology() tautology = test_diagnosis_t(.true.,"") diff --git a/test/modules/test_diagnosis_test_m.F90 b/test/modules/test_diagnosis_test_m.F90 index 83486fb07..408be2d24 100644 --- a/test/modules/test_diagnosis_test_m.F90 +++ b/test/modules/test_diagnosis_test_m.F90 @@ -12,6 +12,7 @@ module test_diagnosis_test_m ,test_description_t & ,test_diagnosis_t & ,test_result_t & + ,bless & ,operator(//) & ,operator(.all.) & ,operator(.also.) & @@ -28,9 +29,6 @@ module test_diagnosis_test_m ,operator(.isAtMost.) & ,operator(.greaterThan.) & ,operator(.isAtLeast.) -#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY - use julienne_m, only : diagnosis_function_i -#endif use iso_c_binding, only : c_ptr, c_loc, c_bool implicit none @@ -55,94 +53,34 @@ function results() result(test_results) type(test_description_t), allocatable :: test_descriptions(:) type(test_diagnosis_test_t) test_diagnosis_test -#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY test_descriptions = [ & - test_description_t("construction from the real expression 'x .approximates. y .within. tolerance'" , check_approximates_real) & - ,test_description_t("construction from the real expression 'x .approximates. y .withinFraction. tolerance'" , check_approximates_real_fraction) & - ,test_description_t("construction from the real expression 'x .approximates. y .withinPercentage. tolerance'" , check_approximates_real_percentage) & - ,test_description_t("construction from the real expression 'x .lessThan. y" , check_less_than_real) & - ,test_description_t("construction from the real expression 'x .greaterThan. y" , check_greater_than_real) & - ,test_description_t("construction from the double precision expression 'x .approximates. y .within. tolerance'" , check_approximates_double) & - ,test_description_t("construction from the double precision expression 'x .approximates. y .withinFraction. tolerance'" , check_approximates_double_fraction) & - ,test_description_t("construction from the double precision expression 'x .approximates. y .withinPercentage. tolerance'", check_approximates_double_percentage) & - ,test_description_t("construction from the double precision expression 'x .lessThan. y" , check_less_than_double) & - ,test_description_t("construction from the double precision expression 'x .greaterThan. y" , check_greater_than_double) & - ,test_description_t("construction from string_t/character expressions 'a .isBefore. b'" , check_alphabetical) & - ,test_description_t("construction from string_t/character expressions 'a .isAfter. b'" , check_reverse_alphabetical) & - ,test_description_t("construction from string_t/character expressions 'a .equalsExpected. b'" , check_equals_character_vs_string) & - ,test_description_t("construction from the character expression 'a .equalsExpected. b'" , check_equals_character) & - ,test_description_t("construction from the type(c_ptr) expression 'p .equalsExpected. q'" , check_equals_c_ptr) & - ,test_description_t("construction from the string_t expression 'a .equalsExpected. b'" , check_equals_string) & - ,test_description_t("construction from the integer expression 'i .equalsExpected. j'" , check_equals_integer) & - ,test_description_t("construction from the integer expression 'i .lessThan. j" , check_less_than_integer) & - ,test_description_t("construction from the integer expression '[i,j] .lessThanOrEqualTo. k" , check_less_than_or_equal_to_integer) & - ,test_description_t("construction from the integer expression 'i .greaterThan. j" , check_greater_than_integer) & - ,test_description_t("construction from the integer expression '[i,j] .greaterThanOrEqualTo. k" , check_greater_than_or_equal_to_integer) & - ,test_description_t("construction from the scalar test_diagnostics_t expression 't .and. u'" , check_and_with_scalar_operands) & - ,test_description_t("construction from the vector test_diagnostics_t expressions 'i .equalsExpected. [j,k]'" , check_and_with_vector_operands) & - ,test_description_t("construction from string concatenation" , check_string_concatentation) & - ,test_description_t("construction from character concatenation" , check_character_concatentation) & - ,test_description_t("construction from (.expects. logical-expression) // 'user-defined message'" , check_expects_logical) & + test_description_t("construction from the real expression 'x .approximates. y .within. tolerance'" , bless(check_approximates_real)) & + ,test_description_t("construction from the real expression 'x .approximates. y .withinFraction. tolerance'" , bless(check_approximates_real_fraction)) & + ,test_description_t("construction from the real expression 'x .approximates. y .withinPercentage. tolerance'" , bless(check_approximates_real_percentage)) & + ,test_description_t("construction from the real expression 'x .lessThan. y" , bless(check_less_than_real)) & + ,test_description_t("construction from the real expression 'x .greaterThan. y" , bless(check_greater_than_real)) & + ,test_description_t("construction from the double precision expression 'x .approximates. y .within. tolerance'" , bless(check_approximates_double)) & + ,test_description_t("construction from the double precision expression 'x .approximates. y .withinFraction. tolerance'" , bless(check_approximates_double_fraction)) & + ,test_description_t("construction from the double precision expression 'x .approximates. y .withinPercentage. tolerance'", bless(check_approximates_double_percentage)) & + ,test_description_t("construction from the double precision expression 'x .lessThan. y" , bless(check_less_than_double)) & + ,test_description_t("construction from the double precision expression 'x .greaterThan. y" , bless(check_greater_than_double)) & + ,test_description_t("construction from string_t/character expressions 'a .isBefore. b'" , bless(check_alphabetical)) & + ,test_description_t("construction from string_t/character expressions 'a .isAfter. b'" , bless(check_reverse_alphabetical)) & + ,test_description_t("construction from string_t/character expressions 'a .equalsExpected. b'" , bless(check_equals_character_vs_string)) & + ,test_description_t("construction from the character expression 'a .equalsExpected. b'" , bless(check_equals_character)) & + ,test_description_t("construction from the type(c_ptr) expression 'p .equalsExpected. q'" , bless(check_equals_c_ptr)) & + ,test_description_t("construction from the string_t expression 'a .equalsExpected. b'" , bless(check_equals_string)) & + ,test_description_t("construction from the integer expression 'i .equalsExpected. j'" , bless(check_equals_integer)) & + ,test_description_t("construction from the integer expression 'i .lessThan. j" , bless(check_less_than_integer)) & + ,test_description_t("construction from the integer expression '[i,j] .lessThanOrEqualTo. k" , bless(check_less_than_or_equal_to_integer)) & + ,test_description_t("construction from the integer expression 'i .greaterThan. j" , bless(check_greater_than_integer)) & + ,test_description_t("construction from the integer expression '[i,j] .greaterThanOrEqualTo. k" , bless(check_greater_than_or_equal_to_integer)) & + ,test_description_t("construction from the scalar test_diagnostics_t expression 't .and. u'" , bless(check_and_with_scalar_operands)) & + ,test_description_t("construction from the vector test_diagnostics_t expressions 'i .equalsExpected. [j,k]'" , bless(check_and_with_vector_operands)) & + ,test_description_t("construction from string concatenation" , bless(check_string_concatentation)) & + ,test_description_t("construction from character concatenation" , bless(check_character_concatentation)) & + ,test_description_t("construction from (.expects. logical-expression) // 'user-defined message'" , bless(check_expects_logical)) & ] -#else - ! Work around missing Fortran 2008 feature: associating a procedure actual argument with a procedure pointer dummy argument: - procedure(diagnosis_function_i), pointer :: & - check_approximates_real_ptr => check_approximates_real & - ,check_approximates_real_fraction_ptr => check_approximates_real_fraction & - ,check_approximates_real_percentage_ptr => check_approximates_real_percentage & - ,check_less_than_real_ptr => check_less_than_real & - ,check_greater_than_real_ptr => check_greater_than_real & - ,check_approximates_double_percentage_ptr => check_approximates_double_percentage & - ,check_approximates_double_ptr => check_approximates_double & - ,check_approximates_double_fraction_ptr => check_approximates_double_fraction & - ,check_less_than_double_ptr => check_less_than_double & - ,check_greater_than_double_ptr => check_greater_than_double & - ,check_equals_character_ptr => check_equals_character & - ,check_equals_c_ptr_ptr => check_equals_c_ptr & - ,check_equals_string_ptr => check_equals_string & - ,check_equals_character_vs_string_ptr => check_equals_character_vs_string & - ,check_reverse_alphabetical_ptr => check_reverse_alphabetical & - ,check_alphabetical_ptr => check_alphabetical & - ,check_equals_integer_ptr => check_equals_integer & - ,check_less_than_integer_ptr => check_less_than_integer & - ,check_less_than_or_equal_to_integer_ptr => check_less_than_or_equal_to_integer & - ,check_greater_than_integer_ptr => check_greater_than_integer & - ,check_greater_than_or_equal_to_integer_ptr => check_greater_than_or_equal_to_integer & - ,check_and_with_scalar_operands_ptr => check_and_with_scalar_operands & - ,check_and_with_vector_operands_ptr => check_and_with_vector_operands & - ,check_string_concatentation_ptr => check_string_concatentation & - ,check_character_concatentation_ptr => check_character_concatentation & - ,check_expects_logical_ptr => check_expects_logical - - test_descriptions = [ & - test_description_t("construction from the real expression 'x .approximates. y .within. tolerance'" , check_approximates_real_ptr) & - ,test_description_t("construction from the real expression 'x .approximates. y .withinFraction. tolerance'" , check_approximates_real_fraction_ptr) & - ,test_description_t("construction from the real expression 'x .approximates. y .withinPercentage. tolerance'" , check_approximates_real_percentage_ptr) & - ,test_description_t("construction from the real expression 'x .lessThan. y" , check_less_than_real_ptr) & - ,test_description_t("construction from the real expression 'x .greaterThan. y" , check_greater_than_real_ptr) & - ,test_description_t("construction from the double precision expression 'x .approximates. y .within. tolerance'" , check_approximates_double_ptr) & - ,test_description_t("construction from the double precision expression 'x .approximates. y .withinFraction. tolerance'" , check_approximates_double_fraction_ptr) & - ,test_description_t("construction from the double precision expression 'x .approximates. y .withinPercentage. tolerance'", check_approximates_double_percentage_ptr) & - ,test_description_t("construction from the double precision expression 'x .lessThan. y" , check_less_than_double_ptr) & - ,test_description_t("construction from the double precision expression 'x .greaterThan. y" , check_greater_than_double_ptr) & - ,test_description_t("construction from string_t/character expressions 'a .isBefore. b'" , check_alphabetical_ptr) & - ,test_description_t("construction from string_t/character expressions 'a .equalsExpected. b'" , check_equals_character_vs_string_ptr) & - ,test_description_t("construction from string_t/character expressions 'a .isAfter. b'" , check_reverse_alphabetical_ptr) & - ,test_description_t("construction from the character expression 'a .equalsExpected. b'" , check_equals_character_ptr) & - ,test_description_t("construction from the type(c_ptr) expression 'p .equalsExpected. q'" , check_equals_c_ptr_ptr) & - ,test_description_t("construction from the string_t expression 'a .equalsExpected. b'" , check_equals_string_ptr) & - ,test_description_t("construction from the integer expression 'i .equalsExpected. j" , check_equals_integer_ptr) & - ,test_description_t("construction from the integer expression 'i .lessThan. j" , check_less_than_integer_ptr) & - ,test_description_t("construction from the integer expression '[i,j] .lessThanOrEqualTo. k" , check_less_than_or_equal_to_integer_ptr) & - ,test_description_t("construction from the integer expression 'i .greaterThan. j" , check_greater_than_integer_ptr) & - ,test_description_t("construction from the integer expression '[i,j] .greaterThanOrEqualTo. k" , check_greater_than_or_equal_to_integer_ptr) & - ,test_description_t("construction from the scalar test_diagnostics_t expression 't .and. u'" , check_and_with_scalar_operands_ptr) & - ,test_description_t("construction from the vector test_diagnostics_t expressions 'i .equalsExpected. [j,k]'" , check_and_with_vector_operands_ptr) & - ,test_description_t("construction from string concatenation" , check_string_concatentation_ptr) & - ,test_description_t("construction from character concatenation" , check_character_concatentation_ptr) & - ,test_description_t("construction from (.expects. logical-expression) // 'user-defined message'" , check_expects_logical_ptr) & - ] -#endif test_results = test_diagnosis_test%run(test_descriptions) end function diff --git a/test/modules/test_result_test_m.F90 b/test/modules/test_result_test_m.F90 index d0a6eb2a9..c462eab65 100644 --- a/test/modules/test_result_test_m.F90 +++ b/test/modules/test_result_test_m.F90 @@ -8,13 +8,11 @@ module test_result_test_m use julienne_m, only : & operator(.expect.) & ,string_t & + ,bless & ,test_description_t & ,test_diagnosis_t & ,test_result_t & ,test_t -#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY - use julienne_m, only : diagnosis_function_i -#endif implicit none private @@ -38,18 +36,9 @@ function results() result(test_results) type(test_description_t), allocatable :: test_descriptions(:) type(test_result_test_t) test_result_test -#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY test_descriptions = [ & - test_description_t(string_t("constructing an array of test_result_t objects elementally"), check_array_result_construction) & + test_description_t(string_t("constructing an array of test_result_t objects elementally"), bless(check_array_result_construction)) & ] -#else - ! Work around missing Fortran 2008 feature: associating a procedure actual argument with a procedure pointer dummy argument: - procedure(diagnosis_function_i), pointer :: & - check_array_ptr => check_array_result_construction - test_descriptions = [ & - test_description_t(string_t("constructing an array of test_result_t objects elementally"), check_array_ptr) & - ] -#endif test_results = test_result_test%run(test_descriptions) end function diff --git a/test/modules/test_test_m.F90 b/test/modules/test_test_m.F90 index 7bd89eac4..b935e37de 100644 --- a/test/modules/test_test_m.F90 +++ b/test/modules/test_test_m.F90 @@ -7,13 +7,11 @@ module test_test_m !! Conditionally test that failure of a test on only one image is reported as a test failure use julienne_m, only : & operator(.expect.) & + ,bless & ,test_description_t & ,test_diagnosis_t & ,test_result_t & ,test_t -#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY - use julienne_m, only : diagnosis_function_i -#endif implicit none private @@ -32,32 +30,15 @@ pure function subject() result(specimen) specimen = "The test_t type" end function -#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY - - function results() result(test_results) - type(test_result_t), allocatable :: test_results(:) - type(test_test_t) test_test - - test_results = test_test%run([ & - test_description_t("reporting failure if a single image fails a test", check_one_image_fails) & - ]) - end function - -#else - function results() result(test_results) type(test_result_t), allocatable :: test_results(:) type(test_test_t) test_test - procedure(diagnosis_function_i), pointer :: & - check_one_image_fails_ptr => check_one_image_fails test_results = test_test%run([ & - test_description_t("reporting failure if a single image fails a test", check_one_image_fails_ptr) & + test_description_t("reporting failure if a single image fails a test", bless(check_one_image_fails)) & ]) end function -#endif - function check_one_image_fails() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis