Fix R memory leak on exception

There is a possible memory leak in case the SWIG_exception_fail macro
is called. The problem is related to its definition that call the
function Rf_warning. This function (as well as Rf_error) involves
a longjmp over C++ destructors on the stack. Thus, all the objects
allocated on the heap are not freed.

Closes #914

Examples/test-suite/r/Makefile.in

@@ -18,6 +18,7 @@ C_TEST_CASES += \
 
 CPP_TEST_CASES += \
 	r_double_delete \
+	r_memory_leak \
 	r_overload_array \
 	r_sexp \
         r_overload_comma \

Examples/test-suite/r/r_memory_leak_runme.R

@@ -0,0 +1,26 @@
+clargs <- commandArgs(trailing=TRUE)
+source(file.path(clargs[1], "unittest.R"))
+
+dyn.load(paste("r_memory_leak", .Platform$dynlib.ext, sep=""))
+source("r_memory_leak.R")
+cacheMetaData(1)
+
+a <- Foo();
+unittest(Foo_get_count(), 1);
+b <- Foo();
+unittest(Foo_get_count(), 2);
+
+# Normal behaviour
+invisible(trigger_internal_swig_exception("no problem", a));
+unittest(Foo_get_count(), 2);
+# SWIG exception introduced
+result <- tryCatch({
+  trigger_internal_swig_exception("null", b);
+}, warning = function(w) {
+  # print("        Hum... We received a warning, but this should be an error");
+  unittest(1,0);
+}, error = function(e) {
+  # print("        Gotcha!");
+  unittest(1,1);
+})
+unittest(Foo_get_count(), 2);

Examples/test-suite/r_memory_leak.i

@@ -0,0 +1,40 @@
+%module r_memory_leak
+
+%include <std_string.i>
+
+%typemap(in) Foo* foo
+{
+  $1 = new Foo;
+}
+%typemap(freearg) Foo* foo
+{
+  printf("    \"        Object deleted\"\n");
+  delete $1;
+}
+%typemap(out) Foo* verify_no_memory_leak
+{
+  if ($1 == NULL)
+    SWIG_exception_fail(SWIG_RuntimeError, "Let's see how the bindings manage this exception!");
+}
+%typemap(scoerceout) Foo*
+  %{ if (!is.null($result) && !is.logical($result)) {$result <- new("$R_class", ref=$result) ;} %}
+
+%inline %{
+  #include <string>
+
+  class Foo {
+      static unsigned count;
+    public:
+      Foo() { ++count; }
+      ~Foo() { --count; }
+      static unsigned get_count() { return count; }
+  };
+
+  unsigned Foo::count = 0;
+
+  static Foo* trigger_internal_swig_exception(const std::string& message, Foo* foo)
+  {
+    return (message == "null") ? NULL : foo;
+  };
+
+%}

Lib/r/rfragments.swg

@@ -1,7 +1,3 @@
-#define SWIG_Error(code, msg) Rf_warning(msg); return Rf_ScalarLogical(NA_LOGICAL)
-
-#define SWIG_fail return Rf_ScalarLogical(NA_LOGICAL)
-
 /* for raw pointers */
 #define SWIG_ConvertPtr(oc, ptr, ty, flags)             SWIG_R_ConvertPtr(oc, ptr, ty, flags)
 #define SWIG_ConvertFunctionPtr(oc, ptr, ty)            SWIG_R_ConvertPtr(oc, ptr, ty, 0)

Lib/r/rrun.swg

@@ -1,3 +1,46 @@
+#include <stdarg.h> // va_list, va_start, va_end
+#include <stdio.h> // vsnprintf
+
+/* Last error */
+static int SWIG_lasterror_code = 0;
+static char SWIG_lasterror_msg[1024];
+SWIGRUNTIME void SWIG_Error(int code, const char *format, ...) {
+  va_list arg;
+  SWIG_lasterror_code = code;
+  va_start(arg, format);
+  vsnprintf(SWIG_lasterror_msg, sizeof(SWIG_lasterror_msg), format, arg);
+  va_end(arg);
+}
+
+SWIGRUNTIME const char* SWIG_ErrorType(int code) {
+  switch (code) {
+  case SWIG_MemoryError:
+    return "SWIG:MemoryError";
+  case SWIG_IOError:
+    return "SWIG:IOError";
+  case SWIG_RuntimeError:
+    return "SWIG:RuntimeError";
+  case SWIG_IndexError:
+    return "SWIG:IndexError";
+  case SWIG_TypeError:
+    return "SWIG:TypeError";
+  case SWIG_DivisionByZero:
+    return "SWIG:DivisionByZero";
+  case SWIG_OverflowError:
+    return "SWIG:OverflowError";
+  case SWIG_SyntaxError:
+    return "SWIG:SyntaxError";
+  case SWIG_ValueError:
+    return "SWIG:ValueError";
+  case SWIG_SystemError:
+    return "SWIG:SystemError";
+  case SWIG_AttributeError:
+    return "SWIG:AttributeError";
+  }
+  return "SWIG:UnknownError";
+}
+
+#define SWIG_fail goto fail
 
 /* Remove global namespace pollution */
 #if !defined(SWIG_NO_R_NO_REMAP)

Source/Modules/r.cxx

@@ -1985,7 +1985,9 @@ int R::functionWrapper(Node *n) {
   for (p = l; p;) {
     if ((tm = Getattr(p, "tmap:freearg"))) {
       Replaceall(tm, "$source", Getattr(p, "lname"));
-      Printv(cleanup, tm, "\n", NIL);
+      if (tm && (Len(tm) != 0)) {
+        Printv(cleanup, tm, "\n", NIL);
+      }
       p = Getattr(p, "tmap:freearg:next");
     } else {
       p = nextSibling(p);
@@ -2066,8 +2068,10 @@ int R::functionWrapper(Node *n) {
   }
 
   /* Output cleanup code */
-  Printv(f->code, cleanup, NIL);
-  Delete(cleanup);
+  int need_cleanup = Len(cleanup) != 0;
+  if (need_cleanup) {
+    Printv(f->code, cleanup, NIL);
+  }
 
   /* Look to see if there is any newfree cleanup code */
   if (GetFlag(n, "feature:new")) {
@@ -2124,7 +2128,18 @@ int R::functionWrapper(Node *n) {
   if (destructor)
     Printv(f->code, "R_ClearExternalPtr(self);\n", NIL);
 
-  Printv(f->code, "return r_ans;\n}\n", NIL);
+  Printv(f->code, "return r_ans;\n", NIL);
+  
+  /* Error handling code */
+  Printv(f->code, "fail: SWIGUNUSED;\n", NIL);
+  if (need_cleanup) {
+    Printv(f->code, cleanup, NIL);
+  }
+  Printv(f->code, "  Rf_error(\"%s %s\", SWIG_ErrorType(SWIG_lasterror_code), SWIG_lasterror_msg);\n", NIL);
+  Printv(f->code, "  return R_NilValue;\n", NIL);
+  Delete(cleanup);
+  
+  Printv(f->code, "}\n", NIL);
   Printv(sfun->code, "\n}", NIL);
 
   /* Substitute the function name */