int attribute_hidden R_TextBufferInit(TextBuffer *txtb, SEXP text) { int i, k, l, n; if (isString(text)) { // translateChar might allocate void *vmax = vmaxget(); n = length(text); l = 0; for (i = 0; i < n; i++) { if (STRING_ELT(text, i) != R_NilValue) { k = int( strlen(translateChar(STRING_ELT(text, i)))); if (k > l) l = k; } } vmaxset(vmax); txtb->vmax = vmax; txtb->buf = static_cast<unsigned char *>(CXXR_alloc(l+2, sizeof(char))); /* '\n' and '\0' */ txtb->bufp = txtb->buf; txtb->text = text; txtb->ntext = n; txtb->offset = 0; transferChars(txtb->buf, translateChar(STRING_ELT(txtb->text, txtb->offset))); txtb->offset++; return 1; } else { txtb->vmax = vmaxget(); txtb->buf = nullptr; txtb->bufp = nullptr; txtb->text = R_NilValue; txtb->ntext = 0; txtb->offset = 1; return 0; } }
SEXP attribute_hidden do_mapply(SEXP call, SEXP op, SEXP args, SEXP rho) { checkArity(op, args); SEXP f = CAR(args), varyingArgs = CADR(args), constantArgs = CADDR(args); int m, zero = 0; R_xlen_t *lengths, *counters, longest = 0; m = length(varyingArgs); SEXP vnames = PROTECT(getAttrib(varyingArgs, R_NamesSymbol)); Rboolean named = CXXRCONSTRUCT(Rboolean, vnames != R_NilValue); lengths = static_cast<R_xlen_t *>( CXXR_alloc(m, sizeof(R_xlen_t))); for (int i = 0; i < m; i++) { SEXP tmp1 = VECTOR_ELT(varyingArgs, i); lengths[i] = xlength(tmp1); if (isObject(tmp1)) { // possibly dispatch on length() /* Cache the .Primitive: unclear caching is worthwhile. */ static SEXP length_op = NULL; if (length_op == NULL) length_op = R_Primitive("length"); // DispatchOrEval() needs 'args' to be a pairlist SEXP ans, tmp2 = PROTECT(list1(tmp1)); if (DispatchOrEval(call, length_op, "length", tmp2, rho, &ans, 0, 1)) lengths[i] = R_xlen_t( (TYPEOF(ans) == REALSXP ? REAL(ans)[0] : asInteger(ans))); UNPROTECT(1); } if (lengths[i] == 0) zero++; if (lengths[i] > longest) longest = lengths[i]; } if (zero && longest) error(_("zero-length inputs cannot be mixed with those of non-zero length")); counters = static_cast<R_xlen_t *>( CXXR_alloc(m, sizeof(R_xlen_t))); memset(counters, 0, m * sizeof(R_xlen_t)); SEXP mindex = PROTECT(allocVector(VECSXP, m)); SEXP nindex = PROTECT(allocVector(VECSXP, m)); /* build a call like f(dots[[1]][[4]], dots[[2]][[4]], dots[[3]][[4]], d=7) */ SEXP fcall = R_NilValue; // -Wall if (constantArgs == R_NilValue) ; else if (isVectorList(constantArgs)) fcall = VectorToPairList(constantArgs); else error(_("argument 'MoreArgs' of 'mapply' is not a list")); PROTECT_INDEX fi; PROTECT_WITH_INDEX(fcall, &fi); Rboolean realIndx = CXXRCONSTRUCT(Rboolean, longest > INT_MAX); SEXP Dots = install("dots"); for (int j = m - 1; j >= 0; j--) { SET_VECTOR_ELT(mindex, j, ScalarInteger(j + 1)); SET_VECTOR_ELT(nindex, j, allocVector(realIndx ? REALSXP : INTSXP, 1)); SEXP tmp1 = PROTECT(lang3(R_Bracket2Symbol, Dots, VECTOR_ELT(mindex, j))); SEXP tmp2 = PROTECT(lang3(R_Bracket2Symbol, tmp1, VECTOR_ELT(nindex, j))); REPROTECT(fcall = CONS(tmp2, fcall), fi); UNPROTECT(2); if (named && CHAR(STRING_ELT(vnames, j))[0] != '\0') SET_TAG(fcall, installTrChar(STRING_ELT(vnames, j))); } REPROTECT(fcall = LCONS(f, fcall), fi); SEXP ans = PROTECT(allocVector(VECSXP, longest)); for (int i = 0; i < longest; i++) { for (int j = 0; j < m; j++) { counters[j] = (++counters[j] > lengths[j]) ? 1 : counters[j]; if (realIndx) REAL(VECTOR_ELT(nindex, j))[0] = double( counters[j]); else INTEGER(VECTOR_ELT(nindex, j))[0] = int( counters[j]); } SEXP tmp = eval(fcall, rho); if (NAMED(tmp)) tmp = duplicate(tmp); SET_VECTOR_ELT(ans, i, tmp); } for (int j = 0; j < m; j++) if (counters[j] != lengths[j]) warning(_("longer argument not a multiple of length of shorter")); UNPROTECT(5); return ans; }