Merge pull request #323 from RcppCore/feature/eval-no-calling-handlers

remove calling handlers from Rcpp_eval

Author: jjallaire

inst/include/Rcpp/api/meat/Rcpp_eval.h

@@ -20,101 +20,66 @@
 
 #include <Rcpp/Interrupt.h>
 
-namespace Rcpp{
-
-    struct EvalCall {
-        SEXP expr;
-        SEXP env;
-        SEXP result;
-        std::vector<std::string> warnings;
-        bool error_occurred;
-        std::string error_message;
-    };
-
-    inline void Rcpp_eval(void* data) {
-
-        EvalCall* evalCall = (EvalCall*)data;
-        SEXP env = evalCall->env;
-
-        Shield<SEXP> expr(evalCall->expr) ;
-
-        Environment RCPP = Environment::Rcpp_namespace();
-        SEXP withCallingHandlersSym    = ::Rf_install("withCallingHandlers");
-        SEXP tryCatchSym               = ::Rf_install("tryCatch");
-        SEXP evalqSym                  = ::Rf_install("evalq");
-        SEXP conditionMessageSym       = ::Rf_install("conditionMessage");
-        SEXP errorRecorderSym          = ::Rf_install(".rcpp_error_recorder");
-        SEXP warningRecorderSym        = ::Rf_install(".rcpp_warning_recorder");
-        SEXP collectWarningsSym        = ::Rf_install(".rcpp_collect_warnings");
-        SEXP errorSym                  = ::Rf_install("error");
-        SEXP warningSym                = ::Rf_install("warning");
-
-        // define the tryCatchCall
-        Shield<SEXP> tryCatchCall( Rf_lang3(
-            tryCatchSym,
-            Rf_lang3( evalqSym, expr, env ),
-            errorRecorderSym
-        ) ) ;
-        SET_TAG( CDDR(tryCatchCall), errorSym ) ;
-
-        // encose it in withCallingHandlers
-        Shield<SEXP> call( Rf_lang3(
-            withCallingHandlersSym,
-            tryCatchCall,
-            warningRecorderSym
-        ) ) ;
-        SET_TAG( CDDR(call), warningSym ) ;
-
-        // execute the call
-        Shield<SEXP> res(::Rf_eval( call, RCPP ) );
+namespace Rcpp {
+
+inline SEXP Rcpp_eval(SEXP expr, SEXP env) {
+
+    // 'identity' function used to capture errors, interrupts
+    SEXP identity = Rf_findFun(
+        ::Rf_install("identity"),
+        R_BaseNamespace
+    );
+    
+    if (identity == R_UnboundValue) {
+        stop("Failed to find 'base::identity()'");
+    }
 
-        // collect warnings
-        Shield<SEXP> warningCall(Rf_lang1(collectWarningsSym));
-        Shield<SEXP> warnings(::Rf_eval(warningCall, RCPP));
+    // define the evalq call -- the actual R evaluation we
+    // want to execute
+    Shield<SEXP> evalqCall(Rf_lang3(
+        ::Rf_install("evalq"),
+        expr,
+        env
+    ));
+    
+    // define the call -- enclose with `tryCatch` so we can record
+    // and later forward error messages
+    Shield<SEXP> call(Rf_lang4(
+        ::Rf_install("tryCatch"),
+        evalqCall,
+        identity,
+        identity
+    ));
+    SET_TAG(CDDR(call), ::Rf_install("error"));
+    SET_TAG(CDDDR(call), ::Rf_install("interrupt"));
+
+    // execute the call
+    Shield<SEXP> res(::Rf_eval(call, R_GlobalEnv));
+
+    // check for condition results (errors, interrupts)
+    if (Rf_inherits(res, "condition")) {
 
-        evalCall->warnings = Rcpp::as<std::vector<std::string> >(warnings);
-
-        // check for error
-        if( error_occured() ) {
-            Shield<SEXP> current_error        ( rcpp_get_current_error() ) ;
-            Shield<SEXP> conditionMessageCall (::Rf_lang2(conditionMessageSym, current_error)) ;
-            Shield<SEXP> condition_message    (::Rf_eval(conditionMessageCall, R_GlobalEnv)) ;
-            evalCall->error_occurred = true;
-            evalCall->error_message = std::string(CHAR(::Rf_asChar(condition_message)));
-        } else {
-            evalCall->error_occurred = false;
-            evalCall->result = res;
+        if (Rf_inherits(res, "error")) {
+            
+            Shield<SEXP> conditionMessageCall(::Rf_lang2(
+                    ::Rf_install("conditionMessage"),
+                    res
+            ));
+            
+            Shield<SEXP> conditionMessage(::Rf_eval(conditionMessageCall, R_GlobalEnv));
+            throw eval_error(CHAR(STRING_ELT(conditionMessage, 0)));
         }
 
-        reset_current_error() ;
-
-    }
-
-    inline SEXP Rcpp_eval(SEXP expr_, SEXP env) {
-
-        // create the call object
-        EvalCall call;
-        call.expr = expr_;
-        call.env = env;
-
-        // execute it
-        Rboolean completed = R_ToplevelExec(Rcpp_eval, (void*)&call);
-
-        // print warnings
-        for (size_t i = 0; i<call.warnings.size(); i++)
-            Rf_warning(call.warnings[i].c_str());
-
-        // handle error or result if it completed, else throw interrupt
-        if (completed) {
-            if (call.error_occurred)
-                throw eval_error(call.error_message);
-            else
-                return call.result;
-        } else {
+        // check for interrupt
+        if (Rf_inherits(res, "interrupt")) {
             throw internal::InterruptedException();
         }
+        
     }
-
+    
+    return res;
 }
 
+} // namespace Rcpp
+
 #endif

inst/include/RcppCommon.h

@@ -28,6 +28,9 @@
 
 #include <Rcpp/r/headers.h>
 
+// Override 'Rf_error' so that we can catch errors
+#define Rf_error Rcpp::stop
+
 /**
  * \brief Rcpp API
  */