/* * R : A Computer Language for Statistical Data Analysis * Copyright (C) 1997--2023 The R Core Team * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, a copy is available at * https://www.R-project.org/Licenses/ */ /* Warnings/Errors In this file we generally do not make use of the call, as it will be something like `[<-`(`*tmp`, ...) and that just confuses the user. The call that is deduced from the context is generally much clearer. */ /* * * Subset Mutation for Lists and Vectors * * The following table shows the codes which have been assigned to the * type combinations in assignments of the form "x[s] <- y". Here the * type of y is given across the top of the table and the type of x at * the side. (Note: the lack of 11 and 12 indices here is due to the * removal of built-in factors). * * NB these tables are out of date, and exclude types 21, 22, 23, 24 ... * x \ y NIL SYM CLOS ENV PROM LANG SPE- BUI- LGL INT REAL CPLX STR VEC EXPR FUN CIAL LTIN LANG 600 601 603 604 605 606 607 608 610 613 614 615 616 619 620 699 LGL 1000 1001 1003 1004 1005 1006 1007 1008 1010 1013 1014 1015 1016 1019 1020 1099 INT 1300 1301 1303 1304 1305 1306 1307 1308 1310 1313 1314 1315 1316 1319 1320 1399 REAL 1400 1401 1403 1404 1405 1406 1407 1408 1410 1413 1414 1415 1416 1419 1420 1499 CPLX 1500 1501 1503 1504 1505 1506 1507 1508 1510 1513 1514 1515 1516 1519 1520 1599 STR 1600 1601 1603 1604 1605 1606 1607 1608 1610 1613 1614 1615 1616 1619 1620 1699 VEC 1900 1901 1903 1904 1905 1906 1907 1908 1910 1913 1914 1915 1916 1919 1920 1999 EXPR 2000 2001 2003 2004 2005 2006 2007 2008 2010 2013 2014 2015 2016 2019 2020 2099 * * * The following table (which is laid out as described above) contains * "*" for those combinations where the assignment has been implemented. * Some assignments do not make a great deal of sense and we have chosen * to leave them unimplemented, although the addition of new assignment * combinations represents no great difficulty. * * NIL SYM CLOS ENV PROM LANG SPE- BUI- LGL INT REAL CPLX STR VEC EXPR FUN * CIAL LTIN LANG LGL * * * * * * * INT * * * * * * * REAL * * * * * * * CPLX * * * * * * * STR * * * * * * * VEC * * * * * * * * * * * * * * * * EXPR * * * * * * * * * * * * The reason for the LGL row and column are because we want to allow any * assignment of the form "x[s] <- NA" (col) and because the interpreted * "ifelse" requires assignment into a logical object. */ /* * 2000/02/17 Altered to allow closures/primitives in lists (VECSXPs) BDR */ /* * 2000/08/01 Also promises, expressions, environments when using [[ PD */ #ifdef HAVE_CONFIG_H #include #endif #include #include #include /* for test of S4 objects */ #include /* The SET_STDVEC_LENGTH macro is used to modify the length of growable vectors. This would need to change to allow ALTREP vectors to grow in place. SETLENGTH is used when checking the write barrier. Always using SETLENGTH would be OK but maybe a little less efficient. */ #ifndef SET_STDVEC_LENGTH # define SET_STDVEC_LENGTH(x, v) SETLENGTH(x, v) #endif #ifdef COMPUTE_REFCNT_VALUES /* Set elements to R_NilValue to decrement REFCNT on old value. */ /* Might be good to have an ALTREP-friendlier version */ /* This should only be used after any operations that could signal an error, otherwise an error will leave the original LHS object in a partially mutated state */ # define CLEAR_VECTOR(x) do { \ if (TYPEOF(x) == EXPRSXP || TYPEOF(x) == VECSXP) { \ R_xlen_t len = XLENGTH(x); \ for (R_xlen_t i = 0; i < len; i++) \ SET_VECTOR_ELT(x, i, R_NilValue); \ } \ } while (0) #else # define CLEAR_VECTOR(x) do { } while (0) #endif static R_INLINE SEXP getNames(SEXP x) { /* defer to getAttrib if a 'dim' attribute is present */ for (SEXP attr = ATTRIB(x); attr != R_NilValue; attr = CDR(attr)) if (TAG(attr) == R_DimSymbol) return getAttrib(x, R_NamesSymbol); /* don't use getAttrib since that would mark as immutable */ for (SEXP attr = ATTRIB(x); attr != R_NilValue; attr = CDR(attr)) if (TAG(attr) == R_NamesSymbol) return CAR(attr); return R_NilValue; } /* EnlargeVector() takes a vector "x" and changes its length to "newlen". This allows to assign values "past the end" of the vector or list. Overcommit by a small percentage to allow more efficient vector growth. */ static SEXP EnlargeNames(SEXP, R_xlen_t, R_xlen_t); static SEXP EnlargeVector(SEXP x, R_xlen_t newlen) { R_xlen_t len, newtruelen; SEXP newx, names; static SEXP R_CheckBoundsSymbol = NULL; if (R_CheckBoundsSymbol == NULL) R_CheckBoundsSymbol = install("check.bounds"); /* Sanity Checks */ if (!isVector(x)) error(_("attempt to enlarge non-vector")); /* Enlarge the vector itself. */ len = xlength(x); if (LOGICAL(GetOption1(R_CheckBoundsSymbol))[0]) warning(_("assignment outside vector/list limits (extending from %lld to %lld)"), (long long)len, (long long)newlen); /* if the vector is not shared, is growable. and has room, then increase its length */ if (! MAYBE_SHARED(x) && IS_GROWABLE(x) && XTRUELENGTH(x) >= newlen) { SET_STDVEC_LENGTH(x, newlen); names = getNames(x); if (!isNull(names)) { SEXP newnames = EnlargeNames(names, len, newlen); if (names != newnames) setAttrib(x, R_NamesSymbol, newnames); } return x; } /* over-committing by 5% seems to be reasonable, but for experimenting the environment variable R_EXPAND_Frac can be used to adjust this */ static double expand_dflt = 1.05; static double expand = 0; if (expand == 0) { char *envval = getenv("R_EXPAND_FRAC"); expand = envval != NULL ? atof(envval) : expand_dflt; if (expand < 1 || expand > 2) { expand = expand_dflt; error("bad expand value"); } } if (newlen > len) { double expanded_nlen = newlen * expand; if (expanded_nlen <= R_XLEN_T_MAX) newtruelen = (R_xlen_t) expanded_nlen; else newtruelen = newlen; } else /* sometimes this is called when no expansion is needed */ newtruelen = newlen; /**** for now, don't cross the long vector boundary; drop when ALTREP is merged */ /* #ifdef ALTREP #error drop the limitation to short vectors #endif if (newtruelen > R_LEN_T_MAX) newtruelen = newlen; */ PROTECT(x); PROTECT(newx = allocVector(TYPEOF(x), newtruelen)); /* Copy the elements into place. */ switch(TYPEOF(x)) { case LGLSXP: case INTSXP: for (R_xlen_t i = 0; i < len; i++) INTEGER0(newx)[i] = INTEGER_ELT(x, i); for (R_xlen_t i = len; i < newtruelen; i++) INTEGER0(newx)[i] = NA_INTEGER; break; case REALSXP: for (R_xlen_t i = 0; i < len; i++) REAL0(newx)[i] = REAL_ELT(x, i); for (R_xlen_t i = len; i < newtruelen; i++) REAL0(newx)[i] = NA_REAL; break; case CPLXSXP: for (R_xlen_t i = 0; i < len; i++) COMPLEX0(newx)[i] = COMPLEX_ELT(x, i); for (R_xlen_t i = len; i < newtruelen; i++) { COMPLEX0(newx)[i].r = NA_REAL; COMPLEX0(newx)[i].i = NA_REAL; } break; case STRSXP: for (R_xlen_t i = 0; i < len; i++) SET_STRING_ELT(newx, i, STRING_ELT(x, i)); for (R_xlen_t i = len; i < newtruelen; i++) SET_STRING_ELT(newx, i, NA_STRING); /* was R_BlankString < 1.6.0 */ break; case EXPRSXP: case VECSXP: for (R_xlen_t i = 0; i < len; i++) SET_VECTOR_ELT(newx, i, VECTOR_ELT(x, i)); for (R_xlen_t i = len; i < newtruelen; i++) SET_VECTOR_ELT(newx, i, R_NilValue); break; case RAWSXP: for (R_xlen_t i = 0; i < len; i++) RAW0(newx)[i] = RAW_ELT(x, i); for (R_xlen_t i = len; i < newtruelen; i++) RAW0(newx)[i] = (Rbyte) 0; break; default: UNIMPLEMENTED_TYPE("EnlargeVector", x); } if (newlen < newtruelen) { SET_GROWABLE_BIT(newx); SET_TRUELENGTH(newx, newtruelen); SET_STDVEC_LENGTH(newx, newlen); } /* Adjust the attribute list. */ names = getNames(x); if (!isNull(names)) setAttrib(newx, R_NamesSymbol, EnlargeNames(names, len, newlen)); copyMostAttrib(x, newx); UNPROTECT(2); return newx; } static SEXP EnlargeNames(SEXP names, R_xlen_t len, R_xlen_t newlen) { if (TYPEOF(names) != STRSXP || XLENGTH(names) != len) error(_("bad names attribute")); SEXP newnames = PROTECT(EnlargeVector(names, newlen)); for (R_xlen_t i = len; i < newlen; i++) SET_STRING_ELT(newnames, i, R_BlankString); UNPROTECT(1); return newnames; } /* used instead of coerceVector to embed a non-vector in a list for purposes of SubassignTypeFix, for cases in which coerceVector should fail; currently used only for OBJSXP = S4SXP */ static SEXP embedInVector(SEXP v, SEXP call) { SEXP ans; if(IS_S4_OBJECT(v)) warningcall(call, "implicit list embedding of S4 objects is deprecated"); else errorcall(call, "implicit list embedding of \"object\" is not possible"); PROTECT(ans = allocVector(VECSXP, 1)); SET_VECTOR_ELT(ans, 0, v); UNPROTECT(1); return (ans); } static Rboolean dispatch_asvector(SEXP *x, SEXP call, SEXP rho) { static SEXP op = NULL; SEXP args; Rboolean ans; if (op == NULL) op = INTERNAL(install("as.vector")); PROTECT(args = list2(*x, mkString("any"))); /* DispatchOrEval internal generic: as.vector */ ans = DispatchOrEval(call, op, "as.vector", args, rho, x, 0, 1); UNPROTECT(1); return ans; } /* Level 1 is used in VectorAssign, MatrixAssign, ArrayAssign. 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 */ Rboolean redo_which = TRUE; int which = 100 * TYPEOF(*x) + TYPEOF(*y); /* coercion can lose the object bit */ Rboolean x_is_object = OBJECT(*x); switch (which) { case 1000: /* logical <- null */ case 1300: /* integer <- null */ case 1400: /* real <- null */ case 1500: /* complex <- null */ case 1600: /* character <- null */ case 1900: /* vector <- null */ case 2000: /* expression <- null */ case 2400: /* raw <- null */ case 1010: /* logical <- logical */ case 1310: /* integer <- logical */ case 1410: /* real <- logical */ case 1510: /* complex <- logical */ case 1313: /* integer <- integer */ case 1413: /* real <- integer */ case 1513: /* complex <- integer */ case 1414: /* real <- real */ case 1514: /* complex <- real */ case 1515: /* complex <- complex */ case 1616: /* character <- character */ case 1919: /* vector <- vector */ case 2020: /* expression <- expression */ case 2424: /* raw <- raw */ redo_which = FALSE; break; case 1013: /* logical <- integer */ *x = coerceVector(*x, INTSXP); break; case 1014: /* logical <- real */ case 1314: /* integer <- real */ *x = coerceVector(*x, REALSXP); break; case 1015: /* logical <- complex */ case 1315: /* integer <- complex */ case 1415: /* real <- complex */ *x = coerceVector(*x, CPLXSXP); break; case 1610: /* character <- logical */ case 1613: /* character <- integer */ case 1614: /* character <- real */ case 1615: /* character <- complex */ *y = coerceVector(*y, STRSXP); break; case 1016: /* logical <- character */ case 1316: /* integer <- character */ case 1416: /* real <- character */ case 1516: /* complex <- character */ *x = coerceVector(*x, STRSXP); break; 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 1920: /* vector <- expression */ case 1921: /* vector <- bytecode */ case 1922: /* vector <- external pointer */ case 1923: /* vector <- weak reference */ case 1924: /* vector <- raw */ case 1903: case 1907: case 1908: case 1999: /* functions */ if (level == 1) { /* Coerce the RHS into a list */ *y = coerceVector(*y, VECSXP); } else { /* Nothing to do here: duplicate when used (if needed) */ redo_which = FALSE; } break; case 1925: /* vector <- S4|OBJ */ if (level == 1) { /* Embed the RHS into a list */ *y = embedInVector(*y, call); } else { /* Nothing to do here: duplicate when used (if needed) */ redo_which = FALSE; } break; case 1019: /* logical <- vector */ case 1319: /* integer <- vector */ case 1419: /* real <- vector */ case 1519: /* complex <- vector */ case 1619: /* character <- vector */ case 2419: /* raw <- vector */ *x = coerceVector(*x, VECSXP); break; case 1020: /* logical <- expression */ case 1320: /* integer <- expression */ case 1420: /* real <- expression */ case 1520: /* complex <- expression */ case 1620: /* character <- expression */ case 2420: /* raw <- expression */ *x = coerceVector(*x, EXPRSXP); break; case 2001: /* expression <- symbol */ 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 2019: /* expression <- vector */ if (level == 1) { /* Coerce the RHS into a list */ *y = coerceVector(*y, VECSXP); } else { /* Note : No coercion is needed here. */ /* We just insert the RHS into the LHS. */ redo_which = FALSE; } break; case 2025: /* expression <- S4|OBJ */ if (level == 1) { /* Embed the RHS into a list */ *y = embedInVector(*y, call); } else { /* Nothing to do here: duplicate when used (if needed) */ redo_which = FALSE; } break; case 1025: /* logical <- S4|OBJ */ case 1325: /* integer <- S4|OBJ */ case 1425: /* real <- S4|OBJ */ case 1525: /* complex <- S4|OBJ */ case 1625: /* character <- S4|OBJ */ case 2425: /* raw <- S4|OBJ */ if (dispatch_asvector(y, call, rho)) { return SubassignTypeFix(x, y, stretch, level, call, rho); } default: error(_("incompatible types (from %s to %s) in subassignment type fix"), R_typeToChar(*x), R_typeToChar(*y)); } if (stretch) { PROTECT(*y); *x = EnlargeVector(*x, stretch); UNPROTECT(1); } SET_OBJECT(*x, x_is_object); if(redo_which) return(100 * TYPEOF(*x) + TYPEOF(*y)); else return(which); } #ifdef LONG_VECTOR_SUPPORT static R_INLINE R_xlen_t gi(SEXP indx, R_xlen_t i) { if (TYPEOF(indx) == REALSXP) { double d = REAL_ELT(indx, i); return R_FINITE(d) ? (R_xlen_t) d : NA_INTEGER; } else return INTEGER_ELT(indx, i); } #else #define R_SHORT_LEN_MAX INT_MAX static R_INLINE int gi(SEXP indx, R_xlen_t i) { if (TYPEOF(indx) == REALSXP) { double d = REAL_ELT(indx, i); if (!R_FINITE(d) || d < -R_SHORT_LEN_MAX || d > R_SHORT_LEN_MAX) return NA_INTEGER; return (int) d; } else return INTEGER_ELT(indx, i); } #endif static SEXP DeleteListElements(SEXP x, SEXP which) { SEXP include, xnew, xnames, xnewnames; R_xlen_t i, ii, len, lenw; len = xlength(x); lenw = xlength(which); /* calculate the length of the result */ PROTECT(include = allocVector(INTSXP, len)); int *pinclude = INTEGER0(include); for (i = 0; i < len; i++) pinclude[i] = 1; for (i = 0; i < lenw; i++) { ii = gi(which, i); if (0 < ii && ii <= len) pinclude[ii - 1] = 0; } ii = 0; for (i = 0; i < len; i++) ii += pinclude[i]; if (ii == len) { UNPROTECT(1); return x; } PROTECT(xnew = allocVector(TYPEOF(x), ii)); ii = 0; for (i = 0; i < len; i++) { if (pinclude[i] == 1) { SET_VECTOR_ELT(xnew, ii, VECTOR_ELT(x, i)); ii++; } } PROTECT(xnames = getAttrib(x, R_NamesSymbol)); if (xnames != R_NilValue) { PROTECT(xnewnames = allocVector(STRSXP, ii)); ii = 0; for (i = 0; i < len; i++) { if (pinclude[i] == 1) { SET_STRING_ELT(xnewnames, ii, STRING_ELT(xnames, i)); ii++; } } setAttrib(xnew, R_NamesSymbol, xnewnames); UNPROTECT(1); } copyMostAttrib(x, xnew); UNPROTECT(3); return xnew; } static R_INLINE SEXP VECTOR_ELT_FIX_NAMED(SEXP y, R_xlen_t i) { /* if RHS (container or element) has NAMED > 0 set NAMED = NAMEDMAX. Duplicating might be safer/more consistent (PR15098) */ SEXP val = VECTOR_ELT(y, i); if ((NAMED(y) || NAMED(val))) ENSURE_NAMEDMAX(val); return val; } #define VECTOR_ASSIGN_LOOP(CODE) do { \ if (TYPEOF(indx) == INTSXP) { \ const int *pindx = INTEGER_RO(indx); \ MOD_ITERATE1(n, ny, i, iny, { \ ii = pindx[i]; \ if (ii == NA_INTEGER) continue; \ ii = ii - 1; \ do { CODE } while (0); \ }); \ } \ else /* could specialize this to REALSXP case */\ MOD_ITERATE1(n, ny, i, iny, { \ ii = gi(indx, i); \ if (ii == NA_INTEGER) continue; \ ii = ii - 1; \ do { CODE } while (0); \ }); \ } while (0) /**** This could use SET_REAL_ELT and such, but would also have to change byte code instructions in eval.c */ static SEXP VectorAssign(SEXP call, SEXP rho, SEXP x, SEXP s, SEXP y) { /* try for quick return for simple scalar case */ if (ATTRIB(s) == R_NilValue) { if (TYPEOF(x) == REALSXP && IS_SCALAR(y, REALSXP)) { if (IS_SCALAR(s, INTSXP)) { R_xlen_t ival = SCALAR_IVAL(s); if (1 <= ival && ival <= XLENGTH(x)) { REAL(x)[ival - 1] = SCALAR_DVAL(y); return x; } } else if (IS_SCALAR(s, REALSXP)) { double dval = SCALAR_DVAL(s); if (R_FINITE(dval)) { R_xlen_t ival = (R_xlen_t) dval; if (1 <= ival && ival <= XLENGTH(x)) { REAL(x)[ival - 1] = SCALAR_DVAL(y); return x; } } } } } if (isNull(x) && isNull(y)) { 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)) { SEXP dnames = PROTECT(GetArrayDimnames(x)); s = strmat2intmat(s, dnames, call, x); UNPROTECT(2); /* dnames, s */ PROTECT(s); } if (isInteger(s) || isReal(s)) { s = mat2indsub(dim, s, R_NilValue, x); // .......... or call, as in VectorSubset() [subset.c]? UNPROTECT(1); PROTECT(s); } } } R_xlen_t stretch = 1; SEXP indx = PROTECT(makeSubscript(x, s, &stretch, R_NilValue)); R_xlen_t i, ii, n = xlength(indx); if(xlength(y) > 1) for(i = 0; i < n; i++) if(gi(indx, i) == NA_INTEGER) error(_("NAs are not allowed in subscripted assignments")); /* Here we make sure that the LHS has */ /* been coerced into a form which can */ /* accept elements from the RHS. */ SEXP old_x = x; int which = SubassignTypeFix(&x, &y, stretch, 1, call, rho); /* = 100 * TYPEOF(x) + TYPEOF(y);*/ if (n == 0) { UNPROTECT(2); return x; } R_xlen_t ny = xlength(y), nx = xlength(x), iny; PROTECT(x); if ((TYPEOF(x) != VECSXP && TYPEOF(x) != EXPRSXP) || y != R_NilValue) { PROTECT(y); if (n > 0 && ny == 0) error(_("replacement has length zero")); if (n > 0 && n % ny) warning(_("number of items to replace is not a multiple of replacement length")); UNPROTECT(1); } /* When array elements are being permuted the RHS */ /* must be duplicated or the elements get trashed. */ /* FIXME : this should be a shallow copy for list */ /* objects. A full duplication is wasteful. */ if (x == y) PROTECT(y = shallow_duplicate(y)); else PROTECT(y); /* Note that we are now committed. */ /* Since we are mutating existing objects, */ /* any changes we make now are (likely to be) permanent. Beware! */ switch(which) { /* because we have called SubassignTypeFix the commented values cannot occur (and would be unsafe) */ case 1010: /* logical <- logical */ case 1310: /* integer <- logical */ /* case 1013: logical <- integer */ case 1313: /* integer <- integer */ { int *px = INTEGER(x); VECTOR_ASSIGN_LOOP(px[ii] = INTEGER_ELT(y, iny);); } break; case 1410: /* real <- logical */ case 1413: /* real <- integer */ { double *px = REAL(x); VECTOR_ASSIGN_LOOP({ int iy = INTEGER_ELT(y, iny); if (iy == NA_INTEGER) px[ii] = NA_REAL; else px[ii] = iy; }); } break; /* case 1014: logical <- real */ /* case 1314: integer <- real */ case 1414: /* real <- real */ { double *px = REAL(x); VECTOR_ASSIGN_LOOP(px[ii] = REAL_ELT(y, iny);); } break; case 1510: /* complex <- logical */ case 1513: /* complex <- integer */ { Rcomplex *px = COMPLEX(x); VECTOR_ASSIGN_LOOP({ int iy = INTEGER_ELT(y, iny); if (iy == NA_INTEGER) { px[ii].r = NA_REAL; px[ii].i = NA_REAL; } else { px[ii].r = iy; px[ii].i = 0.0; } }); } break; case 1514: /* complex <- real */ { Rcomplex *px = COMPLEX(x); VECTOR_ASSIGN_LOOP({ double ry = REAL_ELT(y, iny); if (ISNA(ry)) { px[ii].r = NA_REAL; px[ii].i = NA_REAL; } else { px[ii].r = ry; px[ii].i = 0.0; } }); } break; /* case 1015: logical <- complex */ /* case 1315: integer <- complex */ /* case 1415: real <- complex */ case 1515: /* complex <- complex */ { Rcomplex *px = COMPLEX(x); VECTOR_ASSIGN_LOOP(px[ii] = COMPLEX_ELT(y, iny);); } 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 */ VECTOR_ASSIGN_LOOP(SET_STRING_ELT(x, ii, STRING_ELT(y, iny));); break; /* case 1019: logial <- vector */ /* case 1319: integer <- vector */ /* case 1419: real <- vector */ /* case 1519: complex <- vector */ /* case 1619: character <- vector */ /* case 1910: vector <- logical */ /* case 1913: vector <- integer */ /* case 1914: vector <- real */ /* case 1915: vector <- complex */ /* case 1916: vector <- character */ case 1919: /* vector <- vector */ VECTOR_ASSIGN_LOOP({ /* set NAMED on RHS value to NAMEDMAX if used more than once (PR15098) */ if (i >= ny) ENSURE_NAMEDMAX(VECTOR_ELT(y, iny)); SET_VECTOR_ELT(x, ii, VECTOR_ELT_FIX_NAMED(y, iny)); }); break; /* case 2001: */ /* 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 2019: /* expression <- vector, needed if we have promoted a RHS to a list */ case 2020: /* expression <- expression */ VECTOR_ASSIGN_LOOP(SET_VECTOR_ELT(x, ii, VECTOR_ELT(y, iny));); break; case 1900: /* vector <- null */ case 2000: /* expression <- null */ x = DeleteListElements(x, indx); UNPROTECT(4); return x; break; case 2424: /* raw <- raw */ { Rbyte *px = RAW(x); VECTOR_ASSIGN_LOOP(px[ii] = RAW_ELT(y, iny);); } break; default: warningcall(call, "sub assignment (*[*] <- *) not done; __bug?__"); } /* Check for additional named elements. */ /* Note makeSubscript passes the additional names back as the use.names attribute (a vector list) of the generated subscript vector */ SEXP newnames = getAttrib(indx, R_UseNamesSymbol); if (newnames != R_NilValue) { SEXP oldnames = getAttrib(x, R_NamesSymbol); if (oldnames != R_NilValue) { for (i = 0; i < n; i++) { if (VECTOR_ELT(newnames, i) != R_NilValue) { ii = gi(indx, i); if (ii == NA_INTEGER) continue; ii = ii - 1; SET_STRING_ELT(oldnames, ii, VECTOR_ELT(newnames, i)); } } } else { PROTECT(oldnames = allocVector(STRSXP, nx)); for (i = 0; i < nx; i++) SET_STRING_ELT(oldnames, i, R_BlankString); for (i = 0; i < n; i++) { if (VECTOR_ELT(newnames, i) != R_NilValue) { ii = gi(indx, i); if (ii == NA_INTEGER) continue; ii = ii - 1; SET_STRING_ELT(oldnames, ii, VECTOR_ELT(newnames, i)); } } setAttrib(x, R_NamesSymbol, oldnames); UNPROTECT(1); } } UNPROTECT(4); if (old_x != x) CLEAR_VECTOR(old_x); return x; } // in ./subscript.c : SEXP int_arraySubscript(int dim, SEXP s, SEXP dims, SEXP x, SEXP call); #define MATRIX_ASSIGN_LOOP(CODE) do { \ R_xlen_t k = 0, NR = nr, ij; \ if (anyIdxNA) \ for (int j = 0; j < ncs; j++) { \ int jj = psc[j]; \ if (jj != NA_INTEGER) { \ jj = jj - 1; \ R_xlen_t offset = jj * NR; \ for (int i = 0; i < nrs; i++) { \ int ii = psr[i]; \ if (ii != NA_INTEGER) { \ ij = ii + offset - 1; \ do { CODE } while (0); \ k++; \ if (k == ny) k = 0; \ } \ } \ } \ } \ else \ for (int j = 0; j < ncs; j++) { \ int jj = psc[j] - 1; \ R_xlen_t offset = jj * NR; \ for (int i = 0; i < nrs; i++) { \ int ii = psr[i]; \ ij = ii + offset - 1; \ do { CODE } while (0); \ k++; \ if (k == ny) k = 0; \ } \ } \ } while (0) static SEXP MatrixAssign(SEXP call, SEXP rho, SEXP x, SEXP s, SEXP y) { int which; int nrs, ncs; SEXP sr, sc, dim; if (!isMatrix(x)) error(_("incorrect number of subscripts on matrix")); int nr = nrows(x); R_xlen_t ny = XLENGTH(y); /* Note that "s" has been protected. */ /* No GC problems here. */ dim = getAttrib(x, R_DimSymbol); sr = SETCAR(s, int_arraySubscript(0, CAR(s), dim, x, call)); sc = SETCADR(s, int_arraySubscript(1, CADR(s), dim, x, call)); nrs = LENGTH(sr); ncs = LENGTH(sc); const int *psc = INTEGER_RO(sc); const int *psr = INTEGER_RO(sr); int anyIdxNA = FALSE; for(int i = 0; i < nrs; i++) if (psr[i] == NA_INTEGER) { anyIdxNA = TRUE; break; } for(int i = 0; i < ncs; i++) if (psc[i] == NA_INTEGER) { anyIdxNA = TRUE; break; } if(ny > 1 && anyIdxNA) error(_("NAs are not allowed in subscripted assignments")); R_xlen_t n = ((R_xlen_t) nrs) * ncs; /* 21Oct97 if (length(y) == 0) error("Replacement length is zero"); */ if (n > 0 && ny == 0) error(_("replacement has length zero")); if (n > 0 && n % ny) error(_("number of items to replace is not a multiple of replacement length")); which = SubassignTypeFix(&x, &y, 0, 1, call, rho); if (n == 0) return x; PROTECT(x); /* When array elements are being permuted the RHS */ /* must be duplicated or the elements get trashed. */ /* FIXME : this should be a shallow copy for list */ /* objects. A full duplication is wasteful. */ if (x == y) PROTECT(y = shallow_duplicate(y)); else PROTECT(y); /* Note that we are now committed. Since we are mutating */ /* existing objects any changes we make now are permanent. */ /* Beware! */ switch (which) { /* because we have called SubassignTypeFix the commented values cannot occur (and would be unsafe) */ case 1010: /* logical <- logical */ case 1310: /* integer <- logical */ /* case 1013: logical <- integer */ case 1313: /* integer <- integer */ { int *px = INTEGER(x); if (ALTREP(y)) MATRIX_ASSIGN_LOOP(px[ij] = INTEGER_ELT(y, k);); else { int *py = INTEGER0(y); MATRIX_ASSIGN_LOOP(px[ij] = py[k];); } } break; case 1410: /* real <- logical */ case 1413: /* real <- integer */ { double *px = REAL(x); MATRIX_ASSIGN_LOOP({ int iy = INTEGER_ELT(y, k); if (iy == NA_INTEGER) px[ij] = NA_REAL; else px[ij] = iy; }); } break; /* case 1014: logical <- real */ /* case 1314: integer <- real */ case 1414: /* real <- real */ { double *px = REAL(x); if (ALTREP(y)) MATRIX_ASSIGN_LOOP(px[ij] = REAL_ELT(y, k);); else { double *py = REAL0(y); MATRIX_ASSIGN_LOOP(px[ij] = py[k];); } } break; case 1510: /* complex <- logical */ case 1513: /* complex <- integer */ { Rcomplex *px = COMPLEX(x); MATRIX_ASSIGN_LOOP({ int iy = INTEGER_ELT(y, k); if (iy == NA_INTEGER) { px[ij].r = NA_REAL; px[ij].i = NA_REAL; } else { px[ij].r = iy; px[ij].i = 0.0; } }); } break; case 1514: /* complex <- real */ { Rcomplex *px = COMPLEX(x); MATRIX_ASSIGN_LOOP({ double ry = REAL_ELT(y, k); if (ISNA(ry)) { px[ij].r = NA_REAL; px[ij].i = NA_REAL; } else { px[ij].r = ry; px[ij].i = 0.0; } }); } break; /* case 1015: logical <- complex */ /* case 1315: integer <- complex */ /* case 1415: real <- complex */ case 1515: /* complex <- complex */ { Rcomplex *px = COMPLEX(x); MATRIX_ASSIGN_LOOP(px[ij] = COMPLEX_ELT(y, k);); } 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 */ MATRIX_ASSIGN_LOOP(SET_STRING_ELT(x, ij, STRING_ELT(y, k));); break; case 1919: /* vector <- vector */ /* set NAMED or RHS values to NAMEDMAX if they might be used more than once (PR15098)*/ if (ny < ncs * nrs) for (R_xlen_t i = 0; i < ny; i++) ENSURE_NAMEDMAX(VECTOR_ELT(y, i)); MATRIX_ASSIGN_LOOP(SET_VECTOR_ELT(x, ij, VECTOR_ELT_FIX_NAMED(y, k));); break; case 2424: /* raw <- raw */ { Rbyte *px = RAW(x); MATRIX_ASSIGN_LOOP(px[ij] = RAW_ELT(y, k);); } break; default: error(_("incompatible types (from %s to %s) in matrix subset assignment"), R_typeToChar(x), R_typeToChar(y)); } UNPROTECT(2); return x; } #define ARRAY_ASSIGN_LOOP(CODE) do { \ R_xlen_t i, iny; \ MOD_ITERATE1(n, ny, i, iny, { \ R_xlen_t ii = 0; \ for (int j = 0; j < k; j++) { \ int jj = subs[j][indx[j]]; \ if (jj == NA_INTEGER) { \ ii = NA_INTEGER; \ break; \ } \ else \ ii += (jj - 1) * offset[j]; \ } \ if (ii != NA_INTEGER) \ do { CODE } while (0); \ if (n > 1) { \ int j = 0; \ while (++indx[j] >= bound[j]) { \ indx[j] = 0; \ j++; \ if (j == k) j = 0; \ } \ } \ }); \ } while (0) static SEXP ArrayAssign(SEXP call, SEXP rho, SEXP x, SEXP s, SEXP y) { int k = 0; SEXP dims, tmp; const void *vmax = vmaxget(); PROTECT(dims = getAttrib(x, R_DimSymbol)); if (dims == R_NilValue || (k = LENGTH(dims)) != length(s)) error(_("incorrect number of subscripts")); /* k is now the number of dims */ const int **subs = (const int**) R_alloc(k, sizeof(int*)); int *indx = (int*) R_alloc(k, sizeof(int)); int *bound = (int*) R_alloc(k, sizeof(int)); R_xlen_t *offset = (R_xlen_t*) R_alloc(k, sizeof(R_xlen_t)); R_xlen_t ny = XLENGTH(y); /* Expand the list of subscripts. */ /* s is protected, so no GC problems here */ tmp = s; for (int i = 0; i < k; i++) { SETCAR(tmp, int_arraySubscript(i, CAR(tmp), dims, x, call)); tmp = CDR(tmp); } R_xlen_t n = 1; tmp = s; for (int i = 0; i < k; i++) { indx[i] = 0; subs[i] = INTEGER_RO(CAR(tmp)); bound[i] = LENGTH(CAR(tmp)); n *= bound[i]; tmp = CDR(tmp); } if (n > 0 && ny == 0) error(_("replacement has length zero")); if (n > 0 && n % ny) error(_("number of items to replace is not a multiple of replacement length")); if (ny > 1) { /* check for NAs in indices */ for (int i = 0; i < k; i++) for (int j = 0; j < bound[i]; j++) if (subs[i][j] == NA_INTEGER) error(_("NAs are not allowed in subscripted assignments")); } offset[0] = 1; const int *pdims = INTEGER_RO(dims); for (int i = 1; i < k; i++) offset[i] = offset[i - 1] * pdims[i - 1]; /* Here we make sure that the LHS has been coerced into */ /* a form which can accept elements from the RHS. */ int which = SubassignTypeFix(&x, &y, 0, 1, call, rho);/* = 100 * TYPEOF(x) + TYPEOF(y);*/ if (n == 0) { UNPROTECT(1); return(x); } PROTECT(x); /* When array elements are being permuted the RHS */ /* must be duplicated or the elements get trashed. */ /* FIXME : this should be a shallow copy for list */ /* objects. A full duplication is wasteful. */ if (x == y) PROTECT(y = shallow_duplicate(y)); else PROTECT(y); /* Note that we are now committed. Since we are mutating */ /* existing objects any changes we make now are permanent. */ /* Beware! */ switch (which) { case 1010: /* logical <- logical */ case 1310: /* integer <- logical */ /* case 1013: logical <- integer */ case 1313: /* integer <- integer */ { int *px = INTEGER(x); ARRAY_ASSIGN_LOOP(px[ii] = INTEGER_ELT(y, iny);); } break; case 1410: /* real <- logical */ case 1413: /* real <- integer */ { double *px = REAL(x); ARRAY_ASSIGN_LOOP({ int iy = INTEGER_ELT(y, iny); if (iy == NA_INTEGER) px[ii] = NA_REAL; else px[ii] = iy; }); } break; /* case 1014: logical <- real */ /* case 1314: integer <- real */ case 1414: /* real <- real */ { double *px = REAL(x); ARRAY_ASSIGN_LOOP(px[ii] = REAL_ELT(y, iny);); } break; case 1510: /* complex <- logical */ case 1513: /* complex <- integer */ { Rcomplex *px = COMPLEX(x); ARRAY_ASSIGN_LOOP({ int iy = INTEGER_ELT(y, iny); if (iy == NA_INTEGER) { px[ii].r = NA_REAL; px[ii].i = NA_REAL; } else { px[ii].r = iy; px[ii].i = 0.0; } }); } break; case 1514: /* complex <- real */ { Rcomplex *px = COMPLEX(x); ARRAY_ASSIGN_LOOP({ double ry = REAL_ELT(y, iny); if (ISNA(ry)) { px[ii].r = NA_REAL; px[ii].i = NA_REAL; } else { px[ii].r = ry; px[ii].i = 0.0; } }); } break; /* case 1015: logical <- complex */ /* case 1315: integer <- complex */ /* case 1415: real <- complex */ case 1515: /* complex <- complex */ { Rcomplex *px = COMPLEX(x); ARRAY_ASSIGN_LOOP(px[ii] = COMPLEX_ELT(y, iny);); } 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 */ ARRAY_ASSIGN_LOOP(SET_STRING_ELT(x, ii, STRING_ELT(y, iny));); break; case 1919: /* vector <- vector */ ARRAY_ASSIGN_LOOP({ /* set NAMED on RHS value to NAMEDMAX if used more than once (PR15098) */ if (i >= ny) ENSURE_NAMEDMAX(VECTOR_ELT(y, iny)); SET_VECTOR_ELT(x, ii, VECTOR_ELT_FIX_NAMED(y, iny)); }); break; case 2424: /* raw <- raw */ { Rbyte *px = RAW(x); ARRAY_ASSIGN_LOOP(px[ii] = RAW_ELT(y, iny);); } break; default: error(_("incompatible types (from %s to %s) in array subset assignment"), R_typeToChar(x), R_typeToChar(y)); } UNPROTECT(3); vmaxset(vmax); return x; } /* Use for pairlists */ static SEXP GetOneIndex(SEXP sub, int ind) { if (ind < 0 || ind+1 > length(sub)) error("internal error: index %d from length %d", ind, length(sub)); if (length(sub) > 1) { switch (TYPEOF(sub)) { case INTSXP: sub = ScalarInteger(INTEGER_ELT(sub, ind)); break; case REALSXP: sub = ScalarReal(REAL_ELT(sub, ind)); break; case STRSXP: sub = ScalarString(STRING_ELT(sub, ind)); break; default: error(_("invalid subscript in list assign")); } } return sub; } /* This is only used for [[<-, so only adding one element */ static SEXP SimpleListAssign(SEXP call, SEXP x, SEXP s, SEXP y, int ind, Rboolean check_cycles) { SEXP indx, sub = CAR(s); int ii, n, nx; R_xlen_t stretch = 1; if (length(s) > 1) error(_("invalid number of subscripts to list assign")); PROTECT(sub = GetOneIndex(sub, ind)); PROTECT(indx = makeSubscript(x, sub, &stretch, R_NilValue)); n = length(indx); if (n > 1) error(_("invalid subscript in list assign")); nx = length(x); if (stretch) { SEXP t = CAR(s); SEXP yi = PROTECT(allocList((int)(stretch - nx))); /* This is general enough for only usage */ if(isString(t) && length(t) == stretch - nx) { SEXP z = yi; int i; for(i = 0; i < LENGTH(t); i++, z = CDR(z)) SET_TAG(z, installTrChar(STRING_ELT(t, i))); } UNPROTECT(1); PROTECT(x = listAppend(x, yi)); nx = (int) stretch; } else PROTECT(x); if (n == 1) { ii = asInteger(indx); if (ii != NA_INTEGER) { ii = ii - 1; SEXP xi = nthcdr(x, ii % nx); if (MAYBE_SHARED(y) && CAR(xi) != y) y = R_FixupRHS(x, y); SETCAR(xi, y); } } UNPROTECT(3); return x; } /* This is for x[[s[ind]]] <- NULL */ static SEXP listRemove(SEXP x, SEXP s, int ind) { SEXP pv, px, val; int i, ii, *indx, ns, nx; R_xlen_t stretch=0; const void *vmax = vmaxget(); nx = length(x); PROTECT(s = GetOneIndex(s, ind)); PROTECT(s = makeSubscript(x, s, &stretch, R_NilValue)); ns = length(s); indx = (int*) R_alloc(nx, sizeof(int)); for (i = 0; i < nx; i++) indx[i] = 1; if (TYPEOF(s) == REALSXP) { for (i = 0; i < ns; i++) { double di = REAL_ELT(s, i); if (R_FINITE(di)) indx[(R_xlen_t) di - 1] = 0; } } else { for (i = 0; i < ns; i++) { ii = INTEGER_ELT(s, i); if (ii != NA_INTEGER) indx[ii - 1] = 0; } } px = x; pv = val = R_NilValue; for (i = 0; i < nx; i++) { if (indx[i]) { if (val == R_NilValue) val = px; pv = px; } else { /* The current cell, to which px points, is removed and is no longer accessible, so we can decrement the reference count on it's fields. */ DECREMENT_REFCNT(CAR(px)); DECREMENT_REFCNT(CDR(px)); if (pv != R_NilValue) SETCDR(pv, CDR(px)); } px = CDR(px); } if (val != R_NilValue) { SET_ATTRIB(val, ATTRIB(x)); IS_S4_OBJECT(x) ? SET_S4_OBJECT(val) : UNSET_S4_OBJECT(val); SET_OBJECT(val, OBJECT(x)); RAISE_NAMED(val, NAMED(x)); } UNPROTECT(2); vmaxset(vmax); return val; } // For x[s] <- y --- extract (x, s, y) and return the number of indices static R_INLINE int SubAssignArgs(SEXP args, SEXP *x, SEXP *s, SEXP *y) { if (CDR(args) == R_NilValue) error(_("SubAssignArgs: invalid number of arguments")); *x = CAR(args); if (CDDR(args) == R_NilValue) { *s = R_NilValue; *y = CADR(args); return 0; } else { int nsubs = 1; SEXP p; *s = p = CDR(args); while (CDDR(p) != R_NilValue) { p = CDR(p); nsubs++; } *y = CADR(p); SETCDR(p, R_NilValue); return nsubs; } } /* Version of DispatchOrEval for "[" and friends that speeds up simple cases. Also defined in subset.c */ static R_INLINE int R_DispatchOrEvalSP(SEXP call, SEXP op, const char *generic, SEXP args, SEXP rho, SEXP *ans) { SEXP prom = NULL; if (args != R_NilValue && CAR(args) != R_DotsSymbol) { SEXP x = eval(CAR(args), rho); PROTECT(x); INCREMENT_LINKS(x); if (! OBJECT(x)) { *ans = CONS_NR(x, evalListKeepMissing(CDR(args), rho)); DECREMENT_LINKS(x); UNPROTECT(1); return FALSE; } prom = R_mkEVPROMISE_NR(CAR(args), x); args = CONS(prom, CDR(args)); UNPROTECT(1); } PROTECT(args); int disp = DispatchOrEval(call, op, generic, args, rho, ans, 0, 0); if (prom) DECREMENT_LINKS(PRVALUE(prom)); UNPROTECT(1); return disp; } /* The [<- operator. "x" is the vector that is to be assigned into, */ /* y is the vector that is going to provide the new values and subs is */ /* the vector of subscripts that are going to be replaced. */ /* On entry (CAR(args)) and the last argument have been evaluated */ /* and the remainder of args have not. If this was called directly */ /* the CAR(args) and the last arg won't have been. */ attribute_hidden SEXP do_subassign(SEXP call, SEXP op, SEXP args, SEXP rho) { SEXP ans; /* This code performs an internal version of method dispatch. */ /* We evaluate the first argument and attempt to dispatch on it. */ /* If the dispatch fails, we "drop through" to the default code below. */ /* DispatchOrEval internal generic: [<- */ if(R_DispatchOrEvalSP(call, op, "[<-", args, rho, &ans)) /* if(DispatchAnyOrEval(call, op, "[<-", args, rho, &ans, 0, 0)) */ return(ans); return do_subassign_dflt(call, op, ans, rho); } NORET static void errorNotSubsettable(SEXP x) { SEXP call = R_CurrentExpression; /* behave like error() */ SEXP cond = R_makeNotSubsettableError(x, call); R_signalErrorCondition(cond, call); UNPROTECT(1); /* cond; not reached */ } NORET static void errorMissingSubscript(SEXP x) { SEXP call = R_CurrentExpression; /* behave like error() */ SEXP cond = R_makeMissingSubscriptError(x, call); R_signalErrorCondition(cond, call); UNPROTECT(1); /* cond; not reached */ } attribute_hidden SEXP do_subassign_dflt(SEXP call, SEXP op, SEXP args, SEXP rho) { SEXP subs, x, y; int nsubs, oldtype; PROTECT(args); nsubs = SubAssignArgs(args, &x, &subs, &y); PROTECT(y); /* gets cut loose in SubAssignArs */ /* 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 as.vector(permute) */ for (SEXP s = subs; s != R_NilValue; s = CDR(s)) { SEXP idx = CAR(s); if (x == idx) MARK_NOT_MUTABLE(x); } /* 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)) || ((! IS_ASSIGNMENT_CALL(call)) && MAYBE_REFERENCED(CAR(args)))) x = SETCAR(args, shallow_duplicate(CAR(args))); Rboolean S4 = IS_S4_OBJECT(x); // {before it is changed} oldtype = 0; if (TYPEOF(x) == LISTSXP || TYPEOF(x) == LANGSXP) { oldtype = TYPEOF(x); PROTECT(x = PairToVectorList(x)); } else if (xlength(x) == 0) { if (xlength(y) == 0 && (isNull(x) || TYPEOF(x) == TYPEOF(y) || // isVectorList(y): TYPEOF(y) == VECSXP || TYPEOF(y) == EXPRSXP)) { UNPROTECT(2); /* args, y */ return(x); } else { /* bug PR#2590 coerce only if null */ if(isNull(x)) PROTECT(x = coerceVector(x, TYPEOF(y))); else PROTECT(x); } } else { PROTECT(x); } switch (TYPEOF(x)) { case LGLSXP: case INTSXP: case REALSXP: case CPLXSXP: case STRSXP: case EXPRSXP: case VECSXP: case RAWSXP: switch (nsubs) { case 0: x = VectorAssign(call, rho, x, R_MissingArg, y); break; case 1: x = VectorAssign(call, rho, x, CAR(subs), y); break; case 2: x = MatrixAssign(call, rho, x, subs, y); break; default: x = ArrayAssign(call, rho, x, subs, y); break; } break; default: errorNotSubsettable(x); break; } if (oldtype == LANGSXP) { if(length(x)) { x = VectorToPairList(x); SET_TYPEOF(x, LANGSXP); } 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. */ UNPROTECT(3); /* args, x, y */ SETTER_CLEAR_NAMED(x); if(S4) SET_S4_OBJECT(x); return x; } static SEXP DeleteOneVectorListItem(SEXP x, R_xlen_t which) { SEXP y, xnames, ynames; R_xlen_t i, k, n; n = xlength(x); if (0 <= which && which < n) { PROTECT(y = allocVector(TYPEOF(x), n - 1)); k = 0; for (i = 0 ; i < n; i++) { if(i != which) SET_VECTOR_ELT(y, k++, VECTOR_ELT(x, i)); } PROTECT(xnames = getAttrib(x, R_NamesSymbol)); if (xnames != R_NilValue) { PROTECT(ynames = allocVector(STRSXP, n - 1)); k = 0; for (i = 0 ; i < n; i++) if(i != which) SET_STRING_ELT(ynames, k++, STRING_ELT(xnames, i)); setAttrib(y, R_NamesSymbol, ynames); UNPROTECT(1); } copyMostAttrib(x, y); UNPROTECT(2); return y; } return x; } /* The [[<- operator; should be fast. * ==== * args[1] =: x = object being subscripted * args[2] =: subs = list of subscripts * args[3] =: y = replacement values */ attribute_hidden SEXP do_subassign2(SEXP call, SEXP op, SEXP args, SEXP rho) { SEXP ans; /* DispatchOrEval internal generic: [[<- */ if(R_DispatchOrEvalSP(call, op, "[[<-", args, rho, &ans)) /* if(DispatchAnyOrEval(call, op, "[[<-", args, rho, &ans, 0, 0)) */ return(ans); return do_subassign2_dflt(call, op, ans, rho); } NORET static void errorOutOfBoundsSEXP(SEXP x, int subscript, SEXP sindex) { SEXP call = R_CurrentExpression; /* default behaves like error() */ SEXP cond = R_makeOutOfBoundsError(x, subscript, sindex, call, "[[ ]]"); PROTECT(cond); R_signalErrorCondition(cond, call); UNPROTECT(1); /* cond; not reached */ } 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, nsubs, which, len = 0 /* -Wall */; R_xlen_t stretch, offset, off = -1; /* -Wall */ PROTECT(args); 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). */ if (isNull(x)) { if (isNull(y)) { UNPROTECT(2); /* args, y */ return x; } #ifdef NO_LONGER_IN_R_4_x_y if (length(y) == 1) x = allocVector(TYPEOF(y), 0); else #endif 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) || ((! IS_ASSIGNMENT_CALL(call)) && MAYBE_REFERENCED(x))) SETCAR(args, x = shallow_duplicate(x)); /* code to allow classes to extend ENVSXP */ Rboolean S4 = IS_S4_OBJECT(x); if(S4 && TYPEOF(x) == OBJSXP) { 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")); } PROTECT(x); xtop = xup = x; /* x will be the element which is assigned to */ dims = getAttrib(x, R_DimSymbol); ndims = length(dims); int *pdims = NULL; if (ndims > 0) { if (TYPEOF(dims) == INTSXP) pdims = INTEGER(dims); else error(_("improper dimensions")); } /* ENVSXP special case first */ if( TYPEOF(x) == ENVSXP) { if( nsubs!=1 || !isString(CAR(subs)) || length(CAR(subs)) != 1 ) error(_("wrong args for environment subassignment")); defineVar(installTrChar(STRING_ELT(CAR(subs), 0)), y, x); UNPROTECT(3); /* x, args, y */ return(S4 ? xOrig : x); } /* new case in 1.7.0, one vector index for a list, more general as of 2.10.0 */ Rboolean recursed = FALSE; if (nsubs == 1) { thesub = CAR(subs); len = 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. */ PROTECT(xup); off = OneIndex(xup, thesub, xlength(xup), 0, &newname, len-2, R_NilValue); x = vectorIndex(xup, thesub, len-2, len-1, TRUE, call, TRUE); UNPROTECT(2); /* xup, x */ PROTECT(x); recursed = TRUE; } } PROTECT(xup); 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) errorMissingSubscript(x); if (nsubs == 1) { offset = OneIndex(x, thesub, xlength(x), 0, &newname, recursed ? len-1 : -1, R_NilValue); if (isVectorList(x) && isNull(y)) { SEXP old_x = x; x = DeleteOneVectorListItem(x, offset); if(recursed) { if(isVectorList(xup)) SET_VECTOR_ELT(xup, off, x); else { PROTECT(x); xup = SimpleListAssign(call, xup, subs, x, len-2, FALSE); UNPROTECT(1); /* x */ } } else { xtop = x; if (old_x != x) CLEAR_VECTOR(old_x); } UNPROTECT(4); /* xup, x, args, y */ return xtop; } if (offset < 0) errorOutOfBoundsSEXP(x, -1, thesub); if (offset >= XLENGTH(x)) stretch = offset + 1; } else { if (ndims != nsubs) error(_("[[ ]] improper number of subscripts")); PROTECT(indx = allocVector(INTSXP, ndims)); int *pindx = INTEGER0(indx); names = getAttrib(x, R_DimNamesSymbol); for (i = 0; i < ndims; i++) { SEXP thesub = CAR(subs); pindx[i] = (int) get1index(thesub, isNull(names) ? R_NilValue : VECTOR_ELT(names, i), pdims[i], /*partial ok*/FALSE, -1, call); subs = CDR(subs); if (pindx[i] < 0 || pindx[i] >= pdims[i]) errorOutOfBoundsSEXP(x, i, thesub); } offset = 0; for (i = (ndims - 1); i > 0; i--) offset = (offset + pindx[i]) * pdims[i - 1]; offset += pindx[0]; UNPROTECT(1); /* indx */ } SEXP old_x = x; which = SubassignTypeFix(&x, &y, stretch, 2, call, rho); PROTECT(x); PROTECT(y); 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_ELT(y, 0); break; case 1410: /* real <- logical */ case 1413: /* real <- integer */ if (INTEGER_ELT(y, 0) == NA_INTEGER) REAL(x)[offset] = NA_REAL; else REAL(x)[offset] = INTEGER_ELT(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_ELT(y, 0) == NA_INTEGER) { COMPLEX(x)[offset].r = NA_REAL; COMPLEX(x)[offset].i = NA_REAL; } else { COMPLEX(x)[offset].r = INTEGER_ELT(y, 0); COMPLEX(x)[offset].i = 0.0; } break; case 1514: /* complex <- real */ if (ISNA(REAL_ELT(y, 0))) { COMPLEX(x)[offset].r = NA_REAL; COMPLEX(x)[offset].i = NA_REAL; } else { COMPLEX(x)[offset].r = REAL_ELT(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_ELT(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 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 */ /* drop through: vectors and expressions are treated the same */ case 2001: /* expression <- symbol */ 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 1919: /* vector <- vector */ case 2020: /* expression <- expression */ if (MAYBE_REFERENCED(y) && VECTOR_ELT(x, offset) != y) y = R_FixupRHS(x, y); SET_VECTOR_ELT(x, offset, y); break; case 2424: /* raw <- raw */ RAW(x)[offset] = RAW_ELT(y, 0); break; default: error(_("incompatible types (from %s to %s) in [[ assignment"), R_typeToChar(x), R_typeToChar(y)); } /* 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, length(x))); SET_STRING_ELT(names, offset, newname); setAttrib(x, R_NamesSymbol, names); UNPROTECT(1); /* names */ } else SET_STRING_ELT(names, offset, newname); } if (old_x != x && ! recursed) // might be safe even if recursed is TRUE, but avoid for now CLEAR_VECTOR(old_x); UNPROTECT(4); /* y, x, xup, x */ PROTECT(x); PROTECT(xup); } else if (isPairList(x)) { PROTECT(y); if (nsubs == 1) { if (isNull(y)) { x = listRemove(x, CAR(subs), len-1); } else { x = SimpleListAssign(call, x, subs, y, len-1, TRUE); } } else { if (ndims != nsubs) error(_("[[ ]] improper number of subscripts")); PROTECT(indx = allocVector(INTSXP, ndims)); int *pindx = INTEGER0(indx); names = getAttrib(x, R_DimNamesSymbol); for (i = 0; i < ndims; i++) { SEXP thesub = CAR(subs); pindx[i] = (int) get1index(thesub, VECTOR_ELT(names, i), pdims[i], /*partial ok*/FALSE, -1, call); subs = CDR(subs); if (pindx[i] < 0 || pindx[i] >= pdims[i]) errorOutOfBoundsSEXP(x, i, thesub); } offset = 0; for (i = (ndims - 1); i > 0; i--) offset = (offset + pindx[i]) * pdims[i - 1]; offset += pindx[0]; SEXP slot = nthcdr(x, (int) offset); SETCAR(slot, duplicate(y)); /* FIXME: add name */ UNPROTECT(1); /* indx */ } UNPROTECT(3); /* y, xup, x */ PROTECT(x); PROTECT(xup); } else errorNotSubsettable(x); if(recursed) { if (isVectorList(xup)) { SET_VECTOR_ELT(xup, off, x); } else { xup = SimpleListAssign(call, xup, subs, x, len-2, FALSE); } if (len == 2) xtop = xup; } else xtop = x; UNPROTECT(4); /* xup, x, args, y */ SETTER_CLEAR_NAMED(xtop); if(S4) SET_S4_OBJECT(xtop); return xtop; } /* $<-(x, elt, val), and elt does not get evaluated it gets matched. to get DispatchOrEval to work we need to first translate it to a string */ attribute_hidden SEXP do_subassign3(SEXP call, SEXP op, SEXP args, SEXP env) { SEXP ans, nlist = R_NilValue; checkArity(op, args); /* Note the RHS has already been evaluated at this point */ PROTECT(args = fixSubset3Args(call, args, env, &nlist)); /* DispatchOrEval internal generic: $<- */ if(R_DispatchOrEvalSP(call, op, "$<-", args, env, &ans)) { UNPROTECT(1); /* args */ return(ans); } PROTECT(ans); if (nlist == R_NilValue) nlist = installTrChar(STRING_ELT(CADR(args), 0)); ans = R_subassign3_dflt(call, CAR(ans), nlist, CADDR(ans)); UNPROTECT(2); /* args, ans */ return ans; } /* used in "$<-" (above) and methods_list_dispatch.c */ SEXP R_subassign3_dflt(SEXP call, SEXP x, SEXP nlist, SEXP val) { SEXP t; PROTECT_INDEX pvalidx, pxidx; Rboolean S4; SEXP xS4 = R_NilValue; int nprotect = 0; PROTECT_WITH_INDEX(x, &pxidx); PROTECT_WITH_INDEX(val, &pvalidx); nprotect += 2; S4 = IS_S4_OBJECT(x); if (MAYBE_SHARED(x) || ((! IS_ASSIGNMENT_CALL(call)) && MAYBE_REFERENCED(x))) REPROTECT(x = shallow_duplicate(x), pxidx); /* code to allow classes to extend ENVSXP */ if(TYPEOF(x) == OBJSXP) { xS4 = x; REPROTECT(x = R_getS4DataSlot(x, ANYSXP), pxidx); if(x == R_NilValue) errorcall(call, _("no method for assigning subsets of this S4 class")); } if ((isList(x) || isLanguage(x)) && !isNull(x)) { if (TAG(x) == nlist) { if (val == R_NilValue) { SET_ATTRIB(CDR(x), ATTRIB(x)); IS_S4_OBJECT(x) ? SET_S4_OBJECT(CDR(x)) : UNSET_S4_OBJECT(CDR(x)); SET_OBJECT(CDR(x), OBJECT(x)); RAISE_NAMED(CDR(x), NAMED(x)); SETCAR(x, R_NilValue); // decrements REFCNT x = CDR(x); } else { /* Here we need to check for cycles*/ if (MAYBE_REFERENCED(val) && CAR(x) != val) REPROTECT(val = R_FixupRHS(x, val), pvalidx); SETCAR(x, val); } } else { for (t = x; t != R_NilValue; t = CDR(t)) if (TAG(CDR(t)) == nlist) { if (val == R_NilValue) { SETCAR(CDR(t), R_NilValue); // decrements REFCNT SETCDR(t, CDDR(t)); } else { /* Here we need to check for cycles*/ if (MAYBE_REFERENCED(val) && CADR(t) != val) REPROTECT(val = R_FixupRHS(x, val), pvalidx); SETCAR(CDR(t), val); } break; } else if (CDR(t) == R_NilValue && val != R_NilValue) { SETCDR(t, allocSExp(LISTSXP)); SET_TAG(CDR(t), nlist); if (MAYBE_REFERENCED(val)) ENSURE_NAMEDMAX(val); SETCADR(t, val); break; } } if (x == R_NilValue && val != R_NilValue) { x = allocList(1); if (MAYBE_REFERENCED(val)) ENSURE_NAMEDMAX(val); SETCAR(x, val); SET_TAG(x, nlist); } } /* cannot use isEnvironment since we do not want NULL here */ else if( TYPEOF(x) == ENVSXP ) { defineVar(nlist, val, x); INCREMENT_NAMED(val); } else if( TYPEOF(x) == SYMSXP || /* Used to 'work' in R < 2.8.0 */ TYPEOF(x) == CLOSXP || TYPEOF(x) == SPECIALSXP || TYPEOF(x) == BUILTINSXP) { errorNotSubsettable(x); } else { R_xlen_t i, imatch, nx; SEXP names; int type = VECSXP; if (isExpression(x)) type = EXPRSXP; else if (!isNewList(x)) { warning(_("Coercing LHS to a list")); REPROTECT(x = coerceVector(x, VECSXP), pxidx); } names = PROTECT(getAttrib(x, R_NamesSymbol)); nprotect++; nx = xlength(x); nlist = PRINTNAME(nlist); if (isNull(val)) { /* If "val" is NULL, this is an element deletion */ /* if there is a match to "nlist" otherwise "x" */ /* is unchanged. The attributes need adjustment. */ if (names != R_NilValue) { imatch = -1; for (i = 0; i < nx; i++) if (NonNullStringMatch(STRING_ELT(names, i), nlist)) { imatch = i; break; } if (imatch >= 0) { SEXP ans, ansnames; int ii; PROTECT(ans = allocVector(type, nx - 1)); PROTECT(ansnames = allocVector(STRSXP, nx - 1)); for (i = 0, ii = 0; i < nx; i++) { if (i != imatch) { SET_VECTOR_ELT(ans, ii, VECTOR_ELT(x, i)); SET_STRING_ELT(ansnames, ii, STRING_ELT(names, i)); ii++; } } setAttrib(ans, R_NamesSymbol, ansnames); copyMostAttrib(x, ans); UNPROTECT(2); CLEAR_VECTOR(x); // OK since x != ans x = ans; } /* else x is unchanged */ } } else { /* If "val" is non-NULL, we are either replacing */ /* an existing list element or we are adding a new */ /* element. */ imatch = -1; if (!isNull(names)) { for (i = 0; i < nx; i++) if (NonNullStringMatch(STRING_ELT(names, i), nlist)) { imatch = i; break; } } if (imatch >= 0) { /* We are just replacing an element */ /* Here we need to check for cycles*/ if (MAYBE_REFERENCED(val) && VECTOR_ELT(x, imatch) != val) REPROTECT(val = R_FixupRHS(x, val), pvalidx); SET_VECTOR_ELT(x, imatch, val); } else { /* We are introducing a new element (=> *no* duplication) */ /* Enlarge the list, add the new element */ /* and finally, adjust the attributes. */ SEXP ans, ansnames; PROTECT(ans = allocVector(VECSXP, nx + 1)); PROTECT(ansnames = allocVector(STRSXP, nx + 1)); for (i = 0; i < nx; i++) SET_VECTOR_ELT(ans, i, VECTOR_ELT(x, i)); if (isNull(names)) { for (i = 0; i < nx; i++) SET_STRING_ELT(ansnames, i, R_BlankString); } else { for (i = 0; i < nx; i++) SET_STRING_ELT(ansnames, i, STRING_ELT(names, i)); } if (MAYBE_REFERENCED(val)) ENSURE_NAMEDMAX(val); SET_VECTOR_ELT(ans, nx, val); SET_STRING_ELT(ansnames, nx, nlist); setAttrib(ans, R_NamesSymbol, ansnames); copyMostAttrib(x, ans); UNPROTECT(2); CLEAR_VECTOR(x); // OK since x != ans x = ans; } } } UNPROTECT(nprotect); if(xS4 != R_NilValue) x = xS4; /* x was an env't, the data slot of xS4 */ SETTER_CLEAR_NAMED(x); if(S4) SET_S4_OBJECT(x); return x; }