|
20 | 20 |
|
21 | 21 | #include <Rcpp/Interrupt.h> |
22 | 22 |
|
23 | | -namespace Rcpp{ |
24 | | - |
25 | | - struct EvalCall { |
26 | | - SEXP expr; |
27 | | - SEXP env; |
28 | | - SEXP result; |
29 | | - std::vector<std::string> warnings; |
30 | | - bool error_occurred; |
31 | | - std::string error_message; |
32 | | - }; |
33 | | - |
34 | | - inline void Rcpp_eval(void* data) { |
35 | | - |
36 | | - EvalCall* evalCall = (EvalCall*)data; |
37 | | - SEXP env = evalCall->env; |
38 | | - |
39 | | - Shield<SEXP> expr(evalCall->expr) ; |
40 | | - |
41 | | - Environment RCPP = Environment::Rcpp_namespace(); |
42 | | - SEXP withCallingHandlersSym = ::Rf_install("withCallingHandlers"); |
43 | | - SEXP tryCatchSym = ::Rf_install("tryCatch"); |
44 | | - SEXP evalqSym = ::Rf_install("evalq"); |
45 | | - SEXP conditionMessageSym = ::Rf_install("conditionMessage"); |
46 | | - SEXP errorRecorderSym = ::Rf_install(".rcpp_error_recorder"); |
47 | | - SEXP warningRecorderSym = ::Rf_install(".rcpp_warning_recorder"); |
48 | | - SEXP collectWarningsSym = ::Rf_install(".rcpp_collect_warnings"); |
49 | | - SEXP errorSym = ::Rf_install("error"); |
50 | | - SEXP warningSym = ::Rf_install("warning"); |
51 | | - |
52 | | - // define the tryCatchCall |
53 | | - Shield<SEXP> tryCatchCall( Rf_lang3( |
54 | | - tryCatchSym, |
55 | | - Rf_lang3( evalqSym, expr, env ), |
56 | | - errorRecorderSym |
57 | | - ) ) ; |
58 | | - SET_TAG( CDDR(tryCatchCall), errorSym ) ; |
59 | | - |
60 | | - // encose it in withCallingHandlers |
61 | | - Shield<SEXP> call( Rf_lang3( |
62 | | - withCallingHandlersSym, |
63 | | - tryCatchCall, |
64 | | - warningRecorderSym |
65 | | - ) ) ; |
66 | | - SET_TAG( CDDR(call), warningSym ) ; |
67 | | - |
68 | | - // execute the call |
69 | | - Shield<SEXP> res(::Rf_eval( call, RCPP ) ); |
| 23 | +namespace Rcpp { |
| 24 | + |
| 25 | +inline SEXP Rcpp_eval(SEXP expr, SEXP env) { |
| 26 | + |
| 27 | + // 'identity' function used to capture errors, interrupts |
| 28 | + SEXP identity = Rf_findFun( |
| 29 | + ::Rf_install("identity"), |
| 30 | + R_BaseNamespace |
| 31 | + ); |
| 32 | + |
| 33 | + if (identity == R_UnboundValue) { |
| 34 | + stop("Failed to find 'base::identity()'"); |
| 35 | + } |
70 | 36 |
|
71 | | - // collect warnings |
72 | | - Shield<SEXP> warningCall(Rf_lang1(collectWarningsSym)); |
73 | | - Shield<SEXP> warnings(::Rf_eval(warningCall, RCPP)); |
| 37 | + // define the evalq call -- the actual R evaluation we |
| 38 | + // want to execute |
| 39 | + Shield<SEXP> evalqCall(Rf_lang3( |
| 40 | + ::Rf_install("evalq"), |
| 41 | + expr, |
| 42 | + env |
| 43 | + )); |
| 44 | + |
| 45 | + // define the call -- enclose with `tryCatch` so we can record |
| 46 | + // and later forward error messages |
| 47 | + Shield<SEXP> call(Rf_lang4( |
| 48 | + ::Rf_install("tryCatch"), |
| 49 | + evalqCall, |
| 50 | + identity, |
| 51 | + identity |
| 52 | + )); |
| 53 | + SET_TAG(CDDR(call), ::Rf_install("error")); |
| 54 | + SET_TAG(CDDDR(call), ::Rf_install("interrupt")); |
| 55 | + |
| 56 | + // execute the call |
| 57 | + Shield<SEXP> res(::Rf_eval(call, R_GlobalEnv)); |
| 58 | + |
| 59 | + // check for condition results (errors, interrupts) |
| 60 | + if (Rf_inherits(res, "condition")) { |
74 | 61 |
|
75 | | - evalCall->warnings = Rcpp::as<std::vector<std::string> >(warnings); |
76 | | - |
77 | | - // check for error |
78 | | - if( error_occured() ) { |
79 | | - Shield<SEXP> current_error ( rcpp_get_current_error() ) ; |
80 | | - Shield<SEXP> conditionMessageCall (::Rf_lang2(conditionMessageSym, current_error)) ; |
81 | | - Shield<SEXP> condition_message (::Rf_eval(conditionMessageCall, R_GlobalEnv)) ; |
82 | | - evalCall->error_occurred = true; |
83 | | - evalCall->error_message = std::string(CHAR(::Rf_asChar(condition_message))); |
84 | | - } else { |
85 | | - evalCall->error_occurred = false; |
86 | | - evalCall->result = res; |
| 62 | + if (Rf_inherits(res, "error")) { |
| 63 | + |
| 64 | + Shield<SEXP> conditionMessageCall(::Rf_lang2( |
| 65 | + ::Rf_install("conditionMessage"), |
| 66 | + res |
| 67 | + )); |
| 68 | + |
| 69 | + Shield<SEXP> conditionMessage(::Rf_eval(conditionMessageCall, R_GlobalEnv)); |
| 70 | + throw eval_error(CHAR(STRING_ELT(conditionMessage, 0))); |
87 | 71 | } |
88 | 72 |
|
89 | | - reset_current_error() ; |
90 | | - |
91 | | - } |
92 | | - |
93 | | - inline SEXP Rcpp_eval(SEXP expr_, SEXP env) { |
94 | | - |
95 | | - // create the call object |
96 | | - EvalCall call; |
97 | | - call.expr = expr_; |
98 | | - call.env = env; |
99 | | - |
100 | | - // execute it |
101 | | - Rboolean completed = R_ToplevelExec(Rcpp_eval, (void*)&call); |
102 | | - |
103 | | - // print warnings |
104 | | - for (size_t i = 0; i<call.warnings.size(); i++) |
105 | | - Rf_warning(call.warnings[i].c_str()); |
106 | | - |
107 | | - // handle error or result if it completed, else throw interrupt |
108 | | - if (completed) { |
109 | | - if (call.error_occurred) |
110 | | - throw eval_error(call.error_message); |
111 | | - else |
112 | | - return call.result; |
113 | | - } else { |
| 73 | + // check for interrupt |
| 74 | + if (Rf_inherits(res, "interrupt")) { |
114 | 75 | throw internal::InterruptedException(); |
115 | 76 | } |
| 77 | + |
116 | 78 | } |
117 | | - |
| 79 | + |
| 80 | + return res; |
118 | 81 | } |
119 | 82 |
|
| 83 | +} // namespace Rcpp |
| 84 | + |
120 | 85 | #endif |
0 commit comments