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;
}
/* Version of DispatchOrEval for "[" and friends that speeds up simple cases.
Also defined in subassign.c */
static R_INLINE
int R_DispatchOrEvalSP(SEXP call, SEXP op, const char *generic, SEXP args,
SEXP rho, SEXP *ans)
{
SEXP prom = NULL;
if (args != R_NilValue && CAR(args) != R_DotsSymbol) {
SEXP x = eval(CAR(args), rho);
PROTECT(x);
if (! OBJECT(x)) {
*ans = CONS_NR(x, evalListKeepMissing(CDR(args), rho));
UNPROTECT(1);
return FALSE;
}
prom = mkPROMISE(CAR(args), R_GlobalEnv);
SET_PRVALUE(prom, x);
args = CONS(prom, CDR(args));
UNPROTECT(1);
}
PROTECT(args);
int disp = DispatchOrEval(call, op, generic, args, rho, ans, 0, 0);
if (prom) DECREMENT_REFCNT(PRVALUE(prom));
UNPROTECT(1);
return disp;
}
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);
}