void omxGlobal::reportProgressStr(const char *msg)
{
ProtectedSEXP theCall(Rf_allocVector(LANGSXP, 3));
SETCAR(theCall, Rf_install("imxReportProgress"));
ProtectedSEXP Rmsg(Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(Rmsg, 0, Rf_mkChar(msg));
SETCADR(theCall, Rmsg);
SETCADDR(theCall, Rf_ScalarInteger(previousReportLength));
Rf_eval(theCall, R_GlobalEnv);
}
R_stream_callback(JSONNODE *node)
#endif
{
#ifdef NEW_JSON_NEW_STREAM
SEXP expr = (SEXP) data;
#endif
SEXP ref;
ref = CAR(CDR(expr));
R_SetExternalPtrAddr(ref, node);
Rf_eval(expr, R_GlobalEnv);
}
// only used for debugging
SEXP get_rcpp_cache() {
if( ! Rcpp_cache_know ){
SEXP getNamespaceSym = Rf_install("getNamespace"); // cannot be gc()'ed once in symbol table
Rcpp::Shield<SEXP> RCPP( Rf_eval(Rf_lang2( getNamespaceSym, Rf_mkString("Rcpp") ), R_GlobalEnv) ) ;
Rcpp_cache = Rf_findVarInFrame( RCPP, Rf_install(".rcpp_cache") ) ;
Rcpp_cache_know = true ;
}
return Rcpp_cache ;
}
void
R_json_parse_connection(SEXP r_input, SEXP numLines, struct JSON_parser_struct *parser)
{
const char *input;
unsigned int count = 0, len, totalCount = 0, lineCount = 0;
SEXP call, ans;
int n, i, maxNumLines;
PROTECT(call = allocVector(LANGSXP, 3));
SETCAR(call, Rf_install("readLines"));
SETCAR(CDR(call), r_input);
SETCAR(CDR(CDR(call)), ScalarInteger(1));
maxNumLines = INTEGER(numLines)[0];
while(1) {
PROTECT(ans = Rf_eval(call, R_GlobalEnv));
n = Rf_length(ans);
lineCount += n;
if(n == 0) {
UNPROTECT(1);
break;
}
for(i = 0 ; i < n ; i++) {
input = CHAR(STRING_ELT(ans, i));
len = strlen(input);
for (count = 0; count < len ; ++count, ++totalCount) {
int next_char = input[count];
if (next_char <= 0) {
break;
}
if (!JSON_parser_char(parser, next_char)) {
delete_JSON_parser(parser);
PROBLEM "JSON parser error: syntax error, byte %d (%c)", totalCount, input[count]
ERROR;
}
}
}
UNPROTECT(1);
if(maxNumLines > 0 && lineCount == maxNumLines)
break;
}
UNPROTECT(1);
if (!JSON_parser_done(parser)) {
delete_JSON_parser(parser);
PROBLEM "JSON parser error: syntax error, incomplete content"
ERROR;
}
}
int
R_is(SEXP val, const char * const klass)
{
SEXP expr, ans;
PROTECT(expr = allocVector(LANGSXP, 3));
SETCAR(expr, Rf_install("is"));
SETCAR(CDR(expr), val);
SETCAR(CDR(CDR(expr)), ScalarString(mkChar(klass)));
ans = Rf_eval(expr, R_GlobalEnv);
UNPROTECT(1);
return(LOGICAL(ans)[0]);
}
void
raiseError(llvm::SMDiagnostic err)
{
SEXP e, cur;
PROTECT(e = allocVector(LANGSXP, 4));
SETCAR(e, Rf_install("parseIRError")); cur = CDR(e);
SETCAR(cur, ScalarInteger(err.getLineNo())); cur = CDR(cur);
SETCAR(cur, ScalarInteger(err.getColumnNo())); cur = CDR(cur);
SETCAR(cur, ScalarString(mkChar(err.getMessage().data())));
Rf_eval(e, R_GlobalEnv);
UNPROTECT(1);
}
void
R_schemaValidityFunctionCall(R_SchemaValidCallback *ctx, int warning, const char *msg, va_list args)
{
SEXP arg;
char buf[10000];
vsnprintf(buf, sizeof(buf)/sizeof(buf[0]), msg, args);
PROTECT(arg = mkString(buf));
SET_CLASS(arg, mkString(warning ? "XMLSchemaWarning" : "XMLSchemaError"));
SETCAR(CDR(ctx->fun), arg);
Rf_eval(ctx->fun, R_GlobalEnv);
UNPROTECT(1);
}
static const char*
EmbeddedR_string_from_errmessage(void)
{
SEXP expr, res;
/* PROTECT(errMessage_SEXP) */
PROTECT(expr = allocVector(LANGSXP, 1));
SETCAR(expr, errMessage_SEXP);
PROTECT(res = Rf_eval(expr, R_GlobalEnv));
const char *message = CHARACTER_VALUE(res);
UNPROTECT(2);
return message;
}
// only used for debugging
SEXP get_rcpp_cache() {
if( ! Rcpp_cache_know ){
SEXP getNamespaceSym = Rf_install("getNamespace"); // cannot be gc()'ed once in symbol table
SEXP RCPP = PROTECT( Rf_eval(Rf_lang2( getNamespaceSym, Rf_mkString("Rcpp") ), R_GlobalEnv) ) ;
Rcpp_cache = Rf_findVarInFrame( RCPP, Rf_install(".rcpp_cache") ) ;
Rcpp_cache_know = true ;
Rcpp_protection_stack = VECTOR_ELT(Rcpp_cache, RCPP_PROTECTION_STACK_INDEX) ;
UNPROTECT(1) ;
}
return Rcpp_cache ;
}
double
R_myFun(double val, void *data)
{
SEXP call, ans;
PROTECT( call = allocVector(LANGSXP, 2));
SETCAR(call, (SEXP) data);
SETCAR(CDR(call), ScalarReal(val));
ans = Rf_eval(call, R_GlobalEnv);
UNPROTECT(1);
return(asReal(ans));
}
static float eval_dist(feature_t *f1, feature_t *f2) {
double *x = REAL(cf1), *y = REAL(cf2);
int i;
for (i = 0; i < FDIM; i++) {
x[i] = f1->loc[i];
y[i] = f2->loc[i];
}
SEXP res = Rf_eval(Rf_lang3(dist_clos, cf1, cf2), R_GlobalEnv);
if (TYPEOF(res) == INTSXP && LENGTH(res) == 1)
return (float) (INTEGER(res)[0]);
if (TYPEOF(res) != REALSXP || LENGTH(res) != 1)
Rf_error("invalid distance result - must be a numeric vector of length one");
return (float)(REAL(res)[0]);
}
int
R_isVariableReference(SEXP arg)
{
SEXP e, ans;
int val;
PROTECT(e = allocVector(LANGSXP, 3));
SETCAR(e, Rf_install("is"));
SETCAR(CDR(e), arg);
SETCAR(CDR(CDR(e)), mkString("VariableReference"));
ans = Rf_eval(e, R_GlobalEnv);
val = INTEGER(ans)[0];
UNPROTECT(1);
return(val);
}
SEXP init_Rcpp_cache(){
SEXP getNamespaceSym = Rf_install("getNamespace"); // cannot be gc()'ed once in symbol table
Rcpp::Shield<SEXP> RCPP( Rf_eval(Rf_lang2( getNamespaceSym, Rf_mkString("Rcpp") ), R_GlobalEnv) ) ;
Rcpp::Shield<SEXP> cache( Rf_allocVector( VECSXP, RCPP_CACHE_SIZE ) );
// the Rcpp namespace
SET_VECTOR_ELT( cache, 0, RCPP ) ;
set_error_occured( cache, Rf_ScalarLogical(FALSE) ) ; // error occured
set_current_error( cache, R_NilValue ) ; // current error
SET_VECTOR_ELT( cache, 3, R_NilValue ) ; // stack trace
SET_VECTOR_ELT( cache, RCPP_HASH_CACHE_INDEX, Rf_allocVector(INTSXP, RCPP_HASH_CACHE_INITIAL_SIZE) ) ;
Rf_defineVar( Rf_install(".rcpp_cache"), cache, RCPP );
return cache ;
}
int
R_do_op1_proxy_callback ( int r1, int r2, void * r3 )
{
SEXP e, p, r_ans;
int ans ;
PROTECT(p = e = allocVector(LANGSXP, 3 ));
SETCAR(p, (SEXP) r3 ); p = CDR(p);
SETCAR(p, ScalarInteger ( r1 ) ); p = CDR(p);
SETCAR(p, ScalarInteger ( r2 ) ); p = CDR(p);
PROTECT(r_ans = Rf_eval(e, R_GlobalEnv));
ans = asInteger( r_ans ) ;
UNPROTECT(2);
return (ans) ;
}
/* this is a work-around our compatibility layer for rredis -
it tries to detect values that are serialized and unserializes them.
It also converts RAWs to strings, assuming UTF8 */
SEXP raw_unpack(SEXP sWhat) {
SEXP r;
if (TYPEOF(sWhat) == RAWSXP && LENGTH(sWhat) >= 10) {
unsigned char *a = (unsigned char*) RAW(sWhat);
/* we check for "X\n\0\0" since the foramt is "X\n" <bigendian int version = 2> */
if (a[0] == 'X' && a[1] == '\n' && !a[2] && !a[3])
return Rf_eval(Rf_lang2(Rf_install("unserialize"), sWhat), R_BaseEnv);
}
if (TYPEOF(sWhat) == RAWSXP) { /* we do encode strings as RAW so let's reverse that */
r = PROTECT(Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(r, 0, Rf_mkCharLenCE((const char*)RAW(sWhat), LENGTH(sWhat), CE_UTF8));
UNPROTECT(1);
return r;
}
/* everything else is pass-through */
return sWhat;
}
void
COMError(HRESULT hr)
{
TCHAR buf[512];
GetScodeString(hr, buf, sizeof(buf)/sizeof(buf[0]));
/*
PROBLEM buf
ERROR;
*/
SEXP e;
PROTECT(e = allocVector(LANGSXP, 3));
SETCAR(e, Rf_install("COMStop"));
SETCAR(CDR(e), mkString(buf));
SETCAR(CDR(CDR(e)), ScalarInteger(hr));
Rf_eval(e, R_GlobalEnv);
UNPROTECT(1); /* Won't come back to here. */
}
SEXP
/*
Create an R object which is a reference to this object
(make certain there is no finalizer)
and get the class information
*/
createDynamicRwxReference(wxEvent *ev, const char *tagName)
{
SEXP ref, ans, e;
PROTECT(e = allocVector(LANGSXP, 2));
SETCAR(e, Rf_install("wxObject"));
SETCAR(CDR(e), ref = R_MakeExternalPtr((void *) ev, Rf_install(tagName), R_NilValue));
ans = Rf_eval(e, R_GlobalEnv);
UNPROTECT(1);
return(ans);
}
/* Map an zorba::Item to a POSIXt object within an optional format. */
SEXP
convertItemToPOSIXct(zorba::Item value, const char *fmt)
{
const char *val;
val = value.getStringValue().c_str();
SEXP e, ans;
PROTECT(e = allocVector(LANGSXP, 3));
SETCAR(e, Rf_install("zorbaPOSIXct"));
SETCAR(CDR(e), mkString(val));
SETCAR(CDR(CDR(e)), mkString(fmt));
ans = Rf_eval(e, R_GlobalEnv);
UNPROTECT(1);
return(ans);
}
/* Evaluate an expression (EXPRSXP, such as one that would
be returned by Embedded_parse()) in an environment.
Return NULL on error */
SEXP
EmbeddedR_eval(SEXP expression, SEXP envir) {
if (! RINTERF_ISREADY()) {
return NULL;
}
RStatus ^= RINTERF_IDLE;
SEXP res = R_NilValue;
int errorOccurred = 0;
int i;
for(i = 0; i < LENGTH(expression); i++) {
//res = R_tryEval(VECTOR_ELT(expression,0), envir, &errorOccurred);
res = Rf_eval(VECTOR_ELT(expression, 0), envir);
}
if (errorOccurred) {
res = NULL;
}
RStatus ^= RINTERF_IDLE;
return res;
}
SEXP init_Rcpp_cache(){
SEXP getNamespaceSym = Rf_install("getNamespace"); // cannot be gc()'ed once in symbol table
SEXP RCPP = PROTECT( Rf_eval(Rf_lang2( getNamespaceSym, Rf_mkString("Rcpp") ), R_GlobalEnv) ) ;
SEXP cache = PROTECT( Rf_allocVector( VECSXP, RCPP_CACHE_SIZE ) );
// the Rcpp namespace
SET_VECTOR_ELT( cache, 0, RCPP ) ;
set_error_occured( cache, Rf_ScalarLogical(FALSE) ) ; // error occured
set_current_error( cache, R_NilValue ) ; // current error
SET_VECTOR_ELT( cache, 3, R_NilValue ) ; // stack trace
SET_VECTOR_ELT( cache, RCPP_HASH_CACHE_INDEX, Rf_allocVector(INTSXP, RCPP_HASH_CACHE_INITIAL_SIZE) ) ;
SEXP stack = PROTECT(Rf_allocVector(VECSXP, RCPP_PROTECT_STACK_INITIAL_SIZE)) ;
// we use true length to store "top"
SET_TRUELENGTH(stack, -1 ) ;
SET_VECTOR_ELT( cache, RCPP_PROTECTION_STACK_INDEX, stack ) ;
Rf_defineVar( Rf_install(".rcpp_cache"), cache, RCPP );
UNPROTECT(3) ;
return cache ;
}
void
R_tarCollectContents(const char *fname, char *bytes, unsigned int numBytes, unsigned int remaining, void *data)
{
RTarCallInfo *cb = (RTarCallInfo *)data;
int len = 0;
if(numBytes < 1) {
/* Invoke the function to signal the completion of a file. */
/* Need to make this have the correct length, i.e. cb->offset */
SEXP tmp = cb->rawData;
if(GET_LENGTH(cb->rawData) > cb->offset) {
tmp = allocVector(RAWSXP, cb->offset); /* shouldn't need to protect. */
memcpy(RAW(tmp), RAW(cb->rawData), cb->offset);
}
SETCAR(CDR(cb->e), tmp);
SETCAR(CDR(CDR(cb->e)), mkString(fname));
Rf_eval(cb->e, R_GlobalEnv);
cb->offset = 0;
return;
}
/* If we don't preallocate rawData, then this will continue
to grow the vector just enough to fit the new bytes.*/
if(cb->rawData == R_NilValue)
cb->rawData = allocVector(RAWSXP, numBytes);
else {
len = LENGTH(cb->rawData);
if(len - cb->offset < numBytes) {
SET_LENGTH(cb->rawData, len + numBytes);
PROTECT(cb->rawData);
cb->numProtects++;
}
}
memcpy(RAW(cb->rawData) + cb->offset, bytes, numBytes);
cb->offset += numBytes;
}
zorba::StatelessExternalFunction *
RExternalModule::getExternalFunction(zorba::String name) const
{
SEXP val;
zorba::StatelessExternalFunction *ans = NULL;
const char * const str = name.c_str();
val = findVar(Rf_install(str), env); /* findVarInFrame3(env, Rf_install(str), (Rboolean) TRUE) for just this frame. */
if(val == R_UnboundValue) {
// raise an exception with our own class.
// throw ExternalFunctionData::createZorbaException
fprintf(stderr, "Can't find %s in module\n", str);
return(NULL);
// throw zorba::DynamicException();
}
if(TYPEOF(val) == PROMSXP)
val = Rf_eval(val, R_GlobalEnv);
if(TYPEOF(val) == CLOSXP) {
zorba::ItemFactory *itemFactory;
RXQueryFunction *func;
SEXP rval;
zorba::simplestore::SimpleStore* lStore = zorba::simplestore::SimpleStoreManager::getStore();
zorba::Zorba *zorba = zorba::Zorba::getInstance(lStore);
itemFactory = zorba->getItemFactory();
func = new RXQueryClosureFunction(str, itemFactory, val, true);
PROTECT(rval = makeExternalRObject(func, "RClosureExternalFunction"));
defineVar(Rf_install(str), rval, getEnvironment());
UNPROTECT(1);
ans = dynamic_cast<zorba::PureStatelessExternalFunction*>(func);
} else {
ans = R_GET_REF(val, zorba::StatelessExternalFunction);
}
return(ans);
}
/*
Because we call this function via Rf_eval(), we end up
with an extra call on the stack when we enter recover.
*/
SEXP
stop(const char *className, const char *msg, ...)
{
char buf[10000];
SEXP error, e, ns_env, ns_name;
va_list ap;
va_start(ap, msg);
/* Rvsnprintf(buf, sizeof(buf)/sizeof(buf[0]), msg, ap); */
vsnprintf(buf, sizeof(buf)/sizeof(buf[0]), msg, ap);
va_end(ap);
PROTECT(error = mkString(buf));
/*
const char * classNames[] = {"simpleError", "error", "condition"};
PROTECT(tmp = allocVector(STRSXP, sizeof(classNames)/sizeof(classNames[0])));
for(i = 0; i < sizeof(classNames)/sizeof(classNames[0]); i++)
SET_STRING_ELT(tmp, i+1, mkChar(classNames[i]));
SET_STRING_ELT(tmp, 0, mkChar(className));
SET_CLASS(error, tmp);
*/
PROTECT(e = allocVector(LANGSXP, 2));
PROTECT(ns_name = mkString("XML"));
ns_env = R_FindNamespace(ns_name);
SETCAR(e, findVarInFrame(ns_env, Rf_install("xmlStop")));
SETCAR(CDR(e), error);
Rf_eval(e, R_GlobalEnv);
UNPROTECT(3);
/*
errorcall(error, "%s", msg);
UNPROTECT(1);
*/
return(error);
}
void diagParallel(int verbose, const char* msg, ...)
{
if (!verbose && !Global->parallelDiag) return;
const int maxLen = 240;
char buf1[maxLen];
va_list ap;
va_start(ap, msg);
vsnprintf(buf1, maxLen, msg, ap);
va_end(ap);
if (verbose) {
mxLog("%s", buf1);
} else if (Global->parallelDiag) {
ProtectedSEXP theCall(Rf_allocVector(LANGSXP, 2));
SETCAR(theCall, Rf_install("message"));
ProtectedSEXP Rmsg(Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(Rmsg, 0, Rf_mkChar(buf1));
SETCADR(theCall, Rmsg);
Rf_eval(theCall, R_GlobalEnv);
}
}
std::string get_single_class(SEXP x) {
SEXP klass = Rf_getAttrib(x, R_ClassSymbol);
if (!Rf_isNull(klass)) {
CharacterVector classes(klass);
return collapse_utf8(classes, "/");
}
if (Rf_isMatrix(x)) {
return "matrix";
}
switch (TYPEOF(x)) {
case RAWSXP:
return "raw";
case INTSXP:
return "integer";
case REALSXP :
return "numeric";
case LGLSXP:
return "logical";
case STRSXP:
return "character";
case CPLXSXP:
return "complex";
case VECSXP:
return "list";
default:
break;
}
// just call R to deal with other cases
// we could call R_data_class directly but we might get a "this is not part of the api"
RObject class_call(Rf_lang2(Rf_install("class"), x));
klass = Rf_eval(class_call, R_GlobalEnv);
return CHAR(STRING_ELT(klass, 0));
}
SEXP
RSXML_structuredStop(SEXP errorFun, xmlErrorPtr err)
{
SEXP e, ptr;
int n = 8;
if(!err)
n = 2;
PROTECT(e = allocVector(LANGSXP, n));
SETCAR(e, errorFun != NULL && errorFun != R_NilValue ? errorFun : Rf_install("xmlStructuredStop"));
ptr = CDR(e);
if(err) {
SETCAR(ptr, mkString(err->message));
ptr= CDR(ptr);
SETCAR(ptr, ScalarInteger(err->code));
ptr= CDR(ptr);
SETCAR(ptr, ScalarInteger(err->domain));
ptr= CDR(ptr);
SETCAR(ptr, ScalarInteger(err->line));
ptr= CDR(ptr);
SETCAR(ptr, ScalarInteger(err->int2));
ptr= CDR(ptr);
SETCAR(ptr, ScalarInteger(err->level));
ptr= CDR(ptr);
SETCAR(ptr, err->file ? mkString(err->file) : NEW_CHARACTER(0));
} else {
SETCAR(ptr, NEW_CHARACTER(0));
}
Rf_eval(e, R_GlobalEnv);
UNPROTECT(1);
/* Shouldn't get back to here! Rf_eval() should raise an error.*/
return(R_NilValue);
}
/*
The "simple"/standard callback to an R function.
*/
int
R_json_basicCallback(void* ctx, int type, const struct JSON_value_struct* value)
{
RJSONParserInfo *info = ( RJSONParserInfo *) ctx;
if(info->func != NULL) {
SEXP result, tmp;
tmp = CAR(CDR(info->func));
INTEGER(tmp)[0] = type; /* Names too */
SET_STRING_ELT(info->names, 0, mkChar(jsonTypeNames[type]));
if(value)
SETCAR(CDR(CDR(info->func)), convertJSONValueToR(type, value, info->encoding));
else if(type == JSON_T_TRUE)
SETCAR(CDR(CDR(info->func)), ScalarLogical(1));
else if(type == JSON_T_FALSE)
SETCAR(CDR(CDR(info->func)), ScalarLogical(0));
else
SETCAR(CDR(CDR(info->func)), R_NilValue);
result = Rf_eval(info->func, R_GlobalEnv);
if(isLogical(result))
return(LOGICAL(result)[0]);
else if(isInteger(result))
return(INTEGER(result)[0]);
else if(isNumeric(result))
return(REAL(result)[0]);
else
return(1);
}
return(1);
}
void TimeGreaterThanCensorshipStopPolicy::first() {
//printf("time=%lf\n",time);
if(to_init) {
time=as<double>(Rf_eval(expr,env));
};
}
// TODO: use a vector<string> would make all this a bit more readable
void RInside::initialize(const int argc, const char* const argv[], const bool loadRcpp,
const bool verbose, const bool interactive) {
if (instance_m) {
throw std::runtime_error( "can only have one RInside instance" ) ;
} else {
instance_m = this ;
}
verbose_m = verbose; // Default is false
interactive_m = interactive;
// generated from Makevars{.win}
#include "RInsideEnvVars.h"
#ifdef WIN32
// we need a special case for Windows where users may deploy an RInside binary from CRAN
// which will have R_HOME set at compile time to CRAN's value -- so let's try to correct
// this here: a) allow user's setting of R_HOME and b) use R's get_R_HOME() function
if (getenv("R_HOME") == NULL) { // if on Windows and not set
char *rhome = get_R_HOME(); // query it, including registry
if (rhome != NULL) { // if something was found
setenv("R_HOME", get_R_HOME(), 1); // store what we got as R_HOME
} // this will now be used in next blocks
}
#endif
for (int i = 0; R_VARS[i] != NULL; i+= 2) {
if (getenv(R_VARS[i]) == NULL) { // if env variable is not yet set
if (setenv(R_VARS[i],R_VARS[i+1],1) != 0){
throw std::runtime_error(std::string("Could not set R environment variable ") +
std::string(R_VARS[i]) + std::string(" to ") +
std::string(R_VARS[i+1]));
}
}
}
#ifndef WIN32
R_SignalHandlers = 0; // Don't let R set up its own signal handlers
#endif
init_tempdir();
const char *R_argv[] = {(char*)programName, "--gui=none", "--no-save",
"--no-readline", "--silent", "--vanilla", "--slave"};
int R_argc = sizeof(R_argv) / sizeof(R_argv[0]);
Rf_initEmbeddedR(R_argc, (char**)R_argv);
#ifndef WIN32
R_CStackLimit = -1; // Don't do any stack checking, see R Exts, '8.1.5 Threading issues'
#endif
R_ReplDLLinit(); // this is to populate the repl console buffers
structRstart Rst;
R_DefParams(&Rst);
Rst.R_Interactive = (Rboolean) interactive_m; // sets interactive() to eval to false
#ifdef WIN32
Rst.rhome = getenv("R_HOME"); // which is set above as part of R_VARS
Rst.home = getRUser();
Rst.CharacterMode = LinkDLL;
Rst.ReadConsole = myReadConsole;
Rst.WriteConsole = myWriteConsole;
Rst.CallBack = myCallBack;
Rst.ShowMessage = myAskOk;
Rst.YesNoCancel = myAskYesNoCancel;
Rst.Busy = myBusy;
#endif
R_SetParams(&Rst);
if (true || loadRcpp) { // we always need Rcpp, so load it anyway
// Rf_install is used best by first assigning like this so that symbols get into the symbol table
// where they cannot be garbage collected; doing it on the fly does expose a minuscule risk of garbage
// collection -- with thanks to Doug Bates for the explanation and Luke Tierney for the heads-up
SEXP suppressMessagesSymbol = Rf_install("suppressMessages");
SEXP requireSymbol = Rf_install("require");
Rf_eval(Rf_lang2(suppressMessagesSymbol, Rf_lang2(requireSymbol, Rf_mkString("Rcpp"))), R_GlobalEnv);
}
global_env_m = new Rcpp::Environment(); // member variable for access to R's global environment
autoloads(); // loads all default packages, using code autogenerate from Makevars{,.win}
if ((argc - optind) > 1){ // for argv vector in Global Env */
Rcpp::CharacterVector s_argv( argv+(1+optind), argv+argc );
assign(s_argv, "argv");
} else {
assign(R_NilValue, "argv") ;
}
init_rand(); // for tempfile() to work correctly */
}
static bool Rcpp_cache_know = false ;
static SEXP Rcpp_cache = R_NilValue ;
#define RCPP_HASH_CACHE_INDEX 4
#define RCPP_CACHE_SIZE 6
#ifndef RCPP_HASH_CACHE_INITIAL_SIZE
#define RCPP_HASH_CACHE_INITIAL_SIZE 1024
#endif
// only used for debugging
SEXP get_rcpp_cache() {
RCPP_DEBUG( "get_rcpp_cache (known = %s)", (Rcpp_cache_know ? "true" : "false" ) )
if( ! Rcpp_cache_know ){
SEXP getNamespaceSym = Rf_install("getNamespace");
SEXP RCPP = PROTECT( Rf_eval(Rf_lang2( getNamespaceSym, Rf_mkString("Rcpp11") ), R_GlobalEnv) );
Rcpp_cache = Rf_findVarInFrame( RCPP, Rf_install(".rcpp_cache") ) ;
Rcpp_cache_know = true ;
UNPROTECT(1) ;
}
RCPP_DEBUG( " [get_rcpp_cache] Rcpp_cache = <%p>", Rcpp_cache )
return Rcpp_cache ;
}
namespace Rcpp {
SEXP get_Rcpp11_namespace__impl(){
return VECTOR_ELT( get_rcpp_cache() , 0 ) ;
}
}
