Пример #1
0
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;
    }
}
Пример #2
0
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;
}
Пример #3
0
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;
}