Exemplo n.º 1
0
RObject* RObject::getAttribute(const Symbol* name) const
{
    for (PairList* node = m_attrib; node; node = node->tail())
	if (node->tag() == name)
	    return node->car();
    return 0;
}
Exemplo n.º 2
0
void ArgList::merge(const ConsCell* extraargs)
{
    if (m_status != PROMISED)
	Rf_error("Internal error: ArgList::merge() requires PROMISED ArgList");
    // Convert extraargs into a doubly linked list:
    typedef std::list<pair<const RObject*, RObject*> > Xargs;
    Xargs xargs;
    for (const ConsCell* cc = extraargs; cc; cc = cc->tail())
	xargs.push_back(make_pair(cc->tag(), cc->car()));
    // Apply overriding arg values supplied in extraargs:
    PairList* last = 0;
    for (PairList* pl = mutable_list(); pl; pl = pl->tail()) {
	last = pl;
	const RObject* tag = pl->tag();
	if (tag) {
	    Xargs::iterator it = xargs.begin();
	    while (it != xargs.end() && (*it).first != tag)
		++it;
	    if (it != xargs.end()) {
		pl->setCar((*it).second);
		xargs.erase(it);
	    }
	}
    }
    // Append remaining extraargs:
    for (Xargs::const_iterator it = xargs.begin(); it != xargs.end(); ++it) {
	PairList* cell = PairList::cons((*it).second, 0, (*it).first);
	last = append(cell, last);
    }
}
Exemplo n.º 3
0
int main()
{
   Reader reader;

   /// Если одна большая плитка стоит больше чем две маленькие, то можно ничего не искать
   if( reader.A() > reader.B()*2 )
   {
      std::cout << ( reader.Stars()*reader.B() );
      return 0;
   }

   TableType adj;

   /// заполняем данными из входного файла
   reader.DoFill(adj);

   /// представляем итые клетки в виде двудольного графа
   /// представляем паркет в виде шахматной доски, черные в одной доле, белые в другой
   /// ищем максимум паросочетаний
   PairList pairs;
   FindPairs( reader.VCount(), reader.UCount(), adj, pairs );

   /// считаем найденные пары
   int count = std::count_if( pairs.begin(), pairs.end(), Compare() );
   
   std::cout << count*reader.A() + ( reader.Stars() - count*2 )*reader.B();

   return 0;
}
Exemplo n.º 4
0
Pair *ConstantPool::m_read_list(IInStream &s)
{
    PairList list;
    unsigned count = read_chain_uint(s);
    for (unsigned i = 0; i < count; i++)
        list.add(constant(read_chain_uint(s)));
    return list.list;
}
Exemplo n.º 5
0
// This follows CR in adding new attributes at the end of the list,
// though it would be easier to add them at the beginning.
void RObject::setAttribute(const Symbol* name, RObject* value)
{
    if (!name)
	Rf_error(_("attributes must be named"));
    // Update 'has class' bit if necessary:
    if (name == R_ClassSymbol) {
	if (value == 0)
	    m_type &= static_cast<signed char>(~s_class_mask);
	else m_type |= static_cast<signed char>(s_class_mask);
    }
    // Find attribute:
    PairList* prev = 0;
    PairList* node = m_attrib;
    while (node && node->tag() != name) {
	prev = node;
	node = node->tail();
    }
    if (node) {  // Attribute already present
	// Update existing attribute:
	if (value)
	    node->setCar(value);
	// Delete existing attribute:
	else if (prev)
	    prev->setTail(node->tail());
	else m_attrib = node->tail();
    } else if (value) {  
	// Create new node:
	PairList* newnode = PairList::cons(value, 0, name);
	if (prev)
	    prev->setTail(newnode);
	else { // No preexisting attributes at all:
	    m_attrib = newnode;
	}
    }
}
Exemplo n.º 6
0
void Transformed::divideTools(const std::vector<TopoDS_Shape> &toolsIn, std::vector<TopoDS_Shape> &individualsOut,
                              TopoDS_Compound &compoundOut) const
{
  typedef std::pair<TopoDS_Shape, Bnd_Box> ShapeBoundPair;
  typedef std::list<ShapeBoundPair> PairList;
  typedef std::vector<ShapeBoundPair> PairVector;
  
  PairList pairList;
  
  std::vector<TopoDS_Shape>::const_iterator it;
  for (it = toolsIn.begin(); it != toolsIn.end(); ++it)
  {
    Bnd_Box bound;
    BRepBndLib::Add(*it, bound);
    bound.SetGap(0.0);
    ShapeBoundPair temp = std::make_pair(*it, bound);
    pairList.push_back(temp);
  }
  
  BRep_Builder builder;
  builder.MakeCompound(compoundOut);
  
  while(!pairList.empty())
  {
    PairVector currentGroup;
    currentGroup.push_back(pairList.front());
    pairList.pop_front();
    PairList::iterator it = pairList.begin();
    while(it != pairList.end())
    {
      PairVector::const_iterator groupIt;
      bool found(false);
      for (groupIt = currentGroup.begin(); groupIt != currentGroup.end(); ++groupIt)
      {
	if (!(*it).second.IsOut((*groupIt).second))//touching means is out.
	{
	  found = true;
	  break;
	}
      }
      if (found)
      {
	currentGroup.push_back(*it);
	pairList.erase(it);
	it=pairList.begin();
	continue;
      }
      it++;
    }
    if (currentGroup.size() == 1)
      builder.Add(compoundOut, currentGroup.front().first);
    else
    {
      PairVector::const_iterator groupIt;
      for (groupIt = currentGroup.begin(); groupIt != currentGroup.end(); ++groupIt)
	individualsOut.push_back((*groupIt).first);
    }
  }
}
Exemplo n.º 7
0
void DomUtil::writePairListEntry(QDomDocument &doc, const QString &path, const QString &tag,
                                 const QString &firstAttr, const QString &secondAttr,
                                 const PairList &value)
{
    QDomElement el = createElementByPath(doc, path);

    PairList::ConstIterator it;
    for (it = value.begin(); it != value.end(); ++it) {
        QDomElement subEl = doc.createElement(tag);
        subEl.setAttribute(firstAttr, (*it).first);
        subEl.setAttribute(secondAttr, (*it).second);
        el.appendChild(subEl);
    }
}
Exemplo n.º 8
0
int main(int argc, char* argv[]) {
    Evaluator evalr;
    if (argc < 3 || argc > 4)
	usage(argv[0]);
    // Set up error reporting:
    ptr_R_WriteConsoleEx = WriteConsoleEx;
    ptr_R_ResetConsole = ptr_R_FlushConsole = 
        ptr_R_ClearerrConsole = DoNothing;
    Rf_InitOptions();
    // Set up Environments:
    GCStackRoot<Frame> ff(CXXR_NEW(ListFrame));
    GCStackRoot<Environment> fenvrt(CXXR_NEW(Environment(0, ff)));
    fenv = fenvrt;
    // Process formals:
    cout << "Formal arguments:\n\n";
    GCStackRoot<PairList> formals(getArgs(argv[1]));
    GCStackRoot<ArgMatcher> matcher;
    try {
    	matcher = GCNode::expose(new ArgMatcher(formals));
    } catch (CommandTerminated) {
	cerr << "ArgMatchertest: Error encountered while processing formals" << endl;
	return 0;
    }
    // Process supplied arguments:
    cout << "\nSupplied arguments:\n\n";
    ArgList supplied(getArgs(argv[2]), ArgList::RAW);
    // Set up frame and prior bindings (if any):
    Frame* frame = fenv->frame();
    if (argc == 4) {
	cout << "\nPrior bindings:\n\n";
	GCStackRoot<PairList> prior_bindings(getArgs(argv[3]));
	for (PairList* pb = prior_bindings; pb; pb = pb->tail()) {
	    const Symbol* tag = static_cast<const Symbol*>(pb->tag());
	    Frame::Binding* bdg = frame->obtainBinding(tag);
	    bdg->setValue(pb->car(), Frame::Binding::EXPLICIT);
	}
    }
    // Perform match and show result:
    try {
	matcher->match(fenv, &supplied);
    } catch (CommandTerminated) {
    	cerr << "ArgMatchertest: Error encountered while matching arguments" << endl;
	return 0;
    }
    cout << "\nMatch result:\n\n";
    showFrame(frame);
    return 0;
}
Exemplo n.º 9
0
static int SubAssignArgs(PairList* args, SEXP *x, PairList** s, SEXP *y)
{
    if (CDR(args) == R_NilValue)
	Rf_error(_("SubAssignArgs: invalid number of arguments"));
    *x = args->car();
    if(CDDR(args) == R_NilValue) {
	*s = nullptr;
	*y = args->tail()->car();
	return 0;
    }
    else {
	int nsubs = 1;
	PairList* p = args->tail();
	*s = p;
	PairList* ptail = p->tail();
	while (ptail->tail()) {
	    p = ptail;
	    ptail = p->tail();
	    nsubs++;
	}
	*y = ptail->car();
	p->setTail(nullptr);
	return nsubs;
    }
}
Exemplo n.º 10
0
void FindPairs( int n, int m, TableType const& adj, PairList& pairs )
{
   pairs.assign( m, - 1 );
   std::vector< char > is;

   for( int i = 0; i < n; ++i )
   {
      is.assign( n, false );
      DFS( i, adj, is, pairs );
   }
}
void DatabaseCommand_TrackAttributes::exec( DatabaseImpl* lib )
{
    TomahawkSqlQuery query = lib->newquery();

    QString k;
    switch ( m_type )
    {
        case DatabaseCommand_SetTrackAttributes::EchonestCatalogId:
            k = "echonestcatalogid";
            break;
    }

    PairList results;
    if ( !m_ids.isEmpty() )
    {
        foreach ( const QID id, m_ids )
        {
            query.prepare( "SELECT v FROM track_attributes WHERE id = ? AND k = ?" );
            query.bindValue( 0, id );
            query.bindValue( 1, k );
            if ( query.exec() )
                results.append( QPair< QID, QString >( id, query.value( 0 ).toString() ) );
        }
Exemplo n.º 12
0
void CURRENT_CLASS::computeCameraPairs()
{
    // Nothing in the scene, so no cameras needed
    if(_distancePairs.empty())
        return;

    // Entire scene can be handled by just one camera
    if(_limits.first >= _limits.second * _nearFarRatio)
    {
        _cameraPairs.push_back(_limits);
        return;
    }

    PairList::iterator i, j;

    // Sort the list of distance pairs by descending far distance
    std::sort(_distancePairs.begin(),_distancePairs.end(),precedes);

    // Combine overlapping distance pairs. The resulting set of distance
    // pairs (called combined pairs) will not overlap.
    PairList combinedPairs;
    DistancePair currPair = _distancePairs.front();
    for(i = _distancePairs.begin(); i != _distancePairs.end(); ++i)
    {
        // Current distance pair does not overlap current combined pair, so
        // save the current combined pair and start a new one.
        if(i->second < 0.99 * currPair.first)
        {
            combinedPairs.push_back(currPair);
            currPair = *i;
        }

        // Current distance pair overlaps current combined pair, so expand
        // current combined pair to encompass distance pair.
        else
            currPair.first = std::min(i->first,currPair.first);
    }
    combinedPairs.push_back(currPair); // Add last pair

    // Compute the (near,far) distance pairs for each camera.
    // Each of these distance pairs is called a "view segment".
    double currNearLimit, numSegs, new_ratio;
    double ratio_invlog = 1.0 / log(_nearFarRatio);
    unsigned int temp;
    for(i = combinedPairs.begin(); i != combinedPairs.end(); ++i)
    {
        currPair = *i; // Save current view segment

        // Compute the fractional number of view segments needed to span
        // the current combined distance pair.
        currNearLimit = currPair.second * _nearFarRatio;
        if(currPair.first >= currNearLimit)
            numSegs = 1.0;
        else
        {
            numSegs = log(currPair.first / currPair.second) * ratio_invlog;

            // Compute the near plane of the last view segment
            //currNearLimit *= pow(_nearFarRatio, -floor(-numSegs) - 1);
            for(temp = (unsigned int)(-floor(-numSegs)); temp > 1; temp--)
            {
                currNearLimit *= _nearFarRatio;
            }
        }

        // See if the closest view segment can absorb other combined pairs
        for(j = i + 1; j != combinedPairs.end(); ++j)
        {
            // No other distance pairs can be included
            if(j->first < currNearLimit)
                break;
        }

        // If we did absorb another combined distance pair, recompute the
        // number of required view segments.
        if(i != j - 1)
        {
            i = j - 1;
            currPair.first = i->first;
            if(currPair.first >= currPair.second * _nearFarRatio)
                numSegs = 1.0;
            else
                numSegs = log(currPair.first / currPair.second) * ratio_invlog;
        }

        /* Compute an integer number of segments by rounding the fractional
         number of segments according to how many segments there are.
         In general, the more segments there are, the more likely that the 
         integer number of segments will be rounded down.
         The purpose of this is to try to minimize the number of view segments
         that are used to render any section of the scene without violating
         the specified _nearFarRatio by too much. */
        if(numSegs < 10.0)
            numSegs = floor(numSegs + 1.0 - 0.1 * floor(numSegs));
        else
            numSegs = floor(numSegs);

        // Compute the near/far ratio that will be used for each view segment
        // in this section of the scene.
        new_ratio = pow(currPair.first / currPair.second,1.0 / numSegs);

        // Add numSegs new view segments to the camera pairs list
        for(temp = (unsigned int)numSegs; temp > 0; temp--)
        {
            currPair.first = currPair.second * new_ratio;
            _cameraPairs.push_back(currPair);
            currPair.second = currPair.first;
        }
    }
}
Exemplo n.º 13
0
void ArgList::stripTags()
{
    for (PairList* p = mutable_list(); p; p = p->tail())
	p->setTag(0);
}
Exemplo n.º 14
0
SEXP attribute_hidden
do_subassign2_dflt(SEXP call, SEXP op, SEXP argsarg, SEXP rho)
{
    PairList* args = SEXP_downcast<PairList*>(argsarg);
    SEXP dims, indx, names, newname, x, xtop, xup, y, thesub = R_NilValue, xOrig = R_NilValue;
    int i, ndims, nsubs, which, len = 0 /* -Wall */;
    R_xlen_t  stretch, offset, off = -1; /* -Wall */
    Rboolean S4, recursed=FALSE;

    PROTECT(args);

    PairList* subs;
    nsubs = SubAssignArgs(args, &x, &subs, &y);
    S4 = CXXRCONSTRUCT(Rboolean, IS_S4_OBJECT(x));

    /* Handle NULL left-hand sides.  If the right-hand side */
    /* is NULL, just return the left-hand size otherwise, */
    /* convert to a zero length list (VECSXP). */

    if (isNull(x)) {
	if (isNull(y)) {
	    UNPROTECT(1);
	    return x;
	}
	if (Rf_length(y) == 1)
	    SETCAR(args, x = allocVector(TYPEOF(y), 0));
	else
	    SETCAR(args, x = allocVector(VECSXP, 0));
    }

    /* Ensure that the LHS is a local variable. */
    /* If it is not, then make a local copy. */

    if (MAYBE_SHARED(x)) {
	x = shallow_duplicate(x);
	SETCAR(args, x);
    }

    xtop = xup = x; /* x will be the element which is assigned to */

    dims = getAttrib(x, R_DimSymbol);
    ndims = Rf_length(dims);

    /* code to allow classes to extend ENVSXP */
    if(TYPEOF(x) == S4SXP) {
	xOrig = x; /* will be an S4 object */
        x = R_getS4DataSlot(x, ANYSXP);
	if(TYPEOF(x) != ENVSXP)
	  errorcall(call, _("[[<- defined for objects of type \"S4\" only for subclasses of environment"));
    }

    /* ENVSXP special case first */
    if( TYPEOF(x) == ENVSXP) {
	if( nsubs!=1 || !isString(CAR(subs)) || Rf_length(CAR(subs)) != 1 )
	    error(_("wrong args for environment subassignment"));
	defineVar(installTrChar(STRING_ELT(CAR(subs), 0)), y, x);
	UNPROTECT(1);
	return(S4 ? xOrig : x);
    }

    /* new case in 1.7.0, one vector index for a list,
       more general as of 2.10.0 */
    if (nsubs == 1) {
	thesub = CAR(subs);
	len = Rf_length(thesub); /* depth of recursion, small */
	if (len > 1) {
	    xup = vectorIndex(x, thesub, 0, len-2, /*partial ok*/TRUE, call,
			      TRUE);
	    /* OneIndex sets newname, but it will be overwritten before being used. */
	    off = OneIndex(xup, thesub, xlength(xup), 0, &newname, len-2, R_NilValue);
	    x = vectorIndex(xup, thesub, len-2, len-1, TRUE, call, TRUE);
	    recursed = TRUE;
	}
    }

    stretch = 0;
    if (isVector(x)) {
	if (!isVectorList(x) && LENGTH(y) == 0)
	    error(_("replacement has length zero"));
	if (!isVectorList(x) && LENGTH(y) > 1)
	    error(_("more elements supplied than there are to replace"));
	if (nsubs == 0 || CAR(subs) == R_MissingArg)
	    error(_("[[ ]] with missing subscript"));
	if (nsubs == 1) {
	    offset = OneIndex(x, thesub, Rf_length(x), 0, &newname,
			      recursed ? len-1 : -1, R_NilValue);
	    if (isVectorList(x) && isNull(y)) {
		x = DeleteOneVectorListItem(x, offset);
		if(recursed) {
		    if(isVectorList(xup)) SET_VECTOR_ELT(xup, off, x);
		    else xup = SimpleListAssign(call, xup, subs, x, len-2);
		}
		else xtop = x;
		UNPROTECT(1);
		return xtop;
	    }
	    if (offset < 0)
		error(_("[[ ]] subscript out of bounds"));
	    if (offset >= XLENGTH(x))
		stretch = offset + 1;
	}
	else {
	    if (ndims != nsubs)
		error(_("[[ ]] improper number of subscripts"));
	    PROTECT(indx = allocVector(INTSXP, ndims));
	    names = getAttrib(x, R_DimNamesSymbol);
	    for (i = 0; i < ndims; i++) {
		INTEGER(indx)[i] = int(
		    get1index(CAR(subs), isNull(names) ?
			      R_NilValue : VECTOR_ELT(names, i),
			      INTEGER(dims)[i],
			      /*partial ok*/FALSE, -1, call));
		subs = subs->tail();
		if (INTEGER(indx)[i] < 0 ||
		    INTEGER(indx)[i] >= INTEGER(dims)[i])
		    error(_("[[ ]] subscript out of bounds"));
	    }
	    offset = 0;
	    for (i = (ndims - 1); i > 0; i--)
		offset = (offset + INTEGER(indx)[i]) * INTEGER(dims)[i - 1];
	    offset += INTEGER(indx)[0];
	    UNPROTECT(1);
	}

	which = SubassignTypeFix(&x, &y, 2, call);
	if (stretch) {
	    PROTECT(x);
	    PROTECT(y);
	    x = EnlargeVector(x, stretch);
	    UNPROTECT(2);
	}
	PROTECT(x);

	switch (which) {
	    /* as from 2.3.0 'which' is after conversion */

	case 1010:	/* logical   <- logical	  */
	case 1310:	/* integer   <- logical	  */
	/* case 1013:	   logical   <- integer	  */
	case 1313:	/* integer   <- integer	  */

	    INTEGER(x)[offset] = INTEGER(y)[0];
	    break;

	case 1410:	/* real	     <- logical	  */
	case 1413:	/* real	     <- integer	  */

	    if (INTEGER(y)[0] == NA_INTEGER)
		REAL(x)[offset] = NA_REAL;
	    else
		REAL(x)[offset] = INTEGER(y)[0];
	    break;
	/* case 1014:	   logical   <- real	  */
	/* case 1314:	   integer   <- real	  */
	case 1414:	/* real	     <- real	  */

	    REAL(x)[offset] = REAL(y)[0];
	    break;

	case 1510:	/* complex   <- logical	  */
	case 1513:	/* complex   <- integer	  */

	    if (INTEGER(y)[0] == NA_INTEGER) {
		COMPLEX(x)[offset].r = NA_REAL;
		COMPLEX(x)[offset].i = NA_REAL;
	    }
	    else {
		COMPLEX(x)[offset].r = INTEGER(y)[0];
		COMPLEX(x)[offset].i = 0.0;
	    }
	    break;

	case 1514:	/* complex   <- real	  */

	    if (ISNA(REAL(y)[0])) {
		COMPLEX(x)[offset].r = NA_REAL;
		COMPLEX(x)[offset].i = NA_REAL;
	    }
	    else {
		COMPLEX(x)[offset].r = REAL(y)[0];
		COMPLEX(x)[offset].i = 0.0;
	    }
	    break;

	/* case 1015:	   logical   <- complex	  */
	/* case 1315:	   integer   <- complex	  */
	/* case 1415:	   real	     <- complex	  */
	case 1515:	/* complex   <- complex	  */

	    COMPLEX(x)[offset] = COMPLEX(y)[0];
	    break;

	case 1610:	/* character <- logical	  */
	case 1613:	/* character <- integer	  */
	case 1614:	/* character <- real	  */
	case 1615:	/* character <- complex	  */
	case 1616:	/* character <- character */
	/* case 1016:	   logical   <- character */
	/* case 1316:	   integer   <- character */
	/* case 1416:	   real	     <- character */
	/* case 1516:	   complex   <- character */

	    SET_STRING_ELT(x, offset, STRING_ELT(y, 0));
	    break;

	case 1019:      /* logical    <- vector     */
	case 1319:      /* integer    <- vector     */
	case 1419:      /* real       <- vector     */
	case 1519:      /* complex    <- vector     */
	case 1619:      /* character  <- vector     */

	case 1901:  /* vector     <- symbol     */
	case 1902:  /* vector	  <- pairlist   */
	case 1904:  /* vector     <- environment*/
	case 1905:  /* vector     <- promise    */
	case 1906:  /* vector     <- language   */
	case 1910:  /* vector     <- logical    */
	case 1913:  /* vector     <- integer    */
	case 1914:  /* vector     <- real       */
	case 1915:  /* vector     <- complex    */
	case 1916:  /* vector     <- character  */
	case 1919:  /* vector     <- vector     */
	case 1920:  /* vector     <- expression */
	case 1921:  /* vector     <- bytecode   */
	case 1922:  /* vector     <- external pointer */
	case 1923:  /* vector     <- weak reference */
	case 1924:  /* vector     <- raw */
	case 1925:  /* vector     <- S4 */
	case 1903: case 1907: case 1908: case 1999: /* functions */

	    if( NAMED(y) ) y = duplicate(y);
	    SET_VECTOR_ELT(x, offset, y);
	    break;

	case 2002:	/* expression <- pairlist   */
	case 2006:	/* expression <- language   */
	case 2010:	/* expression <- logical    */
	case 2013:	/* expression <- integer    */
	case 2014:	/* expression <- real	    */
	case 2015:	/* expression <- complex    */
	case 2016:	/* expression <- character  */
	case 2024:      /* expression     <- raw */
	case 2025:      /* expression     <- S4 */
	case 2020:	/* expression <- expression */

	    SET_XVECTOR_ELT(x, offset, R_FixupRHS(x, y));
	    break;

	case 2424:      /* raw <- raw */

	   RAW(x)[offset] = RAW(y)[0];
	   break;

	default:
	    error(_("incompatible types (from %s to %s) in [[ assignment"),
		  type2char(CXXRCONSTRUCT(SEXPTYPE, which%100)), type2char(CXXRCONSTRUCT(SEXPTYPE, which/100)));
	}
	/* If we stretched, we may have a new name. */
	/* In this case we must create a names attribute */
	/* (if it doesn't already exist) and set the new */
	/* value in the names attribute. */
	if (stretch && newname != R_NilValue) {
	    names = getAttrib(x, R_NamesSymbol);
	    if (names == R_NilValue) {
		PROTECT(names = allocVector(STRSXP, Rf_length(x)));
		SET_STRING_ELT(names, offset, newname);
		setAttrib(x, R_NamesSymbol, names);
		UNPROTECT(1);
	    }
	    else
		SET_STRING_ELT(names, offset, newname);
	}
	UNPROTECT(1);
    }
    else if (isPairList(x)) {
	y = R_FixupRHS(x, y);
	PROTECT(y);
	if (nsubs == 1) {
	    if (isNull(y)) {
		x = listRemove(x, CAR(subs), len-1);
	    }
	    else {
		x = SimpleListAssign(call, x, subs, y, len-1);
	    }
	}
	else {
	    if (ndims != nsubs)
		error(_("[[ ]] improper number of subscripts"));
	    PROTECT(indx = allocVector(INTSXP, ndims));
	    names = getAttrib(x, R_DimNamesSymbol);
	    for (i = 0; i < ndims; i++) {
		INTEGER(indx)[i] = int(
		    get1index(CAR(subs), VECTOR_ELT(names, i),
			      INTEGER(dims)[i],
			      /*partial ok*/FALSE, -1, call));
		subs = subs->tail();
		if (INTEGER(indx)[i] < 0 ||
		    INTEGER(indx)[i] >= INTEGER(dims)[i])
		    error(_("[[ ]] subscript (%d) out of bounds"), i+1);
	    }
	    offset = 0;
	    for (i = (ndims - 1); i > 0; i--)
		offset = (offset + INTEGER(indx)[i]) * INTEGER(dims)[i - 1];
	    offset += INTEGER(indx)[0];
	    SEXP slot = nthcdr(x, (int) offset);
	    SETCAR(slot, duplicate(y));
	    /* FIXME: add name */
	    UNPROTECT(1);
	}
	UNPROTECT(1);
    }
    else error(R_MSG_ob_nonsub, type2char(TYPEOF(x)));

    if(recursed) {
	if (isVectorList(xup)) {
	    SET_VECTOR_ELT(xup, off, x);
	} else {
	    xup = SimpleListAssign(call, xup, subs, x, len-2);
	}
	if (len == 2)
	    xtop = xup;
    }
    else xtop = x;

    UNPROTECT(1);
    SET_NAMED(xtop, 0);
    if(S4) SET_S4_OBJECT(xtop);
    return xtop;
}
Exemplo n.º 15
0
SEXP attribute_hidden do_subassign_dflt(SEXP call, SEXP op, SEXP argsarg,
					SEXP rho)
{
    GCStackRoot<PairList> args(SEXP_downcast<PairList*>(argsarg));

    SEXP ignored, x, y;
    PairList* subs;
    int nsubs = SubAssignArgs(args, &x, &subs, &y);
   
    /* If there are multiple references to an object we must */
    /* duplicate it so that only the local version is mutated. */
    /* This will duplicate more often than necessary, but saves */
    /* over always duplicating. */
    if (MAYBE_SHARED(CAR(args))) {
	x = SETCAR(args, shallow_duplicate(CAR(args)));
    }

    bool S4 = IS_S4_OBJECT(x);
    SEXPTYPE xorigtype = TYPEOF(x);
    if (xorigtype == LISTSXP || xorigtype == LANGSXP)
	x = PairToVectorList(x);

    /* bug PR#2590 coerce only if null */
    if (!x)
	x = coerceVector(x, TYPEOF(y));

    switch (TYPEOF(x)) {
    case LGLSXP:
    case INTSXP:
    case REALSXP:
    case CPLXSXP:
    case STRSXP:
    case EXPRSXP:
    case VECSXP:
    case RAWSXP:
	{
	    VectorBase* xv = static_cast<VectorBase*>(x);
	    if (xv->size() == 0 && Rf_length(y) == 0)
		return x;
	    size_t nsubs = listLength(subs);
	    switch (nsubs) {
	    case 0:
		x = VectorAssign(call, x, R_MissingArg, y);
		break;
	    case 1:
		x = VectorAssign(call, x, subs->car(), y);
		break;
	    default:
		x = ArrayAssign(call, x, subs, y);
		break;
	    }
	}
	break;
    default:
	error(R_MSG_ob_nonsub, TYPEOF(x));
	break;
    }

    if (xorigtype == LANGSXP) {
	if(Rf_length(x)) {
	    GCStackRoot<PairList> xlr(static_cast<PairList*>(VectorToPairList(x)));
	    GCStackRoot<Expression> xr(ConsCell::convert<Expression>(xlr));
	    x = xr;
	} else
	    error(_("result is zero-length and so cannot be a language object"));
    }

    /* Note the setting of NAMED(x) to zero here.  This means */
    /* that the following assignment will not duplicate the value. */
    /* This works because at this point, x is guaranteed to have */
    /* at most one symbol bound to it.  It does mean that there */
    /* will be multiple reference problems if "[<-" is used */
    /* in a naked fashion. */

    SET_NAMED(x, 0);
    if (S4)
	SET_S4_OBJECT(x);
    return x;
}