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