Add unit tests for stack unwinding

Author: lionel-

inst/unitTests/cpp/misc.cpp

@@ -224,3 +224,37 @@ String testNullableString(Rcpp::Nullable<Rcpp::String> param = R_NilValue) {
   else
     return String("");
 }
+
+// Class that indicates to R caller whether C++ stack was unwound
+struct unwindIndicator {
+    unwindIndicator(LogicalVector indicator_) {
+        // Reset the indicator to FALSE
+        indicator = indicator_;
+        *LOGICAL(indicator) = 0;
+    }
+
+    // Set indicator to TRUE when stack unwinds
+    ~unwindIndicator() {
+        *LOGICAL(indicator) = 1;
+    }
+
+    LogicalVector indicator;
+};
+
+// [[Rcpp::export]]
+SEXP testEvalUnwindImpl(RObject expr, Environment env, LogicalVector indicator) {
+    unwindIndicator my_data(indicator);
+    return Rcpp::Rcpp_fast_eval(expr, env);
+}
+
+// [[Rcpp::export]]
+SEXP testLongjumpException() {
+    throw Rcpp::internal::LongjumpException(R_NilValue);
+    return R_NilValue;
+}
+
+// [[Rcpp::export]]
+SEXP testSendInterrupt() {
+  Rf_onintr();
+  return R_NilValue;
+}

inst/unitTests/runit.misc.R

@@ -214,4 +214,55 @@ if (.runThisTest) {
         checkTrue(nchar(Rcpp:::bib()) > 0, msg="bib file")
     }
 
+    test.stackUnwinds <- function() {
+        # On old versions of R, Rcpp_fast_eval() falls back to Rcpp_eval() and
+        # leaks on longjumps
+        hasUnwind <- getRversion() >= "3.5.0"
+        checkUnwound <- if (hasUnwind) checkTrue else function(x) checkTrue(!x)
+        testEvalUnwind <- function(expr, indicator) {
+            testEvalUnwindImpl(expr, parent.frame(), indicator)
+        }
+
+        # On errors - Always unwound
+        unwound <- FALSE
+        out <- tryCatch(testEvalUnwind(quote(stop("err")), unwound), error = identity)
+        checkTrue(unwound)
+        msg <- if (hasUnwind) "err" else "Evaluation error: err."
+        checkIdentical(out$message, msg)
+
+        # On interrupts - Always unwound
+        unwound <- FALSE
+        expr <- quote({
+            repeat testSendInterrupt()
+            "returned"
+        })
+        out <- tryCatch(testEvalUnwind(expr, unwound), interrupt = function(c) "onintr")
+        checkTrue(unwound)
+        checkIdentical(out, "onintr")
+
+        # On caught conditions
+        unwound <- FALSE
+        expr <- quote(signalCondition(simpleCondition("cnd")))
+        cnd <- tryCatch(testEvalUnwind(expr, unwound), condition = identity)
+        checkTrue(inherits(cnd, "simpleCondition"))
+        checkUnwound(unwound)
+
+        # On restart jumps
+        unwound <- FALSE
+        expr <- quote(invokeRestart("rst"))
+        out <- withRestarts(testEvalUnwind(expr, unwound), rst = function(...) "restarted")
+        checkIdentical(out, "restarted")
+        checkUnwound(unwound)
+
+        # On returns
+        unwound <- FALSE
+        expr <- quote(signalCondition(simpleCondition(NULL)))
+        out <- callCC(function(k)
+            withCallingHandlers(testEvalUnwind(expr, unwound),
+                simpleCondition = function(e) k("jumped")
+            )
+        )
+        checkIdentical(out, "jumped")
+        checkUnwound(unwound)
+    }
 }