add poly type example

Author: scivision

src/cxx/CMakeLists.txt

@@ -10,6 +10,10 @@ add_executable(cpp_opaque opaque_main.cxx)
 target_link_libraries(cpp_opaque PRIVATE opaque_fortran)
 add_test(NAME C++_Fortran_opaque COMMAND cpp_opaque)
 
+add_executable(cpp_poly_type poly_type_main.cpp)
+target_link_libraries(cpp_poly_type PRIVATE poly_type_fortran)
+add_test(NAME C++_Fortran_poly_type COMMAND cpp_poly_type)
+
 add_executable(cpp_poly_fcn poly_fcn_main.cpp)
 target_link_libraries(cpp_poly_fcn PRIVATE poly_fcn_fortran)
 add_test(NAME C++_Fortran_poly_fcn COMMAND cpp_poly_fcn)

src/cxx/poly_type_main.cpp

@@ -0,0 +1,45 @@
+#include <iostream>
+
+extern "C" void init_type(int*, void**);
+extern "C" void add_one_C(int*, void**, int*, int*);
+
+
+int main(){
+
+  void* x3;
+  void* x4;
+  int xtype=3;
+  int A, C;
+
+  xtype = 3;
+  init_type(&xtype, &x3);
+
+  add_one_C(&xtype, &x3, &A, &C);
+  if(A != 4) {
+    std::cerr << "Error: " << A << " != 4" << std::endl;
+    return EXIT_FAILURE;
+  }
+  std::cout << "C:3 = " << C << std::endl;
+  add_one_C(&xtype, &x3, &A, &C);
+  std::cout << "C:3 = " << C << std::endl;
+  add_one_C(&xtype, &x3, &A, &C);
+  std::cout << "C:3 = " << C << std::endl;
+
+  xtype = 4;
+  init_type(&xtype, &x4);
+
+  add_one_C(&xtype, &x4, &A, &C);
+  if(A != 5) {
+    std::cerr << "Error: " << A << " != 5" << std::endl;
+    return EXIT_FAILURE;
+  }
+  std::cout << "C:4 = " << C << std::endl;
+  add_one_C(&xtype, &x4, &A, &C);
+  std::cout << "C:4 = " << C << std::endl;
+  add_one_C(&xtype, &x4, &A, &C);
+  std::cout << "C:4 = " << C << std::endl;
+
+  std::cout << "OK: poly_type" << std::endl;
+
+  return EXIT_SUCCESS;
+}

src/fortran/CMakeLists.txt

@@ -8,6 +8,8 @@ add_library(error_fortran OBJECT error_lib.f90)
 
 add_library(pointer_fortran OBJECT pointer_lib.f90)
 
+add_library(poly_type_fortran OBJECT poly_type_lib.f90)
+
 add_library(poly_fcn_fortran OBJECT poly_data_lib.f90 poly_fcn_lib.f90)
 
 add_library(struct_fortran OBJECT struct_lib.f90)

src/fortran/poly_type_lib.f90

@@ -0,0 +1,110 @@
+module poly_type
+
+use, intrinsic :: iso_c_binding, only : C_PTR, c_loc, c_int, c_f_pointer
+
+implicit none (type, external)
+
+type, abstract :: base
+integer(c_int) :: A, C
+end type base
+
+type, extends(base) :: vthree
+  integer(c_int) :: B = 3
+end type vthree
+
+type, extends(base) :: vfour
+  integer(c_int) :: B = 4
+end type vfour
+
+contains
+
+
+subroutine init_type(xtype, xC) bind(C)
+  integer(c_int) :: xtype
+  type(C_PTR), intent(inout) :: xC
+
+  class(base), pointer :: x
+  type(vthree), pointer :: three
+  type(vfour), pointer :: four
+
+  select case (xtype)
+  case (3)
+    allocate(three)
+    xC = c_loc(three)
+    x=>three
+  case (4)
+    allocate(four)
+    xC = c_loc(four)
+    x=>four
+  case default
+    error stop "unknown init type"
+  end select
+
+end subroutine init_type
+
+
+function assoc_type(xtype, xC) result(x)
+  integer(c_int) :: xtype
+  type(C_PTR), intent(inout) :: xC
+
+  class(base), pointer :: x
+  type(vthree), pointer :: three
+  type(vfour), pointer :: four
+
+  select case (xtype)
+  case (3)
+    call c_f_pointer(xC, three)
+    x=>three
+  case (4)
+    call c_f_pointer(xC, four)
+    x=>four
+  case default
+    error stop "unknown assoc type"
+  end select
+
+end function assoc_type
+
+
+subroutine add_one_C(xtype, xC, val, accum) bind(C, name='add_one_C')
+  integer(c_int), intent(in) :: xtype
+  type(C_PTR), intent(inout) :: xC
+  integer(c_int), intent(out) :: val, accum
+
+  class(base), pointer :: x
+
+
+  x => assoc_type(xtype, xC)
+
+  select type (x)
+  type is (vthree)
+    call add_one3(x)
+  type is (vfour)
+    call add_one4(x)
+  class default
+    error stop "unknown add type"
+  end select
+
+  val = x%A
+  accum = x%C
+
+end subroutine add_one_C
+
+
+subroutine add_one3(x)
+  class(vthree), intent(inout) :: x
+
+  x%A = x%B + 1
+
+  x%C = x%C + x%A
+end subroutine add_one3
+
+subroutine add_one4(x)
+  class(vfour), intent(inout) :: x
+
+  x%A = x%B + 1
+
+  x%C = x%C + x%A
+end subroutine add_one4
+
+
+end module poly_type