SEXP attribute_hidden do_args(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP s;
checkArity(op,args);
if (TYPEOF(CAR(args)) == STRSXP && length(CAR(args))==1) {
PROTECT(s = installTrChar(STRING_ELT(CAR(args), 0)));
SETCAR(args, findFun(s, rho));
UNPROTECT(1);
}
if (TYPEOF(CAR(args)) == CLOSXP) {
s = allocSExp(CLOSXP);
SET_FORMALS(s, FORMALS(CAR(args)));
SET_BODY(s, R_NilValue);
SET_CLOENV(s, R_GlobalEnv);
return s;
}
if (TYPEOF(CAR(args)) == BUILTINSXP || TYPEOF(CAR(args)) == SPECIALSXP) {
char *nm = PRIMNAME(CAR(args));
SEXP env, s2;
PROTECT_INDEX xp;
PROTECT_WITH_INDEX(env = findVarInFrame3(R_BaseEnv,
install(".ArgsEnv"), TRUE),
&xp);
if (TYPEOF(env) == PROMSXP) REPROTECT(env = eval(env, R_BaseEnv), xp);
PROTECT(s2 = findVarInFrame3(env, install(nm), TRUE));
if(s2 != R_UnboundValue) {
s = duplicate(s2);
SET_CLOENV(s, R_GlobalEnv);
UNPROTECT(2);
return s;
}
UNPROTECT(1); /* s2 */
REPROTECT(env = findVarInFrame3(R_BaseEnv, install(".GenericArgsEnv"),
TRUE), xp);
if (TYPEOF(env) == PROMSXP) REPROTECT(env = eval(env, R_BaseEnv), xp);
PROTECT(s2 = findVarInFrame3(env, install(nm), TRUE));
if(s2 != R_UnboundValue) {
s = allocSExp(CLOSXP);
SET_FORMALS(s, FORMALS(s2));
SET_BODY(s, R_NilValue);
SET_CLOENV(s, R_GlobalEnv);
UNPROTECT(2);
return s;
}
UNPROTECT(2);
}
return R_NilValue;
}
SEXP SmokeObject::enclose(SEXP fun) {
SEXP dupFun;
PROTECT(dupFun = duplicate(fun));
SET_CLOENV(dupFun, internalSexp(CLOENV(fun)));
UNPROTECT(1);
return dupFun;
}
SEXP subset_R8(SEXP x, SEXP name) {
// Look in x (an environment) for the object
SEXP nameSym = Rf_install(CHAR(STRING_ELT(name, 0)));
SEXP foundVar = Rf_findVarInFrame(x, nameSym);
if (foundVar != R_UnboundValue) {
return foundVar;
}
// if not found in x, look in methods
SEXP fun = get_function_from_env_attrib(x, Rf_install("methods"), nameSym);
// If not found in methods, search in methods2. This is present only for
// storing private methods in a superclass.
if (!isFunction(fun)) {
fun = get_function_from_env_attrib(x, Rf_install("methods2"), nameSym);
}
if (!isFunction(fun)) {
return R_NilValue;
}
// Make a copy of the function, with a new environment
SEXP fun2 = PROTECT(duplicate(fun));
SEXP eval_env = Rf_getAttrib(x, Rf_install("eval_env"));
if (!isEnvironment(eval_env)) {
UNPROTECT(1);
return R_NilValue;
}
SET_CLOENV(fun2, eval_env);
UNPROTECT(1);
return fun2;
}
SEXP attribute_hidden do_envirgets(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP env, s = CAR(args);
checkArity(op, args);
check1arg(args, call, "x");
env = CADR(args);
if (TYPEOF(CAR(args)) == CLOSXP
&& (isEnvironment(env) ||
isEnvironment(env = simple_as_environment(env)) ||
isNull(env))) {
if (isNull(env))
error(_("use of NULL environment is defunct"));
if(MAYBE_SHARED(s))
/* this copies but does not duplicate args or code */
s = duplicate(s);
if (TYPEOF(BODY(s)) == BCODESXP)
/* switch to interpreted version if compiled */
SET_BODY(s, R_ClosureExpr(CAR(args)));
SET_CLOENV(s, env);
}
else if (isNull(env) || isEnvironment(env) ||
isEnvironment(env = simple_as_environment(env)))
setAttrib(s, R_DotEnvSymbol, env);
else
error(_("replacement object is not an environment"));
return s;
}
SEXP reassign_function(SEXP name, SEXP env, SEXP old_fun, SEXP new_fun)
{
if (TYPEOF(name) != SYMSXP) error("name must be a symbol");
if (TYPEOF(env) != ENVSXP) error("env must be an environment");
if (TYPEOF(old_fun) != CLOSXP) error("old_fun must be a function");
if (TYPEOF(new_fun) != CLOSXP) error("new_fun must be a function");
SET_FORMALS(old_fun, FORMALS(new_fun));
SET_BODY(old_fun, BODY(new_fun));
SET_CLOENV(old_fun, CLOENV(new_fun));
DUPLICATE_ATTRIB(old_fun, new_fun);
return R_NilValue;
}
SEXP attribute_hidden mkCLOSXP(SEXP formals, SEXP body, SEXP rho)
{
SEXP c;
PROTECT(formals);
PROTECT(body);
PROTECT(rho);
c = allocSExp(CLOSXP);
#ifdef not_used_CheckFormals
if(isList(formals))
SET_FORMALS(c, formals);
else
error(_("invalid formal arguments for 'function'"));
#else
SET_FORMALS(c, formals);
#endif
switch (TYPEOF(body)) {
case CLOSXP:
case BUILTINSXP:
case SPECIALSXP:
case DOTSXP:
case ANYSXP:
error(_("invalid body argument for 'function'"));
break;
default:
SET_BODY(c, body);
break;
}
if(rho == R_NilValue)
SET_CLOENV(c, R_GlobalEnv);
else
SET_CLOENV(c, rho);
UNPROTECT(3);
return c;
}
SEXP InstanceObjectTable::methodClosure(const char *name) const {
static SEXP qtbaseNS = R_FindNamespace(mkString("qtbase"));
static SEXP qinvokeSym = install("qinvoke");
SEXP f, pf, body;
PROTECT(f = allocSExp(CLOSXP));
SET_CLOENV(f, qtbaseNS);
pf = allocList(1);
SET_FORMALS(f, pf);
SET_TAG(pf, R_DotsSymbol);
SETCAR(pf, R_MissingArg);
PROTECT(body =
lang4(qinvokeSym, _instance->sexp(), mkString(name), R_DotsSymbol));
SET_BODY(f, body);
UNPROTECT(2);
return f;
}
SEXP make_closure(SEXP body, SEXP formal_parameter_list, SEXP envir) {
SEXP closure, formals;
PROTECT(closure = allocSExp(CLOSXP));
SET_CLOENV(closure, envir);
const int number_of_formals = length(formal_parameter_list);
PROTECT(formals = allocList(number_of_formals));
SEXP formals_iterator = formals;
for (int i = 0; i < number_of_formals; i++, formals_iterator = CDR(formals_iterator)) {
SEXP formal = STRING_ELT(VECTOR_ELT(formal_parameter_list, i), 0);
SET_TAG(formals_iterator, CreateTag(formal));
SETCAR(formals_iterator, R_MissingArg);
}
SET_FORMALS(closure, formals);
SET_BODY(closure, body);
UNPROTECT(2);
return closure;
}
SEXP exprToFunction(int nVariables, const char **vaList, SEXP rExpr) {
PROTECT(rExpr);
SEXP charList, rChar, pl;
SEXP rFunc;
PROTECT(rFunc= allocSExp(CLOSXP));
SET_CLOENV(rFunc, R_GlobalEnv);
int i = 0, warn= 0, n= 0;
if(nVariables > 0) {
PROTECT(charList = allocVector(STRSXP, nVariables));
for(int i=0; i < nVariables; i++){ //TODO STRSXP fill
PROTECT(rChar= mkChar(vaList[i]));
SET_STRING_ELT(charList, i, rChar);
UNPROTECT(1);
}
PROTECT(charList= VectorToPairList(charList));
n= length(charList);
if(n > 0) {
PROTECT(pl = allocList(n));
if(n == 1) {
SET_TAG(pl, CreateTag(CAR(charList)));
SETCAR(pl, R_MissingArg);
}
else
{ SET_TAG(pl, CreateTag(CAR(charList)));
SETCAR(pl, R_MissingArg);
SEXP nextpl= CDR(pl);
SEXP nextChar= CDR(charList);
for (i= 1; i < n; i++, nextpl = CDR(nextpl), nextChar = CDR(nextChar)) {
SET_TAG(nextpl, CreateTag(CAR(nextChar)));
SETCAR(nextpl, R_MissingArg);
}
}
} }
SET_FORMALS(rFunc, pl);
SET_BODY(rFunc, rExpr);
//setAttrib(rFunc, R_SourceSymbol, eval(lang2(install("deparse"), rFunc), R_BaseEnv)); // TODO: Deparse not necessary
if(n > 0) {UNPROTECT(1);}
UNPROTECT(4);
return rFunc;
}
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;
}
static SEXP duplicate1(SEXP s, Rboolean deep)
{
SEXP t;
R_xlen_t i, n;
duplicate1_elts++;
duplicate_elts++;
switch (TYPEOF(s)) {
case NILSXP:
case SYMSXP:
case ENVSXP:
case SPECIALSXP:
case BUILTINSXP:
case EXTPTRSXP:
case BCODESXP:
case WEAKREFSXP:
return s;
case CLOSXP:
PROTECT(s);
PROTECT(t = allocSExp(CLOSXP));
SET_FORMALS(t, FORMALS(s));
SET_BODY(t, BODY(s));
SET_CLOENV(t, CLOENV(s));
DUPLICATE_ATTRIB(t, s, deep);
if (NOJIT(s)) SET_NOJIT(t);
if (MAYBEJIT(s)) SET_MAYBEJIT(t);
UNPROTECT(2);
break;
case LISTSXP:
PROTECT(s);
t = duplicate_list(s, deep);
UNPROTECT(1);
break;
case LANGSXP:
PROTECT(s);
PROTECT(t = duplicate_list(s, deep));
SET_TYPEOF(t, LANGSXP);
DUPLICATE_ATTRIB(t, s, deep);
UNPROTECT(2);
break;
case DOTSXP:
PROTECT(s);
PROTECT(t = duplicate_list(s, deep));
SET_TYPEOF(t, DOTSXP);
DUPLICATE_ATTRIB(t, s, deep);
UNPROTECT(2);
break;
case CHARSXP:
return s;
break;
case EXPRSXP:
case VECSXP:
n = XLENGTH(s);
PROTECT(s);
PROTECT(t = allocVector(TYPEOF(s), n));
for(i = 0 ; i < n ; i++)
SET_VECTOR_ELT(t, i, duplicate_child(VECTOR_ELT(s, i), deep));
DUPLICATE_ATTRIB(t, s, deep);
COPY_TRUELENGTH(t, s);
UNPROTECT(2);
break;
case LGLSXP: DUPLICATE_ATOMIC_VECTOR(int, LOGICAL, t, s, deep); break;
case INTSXP: DUPLICATE_ATOMIC_VECTOR(int, INTEGER, t, s, deep); break;
case REALSXP: DUPLICATE_ATOMIC_VECTOR(double, REAL, t, s, deep); break;
case CPLXSXP: DUPLICATE_ATOMIC_VECTOR(Rcomplex, COMPLEX, t, s, deep); break;
case RAWSXP: DUPLICATE_ATOMIC_VECTOR(Rbyte, RAW, t, s, deep); break;
case STRSXP:
/* direct copying and bypassing the write barrier is OK since
t was just allocated and so it cannot be older than any of
the elements in s. LT */
DUPLICATE_ATOMIC_VECTOR(SEXP, STRING_PTR, t, s, deep);
break;
case PROMSXP:
return s;
break;
case S4SXP:
PROTECT(s);
PROTECT(t = allocS4Object());
DUPLICATE_ATTRIB(t, s, deep);
UNPROTECT(2);
break;
default:
UNIMPLEMENTED_TYPE("duplicate", s);
t = s;/* for -Wall */
}
if(TYPEOF(t) == TYPEOF(s) ) { /* surely it only makes sense in this case*/
SET_OBJECT(t, OBJECT(s));
(IS_S4_OBJECT(s) ? SET_S4_OBJECT(t) : UNSET_S4_OBJECT(t));
}
return t;
}
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);
}
