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); }