/* PrintLanguage() or PrintClosure() : */ static void PrintLanguageEtc(SEXP s, Rboolean useSource, Rboolean isClosure) { int i; SEXP t = getAttrib(s, R_SrcrefSymbol); Rboolean useSrc = useSource && isInteger(t); if (useSrc) { PROTECT(t = lang2(R_AsCharacterSymbol, t)); t = eval(t, R_BaseEnv); UNPROTECT(1); } else { t = deparse1w(s, 0, useSource | DEFAULTDEPARSE); } PROTECT(t); for (i = 0; i < LENGTH(t); i++) { Rprintf("%s\n", translateChar(STRING_ELT(t, i))); // translate: for srcref part (PR#16732) } UNPROTECT(1); if (isClosure) { if (isByteCode(BODY(s))) Rprintf("<bytecode: %p>\n", BODY(s)); t = CLOENV(s); if (t != R_GlobalEnv) Rprintf("%s\n", EncodeEnvironment(t)); } }
/* format.default(x, trim, digits, nsmall, width, justify, na.encode, scientific) */ SEXP attribute_hidden do_format(SEXP call, SEXP op, SEXP args, SEXP env) { SEXP l, x, y, swd; int il, digits, trim = 0, nsmall = 0, wd = 0, adj = -1, na, sci = 0; int w, d, e; int wi, di, ei, scikeep; const char *strp; R_xlen_t i, n; checkArity(op, args); PrintDefaults(); scikeep = R_print.scipen; if (isEnvironment(x = CAR(args))) { return mkString(EncodeEnvironment(x)); } else if (!isVector(x)) error(_("first argument must be atomic")); args = CDR(args); trim = asLogical(CAR(args)); if (trim == NA_INTEGER) error(_("invalid '%s' argument"), "trim"); args = CDR(args); if (!isNull(CAR(args))) { digits = asInteger(CAR(args)); if (digits == NA_INTEGER || digits < R_MIN_DIGITS_OPT || digits > R_MAX_DIGITS_OPT) error(_("invalid '%s' argument"), "digits"); R_print.digits = digits; } args = CDR(args); nsmall = asInteger(CAR(args)); if (nsmall == NA_INTEGER || nsmall < 0 || nsmall > 20) error(_("invalid '%s' argument"), "nsmall"); args = CDR(args); if (isNull(swd = CAR(args))) wd = 0; else wd = asInteger(swd); if(wd == NA_INTEGER) error(_("invalid '%s' argument"), "width"); args = CDR(args); adj = asInteger(CAR(args)); if(adj == NA_INTEGER || adj < 0 || adj > 3) error(_("invalid '%s' argument"), "justify"); args = CDR(args); na = asLogical(CAR(args)); if(na == NA_LOGICAL) error(_("invalid '%s' argument"), "na.encode"); args = CDR(args); if(LENGTH(CAR(args)) != 1) error(_("invalid '%s' argument"), "scientific"); if(isLogical(CAR(args))) { int tmp = LOGICAL(CAR(args))[0]; if(tmp == NA_LOGICAL) sci = NA_INTEGER; else sci = tmp > 0 ?-100 : 100; } else if (isNumeric(CAR(args))) { sci = asInteger(CAR(args)); } else error(_("invalid '%s' argument"), "scientific"); if(sci != NA_INTEGER) R_print.scipen = sci; if ((n = XLENGTH(x)) <= 0) { PROTECT(y = allocVector(STRSXP, 0)); } else { switch (TYPEOF(x)) { case LGLSXP: PROTECT(y = allocVector(STRSXP, n)); if (trim) w = 0; else formatLogical(LOGICAL(x), n, &w); w = imax2(w, wd); for (i = 0; i < n; i++) { strp = EncodeLogical(LOGICAL(x)[i], w); SET_STRING_ELT(y, i, mkChar(strp)); } break; case INTSXP: PROTECT(y = allocVector(STRSXP, n)); if (trim) w = 0; else formatInteger(INTEGER(x), n, &w); w = imax2(w, wd); for (i = 0; i < n; i++) { strp = EncodeInteger(INTEGER(x)[i], w); SET_STRING_ELT(y, i, mkChar(strp)); } break; case REALSXP: formatReal(REAL(x), n, &w, &d, &e, nsmall); if (trim) w = 0; w = imax2(w, wd); PROTECT(y = allocVector(STRSXP, n)); for (i = 0; i < n; i++) { strp = EncodeReal0(REAL(x)[i], w, d, e, OutDec); SET_STRING_ELT(y, i, mkChar(strp)); } break; case CPLXSXP: formatComplex(COMPLEX(x), n, &w, &d, &e, &wi, &di, &ei, nsmall); if (trim) wi = w = 0; w = imax2(w, wd); wi = imax2(wi, wd); PROTECT(y = allocVector(STRSXP, n)); for (i = 0; i < n; i++) { strp = EncodeComplex(COMPLEX(x)[i], w, d, e, wi, di, ei, OutDec); SET_STRING_ELT(y, i, mkChar(strp)); } break; case STRSXP: { /* this has to be different from formatString/EncodeString as we don't actually want to encode here */ const char *s; char *q; int b, b0, cnt = 0, j; SEXP s0, xx; /* This is clumsy, but it saves rewriting and re-testing this complex code */ PROTECT(xx = duplicate(x)); for (i = 0; i < n; i++) { SEXP tmp = STRING_ELT(xx, i); if(IS_BYTES(tmp)) { const char *p = CHAR(tmp), *q; char *pp = R_alloc(4*strlen(p)+1, 1), *qq = pp, buf[5]; for (q = p; *q; q++) { unsigned char k = (unsigned char) *q; if (k >= 0x20 && k < 0x80) { *qq++ = *q; } else { snprintf(buf, 5, "\\x%02x", k); for(int j = 0; j < 4; j++) *qq++ = buf[j]; } } *qq = '\0'; s = pp; } else s = translateChar(tmp); if(s != CHAR(tmp)) SET_STRING_ELT(xx, i, mkChar(s)); } w = wd; if (adj != Rprt_adj_none) { for (i = 0; i < n; i++) if (STRING_ELT(xx, i) != NA_STRING) w = imax2(w, Rstrlen(STRING_ELT(xx, i), 0)); else if (na) w = imax2(w, R_print.na_width); } else w = 0; /* now calculate the buffer size needed, in bytes */ for (i = 0; i < n; i++) if (STRING_ELT(xx, i) != NA_STRING) { il = Rstrlen(STRING_ELT(xx, i), 0); cnt = imax2(cnt, LENGTH(STRING_ELT(xx, i)) + imax2(0, w-il)); } else if (na) cnt = imax2(cnt, R_print.na_width + imax2(0, w-R_print.na_width)); R_CheckStack2(cnt+1); char buff[cnt+1]; PROTECT(y = allocVector(STRSXP, n)); for (i = 0; i < n; i++) { if(!na && STRING_ELT(xx, i) == NA_STRING) { SET_STRING_ELT(y, i, NA_STRING); } else { q = buff; if(STRING_ELT(xx, i) == NA_STRING) s0 = R_print.na_string; else s0 = STRING_ELT(xx, i) ; s = CHAR(s0); il = Rstrlen(s0, 0); b = w - il; if(b > 0 && adj != Rprt_adj_left) { b0 = (adj == Rprt_adj_centre) ? b/2 : b; for(j = 0 ; j < b0 ; j++) *q++ = ' '; b -= b0; } for(j = 0; j < LENGTH(s0); j++) *q++ = *s++; if(b > 0 && adj != Rprt_adj_right) for(j = 0 ; j < b ; j++) *q++ = ' '; *q = '\0'; SET_STRING_ELT(y, i, mkChar(buff)); } } } UNPROTECT(2); /* xx , y */ PROTECT(y); break; default: error(_("Impossible mode ( x )")); y = R_NilValue;/* -Wall */ } } if((l = getAttrib(x, R_DimSymbol)) != R_NilValue) { setAttrib(y, R_DimSymbol, l); if((l = getAttrib(x, R_DimNamesSymbol)) != R_NilValue) setAttrib(y, R_DimNamesSymbol, l); } else if((l = getAttrib(x, R_NamesSymbol)) != R_NilValue) setAttrib(y, R_NamesSymbol, l); /* In case something else forgets to set PrintDefaults(), PR#14477 */ R_print.scipen = scikeep; UNPROTECT(1); /* y */ return y; }