SEXP attribute_hidden do_rep_len(SEXP call, SEXP op, SEXP args, SEXP rho)
{
R_xlen_t ns, na;
SEXP a, s, len;
checkArity(op, args);
s = CAR(args);
if (!isVector(s) && s != R_NilValue)
error(_("attempt to replicate non-vector"));
len = CADR(args);
if(length(len) != 1)
error(_("invalid '%s' value"), "length.out");
#ifdef LONG_VECTOR_SUPPORT
double sna = asReal(len);
if (!R_FINITE(sna) || sna < 0)
error(_("invalid '%s' value"), "length.out");
na = (R_xlen_t) sna;
#else
if ((na = asInteger(len)) == NA_INTEGER || na < 0) /* na = 0 ok */
error(_("invalid '%s' value"), "length.out");
#endif
if (TYPEOF(s) == NILSXP && na > 0)
error(_("cannot replicate NULL to a non-zero length"));
ns = xlength(s);
if (ns == 0) {
SEXP a;
PROTECT(a = duplicate(s));
if(na > 0) a = xlengthgets(a, na);
UNPROTECT(1);
return a;
}
PROTECT(a = rep3(s, ns, na));
#ifdef _S4_rep_keepClass
if(IS_S4_OBJECT(s)) { /* e.g. contains = "list" */
setAttrib(a, R_ClassSymbol, getClassAttrib(s));
SET_S4_OBJECT(a);
}
#endif
if (inheritsCharSXP(s, R_FactorCharSXP)) {
SEXP tmp;
if(inheritsCharSXP(s, R_OrderedCharSXP)) {
PROTECT(tmp = allocVector(STRSXP, 2));
SET_STRING_ELT(tmp, 0, R_OrderedCharSXP);
SET_STRING_ELT(tmp, 1, R_FactorCharSXP);
} else PROTECT(tmp = mkString("factor"));
setAttrib(a, R_ClassSymbol, tmp);
UNPROTECT(1);
setAttrib(a, R_LevelsSymbol, getLevelsAttrib(s));
}
UNPROTECT(1);
return a;
}
SEXP attribute_hidden do_lengthgets(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP x, ans;
checkArity(op, args);
check1arg(args, call, "x");
x = CAR(args);
if (PRIMVAL(op)) { /* xlength<- */
if(isObject(x) && DispatchOrEval(call, op, "length<-", args,
rho, &ans, 0, 1))
return(ans);
if (!isVector(x) && !isVectorizable(x))
error(_("invalid argument"));
if (length(CADR(args)) != 1)
error(_("invalid value"));
R_xlen_t len = asVecSize(CADR(args));
return xlengthgets(x, len);
}
if(isObject(x) && DispatchOrEval(call, op, "length<-", args,
rho, &ans, 0, 1))
return(ans);
if (!isVector(x) && !isVectorizable(x))
error(_("invalid argument"));
if (length(CADR(args)) != 1)
error(_("invalid value"));
R_xlen_t len = asVecSize(CADR(args));
if (len < 0) error(_("invalid value"));
if (len > R_LEN_T_MAX) {
#ifdef LONG_VECTOR_SUPPORT
return xlengthgets(x, len);
#else
error(_("vector size specified is too large"));
return x; /* -Wall */
#endif
}
return lengthgets(x, (R_len_t) len);
}
SEXP getfmts(SEXP format)
{
int cnt, v, nfmt;
char fmt[MAXLINE+1], bit[MAXLINE+1];
const char *formatString;
size_t n, cur, chunk, maxlen = 0;
int nthis, nstar;
Rboolean use_UTF8;
SEXP res = PROTECT(allocVector(STRSXP, MAXNARGS));
#define SET_RESULT(n, s) { \
if (n >= MAXNARGS) error(_("only %d arguments are allowed"), MAXNARGS); \
maxlen = (n) < maxlen ? maxlen : (n) + 1; \
SET_STRING_ELT(res, (n), mkChar(s)); \
}
if (!isString(format)) error(_("'fmt' is not a character vector"));
nfmt = LENGTH(format);
if (nfmt != 1)
error(_("'fmt' must be length 1"));
use_UTF8 = getCharCE(STRING_ELT(format, 0)) == CE_UTF8;
formatString = TRANSLATE_CHAR(format, 0);
n = strlen(formatString);
if (n > MAXLINE)
error(_("'fmt' length exceeds maximal format length %d"), MAXLINE);
/* process the format string */
for (cur = 0, cnt = 0; cur < n; cur += chunk) {
const char *curFormat = formatString + cur;
char *starc;
if (formatString[cur] == '%') { /* handle special format command */
if (cur < n - 1 && formatString[cur + 1] == '%') {
/* take care of %% in the format */
chunk = 2;
strcpy(bit, "%");
}
else {
/* recognise selected types from Table B-1 of K&R */
/* NB: we deal with "%%" in branch above. */
/* This is MBCS-OK, as we are in a format spec */
/* Include formats c, u, p and n as well as the R formats; this needs to match */
/* C code as well */
chunk = strcspn(curFormat + 1, "diosfeEgGxXaAcupn") + 2;
if (cur + chunk > n)
error(_("unrecognised format specification '%s'"), curFormat);
strncpy(fmt, curFormat, chunk);
fmt[chunk] = '\0';
nthis = -1;
/* now look for %n$ or %nn$ form */
if (strlen(fmt) > 3 && fmt[1] >= '1' && fmt[1] <= '9') {
v = fmt[1] - '0';
if(fmt[2] == '$') {
nthis = v-1;
memmove(fmt+1, fmt+3, strlen(fmt)-2);
} else if(fmt[2] >= '0' && fmt[2] <= '9' && fmt[3] == '$') {
v = 10*v + fmt[2] - '0';
nthis = v-1;
memmove(fmt+1, fmt+4, strlen(fmt)-3);
}
}
starc = Rf_strchr(fmt, '*');
if (starc) { /* handle * format if present */
nstar = -1;
if (strlen(starc) > 3 && starc[1] >= '1' && starc[1] <= '9') {
v = starc[1] - '0';
if(starc[2] == '$') {
nstar = v-1;
memmove(starc+1, starc+3, strlen(starc)-2);
} else if(starc[2] >= '0' && starc[2] <= '9'
&& starc[3] == '$') {
v = 10*v + starc[2] - '0';
nstar = v-1;
memmove(starc+1, starc+4, strlen(starc)-3);
}
}
if(nstar < 0) {
nstar = cnt++;
}
if (Rf_strchr(starc+1, '*'))
error(_("at most one asterisk '*' is supported in each conversion specification"));
SET_RESULT(nstar, "*");
}
if (fmt[strlen(fmt) - 1] == '%') {
} else {
if(nthis < 0) {
nthis = cnt++;
}
SET_RESULT(nthis, fmt);
}
}
}
else { /* not '%' : handle string part */
char *ch = Rf_strchr(curFormat, '%'); /* MBCS-aware version used */
chunk = (ch) ? (size_t) (ch - curFormat) : strlen(curFormat);
strncpy(bit, curFormat, chunk);
bit[chunk] = '\0';
}
} /* end for ( each chunk ) */
res = xlengthgets(res, maxlen);
UNPROTECT(1);
return res;
}
/* This is a primitive SPECIALSXP with internal argument matching */
SEXP attribute_hidden do_rep(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans, x, times = R_NilValue /* -Wall */;
int each = 1, nprotect = 3;
R_xlen_t i, lx, len = NA_INTEGER, nt;
static SEXP do_rep_formals = NULL;
/* includes factors, POSIX[cl]t, Date */
if (DispatchOrEval(call, op, R_RepCharSXP, args, rho, &ans, 0, 0))
return(ans);
/* This has evaluated all the non-missing arguments into ans */
PROTECT(args = ans);
/* This is a primitive, and we have not dispatched to a method
so we manage the argument matching ourselves. We pretend this is
rep(x, times, length.out, each, ...)
*/
if (do_rep_formals == NULL) {
do_rep_formals = CONS(R_NilValue, list4(R_NilValue, R_NilValue, R_NilValue, R_NilValue));
R_PreserveObject(do_rep_formals);
SET_TAG(do_rep_formals, R_XSymbol);
SET_TAG(CDR(do_rep_formals), install("times"));
SET_TAG(CDDR(do_rep_formals), R_LengthOutSymbol);
SET_TAG(CDR(CDDR(do_rep_formals)), install("each"));
SET_TAG(CDDR(CDDR(do_rep_formals)), R_DotsSymbol);
}
PROTECT(args = matchArgs(do_rep_formals, args, call));
x = CAR(args);
/* supported in R 2.15.x */
if (TYPEOF(x) == LISTSXP)
errorcall(call, "replication of pairlists is defunct");
lx = xlength(x);
double slen = asReal(CADDR(args));
if (R_FINITE(slen)) {
if(slen < 0)
errorcall(call, _("invalid '%s' argument"), "length.out");
len = (R_xlen_t) slen;
} else {
len = asInteger(CADDR(args));
if(len != NA_INTEGER && len < 0)
errorcall(call, _("invalid '%s' argument"), "length.out");
}
if(length(CADDR(args)) != 1)
warningcall(call, _("first element used of '%s' argument"),
"length.out");
each = asInteger(CADDDR(args));
if(each != NA_INTEGER && each < 0)
errorcall(call, _("invalid '%s' argument"), "each");
if(length(CADDDR(args)) != 1)
warningcall(call, _("first element used of '%s' argument"), "each");
if(each == NA_INTEGER) each = 1;
if(lx == 0) {
if(len > 0 && x == R_NilValue)
warningcall(call, "'x' is NULL so the result will be NULL");
SEXP a;
PROTECT(a = duplicate(x));
if(len != NA_INTEGER && len > 0) a = xlengthgets(a, len);
UNPROTECT(3);
return a;
}
if (!isVector(x))
errorcall(call, "attempt to replicate an object of type '%s'",
type2char(TYPEOF(x)));
/* So now we know x is a vector of positive length. We need to
replicate it, and its names if it has them. */
/* First find the final length using 'times' and 'each' */
if(len != NA_INTEGER) { /* takes precedence over times */
nt = 1;
} else {
R_xlen_t sum = 0;
if(CADR(args) == R_MissingArg) PROTECT(times = ScalarInteger(1));
else PROTECT(times = coerceVector(CADR(args), INTSXP));
nprotect++;
nt = XLENGTH(times);
if(nt != 1 && nt != lx * each)
errorcall(call, _("invalid '%s' argument"), "times");
if(nt == 1) {
int it = INTEGER(times)[0];
if (it == NA_INTEGER || it < 0)
errorcall(call, _("invalid '%s' argument"), "times");
len = lx * it * each;
} else {
for(i = 0; i < nt; i++) {
int it = INTEGER(times)[i];
if (it == NA_INTEGER || it < 0)
errorcall(call, _("invalid '%s' argument"), "times");
sum += it;
}
len = sum;
}
}
if(len > 0 && each == 0)
errorcall(call, _("invalid '%s' argument"), "each");
SEXP xn = getNamesAttrib(x);
PROTECT(ans = rep4(x, times, len, each, nt));
if (length(xn) > 0)
setAttrib(ans, R_NamesSymbol, rep4(xn, times, len, each, nt));
#ifdef _S4_rep_keepClass
if(IS_S4_OBJECT(x)) { /* e.g. contains = "list" */
setAttrib(ans, R_ClassSymbol, getClassAttrib(x));
SET_S4_OBJECT(ans);
}
#endif
UNPROTECT(nprotect);
return ans;
}
/* public older version */
SEXP lengthgets(SEXP x, R_len_t len)
{
return xlengthgets(x, (R_xlen_t) len);
}
