[Rd] Callbacks seems to get GCed.

[Bernd Schoeller]

Dear list,

I am trying to implement a publish-subscribe mechanism in for an embedded  
R interpreter. But somehow my registered closures seem to get collected by  
the GC, even though I have protected them. I have reducted my code to the  
following sample. Sorry if it is a little verbose.

The first couple of call of calls still work, but at some point one of the  
callbacks (callback1 in my case) changes its type.

Regards and thanks for any help,
   Bernd

#include <stdio.h>
#include <stdlib.h>

#define R_INTERFACE_PTRS 1

#include <Rversion.h>
#include <Rembedded.h>
#include <Rinternals.h>
#include <Rdefines.h>
#include <R_ext/Parse.h>
#include <R_ext/Rdynload.h>
#include <R_ext/RStartup.h>
#include <Rinterface.h>

SEXP callback1;
SEXP callback2;

void set_callback1(SEXP func) {
   PROTECT(callback1 = func);
}

void set_callback2(SEXP func) {
   PROTECT(callback2 = func);
}

R_CMethodDef cMethods[] = {
   {NULL}
};

R_CallMethodDef callMethods[] = {
   {"set_callback1", (DL_FUNC) &set_callback1, 1},
   {"set_callback2", (DL_FUNC) &set_callback2, 1},
   {NULL}
};

void r_trigger_callback1()
{
   int errorOccurred;
   SEXP f = NULL;

   f = allocVector(LANGSXP, 1);
   SETCAR(f, callback1);
   PROTECT(f);
   R_tryEval(f, R_GlobalEnv, &errorOccurred);
   UNPROTECT(1);
}

void r_trigger_callback2()
{
   int errorOccurred;
   SEXP f = NULL;

   f = allocVector(LANGSXP, 1);
   SETCAR(f, callback2);
   PROTECT(f);
   R_tryEval(f, R_GlobalEnv, &errorOccurred);
   UNPROTECT(1);
}


void r_exec(char *code)
{
   SEXP cmdSexp, cmdExpr = R_NilValue;
   ParseStatus status;
   int i,errorOccurred;
   SEXP e;
	
   PROTECT (cmdSexp = allocVector (STRSXP, 1));
   SET_STRING_ELT (cmdSexp, 0, mkChar (code));
   PROTECT (cmdExpr = R_ParseVector (cmdSexp,-1,&status,R_NilValue));
   UNPROTECT_PTR (cmdSexp);

   if (status == PARSE_OK) {		
     for (i = 0; i < length (cmdExpr); i++) {
       PROTECT(e = VECTOR_ELT (cmdExpr,i));
       R_tryEval(e, R_GlobalEnv, &errorOccurred);
       UNPROTECT_PTR(e);
       if (errorOccurred) {
	return;		
       }
     }
   }
}

void initR()
{
   char *argv[] = {"REmbeddedPascal", "--gui=none", "--silent",  
"--no-save"};
   int argc = 4;
   DllInfo *info;

   setenv("R_HOME","/usr/lib/R",0);

   structRstart rp;
   Rstart Rp = &rp;

   R_setStartTime();
   R_DefParams(Rp);

   Rp->R_Quiet = TRUE;
   Rp->RestoreAction = SA_RESTORE;
   Rp->SaveAction = SA_NOSAVE;
   R_SetParams(Rp);

   R_Interactive = TRUE;

   Rf_initialize_R(argc, argv);
   setup_Rmainloop();
   R_ReplDLLinit();
   info = R_getEmbeddingDllInfo();
   R_registerRoutines(info, cMethods, callMethods, NULL, NULL);
}

int main (int argc, char** argv)
{
   int i;
   initR();

   r_exec("x <- function (f) { .Call(\"set_callback1\",f); }");
   r_exec("y <- function (f) { .Call(\"set_callback2\",f); }");
   r_exec("x(function() { print(\"A\"); })");
   r_exec("y(function() { print(\"B\"); })");

   for (i = 0; i < 100000; i++) {
     r_trigger_callback1();
     r_trigger_callback2();
   }

   Rf_endEmbeddedR(0);
}


-- 
Bernd Schoeller, PhD, CTO
Comerge AG, Technoparkstrasse 1, CH-8055 Zurich, www.comerge.net