1 // Copyright (C) 2013 Romain Francois
2 //
3 // This file is part of Rcpp.
4 //
5 // Rcpp is free software: you can redistribute it and/or modify it
6 // under the terms of the GNU General Public License as published by
7 // the Free Software Foundation, either version 2 of the License, or
8 // (at your option) any later version.
9 //
10 // Rcpp is distributed in the hope that it will be useful, but
11 // WITHOUT ANY WARRANTY; without even the implied warranty of
12 // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 // GNU General Public License for more details.
14 //
15 // You should have received a copy of the GNU General Public License
16 // along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
17
18 #ifndef Rcpp_api_meat_Rcpp_eval_h
19 #define Rcpp_api_meat_Rcpp_eval_h
20
21 #include <Rcpp/Interrupt.h>
22 #include <Rversion.h>
23
24
25 namespace Rcpp { namespace internal {
26
27 #ifdef RCPP_USING_UNWIND_PROTECT
28
29 struct EvalData {
30 SEXP expr;
31 SEXP env;
EvalDataEvalData32 EvalData(SEXP expr_, SEXP env_) : expr(expr_), env(env_) { }
33 };
34
Rcpp_protected_eval(void * eval_data)35 inline SEXP Rcpp_protected_eval(void* eval_data) {
36 EvalData* data = static_cast<EvalData*>(eval_data);
37 return ::Rf_eval(data->expr, data->env);
38 }
39
40 // This is used internally instead of Rf_eval() to make evaluation safer
Rcpp_eval_impl(SEXP expr,SEXP env)41 inline SEXP Rcpp_eval_impl(SEXP expr, SEXP env) {
42 return Rcpp_fast_eval(expr, env);
43 }
44
45 #else // R < 3.5.0
46
47 // Fall back to Rf_eval() when the protect-unwind API is unavailable
48 inline SEXP Rcpp_eval_impl(SEXP expr, SEXP env) {
49 return ::Rf_eval(expr, env);
50 }
51
52 #endif
53
54 }} // namespace Rcpp::internal
55
56
57 namespace Rcpp {
58
59 #ifdef RCPP_USING_UNWIND_PROTECT
60
Rcpp_fast_eval(SEXP expr,SEXP env)61 inline SEXP Rcpp_fast_eval(SEXP expr, SEXP env) {
62 internal::EvalData data(expr, env);
63 return unwindProtect(&internal::Rcpp_protected_eval, &data);
64 }
65
66 #else
67
68 inline SEXP Rcpp_fast_eval(SEXP expr, SEXP env) {
69 return Rcpp_eval(expr, env);
70 }
71
72 #endif
73
74
Rcpp_eval(SEXP expr,SEXP env)75 inline SEXP Rcpp_eval(SEXP expr, SEXP env) {
76
77 // 'identity' function used to capture errors, interrupts
78 Shield<SEXP> identity(Rf_findFun(::Rf_install("identity"), R_BaseNamespace));
79
80 if (identity == R_UnboundValue) {
81 stop("Failed to find 'base::identity()'");
82 }
83
84 // define the evalq call -- the actual R evaluation we want to execute
85 Shield<SEXP> evalqCall(Rf_lang3(::Rf_install("evalq"), expr, env));
86
87 // define the call -- enclose with `tryCatch` so we can record and forward error messages
88 Shield<SEXP> call(Rf_lang4(::Rf_install("tryCatch"), evalqCall, identity, identity));
89 SET_TAG(CDDR(call), ::Rf_install("error"));
90 SET_TAG(CDDR(CDR(call)), ::Rf_install("interrupt"));
91
92 Shield<SEXP> res(internal::Rcpp_eval_impl(call, R_BaseEnv));
93
94 // check for condition results (errors, interrupts)
95 if (Rf_inherits(res, "condition")) {
96
97 if (Rf_inherits(res, "error")) {
98
99 Shield<SEXP> conditionMessageCall(::Rf_lang2(::Rf_install("conditionMessage"), res));
100
101 Shield<SEXP> conditionMessage(internal::Rcpp_eval_impl(conditionMessageCall, R_BaseEnv));
102 throw eval_error(CHAR(STRING_ELT(conditionMessage, 0)));
103 }
104
105 // check for interrupt
106 if (Rf_inherits(res, "interrupt")) {
107 throw internal::InterruptedException();
108 }
109
110 }
111
112 return res;
113 }
114
115 } // namespace Rcpp
116
117 #endif
118