SEXP do_edit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
int i, rc;
ParseStatus status;
SEXP x, fn, envir, ed, src, srcfile, Rfn;
char *filename, *editcmd;
const char *cmd;
const void *vmaxsave;
FILE *fp;
#ifdef Win32
SEXP ti;
char *title;
#endif
checkArity(op, args);
vmaxsave = vmaxget();
x = CAR(args); args = CDR(args);
if (TYPEOF(x) == CLOSXP) envir = CLOENV(x);
else envir = R_NilValue;
PROTECT(envir);
fn = CAR(args); args = CDR(args);
if (!isString(fn))
error(_("invalid argument to edit()"));
if (LENGTH(STRING_ELT(fn, 0)) > 0) {
const char *ss = translateChar(STRING_ELT(fn, 0));
filename = R_alloc(strlen(ss), sizeof(char));
strcpy(filename, ss);
}
else filename = DefaultFileName;
if (x != R_NilValue) {
if((fp=R_fopen(R_ExpandFileName(filename), "w")) == NULL)
errorcall(call, _("unable to open file"));
if (LENGTH(STRING_ELT(fn, 0)) == 0) EdFileUsed++;
if (TYPEOF(x) != CLOSXP || isNull(src = getAttrib(x, R_SourceSymbol)))
src = deparse1(x, CXXRFALSE, FORSOURCING); /* deparse for sourcing, not for display */
for (i = 0; i < LENGTH(src); i++)
fprintf(fp, "%s\n", translateChar(STRING_ELT(src, i)));
fclose(fp);
}
#ifdef Win32
ti = CAR(args);
#endif
args = CDR(args);
ed = CAR(args);
if (!isString(ed)) errorcall(call, _("argument 'editor' type not valid"));
cmd = translateChar(STRING_ELT(ed, 0));
if (strlen(cmd) == 0) errorcall(call, _("argument 'editor' is not set"));
editcmd = R_alloc(strlen(cmd) + strlen(filename) + 6, sizeof(char));
#ifdef Win32
if (!strcmp(cmd,"internal")) {
if (!isString(ti))
error(_("'title' must be a string"));
if (LENGTH(STRING_ELT(ti, 0)) > 0) {
title = R_alloc(strlen(CHAR(STRING_ELT(ti, 0)))+1, sizeof(char));
strcpy(title, CHAR(STRING_ELT(ti, 0)));
} else {
title = R_alloc(strlen(filename)+1, sizeof(char));
strcpy(title, filename);
}
Rgui_Edit(filename, CE_NATIVE, title, 1);
}
else {
/* Quote path if necessary */
if(cmd[0] != '"' && Rf_strchr(cmd, ' '))
sprintf(editcmd, "\"%s\" \"%s\"", cmd, filename);
else
sprintf(editcmd, "%s \"%s\"", cmd, filename);
rc = runcmd(editcmd, CE_NATIVE, 1, 1, NULL, NULL, NULL);
if (rc == NOLAUNCH)
errorcall(call, _("unable to run editor '%s'"), cmd);
if (rc != 0)
warningcall(call, _("editor ran but returned error status"));
}
#else
if (ptr_R_EditFile)
rc = ptr_R_EditFile(filename);
else {
sprintf(editcmd, "'%s' '%s'", cmd, filename); // allow for spaces
rc = R_system(editcmd);
}
if (rc != 0)
errorcall(call, _("problem with running editor %s"), cmd);
#endif
if (asLogical(GetOption1(install("keep.source")))) {
PROTECT(Rfn = findFun(install("readLines"), R_BaseEnv));
PROTECT(src = lang2(Rfn, ScalarString(mkChar(R_ExpandFileName(filename)))));
PROTECT(src = eval(src, R_BaseEnv));
PROTECT(Rfn = findFun(install("srcfilecopy"), R_BaseEnv));
PROTECT(srcfile = lang3(Rfn, ScalarString(mkChar("<tmp>")), src));
srcfile = eval(srcfile, R_BaseEnv);
UNPROTECT(5);
} else
srcfile = R_NilValue;
PROTECT(srcfile);
/* <FIXME> setup a context to close the file, and parse and eval
line by line */
if((fp = R_fopen(R_ExpandFileName(filename), "r")) == NULL)
errorcall(call, _("unable to open file to read"));
x = PROTECT(R_ParseFile(fp, -1, &status, srcfile));
fclose(fp);
if (status != PARSE_OK)
errorcall(call,
_("%s occurred on line %d\n use a command like\n x <- edit()\n to recover"), R_ParseErrorMsg, R_ParseError);
R_ResetConsole();
{ /* can't just eval(x) here */
int j, n;
SEXP tmp = R_NilValue;
n = LENGTH(x);
for (j = 0 ; j < n ; j++)
tmp = eval(XVECTOR_ELT(x, j), R_GlobalEnv);
x = tmp;
}
if (TYPEOF(x) == CLOSXP && envir != R_NilValue)
SET_CLOENV(x, envir);
UNPROTECT(3);
vmaxset(vmaxsave);
return x;
}
SEXP attribute_hidden do_relop_dflt(SEXP call, SEXP op, SEXP x, SEXP y)
{
SEXP klass = R_NilValue, dims, tsp=R_NilValue, xnames, ynames;
int nx, ny, xarray, yarray, xts, yts;
Rboolean mismatch = FALSE, iS;
PROTECT_INDEX xpi, ypi;
PROTECT_WITH_INDEX(x, &xpi);
PROTECT_WITH_INDEX(y, &ypi);
nx = length(x);
ny = length(y);
/* pre-test to handle the most common case quickly.
Used to skip warning too ....
*/
if (ATTRIB(x) == R_NilValue && ATTRIB(y) == R_NilValue &&
TYPEOF(x) == REALSXP && TYPEOF(y) == REALSXP &&
LENGTH(x) > 0 && LENGTH(y) > 0) {
SEXP ans = real_relop((RELOP_TYPE) PRIMVAL(op), x, y);
if (nx > 0 && ny > 0)
mismatch = ((nx > ny) ? nx % ny : ny % nx) != 0;
if (mismatch) {
PROTECT(ans);
warningcall(call, _("longer object length is not a multiple of shorter object length"));
UNPROTECT(1);
}
UNPROTECT(2);
return ans;
}
/* That symbols and calls were allowed was undocumented prior to
R 2.5.0. We deparse them as deparse() would, minus attributes */
if ((iS = isSymbol(x)) || TYPEOF(x) == LANGSXP) {
SEXP tmp = allocVector(STRSXP, 1);
PROTECT(tmp);
SET_STRING_ELT(tmp, 0, (iS) ? PRINTNAME(x) :
STRING_ELT(deparse1(x, 0, DEFAULTDEPARSE), 0));
REPROTECT(x = tmp, xpi);
UNPROTECT(1);
}
if ((iS = isSymbol(y)) || TYPEOF(y) == LANGSXP) {
SEXP tmp = allocVector(STRSXP, 1);
PROTECT(tmp);
SET_STRING_ELT(tmp, 0, (iS) ? PRINTNAME(y) :
STRING_ELT(deparse1(y, 0, DEFAULTDEPARSE), 0));
REPROTECT(y = tmp, ypi);
UNPROTECT(1);
}
if (!isVector(x) || !isVector(y)) {
if (isNull(x) || isNull(y)) {
UNPROTECT(2);
return allocVector(LGLSXP,0);
}
errorcall(call,
_("comparison (%d) is possible only for atomic and list types"),
PRIMVAL(op));
}
if (TYPEOF(x) == EXPRSXP || TYPEOF(y) == EXPRSXP)
errorcall(call, _("comparison is not allowed for expressions"));
/* ELSE : x and y are both atomic or list */
if (LENGTH(x) <= 0 || LENGTH(y) <= 0) {
UNPROTECT(2);
return allocVector(LGLSXP,0);
}
mismatch = FALSE;
xarray = isArray(x);
yarray = isArray(y);
xts = isTs(x);
yts = isTs(y);
if (nx > 0 && ny > 0)
mismatch = ((nx > ny) ? nx % ny : ny % nx) != 0;
if (xarray || yarray) {
if (xarray && yarray) {
if (!conformable(x, y))
errorcall(call, _("non-conformable arrays"));
PROTECT(dims = getAttrib(x, R_DimSymbol));
}
else if (xarray) {
PROTECT(dims = getAttrib(x, R_DimSymbol));
}
else /*(yarray)*/ {
PROTECT(dims = getAttrib(y, R_DimSymbol));
}
PROTECT(xnames = getAttrib(x, R_DimNamesSymbol));
PROTECT(ynames = getAttrib(y, R_DimNamesSymbol));
}
else {
PROTECT(dims = R_NilValue);
PROTECT(xnames = getAttrib(x, R_NamesSymbol));
PROTECT(ynames = getAttrib(y, R_NamesSymbol));
}
if (xts || yts) {
if (xts && yts) {
if (!tsConform(x, y))
errorcall(call, _("non-conformable time series"));
PROTECT(tsp = getAttrib(x, R_TspSymbol));
PROTECT(klass = getAttrib(x, R_ClassSymbol));
}
else if (xts) {
if (length(x) < length(y))
ErrorMessage(call, ERROR_TSVEC_MISMATCH);
PROTECT(tsp = getAttrib(x, R_TspSymbol));
PROTECT(klass = getAttrib(x, R_ClassSymbol));
}
else /*(yts)*/ {
if (length(y) < length(x))
ErrorMessage(call, ERROR_TSVEC_MISMATCH);
PROTECT(tsp = getAttrib(y, R_TspSymbol));
PROTECT(klass = getAttrib(y, R_ClassSymbol));
}
}
if (mismatch)
warningcall(call, _("longer object length is not a multiple of shorter object length"));
if (isString(x) || isString(y)) {
REPROTECT(x = coerceVector(x, STRSXP), xpi);
REPROTECT(y = coerceVector(y, STRSXP), ypi);
x = string_relop((RELOP_TYPE) PRIMVAL(op), x, y);
}
else if (isComplex(x) || isComplex(y)) {
REPROTECT(x = coerceVector(x, CPLXSXP), xpi);
REPROTECT(y = coerceVector(y, CPLXSXP), ypi);
x = complex_relop((RELOP_TYPE) PRIMVAL(op), x, y, call);
}
else if (isReal(x) || isReal(y)) {
REPROTECT(x = coerceVector(x, REALSXP), xpi);
REPROTECT(y = coerceVector(y, REALSXP), ypi);
x = real_relop((RELOP_TYPE) PRIMVAL(op), x, y);
}
else if (isInteger(x) || isInteger(y)) {
REPROTECT(x = coerceVector(x, INTSXP), xpi);
REPROTECT(y = coerceVector(y, INTSXP), ypi);
x = integer_relop((RELOP_TYPE) PRIMVAL(op), x, y);
}
else if (isLogical(x) || isLogical(y)) {
REPROTECT(x = coerceVector(x, LGLSXP), xpi);
REPROTECT(y = coerceVector(y, LGLSXP), ypi);
x = integer_relop((RELOP_TYPE) PRIMVAL(op), x, y);
}
else if (TYPEOF(x) == RAWSXP || TYPEOF(y) == RAWSXP) {
REPROTECT(x = coerceVector(x, RAWSXP), xpi);
REPROTECT(y = coerceVector(y, RAWSXP), ypi);
x = raw_relop((RELOP_TYPE) PRIMVAL(op), x, y);
} else errorcall(call, _("comparison of these types is not implemented"));
PROTECT(x);
if (dims != R_NilValue) {
setAttrib(x, R_DimSymbol, dims);
if (xnames != R_NilValue)
setAttrib(x, R_DimNamesSymbol, xnames);
else if (ynames != R_NilValue)
setAttrib(x, R_DimNamesSymbol, ynames);
}
else {
if (length(x) == length(xnames))
setAttrib(x, R_NamesSymbol, xnames);
else if (length(x) == length(ynames))
setAttrib(x, R_NamesSymbol, ynames);
}
if (xts || yts) {
setAttrib(x, R_TspSymbol, tsp);
setAttrib(x, R_ClassSymbol, klass);
UNPROTECT(2);
}
UNPROTECT(6);
return x;
}
/* D() implements the "derivative table" : */
static SEXP D(SEXP expr, SEXP var)
{
#define PP_S(F,a1,a2) PP(simplify(F,a1,a2))
#define PP_S2(F,a1) PP(simplify(F,a1, R_MissingArg))
SEXP ans = R_NilValue, expr1, expr2;
switch(TYPEOF(expr)) {
case LGLSXP:
case INTSXP:
case REALSXP:
case CPLXSXP:
ans = Constant(0);
break;
case SYMSXP:
if (expr == var) ans = Constant(1.);
else ans = Constant(0.);
break;
case LISTSXP:
if (inherits(expr, "expression")) ans = D(CAR(expr), var);
else ans = Constant(NA_REAL);
break;
case LANGSXP:
if (CAR(expr) == ParenSymbol) {
ans = D(CADR(expr), var);
}
else if (CAR(expr) == PlusSymbol) {
if (length(expr) == 2)
ans = D(CADR(expr), var);
else {
ans = simplify(PlusSymbol,
PP(D(CADR(expr), var)),
PP(D(CADDR(expr), var)));
UNPROTECT(2);
}
}
else if (CAR(expr) == MinusSymbol) {
if (length(expr) == 2) {
ans = simplify(MinusSymbol,
PP(D(CADR(expr), var)),
R_MissingArg);
UNPROTECT(1);
}
else {
ans = simplify(MinusSymbol,
PP(D(CADR(expr), var)),
PP(D(CADDR(expr), var)));
UNPROTECT(2);
}
}
else if (CAR(expr) == TimesSymbol) {
ans = simplify(PlusSymbol,
PP_S(TimesSymbol,PP(D(CADR(expr),var)), CADDR(expr)),
PP_S(TimesSymbol,CADR(expr), PP(D(CADDR(expr),var))));
UNPROTECT(4);
}
else if (CAR(expr) == DivideSymbol) {
PROTECT(expr1 = D(CADR(expr), var));
PROTECT(expr2 = D(CADDR(expr), var));
ans = simplify(MinusSymbol,
PP_S(DivideSymbol, expr1, CADDR(expr)),
PP_S(DivideSymbol,
PP_S(TimesSymbol, CADR(expr), expr2),
PP_S(PowerSymbol,CADDR(expr),PP(Constant(2.)))));
UNPROTECT(7);
}
else if (CAR(expr) == PowerSymbol) {
if (isLogical(CADDR(expr)) || isNumeric(CADDR(expr))) {
ans = simplify(TimesSymbol,
CADDR(expr),
PP_S(TimesSymbol,
PP(D(CADR(expr), var)),
PP_S(PowerSymbol,
CADR(expr),
PP(Constant(asReal(CADDR(expr))-1.)))));
UNPROTECT(4);
}
else {
expr1 = simplify(TimesSymbol,
PP_S(PowerSymbol,
CADR(expr),
PP_S(MinusSymbol,
CADDR(expr),
PP(Constant(1.0)))),
PP_S(TimesSymbol,
CADDR(expr),
PP(D(CADR(expr), var))));
UNPROTECT(5);
PROTECT(expr1);
expr2 = simplify(TimesSymbol,
PP_S(PowerSymbol, CADR(expr), CADDR(expr)),
PP_S(TimesSymbol,
PP_S2(LogSymbol, CADR(expr)),
PP(D(CADDR(expr), var))));
UNPROTECT(4);
PROTECT(expr2);
ans = simplify(PlusSymbol, expr1, expr2);
UNPROTECT(2);
}
}
else if (CAR(expr) == ExpSymbol) {
ans = simplify(TimesSymbol,
expr,
PP(D(CADR(expr), var)));
UNPROTECT(1);
}
else if (CAR(expr) == LogSymbol) {
if (length(expr) != 2)
error("only single-argument calls are supported");
ans = simplify(DivideSymbol,
PP(D(CADR(expr), var)),
CADR(expr));
UNPROTECT(1);
}
else if (CAR(expr) == CosSymbol) {
ans = simplify(TimesSymbol,
PP_S2(SinSymbol, CADR(expr)),
PP_S2(MinusSymbol, PP(D(CADR(expr), var))));
UNPROTECT(3);
}
else if (CAR(expr) == SinSymbol) {
ans = simplify(TimesSymbol,
PP_S2(CosSymbol, CADR(expr)),
PP(D(CADR(expr), var)));
UNPROTECT(2);
}
else if (CAR(expr) == TanSymbol) {
ans = simplify(DivideSymbol,
PP(D(CADR(expr), var)),
PP_S(PowerSymbol,
PP_S2(CosSymbol, CADR(expr)),
PP(Constant(2.0))));
UNPROTECT(4);
}
else if (CAR(expr) == CoshSymbol) {
ans = simplify(TimesSymbol,
PP_S2(SinhSymbol, CADR(expr)),
PP(D(CADR(expr), var)));
UNPROTECT(2);
}
else if (CAR(expr) == SinhSymbol) {
ans = simplify(TimesSymbol,
PP_S2(CoshSymbol, CADR(expr)),
PP(D(CADR(expr), var))),
UNPROTECT(2);
}
else if (CAR(expr) == TanhSymbol) {
ans = simplify(DivideSymbol,
PP(D(CADR(expr), var)),
PP_S(PowerSymbol,
PP_S2(CoshSymbol, CADR(expr)),
PP(Constant(2.0))));
UNPROTECT(4);
}
else if (CAR(expr) == SqrtSymbol) {
PROTECT(expr1 = Rf_lang3(PowerSymbol, CADR(expr), Constant(0.5)));
ans = D(expr1, var);
UNPROTECT(1);
}
else if (CAR(expr) == PnormSymbol) {
ans = simplify(TimesSymbol,
PP_S2(DnormSymbol, CADR(expr)),
PP(D(CADR(expr), var)));
UNPROTECT(2);
}
else if (CAR(expr) == DnormSymbol) {
ans = simplify(TimesSymbol,
PP_S2(MinusSymbol, CADR(expr)),
PP_S(TimesSymbol,
PP_S2(DnormSymbol, CADR(expr)),
PP(D(CADR(expr), var))));
UNPROTECT(4);
}
else if (CAR(expr) == AsinSymbol) {
ans = simplify(DivideSymbol,
PP(D(CADR(expr), var)),
PP_S(SqrtSymbol,
PP_S(MinusSymbol, PP(Constant(1.)),
PP_S(PowerSymbol,CADR(expr),PP(Constant(2.)))),
R_MissingArg));
UNPROTECT(6);
}
else if (CAR(expr) == AcosSymbol) {
ans = simplify(MinusSymbol,
PP_S(DivideSymbol,
PP(D(CADR(expr), var)),
PP_S(SqrtSymbol,
PP_S(MinusSymbol,PP(Constant(1.)),
PP_S(PowerSymbol,
CADR(expr),PP(Constant(2.)))),
R_MissingArg)), R_MissingArg);
UNPROTECT(7);
}
else if (CAR(expr) == AtanSymbol) {
ans = simplify(DivideSymbol,
PP(D(CADR(expr), var)),
PP_S(PlusSymbol,PP(Constant(1.)),
PP_S(PowerSymbol, CADR(expr),PP(Constant(2.)))));
UNPROTECT(5);
}
else if (CAR(expr) == LGammaSymbol) {
ans = simplify(TimesSymbol,
PP(D(CADR(expr), var)),
PP_S2(DiGammaSymbol, CADR(expr)));
UNPROTECT(2);
}
else if (CAR(expr) == GammaSymbol) {
ans = simplify(TimesSymbol,
PP(D(CADR(expr), var)),
PP_S(TimesSymbol,
expr,
PP_S2(DiGammaSymbol, CADR(expr))));
UNPROTECT(3);
}
else if (CAR(expr) == DiGammaSymbol) {
ans = simplify(TimesSymbol,
PP(D(CADR(expr), var)),
PP_S2(TriGammaSymbol, CADR(expr)));
UNPROTECT(2);
}
else if (CAR(expr) == TriGammaSymbol) {
ans = simplify(TimesSymbol,
PP(D(CADR(expr), var)),
PP_S(PsiSymbol, CADR(expr), PP(ScalarInteger(2))));
UNPROTECT(3);
}
else if (CAR(expr) == PsiSymbol) {
if (length(expr) == 2){
ans = simplify(TimesSymbol,
PP(D(CADR(expr), var)),
PP_S(PsiSymbol, CADR(expr), PP(ScalarInteger(1))));
UNPROTECT(3);
} else if (TYPEOF(CADDR(expr)) == INTSXP ||
TYPEOF(CADDR(expr)) == REALSXP) {
ans = simplify(TimesSymbol,
PP(D(CADR(expr), var)),
PP_S(PsiSymbol,
CADR(expr),
PP(ScalarInteger(asInteger(CADDR(expr))+1))));
UNPROTECT(3);
} else {
ans = simplify(TimesSymbol,
PP(D(CADR(expr), var)),
PP_S(PsiSymbol,
CADR(expr),
simplify(PlusSymbol, CADDR(expr),
PP(ScalarInteger(1)))));
UNPROTECT(3);
}
}
else {
SEXP u = deparse1(CAR(expr), 0, SIMPLEDEPARSE);
error(_("Function '%s' is not in the derivatives table"),
translateChar(STRING_ELT(u, 0)));
}
break;
default:
ans = Constant(NA_REAL);
}
return ans;
#undef PP_S
} /* D() */
SEXP do_edit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
int i, rc;
ParseStatus status;
SEXP x, fn, envir, ti, ed, t;
char *filename, *editcmd, *vmaxsave, *cmd;
FILE *fp;
#ifdef Win32
char *title;
#endif
checkArity(op, args);
vmaxsave = vmaxget();
x = CAR(args); args = CDR(args);
if (TYPEOF(x) == CLOSXP) envir = CLOENV(x);
else envir = R_NilValue;
PROTECT(envir);
fn = CAR(args); args = CDR(args);
if (!isString(fn))
error(_("invalid argument to edit()"));
if (LENGTH(STRING_ELT(fn, 0)) > 0) {
filename = R_alloc(strlen(CHAR(STRING_ELT(fn, 0))), sizeof(char));
strcpy(filename, CHAR(STRING_ELT(fn, 0)));
}
else filename = DefaultFileName;
if (x != R_NilValue) {
if((fp=R_fopen(R_ExpandFileName(filename), "w")) == NULL)
errorcall(call, _("unable to open file"));
if (LENGTH(STRING_ELT(fn, 0)) == 0) EdFileUsed++;
if (TYPEOF(x) != CLOSXP || isNull(t = getAttrib(x, R_SourceSymbol)))
t = deparse1(x, 0, FORSOURCING); /* deparse for sourcing, not for display */
for (i = 0; i < LENGTH(t); i++)
fprintf(fp, "%s\n", CHAR(STRING_ELT(t, i)));
fclose(fp);
}
ti = CAR(args); args = CDR(args);
ed = CAR(args);
if (!isString(ed)) errorcall(call, _("argument 'editor' type not valid"));
cmd = CHAR(STRING_ELT(ed, 0));
if (strlen(cmd) == 0) errorcall(call, _("argument 'editor' is not set"));
editcmd = R_alloc(strlen(cmd) + strlen(filename) + 6, sizeof(char));
#ifdef Win32
if (!strcmp(cmd,"internal")) {
if (!isString(ti))
error(_("'title' must be a string"));
if (LENGTH(STRING_ELT(ti, 0)) > 0) {
title = R_alloc(strlen(CHAR(STRING_ELT(ti, 0)))+1, sizeof(char));
strcpy(title, CHAR(STRING_ELT(ti, 0)));
} else {
title = R_alloc(strlen(filename)+1, sizeof(char));
strcpy(title, filename);
}
Rgui_Edit(filename, title, 1);
}
else {
/* Quote path if necessary */
if(cmd[0] != '"' && Rf_strchr(cmd, ' '))
sprintf(editcmd, "\"%s\" \"%s\"", cmd, filename);
else
sprintf(editcmd, "%s \"%s\"", cmd, filename);
rc = runcmd(editcmd, 1, 1, "");
if (rc == NOLAUNCH)
errorcall(call, _("unable to run editor '%s'"), cmd);
if (rc != 0)
warningcall(call, _("editor ran but returned error status"));
}
#else
if (ptr_R_EditFile)
rc = ptr_R_EditFile(filename);
else {
sprintf(editcmd, "%s %s", cmd, filename);
rc = R_system(editcmd);
}
if (rc != 0)
errorcall(call, _("problem with running editor %s"), cmd);
#endif
if((fp = R_fopen(R_ExpandFileName(filename), "r")) == NULL)
errorcall(call, _("unable to open file to read"));
R_ParseCnt = 0;
x = PROTECT(R_ParseFile(fp, -1, &status));
fclose(fp);
if (status != PARSE_OK)
errorcall(call,
_("an error occurred on line %d\n use a command like\n x <- edit()\n to recover"), R_ParseError);
R_ResetConsole();
{ /* can't just eval(x) here */
int j, n;
SEXP tmp = R_NilValue;
n = LENGTH(x);
for (j = 0 ; j < n ; j++)
tmp = eval(VECTOR_ELT(x, j), R_GlobalEnv);
x = tmp;
}
if (TYPEOF(x) == CLOSXP && envir != R_NilValue)
SET_CLOENV(x, envir);
UNPROTECT(2);
vmaxset(vmaxsave);
return (x);
}
