[rkward-cvs] SF.net SVN: rkward: [1826] trunk/rkward/rkward/rbackend
tfry at users.sourceforge.net
tfry at users.sourceforge.net
Wed Apr 18 18:07:34 UTC 2007
Revision: 1826
http://svn.sourceforge.net/rkward/?rev=1826&view=rev
Author: tfry
Date: 2007-04-18 11:07:34 -0700 (Wed, 18 Apr 2007)
Log Message:
-----------
Activate the new .rk.get.structure. A mail on this will follow, soon
Modified Paths:
--------------
trunk/rkward/rkward/rbackend/rembedinternal.cpp
trunk/rkward/rkward/rbackend/rkstructuregetter.cpp
trunk/rkward/rkward/rbackend/rkstructuregetter.h
trunk/rkward/rkward/rbackend/rpackages/rkward/R/internal.R
Modified: trunk/rkward/rkward/rbackend/rembedinternal.cpp
===================================================================
--- trunk/rkward/rkward/rbackend/rembedinternal.cpp 2007-04-18 16:38:55 UTC (rev 1825)
+++ trunk/rkward/rkward/rbackend/rembedinternal.cpp 2007-04-18 18:07:34 UTC (rev 1826)
@@ -87,6 +87,7 @@
#include "Rembedded.h"
#else
extern void R_ReplDLLinit (void);
+extern Rboolean R_ToplevelExec(void (*fun)(void *), void *data);
#endif
// some functions we need that are not declared
@@ -641,11 +642,11 @@
#include "rkstructuregetter.cpp"
-SEXP doGetStructureTest (SEXP toplevel, SEXP name, SEXP namespacename) {
+SEXP doGetStructure (SEXP toplevel, SEXP name, SEXP envlevel, SEXP namespacename) {
RK_TRACE (RBACKEND);
RKStructureGetter getter (false);
- RData *ret = getter.getStructure (toplevel, name, namespacename);
+ RData *ret = getter.getStructure (toplevel, name, envlevel, namespacename);
return R_MakeExternalPtr (ret, RKWard_RData_Tag, R_NilValue);
}
@@ -660,7 +661,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, 3 },
+ { "rk.get.structure", (DL_FUNC) &doGetStructure, 4 },
{ 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-18 16:38:55 UTC (rev 1825)
+++ trunk/rkward/rkward/rbackend/rkstructuregetter.cpp 2007-04-18 18:07:34 UTC (rev 1826)
@@ -17,8 +17,6 @@
#include "rkstructuregetter.h"
-//#define qDebug
-
RKStructureGetter::RKStructureGetter (bool keep_evalled_promises) {
RK_TRACE (RBACKEND);
@@ -43,6 +41,7 @@
is_character_fun = prefetch_fun ("is.character");
is_logical_fun = prefetch_fun ("is.logical");
double_brackets_fun = prefetch_fun ("[[");
+ dims_fun = prefetch_fun ("dim");
names_fun = prefetch_fun ("names");
length_fun = prefetch_fun ("length");
@@ -102,11 +101,11 @@
return ((bool) VECTOR_ELT (res, 0));
}
-RData *RKStructureGetter::getStructure (SEXP toplevel, SEXP name, SEXP namespacename) {
+RData *RKStructureGetter::getStructure (SEXP toplevel, SEXP name, SEXP envlevel, SEXP namespacename) {
RK_TRACE (RBACKEND);
// TODO: accept an envlevel parameter
- envir_depth = 0;
+ envir_depth = INTEGER (envlevel)[0];
unsigned int count;
QString *name_dummy = SEXPToStringList (name, &count);
@@ -131,9 +130,9 @@
}
RData *ret = new RData;
- // TODO: wrap inside a toplevel exec
- getStructureWorker (toplevel, name_string, false, ret);
+ getStructureSafe (toplevel, name_string, false, ret);
+
if (with_namespace) {
UNPROTECT (1); /* namespace_envir */
}
@@ -141,6 +140,31 @@
return ret;
}
+void RKStructureGetter::getStructureSafe (SEXP value, const QString &name, bool misplaced, RData *storage) {
+ RK_TRACE (RBACKEND);
+
+ GetStructureWorkerArgs args;
+ args.toplevel = value;
+ args.name = name;
+ args.misplaced = false;
+ args.storage = storage;
+ args.getter = this;
+
+ Rboolean ok = R_ToplevelExec ((void (*)(void*)) getStructureWrapper, &args);
+
+ if (ok != TRUE) {
+ storage->discardData();
+ Rf_warning ("failure to get object %s", name.latin1());
+ getStructureWorker (R_NilValue, name, misplaced, storage);
+ }
+}
+
+void RKStructureGetter::getStructureWrapper (GetStructureWorkerArgs *data) {
+ RK_TRACE (RBACKEND);
+
+ data->getter->getStructureWorker (data->toplevel, data->name, data->misplaced, data->storage);
+}
+
SEXP RKStructureGetter::resolvePromise (SEXP from) {
RK_TRACE (RBACKEND);
@@ -279,7 +303,7 @@
// get dims
int *dims;
unsigned int num_dims;
- SEXP dims_s = Rf_getAttrib (value, R_DimSymbol);
+ SEXP dims_s = callSimpleFun (dims_fun, value, R_BaseEnv);
if (!Rf_isNull (dims_s)) {
dims = SEXPToIntArray (dims_s, &num_dims);
} else {
@@ -388,21 +412,21 @@
# endif
}
- getStructureWorker (child, childnames[i], child_misplaced, children[i]);
+ getStructureSafe (child, childnames[i], child_misplaced, children[i]);
UNPROTECT (2); /* childname, child */
}
} else if (do_cont) {
RK_DO (qDebug ("recurse into list %s", name.latin1()), RBACKEND, DL_DEBUG);
- if (Rf_isList (value)) { // old style list
+ if (Rf_isList (value) && (!Rf_isObject (value))) { // old style list
for (unsigned int i = 0; i < childcount; ++i) {
SEXP child = CAR (value);
- getStructureWorker (child, childnames[i], false, children[i]);
+ getStructureSafe (child, childnames[i], false, children[i]);
CDR (value);
}
- } else if (Rf_isNewList (value)) { // new style list
+ } else if (Rf_isNewList (value) && (!Rf_isObject (value))) { // new style list
for (unsigned int i = 0; i < childcount; ++i) {
SEXP child = VECTOR_ELT(value, i);
- getStructureWorker (child, childnames[i], false, children[i]);
+ getStructureSafe (child, childnames[i], false, children[i]);
}
} else { // probably an S4 object disguised as a list
SEXP index = Rf_allocVector(INTSXP, 1);
@@ -410,7 +434,7 @@
for (unsigned int i = 0; i < childcount; ++i) {
INTEGER (index)[0] = (i + 1);
SEXP child = callSimpleFun2 (double_brackets_fun, value, index, R_BaseEnv);
- getStructureWorker (child, childnames[i], false, children[i]);
+ getStructureSafe (child, childnames[i], false, children[i]);
}
UNPROTECT (1); /* index */
}
Modified: trunk/rkward/rkward/rbackend/rkstructuregetter.h
===================================================================
--- trunk/rkward/rkward/rbackend/rkstructuregetter.h 2007-04-18 16:38:55 UTC (rev 1825)
+++ trunk/rkward/rkward/rbackend/rkstructuregetter.h 2007-04-18 18:07:34 UTC (rev 1826)
@@ -26,9 +26,20 @@
RKStructureGetter (bool keep_evalled_promises);
~RKStructureGetter ();
- RData *getStructure (SEXP toplevel, SEXP name, SEXP namespacename);
+ RData *getStructure (SEXP toplevel, SEXP name, SEXP envlevel, SEXP namespacename);
private:
+ struct GetStructureWorkerArgs {
+ SEXP toplevel;
+ QString name;
+ bool misplaced;
+ RData *storage;
+ RKStructureGetter *getter;
+ };
+
void getStructureWorker (SEXP value, const QString &name, bool misplaced, RData *storage);
+/** needed to wrap things inside an R_ToplevelExec */
+ static void getStructureWrapper (GetStructureWorkerArgs *data);
+ void getStructureSafe (SEXP value, const QString &name, bool misplaced, RData *storage);
SEXP resolvePromise (SEXP from);
SEXP prefetch_fun (char *name, bool from_base=true);
@@ -41,6 +52,7 @@
static bool callSimpleBool (SEXP fun, SEXP arg, SEXP env);
SEXP class_fun;
+ SEXP dims_fun;
SEXP meta_attrib;
SEXP get_meta_fun;
SEXP is_matrix_fun;
Modified: trunk/rkward/rkward/rbackend/rpackages/rkward/R/internal.R
===================================================================
--- trunk/rkward/rkward/rbackend/rpackages/rkward/R/internal.R 2007-04-18 16:38:55 UTC (rev 1825)
+++ trunk/rkward/rkward/rbackend/rpackages/rkward/R/internal.R 2007-04-18 18:07:34 UTC (rev 1826)
@@ -339,14 +339,14 @@
}
".rk.get.structure.new" <- function (x, name, envlevel=0, namespacename=NULL) {
- .Call ("rk.get.structure.test", x, name, namespacename)
+ .Call ("rk.get.structure", x, as.character (name), as.integer (envlevel), as.character (namespacename))
}
".rk.try.get.namespace" <- function (name) {
tryCatch (asNamespace (namespacename), error = function(e) NULL)
}
-".rk.get.structure" <- .rk.get.structure.old
+".rk.get.structure" <- .rk.get.structure.new
".rk.get.formals" <- function (x)
{
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