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 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;
}
/* Construct a string identifying some SEXP, either as a scalar value or as a pointer.
If we use its pointer, set NAMED = 2 on the pointer used.
Return that pointer, or R_NilValue. */
SEXP stringify_item(SEXP item, char *bufptr) {
int done = 0;
SEXP item_ptr = R_NilValue;
while(!done) {
switch (TYPEOF(item)) {
case PROMSXP:
/* if we have a promise, drill down. */
item = PRCODE(item);
break;
case CHARSXP:
/* interned string, represent its pointer */
item_ptr = item;
bufptr += sprintf(bufptr, "c%p", CHAR(item_ptr));
done = 1;
break;
case REALSXP:
case INTSXP:
case STRSXP:
case LGLSXP:
/* we have a code literal. represent it canonically,
and don't hold a ref to a scalar. */
if (LENGTH(item) == 0) {
switch(TYPEOF(item)) {
case REALSXP: bufptr += sprintf(bufptr, "r0"); break;
case INTSXP: bufptr += sprintf(bufptr, "i0"); break;
case LGLSXP: bufptr += sprintf(bufptr, "l0"); break;
case STRSXP: bufptr += sprintf(bufptr, "s0"); break;
default: error("Unexpected type %s (this shouldn't happen)", TYPEOF(item));
}
} else if (LENGTH(item) == 1) {
switch(TYPEOF(item)) {
case REALSXP:
bufptr += sprintf(bufptr, "r");
bufptr += sprintdouble(bufptr, REAL(item)[0]);
break;
case INTSXP: bufptr += sprintf(bufptr, "i%x", INTEGER(item)[0]); break;
case LGLSXP: bufptr += sprintf(bufptr, "l%x", LOGICAL(item)[0]); break;
case STRSXP:
item_ptr = STRING_ELT(item, 0);
bufptr += sprintf(bufptr, "s%p", CHAR(item_ptr)); break;
default: error("Unexpected type %s (this shouldn't happen)", TYPEOF(item));
}
} else {
/* for non-scalar vectors, represent the pointer */
item_ptr = item;
bufptr += sprintf(bufptr, "v%p", (void *)item_ptr);
}
done = 1;
break;
case VECSXP:
item_ptr = item;
bufptr += sprintf(bufptr, "l%p", (void *)item_ptr);
done = 1;
break;
case CLOSXP:
item_ptr = item;
bufptr += sprintf(bufptr, "c_%p/%p/%p",
(void *) FORMALS(item),
(void *) BODY(item),
(void *) CLOENV(item));
done = 1;
break;
case SYMSXP:
case LANGSXP:
case EXPRSXP:
case BCODESXP:
case BUILTINSXP:
case SPECIALSXP:
case NILSXP:
/* We have an expression-ish, represent its pointer. */
item_ptr = item;
bufptr += sprintf(bufptr, "e%p", (void *)item_ptr);
done = 1;
break;
default:
error("Unexpected type %s", type2char(TYPEOF(item)));
}
}
if (item_ptr != R_NilValue) {
SET_NAMED(item_ptr, 2);
}
return item_ptr;
}
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);
}
