diff --git a/src/julienne/julienne_test_result_m.f90 b/src/julienne/julienne_test_result_m.f90 index 885aa7b7..709f6db4 100644 --- a/src/julienne/julienne_test_result_m.f90 +++ b/src/julienne/julienne_test_result_m.f90 @@ -11,12 +11,14 @@ module julienne_test_result_m type test_result_t !! Encapsulate test descriptions and outcomes private - type(string_t) description_ + character(len=:), allocatable :: description_ logical passed_ contains procedure :: characterize procedure :: passed - procedure :: description_contains + generic :: description_contains => description_contains_string, description_contains_characters + procedure, private :: description_contains_string + procedure, private :: description_contains_characters end type interface test_result_t @@ -55,7 +57,7 @@ impure elemental module function passed(self) result(test_passed) logical test_passed end function - elemental module function description_contains(self, substring) result(substring_found) + elemental module function description_contains_string(self, substring) result(substring_found) !! The result is true if and only if the test description contains the substring implicit none class(test_result_t), intent(in) :: self @@ -63,6 +65,14 @@ elemental module function description_contains(self, substring) result(substring logical substring_found end function + elemental module function description_contains_characters(self, substring) result(substring_found) + !! The result is true if and only if the test description contains the substring + implicit none + class(test_result_t), intent(in) :: self + character(len=*), intent(in) :: substring + logical substring_found + end function + end interface end module julienne_test_result_m diff --git a/src/julienne/julienne_test_result_s.f90 b/src/julienne/julienne_test_result_s.f90 index b9d091df..48ea16de 100644 --- a/src/julienne/julienne_test_result_s.f90 +++ b/src/julienne/julienne_test_result_s.f90 @@ -17,7 +17,7 @@ end procedure module procedure characterize - characterization = trim(merge("passes on ", "FAILS on ", self%passed_)) // " " // trim(self%description_%string()) // "." + characterization = trim(merge("passes on ", "FAILS on ", self%passed_)) // " " // trim(self%description_) // "." end procedure module procedure passed @@ -25,8 +25,12 @@ call co_all(test_passed) end procedure - module procedure description_contains - substring_found = index(self%description_%string(), substring%string()) /= 0 + module procedure description_contains_string + substring_found = index(self%description_, substring%string()) /= 0 + end procedure + + module procedure description_contains_characters + substring_found = index(self%description_, substring) /= 0 end procedure end submodule julienne_test_result_s diff --git a/test/test_description_test.F90 b/test/test_description_test.F90 index ec32f928..25aa2fb1 100644 --- a/test/test_description_test.F90 +++ b/test/test_description_test.F90 @@ -5,7 +5,14 @@ module test_description_test_m !! Verify test_description_t object behavior - use julienne_m, only : string_t, test_result_t, test_description_t, test_t, test_description_substring + use julienne_m, only : & + string_t & + ,test_result_t & + ,test_description_t & + ,test_t & + ,test_description_substring & + ,vector_test_description_t & + ,vector_function_strategy_t #if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY use julienne_m, only : test_function_i #endif @@ -20,6 +27,11 @@ module test_description_test_m procedure, nopass :: results end type + type, extends(vector_function_strategy_t) :: substring_search_test_function_t + contains + procedure, nopass :: vector_function => check_substring_search + end type + contains pure function subject() result(specimen) @@ -28,28 +40,63 @@ pure function subject() result(specimen) end function function results() result(test_results) - type(test_result_t), allocatable :: test_results(:) - type(test_description_t), allocatable :: test_descriptions(:) + type(test_result_t), allocatable :: test_results(:), vector_test_results(:) + type(test_description_t), allocatable :: scalar_test_descriptions(:) + type(vector_test_description_t), allocatable :: vector_test_descriptions(:) + type(substring_search_test_function_t) substring_search_test_function #if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY - test_descriptions = [ & + scalar_test_descriptions = [ & test_description_t("identical construction from string_t or character arguments", check_character_constructor) & ] #else ! Work around missing Fortran 2008 feature: associating a procedure actual argument with a procedure pointer dummy argument: procedure(test_function_i), pointer :: check_character_ptr check_character_ptr => check_character_constructor - test_descriptions = [ & + scalar_test_descriptions = [ & test_description_t("identical construction from string_t or character arguments", check_character_ptr) & ] #endif + + vector_test_descriptions = [ & + vector_test_description_t( & + [ string_t("finding a string_t substring in a test description") & + ,string_t("finding an assumed-length character substring in a test description") & + ,string_t("not finding a missing string_t substring in a test description") & + ,string_t("not finding a missing assumed-length character substring in a test description") & + ], substring_search_test_function & + ) & + ] + associate( & substring_in_subject => index(subject(), test_description_substring) /= 0, & - substring_in_description => test_descriptions%contains_text(string_t(test_description_substring)) & + substring_in_description => scalar_test_descriptions%contains_text(string_t(test_description_substring)), & + num_vector_tests => size(vector_test_descriptions) & ) - test_descriptions = pack(test_descriptions, substring_in_subject .or. substring_in_description) + scalar_test_descriptions = pack(scalar_test_descriptions, substring_in_subject .or. substring_in_description) + + block + integer i + + associate( & + substring_in_description_vector => & + [(any(vector_test_descriptions(i)%contains_text(test_description_substring)), i=1,num_vector_tests)] & + ) + if (substring_in_subject) then + vector_test_results = [(vector_test_descriptions(i)%run(), i=1,num_vector_tests)] + else if (any(substring_in_description_vector)) then + vector_test_descriptions = pack(vector_test_descriptions, substring_in_description_vector) + vector_test_results = [(vector_test_descriptions(i)%run(), i=1,size(vector_test_descriptions))] + vector_test_results = & + pack(vector_test_results, vector_test_results%description_contains(string_t(test_description_substring))) + else + vector_test_results = [test_result_t::] + end if + test_results = [scalar_test_descriptions%run(), vector_test_results] + end associate + end block end associate - test_results = test_descriptions%run() + end function function check_character_constructor() result(passed) @@ -67,4 +114,36 @@ logical function tautology() end function end function + function check_substring_search() result(tests_pass) + logical, allocatable :: tests_pass(:) + type(test_description_t), allocatable :: test_descriptions(:) + +#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + + procedure(test_function_i), pointer :: null_ptr + null_ptr => null() + + test_descriptions = [ & + test_description_t("an example substring" , null_ptr) & + ,test_description_t("another example substring", null_ptr) & + ,test_description_t("moving right along" , null_ptr) & + ,test_description_t("nothing to see here" , null_ptr) & + ] +#else + + test_descriptions = [ & + test_description_t("an example substring" , null()) & + ,test_description_t("another example substring", null()) & + ,test_description_t("moving right along" , null()) & + ,test_description_t("nothing to see here" , null()) & + ] +#endif + tests_pass = [ & + test_descriptions(1)%contains_text(string_t("example") ) & + , test_descriptions(2)%contains_text( "example" ) & + ,.not. test_descriptions(3)%contains_text(string_t("missing string")) & + ,.not. test_descriptions(4)%contains_text( "missing string" ) & + ] + end function + end module test_description_test_m