| /* |
| * R : A Computer Language for Statistical Data Analysis |
| * Copyright (C) 1997-2017 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 |
| */ |
| |
| /* a temporary hack until the SET_REFCNT below is removed */ |
| #ifdef SWITCH_TO_REFCNT |
| # define USE_RINTERNALS |
| #endif |
| |
| #ifdef HAVE_CONFIG_H |
| #include <config.h> |
| #endif |
| |
| #include <Defn.h> |
| #include <Internal.h> |
| #include <R_ext/RS.h> /* for test of S4 objects */ |
| #include <R_ext/Itermacros.h> |
| |
| /* 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 |
| |
| /* This version of SET_VECTOR_ELT does not increment the REFCNT for |
| the new vector->element link. It assumes that the old vector is |
| becoming garbage and so it's references become no longer |
| accessible. */ |
| static R_INLINE void SET_VECTOR_ELT_NR(SEXP x, R_xlen_t i, SEXP v) |
| { |
| #ifdef COMPUTE_REFCNT_VALUES |
| int ref = REFCNT(v); |
| SET_VECTOR_ELT(x, i, v); |
| SET_REFCNT(v, ref); |
| #else |
| SET_VECTOR_ELT(x, i, v); |
| #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 %d to %d)"), |
| len, 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_NR(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 wich coerceVector should |
| fail; namely, S4SXP */ |
| static SEXP embedInVector(SEXP v, SEXP call) |
| { |
| SEXP ans; |
| warningcall(call, "implicit list embedding of S4 objects is deprecated"); |
| 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"))); |
| 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 */ |
| |
| 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 */ |
| |
| 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 */ |
| case 1325: /* integer <- S4 */ |
| case 1425: /* real <- S4 */ |
| case 1525: /* complex <- S4 */ |
| case 1625: /* character <- S4 */ |
| case 2425: /* raw <- S4 */ |
| 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"), |
| type2char(which%100), type2char(which/100)); |
| } |
| |
| 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++; |
| } |
| } |
| 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(2); |
| 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) |
| { |
| SEXP indx, newnames; |
| R_xlen_t i, ii, n, nx, ny, iny; |
| int which; |
| R_xlen_t stretch; |
| |
| /* 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); |
| UNPROTECT(2); /* dnames, s */ |
| PROTECT(s); |
| } |
| if (isInteger(s) || isReal(s)) { |
| s = mat2indsub(dim, s, R_NilValue); |
| UNPROTECT(1); |
| PROTECT(s); |
| } |
| } |
| } |
| |
| stretch = 1; |
| PROTECT(indx = makeSubscript(x, s, &stretch, R_NilValue)); |
| 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. */ |
| which = SubassignTypeFix(&x, &y, stretch, 1, call, rho); |
| /* = 100 * TYPEOF(x) + TYPEOF(y);*/ |
| if (n == 0) { |
| UNPROTECT(2); |
| return x; |
| } |
| ny = xlength(y); |
| nx = xlength(x); |
| |
| PROTECT(x); |
| |
| if ((TYPEOF(x) != VECSXP && TYPEOF(x) != EXPRSXP) || y != R_NilValue) { |
| 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")); |
| } |
| |
| |
| /* 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 */ |
| 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); |
| return x; |
| } |
| |
| 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; |
| |
| /* <TSL> 21Oct97 |
| if (length(y) == 0) |
| error("Replacement length is zero"); |
| </TSL> */ |
| |
| 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"), |
| type2char(which%100), type2char(which/100)); |
| } |
| 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"), |
| type2char(which%100), type2char(which/100)); |
| } |
| |
| 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) |
| { |
| 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); |
| 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. */ |
| |
| SEXP attribute_hidden 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. */ |
| |
| 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); |
| } |
| |
| SEXP attribute_hidden do_subassign_dflt(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP subs, x, y; |
| int nsubs, oldtype; Rboolean S4; |
| |
| 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))) |
| x = SETCAR(args, shallow_duplicate(CAR(args))); |
| |
| S4 = IS_S4_OBJECT(x); |
| |
| 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: |
| error(R_MSG_ob_nonsub, type2char(TYPEOF(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_NR(y, k++, VECTOR_ELT(x, i)); |
| 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(1); |
| 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 */ |
| SEXP attribute_hidden do_subassign2(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP ans; |
| |
| 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); |
| } |
| |
| SEXP attribute_hidden |
| 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 */ |
| Rboolean S4, recursed=FALSE; |
| |
| PROTECT(args); |
| |
| nsubs = SubAssignArgs(args, &x, &subs, &y); |
| PROTECT(y); /* gets cut loose in SubAssignArs */ |
| S4 = 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(2); /* args, y */ |
| return x; |
| } |
| if (length(y) == 1) |
| x = allocVector(TYPEOF(y), 0); |
| else |
| 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)) |
| SETCAR(args, x = shallow_duplicate(x)); |
| |
| /* 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")); |
| } |
| |
| 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 */ |
| 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) |
| error(_("[[ ]] with missing subscript")); |
| if (nsubs == 1) { |
| offset = OneIndex(x, thesub, xlength(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 { |
| PROTECT(x); |
| xup = SimpleListAssign(call, xup, subs, x, len-2); |
| UNPROTECT(1); /* x */ |
| } |
| } else xtop = x; |
| UNPROTECT(4); /* xup, x, args, y */ |
| 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)); |
| int *pindx = INTEGER0(indx); |
| names = getAttrib(x, R_DimNamesSymbol); |
| for (i = 0; i < ndims; i++) { |
| pindx[i] = (int) |
| get1index(CAR(subs), 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]) |
| error(_("[[ ]] subscript out of bounds")); |
| } |
| offset = 0; |
| for (i = (ndims - 1); i > 0; i--) |
| offset = (offset + pindx[i]) * pdims[i - 1]; |
| offset += pindx[0]; |
| UNPROTECT(1); /* indx */ |
| } |
| |
| 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 */ |
| |
| SET_VECTOR_ELT(x, offset, R_FixupRHS(x, y)); |
| break; |
| |
| case 2424: /* raw <- raw */ |
| |
| RAW(x)[offset] = RAW_ELT(y, 0); |
| break; |
| |
| default: |
| error(_("incompatible types (from %s to %s) in [[ assignment"), |
| type2char(which%100), type2char(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, length(x))); |
| SET_STRING_ELT(names, offset, newname); |
| setAttrib(x, R_NamesSymbol, names); |
| UNPROTECT(1); /* names */ |
| } |
| else |
| SET_STRING_ELT(names, offset, newname); |
| } |
| UNPROTECT(4); /* y, x, xup, x */ |
| PROTECT(x); |
| PROTECT(xup); |
| } |
| 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)); |
| int *pindx = INTEGER0(indx); |
| names = getAttrib(x, R_DimNamesSymbol); |
| for (i = 0; i < ndims; i++) { |
| pindx[i] = (int) |
| get1index(CAR(subs), VECTOR_ELT(names, i), |
| pdims[i], |
| /*partial ok*/FALSE, -1, call); |
| subs = CDR(subs); |
| if (pindx[i] < 0 || |
| pindx[i] >= pdims[i]) |
| error(_("[[ ]] subscript (%d) out of bounds"), i+1); |
| } |
| 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 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(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 |
| */ |
| SEXP attribute_hidden 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)); |
| |
| 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 maybe_duplicate=FALSE; |
| Rboolean S4; SEXP xS4 = R_NilValue; |
| |
| PROTECT_WITH_INDEX(x, &pxidx); |
| PROTECT_WITH_INDEX(val, &pvalidx); |
| S4 = IS_S4_OBJECT(x); |
| |
| if (MAYBE_SHARED(x)) |
| REPROTECT(x = shallow_duplicate(x), pxidx); |
| |
| /* If we aren't creating a new entry and NAMED>0 |
| we need to duplicate to prevent cycles. |
| If we are creating a new entry we could duplicate |
| or increase NAMED. We duplicate if NAMED == 1, but |
| not if NAMED > 1 */ |
| if (MAYBE_SHARED(val)) |
| maybe_duplicate=TRUE; |
| else if (MAYBE_REFERENCED(val)) |
| REPROTECT(val = R_FixupRHS(x, val), pvalidx); |
| /* code to allow classes to extend ENVSXP */ |
| if(TYPEOF(x) == S4SXP) { |
| 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)) { |
| /* Here we do need to duplicate */ |
| if (maybe_duplicate) |
| REPROTECT(val = R_FixupRHS(x, val), pvalidx); |
| 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)); |
| x = CDR(x); |
| } |
| else |
| SETCAR(x, val); |
| } |
| else { |
| for (t = x; t != R_NilValue; t = CDR(t)) |
| if (TAG(CDR(t)) == nlist) { |
| if (val == R_NilValue) |
| SETCDR(t, CDDR(t)); |
| else |
| SETCAR(CDR(t), val); |
| break; |
| } |
| else if (CDR(t) == R_NilValue && val != R_NilValue) { |
| SETCDR(t, allocSExp(LISTSXP)); |
| SET_TAG(CDR(t), nlist); |
| SETCADR(t, val); |
| break; |
| } |
| } |
| if (x == R_NilValue && val != R_NilValue) { |
| x = allocList(1); |
| 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); |
| } |
| else if( TYPEOF(x) == SYMSXP || /* Used to 'work' in R < 2.8.0 */ |
| TYPEOF(x) == CLOSXP || |
| TYPEOF(x) == SPECIALSXP || |
| TYPEOF(x) == BUILTINSXP) { |
| error(R_MSG_ob_nonsub, type2char(TYPEOF(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 = getAttrib(x, R_NamesSymbol); |
| 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); |
| 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 */ |
| if (maybe_duplicate) |
| 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_NR(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)); |
| } |
| SET_VECTOR_ELT(ans, nx, val); |
| SET_STRING_ELT(ansnames, nx, nlist); |
| setAttrib(ans, R_NamesSymbol, ansnames); |
| copyMostAttrib(x, ans); |
| UNPROTECT(2); |
| x = ans; |
| } |
| } |
| } |
| UNPROTECT(2); |
| 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; |
| } |