[rkward-cvs] SF.net SVN: rkward: [1811] trunk/rkward/rkward/rbackend
tfry at users.sourceforge.net
tfry at users.sourceforge.net
Wed Apr 11 22:41:43 UTC 2007
Revision: 1811
http://svn.sourceforge.net/rkward/?rev=1811&view=rev
Author: tfry
Date: 2007-04-11 15:41:42 -0700 (Wed, 11 Apr 2007)
Log Message:
-----------
First semi functional version of the new .rk.get.structure(). Still unfinished, and unused.
Modified Paths:
--------------
trunk/rkward/rkward/rbackend/rembedinternal.cpp
trunk/rkward/rkward/rbackend/rkstructuregetter.cpp
trunk/rkward/rkward/rbackend/rkstructuregetter.h
Modified: trunk/rkward/rkward/rbackend/rembedinternal.cpp
===================================================================
--- trunk/rkward/rkward/rbackend/rembedinternal.cpp 2007-04-11 19:32:43 UTC (rev 1810)
+++ trunk/rkward/rkward/rbackend/rembedinternal.cpp 2007-04-11 22:41:42 UTC (rev 1811)
@@ -649,7 +649,7 @@
{ "rk.do.error", (DL_FUNC) &doError, 1 },
{ "rk.do.command", (DL_FUNC) &doSubstackCall, 1 },
{ "rk.update.locale", (DL_FUNC) &doUpdateLocale, 0 },
- { "rk.get.structure.test", (DL_FUNC) &doGetStructureTest, 0 },
+ { "rk.get.structure.test", (DL_FUNC) &doGetStructureTest, 3 },
{ 0, 0, 0 }
};
R_registerRoutines (info, NULL, callMethods, NULL, NULL);
Modified: trunk/rkward/rkward/rbackend/rkstructuregetter.cpp
===================================================================
--- trunk/rkward/rkward/rbackend/rkstructuregetter.cpp 2007-04-11 19:32:43 UTC (rev 1810)
+++ trunk/rkward/rkward/rbackend/rkstructuregetter.cpp 2007-04-11 22:41:42 UTC (rev 1811)
@@ -24,69 +24,117 @@
class_fun = Rf_findFun (Rf_install ("class"), R_BaseEnv);;
PROTECT (class_fun);
+ RK_ASSERT (!Rf_isNull (class_fun));
meta_attrib = Rf_install (".rk.meta");
PROTECT (meta_attrib);
+ RK_ASSERT (!Rf_isNull (meta_attrib));
+
+ get_meta_fun = Rf_findFun (Rf_install (".rk.get.meta"), R_GlobalEnv);;
+ PROTECT (get_meta_fun);
+ RK_ASSERT (!Rf_isNull (get_meta_fun));
}
RKStructureGetter::~RKStructureGetter () {
RK_TRACE (RBACKEND);
- UNPROTECT (2); /* meta_attrib, class_fun */
+ UNPROTECT (3); /* get_meta_fun, meta_attrib, class_fun */
}
RData *RKStructureGetter::getStructure (SEXP toplevel, SEXP name, SEXP namespacename) {
RK_TRACE (RBACKEND);
+ envir_depth = 0;
+
unsigned int count;
QString *name_dummy = SEXPToStringList (name, &count);
RK_ASSERT (count == 1);
QString name_string = name_dummy[0];
delete [] name_dummy;
- // TODO: resolve namespace, if needed
+ // resolve namespace, if needed
+ if (Rf_isNull (namespacename)) {
+ with_namespace = false;
+ } else {
+ with_namespace = true;
+ SEXP as_ns_fun = Rf_findFun (Rf_install ("asNamespace"), R_BaseEnv);;
+ PROTECT (as_ns_fun);
+ RK_ASSERT (!Rf_isNull (as_ns_fun));
+
+ SEXP call = allocVector (LANGSXP, 2);
+ PROTECT (call);
+ SETCAR (call, as_ns_fun);
+ SETCAR (CDR (call), namespacename);
+ int error;
+ SEXP namespace_envir = R_tryEval (call, R_GlobalEnv, &error);
+ UNPROTECT (2); /* as_ns_fun, call */
+
+ if (error) namespace_envir = R_NilValue;
+
+ PROTECT (namespace_envir);
+ }
+
RData *ret = new RData;
// TODO: wrap inside a toplevel exec
- getStructureWorker (toplevel, name_string, /* TODO */ false, ret);
+ getStructureWorker (toplevel, name_string, ret);
+ if (with_namespace) {
+ UNPROTECT (1); /* namespace_envir */
+ }
+
return ret;
+}
+SEXP RKStructureGetter::resolvePromise (SEXP from) {
+ RK_TRACE (RBACKEND);
-/*
- char *cname = (char*) STRING_PTR (VECTOR_ELT (name, 0));
- SEXP val = findVar (install(CHAR(STRING_ELT(name, 0))), envir);
- if (TYPEOF (val) == PROMSXP) {
- qDebug ("name %s, type %d, unbound %d", cname, TYPEOF (val), PRVALUE(val) == R_UnboundValue);
- } */
+ SEXP ret = from;
+ if (TYPEOF (from) == PROMSXP) {
+ if (PRVALUE(from) == R_UnboundValue) {
+ PROTECT (from);
+ SET_PRSEEN(from, 1);
+ ret = eval(PRCODE(from), PRENV(from));
+ SET_PRSEEN(from, 0);
+ if (keep_evalled_promises) {
+ SET_PRVALUE(from, ret);
+ SET_PRENV(from, R_NilValue);
+ }
+ UNPROTECT (1);
+ }
+ }
+
+ return ret;
}
-void RKStructureGetter::getStructureWorker (SEXP value, const QString &name, bool misplaced, RData *storage) {
+void RKStructureGetter::getStructureWorker (SEXP val, const QString &name, RData *storage) {
RK_TRACE (RBACKEND);
bool is_function = false;
bool is_container = false;
+ bool is_environment = false;
unsigned int type = 0;
unsigned int count;
SEXP call;
- // TODO: move all this logic to a separate file
- // TODO: instead of returning an RData, take the parent as parameter, and add to that. Why? Because this way we can tie up all the data earlier. Then, if there is an error (hopefully, there isn't, of course), most memory can be released easily, without the need for much bookkeeping).
+ PROTECT (val);
+ // manually resolve any promises
+ SEXP value = resolvePromise (val);
+ PROTECT (value);
+ UNPROTECT (1); /* val */
- // TODO: make name parameter a const QString&
- // TODO: can namespacename be pre-resolved to a namespace environment? Not that it should matter too much, as it is only needed when recursing into environments, and only once per env.
+ //qDebug ("fetching %s", name.latin1());
- // TODO: manually resolve promises
-
// first field: get name
RData *namedata = new RData;
namedata->datatype = RData::StringVector;
- QString *dummy = new QString[1];
- dummy[0] = name;
- namedata->data = dummy;
+ namedata->length = 1;
+ QString *name_dummy = new QString[1];
+ name_dummy[0] = name;
+ namedata->data = name_dummy;
- // get classes (note that those are the third element in the RData for historical reasons, but we need to fetch them earlier, in order to find out, whether an object is a data.frame.
+ // get classes
call = allocVector (LANGSXP, 2);
PROTECT (call);
SETCAR (call, class_fun);
@@ -97,6 +145,12 @@
unsigned int num_classes = count;
UNPROTECT (2); /* classes_s, call */
+ // store classes
+ RData *classdata = new RData;
+ classdata->datatype = RData::StringVector;
+ classdata->data = classes;
+ classdata->length = num_classes;
+
// basic classification
for (unsigned int i = 0; i < num_classes; ++i) {
if (classes[i] == "data.frame") type |= RObject::DataFrame;
@@ -115,6 +169,7 @@
type |= RObject::Function;
} else if (Rf_isEnvironment (value)) {
is_container = true;
+ is_environment = true;
type |= RObject::Environment;
} else {
type |= RObject::Variable;
@@ -124,19 +179,132 @@
else if (Rf_isLogical (value)) type |= RObject::Logical;
}
}
- if (!Rf_isNull (Rf_getAttrib (value, meta_attrib))) type |= RObject::HasMetaObject;
- if (misplaced) type |= RObject::Misplaced;
- // TODO: store type
+ // TODO: is it misplaced?
+ if (with_namespace) {
+ // TODO!
+ type |= RObject::Misplaced;
+ }
- // TODO: store classes
+ // get meta data, if any
+ RData *metadata = new RData;
+ metadata->datatype = RData::StringVector;
+ if (!Rf_isNull (Rf_getAttrib (value, meta_attrib))) {
+ type |= RObject::HasMetaObject;
- // TODO: get and store dims
+ call = allocVector (LANGSXP, 2);
+ PROTECT (call);
+ SETCAR (call, get_meta_fun);
+ SETCAR (CDR (call), value);
+ SEXP meta_s = Rf_eval (call, R_GlobalEnv);
+ PROTECT (meta_s);
+ metadata->data = SEXPToStringList (classes_s, &count);
+ metadata->length = count;
+ UNPROTECT (2); /* meta_s, call */
+ } else {
+ metadata->length = 1;
+ QString *meta_dummy = new QString[1];
+ meta_dummy[0] = "";
+ metadata->data = meta_dummy;
+ }
+ // store type
+ RData *typedata = new RData;
+ typedata->datatype = RData::IntVector;
+ typedata->length = 1;
+ int *type_dummy = new int[1];
+ type_dummy[0] = type;
+ typedata->data = type_dummy;
+
+ // get dims
+ int *dims;
+ unsigned int num_dims;
+ SEXP dims_s = Rf_getAttrib (value, R_DimSymbol);
+ if (!Rf_isNull (dims_s)) {
+ dims = SEXPToIntArray (dims_s, &num_dims);
+ } else {
+ num_dims = 1;
+ dims = new int[1];
+ dims[0] = Rf_length (dims_s);
+ }
+
+ // store dims
+ RData *dimdata = new RData;
+ dimdata->datatype = RData::IntVector;
+ dimdata->length = num_dims;
+ dimdata->data = dims;
+
+ // store everything we have so far
if (is_container) {
- // TODO: get and store children
+ storage->length = 6;
} else if (is_function) {
+ storage->length = 7;
+ } else {
+ storage->length = 5;
+ }
+ storage->datatype = RData::StructureVector;
+ RData **res = new RData*[storage->length];
+ storage->data = res;
+ res[0] = namedata;
+ res[1] = typedata;
+ res[2] = classdata;
+ res[3] = metadata;
+ res[4] = dimdata;
+
+ // now add the extra info for containers and functions
+ if (is_container) {
+ RData *childdata = new RData;
+ childdata->datatype = RData::StructureVector;
+ childdata->length = 0;
+ childdata->data = 0;
+ res[5] = childdata;
+
+ if (is_environment) {
+ if (++envir_depth > 1) {
+ } else {
+ //qDebug ("recurse into %s", name.latin1());
+
+ unsigned int childcount;
+ SEXP childnames_s = R_lsInternal (value, (Rboolean) 1);
+ PROTECT (childnames_s);
+ QString *childnames = SEXPToStringList (childnames_s, &childcount);
+
+ childdata->length = childcount;
+ RData **children = new RData*[childcount];
+ childdata->data = children;
+ childdata->length = childcount;
+ for (unsigned int i = 0; i < childcount; ++i) { // in case there is an error while fetching one of the children, let's pre-initialize everything.
+ children[i] = new RData;
+ children[i]->data = 0;
+ children[i]->length = 0;
+ children[i]->datatype = RData::NoData;
+ }
+ for (unsigned int i = 0; i < childcount; ++i) {
+ SEXP child = Rf_findVar (install(CHAR(STRING_ELT(childnames_s, i))), value);
+ getStructureWorker (child, childnames[i], children[i]);
+ }
+ UNPROTECT (1); /* childnames_s */
+ }
+ --envir_depth;
+ } else {
+ // TODO: get children from list
+ }
+ } else if (is_function) {
+ RData *funargsdata = new RData;
+ funargsdata->datatype = RData::StructureVector;
+ funargsdata->length = 0;
+ funargsdata->data = 0;
+ res[5] = funargsdata;
+
+ RData *funargvaluesdata = new RData;
+ funargvaluesdata->datatype = RData::StructureVector;
+ funargvaluesdata->length = 0;
+ funargvaluesdata->data = 0;
+ res[6] = funargvaluesdata;
+
// TODO: get and store arguments
}
+
+ UNPROTECT (1); /* value */
}
Modified: trunk/rkward/rkward/rbackend/rkstructuregetter.h
===================================================================
--- trunk/rkward/rkward/rbackend/rkstructuregetter.h 2007-04-11 19:32:43 UTC (rev 1810)
+++ trunk/rkward/rkward/rbackend/rkstructuregetter.h 2007-04-11 22:41:42 UTC (rev 1811)
@@ -28,13 +28,15 @@
RData *getStructure (SEXP toplevel, SEXP name, SEXP namespacename);
private:
- void getStructureWorker (SEXP value, const QString &name, bool misplaced, RData *storage);
+ void getStructureWorker (SEXP value, const QString &name, RData *storage);
+ SEXP resolvePromise (SEXP from);
bool with_namespace;
SEXP namespace_envir;
SEXP class_fun;
SEXP meta_attrib;
+ SEXP get_meta_fun;
bool keep_evalled_promises;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
More information about the rkward-tracker
mailing list