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;
}
