/* Return NULL on failure */
SEXP
EmbeddedR_getBaseEnv(void) {
if (! RINTERF_ISREADY()) {
printf("R is not ready.\n");
return NULL;
}
RStatus ^= RINTERF_IDLE;
SEXP sexp = R_BaseEnv;
//FIXME: protect/unprotect from garbage collection (for now protect only)
R_PreserveObject(sexp);
RStatus ^= RINTERF_IDLE;
return sexp;
}
/* Return -1 on failure */
int
Sexp_ndims(const SEXP sexp) {
if (! RINTERF_ISREADY()) {
return -1;
}
SEXP dims = getAttrib(sexp, R_DimSymbol);
int res;
if (Rf_isNull(dims))
res = 1;
else
res = LENGTH(dims);
return res;
}
/* Return NULL on failure */
SEXP
Sexp_getAttribute(const SEXP sexp,
char *name) {
if (! RINTERF_ISREADY()) {
return NULL;
}
SEXP res = Rf_getAttrib(sexp, Rf_install(name));
if (Rf_isNull(res)) {
res = NULL;
} else {
R_PreserveObject(res);
}
return res;
}
/* Return NULL on failure */
SEXP
SexpEnvironment_getvalue(const SEXP envir, const char* name) {
if (! RINTERF_ISREADY()) {
printf("R is not ready.\n");
return NULL;
}
RStatus ^= RINTERF_IDLE;
SEXP sexp, symbol;
symbol = Rf_install(name);
PROTECT(sexp = findVarInFrame(envir, symbol));
//FIXME: protect/unprotect from garbage collection (for now protect only)
R_PreserveObject(sexp);
UNPROTECT(1);
RStatus ^= RINTERF_IDLE;
return sexp;
}
SEXP
SexpStrVector_new_nofill(int n) {
if (! RINTERF_ISREADY()) {
printf("R is not ready.\n");
return NULL;
}
RStatus ^= RINTERF_IDLE;
SEXP sexp = NEW_CHARACTER(n);
if (sexp == NULL) {
printf("Problem while creating R vector.\n");
RStatus ^= RINTERF_IDLE;
return sexp;
}
R_PreserveObject(sexp);
RStatus ^= RINTERF_IDLE;
return sexp;
}
int
SexpEnvironment_delvalue(const SEXP envir, const char* name) {
if (! RINTERF_ISREADY()) {
printf("R is not ready.\n");
return -1;
}
RStatus ^= RINTERF_IDLE;
if (envir == R_BaseNamespace) {
printf("Variables in the R base namespace cannot be changed.\n");
RStatus ^= RINTERF_IDLE;
return -1;
} else if (envir == R_BaseEnv) {
printf("Variables in the R base environment cannot be changed.\n");
RStatus ^= RINTERF_IDLE;
return -1;
} else if (envir == R_EmptyEnv) {
printf("Nothing can be changed from the empty environment.\n");
RStatus ^= RINTERF_IDLE;
return -1;
} else if (R_EnvironmentIsLocked(envir)) {
printf("Variables in a locked environment cannot be changed.\n");
RStatus ^= RINTERF_IDLE;
return -1;
}
SEXP sexp, symbol;
symbol = Rf_install(name);
PROTECT(sexp = findVarInFrame(envir, symbol));
if (sexp == R_UnboundValue) {
printf("'%s' not found.\n", name);
UNPROTECT(1);
RStatus ^= RINTERF_IDLE;
return -1;
}
SEXP res_rm = librinterface_remove(symbol, envir, R_BaseEnv);
if (! res_rm) {
printf("Could not remove the variable '%s' from environment.", name);
UNPROTECT(1);
RStatus ^= RINTERF_IDLE;
return -1;
}
UNPROTECT(1);
RStatus ^= RINTERF_IDLE;
return 0;
}
/* 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,i), envir, &errorOccurred);
}
if (errorOccurred) {
res = NULL;
}
RStatus ^= RINTERF_IDLE;
return res;
}
int
SexpEnvironment_setvalue(const SEXP envir, const char* name, const SEXP value) {
if (! RINTERF_ISREADY()) {
printf("R is not ready.\n");
return -1;
}
RStatus ^= RINTERF_IDLE;
SEXP symbol;
symbol = Rf_install(name);
//FIXME: is the copy really needed / good ?
SEXP value_copy;
PROTECT(value_copy = Rf_duplicate(value));
Rf_defineVar(symbol, value_copy, envir);
//FIXME: protect/unprotect from garbage collection (for now protect only)
UNPROTECT(1);
RStatus ^= RINTERF_IDLE;
return 0;
}
/* Return NULL on failure */
SEXP
SexpEnvironment_get(const SEXP envir, const char* symbol) {
if (! RINTERF_ISREADY()) {
printf("R is not ready.\n");
return NULL;
}
RStatus ^= RINTERF_IDLE;
SEXP sexp, sexp_ok;
PROTECT(sexp = findVar(Rf_install(symbol), envir));
if (TYPEOF(sexp) == PROMSXP) {
sexp_ok = Sexp_evalPromise(sexp);
} else {
sexp_ok = sexp;
}
//FIXME: protect/unprotect from garbage collection (for now protect only)
R_PreserveObject(sexp_ok);
UNPROTECT(1);
RStatus ^= RINTERF_IDLE;
return sexp_ok;
}
/* Parse a string as R code.
Return NULL on error */
SEXP
EmbeddedR_parse(char *string) {
if (! RINTERF_ISREADY()) {
return NULL;
}
RStatus ^= RINTERF_IDLE;
ParseStatus status;
SEXP cmdSexp, cmdExpr;
PROTECT(cmdSexp = allocVector(STRSXP, 1));
SET_STRING_ELT(cmdSexp, 0, mkChar(string));
PROTECT(cmdExpr = R_ParseVector(cmdSexp, -1, &status, R_NilValue));
if (status != PARSE_OK) {
UNPROTECT(2);
RStatus ^= RINTERF_IDLE;
return NULL;
}
R_PreserveObject(cmdExpr);
UNPROTECT(2);
RStatus ^= RINTERF_IDLE;
return cmdExpr;
}
/* Is the R interface ready (embedded R initialized and idle) ?
Return 0 or 1*/
int
EmbeddedR_isReady (void) {
return RINTERF_ISREADY() == 0 ? 0 : 1;
}
/* Initialize R, that is start an embedded R.
Parameters are found in the global 'initargv'.
Return 0 on success, -1 on failure.
*/
int
EmbeddedR_init(void) {
if (RINTERF_ISREADY()) {
printf("R is already ready.\n");
return -1;
}
RStatus ^= RINTERF_IDLE;
if (! RINTERF_HASARGSSET()) {
/* Initialization arguments must be set and
R can only be initialized once */
printf("Initialization parameters must be set first.\n");
RStatus ^= RINTERF_IDLE;
return -1;
}
if (! initargv) {
printf("No initialisation argument. This should have been caught earlier.\n");
RStatus ^= RINTERF_IDLE;
return -1;
}
int status = Rf_initEmbeddedR(initargv->argc, initargv->argv);
if (status < 0) {
printf("R initialization failed.\n");
RStatus ^= RINTERF_IDLE;
return -1;
}
/* R_Interactive = TRUE; */
/* #ifdef RIF_HAS_RSIGHAND */
/* R_SignalHandlers = 0; */
/* #endif */
/* #ifdef CSTACK_DEFNS */
/* /\* Taken from JRI: */
/* * disable stack checking, because threads will thow it off *\/ */
/* R_CStackStart = (uintptr_t) -1; */
/* R_CStackLimit = (uintptr_t) -1; */
/* /\* --- *\/ */
/* #endif */
//setup_Rmainloop();
/*FIXME: setting readline variables so R's oddly static declarations
become harmless*/
#ifdef HAS_READLINE
char *rl_completer, *rl_basic;
rl_completer = strndup(rl_completer_word_break_characters, 200);
rl_completer_word_break_characters = rl_completer;
rl_basic = strndup(rl_basic_word_break_characters, 200);
rl_basic_word_break_characters = rl_basic;
#endif
/* */
errMessage_SEXP = findVar(install("geterrmessage"),
R_BaseNamespace);
RStatus |= (RINTERF_INITIALIZED);
RStatus ^= RINTERF_IDLE;
return 0;
}
