Add callback test

Author: sethrj

Examples/test-suite/fortran/fortran_callback_runme.F90

@@ -0,0 +1,75 @@
+! File : fortran_callback_runme.F90
+
+#include "fassert.h"
+
+module fortran_callback_mod
+  use, intrinsic :: ISO_C_BINDING
+  use ISO_FORTRAN_ENV
+  implicit none
+  integer, parameter :: STDOUT = OUTPUT_UNIT
+  integer(C_INT), save, public :: module_int
+contains
+
+function myexp(left, right) bind(C) &
+    result(fresult)
+  use, intrinsic :: ISO_C_BINDING
+  integer(C_INT), intent(in), value :: left
+  integer(C_INT), intent(in), value :: right
+  integer(C_INT) :: fresult
+
+  fresult = left ** right
+end function
+  
+function mywrite() bind(C) &
+    result(fresult)
+  use, intrinsic :: ISO_C_BINDING
+  integer(C_INT) :: fresult
+  ! write(STDOUT,*) "Hi there"
+  fresult = 256_c_int
+end function
+
+subroutine store_an_int(i) bind(C)
+  use, intrinsic :: ISO_C_BINDING
+  integer(C_INT), value, intent(in) :: i
+  ! write(STDOUT,*) "Got an integer: ", i
+  module_int = i
+end subroutine
+  
+end module
+
+program fortran_callback_runme
+  call test_callback
+contains
+
+subroutine test_callback
+  use fortran_callback
+  use fortran_callback_mod
+  integer(C_INT) :: i
+  procedure(call_binary_cb), pointer :: unused => NULL()
+  procedure(binary_op), pointer :: bin_op_ptr => NULL()
+
+  ! Use callbacks with Fortran module pointers
+  bin_op_ptr => myexp
+  i = call_binary(myexp, 2, 3)
+  ASSERT(i == 8)
+  i = call_things(mywrite)
+  ASSERT(i == 256)
+  call also_call_things(store_an_int, 999)
+  ASSERT(module_int == 999)
+
+  ! Get a C callback
+  bin_op_ptr => get_a_callback("mul")
+  ASSERT(associated(bin_op_ptr))
+  ASSERT(bin_op_ptr(2, 5) == 10)
+
+  bin_op_ptr => get_a_callback("add")
+  ASSERT(associated(bin_op_ptr))
+  ASSERT(bin_op_ptr(2, 5) == 7)
+
+  bin_op_ptr => get_a_callback("nopenope")
+  ASSERT(.not. associated(bin_op_ptr))
+
+end subroutine
+end program
+
+

Examples/test-suite/fortran_callback.i

@@ -27,7 +27,7 @@ extern "C" {
 #endif
 
 int add(int left, int right) { return left + right; }
-int mul(int left, int right) { return left - right; }
+int mul(int left, int right) { return left * right; }
 
 #ifdef __cplusplus
 } // end extern
@@ -39,6 +39,11 @@ int mul(int left, int right) { return left - right; }
 // Declare callback signature *and* create function with wrapper
 %fortrancallback("%s_cb") call_binary;
 
+%{
+#include <string.h>
+#include <stdio.h>
+%}
+
 %inline %{
 #ifdef __cplusplus
 extern "C" {
@@ -62,5 +67,15 @@ typedef void (*one_int_cb)(int);
 void also_call_things(one_int_cb fptr, int val)
 { return (*fptr)(val); }
 
+binary_op_cb get_a_callback(const char* name) {
+  if (strcmp(name, "add") == 0) {
+    return &add;
+  } if (strcmp(name, "mul") == 0) {
+    return &mul;
+  }
+  printf("Invalid callback name '%s'\n", name);
+  return NULL;
+}
+
 %}