Add test to testrffi that uses PREENV, R_PromiseExpr

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)
+}

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}
 };
 

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;
+}

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);

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]])