From 8ba98add4490919b4a5350d0fa99657e9dde4842 Mon Sep 17 00:00:00 2001
From: stepan <stepan.sindelar@oracle.com>
Date: Fri, 21 Jul 2017 10:49:13 +0200
Subject: [PATCH] Add test to testrffi that uses PREENV, R_PromiseExpr
---
.../packages/testrffi/testrffi/R/testrffi.R | 4 ++++
.../packages/testrffi/testrffi/src/init.c | 1 +
.../packages/testrffi/testrffi/src/testrffi.c | 22 +++++++++++++++++++
.../packages/testrffi/testrffi/src/testrffi.h | 2 ++
.../testrffi/testrffi/tests/simpleTests.R | 9 ++++++++
5 files changed, 38 insertions(+)
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 5d51f5d371..b10b83725e 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 cc10d16e70..ca91702c5e 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 373d444e6d..28ab2aed24 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 5c9f89bc76..981df927da 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 87e923d598..b378a50ecf 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]])
--
GitLab