SEXP attribute_hidden do_delayed(SEXP call, SEXP op, SEXP args, SEXP rho) { SEXP name = R_NilValue /* -Wall */, expr, eenv, aenv; checkArity(op, args); if (!isString(CAR(args)) || length(CAR(args)) == 0) error(_("invalid first argument")); else name = installTrChar(STRING_ELT(CAR(args), 0)); args = CDR(args); expr = CAR(args); args = CDR(args); eenv = CAR(args); if (isNull(eenv)) { error(_("use of NULL environment is defunct")); eenv = R_BaseEnv; } else if (!isEnvironment(eenv)) errorcall(call, _("invalid '%s' argument"), "eval.env"); args = CDR(args); aenv = CAR(args); if (isNull(aenv)) { error(_("use of NULL environment is defunct")); aenv = R_BaseEnv; } else if (!isEnvironment(aenv)) errorcall(call, _("invalid '%s' argument"), "assign.env"); defineVar(name, mkPROMISE(expr, eenv), aenv); return R_NilValue; }
/* makeLazy(names, values, expr, eenv, aenv) */ SEXP attribute_hidden do_makelazy(SEXP call, SEXP op, SEXP args, SEXP rho) { SEXP names, values, val, expr, eenv, aenv, expr0; R_xlen_t i; checkArity(op, args); names = CAR(args); args = CDR(args); if (!isString(names)) error(_("invalid first argument")); values = CAR(args); args = CDR(args); expr = CAR(args); args = CDR(args); eenv = CAR(args); args = CDR(args); if (!isEnvironment(eenv)) error(_("invalid '%s' argument"), "eval.env"); aenv = CAR(args); if (!isEnvironment(aenv)) error(_("invalid '%s' argument"), "assign.env"); for(i = 0; i < XLENGTH(names); i++) { SEXP name = installChar(STRING_ELT(names, i)); PROTECT(val = eval(VECTOR_ELT(values, i), eenv)); PROTECT(expr0 = duplicate(expr)); SETCAR(CDR(expr0), val); defineVar(name, mkPROMISE(expr0, eenv), aenv); UNPROTECT(2); } return R_NilValue; }
/* Version of DispatchOrEval for "[" and friends that speeds up simple cases. Also defined in subassign.c */ static R_INLINE int R_DispatchOrEvalSP(SEXP call, SEXP op, const char *generic, SEXP args, SEXP rho, SEXP *ans) { SEXP prom = NULL; if (args != R_NilValue && CAR(args) != R_DotsSymbol) { SEXP x = eval(CAR(args), rho); PROTECT(x); if (! OBJECT(x)) { *ans = CONS_NR(x, evalListKeepMissing(CDR(args), rho)); UNPROTECT(1); return FALSE; } prom = mkPROMISE(CAR(args), R_GlobalEnv); SET_PRVALUE(prom, x); args = CONS(prom, CDR(args)); UNPROTECT(1); } PROTECT(args); int disp = DispatchOrEval(call, op, generic, args, rho, ans, 0, 0); if (prom) DECREMENT_REFCNT(PRVALUE(prom)); UNPROTECT(1); return disp; }