test_description_t Bless workaround

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

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

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.) &

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.)

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
 

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

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