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