SEXP attribute_hidden do_args(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP s;
checkArity(op,args);
if (TYPEOF(CAR(args)) == STRSXP && length(CAR(args))==1) {
PROTECT(s = installTrChar(STRING_ELT(CAR(args), 0)));
SETCAR(args, findFun(s, rho));
UNPROTECT(1);
}
if (TYPEOF(CAR(args)) == CLOSXP) {
s = allocSExp(CLOSXP);
SET_FORMALS(s, FORMALS(CAR(args)));
SET_BODY(s, R_NilValue);
SET_CLOENV(s, R_GlobalEnv);
return s;
}
if (TYPEOF(CAR(args)) == BUILTINSXP || TYPEOF(CAR(args)) == SPECIALSXP) {
char *nm = PRIMNAME(CAR(args));
SEXP env, s2;
PROTECT_INDEX xp;
PROTECT_WITH_INDEX(env = findVarInFrame3(R_BaseEnv,
install(".ArgsEnv"), TRUE),
&xp);
if (TYPEOF(env) == PROMSXP) REPROTECT(env = eval(env, R_BaseEnv), xp);
PROTECT(s2 = findVarInFrame3(env, install(nm), TRUE));
if(s2 != R_UnboundValue) {
s = duplicate(s2);
SET_CLOENV(s, R_GlobalEnv);
UNPROTECT(2);
return s;
}
UNPROTECT(1); /* s2 */
REPROTECT(env = findVarInFrame3(R_BaseEnv, install(".GenericArgsEnv"),
TRUE), xp);
if (TYPEOF(env) == PROMSXP) REPROTECT(env = eval(env, R_BaseEnv), xp);
PROTECT(s2 = findVarInFrame3(env, install(nm), TRUE));
if(s2 != R_UnboundValue) {
s = allocSExp(CLOSXP);
SET_FORMALS(s, FORMALS(s2));
SET_BODY(s, R_NilValue);
SET_CLOENV(s, R_GlobalEnv);
UNPROTECT(2);
return s;
}
UNPROTECT(2);
}
return R_NilValue;
}
SEXP attribute_hidden do_formals(SEXP call, SEXP op, SEXP args, SEXP rho)
{
checkArity(op, args);
if (TYPEOF(CAR(args)) == CLOSXP)
return duplicate(FORMALS(CAR(args)));
else
return R_NilValue;
}
SEXP reassign_function(SEXP name, SEXP env, SEXP old_fun, SEXP new_fun)
{
if (TYPEOF(name) != SYMSXP) error("name must be a symbol");
if (TYPEOF(env) != ENVSXP) error("env must be an environment");
if (TYPEOF(old_fun) != CLOSXP) error("old_fun must be a function");
if (TYPEOF(new_fun) != CLOSXP) error("new_fun must be a function");
SET_FORMALS(old_fun, FORMALS(new_fun));
SET_BODY(old_fun, BODY(new_fun));
SET_CLOENV(old_fun, CLOENV(new_fun));
DUPLICATE_ATTRIB(old_fun, new_fun);
return R_NilValue;
}
static void callback_closure(char * buf, int buflen, SEXP closure)
{
static char tmp[21];
SEXP formals;
formals = FORMALS(closure);
snprintf(buf, buflen, "R_call %p", (void *) closure);
while ( formals != R_NilValue )
{
if (TAG(formals) == R_DotsSymbol) break;
snprintf(tmp, 20, " %%%s", CHAR(PRINTNAME(TAG(formals))));
tmp[20] = '\0';
if (strlen(buf) + strlen(tmp) >= buflen)
error(_("argument list is too long in tcltk internal function 'callback_closure'"));
strcat(buf, tmp);
formals = CDR(formals);
}
}
SEXP deriv(SEXP args)
{
/* deriv(expr, namevec, function.arg, tag, hessian) */
SEXP ans, ans2, expr, funarg, names, s;
int f_index, *d_index, *d2_index;
int i, j, k, nexpr, nderiv=0, hessian;
SEXP exprlist, tag;
args = CDR(args);
InitDerivSymbols();
PROTECT(exprlist = LCONS(R_BraceSymbol, R_NilValue));
/* expr: */
if (isExpression(CAR(args)))
PROTECT(expr = VECTOR_ELT(CAR(args), 0));
else PROTECT(expr = CAR(args));
args = CDR(args);
/* namevec: */
names = CAR(args);
if (!isString(names) || (nderiv = length(names)) < 1)
error(_("invalid variable names"));
args = CDR(args);
/* function.arg: */
funarg = CAR(args);
args = CDR(args);
/* tag: */
tag = CAR(args);
if (!isString(tag) || length(tag) < 1
|| length(STRING_ELT(tag, 0)) < 1 || length(STRING_ELT(tag, 0)) > 60)
error(_("invalid tag"));
args = CDR(args);
/* hessian: */
hessian = asLogical(CAR(args));
/* NOTE: FindSubexprs is destructive, hence the duplication.
It can allocate, so protect the duplicate.
*/
PROTECT(ans = duplicate(expr));
f_index = FindSubexprs(ans, exprlist, tag);
d_index = (int*)R_alloc((size_t) nderiv, sizeof(int));
if (hessian)
d2_index = (int*)R_alloc((size_t) ((nderiv * (1 + nderiv))/2),
sizeof(int));
else d2_index = d_index;/*-Wall*/
UNPROTECT(1);
for(i=0, k=0; i<nderiv ; i++) {
PROTECT(ans = duplicate(expr));
PROTECT(ans = D(ans, installTrChar(STRING_ELT(names, i))));
PROTECT(ans2 = duplicate(ans)); /* keep a temporary copy */
d_index[i] = FindSubexprs(ans, exprlist, tag); /* examine the derivative first */
PROTECT(ans = duplicate(ans2)); /* restore the copy */
if (hessian) {
for(j = i; j < nderiv; j++) {
PROTECT(ans2 = duplicate(ans)); /* install could allocate */
PROTECT(ans2 = D(ans2, installTrChar(STRING_ELT(names, j))));
d2_index[k] = FindSubexprs(ans2, exprlist, tag);
k++;
UNPROTECT(2);
}
}
UNPROTECT(4);
}
nexpr = length(exprlist) - 1;
if (f_index) {
Accumulate2(MakeVariable(f_index, tag), exprlist);
}
else {
PROTECT(ans = duplicate(expr));
Accumulate2(expr, exprlist);
UNPROTECT(1);
}
Accumulate2(R_NilValue, exprlist);
if (hessian) { Accumulate2(R_NilValue, exprlist); }
for (i = 0, k = 0; i < nderiv ; i++) {
if (d_index[i]) {
Accumulate2(MakeVariable(d_index[i], tag), exprlist);
if (hessian) {
PROTECT(ans = duplicate(expr));
PROTECT(ans = D(ans, installTrChar(STRING_ELT(names, i))));
for (j = i; j < nderiv; j++) {
if (d2_index[k]) {
Accumulate2(MakeVariable(d2_index[k], tag), exprlist);
} else {
PROTECT(ans2 = duplicate(ans));
PROTECT(ans2 = D(ans2, installTrChar(STRING_ELT(names, j))));
Accumulate2(ans2, exprlist);
UNPROTECT(2);
}
k++;
}
UNPROTECT(2);
}
} else { /* the first derivative is constant or simple variable */
PROTECT(ans = duplicate(expr));
PROTECT(ans = D(ans, installTrChar(STRING_ELT(names, i))));
Accumulate2(ans, exprlist);
UNPROTECT(2);
if (hessian) {
for (j = i; j < nderiv; j++) {
if (d2_index[k]) {
Accumulate2(MakeVariable(d2_index[k], tag), exprlist);
} else {
PROTECT(ans2 = duplicate(ans));
PROTECT(ans2 = D(ans2, installTrChar(STRING_ELT(names, j))));
if(isZero(ans2)) Accumulate2(R_MissingArg, exprlist);
else Accumulate2(ans2, exprlist);
UNPROTECT(2);
}
k++;
}
}
}
}
Accumulate2(R_NilValue, exprlist);
Accumulate2(R_NilValue, exprlist);
if (hessian) { Accumulate2(R_NilValue, exprlist); }
i = 0;
ans = CDR(exprlist);
while (i < nexpr) {
if (CountOccurrences(MakeVariable(i+1, tag), CDR(ans)) < 2) {
SETCDR(ans, Replace(MakeVariable(i+1, tag), CAR(ans), CDR(ans)));
SETCAR(ans, R_MissingArg);
}
else {
SEXP var;
PROTECT(var = MakeVariable(i+1, tag));
SETCAR(ans, lang3(install("<-"), var, AddParens(CAR(ans))));
UNPROTECT(1);
}
i = i + 1;
ans = CDR(ans);
}
/* .value <- ... */
SETCAR(ans, lang3(install("<-"), install(".value"), AddParens(CAR(ans))));
ans = CDR(ans);
/* .grad <- ... */
SETCAR(ans, CreateGrad(names));
ans = CDR(ans);
/* .hessian <- ... */
if (hessian) { SETCAR(ans, CreateHess(names)); ans = CDR(ans); }
/* .grad[, "..."] <- ... */
for (i = 0; i < nderiv ; i++) {
SETCAR(ans, DerivAssign(STRING_ELT(names, i), AddParens(CAR(ans))));
ans = CDR(ans);
if (hessian) {
for (j = i; j < nderiv; j++) {
if (CAR(ans) != R_MissingArg) {
if (i == j) {
SETCAR(ans, HessAssign1(STRING_ELT(names, i),
AddParens(CAR(ans))));
} else {
SETCAR(ans, HessAssign2(STRING_ELT(names, i),
STRING_ELT(names, j),
AddParens(CAR(ans))));
}
}
ans = CDR(ans);
}
}
}
/* attr(.value, "gradient") <- .grad */
SETCAR(ans, AddGrad());
ans = CDR(ans);
if (hessian) { SETCAR(ans, AddHess()); ans = CDR(ans); }
/* .value */
SETCAR(ans, install(".value"));
/* Prune the expression list removing eliminated sub-expressions */
SETCDR(exprlist, Prune(CDR(exprlist)));
if (TYPEOF(funarg) == LGLSXP && LOGICAL(funarg)[0]) { /* fun = TRUE */
funarg = names;
}
if (TYPEOF(funarg) == CLOSXP)
{
funarg = mkCLOSXP(FORMALS(funarg), exprlist, CLOENV(funarg));
}
else if (isString(funarg)) {
SEXP formals = allocList(length(funarg));
ans = formals;
for(i = 0; i < length(funarg); i++) {
SET_TAG(ans, installTrChar(STRING_ELT(funarg, i)));
SETCAR(ans, R_MissingArg);
ans = CDR(ans);
}
funarg = mkCLOSXP(formals, exprlist, R_GlobalEnv);
}
else {
funarg = allocVector(EXPRSXP, 1);
SET_VECTOR_ELT(funarg, 0, exprlist);
/* funarg = lang2(install("expression"), exprlist); */
}
UNPROTECT(2);
return funarg;
}
/* 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;
}
/** Returns the list of formal arguments of a closure.
*
* @param sexp An R closure.
* @return The list of formal arguments of the R closure.
*/
CAMLprim value ocamlr_inspect_closxp_formals (value sexp) {
return(Val_sexp(FORMALS(Sexp_val(sexp))));
}
// TODO: split out some of the large blocks into helper functions, to make this easier to read
void RKStructureGetter::getStructureWorker (SEXP val, const QString &name, int add_type_flags, RData *storage, int nesting_depth) {
RK_TRACE (RBACKEND);
bool at_toplevel = (toplevel_value == val);
bool is_function = false;
bool is_container = false;
bool is_environment = false;
bool no_recurse = (nesting_depth >= 2); // TODO: should be configurable
unsigned int type = 0;
RK_DEBUG (RBACKEND, DL_DEBUG, "fetching '%s': %p, s-type %d", name.toLatin1().data(), val, TYPEOF (val));
SEXP value = val;
PROTECT_INDEX value_index;
PROTECT_WITH_INDEX (value, &value_index);
// manually resolve any promises
REPROTECT (value = resolvePromise (value), value_index);
bool is_s4 = Rf_isS4 (value);
SEXP baseenv = R_BaseEnv;
if (is_s4) baseenv = R_GlobalEnv;
// first field: get name
RData *namedata = new RData;
namedata->setData (QStringList (name));
// get classes
SEXP classes_s;
if ((TYPEOF (value) == LANGSXP) || (TYPEOF (value) == SYMSXP)) { // if it's a call, we should NEVER send it through eval
extern SEXP R_data_class (SEXP, Rboolean);
classes_s = R_data_class (value, (Rboolean) 0);
REPROTECT (value = Rf_coerceVector (value, EXPRSXP), value_index); // make sure the object is safe for everything to come
PROTECT (classes_s);
} else {
classes_s = RKRSupport::callSimpleFun (class_fun, value, baseenv);
PROTECT (classes_s);
}
QStringList classes = RKRSupport::SEXPToStringList (classes_s);
UNPROTECT (1); /* classes_s */
// store classes
RData *classdata = new RData;
classdata->setData (classes);
// basic classification
for (int i = classes.size () - 1; i >= 0; --i) {
#warning: Using is.data.frame() may be more reliable (would need to be called only on List-objects, thus no major performance hit)
if (classes[i] == "data.frame") type |= RObject::DataFrame;
}
if (RKRSupport::callSimpleBool (is_matrix_fun, value, baseenv)) type |= RObject::Matrix;
if (RKRSupport::callSimpleBool (is_list_fun, value, baseenv)) type |= RObject::List;
if (type != 0) {
is_container = true;
type |= RObject::Container;
} else {
if (RKRSupport::callSimpleBool (is_function_fun, value, baseenv)) {
is_function = true;
type |= RObject::Function;
} else if (RKRSupport::callSimpleBool (is_environment_fun, value, baseenv)) {
is_container = true;
type |= RObject::Environment;
is_environment = true;
} else {
type |= RObject::Variable;
if (RKRSupport::callSimpleBool (is_factor_fun, value, baseenv)) type |= RObject::Factor;
else if (RKRSupport::callSimpleBool (is_numeric_fun, value, baseenv)) type |= RObject::Numeric;
else if (RKRSupport::callSimpleBool (is_character_fun, value, baseenv)) type |= RObject::Character;
else if (RKRSupport::callSimpleBool (is_logical_fun, value, baseenv)) type |= RObject::Logical;
if (RKRSupport::callSimpleBool (is_array_fun, value, baseenv)) type |= RObject::Array;
}
}
type |= add_type_flags;
if (is_container) {
if (no_recurse) {
type |= RObject::Incomplete;
RK_DEBUG (RBACKEND, DL_DEBUG, "Depth limit reached. Will not recurse into %s", name.toLatin1().data ());
}
}
// get meta data, if any
RData *metadata = new RData;
if (!Rf_isNull (Rf_getAttrib (value, meta_attrib))) {
SEXP meta_s = RKRSupport::callSimpleFun (get_meta_fun, value, R_GlobalEnv);
PROTECT (meta_s);
metadata->setData (RKRSupport::SEXPToStringList (meta_s));
UNPROTECT (1); /* meta_s */
} else {
metadata->setData (QStringList ());
}
// get dims
RData::IntStorage dims;
SEXP dims_s = RKRSupport::callSimpleFun (dims_fun, value, baseenv);
if (!Rf_isNull (dims_s)) {
dims = RKRSupport::SEXPToIntArray (dims_s);
} else {
unsigned int len = Rf_length (value);
if ((len < 2) && (!is_function)) { // suspicious. Maybe some kind of list
SEXP len_s = RKRSupport::callSimpleFun (length_fun, value, baseenv);
PROTECT (len_s);
if (Rf_isNull (len_s)) {
dims.append (len);
} else {
dims = RKRSupport::SEXPToIntArray (len_s);
}
UNPROTECT (1); /* len_s */
} else {
dims.append (len);
}
}
// store dims
RData *dimdata = new RData;
dimdata->setData (dims);
RData *slotsdata = new RData ();
// does it have slots?
if (is_s4) {
type |= RObject::S4Object;
if (no_recurse) {
type |= RObject::Incomplete;
RK_DEBUG (RBACKEND, DL_DEBUG, "Depth limit reached. Will not recurse into slots of %s", name.toLatin1().data ());
} else {
RData::RDataStorage dummy (1, 0);
dummy[0] = new RData ();
SEXP slots_pseudo_object = RKRSupport::callSimpleFun (rk_get_slots_fun, value, R_GlobalEnv);
PROTECT (slots_pseudo_object);
getStructureSafe (slots_pseudo_object, "SLOTS", RObject::PseudoObject, dummy[0], nesting_depth); // do not increase depth for this pseudo-object
UNPROTECT (1);
slotsdata->setData (dummy);
}
}
// store type
RData *typedata = new RData;
typedata->setData (RData::IntStorage (1, type));
// store everything we have so far
int storage_length = RObject::StorageSizeBasicInfo;
if (is_container) {
storage_length = RObject::StorageSizeBasicInfo + 1;
} else if (is_function) {
storage_length = RObject::StorageSizeBasicInfo + 2;
}
RData::RDataStorage res (storage_length, 0);
res[RObject::StoragePositionName] = namedata;
res[RObject::StoragePositionType] = typedata;
res[RObject::StoragePositionClass] = classdata;
res[RObject::StoragePositionMeta] = metadata;
res[RObject::StoragePositionDims] = dimdata;
res[RObject::StoragePositionSlots] = slotsdata;
// now add the extra info for containers and functions
if (is_container) {
bool do_env = (is_environment && (!no_recurse));
bool do_cont = is_container && (!is_environment) && (!no_recurse);
// fetch list of child names
SEXP childnames_s;
if (do_env) {
childnames_s = R_lsInternal (value, (Rboolean) 1);
} else if (do_cont) {
childnames_s = RKRSupport::callSimpleFun (names_fun, value, baseenv);
} else {
childnames_s = R_NilValue; // dummy
}
PROTECT (childnames_s);
QStringList childnames = RKRSupport::SEXPToStringList (childnames_s);
int childcount = childnames.size ();
if (childcount > NAMED_CHILDREN_LIMIT) {
RK_DEBUG (RBACKEND, DL_WARNING, "object %s has %d named children. Will only retrieve the first %d", name.toLatin1().data (), childcount, NAMED_CHILDREN_LIMIT);
childcount = NAMED_CHILDREN_LIMIT;
}
RData::RDataStorage children (childcount, 0);
for (int i = 0; i < childcount; ++i) {
children[i] = new RData (); // NOTE: RData-ctor pre-initalizes these to empty. Thus, we're safe even if there is an error while fetching one of the children.
}
if (do_env) {
RK_DEBUG (RBACKEND, DL_DEBUG, "recurse into environment %s", name.toLatin1().data ());
if (!Rf_isEnvironment (value)) {
// some classes (ReferenceClasses) are identified as envionments by is.environment(), but are not internally ENVSXPs.
// For these, Rf_findVar would fail.
REPROTECT (value = RKRSupport::callSimpleFun (as_environment_fun, value, R_GlobalEnv), value_index);
}
for (int i = 0; i < childcount; ++i) {
SEXP current_childname = Rf_install(CHAR(STRING_ELT(childnames_s, i))); // ??? Why does simply using STRING_ELT(childnames_i, i) crash?
PROTECT (current_childname);
SEXP child = Rf_findVar (current_childname, value);
PROTECT (child);
bool child_misplaced = false;
if (at_toplevel && with_namespace && (!RKRBackend::this_pointer->RRuntimeIsVersion (2, 14, 0))) {
if (!Rf_isNull (namespace_envir)) {
SEXP dummy = Rf_findVarInFrame (namespace_envir, current_childname);
if (Rf_isNull (dummy) || (dummy == R_UnboundValue)) child_misplaced = true;
}
}
getStructureSafe (child, childnames[i], child_misplaced ? RObject::Misplaced : 0, children[i], nesting_depth + 1);
UNPROTECT (2); /* current_childname, child */
}
} else if (do_cont) {
RK_DEBUG (RBACKEND, DL_DEBUG, "recurse into list %s", name.toLatin1().data ());
// fewer elements than names() can happen, although I doubt it is supposed to happen.
// see http://sourceforge.net/tracker/?func=detail&aid=3002439&group_id=50231&atid=459007
bool may_be_special = Rf_length (value) < childcount;
if (Rf_isList (value) && (!may_be_special)) { // old style list
for (int i = 0; i < childcount; ++i) {
SEXP child = CAR (value);
getStructureSafe (child, childnames[i], 0, children[i], nesting_depth + 1);
CDR (value);
}
} else if (Rf_isNewList (value) && (!may_be_special)) { // new style list
for (int i = 0; i < childcount; ++i) {
SEXP child = VECTOR_ELT(value, i);
getStructureSafe (child, childnames[i], 0, children[i], nesting_depth + 1);
}
} else { // probably an S4 object disguised as a list
SEXP index = Rf_allocVector(INTSXP, 1);
PROTECT (index);
for (int i = 0; i < childcount; ++i) {
INTEGER (index)[0] = (i + 1);
SEXP child = RKRSupport::callSimpleFun2 (double_brackets_fun, value, index, baseenv);
getStructureSafe (child, childnames[i], 0, children[i], nesting_depth + 1);
}
UNPROTECT (1); /* index */
}
}
UNPROTECT (1); /* childnames_s */
RData *childdata = new RData;
childdata->setData (children);
res[RObject::StoragePositionChildren] = childdata;
if (is_environment && at_toplevel && with_namespace) {
RData *namespacedata = new RData;
if (no_recurse) {
type |= RObject::Incomplete;
RK_DEBUG (RBACKEND, DL_DEBUG, "Depth limit reached. Will not recurse into namespace of %s", name.toLatin1().data ());
} else {
RData::RDataStorage dummy (1, 0);
dummy[0] = new RData ();
getStructureSafe (namespace_envir, "NAMESPACE", RObject::PseudoObject, dummy[0], nesting_depth+99); // HACK: By default, do not recurse into the children of the namespace, until dealing with the namespace object itself.
namespacedata->setData (dummy);
}
res.insert (RObject::StoragePositionNamespace, namespacedata);
}
} else if (is_function) {
// TODO: getting the formals is still a bit of a bottleneck, but no idea, how to improve on this, any further
SEXP formals_s;
if (Rf_isPrimitive (value)) formals_s = FORMALS (RKRSupport::callSimpleFun (args_fun, value, baseenv)); // primitives don't have formals, internally
else formals_s = FORMALS (value);
PROTECT (formals_s);
// get the default values
QStringList formals = RKRSupport::SEXPToStringList (formals_s);
// for the most part, the implicit as.character in SEXPToStringList does a good on the formals (and it's the fastest of many options that I have tried).
// Only for naked strings (as in 'function (a="something")'), we're missing the quotes. So we add quotes, after conversion, as needed:
SEXP dummy = formals_s;
const int formals_len = Rf_length (formals_s);
for (int i = 0; i < formals_len; ++i) {
if (TYPEOF (CAR (dummy)) == STRSXP) formals[i] = RKRSharedFunctionality::quote (formals[i]);
dummy = CDR (dummy);
}
RData *funargvaluesdata = new RData;
funargvaluesdata->setData (formals);
// the argument names
SEXP names_s = Rf_getAttrib (formals_s, R_NamesSymbol);
PROTECT (names_s);
RData *funargsdata = new RData;
funargsdata->setData (RKRSupport::SEXPToStringList (names_s));
UNPROTECT (2); /* names_s, formals_s */
res[RObject::StoragePositionFunArgs] = funargsdata;
res[RObject::StoragePositionFunValues] = funargvaluesdata;
}
UNPROTECT (1); /* value */
RK_ASSERT (!res.contains (0));
storage->setData (res);
}
static R_size_t objectsize(SEXP s)
{
R_size_t cnt = 0, vcnt = 0;
SEXP tmp, dup;
Rboolean isVec = FALSE;
switch (TYPEOF(s)) {
case NILSXP:
return(0);
break;
case SYMSXP:
break;
case LISTSXP:
case LANGSXP:
case BCODESXP:
case DOTSXP:
cnt += objectsize(TAG(s));
cnt += objectsize(CAR(s));
cnt += objectsize(CDR(s));
break;
case CLOSXP:
cnt += objectsize(FORMALS(s));
cnt += objectsize(BODY(s));
/* no charge for the environment */
break;
case ENVSXP:
R_CheckStack(); /* in case attributes might lead to a cycle */
case PROMSXP:
case SPECIALSXP:
case BUILTINSXP:
break;
case CHARSXP:
vcnt = BYTE2VEC(length(s)+1);
isVec = TRUE;
break;
case LGLSXP:
case INTSXP:
vcnt = INT2VEC(xlength(s));
isVec = TRUE;
break;
case REALSXP:
vcnt = FLOAT2VEC(xlength(s));
isVec = TRUE;
break;
case CPLXSXP:
vcnt = COMPLEX2VEC(xlength(s));
isVec = TRUE;
break;
case STRSXP:
vcnt = PTR2VEC(xlength(s));
PROTECT(dup = Rf_csduplicated(s));
for (R_xlen_t i = 0; i < xlength(s); i++) {
tmp = STRING_ELT(s, i);
if(tmp != NA_STRING && !LOGICAL(dup)[i])
cnt += objectsize(tmp);
}
isVec = TRUE;
UNPROTECT(1);
break;
case ANYSXP:
/* we don't know about these */
break;
case VECSXP:
case EXPRSXP:
case WEAKREFSXP:
/* Generic Vector Objects */
vcnt = PTR2VEC(xlength(s));
for (R_xlen_t i = 0; i < xlength(s); i++)
cnt += objectsize(VECTOR_ELT(s, i));
isVec = TRUE;
break;
case EXTPTRSXP:
cnt += sizeof(void *); /* the actual pointer */
cnt += objectsize(EXTPTR_PROT(s));
cnt += objectsize(EXTPTR_TAG(s));
break;
case RAWSXP:
vcnt = BYTE2VEC(xlength(s));
isVec = TRUE;
break;
case S4SXP:
/* Has TAG and ATRIB but no CAR nor CDR */
cnt += objectsize(TAG(s));
break;
default:
UNIMPLEMENTED_TYPE("object.size", s);
}
/* add in node space:
we need to take into account the rounding up that goes on
in the node classes. */
if(isVec) {
cnt += sizeof(SEXPREC_ALIGN);
if (vcnt > 16) cnt += 8*vcnt;
else if (vcnt > 8) cnt += 128;
else if (vcnt > 6) cnt += 64;
else if (vcnt > 4) cnt += 48;
else if (vcnt > 2) cnt += 32;
else if (vcnt > 1) cnt += 16;
else if (vcnt > 0) cnt += 8;
} else cnt += sizeof(SEXPREC);
/* add in attributes: these are fake for CHARSXPs */
if(TYPEOF(s) != CHARSXP) cnt += objectsize(ATTRIB(s));
return(cnt);
}
static SEXP duplicate1(SEXP s, Rboolean deep)
{
SEXP t;
R_xlen_t i, n;
duplicate1_elts++;
duplicate_elts++;
switch (TYPEOF(s)) {
case NILSXP:
case SYMSXP:
case ENVSXP:
case SPECIALSXP:
case BUILTINSXP:
case EXTPTRSXP:
case BCODESXP:
case WEAKREFSXP:
return s;
case CLOSXP:
PROTECT(s);
PROTECT(t = allocSExp(CLOSXP));
SET_FORMALS(t, FORMALS(s));
SET_BODY(t, BODY(s));
SET_CLOENV(t, CLOENV(s));
DUPLICATE_ATTRIB(t, s, deep);
if (NOJIT(s)) SET_NOJIT(t);
if (MAYBEJIT(s)) SET_MAYBEJIT(t);
UNPROTECT(2);
break;
case LISTSXP:
PROTECT(s);
t = duplicate_list(s, deep);
UNPROTECT(1);
break;
case LANGSXP:
PROTECT(s);
PROTECT(t = duplicate_list(s, deep));
SET_TYPEOF(t, LANGSXP);
DUPLICATE_ATTRIB(t, s, deep);
UNPROTECT(2);
break;
case DOTSXP:
PROTECT(s);
PROTECT(t = duplicate_list(s, deep));
SET_TYPEOF(t, DOTSXP);
DUPLICATE_ATTRIB(t, s, deep);
UNPROTECT(2);
break;
case CHARSXP:
return s;
break;
case EXPRSXP:
case VECSXP:
n = XLENGTH(s);
PROTECT(s);
PROTECT(t = allocVector(TYPEOF(s), n));
for(i = 0 ; i < n ; i++)
SET_VECTOR_ELT(t, i, duplicate_child(VECTOR_ELT(s, i), deep));
DUPLICATE_ATTRIB(t, s, deep);
COPY_TRUELENGTH(t, s);
UNPROTECT(2);
break;
case LGLSXP: DUPLICATE_ATOMIC_VECTOR(int, LOGICAL, t, s, deep); break;
case INTSXP: DUPLICATE_ATOMIC_VECTOR(int, INTEGER, t, s, deep); break;
case REALSXP: DUPLICATE_ATOMIC_VECTOR(double, REAL, t, s, deep); break;
case CPLXSXP: DUPLICATE_ATOMIC_VECTOR(Rcomplex, COMPLEX, t, s, deep); break;
case RAWSXP: DUPLICATE_ATOMIC_VECTOR(Rbyte, RAW, t, s, deep); break;
case STRSXP:
/* direct copying and bypassing the write barrier is OK since
t was just allocated and so it cannot be older than any of
the elements in s. LT */
DUPLICATE_ATOMIC_VECTOR(SEXP, STRING_PTR, t, s, deep);
break;
case PROMSXP:
return s;
break;
case S4SXP:
PROTECT(s);
PROTECT(t = allocS4Object());
DUPLICATE_ATTRIB(t, s, deep);
UNPROTECT(2);
break;
default:
UNIMPLEMENTED_TYPE("duplicate", s);
t = s;/* for -Wall */
}
if(TYPEOF(t) == TYPEOF(s) ) { /* surely it only makes sense in this case*/
SET_OBJECT(t, OBJECT(s));
(IS_S4_OBJECT(s) ? SET_S4_OBJECT(t) : UNSET_S4_OBJECT(t));
}
return t;
}
/* do the two objects compute as identical?
Also used in unique.c */
Rboolean
R_compute_identical(SEXP x, SEXP y, int flags)
{
SEXP ax, ay, atrx, atry;
if(x == y) /* same pointer */
return TRUE;
if(TYPEOF(x) != TYPEOF(y))
return FALSE;
if(OBJECT(x) != OBJECT(y))
return FALSE;
/* Skip attribute checks for CHARSXP
-- such attributes are used for the cache. */
if(TYPEOF(x) == CHARSXP)
{
/* This matches NAs */
return Seql(x, y);
}
ax = ATTRIB(x); ay = ATTRIB(y);
if (!ATTR_AS_SET) {
if(!R_compute_identical(ax, ay, flags)) return FALSE;
}
/* Attributes are special: they should be tagged pairlists. We
don't test them if they are not, and we do not test the order
if they are.
This code is not very efficient, but then neither is using
pairlists for attributes. If long attribute lists become more
common (and they are used for S4 slots) we should store them in
a hash table.
*/
else if(ax != R_NilValue || ay != R_NilValue) {
if(ax == R_NilValue || ay == R_NilValue)
return FALSE;
if(TYPEOF(ax) != LISTSXP || TYPEOF(ay) != LISTSXP) {
warning(_("ignoring non-pairlist attributes"));
} else {
SEXP elx, ely;
if(length(ax) != length(ay)) return FALSE;
/* They are the same length and should have
unique non-empty non-NA tags */
for(elx = ax; elx != R_NilValue; elx = CDR(elx)) {
const char *tx = CHAR(PRINTNAME(TAG(elx)));
for(ely = ay; ely != R_NilValue; ely = CDR(ely))
if(streql(tx, CHAR(PRINTNAME(TAG(ely))))) {
/* We need to treat row.names specially here */
if(streql(tx, "row.names")) {
PROTECT(atrx = getAttrib(x, R_RowNamesSymbol));
PROTECT(atry = getAttrib(y, R_RowNamesSymbol));
if(!R_compute_identical(atrx, atry, flags)) {
UNPROTECT(2);
return FALSE;
} else
UNPROTECT(2);
} else
if(!R_compute_identical(CAR(elx), CAR(ely), flags))
return FALSE;
break;
}
if(ely == R_NilValue) return FALSE;
}
}
}
switch (TYPEOF(x)) {
case NILSXP:
return TRUE;
case LGLSXP:
if (length(x) != length(y)) return FALSE;
/* Use memcmp (which is ISO C90) to speed up the comparison */
return memcmp((void *)LOGICAL(x), (void *)LOGICAL(y),
length(x) * sizeof(int)) == 0 ? TRUE : FALSE;
case INTSXP:
if (length(x) != length(y)) return FALSE;
/* Use memcmp (which is ISO C90) to speed up the comparison */
return memcmp((void *)INTEGER(x), (void *)INTEGER(y),
length(x) * sizeof(int)) == 0 ? TRUE : FALSE;
case REALSXP:
{
int n = length(x);
if(n != length(y)) return FALSE;
else {
double *xp = REAL(x), *yp = REAL(y);
int i, ne_strict = NUM_EQ | (SINGLE_NA << 1);
for(i = 0; i < n; i++)
if(neWithNaN(xp[i], yp[i], ne_strict)) return FALSE;
}
return TRUE;
}
case CPLXSXP:
{
int n = length(x);
if(n != length(y)) return FALSE;
else {
Rcomplex *xp = COMPLEX(x), *yp = COMPLEX(y);
int i, ne_strict = NUM_EQ | (SINGLE_NA << 1);
for(i = 0; i < n; i++)
if(neWithNaN(xp[i].r, yp[i].r, ne_strict) ||
neWithNaN(xp[i].i, yp[i].i, ne_strict))
return FALSE;
}
return TRUE;
}
case STRSXP:
{
int i, n = length(x);
if(n != length(y)) return FALSE;
for(i = 0; i < n; i++) {
/* This special-casing for NAs is not needed */
Rboolean na1 = (STRING_ELT(x, i) == NA_STRING),
na2 = (STRING_ELT(y, i) == NA_STRING);
if(na1 ^ na2) return FALSE;
if(na1 && na2) continue;
if (! Seql(STRING_ELT(x, i), STRING_ELT(y, i))) return FALSE;
}
return TRUE;
}
case CHARSXP: /* Probably unreachable, but better safe than sorry... */
{
/* This matches NAs */
return Seql(x, y);
}
case VECSXP:
case EXPRSXP:
{
int i, n = length(x);
if(n != length(y)) return FALSE;
for(i = 0; i < n; i++)
if(!R_compute_identical(VECTOR_ELT(x, i),VECTOR_ELT(y, i), flags))
return FALSE;
return TRUE;
}
case LANGSXP:
case LISTSXP:
{
while (x != R_NilValue) {
if(y == R_NilValue)
return FALSE;
if(!R_compute_identical(CAR(x), CAR(y), flags))
return FALSE;
if(!R_compute_identical(PRINTNAME(TAG(x)), PRINTNAME(TAG(y)), flags))
return FALSE;
x = CDR(x);
y = CDR(y);
}
return(y == R_NilValue);
}
case CLOSXP:
return(R_compute_identical(FORMALS(x), FORMALS(y), flags) &&
R_compute_identical(BODY_EXPR(x), BODY_EXPR(y), flags) &&
(CLOENV(x) == CLOENV(y) ? TRUE : FALSE) &&
(IGNORE_BYTECODE || R_compute_identical(BODY(x), BODY(y), flags))
);
case SPECIALSXP:
case BUILTINSXP:
return(PRIMOFFSET(x) == PRIMOFFSET(y) ? TRUE : FALSE);
case ENVSXP:
case SYMSXP:
case WEAKREFSXP:
case BCODESXP: /**** is this the best approach? */
return(x == y ? TRUE : FALSE);
case EXTPTRSXP:
return (EXTPTR_PTR(x) == EXTPTR_PTR(y) ? TRUE : FALSE);
case RAWSXP:
if (length(x) != length(y)) return FALSE;
/* Use memcmp (which is ISO C90) to speed up the comparison */
return memcmp((void *)RAW(x), (void *)RAW(y),
length(x) * sizeof(Rbyte)) == 0 ? TRUE : FALSE;
/* case PROMSXP: args are evaluated, so will not be seen */
/* test for equality of the substituted expression -- or should
we require both expression and environment to be identical? */
/*#define PREXPR(x) ((x)->u.promsxp.expr)
#define PRENV(x) ((x)->u.promsxp.env)
return(R_compute_identical(subsititute(PREXPR(x), PRENV(x),
flags),
subsititute(PREXPR(y), PRENV(y))));*/
case S4SXP:
/* attributes already tested, so all slots identical */
return TRUE;
default:
/* these are all supposed to be types that represent constant
entities, so no further testing required ?? */
printf("Unknown Type: %s (%x)\n", type2char(TYPEOF(x)), TYPEOF(x));
return TRUE;
}
}
