The R Project SVN R

Rev

Rev 63181 | Rev 63442 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 63181 Rev 63223
Line 1239... Line 1239...
1239 
static SEXP SimpleListAssign(SEXP call, SEXP x, SEXP s, SEXP y, int ind)
 1239 
static SEXP SimpleListAssign(SEXP call, SEXP x, SEXP s, SEXP y, int ind)
1240 
{
 1240 
{
1241 
    SEXP indx, sub = CAR(s);
 1241 
    SEXP indx, sub = CAR(s);
1242 
    int ii, n, nx;
 1242 
    int ii, n, nx;
1243 
    R_xlen_t stretch = 1;
 1243 
    R_xlen_t stretch = 1;
1244 
    const void *vmax = vmaxget();
 - 
 
1245 
 
 1244 
 
1246 
    if (length(s) > 1)
 1245 
    if (length(s) > 1)
1247 
	error(_("invalid number of subscripts to list assign"));
 1246 
	error(_("invalid number of subscripts to list assign"));
1248 
 
 1247 
 
1249 
    PROTECT(sub = GetOneIndex(sub, ind));
 1248 
    PROTECT(sub = GetOneIndex(sub, ind));
Line 1261... Line 1260...
1261 
	/* This is general enough for only usage */
 1260 
	/* This is general enough for only usage */
1262 
	if(isString(t) && length(t) == stretch - nx) {
 1261 
	if(isString(t) && length(t) == stretch - nx) {
1263 
	    SEXP z = yi;
 1262 
	    SEXP z = yi;
1264 
	    int i;
 1263 
	    int i;
1265 
	    for(i = 0; i < LENGTH(t); i++, z = CDR(z))
 1264 
	    for(i = 0; i < LENGTH(t); i++, z = CDR(z))
1266 
		SET_TAG(z, install(translateChar(STRING_ELT(t, i))));
 1265 
		SET_TAG(z, installTrChar(STRING_ELT(t, i)));
1267 
	}
 1266 
	}
1268 
	PROTECT(x = listAppend(x, yi));
 1267 
	PROTECT(x = listAppend(x, yi));
1269 
	nx = (int) stretch;
 1268 
	nx = (int) stretch;
1270 
    }
 1269 
    }
1271 
    else PROTECT(x);
 1270 
    else PROTECT(x);
Line 1277... Line 1276...
1277 
	    SEXP xi = nthcdr(x, ii % nx);
 1276 
	    SEXP xi = nthcdr(x, ii % nx);
1278 
	    SETCAR(xi, y);
 1277 
	    SETCAR(xi, y);
1279 
	}
 1278 
	}
1280 
    }
 1279 
    }
1281 
    UNPROTECT(3);
 1280 
    UNPROTECT(3);
1282 
    vmaxset(vmax);
 - 
 
1283 
    return x;
 1281 
    return x;
1284 
}
 1282 
}
1285 
 
 1283 
 
1286 
/* This is for x[[s[ind]]] <- NULL */
 1284 
/* This is for x[[s[ind]]] <- NULL */
1287 
 
 1285 
 
Line 1559... Line 1557...
1559 
 
 1557 
 
1560 
    /* ENVSXP special case first */
 1558 
    /* ENVSXP special case first */
1561 
    if( TYPEOF(x) == ENVSXP) {
 1559 
    if( TYPEOF(x) == ENVSXP) {
1562 
	if( nsubs!=1 || !isString(CAR(subs)) || length(CAR(subs)) != 1 )
 1560 
	if( nsubs!=1 || !isString(CAR(subs)) || length(CAR(subs)) != 1 )
1563 
	    error(_("wrong args for environment subassignment"));
 1561 
	    error(_("wrong args for environment subassignment"));
1564 
	defineVar(install(translateChar(STRING_ELT(CAR(subs), 0))), y, x);
 1562 
	defineVar(installTrChar(STRING_ELT(CAR(subs), 0)), y, x);
1565 
	UNPROTECT(1);
 1563 
	UNPROTECT(1);
1566 
	return(S4 ? xOrig : x);
 1564 
	return(S4 ? xOrig : x);
1567 
    }
 1565 
    }
1568 
 
 1566 
 
1569 
    /* new case in 1.7.0, one vector index for a list,
 1567 
    /* new case in 1.7.0, one vector index for a list,
Line 1859... Line 1857...
1859 
 
 1857 
 
1860 
    if(DispatchOrEval(call, op, "$<-", args, env, &ans, 0, 0))
 1858 
    if(DispatchOrEval(call, op, "$<-", args, env, &ans, 0, 0))
1861 
      return(ans);
 1859 
      return(ans);
1862 
 
 1860 
 
1863 
    if (! iS)
 1861 
    if (! iS)
1864 
	nlist = install(translateChar(STRING_ELT(input, 0)));
 1862 
	nlist = installTrChar(STRING_ELT(input, 0));
1865 
 
 1863 
 
1866 
    return R_subassign3_dflt(call, CAR(ans), nlist, CADDR(ans));
 1864 
    return R_subassign3_dflt(call, CAR(ans), nlist, CADDR(ans));
1867 
}
 1865 
}
1868 
 
 1866 
 
1869 
/* used in "$<-" (above) and methods_list_dispatch.c */
 1867 
/* used in "$<-" (above) and methods_list_dispatch.c */