Skip to content

Commit 5447f03

Browse files
eddelbuetteleddelbuettel
authored
Merge pull request #801 from lionel-/fix-unwind
Fix unwind tests on win-builder
2 parents 7d063b4 + c9f70e5 commit 5447f03

File tree

4 files changed

+156
-81
lines changed

4 files changed

+156
-81
lines changed

‎inst/unitTests/cpp/misc.cpp‎

Lines changed: 0 additions & 30 deletions
Original file line numberDiff line numberDiff line change
@@ -19,8 +19,6 @@
1919
// You should have received a copy of the GNU General Public License
2020
// along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
2121

22-
#define RCPP_PROTECTED_EVAL
23-
2422
#include <Rcpp.h>
2523
using namespace Rcpp;
2624
using namespace std;
@@ -226,31 +224,3 @@ String testNullableString(Rcpp::Nullable<Rcpp::String> param = R_NilValue) {
226224
else
227225
return String("");
228226
}
229-
230-
// Class that indicates to R caller whether C++ stack was unwound
231-
struct unwindIndicator {
232-
unwindIndicator(LogicalVector indicator_) {
233-
// Reset the indicator to FALSE
234-
indicator = indicator_;
235-
*LOGICAL(indicator) = 0;
236-
}
237-
238-
// Set indicator to TRUE when stack unwinds
239-
~unwindIndicator() {
240-
*LOGICAL(indicator) = 1;
241-
}
242-
243-
LogicalVector indicator;
244-
};
245-
246-
// [[Rcpp::export]]
247-
SEXP testEvalUnwindImpl(RObject expr, Environment env, LogicalVector indicator) {
248-
unwindIndicator my_data(indicator);
249-
return Rcpp::Rcpp_fast_eval(expr, env);
250-
}
251-
252-
// [[Rcpp::export]]
253-
SEXP testSendInterrupt() {
254-
Rf_onintr();
255-
return R_NilValue;
256-
}

‎inst/unitTests/cpp/stack.cpp‎

Lines changed: 53 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,53 @@
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+
#define RCPP_PROTECTED_EVAL
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 {
29+
unwindIndicator(LogicalVector indicator_) {
30+
// Reset the indicator to FALSE
31+
indicator = indicator_;
32+
*LOGICAL(indicator) = 0;
33+
}
34+
35+
// Set indicator to TRUE when stack unwinds
36+
~unwindIndicator() {
37+
*LOGICAL(indicator) = 1;
38+
}
39+
40+
LogicalVector indicator;
41+
};
42+
43+
// [[Rcpp::export]]
44+
SEXP testFastEval(RObject expr, Environment env, LogicalVector indicator) {
45+
unwindIndicator my_data(indicator);
46+
return Rcpp::Rcpp_fast_eval(expr, env);
47+
}
48+
49+
// [[Rcpp::export]]
50+
SEXP testSendInterrupt() {
51+
Rf_onintr();
52+
return R_NilValue;
53+
}

‎inst/unitTests/runit.misc.R‎

Lines changed: 0 additions & 51 deletions
Original file line numberDiff line numberDiff line change
@@ -214,55 +214,4 @@ if (.runThisTest) {
214214
checkTrue(nchar(Rcpp:::bib()) > 0, msg="bib file")
215215
}
216216

217-
test.stackUnwinds <- function() {
218-
# On old versions of R, Rcpp_fast_eval() falls back to Rcpp_eval() and
219-
# leaks on longjumps
220-
hasUnwind <- getRversion() >= "3.5.0"
221-
checkUnwound <- if (hasUnwind) checkTrue else function(x) checkTrue(!x)
222-
testEvalUnwind <- function(expr, indicator) {
223-
testEvalUnwindImpl(expr, parent.frame(), indicator)
224-
}
225-
226-
# On errors - Always unwound
227-
unwound <- FALSE
228-
out <- tryCatch(testEvalUnwind(quote(stop("err")), unwound), error = identity)
229-
checkTrue(unwound)
230-
msg <- if (hasUnwind) "err" else "Evaluation error: err."
231-
checkIdentical(out$message, msg)
232-
233-
# On interrupts - Always unwound
234-
unwound <- FALSE
235-
expr <- quote({
236-
repeat testSendInterrupt()
237-
"returned"
238-
})
239-
out <- tryCatch(testEvalUnwind(expr, unwound), interrupt = function(c) "onintr")
240-
checkTrue(unwound)
241-
checkIdentical(out, "onintr")
242-
243-
# On caught conditions
244-
unwound <- FALSE
245-
expr <- quote(signalCondition(simpleCondition("cnd")))
246-
cnd <- tryCatch(testEvalUnwind(expr, unwound), condition = identity)
247-
checkTrue(inherits(cnd, "simpleCondition"))
248-
checkUnwound(unwound)
249-
250-
# On restart jumps
251-
unwound <- FALSE
252-
expr <- quote(invokeRestart("rst"))
253-
out <- withRestarts(testEvalUnwind(expr, unwound), rst = function(...) "restarted")
254-
checkIdentical(out, "restarted")
255-
checkUnwound(unwound)
256-
257-
# On returns
258-
unwound <- FALSE
259-
expr <- quote(signalCondition(simpleCondition(NULL)))
260-
out <- callCC(function(k)
261-
withCallingHandlers(testEvalUnwind(expr, unwound),
262-
simpleCondition = function(e) k("jumped")
263-
)
264-
)
265-
checkIdentical(out, "jumped")
266-
checkUnwound(unwound)
267-
}
268217
}

‎inst/unitTests/runit.stack.R‎

Lines changed: 103 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,103 @@
1+
#!/usr/bin/env r
2+
#
3+
# Copyright (C) 2010 - 2017 Dirk Eddelbuettel and Romain Francois
4+
#
5+
# This file is part of Rcpp.
6+
#
7+
# Rcpp is free software: you can redistribute it and/or modify it
8+
# under the terms of the GNU General Public License as published by
9+
# the Free Software Foundation, either version 2 of the License, or
10+
# (at your option) any later version.
11+
#
12+
# Rcpp is distributed in the hope that it will be useful, but
13+
# WITHOUT ANY WARRANTY; without even the implied warranty of
14+
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15+
# GNU General Public License for more details.
16+
#
17+
# You should have received a copy of the GNU General Public License
18+
# along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
19+
20+
.runThisTest <- Sys.getenv("RunAllRcppTests") == "yes"
21+
22+
23+
if (FALSE && .runThisTest) {
24+
25+
.setUp <- Rcpp:::unitTestSetup("stack.cpp")
26+
27+
# On old versions of R, Rcpp_fast_eval() falls back to Rcpp_eval() and
28+
# leaks on longjumps
29+
hasUnwind <- getRversion() >= "3.5.0"
30+
checkUnwound <- if (hasUnwind) checkTrue else function(x) checkTrue(!x)
31+
EvalUnwind <- function(expr, indicator) {
32+
testFastEval(expr, parent.frame(), indicator)
33+
}
34+
35+
# Stack is always unwound on errors and interrupts
36+
test.stackUnwindsOnErrors <- function() {
37+
unwound <- FALSE
38+
out <- tryCatch(EvalUnwind(quote(stop("err")), unwound), error = identity)
39+
checkTrue(unwound)
40+
msg <- if (hasUnwind) "err" else "Evaluation error: err."
41+
checkIdentical(out$message, msg)
42+
}
43+
44+
test.stackUnwindsOnInterrupts <- function() {
45+
unwound <- FALSE
46+
expr <- quote({
47+
repeat testSendInterrupt()
48+
"returned"
49+
})
50+
out <- tryCatch(EvalUnwind(expr, unwound), interrupt = function(c) "onintr")
51+
checkTrue(unwound)
52+
checkIdentical(out, "onintr")
53+
54+
}
55+
56+
test.stackUnwindsOnCaughtConditions <- function() {
57+
unwound <- FALSE
58+
expr <- quote(signalCondition(simpleCondition("cnd")))
59+
cnd <- tryCatch(EvalUnwind(expr, unwound), condition = identity)
60+
checkTrue(inherits(cnd, "simpleCondition"))
61+
checkUnwound(unwound)
62+
63+
}
64+
65+
test.stackUnwindsOnRestartJumps <- function() {
66+
unwound <- FALSE
67+
expr <- quote(invokeRestart("rst"))
68+
out <- withRestarts(EvalUnwind(expr, unwound), rst = function(...) "restarted")
69+
checkIdentical(out, "restarted")
70+
checkUnwound(unwound)
71+
72+
}
73+
74+
test.stackUnwindsOnReturns <- function() {
75+
unwound <- FALSE
76+
expr <- quote(signalCondition(simpleCondition(NULL)))
77+
out <- callCC(function(k) {
78+
withCallingHandlers(EvalUnwind(expr, unwound),
79+
simpleCondition = function(e) k("jumped")
80+
)
81+
})
82+
checkIdentical(out, "jumped")
83+
checkUnwound(unwound)
84+
85+
}
86+
87+
test.stackUnwindsOnReturnedConditions <- function() {
88+
unwound <- FALSE
89+
cnd <- simpleError("foo")
90+
out <- tryCatch(EvalUnwind(quote(cnd), unwound),
91+
error = function(c) "abort"
92+
)
93+
checkTrue(unwound)
94+
95+
# The old mechanism cannot differentiate between a returned error and a
96+
# thrown error
97+
if (hasUnwind) {
98+
checkIdentical(out, cnd)
99+
} else {
100+
checkIdentical(out, "abort")
101+
}
102+
}
103+
}

0 commit comments

Comments
 (0)