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