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