/* This is used for [[ and [[<- with a vector of indices of length > 1 . x is a list or pairlist, and it is indexed recusively from level start to level stop-1. ( 0...len-1 or 0..len-2 then len-1). For [[<- it needs to duplicate if substructure might be shared. */ SEXP attribute_hidden vectorIndex(SEXP x, SEXP thesub, int start, int stop, int pok, SEXP call, Rboolean dup) { int i; R_xlen_t offset; SEXP cx; /* sanity check */ if (dup && MAYBE_SHARED(x)) error("should only be called in an assignment context."); for(i = start; i < stop; i++) { if(!isVectorList(x) && !isPairList(x)) { if (i) errorcall(call, _("recursive indexing failed at level %d\n"), i+1); else errorcall(call, _("attempt to select more than one element")); } PROTECT(x); SEXP names = PROTECT(getAttrib(x, R_NamesSymbol)); offset = get1index(thesub, names, xlength(x), pok, i, call); UNPROTECT(2); /* x, names */ if(offset < 0 || offset >= xlength(x)) errorcall(call, _("no such index at level %d\n"), i+1); if(isPairList(x)) { #ifdef LONG_VECTOR_SUPPORT if (offset > R_SHORT_LEN_MAX) error("invalid subscript for pairlist"); #endif cx = nthcdr(x, (int) offset); if (NAMED(x) > NAMED(CAR(cx))) SET_NAMED(CAR(x), NAMED(x)); x = CAR(cx); if (dup && MAYBE_SHARED(x)) { x = shallow_duplicate(x); SETCAR(cx, x); } } else { cx = x; x = VECTOR_ELT(x, offset); if (NAMED(cx) > NAMED(x)) SET_NAMED(x, NAMED(cx)); if (dup && MAYBE_SHARED(x)) { x = shallow_duplicate(x); SET_VECTOR_ELT(cx, offset, x); } } } return x; }
SEXP attribute_hidden do_subset2_dflt(SEXP call, SEXP op, SEXP args, SEXP rho) { SEXP ans, dims, dimnames, indx, subs, x; int i, ndims, nsubs; int drop = 1, pok, exact = -1; int named_x; R_xlen_t offset = 0; PROTECT(args); ExtractDropArg(args, &drop); /* Is partial matching ok? When the exact arg is NA, a warning is issued if partial matching occurs. */ exact = ExtractExactArg(args); if (exact == -1) pok = exact; else pok = !exact; x = CAR(args); /* This code was intended for compatibility with S, */ /* but in fact S does not do this. Will anyone notice? */ if (x == R_NilValue) { UNPROTECT(1); /* args */ return x; } /* Get the subscripting and dimensioning information */ /* and check that any array subscripting is compatible. */ subs = CDR(args); if(0 == (nsubs = length(subs))) errorcall(call, _("no index specified")); dims = getAttrib(x, R_DimSymbol); ndims = length(dims); if(nsubs > 1 && nsubs != ndims) errorcall(call, _("incorrect number of subscripts")); /* code to allow classes to extend environment */ if(TYPEOF(x) == S4SXP) { x = R_getS4DataSlot(x, ANYSXP); if(x == R_NilValue) errorcall(call, _("this S4 class is not subsettable")); } PROTECT(x); /* split out ENVSXP for now */ if( TYPEOF(x) == ENVSXP ) { if( nsubs != 1 || !isString(CAR(subs)) || length(CAR(subs)) != 1 ) errorcall(call, _("wrong arguments for subsetting an environment")); ans = findVarInFrame(x, installTrChar(STRING_ELT(CAR(subs), 0))); if( TYPEOF(ans) == PROMSXP ) { PROTECT(ans); ans = eval(ans, R_GlobalEnv); UNPROTECT(1); /* ans */ } else SET_NAMED(ans, 2); UNPROTECT(2); /* args, x */ if(ans == R_UnboundValue) return(R_NilValue); if (NAMED(ans)) SET_NAMED(ans, 2); return ans; } /* back to the regular program */ if (!(isVector(x) || isList(x) || isLanguage(x))) errorcall(call, R_MSG_ob_nonsub, type2char(TYPEOF(x))); named_x = NAMED(x); /* x may change below; save this now. See PR#13411 */ if(nsubs == 1) { /* vector indexing */ SEXP thesub = CAR(subs); int len = length(thesub); if (len > 1) { #ifdef SWITCH_TO_REFCNT if (IS_GETTER_CALL(call)) { /* this is (most likely) a getter call in a complex assighment so we duplicate as needed. The original x should have been duplicated if it might be shared */ if (MAYBE_SHARED(x)) error("getter call used outside of a complex assignment."); x = vectorIndex(x, thesub, 0, len-1, pok, call, TRUE); } else x = vectorIndex(x, thesub, 0, len-1, pok, call, FALSE); #else x = vectorIndex(x, thesub, 0, len-1, pok, call, FALSE); #endif named_x = NAMED(x); UNPROTECT(1); /* x */ PROTECT(x); } SEXP xnames = PROTECT(getAttrib(x, R_NamesSymbol)); offset = get1index(thesub, xnames, xlength(x), pok, len > 1 ? len-1 : -1, call); UNPROTECT(1); /* xnames */ if (offset < 0 || offset >= xlength(x)) { /* a bold attempt to get the same behaviour for $ and [[ */ if (offset < 0 && (isNewList(x) || isExpression(x) || isList(x) || isLanguage(x))) { UNPROTECT(2); /* args, x */ return R_NilValue; } else errorcall(call, R_MSG_subs_o_b); } } else { /* matrix indexing */ /* Here we use the fact that: */ /* CAR(R_NilValue) = R_NilValue */ /* CDR(R_NilValue) = R_NilValue */ int ndn; /* Number of dimnames. Unlikely to be anything but 0 or nsubs, but just in case... */ PROTECT(indx = allocVector(INTSXP, nsubs)); dimnames = getAttrib(x, R_DimNamesSymbol); ndn = length(dimnames); for (i = 0; i < nsubs; i++) { INTEGER(indx)[i] = (int) get1index(CAR(subs), (i < ndn) ? VECTOR_ELT(dimnames, i) : R_NilValue, INTEGER(indx)[i], pok, -1, call); subs = CDR(subs); if (INTEGER(indx)[i] < 0 || INTEGER(indx)[i] >= INTEGER(dims)[i]) errorcall(call, R_MSG_subs_o_b); } offset = 0; for (i = (nsubs - 1); i > 0; i--) offset = (offset + INTEGER(indx)[i]) * INTEGER(dims)[i - 1]; offset += INTEGER(indx)[0]; UNPROTECT(1); /* indx */ } if(isPairList(x)) { #ifdef LONG_VECTOR_SUPPORT if (offset > R_SHORT_LEN_MAX) error("invalid subscript for pairlist"); #endif ans = CAR(nthcdr(x, (int) offset)); if (named_x > NAMED(ans)) SET_NAMED(ans, named_x); } else if(isVectorList(x)) { /* did unconditional duplication before 2.4.0 */ ans = VECTOR_ELT(x, offset); if (named_x > NAMED(ans)) SET_NAMED(ans, named_x); } else { ans = allocVector(TYPEOF(x), 1); switch (TYPEOF(x)) { case LGLSXP: case INTSXP: INTEGER(ans)[0] = INTEGER(x)[offset]; break; case REALSXP: REAL(ans)[0] = REAL(x)[offset]; break; case CPLXSXP: COMPLEX(ans)[0] = COMPLEX(x)[offset]; break; case STRSXP: SET_STRING_ELT(ans, 0, STRING_ELT(x, offset)); break; case RAWSXP: RAW(ans)[0] = RAW(x)[offset]; break; default: UNIMPLEMENTED_TYPE("do_subset2", x); } } UNPROTECT(2); /* args, x */ return ans; }