Fix memory leak in R shared_ptr wrappers

Fix leak when a cast up a class inheritance chain is
required.

Adds implementation of SWIG_ConvertPtrAndOwn for R.

Closes #2386

4 files changed, 36 insertions, 22 deletions

diff --git a/CHANGES.current b/CHANGES.current
index 5cba21e33..0af67c484 100644
--- a/CHANGES.current
+++ b/CHANGES.current
@@ -7,3 +7,7 @@ the issue number to the end of the URL: https://github.com/swig/swig/issues/
 Version 4.1.1 (in progress)
 ===========================
 
+2022-10-26: wsfulton
+            [R] #2386 Fix memory leak in R shared_ptr wrappers.
+            Fix leak when a cast up a class inheritance chain is required.
+
diff --git a/Examples/test-suite/r/li_boost_shared_ptr_runme.R b/Examples/test-suite/r/li_boost_shared_ptr_runme.R
index 607d008c0..1f7507337 100644
--- a/Examples/test-suite/r/li_boost_shared_ptr_runme.R
+++ b/Examples/test-suite/r/li_boost_shared_ptr_runme.R
@@ -80,8 +80,8 @@ testSuite <- function() {
     testSuite_verifyCount(2, kret)
   }
 
+  # pass by shared_ptr pointer reference
   {
-    # pass by shared_ptr pointer reference
     k = Klass("me oh my")
     kret = smartpointerpointerreftest(k)
     val = kret$getValue()
@@ -312,8 +312,8 @@ testSuite <- function() {
     kret = smartpointertest(k)
     val = kret$getValue()
     unittest("me oh my smartpointertest-Derived", val)
-    #testSuite_verifyCount(2, k)
-    #testSuite_verifyCount(2, kret)
+    testSuite_verifyCount(2, k)
+    testSuite_verifyCount(2, kret)
   }
 
   # pass by shared_ptr pointer (mixed)
@@ -322,8 +322,8 @@ testSuite <- function() {
     kret = smartpointerpointertest(k)
     val = kret$getValue()
     unittest("me oh my smartpointerpointertest-Derived", val)
-    #testSuite_verifyCount(2, k)
-    #testSuite_verifyCount(2, kret)
+    testSuite_verifyCount(2, k)
+    testSuite_verifyCount(2, kret)
   }
 
   # pass by shared_ptr reference (mixed)
@@ -332,8 +332,8 @@ testSuite <- function() {
     kret = smartpointerreftest(k)
     val = kret$getValue()
     unittest("me oh my smartpointerreftest-Derived", val)
-    #testSuite_verifyCount(2, k)
-    #testSuite_verifyCount(2, kret)
+    testSuite_verifyCount(2, k)
+    testSuite_verifyCount(2, kret)
   }
 
   # pass by shared_ptr pointer reference (mixed)
@@ -342,8 +342,8 @@ testSuite <- function() {
     kret = smartpointerpointerreftest(k)
     val = kret$getValue()
     unittest("me oh my smartpointerpointerreftest-Derived", val)
-    #testSuite_verifyCount(2, k)
-    #testSuite_verifyCount(2, kret)
+    testSuite_verifyCount(2, k)
+    testSuite_verifyCount(2, kret)
   }
 
   # pass by value (mixed)
@@ -352,8 +352,8 @@ testSuite <- function() {
     kret = valuetest(k)
     val = kret$getValue()
     unittest("me oh my valuetest", val)  # note slicing
-    #testSuite_verifyCount(1, k)
-    #testSuite_verifyCount(1, kret)
+    testSuite_verifyCount(1, k)
+    testSuite_verifyCount(1, kret)
   }
 
   # pass by pointer (mixed)
@@ -362,8 +362,8 @@ testSuite <- function() {
     kret = pointertest(k)
     val = kret$getValue()
     unittest("me oh my pointertest-Derived", val)
-    #testSuite_verifyCount(1, k)
-    #testSuite_verifyCount(1, kret)
+    testSuite_verifyCount(1, k)
+    testSuite_verifyCount(1, kret)
   }
 
   # pass by ref (mixed)
@@ -372,8 +372,8 @@ testSuite <- function() {
     kret = reftest(k)
     val = kret$getValue()
     unittest("me oh my reftest-Derived", val)
-    #testSuite_verifyCount(1, k)
-    #testSuite_verifyCount(1, kret)
+    testSuite_verifyCount(1, k)
+    testSuite_verifyCount(1, kret)
   }
 
 
@@ -420,7 +420,7 @@ testSuite <- function() {
     testSuite_verifyCount(1, k)
     val = test3rdupcast(k)
     unittest("me oh my-3rdDerived", val)
-#    testSuite_verifyCount(1, k)
+    testSuite_verifyCount(1, k)
   }
 
   #
diff --git a/Lib/r/rrun.swg b/Lib/r/rrun.swg
index 798446128..3ffc02f28 100644
--- a/Lib/r/rrun.swg
+++ b/Lib/r/rrun.swg
@@ -15,8 +15,9 @@ extern "C" {
 #endif
 
 /* for raw pointer */
+#define SWIG_R_ConvertPtr(obj, pptr, type, flags)       SWIG_R_ConvertPtrAndOwn(obj, pptr, type, flags, 0)
 #define SWIG_ConvertPtr(obj, pptr, type, flags)         SWIG_R_ConvertPtr(obj, pptr, type, flags)
-#define SWIG_ConvertPtrAndOwn(obj,pptr,type,flags,own)  SWIG_R_ConvertPtr(obj, pptr, type, flags)
+#define SWIG_ConvertPtrAndOwn(obj,pptr,type,flags,own)  SWIG_R_ConvertPtrAndOwn(obj, pptr, type, flags, own)
 #define SWIG_NewPointerObj(ptr, type, flags)            SWIG_R_NewPointerObj(ptr, type, flags)
 
 #include <stdio.h>
@@ -314,9 +315,11 @@ SWIG_R_NewPointerObj(void *ptr, swig_type_info *type, int flags) {
 
 /* Convert a pointer value */
 SWIGRUNTIMEINLINE int
-SWIG_R_ConvertPtr(SEXP obj, void **ptr, swig_type_info *ty, int flags) {
+SWIG_R_ConvertPtrAndOwn(SEXP obj, void **ptr, swig_type_info *ty, int flags, int *own) {
   void *vptr;
   if (!obj) return SWIG_ERROR;
+  if (own)
+    *own = 0;
   if (obj == R_NilValue) {
     if (ptr) *ptr = NULL;
     return (flags & SWIG_POINTER_NO_NULL) ? SWIG_NullReferenceError : SWIG_OK;
@@ -331,8 +334,15 @@ SWIG_R_ConvertPtr(SEXP obj, void **ptr, swig_type_info *ty, int flags) {
     } else {
       swig_cast_info *tc = SWIG_TypeCheck(to->name,ty);
       int newmemory = 0;
-      if (ptr) *ptr = SWIG_TypeCast(tc,vptr,&newmemory);
-      assert(!newmemory); /* newmemory handling not yet implemented */
+      if (ptr) {
+        int newmemory = 0;
+        *ptr = SWIG_TypeCast(tc, vptr, &newmemory);
+        if (newmemory == SWIG_CAST_NEW_MEMORY) {
+          assert(own); /* badly formed typemap which will lead to a memory leak - it must set and use own to delete *ptr */
+          if (own)
+            *own = *own | SWIG_CAST_NEW_MEMORY;
+        }
+      }
     }
   } else {
       if (ptr) *ptr = vptr;
diff --git a/Lib/r/std_vector.i b/Lib/r/std_vector.i
index 62478fe6a..98840c5dc 100644
--- a/Lib/r/std_vector.i
+++ b/Lib/r/std_vector.i
@@ -544,7 +544,7 @@
   struct traits_asptr < std::vector<T> > {
     static int asptr(SEXP obj, std::vector<T> **val) {
       std::vector<T> *p;
-      int res = SWIG_R_ConvertPtr(obj, (void**)&p, type_info< std::vector<T> >(), 0);
+      int res = SWIG_ConvertPtr(obj, (void**)&p, type_info< std::vector<T> >(), 0);
       if (SWIG_IsOK(res)) {
         if (val) *val = p;
       }
@@ -827,7 +827,7 @@
     static int asptr(SEXP obj, std::vector< std::vector<T> > **val) {
       std::vector< std::vector<T> > *p;
       Rprintf("vector of vectors - unsupported content\n");
-      int res = SWIG_R_ConvertPtr(obj, (void**)&p, type_info< std::vector< std::vector<T> > > (), 0);
+      int res = SWIG_ConvertPtr(obj, (void**)&p, type_info< std::vector< std::vector<T> > > (), 0);
       if (SWIG_IsOK(res)) {
         if (val) *val = p;
       }