1
2##  Copyright (C) 2010 - 2019  Dirk Eddelbuettel and Romain Francois
3##
4##  This file is part of Rcpp.
5##
6##  Rcpp is free software: you can redistribute it and/or modify it
7##  under the terms of the GNU General Public License as published by
8##  the Free Software Foundation, either version 2 of the License, or
9##  (at your option) any later version.
10##
11##  Rcpp is distributed in the hope that it will be useful, but
12##  WITHOUT ANY WARRANTY; without even the implied warranty of
13##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14##  GNU General Public License for more details.
15##
16##  You should have received a copy of the GNU General Public License
17##  along with Rcpp.  If not, see <http://www.gnu.org/licenses/>.
18
19if (Sys.getenv("RunAllRcppTests") != "yes") exit_file("Set 'RunAllRcppTests' to 'yes' to run.")
20
21Rcpp::sourceCpp("cpp/stack.cpp")
22
23## On old versions of R, Rcpp_fast_eval() falls back to Rcpp_eval() and
24## leaks on longjumps
25hasUnwind <- getRversion() >= "3.5.0"
26checkUnwound <- if (hasUnwind) expect_true else function(x) expect_identical(x, NULL)
27checkErrorMessage <- function(x, msg) {
28    if (!hasUnwind) {
29        msg <- paste0("Evaluation error: ", msg, ".")
30    }
31    expect_identical(x$message, msg)
32}
33evalUnwind <- function(expr, indicator) {
34    testFastEval(expr, parent.frame(), indicator)
35}
36
37## Wrap the unwind indicator in an environment because mutating
38## vectors passed by argument can corrupt the R session in
39## byte-compiled code.
40newIndicator <- function() {
41    env <- new.env()
42    env$unwound <- NULL
43    env
44}
45
46## Stack is always unwound on errors and interrupts
47#    test.stackUnwindsOnErrors <- function() {
48indicator <- newIndicator()
49out <- tryCatch(evalUnwind(quote(stop("err")), indicator), error = identity)
50expect_true(indicator$unwound)
51checkErrorMessage(out, "err")
52
53
54#    test.stackUnwindsOnInterrupts <- function() {
55if (.Platform$OS.type != "windows") {
56    indicator <- newIndicator()
57    expr <- quote({
58        repeat testSendInterrupt()
59        "returned"
60    })
61    out <- tryCatch(evalUnwind(expr, indicator), interrupt = function(c) "onintr")
62    expect_true(indicator$unwound)
63    expect_identical(out, "onintr")
64}
65
66#    test.stackUnwindsOnCaughtConditions <- function() {
67indicator <- newIndicator()
68expr <- quote(signalCondition(simpleCondition("cnd")))
69cnd <- tryCatch(evalUnwind(expr, indicator), condition = identity)
70expect_true(inherits(cnd, "simpleCondition"))
71checkUnwound(indicator$unwound)
72
73#    test.stackUnwindsOnRestartJumps <- function() {
74indicator <- newIndicator()
75expr <- quote(invokeRestart("rst"))
76out <- withRestarts(evalUnwind(expr, indicator), rst = function(...) "restarted")
77expect_identical(out, "restarted")
78checkUnwound(indicator$unwound)
79
80#    test.stackUnwindsOnReturns <- function() {
81indicator <- newIndicator()
82expr <- quote(signalCondition(simpleCondition(NULL)))
83out <- callCC(function(k) {
84    withCallingHandlers(evalUnwind(expr, indicator), simpleCondition = function(e) k("jumped"))
85})
86expect_identical(out, "jumped")
87checkUnwound(indicator$unwound)
88
89#    test.stackUnwindsOnReturnedConditions <- function() {
90indicator <- newIndicator()
91cnd <- simpleError("foo")
92out <- tryCatch(evalUnwind(quote(cnd), indicator), error = function(c) "abort")
93expect_true(indicator$unwound)
94
95## The old mechanism cannot differentiate between a returned error and a
96## thrown error
97if (hasUnwind) {
98    expect_identical(out, cnd)
99} else {
100    expect_identical(out, "abort")
101}
102
103## Longjump from the inner protected eval
104#    test.stackUnwindsOnNestedEvalsInner <- function() {
105indicator1 <- newIndicator()
106indicator2 <- newIndicator()
107innerUnwindExpr <- quote(evalUnwind(quote(invokeRestart("here", "jump")), indicator2))
108out <- withRestarts(
109    here = identity,
110    evalUnwind(innerUnwindExpr, indicator1)
111)
112
113expect_identical(out, "jump")
114checkUnwound(indicator1$unwound)
115checkUnwound(indicator2$unwound)
116
117## Longjump from the outer protected eval
118#    test.stackUnwindsOnNestedEvalsOuter <- function() {
119indicator1 <- newIndicator()
120indicator2 <- newIndicator()
121innerUnwindExpr <- quote({
122    evalUnwind(NULL, indicator2)
123    invokeRestart("here", "jump")
124})
125out <- withRestarts(here = identity, evalUnwind(innerUnwindExpr, indicator1))
126
127expect_identical(out, "jump")
128checkUnwound(indicator1$unwound)
129expect_true(indicator2$unwound) # Always unwound
130
131#    test.unwindProtect <- function() {
132if (hasUnwind) {
133    indicator <- newIndicator()
134    expect_error(testUnwindProtect(indicator, fail = TRUE))
135    expect_true(indicator$unwound)
136
137    indicator <- newIndicator()
138    expect_error(testUnwindProtectLambda(indicator, fail = TRUE))
139    expect_true(indicator$unwound)
140
141    indicator <- newIndicator()
142    expect_error(testUnwindProtectFunctionObject(indicator, fail = TRUE))
143    expect_true(indicator$unwound)
144
145    indicator <- newIndicator()
146    expect_equal(testUnwindProtect(indicator, fail = FALSE), 42)
147    expect_true(indicator$unwound)
148
149    indicator <- newIndicator()
150    expect_equal(testUnwindProtectLambda(indicator, fail = FALSE), 42)
151    expect_true(indicator$unwound)
152
153    indicator <- newIndicator()
154    expect_equal(testUnwindProtectFunctionObject(indicator, fail = FALSE), 420)
155    expect_true(indicator$unwound)
156}
157