1 // -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; indent-tabs-mode: nil; -*-
2 //
3 // misc.cpp: Rcpp R/C++ interface class library -- misc unit tests
4 //
5 // Copyright (C) 2013 - 2015 Dirk Eddelbuettel and Romain Francois
6 //
7 // This file is part of Rcpp.
8 //
9 // Rcpp is free software: you can redistribute it and/or modify it
10 // under the terms of the GNU General Public License as published by
11 // the Free Software Foundation, either version 2 of the License, or
12 // (at your option) any later version.
13 //
14 // Rcpp is distributed in the hope that it will be useful, but
15 // WITHOUT ANY WARRANTY; without even the implied warranty of
16 // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 // GNU General Public License for more details.
18 //
19 // You should have received a copy of the GNU General Public License
20 // along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
21
22 // [[Rcpp::plugins(unwindProtect,cpp11)]]
23
24 #include <Rcpp.h>
25 using namespace Rcpp;
26
27 // Class that indicates to R caller whether C++ stack was unwound
28 struct unwindIndicator {
unwindIndicatorunwindIndicator29 unwindIndicator(Environment indicator_) {
30 // Reset the indicator to NULL
31 indicator = indicator_;
32 indicator["unwound"] = R_NilValue;
33 }
34
35 // Set indicator to TRUE when stack unwinds
~unwindIndicatorunwindIndicator36 ~unwindIndicator() {
37 indicator["unwound"] = LogicalVector::create(1);
38 }
39
40 Environment indicator;
41 };
42
43 // [[Rcpp::export]]
testFastEval(RObject expr,Environment env,Environment indicator)44 SEXP testFastEval(RObject expr, Environment env, Environment indicator) {
45 unwindIndicator my_data(indicator);
46 return Rcpp::Rcpp_fast_eval(expr, env);
47 }
48
49 // [[Rcpp::export]]
testSendInterrupt()50 SEXP testSendInterrupt() {
51 Rf_onintr();
52 return R_NilValue;
53 }
54
maybeThrow(void * data)55 SEXP maybeThrow(void* data) {
56 bool* fail = (bool*) data;
57 if (*fail)
58 Rf_error("throw!");
59 else
60 return NumericVector::create(42);
61 }
62
63 // [[Rcpp::export]]
testUnwindProtect(Environment indicator,bool fail)64 SEXP testUnwindProtect(Environment indicator, bool fail) {
65 unwindIndicator my_data(indicator);
66 SEXP out = R_NilValue;
67
68 #ifdef RCPP_USING_UNWIND_PROTECT
69 out = Rcpp::unwindProtect(&maybeThrow, &fail);
70 #endif
71 return out;
72 }
73
74
75 // [[Rcpp::export]]
testUnwindProtectLambda(Environment indicator,bool fail)76 SEXP testUnwindProtectLambda(Environment indicator, bool fail) {
77 unwindIndicator my_data(indicator);
78 SEXP out = R_NilValue;
79
80 #ifdef RCPP_USING_UNWIND_PROTECT
81 out = Rcpp::unwindProtect([&] () { return maybeThrow(&fail); });
82 #endif
83
84 return out;
85 }
86
87 struct FunctionObj {
FunctionObjFunctionObj88 FunctionObj(int data_, bool fail_) : data(data_), fail(fail_) { }
operator ()FunctionObj89 SEXP operator() () {
90 NumericVector x = maybeThrow(&fail);
91 x[0] = x[0] * data;
92 return x;
93 }
94 int data;
95 bool fail;
96 };
97
98 // [[Rcpp::export]]
testUnwindProtectFunctionObject(Environment indicator,bool fail)99 SEXP testUnwindProtectFunctionObject(Environment indicator, bool fail) {
100 unwindIndicator my_data(indicator);
101 SEXP out = R_NilValue;
102
103 #ifdef RCPP_USING_UNWIND_PROTECT
104 out = Rcpp::unwindProtect(FunctionObj(10, fail));
105 #endif
106
107 return out;
108 }
109