// enabling tracing on a function turns it into an S4 object with an 'original'
// slot that includes the function's original contents. use this instead if
// it's set up. (consider: is it safe to assume that S4 objects here are always
// traced functions, or do we need to compare classes to be safe?)
SEXP RCntxt::originalFunctionCall() const
{
SEXP callObject = callfun();
if (Rf_isS4(callObject))
{
callObject = r::sexp::getAttrib(callObject, "original");
}
return callObject;
}
char *nvimcom_browser_line(SEXP *x, const char *xname, const char *curenv, const char *prefix, char *p)
{
char xclass[64];
char newenv[512];
char curenvB[512];
char ebuf[64];
char pre[128];
char newpre[128];
int len;
const char *ename;
SEXP listNames, label, lablab, eexp, elmt = R_NilValue;
SEXP cmdSexp, cmdexpr, ans, cmdSexp2, cmdexpr2;
ParseStatus status, status2;
int er = 0;
char buf[128];
if(strlen(xname) > 64)
return p;
if(obbrbufzise < strlen(obbrbuf2) + 1024)
p = nvimcom_grow_obbrbuf();
p = nvimcom_strcat(p, prefix);
if(Rf_isLogical(*x)){
p = nvimcom_strcat(p, "%#");
strcpy(xclass, "logical");
} else if(Rf_isNumeric(*x)){
p = nvimcom_strcat(p, "{#");
strcpy(xclass, "numeric");
} else if(Rf_isFactor(*x)){
p = nvimcom_strcat(p, "'#");
strcpy(xclass, "factor");
} else if(Rf_isValidString(*x)){
p = nvimcom_strcat(p, "\"#");
strcpy(xclass, "character");
} else if(Rf_isFunction(*x)){
p = nvimcom_strcat(p, "(#");
strcpy(xclass, "function");
} else if(Rf_isFrame(*x)){
p = nvimcom_strcat(p, "[#");
strcpy(xclass, "data.frame");
} else if(Rf_isNewList(*x)){
p = nvimcom_strcat(p, "[#");
strcpy(xclass, "list");
} else if(Rf_isS4(*x)){
p = nvimcom_strcat(p, "<#");
strcpy(xclass, "s4");
} else if(TYPEOF(*x) == PROMSXP){
p = nvimcom_strcat(p, "&#");
strcpy(xclass, "lazy");
} else {
p = nvimcom_strcat(p, "=#");
strcpy(xclass, "other");
}
PROTECT(lablab = allocVector(STRSXP, 1));
SET_STRING_ELT(lablab, 0, mkChar("label"));
PROTECT(label = getAttrib(*x, lablab));
p = nvimcom_strcat(p, xname);
p = nvimcom_strcat(p, "\t");
if(length(label) > 0){
if(Rf_isValidString(label)){
snprintf(buf, 127, "%s", CHAR(STRING_ELT(label, 0)));
p = nvimcom_strcat(p, buf);
} else {
if(labelerr)
p = nvimcom_strcat(p, "Error: label isn't \"character\".");
}
}
p = nvimcom_strcat(p, "\n");
UNPROTECT(2);
if(strcmp(xclass, "list") == 0 || strcmp(xclass, "data.frame") == 0 || strcmp(xclass, "s4") == 0){
strncpy(curenvB, curenv, 500);
if(xname[0] == '[' && xname[1] == '['){
curenvB[strlen(curenvB) - 1] = 0;
}
if(strcmp(xclass, "s4") == 0)
snprintf(newenv, 500, "%s%s@", curenvB, xname);
else
snprintf(newenv, 500, "%s%s$", curenvB, xname);
if((nvimcom_get_list_status(newenv, xclass) == 1)){
len = strlen(prefix);
if(nvimcom_is_utf8){
int j = 0, i = 0;
while(i < len){
if(prefix[i] == '\xe2'){
i += 3;
if(prefix[i-1] == '\x80' || prefix[i-1] == '\x94'){
pre[j] = ' '; j++;
} else {
pre[j] = '\xe2'; j++;
pre[j] = '\x94'; j++;
pre[j] = '\x82'; j++;
}
} else {
pre[j] = prefix[i];
i++, j++;
}
}
pre[j] = 0;
} else {
for(int i = 0; i < len; i++){
if(prefix[i] == '-' || prefix[i] == '`')
pre[i] = ' ';
else
pre[i] = prefix[i];
}
pre[len] = 0;
}
sprintf(newpre, "%s%s", pre, strT);
if(strcmp(xclass, "s4") == 0){
snprintf(buf, 127, "slotNames(%s%s)", curenvB, xname);
PROTECT(cmdSexp = allocVector(STRSXP, 1));
SET_STRING_ELT(cmdSexp, 0, mkChar(buf));
PROTECT(cmdexpr = R_ParseVector(cmdSexp, -1, &status, R_NilValue));
if (status != PARSE_OK) {
p = nvimcom_strcat(p, "nvimcom error: invalid value in slotNames(");
p = nvimcom_strcat(p, xname);
p = nvimcom_strcat(p, ")\n");
} else {
PROTECT(ans = R_tryEval(VECTOR_ELT(cmdexpr, 0), R_GlobalEnv, &er));
if(er){
p = nvimcom_strcat(p, "nvimcom error: ");
p = nvimcom_strcat(p, xname);
p = nvimcom_strcat(p, "\n");
} else {
len = length(ans);
if(len > 0){
int len1 = len - 1;
for(int i = 0; i < len; i++){
ename = CHAR(STRING_ELT(ans, i));
snprintf(buf, 127, "%s%s@%s", curenvB, xname, ename);
PROTECT(cmdSexp2 = allocVector(STRSXP, 1));
SET_STRING_ELT(cmdSexp2, 0, mkChar(buf));
PROTECT(cmdexpr2 = R_ParseVector(cmdSexp2, -1, &status2, R_NilValue));
if (status2 != PARSE_OK) {
p = nvimcom_strcat(p, "nvimcom error: invalid code \"");
p = nvimcom_strcat(p, xname);
p = nvimcom_strcat(p, "@");
p = nvimcom_strcat(p, ename);
p = nvimcom_strcat(p, "\"\n");
} else {
PROTECT(elmt = R_tryEval(VECTOR_ELT(cmdexpr2, 0), R_GlobalEnv, &er));
if(i == len1)
sprintf(newpre, "%s%s", pre, strL);
p = nvimcom_browser_line(&elmt, ename, newenv, newpre, p);
UNPROTECT(1);
}
UNPROTECT(2);
}
}
}
UNPROTECT(1);
}
UNPROTECT(2);
} else {
PROTECT(listNames = getAttrib(*x, R_NamesSymbol));
len = length(listNames);
if(len == 0){ /* Empty list? */
int len1 = length(*x);
if(len1 > 0){ /* List without names */
len1 -= 1;
for(int i = 0; i < len1; i++){
sprintf(ebuf, "[[%d]]", i + 1);
elmt = VECTOR_ELT(*x, i);
p = nvimcom_browser_line(&elmt, ebuf, newenv, newpre, p);
}
sprintf(newpre, "%s%s", pre, strL);
sprintf(ebuf, "[[%d]]", len1 + 1);
PROTECT(elmt = VECTOR_ELT(*x, len));
p = nvimcom_browser_line(&elmt, ebuf, newenv, newpre, p);
UNPROTECT(1);
}
} else { /* Named list */
len -= 1;
for(int i = 0; i < len; i++){
PROTECT(eexp = STRING_ELT(listNames, i));
ename = CHAR(eexp);
UNPROTECT(1);
if(ename[0] == 0){
sprintf(ebuf, "[[%d]]", i + 1);
ename = ebuf;
}
PROTECT(elmt = VECTOR_ELT(*x, i));
p = nvimcom_browser_line(&elmt, ename, newenv, newpre, p);
UNPROTECT(1);
}
sprintf(newpre, "%s%s", pre, strL);
ename = CHAR(STRING_ELT(listNames, len));
if(ename[0] == 0){
sprintf(ebuf, "[[%d]]", len + 1);
ename = ebuf;
}
PROTECT(elmt = VECTOR_ELT(*x, len));
p = nvimcom_browser_line(&elmt, ename, newenv, newpre, p);
UNPROTECT(1);
}
UNPROTECT(1); /* listNames */
}
}
}
return p;
}
// 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);
}
