poly_function: correct and return status to C++

Author: scivision

src/poly_function/c_interface_poly.f90

@@ -3,12 +3,19 @@ module c_interface_poly
 !! from https://github.com/mattzett/fortran_tests
 
   use datamod_poly, only: dataobj_poly,data1,data2
-  use, intrinsic :: iso_c_binding, only: c_loc,c_ptr,c_f_pointer,c_int, c_float, c_size_t
+  use, intrinsic :: iso_c_binding, only: c_loc,c_ptr,c_f_pointer,c_int, c_float, c_size_t, c_null_ptr, c_associated
   implicit none
 
+  integer(c_int), parameter :: STATUS_SUCCESS = 0_c_int
+  integer(c_int), parameter :: STATUS_INVALID_TYPE = 1_c_int
+  integer(c_int), parameter :: STATUS_NULL_PTR = 2_c_int
+  integer(c_int), parameter :: STATUS_ZERO_DIMS = 3_c_int
+  integer(c_int), parameter :: STATUS_ALLOC_FAIL = 4_c_int
+  integer(c_int), parameter :: STATUS_BAD_OBJECT_PTR = 5_c_int
+
 contains
 
-subroutine objconstruct_C(objtype,cptr_f90obj,cptr_indata,lx,ly) bind(C, name='objconstruct_C')
+integer(c_int) function objconstruct_C(objtype,cptr_f90obj,cptr_indata,lx,ly) bind(C, name='objconstruct_C')
 !! return a c pointer to a fortran polymorphic object that is created by this routine; in this case we
 !! are passing the object type to be created from the C main program
   integer(c_int), intent(in) :: objtype
@@ -19,24 +26,44 @@ subroutine objconstruct_C(objtype,cptr_f90obj,cptr_indata,lx,ly) bind(C, name='o
   type(data1), pointer :: tmpobj1    !< declared as pointers so they don't auto-allocate when we return
   type(data2), pointer :: tmpobj2    !< ditto
   real(c_float), dimension(:,:), pointer :: fortdata
+  integer :: alloc_status
 
   !> nullify for sake of clarity and good practice
   nullify(tmpobj1, tmpobj2)
+  objconstruct_C = STATUS_SUCCESS
+  cptr_f90obj = c_null_ptr
+
+  if (.not. c_associated(cptr_indata)) then
+    objconstruct_C = STATUS_NULL_PTR
+    return
+  end if
+
+  if (lx == 0_c_size_t .or. ly == 0_c_size_t) then
+    objconstruct_C = STATUS_ZERO_DIMS
+    return
+  end if
 
   !> allocate derived type, note that c_loc only works on a static type (i.e. not polymorphic class), hence the tmpobj's
   select case (objtype)
     case (1)
-      allocate(data1::obj)
-      allocate(tmpobj1)
+      allocate(tmpobj1, stat=alloc_status)
+      if (alloc_status /= 0) then
+        objconstruct_C = STATUS_ALLOC_FAIL
+        return
+      end if
       cptr_f90obj=c_loc(tmpobj1)
       obj=>tmpobj1
     case (2)
-      allocate(data2::obj)
-      allocate(tmpobj2)
+      allocate(tmpobj2, stat=alloc_status)
+      if (alloc_status /= 0) then
+        objconstruct_C = STATUS_ALLOC_FAIL
+        return
+      end if
       cptr_f90obj=c_loc(tmpobj2)
       obj=>tmpobj2
     case default
-      error stop 'unable to identify object type during construction'
+      objconstruct_C = STATUS_INVALID_TYPE
+      return
   end select
 
   !> initialize some test data, and call methods to print
@@ -45,53 +72,87 @@ subroutine objconstruct_C(objtype,cptr_f90obj,cptr_indata,lx,ly) bind(C, name='o
   call obj%set_data(fortdata)
 
   !! note lack of deallocate and nullify here; we need memory allocated to persist past the return.
-end subroutine objconstruct_C
+end function objconstruct_C
 
 
 !> Use some of the polymorphic object methods and data
-subroutine objuse_C(objtype,objC) bind(C, name='objuse_C')
+integer(c_int) function objuse_C(objtype,objC) bind(C, name='objuse_C')
   type(c_ptr), intent(in) :: objC
   integer(c_int), intent(in) :: objtype
   class(dataobj_poly),pointer :: obj
+  integer(c_int) :: status
+
+  objuse_C = STATUS_SUCCESS
+  if (.not. c_associated(objC)) then
+    objuse_C = STATUS_NULL_PTR
+    return
+  end if
+
+  call set_pointer_dyntype(objtype,objC,obj,status)
+  if (status /= 0) then
+    objuse_C = status
+    return
+  end if
 
-  obj=>set_pointer_dyntype(objtype,objC)
   call obj%print_data()
-end subroutine objuse_C
+end function objuse_C
 
 
 !> set fortran object pointer dynamic type to what is indicated in objtype.  Convert C pointer using
 !    declared static types (c_f_pointer will not work on a polymorphic object).
-function set_pointer_dyntype(objtype, objC) result(obj)
+subroutine set_pointer_dyntype(objtype, objC, obj, status)
   type(c_ptr), intent(in) :: objC
   integer(c_int), intent(in) :: objtype
-  class(dataobj_poly), pointer :: obj
+  class(dataobj_poly), pointer, intent(out) :: obj
+  integer(c_int), intent(out) :: status
   type(data1), pointer :: obj1
   type(data2), pointer :: obj2
 
+  status = STATUS_SUCCESS
+  nullify(obj)
+  nullify(obj1, obj2)
+
   select case (objtype)
     case (1)
       call c_f_pointer(objC,obj1)
+      if (.not. associated(obj1)) then
+        status = STATUS_BAD_OBJECT_PTR
+        return
+      end if
       obj=>obj1
     case (2)
       call c_f_pointer(objC,obj2)
+      if (.not. associated(obj2)) then
+        status = STATUS_BAD_OBJECT_PTR
+        return
+      end if
       obj=>obj2
     case default
-      error stop 'ERROR: set_pointer_dyntype: unable to identify object type during conversion from C to fortran class pointer'
+      status = STATUS_INVALID_TYPE
   end select
-end function set_pointer_dyntype
+end subroutine set_pointer_dyntype
 
 
-subroutine destruct_C(objtype, objC) bind(C, name='destruct_C')
+integer(c_int) function destruct_C(objtype, objC) bind(C, name='destruct_C')
 type(c_ptr), intent(inout) :: objC
 integer(c_int), intent(in) :: objtype
 
 class(dataobj_poly),pointer :: obj
+integer(c_int) :: status
+
+destruct_C = STATUS_SUCCESS
+if (.not. c_associated(objC)) return
 
-obj=>set_pointer_dyntype(objtype,objC)
+call set_pointer_dyntype(objtype,objC,obj,status)
+if (status /= 0) then
+  destruct_C = status
+  return
+end if
 
-deallocate(obj%dataval)
+if (associated(obj%dataval)) deallocate(obj%dataval)
 deallocate(obj)
+objC = c_null_ptr
 
-end subroutine
+end function destruct_C
 
 end module c_interface_poly

src/poly_function/datamod_poly.f90

@@ -36,10 +36,29 @@ module datamod_poly
 subroutine set_data(self,array)
   class(dataobj_poly), intent(inout) :: self
   real(c_float), dimension(:,:), intent(in) :: array
-
-  self%lx=size(array,1)
-  self%ly=size(array,2)
-  allocate(self%dataval(self%lx,self%ly))
+  integer(c_int) :: nx, ny
+  integer(c_int) :: dealloc_status, alloc_status
+
+  nx = size(array,1)
+  ny = size(array,2)
+
+  ! Reuse existing allocation when shape matches to avoid churn.
+  if (associated(self%dataval)) then
+    if (size(self%dataval,1) == nx .and. size(self%dataval,2) == ny) then
+      self%lx = nx
+      self%ly = ny
+      self%dataval(:,:) = array(:,:)
+      return
+    end if
+    deallocate(self%dataval, stat=dealloc_status)
+    if (dealloc_status /= 0) return
+  end if
+
+  allocate(self%dataval(nx,ny), stat=alloc_status)
+  if (alloc_status /= 0) return
+
+  self%lx = nx
+  self%ly = ny
   self%dataval(:,:)=array(:,:)
 end subroutine set_data
 

src/poly_function/my_polyfcn.h

@@ -1,10 +1,12 @@
+#include <stddef.h>
+
 #ifdef __cplusplus
 extern "C" {
 #endif
 
-void objconstruct_C(int*, void**, float**, const size_t*, const size_t*);
-void objuse_C(int*, void*);
-void destruct_C(int*, void**);
+int objconstruct_C(int*, void**, float**, const size_t*, const size_t*);
+int objuse_C(int*, void**);
+int destruct_C(int*, void**);
 
 #ifdef __cplusplus
 }

test/poly_function/main.cpp

@@ -1,31 +1,46 @@
 // C++ calling polymorphic Fortran object
 // based on https://github.com/mattzett/fortran_tests
+// objconstruct_C returns status code:
+// 0: success
+// 1: invalid object type
+// 2: null C pointer input
+// 3: zero dimensions in constructor
+// 4: allocation failure
+// 5: invalid/stale object pointer
 #include <array>
 #include <iostream>
 #include <cstdlib>
 
 #include "my_polyfcn.h"
 
-
 int main() {
 
  // pointers for various fortran data
-void* objptr1;
-void* objptr2;
+void* objptr1 = nullptr;
+void* objptr2 = nullptr;
 int objtype;
 float* arrptr;
+int status;
 
 const size_t lx1=2;
 const size_t ly1=2;
 
-// Object 1`
+// Object 1
 objtype=1;
 std::array<float, lx1*ly1> x1;
 x1 = {1, 2, 3, 4};
 arrptr = &x1.front();
-objconstruct_C(&objtype, &objptr1, &arrptr, &lx1, &ly1);
+status = objconstruct_C(&objtype, &objptr1, &arrptr, &lx1, &ly1);
+if (status != 0) {
+  std::cerr << "objconstruct_C failed for object 1 with status " << status << "\n";
+  return EXIT_FAILURE;
+}
 std::cout << "Use object 1\n";
-objuse_C(&objtype, &objptr1);
+status = objuse_C(&objtype, &objptr1);
+if (status != 0) {
+  std::cerr << "objuse_C failed for object 1 with status " << status << "\n";
+  return EXIT_FAILURE;
+}
 
 // Object 2
 objtype=2;
@@ -34,21 +49,112 @@ const size_t ly2=3;
 std::array<float, lx2*ly2> x2;
 x2 = {6,5,4,3,2,1};
 arrptr = &x2.front();
-objconstruct_C(&objtype, &objptr2, &arrptr, &lx2, &ly2);
+status = objconstruct_C(&objtype, &objptr2, &arrptr, &lx2, &ly2);
+if (status != 0) {
+  std::cerr << "objconstruct_C failed for object 2 with status " << status << "\n";
+  return EXIT_FAILURE;
+}
 std::cout << "Use object 2\n";
-objuse_C(&objtype,&objptr2);
+status = objuse_C(&objtype, &objptr2);
+if (status != 0) {
+  std::cerr << "objuse_C failed for object 2 with status " << status << "\n";
+  return EXIT_FAILURE;
+}
 
 // show that objects persist
 std::cout << "Use object 1 again\n";
 objtype=1;
-objuse_C(&objtype, &objptr1);
+status = objuse_C(&objtype, &objptr1);
+if (status != 0) {
+  std::cerr << "objuse_C failed when reusing object 1 with status " << status << "\n";
+  return EXIT_FAILURE;
+}
 
 std::cout << "Use object 2 again\n";
 objtype=2;
-objuse_C(&objtype, &objptr2);
+status = objuse_C(&objtype, &objptr2);
+if (status != 0) {
+	std::cerr << "objuse_C failed when reusing object 2 with status " << status << "\n";
+	return EXIT_FAILURE;
+}
+
+// Negative-path checks for C ABI status behavior.
+int invalid_objtype = 999;
+status = objuse_C(&invalid_objtype, &objptr1);
+if (status != 1) {
+	std::cerr << "Expected invalid objtype status 1 from objuse_C, got " << status << "\n";
+	return EXIT_FAILURE;
+}
+
+void* null_obj = nullptr;
+status = objuse_C(&objtype, &null_obj);
+if (status != 2) {
+	std::cerr << "Expected null pointer status 2 from objuse_C, got " << status << "\n";
+	return EXIT_FAILURE;
+}
+
+void* bad_construct_ptr = nullptr;
+size_t zero_dim = 0;
+objtype = 1;
+status = objconstruct_C(&objtype, &bad_construct_ptr, &arrptr, &zero_dim, &ly1);
+if (status != 3) {
+	std::cerr << "Expected zero-dimension status 3 from objconstruct_C, got " << status << "\n";
+	return EXIT_FAILURE;
+}
+
+objtype = 999;
+status = objconstruct_C(&objtype, &bad_construct_ptr, &arrptr, &lx1, &ly1);
+if (status != 1) {
+	std::cerr << "Expected invalid objtype status 1 from objconstruct_C, got " << status << "\n";
+	return EXIT_FAILURE;
+}
+
+// Stress the object lifecycle repeatedly.
+for (int iter = 0; iter < 100; ++iter) {
+	void* loop_obj = nullptr;
+	objtype = (iter % 2) + 1;
+	size_t loop_lx = (objtype == 1) ? lx1 : lx2;
+	size_t loop_ly = (objtype == 1) ? ly1 : ly2;
+	arrptr = (objtype == 1) ? &x1.front() : &x2.front();
+
+	status = objconstruct_C(&objtype, &loop_obj, &arrptr, &loop_lx, &loop_ly);
+	if (status != 0) {
+		std::cerr << "Lifecycle loop construct failed at iteration " << iter << " with status " << status << "\n";
+		return EXIT_FAILURE;
+	}
+
+	     status = objuse_C(&objtype, &loop_obj);
+	if (status != 0) {
+		std::cerr << "Lifecycle loop use failed at iteration " << iter << " with status " << status << "\n";
+		return EXIT_FAILURE;
+	}
+
+	status = destruct_C(&objtype, &loop_obj);
+	if (status != 0) {
+		std::cerr << "Lifecycle loop destruct failed at iteration " << iter << " with status " << status << "\n";
+		return EXIT_FAILURE;
+	}
+}
+
+objtype=1;
+status = destruct_C(&objtype, &objptr1);
+if (status != 0) {
+	std::cerr << "destruct_C failed for object 1 with status " << status << "\n";
+	return EXIT_FAILURE;
+}
+objtype=2;
+status = destruct_C(&objtype, &objptr2);
+if (status != 0) {
+	std::cerr << "destruct_C failed for object 2 with status " << status << "\n";
+	return EXIT_FAILURE;
+}
 
-destruct_C(&objtype, &objptr1);
-destruct_C(&objtype, &objptr2);
+// Double-destroy should be harmless because destruct_C ignores null pointers.
+status = destruct_C(&objtype, &objptr2);
+if (status != 0) {
+	std::cerr << "Expected success from double destruct, got status " << status << "\n";
+	return EXIT_FAILURE;
+}
 
 return EXIT_SUCCESS;
 }