The R Project SVN – R – Diff – /trunk/src/main/subassign.c



	    error("bad expand value");
	}
    }
 
    if (newlen > len) {
	double expanded_nlen = (double)newlen * expand;
	if (expanded_nlen <= R_XLEN_T_MAX)
	    newtruelen = (R_xlen_t) expanded_nlen;
	else
	    newtruelen = newlen;
    }

   That coerces RHS to a list or expression.
 
   Level 2 is used in do_subassign2_dflt.
   This does not coerce when assigning into a list.
*/
 
static int SubassignTypeFix(SEXP *x, SEXP *y, R_xlen_t stretch,
			    int level,
			    SEXP call, SEXP rho)
{
    /* A rather pointless optimization, but level 2 used to be handled
       differently */
    bool redo_which = true;

        }
 
    default:
	error(_("incompatible types (from %s to %s) in subassignment type fix"),
	      R_typeToChar(*x), R_typeToChar(*y));
    } //--- end switch(which)
 
    if (stretch) {
	PROTECT(*y);
	*x = EnlargeVector(*x, stretch); // FIXME: 1d-array w/ {dim,dimnames} |--> vector w/ names
	UNPROTECT(1);
    }
    SET_OBJECT(*x, x_is_object);
 
    if(redo_which)
	return(100 * TYPEOF(*x) + TYPEOF(*y));
    else
	return(which);
} // SubassignTypeFix
 
#ifdef LONG_VECTOR_SUPPORT
static R_INLINE R_xlen_t gi(SEXP indx, R_xlen_t i)
{
    if (TYPEOF(indx) == REALSXP) {

	return R_NilValue;
    }
 
    /* Check to see if we have special matrix subscripting. */
    /* If so, we manufacture a real subscript vector. */
 
    PROTECT(s);
    if (ATTRIB(s) != R_NilValue) { /* pretest to speed up simple case */
	SEXP dim = getAttrib(x, R_DimSymbol);
	if (isMatrix(s) && isArray(x) && ncols(s) == length(dim)) {
	    if (isString(s)) {

    UNPROTECT(1); /* cond; not reached */
}
 
attribute_hidden SEXP do_subassign_dflt(SEXP call, SEXP op, SEXP args, SEXP rho)
{
 
 
 
    PROTECT(args);
 
    SEXP subs, x, y;
    int nsubs = SubAssignArgs(args, &x, &subs, &y);
    PROTECT(y); /* gets cut loose in SubAssignArgs */
 
    /* make sure the LHS is duplicated if it matches one of the indices */
    /* otherwise this gets the wrong answer:
          permute <- structure(c(3L, 1L, 2L), dim = c(3, 1))
	  permute[permute, 1] <- 1:3

    if (MAYBE_SHARED(CAR(args)) ||
	((! IS_ASSIGNMENT_CALL(call)) && MAYBE_REFERENCED(CAR(args))))
	x = SETCAR(args, shallow_duplicate(CAR(args)));
 
    bool S4 = IS_S4_OBJECT(x); // {before it is changed}
    int oldtype = 0;
    if (TYPEOF(x) == LISTSXP || TYPEOF(x) == LANGSXP) {
	oldtype = TYPEOF(x);
	x = PairToVectorList(x);
    }
    else if (xlength(x) == 0) {

 
attribute_hidden SEXP
do_subassign2_dflt(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP dims, indx, names, newname, subs, x, xtop, xup, y, thesub = R_NilValue, xOrig = R_NilValue;
    int i, ndims, which, len = 0 /* -Wall */;
    R_xlen_t  stretch, offset, off = -1; /* -Wall */
 
    PROTECT(args);
 
    int nsubs = SubAssignArgs(args, &x, &subs, &y);
    PROTECT(y); /* gets cut loose in SubAssignArgs */
 
    /* 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). */

Rev 89032	Rev 89130
Line 190...	Line 190...
190	`error("bad expand value");`	190	`error("bad expand value");`
191	`}`	191	`}`
192	`}`	192	`}`
193		193
194	`if (newlen > len) {`	194	`if (newlen > len) {`
195	`double expanded_nlen = newlen * expand;`	195	`double expanded_nlen = (double)newlen * expand;`
196	`if (expanded_nlen <= R_XLEN_T_MAX)`	196	`if (expanded_nlen <= R_XLEN_T_MAX)`
197	`newtruelen = (R_xlen_t) expanded_nlen;`	197	`newtruelen = (R_xlen_t) expanded_nlen;`
198	`else`	198	`else`
199	`newtruelen = newlen;`	199	`newtruelen = newlen;`
200	`}`	200	`}`
Line 320...	Line 320...
320	`That coerces RHS to a list or expression.`	320	`That coerces RHS to a list or expression.`
321		321
322	`Level 2 is used in do_subassign2_dflt.`	322	`Level 2 is used in do_subassign2_dflt.`
323	`This does not coerce when assigning into a list.`	323	`This does not coerce when assigning into a list.`
324	`*/`	324	`*/`
325		-
326	`static int SubassignTypeFix(SEXP x, SEXP y, R_xlen_t stretch, int level,`	325	`static int SubassignTypeFix(SEXP x, SEXP y, R_xlen_t stretch,`
-		326	`int level,`
327	`SEXP call, SEXP rho)`	327	`SEXP call, SEXP rho)`
328	`{`	328	`{`
329	`/* A rather pointless optimization, but level 2 used to be handled`	329	`/* A rather pointless optimization, but level 2 used to be handled`
330	`differently */`	330	`differently */`
331	`bool redo_which = true;`	331	`bool redo_which = true;`
Line 492...	Line 492...
492	`}`	492	`}`
493		493
494	`default:`	494	`default:`
495	`error(_("incompatible types (from %s to %s) in subassignment type fix"),`	495	`error(_("incompatible types (from %s to %s) in subassignment type fix"),`
496	`R_typeToChar(x), R_typeToChar(y));`	496	`R_typeToChar(x), R_typeToChar(y));`
497	`}`	497	`} //--- end switch(which)`
498		498
499	`if (stretch) {`	499	`if (stretch) {`
500	`PROTECT(*y);`	500	`PROTECT(*y);`
501	`x = EnlargeVector(x, stretch);`	501	`x = EnlargeVector(x, stretch); // FIXME: 1d-array w/ {dim,dimnames} \|--> vector w/ names`
502	`UNPROTECT(1);`	502	`UNPROTECT(1);`
503	`}`	503	`}`
504	`SET_OBJECT(*x, x_is_object);`	504	`SET_OBJECT(*x, x_is_object);`
505		505
506	`if(redo_which)`	506	`if(redo_which)`
507	`return(100 * TYPEOF(x) + TYPEOF(y));`	507	`return(100 * TYPEOF(x) + TYPEOF(y));`
508	`else`	508	`else`
509	`return(which);`	509	`return(which);`
510	`}`	510	`} // SubassignTypeFix`
511		511
512	`#ifdef LONG_VECTOR_SUPPORT`	512	`#ifdef LONG_VECTOR_SUPPORT`
513	`static R_INLINE R_xlen_t gi(SEXP indx, R_xlen_t i)`	513	`static R_INLINE R_xlen_t gi(SEXP indx, R_xlen_t i)`
514	`{`	514	`{`
515	`if (TYPEOF(indx) == REALSXP) {`	515	`if (TYPEOF(indx) == REALSXP) {`
Line 640...	Line 640...
640	`return R_NilValue;`	640	`return R_NilValue;`
641	`}`	641	`}`
642		642
643	`/* Check to see if we have special matrix subscripting. */`	643	`/* Check to see if we have special matrix subscripting. */`
644	`/* If so, we manufacture a real subscript vector. */`	644	`/* If so, we manufacture a real subscript vector. */`
645		-
646	`PROTECT(s);`	645	`PROTECT(s);`
647	`if (ATTRIB(s) != R_NilValue) { /* pretest to speed up simple case */`	646	`if (ATTRIB(s) != R_NilValue) { /* pretest to speed up simple case */`
648	`SEXP dim = getAttrib(x, R_DimSymbol);`	647	`SEXP dim = getAttrib(x, R_DimSymbol);`
649	`if (isMatrix(s) && isArray(x) && ncols(s) == length(dim)) {`	648	`if (isMatrix(s) && isArray(x) && ncols(s) == length(dim)) {`
650	`if (isString(s)) {`	649	`if (isString(s)) {`
Line 1610...	Line 1609...
1610	`UNPROTECT(1); /* cond; not reached */`	1609	`UNPROTECT(1); /* cond; not reached */`
1611	`}`	1610	`}`
1612		1611
1613	`attribute_hidden SEXP do_subassign_dflt(SEXP call, SEXP op, SEXP args, SEXP rho)`	1612	`attribute_hidden SEXP do_subassign_dflt(SEXP call, SEXP op, SEXP args, SEXP rho)`
1614	`{`	1613	`{`
1615	`SEXP subs, x, y;`	-
1616	`int nsubs, oldtype;`	-
1617		-
1618	`PROTECT(args);`	1614	`PROTECT(args);`
1619		1615
-		1616	`SEXP subs, x, y;`
1620	`nsubs = SubAssignArgs(args, &x, &subs, &y);`	1617	`int nsubs = SubAssignArgs(args, &x, &subs, &y);`
1621	`PROTECT(y); /* gets cut loose in SubAssignArs */`	1618	`PROTECT(y); /* gets cut loose in SubAssignArgs */`
1622		1619
1623	`/* make sure the LHS is duplicated if it matches one of the indices */`	1620	`/* make sure the LHS is duplicated if it matches one of the indices */`
1624	`/* otherwise this gets the wrong answer:`	1621	`/* otherwise this gets the wrong answer:`
1625	`permute <- structure(c(3L, 1L, 2L), dim = c(3, 1))`	1622	`permute <- structure(c(3L, 1L, 2L), dim = c(3, 1))`
1626	`permute[permute, 1] <- 1:3`	1623	`permute[permute, 1] <- 1:3`
Line 1640...	Line 1637...
1640	`if (MAYBE_SHARED(CAR(args)) \|\|`	1637	`if (MAYBE_SHARED(CAR(args)) \|\|`
1641	`((! IS_ASSIGNMENT_CALL(call)) && MAYBE_REFERENCED(CAR(args))))`	1638	`((! IS_ASSIGNMENT_CALL(call)) && MAYBE_REFERENCED(CAR(args))))`
1642	`x = SETCAR(args, shallow_duplicate(CAR(args)));`	1639	`x = SETCAR(args, shallow_duplicate(CAR(args)));`
1643		1640
1644	`bool S4 = IS_S4_OBJECT(x); // {before it is changed}`	1641	`bool S4 = IS_S4_OBJECT(x); // {before it is changed}`
1645	`oldtype = 0;`	1642	`int oldtype = 0;`
1646	`if (TYPEOF(x) == LISTSXP \|\| TYPEOF(x) == LANGSXP) {`	1643	`if (TYPEOF(x) == LISTSXP \|\| TYPEOF(x) == LANGSXP) {`
1647	`oldtype = TYPEOF(x);`	1644	`oldtype = TYPEOF(x);`
1648	`x = PairToVectorList(x);`	1645	`x = PairToVectorList(x);`
1649	`}`	1646	`}`
1650	`else if (xlength(x) == 0) {`	1647	`else if (xlength(x) == 0) {`
Line 1768...	Line 1765...
1768		1765
1769	`attribute_hidden SEXP`	1766	`attribute_hidden SEXP`
1770	`do_subassign2_dflt(SEXP call, SEXP op, SEXP args, SEXP rho)`	1767	`do_subassign2_dflt(SEXP call, SEXP op, SEXP args, SEXP rho)`
1771	`{`	1768	`{`
1772	`SEXP dims, indx, names, newname, subs, x, xtop, xup, y, thesub = R_NilValue, xOrig = R_NilValue;`	1769	`SEXP dims, indx, names, newname, subs, x, xtop, xup, y, thesub = R_NilValue, xOrig = R_NilValue;`
1773	`int i, ndims, nsubs, which, len = 0 /* -Wall */;`	1770	`int i, ndims, which, len = 0 /* -Wall */;`
1774	`R_xlen_t stretch, offset, off = -1; /* -Wall */`	1771	`R_xlen_t stretch, offset, off = -1; /* -Wall */`
1775		1772
1776	`PROTECT(args);`	1773	`PROTECT(args);`
1777		1774
1778	`nsubs = SubAssignArgs(args, &x, &subs, &y);`	1775	`int nsubs = SubAssignArgs(args, &x, &subs, &y);`
1779	`PROTECT(y); /* gets cut loose in SubAssignArgs */`	1776	`PROTECT(y); /* gets cut loose in SubAssignArgs */`
1780		1777
1781	`/* Handle NULL left-hand sides. If the right-hand side */`	1778	`/* Handle NULL left-hand sides. If the right-hand side */`
1782	`/* is NULL, just return the left-hand size otherwise, */`	1779	`/* is NULL, just return the left-hand size otherwise, */`
1783	`/* convert to a zero length list (VECSXP). */`	1780	`/* convert to a zero length list (VECSXP). */`

The R Project SVN R

(root)/trunk/src/main/subassign.c @ 77458 – Rev 89032 → 89130