/* {{{ proto mixed R::parseEval(string code[, mixed &result])
*/
static PHP_METHOD(R, parseEval)
{
char *code;
int code_len, error_occured = 0;
SEXP e1, e2, tmp, val_parse, val, next;
zval *result = NULL;
if (zend_parse_parameters(ZEND_NUM_ARGS() TSRMLS_CC, "s|z/", &code, &code_len, &result) == FAILURE) {
return;
}
if (result) {
zval_dtor(result);
ZVAL_NULL(result);
}
PROTECT(e1 = allocVector(LANGSXP, 2));
SETCAR(e1, Rf_install("parse"));
SETCAR(CDR(e1), tmp = NEW_CHARACTER(1));
SET_STRING_ELT(tmp, 0, COPY_TO_USER_STRING(code));
next = CDR(e1);
SET_TAG(next, Rf_install("text"));
val_parse = R_tryEval(e1, R_GlobalEnv, &error_occured);
if (error_occured) {
UNPROTECT(1);
RETURN_FALSE;
}
/* okay, the call succeeded */
PROTECT(val_parse);
PROTECT(e2 = allocVector(LANGSXP, 2));
SETCAR(e2, Rf_install("eval"));
SETCAR(CDR(e2), val_parse);
UNPROTECT(1);
val = R_tryEval(e2, R_GlobalEnv, &error_occured);
if (error_occured) {
UNPROTECT(2);
RETURN_FALSE;
}
if (result) {
php_r_to_zval(val, result);
UNPROTECT(2);
RETURN_TRUE;
} else {
php_r_to_zval(val, return_value);
UNPROTECT(2);
}
}
/* Autoload default packages and names from autoloads.h
*
* This function behaves in almost every way like
* R's autoload:
* function (name, package, reset = FALSE, ...)
* {
* if (!reset && exists(name, envir = .GlobalEnv, inherits = FALSE))
* stop("an object with that name already exists")
* m <- match.call()
* m[[1]] <- as.name("list")
* newcall <- eval(m, parent.frame())
* newcall <- as.call(c(as.name("autoloader"), newcall))
* newcall$reset <- NULL
* if (is.na(match(package, .Autoloaded)))
* assign(".Autoloaded", c(package, .Autoloaded), env = .AutoloadEnv)
* do.call("delayedAssign", list(name, newcall, .GlobalEnv,
* .AutoloadEnv))
* invisible()
* }
*
* What's missing is the updating of the string vector .Autoloaded with the list
* of packages, which by my code analysis is useless and only for informational
* purposes.
*
*/
void autoloads(void){
SEXP da, dacall, al, alcall, AutoloadEnv, name, package;
int i,j, idx=0, errorOccurred, ptct;
/* delayedAssign call*/
PROTECT(da = Rf_findFun(Rf_install("delayedAssign"), R_GlobalEnv));
PROTECT(AutoloadEnv = Rf_findVar(Rf_install(".AutoloadEnv"), R_GlobalEnv));
if (AutoloadEnv == R_NilValue){
fprintf(stderr,"%s: Cannot find .AutoloadEnv!\n", programName);
exit(1);
}
PROTECT(dacall = allocVector(LANGSXP,5));
SETCAR(dacall,da);
/* SETCAR(CDR(dacall),name); */ /* arg1: assigned in loop */
/* SETCAR(CDR(CDR(dacall)),alcall); */ /* arg2: assigned in loop */
SETCAR(CDR(CDR(CDR(dacall))),R_GlobalEnv); /* arg3 */
SETCAR(CDR(CDR(CDR(CDR(dacall)))),AutoloadEnv); /* arg3 */
/* autoloader call */
PROTECT(al = Rf_findFun(Rf_install("autoloader"), R_GlobalEnv));
PROTECT(alcall = allocVector(LANGSXP,3));
SET_TAG(alcall, R_NilValue); /* just like do_ascall() does */
SETCAR(alcall,al);
/* SETCAR(CDR(alcall),name); */ /* arg1: assigned in loop */
/* SETCAR(CDR(CDR(alcall)),package); */ /* arg2: assigned in loop */
ptct = 5;
for(i = 0; i < packc; i++){
idx += (i != 0)? packobjc[i-1] : 0;
for (j = 0; j < packobjc[i]; j++){
/*printf("autload(%s,%s)\n",packobj[idx+j],pack[i]);*/
PROTECT(name = NEW_CHARACTER(1));
PROTECT(package = NEW_CHARACTER(1));
SET_STRING_ELT(name, 0, COPY_TO_USER_STRING(packobj[idx+j]));
SET_STRING_ELT(package, 0, COPY_TO_USER_STRING(pack[i]));
/* Set up autoloader call */
PROTECT(alcall = allocVector(LANGSXP,3));
SET_TAG(alcall, R_NilValue); /* just like do_ascall() does */
SETCAR(alcall,al);
SETCAR(CDR(alcall),name);
SETCAR(CDR(CDR(alcall)),package);
/* Setup delayedAssign call */
SETCAR(CDR(dacall),name);
SETCAR(CDR(CDR(dacall)),alcall);
R_tryEval(dacall,R_GlobalEnv,&errorOccurred);
if (errorOccurred){
fprintf(stderr,"%s: Error calling delayedAssign!\n", programName);
exit(1);
}
ptct += 3;
}
}
UNPROTECT(ptct);
}
int source(char *file){
SEXP expr, s, f, p;
int errorOccurred;
/* Find source function */
s = Rf_findFun(Rf_install("source"), R_GlobalEnv);
PROTECT(s);
/* Make file argument */
PROTECT(f = NEW_CHARACTER(1));
SET_STRING_ELT(f, 0, COPY_TO_USER_STRING(file));
/* Make print.eval argument */
PROTECT(p = NEW_LOGICAL(1));
LOGICAL_DATA(p)[0] = (verbose)? TRUE : FALSE;
/* expression source(f,print.eval=p) */
PROTECT(expr = allocVector(LANGSXP,3));
SETCAR(expr,s);
SETCAR(CDR(expr),f);
SETCAR(CDR(CDR(expr)), p);
SET_TAG(CDR(CDR(expr)), Rf_install("print.eval"));
errorOccurred=0;
R_tryEval(expr,NULL,&errorOccurred);
UNPROTECT(4);
return errorOccurred;
}
gboolean
S_PangoCairoShapeRendererFunc(cairo_t* s_cr, PangoAttrShape* s_attr, gboolean s_do_path, gpointer s_data)
{
USER_OBJECT_ e;
USER_OBJECT_ tmp;
USER_OBJECT_ s_ans;
gint err;
PROTECT(e = allocVector(LANGSXP, 4+((R_CallbackData *)s_data)->useData));
tmp = e;
SETCAR(tmp, ((R_CallbackData *)s_data)->function);
tmp = CDR(tmp);
SETCAR(tmp, toRPointerWithCairoRef(s_cr, "Cairo", cairo));
tmp = CDR(tmp);
SETCAR(tmp, toRPointer(s_attr, "PangoAttrShape"));
tmp = CDR(tmp);
SETCAR(tmp, asRLogical(s_do_path));
tmp = CDR(tmp);
if(((R_CallbackData *)s_data)->useData)
{
SETCAR(tmp, ((R_CallbackData *)s_data)->data);
tmp = CDR(tmp);
}
s_ans = R_tryEval(e, R_GlobalEnv, &err);
UNPROTECT(1);
if(err)
return(((gboolean)0));
return(((gboolean)asCLogical(s_ans)));
}
/* Evaluate a SEXP. It must be constructed by hand. It raises a Ruby
exception if an error ocurred in the evaluation */
SEXP do_eval_expr(SEXP e) {
SEXP res;
VALUE rb_eRException;
int error = 0;
signal(SIGINT, interrupt_R);
interrupted = 0;
res = R_tryEval(e, R_GlobalEnv, &error);
if (error) {
if (interrupted) {
rb_raise(rb_eInterrupt,"RSRuby interrupted");
}
else {
rb_eRException = rb_const_get(rb_cObject,
rb_intern("RException"));
rb_raise(rb_eRException, "%s", get_last_error_msg());
return NULL;
}
}
return res;
}
gboolean
S_PangoFontsetForeachFunc(PangoFontset* s_fontset, PangoFont* s_font, gpointer s_data)
{
USER_OBJECT_ e;
USER_OBJECT_ tmp;
USER_OBJECT_ s_ans;
gint err;
PROTECT(e = allocVector(LANGSXP, 3+((R_CallbackData *)s_data)->useData));
tmp = e;
SETCAR(tmp, ((R_CallbackData *)s_data)->function);
tmp = CDR(tmp);
SETCAR(tmp, toRPointerWithRef(s_fontset, "PangoFontset"));
tmp = CDR(tmp);
SETCAR(tmp, toRPointerWithRef(s_font, "PangoFont"));
tmp = CDR(tmp);
if(((R_CallbackData *)s_data)->useData)
{
SETCAR(tmp, ((R_CallbackData *)s_data)->data);
tmp = CDR(tmp);
}
s_ans = R_tryEval(e, R_GlobalEnv, &err);
UNPROTECT(1);
if(err)
return(((gboolean)0));
return(((gboolean)asCLogical(s_ans)));
}
/**
* Wrapper for R function add1, defined in func.R.
*/
void R_add1(int alen, int a[])
{
// Allocate an R vector and copy the C array into it.
SEXP arg;
PROTECT(arg = allocVector(INTSXP, alen));
memcpy(INTEGER(arg), a, alen * sizeof(int));
// Setup a call to the R function
SEXP add1_call;
PROTECT(add1_call = lang2(install("add1"), arg));
// Execute the function
int errorOccurred;
SEXP ret = R_tryEval(add1_call, R_GlobalEnv, &errorOccurred);
if (!errorOccurred)
{
printf("R returned: ");
double *val = REAL(ret);
for (int i = 0; i < LENGTH(ret); i++)
printf("%0.1f, ", val[i]);
printf("\n");
}
else
{
printf("Error occurred calling R\n");
}
UNPROTECT(2);
}
SEXP R_get_function(char *fname)
{
SEXP expr, res;
int error;
printf("fname: %s\n", fname);
SEXP robj = Rf_findVar(Rf_install(fname), R_GlobalEnv);
if (robj == R_UnboundValue)
return R_NilValue;
robj = Rf_findFun(Rf_install(fname), R_GlobalEnv);
printf("VALUE: \n");
Rf_PrintValue(robj);
PROTECT(expr = allocVector(LANGSXP, 2));
SETCAR(expr, install("get"));
SETCAR(CDR(expr), Rf_mkString(fname));
res = R_tryEval(expr, R_GlobalEnv, &error);
// Rf_PrintValue(res);
if (error) {
// rb_raise(rb_eRException, "R execution exception. %s", expr);
UNPROTECT(1);
return NULL;
}
UNPROTECT(1);
return res;
}
SEXP
RClosureTable_callWithName(R_ObjectTableAction handlerType, const char * const name, R_ObjectTable *tb)
{
SEXP obj, fun, val, e;
int errorOccurred = FALSE;
obj = (SEXP) tb->privateData;
fun = RClosureTable_getFunction(obj, handlerType);
if(!fun || fun == R_NilValue) {
return(NEW_LOGICAL(1));
}
PROTECT(e = allocVector(LANGSXP,2));
SETCAR(e, fun);
SETCAR(CDR(e), val = NEW_CHARACTER(1));
SET_STRING_ELT(val, 0, COPY_TO_USER_STRING(name));
#ifndef TRY_EVAL
val = eval(e, R_GlobalEnv);
#else
val = R_tryEval(e, NULL, &errorOccurred);
#endif
if(errorOccurred) {
UNPROTECT(1);
return(R_UnboundValue);
}
UNPROTECT(1);
return(val);
}
cairo_status_t
S_cairo_write_func_t(gpointer s_closure, const guchar* s_data, guint s_length)
{
USER_OBJECT_ e;
USER_OBJECT_ tmp;
USER_OBJECT_ s_ans;
gint err;
PROTECT(e = allocVector(LANGSXP, 4));
tmp = e;
SETCAR(tmp, ((R_CallbackData *)s_closure)->function);
tmp = CDR(tmp);
SETCAR(tmp, asRRawArrayWithSize(s_data, s_length));
tmp = CDR(tmp);
SETCAR(tmp, asRNumeric(s_length));
tmp = CDR(tmp);
SETCAR(tmp, ((R_CallbackData *)s_closure)->data);
tmp = CDR(tmp);
s_ans = R_tryEval(e, R_GlobalEnv, &err);
if(err)
return(((cairo_status_t)0));
UNPROTECT(1);
return(((cairo_status_t)asCEnum(s_ans, CAIRO_TYPE_STATUS)));
}
int
loadXSLPackage(void)
{
USER_OBJECT_ e, fun, tmp;
int isError;
PROTECT(fun = Rf_findFun(Rf_install("library"), R_GlobalEnv));
PROTECT(e = allocVector(LANGSXP, 2));
SETCAR(e, fun);
SETCAR(CDR(e), tmp = NEW_CHARACTER(1));
SET_VECTOR_ELT(tmp, 0, COPY_TO_USER_STRING("Sxslt"));
R_tryEval(e, R_GlobalEnv, &isError);
if(isError) {
Rf_error("Couldn't load Sxslt package. Check the setting of R_LIBS");
/*
fprintf(stderr, "Couldn't load Sxslt package. Check the setting of R_LIBS\n");
fflush(stderr);
*/
}
UNPROTECT(2);
return(TRUE);
}
SEXP librinterface_remove(SEXP symbol, SEXP env, SEXP rho)
{
SEXP c_R, call_R, res;
static SEXP fun_R = NULL;
/* Only fetch rm() the first time */
if (fun_R == NULL) {
PROTECT(fun_R = librinterface_FindFun(install("rm"), rho));
R_PreserveObject(fun_R);
UNPROTECT(1);
}
if(!isEnvironment(rho)) error("'rho' should be an environment");
/* incantation to summon R */
PROTECT(c_R = call_R = allocList(2+1));
SET_TYPEOF(c_R, LANGSXP);
SETCAR(c_R, fun_R);
c_R = CDR(c_R);
/* first argument is the name of the variable to be removed */
SETCAR(c_R, symbol);
//SET_TAG(c_R, install("list"));
c_R = CDR(c_R);
/* second argument is the environment in which the variable
should be removed */
SETCAR(c_R, env);
SET_TAG(c_R, install("envir"));
c_R = CDR(c_R);
int error = 0;
PROTECT(res = R_tryEval(call_R, rho, &error));
UNPROTECT(3);
return res;
}
SEXP rpy_remove(SEXP symbol, SEXP env, SEXP rho)
{
SEXP c_R, call_R, res, fun_R;
PROTECT(fun_R = rpy_findFun(install("rm"), rho));
if(!isEnvironment(rho)) error("'rho' should be an environment");
/* incantation to summon R */
PROTECT(c_R = call_R = allocList(2+1));
SET_TYPEOF(c_R, LANGSXP);
SETCAR(c_R, fun_R);
c_R = CDR(c_R);
/* first argument is the name of the variable to be removed */
SETCAR(c_R, symbol);
//SET_TAG(c_R, install("list"));
c_R = CDR(c_R);
/* second argument is the environment in which the variable
should be removed */
SETCAR(c_R, env);
SET_TAG(c_R, install("envir"));
c_R = CDR(c_R);
int error = 0;
PROTECT(res = R_tryEval(call_R, rho, &error));
UNPROTECT(3);
return res;
}
int R_curl_callback_progress(SEXP fun,
double dltotal, double dlnow,
double ultotal, double ulnow) {
SEXP down = PROTECT(allocVector(REALSXP, 2));
REAL(down)[0] = dltotal;
REAL(down)[1] = dlnow;
SEXP up = PROTECT(allocVector(REALSXP, 2));
REAL(up)[0] = ultotal;
REAL(up)[1] = ulnow;
SEXP call = PROTECT(LCONS(fun, LCONS(down, LCONS(up, R_NilValue))));
int ok;
SEXP res = PROTECT(R_tryEval(call, R_GlobalEnv, &ok));
if (ok != 0 || pending_interrupt()) {
UNPROTECT(4);
return 0;
}
if (TYPEOF(res) != LGLSXP || length(res) != 1) {
UNPROTECT(4);
Rf_warning("progress callback must return boolean");
return 0;
}
UNPROTECT(4);
return !asLogical(res);
}
int inla_R_source(const char *filename)
{
if (!filename)
return INLA_OK;
inla_R_init();
#pragma omp critical
{
SEXP e, result;
int error;
if (R_debug)
fprintf(stderr, "R-interface: source file [%s]\n", filename);
PROTECT(e = lang2(install("source"), mkString(filename)));
PROTECT(result = R_tryEval(e, R_GlobalEnv, &error));
if (error){
fprintf(stderr, "\n *** ERROR ***: source R-file [%s] failed.\n", filename);
exit(1);
}
UNPROTECT(2);
}
return INLA_OK;
}
void* rffi_get_ary(char* cmd,int* type,int* len) {
int errorOccurred,status, i;
SEXP text, expr, ans; //=R_NilValue /* -Wall */;
text = PROTECT(allocVector(STRSXP, 1));
//printf("cmd: %s\n",cmdString);
SET_STRING_ELT(text, 0, mkChar(cmd));
expr = PROTECT(RR_ParseVector(text, -1, &status));
if (status != PARSE_OK) {
printf("Parsing error in: %s\n",cmd);
UNPROTECT(2);
return (void*)NULL;
}
/* Note that expr becomes an EXPRSXP and hence we need the loop
below (a straight eval(expr, R_GlobalEnv) won't work) */
ans = R_tryEval(VECTOR_ELT(expr, 0),R_GlobalEnv,&errorOccurred);
if(errorOccurred) {
//fflush(stderr);
printf("Exec error in: %s\n",cmd);
UNPROTECT(2);
return (void*)NULL;
}
UNPROTECT(2);
//printf("eval_get\n");
return util_SEXP2C(ans,type,len);
}
gboolean
S_PangoAttrFilterFunc(PangoAttribute* s_attribute, gpointer s_data)
{
USER_OBJECT_ e;
USER_OBJECT_ tmp;
USER_OBJECT_ s_ans;
gint err;
PROTECT(e = allocVector(LANGSXP, 2+((R_CallbackData *)s_data)->useData));
tmp = e;
SETCAR(tmp, ((R_CallbackData *)s_data)->function);
tmp = CDR(tmp);
SETCAR(tmp, asRPangoAttributeCopy(s_attribute));
tmp = CDR(tmp);
if(((R_CallbackData *)s_data)->useData)
{
SETCAR(tmp, ((R_CallbackData *)s_data)->data);
tmp = CDR(tmp);
}
s_ans = R_tryEval(e, R_GlobalEnv, &err);
UNPROTECT(1);
if(err)
return(((gboolean)0));
return(((gboolean)asCLogical(s_ans)));
}
/**
* Invokes the command source("foo.R").
*/
void source(const char *name)
{
SEXP e;
PROTECT(e = lang2(install("source"), mkString(name)));
R_tryEval(e, R_GlobalEnv, NULL);
UNPROTECT(1);
}
long r_eval(long exp, int *er){
SEXP es, exps=L2SEXP(exp);
int i=0, l;
if (TYPEOF(exps)==EXPRSXP) { /* if the object is a list of exps, eval them one by one */
l=LENGTH(exps);
while (i<l) {
es=R_tryEval(VECTOR_ELT(exps,i), R_GlobalEnv, er);
i++;
}
} else
es=R_tryEval(exps, R_GlobalEnv, er);
return SEXP2L(es);
}
// this is a non-throwing version returning an error code
int REmbed::parseEval(QString line, SEXP & ans) {
ParseStatus status;
SEXP cmdSexp, cmdexpr = R_NilValue;
int i, errorOccurred;
program << line;
PROTECT(cmdSexp = Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(cmdSexp, 0, Rf_mkChar(program.join(" ").toStdString().c_str()));
cmdexpr = PROTECT(R_ParseVector(cmdSexp, -1, &status, R_NilValue));
switch (status){
case PARSE_OK:
// Loop is needed here as EXPSEXP might be of length > 1
for(i = 0; i < Rf_length(cmdexpr); i++){
ans = R_tryEval(VECTOR_ELT(cmdexpr, i), R_GlobalEnv, &errorOccurred);
if (errorOccurred) {
if (verbose) Rf_warning("%s: Error in evaluating R code (%d)\n", name, status);
UNPROTECT(2);
program.clear();
return 1;
}
if (verbose) {
Rf_PrintValue(ans);
}
}
program.clear();
break;
case PARSE_INCOMPLETE:
// need to read another line
break;
case PARSE_NULL:
if (verbose) Rf_warning("%s: ParseStatus is null (%d)\n", name, status);
UNPROTECT(2);
program.clear();
return 1;
break;
case PARSE_ERROR:
if (verbose) Rf_error("Parse Error: \"%s\"\n", line.toStdString().c_str());
UNPROTECT(2);
program.clear();
return 1;
break;
case PARSE_EOF:
if (verbose) Rf_warning("%s: ParseStatus is eof (%d)\n", name, status);
break;
default:
if (verbose) Rf_warning("%s: ParseStatus is not documented %d\n", name, status);
UNPROTECT(2);
program.clear();
return 1;
break;
}
UNPROTECT(2);
return 0;
}
// this is a non-throwing version returning an error code
int RInside::parseEval(const std::string & line, SEXP & ans) {
ParseStatus status;
SEXP cmdSexp, cmdexpr = R_NilValue;
int i, errorOccurred;
mb_m.add((char*)line.c_str());
PROTECT(cmdSexp = Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(cmdSexp, 0, Rf_mkChar(mb_m.getBufPtr()));
cmdexpr = PROTECT(R_ParseVector(cmdSexp, -1, &status, R_NilValue));
switch (status){
case PARSE_OK:
// Loop is needed here as EXPSEXP might be of length > 1
for(i = 0; i < Rf_length(cmdexpr); i++){
ans = R_tryEval(VECTOR_ELT(cmdexpr, i), *global_env_m, &errorOccurred);
if (errorOccurred) {
if (verbose_m) Rf_warning("%s: Error in evaluating R code (%d)\n", programName, status);
UNPROTECT(2);
mb_m.rewind();
return 1;
}
if (verbose_m) {
Rf_PrintValue(ans);
}
}
mb_m.rewind();
break;
case PARSE_INCOMPLETE:
// need to read another line
break;
case PARSE_NULL:
if (verbose_m) Rf_warning("%s: ParseStatus is null (%d)\n", programName, status);
UNPROTECT(2);
mb_m.rewind();
return 1;
break;
case PARSE_ERROR:
if (verbose_m) Rf_warning("Parse Error: \"%s\"\n", line.c_str());
UNPROTECT(2);
mb_m.rewind();
return 1;
break;
case PARSE_EOF:
if (verbose_m) Rf_warning("%s: ParseStatus is eof (%d)\n", programName, status);
break;
default:
if (verbose_m) Rf_warning("%s: ParseStatus is not documented %d\n", programName, status);
UNPROTECT(2);
mb_m.rewind();
return 1;
break;
}
UNPROTECT(2);
return 0;
}
/* Temporary hack to suppress error message printing around a
R_tryEval call for use in methods_list_dispatch.c; should be
replaced once we have a way of establishing error handlers from C
code (probably would want a calling handler if we want to allow
user-defined calling handlers to enter a debugger, for
example). LT */
SEXP R_tryEvalSilent(SEXP e, SEXP env, int *ErrorOccurred)
{
SEXP val;
Rboolean oldshow = R_ShowErrorMessages;
R_ShowErrorMessages = FALSE;
val = R_tryEval(e, env, ErrorOccurred);
R_ShowErrorMessages = oldshow;
return val;
}
HRESULT
createGenericCOMObject(SEXP obj, VARIANT *var)
{
SEXP e, val;
int errorOccurred;
/* Make certain RDCOMServer is loaded as this might be invoked
as part of RDCOMClient. */
PROTECT(e = allocVector(LANGSXP, 3));
SETCAR(e, Rf_install("require"));
SETCAR(CDR(e), Rf_install("RDCOMServer"));
SETCAR(CDR(CDR(e)), val = allocVector(LGLSXP, 1));
INTEGER(val)[0] = TRUE;
SET_TAG(CDR(CDR(e)), Rf_install("quiet"));
val = R_tryEval(e, R_GlobalEnv, &errorOccurred);
UNPROTECT(1);
if(!LOGICAL(val)[0]) {
PROBLEM "Can't attach the RDCOMServer package needed to create a generic COM object"
ERROR;
return(S_FALSE);
}
PROTECT(e = allocVector(LANGSXP, 2));
SETCAR(e, Rf_install("createCOMObject"));
SETCAR(CDR(e), obj);
val = R_tryEval(e, R_GlobalEnv, &errorOccurred);
if(errorOccurred) {
UNPROTECT(1);
PROBLEM "Can't create COM object"
ERROR;
return(S_FALSE);
}
RCOMObject *robj;
if(TYPEOF(val) != EXTPTRSXP)
return(S_FALSE);
robj = (RCOMObject *) R_ExternalPtrAddr(val);
V_VT(var) = VT_DISPATCH;
V_DISPATCH(var) = robj;
return(S_OK);
}
int parse_eval(membuf_t *pmb, char *line, int lineno){
membuf_t mb = *pmb;
ParseStatus status;
SEXP cmdSexp, cmdexpr, ans = R_NilValue;
int i, errorOccurred;
mb = *pmb = add_to_membuf(pmb,line);
PROTECT(cmdSexp = allocVector(STRSXP, 1));
SET_STRING_ELT(cmdSexp, 0, mkChar((char*)mb->buf));
/* R_ParseVector gets a new argument in R 2.5.x */
cmdexpr = PROTECT(R_ParseVector(cmdSexp, -1, &status, R_NilValue));
switch (status){
case PARSE_OK:
/* Loop is needed here as EXPSEXP might be of length > 1 */
for(i = 0; i < length(cmdexpr); i++){
ans = R_tryEval(VECTOR_ELT(cmdexpr, i),NULL, &errorOccurred);
if (errorOccurred) {
UNPROTECT(2);
return 1;
}
if (verbose) {
PrintValue(ans);
}
}
mb = *pmb = rewind_membuf(pmb);
break;
case PARSE_INCOMPLETE:
fprintf(stderr, "%s: Incomplete Line! Need more code! (%d)\n", programName, status);
UNPROTECT(2);
return 1;
break;
case PARSE_NULL:
fprintf(stderr, "%s: ParseStatus is null (%d)\n", programName, status);
UNPROTECT(2);
return 1;
break;
case PARSE_ERROR:
fprintf(stderr,"Parse Error line %d: \"%s\"\n", lineno, line);
UNPROTECT(2);
return 1;
break;
case PARSE_EOF:
fprintf(stderr, "%s: EOF reached (%d)\n", programName, status);
break;
default:
fprintf(stderr, "%s: ParseStatus is not documented %d\n", programName, status);
UNPROTECT(2);
return 1;
break;
}
UNPROTECT(2);
return 0;
}
CAMLprim value ocamlr_eval_sxp (value sexp_list) {
/* sexp_list is an OCaml value containing a SEXP of sexptype LANGSXP.
This is a LISP-style pairlist of SEXP values. r_eval_sxp executes
the whole pairlist, and sends back the resulting SEXP wrapped up in
an OCaml value. There's also an error handling mechanism. */
/* r_eval_sxp handles values of type LANGSXP and PROMSXP. So we have two
functions on the OCaml side associated to this stub, the first on
with type lang sexp -> raw sexp, the other one with type
prom sexp -> raw sexp. This also means that there is a dynamic type
checking being done in the scope of the R_tryEval function, and it
would be nice to shortcut it with statically typed equivalents. */
CAMLparam0();
SEXP e; // Placeholder for the result of beta-reduction.
int error = 0; // Error catcher boolean.
SEXP our_call = Sexp_val(sexp_list);
caml_enter_blocking_section();
e = R_tryEval(our_call, R_GlobalEnv, &error);
caml_leave_blocking_section();
/* Implements error handling from R to Objective Caml. */
if (error) {
value ml_error_call = Val_unit;
value ml_error_message = Val_unit;
Begin_roots2(ml_error_call, ml_error_message);
ml_error_call = Val_sexp(ocamlr_error_call);
ocamlr_error_call = NULL; //should check for a memory leak here...
//depends on GC status of prior error_call.
ml_error_message = caml_copy_string(ocamlr_error_message);
ocamlr_error_message = NULL; //should check for a memory leak here...
//it seems to me that a string is leaked here.
value error_result = caml_alloc_small(2, 0);
Store_field(error_result, 0, ml_error_call);
Store_field(error_result, 1, ml_error_message);
/* The exception callback mechanism is described on the webpage
http://www.pps.jussieu.fr/Livres/ora/DA-OCAML/book-ora118.html
We should check to see if we could avoid the string-name lookup
to avoid unnecessary delays in exception handling. */
caml_raise_with_arg(*caml_named_value("OCaml-R generic error"), error_result);
End_roots();
}
CAMLreturn(Val_sexp(e));
}
static void callback_set_seed(void *unused, uli_t seed) {
// call R's set.seed using equivalent of parse(text="set.seed(seed)")
SEXP call = PROTECT(lang2(install("set.seed"), ScalarInteger(seed)));
int evalError;
SEXP result = R_tryEval(call, R_GlobalEnv, &evalError);
UNPROTECT(1);
if (evalError) error("Failed to eval 'set.seed(%d)'", seed);
if (! quiet) Rprintf("\nSet seed to %u\n", seed);
return;
}
static uli_t callback_get_int(void *unused) {
if (global_parsed_callback == NULL) return 0;
int evalError;
SEXP random_sexp = R_tryEval(global_parsed_callback, R_GlobalEnv, &evalError);
if (evalError) {
error("Failed to eval stored call");
return 0;
}
uli_t random_int = INTEGER_VALUE(random_sexp);
if (verbose) Rprintf("%u ", random_int);
return random_int;
}
int R_sys_getpid()
{
SEXP sys_pid, e1;
int errorOccurred;
PROTECT(e1 = lang1(install("Sys.getpid") ) );
PROTECT(sys_pid = R_tryEval(e1, R_GlobalEnv, &errorOccurred) );
int* sys_pid_r = INTEGER(sys_pid);
int ret =sys_pid_r[0];
UNPROTECT(2);
return(ret);
}
SEXP eval_Rexpr(SEXP expr) {
SEXP res;
int error = 0;
// Rf_PrintValue(expr);
res = R_tryEval(expr, R_GlobalEnv, &error);
if (error) {
// rb_raise(rb_eRException, "%s", get_last_error_msg());
printf("error occured in eval_Rexpr [i]");
}
return res;
}
SEXP cqlsVector_eval_cmd(CQLS_R renv, SEXP cmdR) {
SEXP ans;
int status;
PROTECT(ans = R_tryEval(VECTOR_ELT(cmdR, 0),renv->env, &status));
if(status) {
//fRprintf(stderr, "Caught another error calling sqrt()\n");
ans=R_NilValue;
fflush(stderr);
}
UNPROTECT(1);
return ans;
}
