static SEXP _top_prenv(SEXP promise, SEXP env) {
while(TYPEOF(promise) == PROMSXP) {
env = PRENV(promise);
promise = PREXPR(promise);
}
return env;
}
SEXP RKStructureGetter::resolvePromise (SEXP from) {
RK_TRACE (RBACKEND);
SEXP ret = from;
if (TYPEOF (from) == PROMSXP) {
ret = PRVALUE(from);
if (ret == R_UnboundValue) {
RK_DEBUG (RBACKEND, DL_DEBUG, "temporarily resolving unbound promise");
PROTECT (from);
SET_PRSEEN(from, 1);
ret = Rf_eval(PRCODE(from), PRENV(from));
SET_PRSEEN(from, 0);
if (keep_evalled_promises) {
SET_PRVALUE(from, ret);
SET_PRENV(from, R_NilValue);
}
UNPROTECT (1);
RK_DEBUG (RBACKEND, DL_DEBUG, "resolved type is %d", TYPEOF (ret));
}
}
return ret;
}
SEXP _dots_expressions(SEXP dots) {
SEXP names, s, expressions;
int i, length;
if ((TYPEOF(dots) == VECSXP) && (LENGTH(dots) == 0))
return R_NilValue;
else if ((TYPEOF(dots) != DOTSXP) && (TYPEOF(dots) != LISTSXP))
error("Expected dotlist or pairlist, got %d", TYPEOF(dots));
names = PROTECT(_dots_names(dots));
length = _dots_length(dots);
PROTECT(expressions = allocVector(VECSXP, length));
for (s = dots, i = 0; i < length; s = CDR(s), i++) {
SEXP item = CAR(s);
// if we have an unevluated promise whose code is another promise, descend
while ((PRENV(item) != R_NilValue) && (TYPEOF(PRCODE(item)) == PROMSXP)) {
item = PRCODE(item);
}
SET_VECTOR_ELT(expressions, i, PREXPR(item));
}
if (names != R_NilValue)
setAttrib(expressions, R_NamesSymbol, names);
UNPROTECT(2);
return(expressions);
}
SEXP Promise_eval(SEXP sexp) {
SEXP res, env;
PROTECT(env = PRENV(sexp));
PROTECT(res = eval(sexp, env));
UNPROTECT(2);
return res;
}
/* Return NULL on failure */
SEXP
Sexp_evalPromise(const SEXP sexp) {
if (TYPEOF(sexp) != PROMSXP) {
printf("Not a promise.\n");
return NULL;
}
SEXP env, sexp_concrete;
PROTECT(env = PRENV(sexp));
PROTECT(sexp_concrete = eval(sexp, env));
R_PreserveObject(sexp_concrete);
UNPROTECT(2);
return sexp_concrete;
}
// [[Rcpp::export]]
SEXP make_lazy(SEXP name, SEXP env, SEXP follow_symbols_) {
SEXP promise = findVar(name, env);
int follow_symbols = asLogical(follow_symbols_);
// recurse until we find the real promise, not a promise of a promise
while(TYPEOF(promise) == PROMSXP) {
env = PRENV(promise);
promise = PREXPR(promise);
// If the promise is threaded through multiple functions, we'll
// get some symbols along the way. If the symbol is bound to a promise
// keep going on up
if (follow_symbols && TYPEOF(promise) == SYMSXP) {
SEXP obj = findVar(promise, env);
if (TYPEOF(obj) == PROMSXP) {
promise = obj;
}
}
}
// Make named list for output
SEXP lazy = PROTECT(allocVector(VECSXP, 2));
SET_VECTOR_ELT(lazy, 0, promise);
SET_VECTOR_ELT(lazy, 1, env);
SEXP names = PROTECT(allocVector(STRSXP, 2));
SET_STRING_ELT(names, 0, mkChar("expr"));
SET_STRING_ELT(names, 1, mkChar("env"));
setAttrib(lazy, install("names"), names);
setAttrib(lazy, install("class"), PROTECT(mkString("lazy")));
UNPROTECT(3);
return lazy;
}
SEXP _dots_unpack(SEXP dots) {
int i;
SEXP s;
int length = 0;
SEXP names, environments, expressions, values;
//SEXP evaluated, codeptr, missing, wraplist;
//SEXP seen;
SEXP dataFrame;
SEXP colNames;
//check inputs and measure length
length = _dots_length(dots);
// unpack information for each item:
// names, environemnts, expressions, values, evaluated, seen
PROTECT(names = allocVector(STRSXP, length));
PROTECT(environments = allocVector(VECSXP, length));
PROTECT(expressions = allocVector(VECSXP, length));
PROTECT(values = allocVector(VECSXP, length));
for (s = dots, i = 0; i < length; s = CDR(s), i++) {
if (TYPEOF(s) != DOTSXP && TYPEOF(s) != LISTSXP)
error("Expected dotlist or pairlist, got %s at index %d", type2char(TYPEOF(s)), i);
SEXP item = CAR(s);
if (item == R_MissingArg) item = emptypromise();
if (TYPEOF(item) != PROMSXP)
error("Expected PROMSXP as CAR of DOTSXP, got %s", type2char(TYPEOF(item)));
// if we have an unevluated promise whose code is another promise, descend
while ((PRENV(item) != R_NilValue) && (TYPEOF(PRCODE(item)) == PROMSXP)) {
item = PRCODE(item);
}
if ((TYPEOF(PRENV(item)) != ENVSXP) && (PRENV(item) != R_NilValue))
error("Expected ENVSXP or NULL in environment slot of DOTSXP, got %s",
type2char(TYPEOF(item)));
SET_VECTOR_ELT(environments, i, PRENV(item));
SET_VECTOR_ELT(expressions, i, PREXPR(item));
SET_STRING_ELT(names, i, isNull(TAG(s)) ? R_BlankString : PRINTNAME(TAG(s)));
if (PRVALUE(item) != R_UnboundValue) {
SET_VECTOR_ELT(values, i, PRVALUE(item));
} else {
SET_VECTOR_ELT(values, i, R_NilValue);
}
}
PROTECT(dataFrame = allocVector(VECSXP, 4));
SET_VECTOR_ELT(dataFrame, 0, names);
SET_VECTOR_ELT(dataFrame, 1, environments);
SET_VECTOR_ELT(dataFrame, 2, expressions);
SET_VECTOR_ELT(dataFrame, 3, values);
PROTECT(colNames = allocVector(STRSXP, 4));
SET_STRING_ELT(colNames, 0, mkChar("name"));
SET_STRING_ELT(colNames, 1, mkChar("envir"));
SET_STRING_ELT(colNames, 2, mkChar("expr"));
SET_STRING_ELT(colNames, 3, mkChar("value"));
setAttrib(dataFrame, R_NamesSymbol, colNames);
setAttrib(dataFrame, R_RowNamesSymbol, names);
setAttrib(dataFrame, R_ClassSymbol, ScalarString(mkChar("data.frame")));
UNPROTECT(6);
return(dataFrame);
}
