static SEXP listRemove(SEXP x, SEXP s, int ind)
{
std::vector<ConsCell*, Allocator<ConsCell*> > vcc;
// Assemble vector of pointers to list elements:
for (ConsCell* xp = SEXP_downcast<ConsCell*>(x);
xp; xp = xp->tail())
vcc.push_back(xp);
// Null out pointers to unwanted elements:
{
R_xlen_t stretch = 0;
GCStackRoot<> sub(GetOneIndex(s, ind));
GCStackRoot<IntVector>
iv(SEXP_downcast<IntVector*>(makeSubscript(x, sub, &stretch, nullptr)));
size_t ns = iv->size();
for (size_t i = 0; i < ns; ++i) {
int ii = (*iv)[i];
if (ii != NA_INTEGER) vcc[ii-1] = nullptr;
}
}
// Restring the pearls:
{
ConsCell* ans = nullptr;
for (size_t i = vcc.size(); i > 0; --i) {
ConsCell* cc = vcc[i - 1];
if (cc) {
PairList* tail = static_cast<PairList*>(ans);
ans = cc;
ans->setTail(tail);
}
}
return ans;
}
}
void ArgList::wrapInPromises(Environment* env)
{
if (m_status == PROMISED)
Rf_error("Internal error:"
" ArgList already wrapped in Promises");
if (m_status == EVALUATED)
env = 0;
else if (m_first_arg_env && env != m_first_arg_env)
Rf_error("Internal error: first arg of ArgList"
" previously evaluated in different environment");
GCStackRoot<const PairList> oldargs(list());
setList(0);
PairList* lastout = 0;
for (const PairList* inp = oldargs; inp; inp = inp->tail()) {
RObject* rawvalue = inp->car();
if (rawvalue == DotsSymbol) {
Frame::Binding* binding = env->findBinding(DotsSymbol);
if (binding) {
RObject* dval = binding->forcedValue();
if (!dval || dval->sexptype() == DOTSXP) {
ConsCell* dotlist = static_cast<ConsCell*>(dval);
while (dotlist) {
Promise* prom;
if (!m_first_arg_env)
prom = new Promise(dotlist->car(), env);
else {
prom = new Promise(m_first_arg, 0);
m_first_arg = 0;
m_first_arg_env = 0;
}
prom->expose();
const Symbol* tag = tag2Symbol(dotlist->tag());
PairList* cell = PairList::cons(prom, 0, tag);
lastout = append(cell, lastout);
dotlist = dotlist->tail();
}
} else if (dval != Symbol::missingArgument())
Rf_error(_("'...' used in an incorrect context"));
}
} else {
const Symbol* tag = tag2Symbol(inp->tag());
RObject* value = Symbol::missingArgument();
if (m_first_arg_env) {
value = CXXR_NEW(Promise(m_first_arg, 0));
m_first_arg = 0;
m_first_arg_env = 0;
} else if (rawvalue != Symbol::missingArgument())
value = CXXR_NEW(Promise(rawvalue, env));
PairList* cell = PairList::cons(value, 0, tag);
lastout = append(cell, lastout);
}
}
m_status = PROMISED;
}
void ArgList::evaluate(Environment* env, bool allow_missing)
{
if (m_status == EVALUATED)
Rf_error("Internal error: ArgList already evaluated");
if (m_first_arg_env && env != m_first_arg_env)
Rf_error("Internal error: first arg of ArgList"
" previously evaluated in different environment");
GCStackRoot<const PairList> oldargs(list());
setList(0);
PairList* lastout = 0;
unsigned int arg_number = 1;
for (const PairList* inp = oldargs; inp; inp = inp->tail()) {
RObject* incar = inp->car();
if (incar == DotsSymbol) {
Frame::Binding* bdg = env->findBinding(CXXR::DotsSymbol);
if (!bdg)
Rf_error(_("'...' used but not bound"));
RObject* h = bdg->forcedValue();
if (!h || h->sexptype() == DOTSXP) {
ConsCell* dotlist = static_cast<DottedArgs*>(h);
while (dotlist) {
RObject* dotcar = dotlist->car();
RObject* outcar = Symbol::missingArgument();
if (m_first_arg_env) {
outcar = m_first_arg;
m_first_arg = 0;
m_first_arg_env = 0;
} else if (dotcar != Symbol::missingArgument())
outcar = Evaluator::evaluate(dotcar, env);
PairList* cell = PairList::cons(outcar, 0, dotlist->tag());
lastout = append(cell, lastout);
dotlist = dotlist->tail();
}
} else if (h != Symbol::missingArgument())
Rf_error(_("'...' used in an incorrect context"));
} else {
const RObject* tag = inp->tag();
PairList* cell = 0;
if (m_first_arg_env) {
cell = PairList::cons(m_first_arg, 0, tag);
m_first_arg = 0;
m_first_arg_env = 0;
} else if (incar && incar->sexptype() == SYMSXP) {
Symbol* sym = static_cast<Symbol*>(incar);
if (sym == Symbol::missingArgument()) {
if (allow_missing)
cell = PairList::cons(Symbol::missingArgument(), 0, tag);
else Rf_error(_("argument %d is empty"), arg_number);
} else if (isMissingArgument(sym, env->frame())) {
if (allow_missing)
cell = PairList::cons(Symbol::missingArgument(), 0, tag);
else Rf_error(_("'%s' is missing"),
sym->name()->c_str());
}
}
if (!cell) {
RObject* outcar = Evaluator::evaluate(incar, env);
cell = PairList::cons(outcar, 0, inp->tag());
}
lastout = append(cell, lastout);
}
++arg_number;
}
m_status = EVALUATED;
}