[rkward-cvs] rkward/rkward/rbackend rembedinternal.cpp,1.42,1.43

[Thomas Friedrichsmeier]

Update of /cvsroot/rkward/rkward/rkward/rbackend
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv21203/rkward/rbackend

Modified Files:
	rembedinternal.cpp 
Log Message:
Failed attempt at creating an RObjectTable for the workspace

Index: rembedinternal.cpp
===================================================================
RCS file: /cvsroot/rkward/rkward/rkward/rbackend/rembedinternal.cpp,v
retrieving revision 1.42
retrieving revision 1.43
diff -C2 -d -r1.42 -r1.43
*** rembedinternal.cpp	19 Jun 2006 20:04:31 -0000	1.42
--- rembedinternal.cpp	21 Jun 2006 16:57:40 -0000	1.43
***************
*** 25,30 ****
--- 25,32 ----
  #define R_INTERFACE_PTRS 1
  
+ #include "Rdefines.h"
  #include "R_ext/Rdynload.h"
  #include "R_ext/eventloop.h"
+ #include "R_ext/Callbacks.h"
  #include "R.h"
  #include "Rinternals.h"
***************
*** 62,65 ****
--- 64,148 ----
  #include "../rkglobals.h"
  
+ #ifdef REMBEDINTERNALEXPERIMENTAL
+ // code mostly copied from RObjectTables
+ SEXP RealGlobalEnv;
+ 
+ Rboolean fakeRGlobalEnv_exists (const char * const name, Rboolean *canCache, R_ObjectTable *tb) {
+ 	*canCache = (Rboolean) FALSE;
+ 	Rprintf ("exists");
+ }
+ 
+ SEXP fakeRGlobalEnv_get (const char * const name, Rboolean *canCache, R_ObjectTable *tb) {
+ 	Rprintf ("get");
+ 	return (R_NilValue);
+ }
+ 
+ int fakeRGlobalEnv_remove (const char * const name,  R_ObjectTable *tb) {
+ 	Rprintf ("remove");
+ 	return 0;
+ }
+ 
+ Rboolean fakeRGlobalEnv_canCache (const char * const name, R_ObjectTable *tb) {
+ 	return ((Rboolean) FALSE);
+ }
+ 
+ SEXP fakeRGlobalEnv_assign (const char * const name, SEXP value, R_ObjectTable *tb) {
+ 	Rprintf ("assign");
+ 	return (R_NilValue);
+ }
+ 
+ SEXP fakeRGlobalEnv_objects (R_ObjectTable *tb) {
+ 	Rprintf ("objects");
+ 	return (R_NilValue);
+ }
+ 
+ void createFakeRGlobalEnv ()
+ {
+  R_ObjectTable *tb;
+  SEXP val, klass;
+ 
+   tb = (R_ObjectTable *) malloc(sizeof(R_ObjectTable));
+   if(!tb)
+       error("cannot allocate space for an internal R object table");
+ 
+   tb->type = 15;
+   tb->cachedNames = NULL;
+   tb->active = (Rboolean) TRUE;
+ 
+   R_PreserveObject (R_GlobalEnv);
+   tb->privateData = R_GlobalEnv;
+ 
+   tb->exists = fakeRGlobalEnv_exists;
+   tb->get = fakeRGlobalEnv_get;
+   tb->remove = fakeRGlobalEnv_remove;
+   tb->assign = fakeRGlobalEnv_assign;
+   tb->objects = fakeRGlobalEnv_objects;
+   tb->canCache = fakeRGlobalEnv_canCache;
+ 
+   tb->onAttach = NULL;
+   tb->onDetach = NULL;
+ 
+   PROTECT(val = R_MakeExternalPtr(tb, Rf_install("UserDefinedDatabase"), R_NilValue));
+   PROTECT(klass = NEW_CHARACTER(1));
+   SET_STRING_ELT(klass, 0, COPY_TO_USER_STRING("UserDefinedDatabase"));
+   SET_CLASS(val, klass);
+   UNPROTECT(2);
+ 
+   RealGlobalEnv = R_GlobalEnv;
+ 
+         SEXP s = allocSExp(ENVSXP);
+         SET_HASHTAB(s, CAR (val));
+ 	setAttrib(s, R_ClassSymbol, getAttrib(HASHTAB(s), R_ClassSymbol));
+ 	setAttrib(s, install("name"), install ("test"));
+ 
+ //	SET_ENCLOS (val, RealGlobalEnv);
+ //	R_GlobalEnv = val;
+ 	SEXP x = ENCLOS(R_GlobalEnv);
+ 	SET_ENCLOS(R_GlobalEnv, s);
+ 	SET_ENCLOS(s, x);
+ MARK_AS_GLOBAL_FRAME(s);
+ }
+ #endif
+ 
  // ############## R Standard callback overrides BEGIN ####################
  void RSuicide (char* message) {
***************
*** 264,268 ****
  	/* close all the graphics devices */
  	if (!suicidal) KillAllDevices ();
! 	fpu_setup (FALSE);
  }
  
--- 347,351 ----
  	/* close all the graphics devices */
  	if (!suicidal) KillAllDevices ();
! 	fpu_setup ((Rboolean) FALSE);
  }