diff --git a/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/R/testrffi.R b/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/R/testrffi.R index 5d51f5d3711b65d5e774f4face20217fe92d6fb6..b10b83725e0ac1a99d8032e85d5cf8d2b3c17a6b 100644 --- a/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/R/testrffi.R +++ b/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/R/testrffi.R @@ -164,3 +164,7 @@ rffi.ATTRIB <- function(x) { rffi.getStringNA <- function() { .Call("test_stringNA") } + +rffi.captureDotsWithSingleElement <- function(env) { + .Call('test_captureDotsWithSingleElement', env) +} diff --git a/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/src/init.c b/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/src/init.c index cc10d16e70de109316ec99eab9712bc97c69295c..ca91702c5e0675895817ff5ad0bc4db0c712c71e 100644 --- a/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/src/init.c +++ b/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/src/init.c @@ -74,6 +74,7 @@ static const R_CallMethodDef CallEntries[] = { CALLDEF(test_coerceVector, 2), CALLDEF(test_ATTRIB, 1), CALLDEF(test_stringNA, 0), + CALLDEF(test_captureDotsWithSingleElement, 1), {NULL, NULL, 0} }; diff --git a/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/src/testrffi.c b/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/src/testrffi.c index 373d444e6d296fbbf4de95ce0e7e5c8e17f356ca..28ab2aed241e631c6fd633dfe2dfc3e47fd95cdc 100644 --- a/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/src/testrffi.c +++ b/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/src/testrffi.c @@ -332,3 +332,25 @@ SEXP test_stringNA(void) { SET_STRING_ELT(x, 0, NA_STRING); return x; } + +// This function is expected to be called only with environment that has single +// promise value in the '...' variable and this is asserted inside this function. +// The return value is list with the promises' expression and environment. +SEXP test_captureDotsWithSingleElement(SEXP env) { + SEXP dots = findVarInFrame3(env, R_DotsSymbol, TRUE); + int n_dots = length(dots); + if (n_dots != 1) { + printf("Error: test_captureDotsWithSingleElement expectes single promise in ...\n"); + return R_NilValue; + } + SEXP promise = CAR(dots); + if (TYPEOF(promise) != PROMSXP) { + printf("Error: test_captureDotsWithSingleElement expectes a promise in ...\n"); + return R_NilValue; + } + SEXP info = PROTECT(allocVector(VECSXP, 2)); + SET_VECTOR_ELT(info, 0, R_PromiseExpr(promise)); + SET_VECTOR_ELT(info, 1, PRENV(promise)); + UNPROTECT(1); + return info; +} diff --git a/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/src/testrffi.h b/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/src/testrffi.h index 5c9f89bc762c1bfde1d9a734dfd634e94b1d194f..981df927dac74a0ca0a7a4dccfb2dfb64103d7da 100644 --- a/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/src/testrffi.h +++ b/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/src/testrffi.h @@ -91,3 +91,5 @@ extern SEXP test_coerceVector(SEXP x, SEXP mode); extern SEXP test_ATTRIB(SEXP); extern SEXP test_stringNA(void); + +extern SEXP test_captureDotsWithSingleElement(SEXP env); diff --git a/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/tests/simpleTests.R b/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/tests/simpleTests.R index 87e923d5983d0b3e107aedf0d90397fe9ea8ca68..b378a50ecff075375707c94afe9f8418ee20ee03 100644 --- a/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/tests/simpleTests.R +++ b/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/tests/simpleTests.R @@ -33,3 +33,12 @@ stopifnot(attrs[[1]] == 'hello') # loess invokes loess_raw native function passing in string value as argument and that is what we test here. loess(dist ~ speed, cars); + +# code snippet that simulates work with promises ala rlang package +tmp <- c(1,2,4) +some_unique_name <- TRUE +foo <- function(...) { tmp <- 'this is not the right tmp'; bar(); } +bar <- function() rffi.captureDotsWithSingleElement(parent.frame()) +promiseInfo <- foo(tmp) +stopifnot('some_unique_name' %in% ls(promiseInfo[[2]])) +eval(promiseInfo[[1]], promiseInfo[[2]])