USER_OBJECT_
directConvertFromPerl(SV * perlObj, USER_OBJECT_ convert)
{
USER_OBJECT_ ans = NULL_USER_OBJECT;
if(TYPEOF(convert) == CLOSXP) {
SEXP e, ref;
PROTECT(e = allocVector(LANGSXP, 2));
SETCAR(e, convert);
PROTECT(ref = makeForeignPerlReference((SV*) perlObj, makeRSPerlClassVector("PerlReference"), &exportReferenceTable));
/* Alternative way of creating the reference.
SEXP classes;
PROTECT(classes = computeRSPerlClassVector(val, &elementType, convert));
PROTECT(ref = makeForeignPerlReference(perlObj, classes, &exportReferenceTable));
*/
SETCAR(CDR(e), ref);
ans = Rf_eval(e, R_GlobalEnv);
UNPROTECT(2);
} else if(TYPEOF(convert) == EXTPTRSXP) {
FromPerlNativeConverter f;
if(R_ExternalPtrTag(convert) != Rf_install("native symbol")) {
PROBLEM "Unrecognized external pointer passed to directConvertFromPerlRoutine"
ERROR;
}
f = (FromPerlNativeConverter) R_ExternalPtrAddr(convert);
ans = f(perlObj);
}
return(ans);
}
SEXP
simplifyRList(SEXP l)
{
int i, n;
int type = TYPEOF(VECTOR_ELT(l, 0));
SEXP el;
n = GET_LENGTH(l);
for(i = 1; i < n ; i++) {
el = VECTOR_ELT(l, i);
if(type != TYPEOF(el))
return(l);
}
if(type != INTSXP && type != LGLSXP && type != STRSXP && type != REALSXP && type != CPLXSXP)
return(l);
{
SEXP e;
PROTECT(e = allocVector(LANGSXP, 2));
SETCAR(e, Rf_install("unlist"));
SETCAR(CDR(e), l);
l = Rf_eval(e, R_GlobalEnv);
UNPROTECT(1);
}
return(l);
}
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)));
}
bool
RwxTextDropTarget::OnDropText(wxCoord x, wxCoord y, const wxString &text)
{
if(!R_OnDropText_m)
return(false);
SEXP e, r_ans, p;
bool ans;
//XXX check
PROTECT(e = allocVector(LANGSXP, 5));
SETCAR(e, R_OnDropText_m); p = CDR(e);
SETCAR(p, R_make_wx_Ref(this, "RwxTextDropTarget")); p = CDR(p);
SETCAR(p, ScalarInteger(x)); p = CDR(p);
SETCAR(p, ScalarInteger(y)); p = CDR(p);
SETCAR(p, wxStringToR(text));
r_ans = Rf_eval(e, R_GlobalEnv);
if(TYPEOF(r_ans) == LGLSXP)
ans = LOGICAL(r_ans)[0];
else
ans = Rf_length(r_ans) > 0;
UNPROTECT(1);
return(ans);
}
static SEXP CreateHess(SEXP names)
{
SEXP p, q, data, dim, dimnames;
int i, n;
n = length(names);
PROTECT(dimnames = lang4(R_NilValue, R_NilValue, R_NilValue, R_NilValue));
SETCAR(dimnames, install("list"));
p = install("c");
PROTECT(q = allocList(n));
SETCADDR(dimnames, LCONS(p, q));
UNPROTECT(1);
for(i = 0 ; i < n ; i++) {
SETCAR(q, ScalarString(STRING_ELT(names, i)));
q = CDR(q);
}
SETCADDDR(dimnames, duplicate(CADDR(dimnames)));
PROTECT(dim = lang4(R_NilValue, R_NilValue, R_NilValue,R_NilValue));
SETCAR(dim, install("c"));
SETCADR(dim, lang2(install("length"), install(".value")));
SETCADDR(dim, ScalarInteger(length(names)));
SETCADDDR(dim, ScalarInteger(length(names)));
PROTECT(data = ScalarReal(0.));
PROTECT(p = lang4(install("array"), data, dim, dimnames));
p = lang3(install("<-"), install(".hessian"), p);
UNPROTECT(4);
return p;
}
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;
}
/**
Computes the smoothed values for the y variable
for the bivariate X and Y identified by column
index for the data set in ggobi.
This calls the R/S function currently registered
in the variable RS_smoothFunction with three arguments:
the numeric vectors x & y
the desired window width as specified by the
the argument `width'.
*/
double *
RS_GGOBI(smooth)(int x_index, int y_index, double width, ggobid *gg)
{
double *values;
USER_OBJECT_ vals, tmp;
USER_OBJECT_ e;
if(RS_smoothFunction == NULL || RS_smoothFunction == R_UnboundValue)
return(NULL);
e = allocVector(LANGSXP, 4);
PROTECT(e);
SETCAR(e, RS_smoothFunction);
SETCAR(CDR(e), RS_GGOBI(variableToRS)(x_index, gg));
SETCAR(CDR(CDR(e)), RS_GGOBI(variableToRS)(y_index, gg));
tmp = NEW_NUMERIC(1);
NUMERIC_DATA(tmp)[0] = width;
SETCAR(CDR(CDR(CDR(e))), tmp);
vals = eval(e, R_GlobalEnv);
PROTECT(vals);
/* PrintValue(vals); */
values = asCArray(vals, double, asCNumeric);
UNPROTECT(2);
return(values);
}
void copyListMatrix(SEXP s, SEXP t, Rboolean byrow)
{
int nr = nrows(s), nc = ncols(s);
R_xlen_t ns = ((R_xlen_t) nr) * nc;
SEXP pt = t;
if(byrow) {
R_xlen_t NR = nr;
SEXP tmp = PROTECT(allocVector(STRSXP, ns));
for (int i = 0; i < nr; i++)
for (int j = 0; j < nc; j++) {
SET_STRING_ELT(tmp, i + j * NR, duplicate(CAR(pt)));
pt = CDR(pt);
if(pt == R_NilValue) pt = t;
}
for (int i = 0; i < ns; i++) {
SETCAR(s, STRING_ELT(tmp, i++));
s = CDR(s);
}
UNPROTECT(1);
}
else {
for (int i = 0; i < ns; i++) {
SETCAR(s, duplicate(CAR(pt)));
s = CDR(s);
pt = CDR(pt);
if(pt == R_NilValue) pt = t;
}
}
}
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)));
}
USER_OBJECT_
createFactor(USER_OBJECT_ vals, vartabled *vt, GGobiData *d, int which)
{
USER_OBJECT_ labels, levels, ans, e;
int i;
PROTECT(levels = NEW_INTEGER(vt->nlevels));
PROTECT(labels = NEW_CHARACTER(vt->nlevels));
for(i = 0; i < vt->nlevels; i++) {
INTEGER_DATA(levels)[i] = vt->level_values[i];
if (vt->level_names[i])
SET_STRING_ELT(labels, i, COPY_TO_USER_STRING(vt->level_names[i]));
}
PROTECT(e = allocVector(LANGSXP, 4));
SETCAR(e, Rf_install("factor"));
SETCAR(CDR(e), vals);
SETCAR(CDR(CDR(e)), levels);
SETCAR(CDR(CDR(CDR(e))), labels);
ans = eval(e, R_GlobalEnv);
UNPROTECT(3);
return(ans);
}
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)));
}
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);
}
static wxDragResult
invoke(SEXP fun, wxTextDropTarget *This, wxCoord x, wxCoord y, wxDragResult def)
{
SEXP e, r_ans, p;
wxDragResult ans;
PROTECT(e = p = allocVector(LANGSXP, 5));
SETCAR(e, fun); p = CDR(p);
SETCAR(p, R_make_wx_Ref(This, "RwxTextDropTarget")); p = CDR(p);
SETCAR(p, ScalarInteger(x)); p = CDR(p);
SETCAR(p, ScalarInteger(y)); p = CDR(p);
SETCAR(p, ScalarInteger(def)); //XX make an enum
r_ans = Rf_eval(e, R_GlobalEnv);
if(TYPEOF(r_ans) == INTSXP)
ans = (wxDragResult) LOGICAL(r_ans)[0];
else if(TYPEOF(r_ans) == REALSXP)
ans = (wxDragResult) REAL(r_ans)[0];
else
ans = def;
UNPROTECT(1);
return(ans);
}
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;
}
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);
}
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)));
}
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;
}
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;
}
Rboolean
R_isInstanceOf(USER_OBJECT_ obj, const char *klass)
{
USER_OBJECT_ klasses;
int n, i;
SEXP e, r_ans;
Rboolean ans;
klasses = GET_CLASS(obj);
n = GET_LENGTH(klasses);
for(i = 0; i < n ; i++) {
if(strcmp(CHAR_DEREF(STRING_ELT(klasses, i)), klass) == 0)
return(TRUE);
}
PROTECT(e = allocVector(LANGSXP, 3));
SETCAR(e, Rf_install("is"));
SETCAR(CDR(e), obj);
SETCAR(CDR(CDR(e)), mkString(klass));
r_ans = Rf_eval(e, R_GlobalEnv);
ans = LOGICAL(r_ans)[0];
UNPROTECT(1);
return(ans);
}
static SEXP
convertNodeSetToR(xmlNodeSetPtr obj, SEXP fun, int encoding, SEXP manageMemory)
{
SEXP ans, expr = NULL, arg = NULL, ref;
int i;
if(!obj)
return(NULL_USER_OBJECT);
PROTECT(ans = NEW_LIST(obj->nodeNr));
if(GET_LENGTH(fun) && (TYPEOF(fun) == CLOSXP || TYPEOF(fun) == BUILTINSXP)) {
PROTECT(expr = allocVector(LANGSXP, 2));
SETCAR(expr, fun);
arg = CDR(expr);
} else if(TYPEOF(fun) == LANGSXP) {
expr = fun;
arg = CDR(expr);
}
for(i = 0; i < obj->nodeNr; i++) {
xmlNodePtr el;
el = obj->nodeTab[i];
if(el->type == XML_ATTRIBUTE_NODE) {
#if 0
PROTECT(ref = mkString((el->children && el->children->content) ? XMLCHAR_TO_CHAR(el->children->content) : ""));
SET_NAMES(ref, mkString(el->name));
#else
PROTECT(ref = ScalarString(mkCharCE((el->children && el->children->content) ? XMLCHAR_TO_CHAR(el->children->content) : "", encoding)));
SET_NAMES(ref, ScalarString(mkCharCE(el->name, encoding)));
#endif
SET_CLASS(ref, mkString("XMLAttributeValue"));
UNPROTECT(1);
} else if(el->type == XML_NAMESPACE_DECL)
ref = R_createXMLNsRef((xmlNsPtr) el);
else
ref = R_createXMLNodeRef(el, manageMemory);
if(expr) {
PROTECT(ref);
SETCAR(arg, ref);
PROTECT(ref = Rf_eval(expr, R_GlobalEnv)); /*XXX do we want to catch errors here? Maybe to release the namespaces. */
SET_VECTOR_ELT(ans, i, ref);
UNPROTECT(2);
} else
SET_VECTOR_ELT(ans, i, ref);
}
if(expr) {
if(TYPEOF(fun) == CLOSXP || TYPEOF(fun) == BUILTINSXP)
UNPROTECT(1);
} else
SET_CLASS(ans, mkString("XMLNodeSet"));
UNPROTECT(1);
return(ans);
}
SEXP single_arg_R_fun(char* fun, SEXP x){
SEXP s, t;
t = s = PROTECT(allocList(2));
SET_TYPEOF(s, LANGSXP);
SETCAR(t, install(fun)); t = CDR(t);
SETCAR(t, x);
UNPROTECT(1);
return eval(s, R_GlobalEnv);
}
/* 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);
}
/* This is a primitive SPECIALSXP */
SEXP attribute_hidden do_onexit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
RCNTXT *ctxt;
SEXP code, oldcode, tmp, argList;
int addit = 0;
static SEXP do_onexit_formals = NULL;
if (do_onexit_formals == NULL)
do_onexit_formals = allocFormalsList2(install("expr"), install("add"));
PROTECT(argList = matchArgs(do_onexit_formals, args, call));
if (CAR(argList) == R_MissingArg) code = R_NilValue;
else code = CAR(argList);
if (CADR(argList) != R_MissingArg) {
addit = asLogical(eval(CADR(args), rho));
if (addit == NA_INTEGER)
errorcall(call, _("invalid '%s' argument"), "add");
}
ctxt = R_GlobalContext;
/* Search for the context to which the on.exit action is to be
attached. Lexical scoping is implemented by searching for the
first closure call context with an environment matching the
expression evaluation environment. */
while (ctxt != R_ToplevelContext &&
!((ctxt->callflag & CTXT_FUNCTION) && ctxt->cloenv == rho) )
ctxt = ctxt->nextcontext;
if (ctxt->callflag & CTXT_FUNCTION)
{
if (addit && (oldcode = ctxt->conexit) != R_NilValue ) {
if ( CAR(oldcode) != R_BraceSymbol )
{
PROTECT(tmp = allocList(3));
SETCAR(tmp, R_BraceSymbol);
SETCADR(tmp, oldcode);
SETCADDR(tmp, code);
SET_TYPEOF(tmp, LANGSXP);
ctxt->conexit = tmp;
UNPROTECT(1);
}
else
{
PROTECT(tmp = allocList(1));
SETCAR(tmp, code);
ctxt->conexit = listAppend(duplicate(oldcode),tmp);
UNPROTECT(1);
}
}
else
ctxt->conexit = code;
}
UNPROTECT(1);
return R_NilValue;
}
SEXP RKStructureGetter::callSimpleFun (SEXP fun, SEXP arg, SEXP env) {
SEXP call = allocVector (LANGSXP, 2);
PROTECT (call);
SETCAR (call, fun);
SETCAR (CDR (call), arg);
SEXP ret = eval (call, env);
UNPROTECT (1); /* call */
return ret;
}
/* {{{ 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);
}
}
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;
}
}
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);
}
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]);
}
SEXP
createCOMReferenceObject(SEXP ptr, const char *tag)
{
SEXP e, val;
PROTECT(e = allocVector(LANGSXP, 3));
SETCAR(e, Rf_install("createCOMReference")); /* in RDCOMClient code. */
SETCAR(CDR(e), ptr);
SETCAR(CDR(CDR(e)), mkString(tag));
val = eval(e, R_GlobalEnv);
UNPROTECT(1);
return(val);
}
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));
}
