[rkward-cvs] SF.net SVN: rkward: [1816] trunk/rkward
tfry at users.sourceforge.net
tfry at users.sourceforge.net
Mon Apr 16 17:17:29 UTC 2007
Revision: 1816
http://svn.sourceforge.net/rkward/?rev=1816&view=rev
Author: tfry
Date: 2007-04-16 10:17:29 -0700 (Mon, 16 Apr 2007)
Log Message:
-----------
Fragments and lots of debug code
Modified Paths:
--------------
trunk/rkward/ChangeLog
trunk/rkward/rkward/rbackend/Makefile.am
trunk/rkward/rkward/rbackend/rkstructuregetter.cpp
trunk/rkward/rkward/rbackend/rkstructuregetter.h
Modified: trunk/rkward/ChangeLog
===================================================================
--- trunk/rkward/ChangeLog 2007-04-15 16:37:38 UTC (rev 1815)
+++ trunk/rkward/ChangeLog 2007-04-16 17:17:29 UTC (rev 1816)
@@ -1,3 +1,4 @@
+- compilation fix for FreeBSD (thanks to Thierry Thomas)
- fixed: when executing commands line by line from the script editor, line breaks would be omitted
- Messages, warnings, and errors for plugin commands are shown in the output, instead of in a dialog
Modified: trunk/rkward/rkward/rbackend/Makefile.am
===================================================================
--- trunk/rkward/rkward/rbackend/Makefile.am 2007-04-15 16:37:38 UTC (rev 1815)
+++ trunk/rkward/rkward/rbackend/Makefile.am 2007-04-16 17:17:29 UTC (rev 1816)
@@ -9,3 +9,5 @@
noinst_HEADERS = rembedinternal.h rinterface.h rthread.h rcommand.h rcommandreceiver.h rcommandstack.h \
rdata.h rkpthreadsupport.h rklocalesupport.h
SUBDIRS = rpackages
+
+rembedinternal.o: rkstructuregetter.cpp
\ No newline at end of file
Modified: trunk/rkward/rkward/rbackend/rkstructuregetter.cpp
===================================================================
--- trunk/rkward/rkward/rbackend/rkstructuregetter.cpp 2007-04-15 16:37:38 UTC (rev 1815)
+++ trunk/rkward/rkward/rbackend/rkstructuregetter.cpp 2007-04-16 17:17:29 UTC (rev 1816)
@@ -33,14 +33,77 @@
get_meta_fun = Rf_findFun (Rf_install (".rk.get.meta"), R_GlobalEnv);;
PROTECT (get_meta_fun);
RK_ASSERT (!Rf_isNull (get_meta_fun));
+
+// Why do we need all these? Because the is.xxx functions may do an internal dispatch, that we do not want to miss, but don't easily get by e.g. calling Rf_isFunction() directly.
+ is_matrix_fun = Rf_findFun (Rf_install ("is.matrix"), R_BaseEnv);;
+ PROTECT (is_matrix_fun);
+ RK_ASSERT (!Rf_isNull (is_matrix_fun));
+
+ is_array_fun = Rf_findFun (Rf_install ("is.array"), R_BaseEnv);;
+ PROTECT (is_array_fun);
+ RK_ASSERT (!Rf_isNull (is_array_fun));
+
+ is_list_fun = Rf_findFun (Rf_install ("is.list"), R_BaseEnv);;
+ PROTECT (is_list_fun);
+ RK_ASSERT (!Rf_isNull (is_list_fun));
+
+ is_function_fun = Rf_findFun (Rf_install ("is.function"), R_BaseEnv);;
+ PROTECT (is_function_fun);
+ RK_ASSERT (!Rf_isNull (is_function_fun));
+
+ is_environment_fun = Rf_findFun (Rf_install ("is.environment"), R_BaseEnv);;
+ PROTECT (is_environment_fun);
+ RK_ASSERT (!Rf_isNull (is_environment_fun));
+
+ is_factor_fun = Rf_findFun (Rf_install ("is.factor"), R_BaseEnv);;
+ PROTECT (is_factor_fun);
+ RK_ASSERT (!Rf_isNull (is_factor_fun));
+
+ is_numeric_fun = Rf_findFun (Rf_install ("is.numeric"), R_BaseEnv);;
+ PROTECT (is_numeric_fun);
+ RK_ASSERT (!Rf_isNull (is_numeric_fun));
+
+ is_character_fun = Rf_findFun (Rf_install ("is.character"), R_BaseEnv);;
+ PROTECT (is_character_fun);
+ RK_ASSERT (!Rf_isNull (is_character_fun));
+
+ is_logical_fun = Rf_findFun (Rf_install ("is.logical"), R_BaseEnv);;
+ PROTECT (is_logical_fun);
+ RK_ASSERT (!Rf_isNull (is_logical_fun));
+
+ names_fun = Rf_findFun (Rf_install ("names"), R_BaseEnv);;
+ PROTECT (names_fun);
+ RK_ASSERT (!Rf_isNull (names_fun));
+
+ /* TODO:
+ formals-handling
+ */
}
RKStructureGetter::~RKStructureGetter () {
RK_TRACE (RBACKEND);
- UNPROTECT (3); /* get_meta_fun, meta_attrib, class_fun */
+ UNPROTECT (13); /* all the pre-resolved functions */
}
+SEXP RKStructureGetter::callSimpleFun (SEXP fun, SEXP arg) {
+ SEXP call = allocVector (LANGSXP, 2);
+ PROTECT (call);
+ SETCAR (call, fun);
+ SETCAR (CDR (call), arg);
+
+ SEXP ret = eval (call, R_GlobalEnv);
+
+ UNPROTECT (1); /* call */
+ return ret;
+}
+
+bool RKStructureGetter::callSimpleBool (SEXP fun, SEXP arg) {
+ SEXP res = callSimpleFun (fun, arg);
+ RK_ASSERT (TYPEOF (res) == LGLSXP);
+ return ((bool) VECTOR_ELT (res, 0));
+}
+
RData *RKStructureGetter::getStructure (SEXP toplevel, SEXP name, SEXP namespacename) {
RK_TRACE (RBACKEND);
@@ -67,7 +130,7 @@
SETCAR (call, as_ns_fun);
SETCAR (CDR (call), namespacename);
int error;
- SEXP namespace_envir = R_tryEval (call, R_GlobalEnv, &error);
+ namespace_envir = R_tryEval (call, R_GlobalEnv, &error);
UNPROTECT (2); /* as_ns_fun, call */
if (error) namespace_envir = R_NilValue;
@@ -77,7 +140,7 @@
RData *ret = new RData;
// TODO: wrap inside a toplevel exec
- getStructureWorker (toplevel, name_string, ret);
+ getStructureWorker (toplevel, name_string, false, ret);
if (with_namespace) {
UNPROTECT (1); /* namespace_envir */
@@ -90,25 +153,35 @@
RK_TRACE (RBACKEND);
SEXP ret = from;
-
+qDebug ("resolving type: %d", TYPEOF (from));
if (TYPEOF (from) == PROMSXP) {
+qDebug ("resolving: is a promise");
if (PRVALUE(from) == R_UnboundValue) {
PROTECT (from);
SET_PRSEEN(from, 1);
+qDebug ("resolve1");
ret = eval(PRCODE(from), PRENV(from));
+qDebug ("resolve2");
SET_PRSEEN(from, 0);
+qDebug ("resolve3");
if (keep_evalled_promises) {
SET_PRVALUE(from, ret);
SET_PRENV(from, R_NilValue);
}
+qDebug ("resolve4");
UNPROTECT (1);
}
+ } else if (TYPEOF (from) == SYMSXP) {
+qDebug ("resolving: is a symbol");
+// TODO! (and do we actually need this?)
+ return R_NilValue;
}
return ret;
}
-void RKStructureGetter::getStructureWorker (SEXP val, const QString &name, RData *storage) {
+// 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, bool misplaced, RData *storage) {
RK_TRACE (RBACKEND);
bool is_function = false;
@@ -118,13 +191,17 @@
unsigned int count;
SEXP call;
+ qDebug ("fetching '%s': %p", name.latin1(), val);
+
PROTECT (val);
// manually resolve any promises
SEXP value = resolvePromise (val);
+qDebug ("a");
+ UNPROTECT (1); /* val */
+qDebug ("b");
PROTECT (value);
- UNPROTECT (1); /* val */
- //qDebug ("fetching %s", name.latin1());
+qDebug ("resolved");
// first field: get name
RData *namedata = new RData;
@@ -135,15 +212,11 @@
namedata->data = name_dummy;
// get classes
- call = allocVector (LANGSXP, 2);
- PROTECT (call);
- SETCAR (call, class_fun);
- SETCAR (CDR (call), value);
- SEXP classes_s = Rf_eval (call, R_GlobalEnv);
+ SEXP classes_s = callSimpleFun (class_fun, value);
PROTECT (classes_s);
QString *classes = SEXPToStringList (classes_s, &count);
unsigned int num_classes = count;
- UNPROTECT (2); /* classes_s, call */
+ UNPROTECT (1); /* classes_s */
// store classes
RData *classdata = new RData;
@@ -156,51 +229,42 @@
if (classes[i] == "data.frame") type |= RObject::DataFrame;
}
- if (Rf_isMatrix (value)) type |= RObject::Matrix;
- if (Rf_isArray (value)) type |= RObject::Array;
- if (Rf_isList (value)) type |= RObject::List;
- if (Rf_isNewList (value)) type |= RObject::List;
+ if (callSimpleBool (is_matrix_fun, value)) type |= RObject::Matrix;
+ if (callSimpleBool (is_array_fun, value)) type |= RObject::Array;
+ if (callSimpleBool (is_list_fun, value)) type |= RObject::List;
if (type != 0) {
is_container = true;
} else {
- if (Rf_isFunction (value)) {
+ if (callSimpleBool (is_function_fun, value)) {
+qDebug ("funpre");
is_function = true;
type |= RObject::Function;
- } else if (Rf_isEnvironment (value)) {
+ } else if (callSimpleBool (is_environment_fun, value)) {
is_container = true;
is_environment = true;
type |= RObject::Environment;
} else {
type |= RObject::Variable;
- if (Rf_isFactor (value)) type |= RObject::Factor;
- else if (Rf_isNumeric (value)) type |= RObject::Numeric;
- else if (Rf_isString (value)) type |= RObject::Character;
- else if (Rf_isLogical (value)) type |= RObject::Logical;
+ if (callSimpleBool (is_factor_fun, value)) type |= RObject::Factor;
+ else if (callSimpleBool (is_numeric_fun, value)) type |= RObject::Numeric;
+ else if (callSimpleBool (is_character_fun, value)) type |= RObject::Character;
+ else if (callSimpleBool (is_logical_fun, value)) type |= RObject::Logical;
}
}
+ if (misplaced) type |= RObject::Misplaced;
- // TODO: is it misplaced?
- if (with_namespace) {
- // TODO!
- type |= RObject::Misplaced;
- }
-
// get meta data, if any
RData *metadata = new RData;
metadata->datatype = RData::StringVector;
if (!Rf_isNull (Rf_getAttrib (value, meta_attrib))) {
type |= RObject::HasMetaObject;
- call = allocVector (LANGSXP, 2);
- PROTECT (call);
- SETCAR (call, get_meta_fun);
- SETCAR (CDR (call), value);
- SEXP meta_s = Rf_eval (call, R_GlobalEnv);
+ SEXP meta_s = callSimpleFun (get_meta_fun, value);
PROTECT (meta_s);
metadata->data = SEXPToStringList (classes_s, &count);
metadata->length = count;
- UNPROTECT (2); /* meta_s, call */
+ UNPROTECT (1); /* meta_s */
} else {
metadata->length = 1;
QString *meta_dummy = new QString[1];
@@ -253,56 +317,130 @@
// now add the extra info for containers and functions
if (is_container) {
+ bool do_env = (is_environment && (++envir_depth < 2));
+ bool do_cont = is_container && (!is_environment);
+
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());
+ // fetch list of child names
+ unsigned int childcount;
+ SEXP childnames_s;
+ if (do_env) {
+ childnames_s = R_lsInternal (value, (Rboolean) 1);
+ } else if (do_cont) {
+ childnames_s = callSimpleFun (names_fun, value);
+ } else {
+ childnames_s = R_NilValue; // dummy
+ }
+ PROTECT (childnames_s);
+ QString *childnames = SEXPToStringList (childnames_s, &childcount);
+QString dummy;
+for (unsigned int i = 0; i < childcount; ++i) {
+ dummy.append (childnames[i] + "\t");
+}
+qDebug ("%s", dummy.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;
+ }
- 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;
+ if (do_env) {
+ qDebug ("recurse into environment %s", name.latin1());
+ for (unsigned int i = 0; i < childcount; ++i) {
+ SEXP current_childname = install(CHAR(STRING_ELT(childnames_s, i)));
+ PROTECT (current_childname);
+ SEXP child = Rf_findVar (current_childname, value);
+ PROTECT (child);
+
+ bool child_misplaced = false;
+ if (with_namespace) {
+ /* before R 2.4.0, operator "::" would only work on true namespaces, not on package names (operator "::" work, if there is a namespace, and that namespace has the symbol in it)
+ TODO remove once we depend on R >= 2.4.0 */
+# ifndef R_2_5
+ if (Rf_isNull (namespace_envir)) {
+ child_misplaced = true;
+ } else {
+ SEXP dummy = Rf_findVar (current_childname, namespace_envir);
+ if (Rf_isNull (dummy)) child_misplaced = true;
+ }
+ /* for R 2.4.0 or greater: operator "::" works if package has no namespace at all, or has a namespace with the symbol in it */
+# else
+ if (!Rf_isNull (namespace_envir)) {
+ SEXP dummy = Rf_findVar (current_childname, namespace_envir);
+ if (Rf_isNull (dummy)) child_misplaced = true;
+ }
+# endif
}
- 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 */
+
+ getStructureWorker (child, childnames[i], child_misplaced, children[i]);
+ UNPROTECT (2); /* childname, child */
}
- --envir_depth;
- } else {
- // TODO: get children from list
+ } else if (do_cont) {
+ qDebug ("recurse into list %s", name.latin1());
+ for (unsigned int i = 0; i < childcount; ++i) {
+ SEXP child = VECTOR_ELT(value, i);
+ getStructureWorker (child, childnames[i], false, children[i]);
+ }
}
+ UNPROTECT (1); /* childnames_s */
} else if (is_function) {
+qDebug ("fun");
RData *funargsdata = new RData;
- funargsdata->datatype = RData::StructureVector;
+ funargsdata->datatype = RData::StringVector;
funargsdata->length = 0;
funargsdata->data = 0;
res[5] = funargsdata;
RData *funargvaluesdata = new RData;
- funargvaluesdata->datatype = RData::StructureVector;
+ funargvaluesdata->datatype = RData::StringVector;
funargvaluesdata->length = 0;
funargvaluesdata->data = 0;
res[6] = funargvaluesdata;
- // TODO: get and store arguments
+ if (TYPEOF (value) == CLOSXP) { // if it is not, it does not have any formals
+ SEXP formals_s = FORMALS (value);
+ PROTECT (formals_s);
+qDebug ("%d args", Rf_length (formals_s));
+qDebug ("fun1");
+ SEXP names_s = getAttrib (formals_s, R_NamesSymbol);
+ PROTECT (names_s);
+qDebug ("fun2");
+ funargsdata->data = SEXPToStringList (names_s, &(funargsdata->length));
+qDebug ("fun3");
+ // TODO: get and store argument values
+
+ // convert argument values to character representation
+/* unsigned int length = Rf_length (formals_s);
+ SEXP argvalues_char_s = Rf_allocVector (STRSXP, Rf_length (formals_s));
+ PROTECT (arg_values_char_s);
+ for (unsigned int i = 0; i < length; ++i) {
+ if (TYPEOF (VECTOR_ELT (formals_s, i)) == STRSXP) {
+ SET_VECTOR_ELT (formals_s,
+ }
+ } */
+QString *dummy1;
+ funargvaluesdata->data = dummy1 = SEXPToStringList (formals_s, &(funargvaluesdata->length));
+qDebug ("fun4");
+QString dummy;
+for (unsigned int i = 0; i < funargvaluesdata->length; ++i) {
+ dummy.append (dummy1[i] + "\t");
+}
+qDebug ("%s", dummy.latin1());
+ UNPROTECT (2); /* names_s, formals_s */
+ } else {
+qDebug ("not a closure");
+ }
}
UNPROTECT (1); /* value */
Modified: trunk/rkward/rkward/rbackend/rkstructuregetter.h
===================================================================
--- trunk/rkward/rkward/rbackend/rkstructuregetter.h 2007-04-15 16:37:38 UTC (rev 1815)
+++ trunk/rkward/rkward/rbackend/rkstructuregetter.h 2007-04-16 17:17:29 UTC (rev 1816)
@@ -28,15 +28,28 @@
RData *getStructure (SEXP toplevel, SEXP name, SEXP namespacename);
private:
- void getStructureWorker (SEXP value, const QString &name, RData *storage);
+ void getStructureWorker (SEXP value, const QString &name, bool misplaced, RData *storage);
SEXP resolvePromise (SEXP from);
bool with_namespace;
SEXP namespace_envir;
+ static SEXP callSimpleFun (SEXP fun, SEXP arg);
+ static bool callSimpleBool (SEXP fun, SEXP arg);
+
SEXP class_fun;
SEXP meta_attrib;
SEXP get_meta_fun;
+ SEXP is_matrix_fun;
+ SEXP is_array_fun;
+ SEXP is_list_fun;
+ SEXP is_function_fun;
+ SEXP is_environment_fun;
+ SEXP is_factor_fun;
+ SEXP is_numeric_fun;
+ SEXP is_character_fun;
+ SEXP is_logical_fun;
+ SEXP names_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