static void cat_sepwidth(SEXP sep, int *width, int ntot)
{
if (sep == R_NilValue || LENGTH(sep) == 0)
*width = 0;
else
*width = Rstrlen(STRING_ELT(sep, ntot % LENGTH(sep)), 0);
}
static void cat_newline(SEXP labels, int *width, int lablen, int ntot)
{
Rprintf("\n");
*width = 0;
if (labels != R_NilValue) {
Rprintf("%s ", EncodeString(STRING_ELT(labels, ntot % lablen),
1, 0, Rprt_adj_left));
*width += Rstrlen(STRING_ELT(labels, ntot % lablen), 0) + 1;
}
}
void formatString(SEXP *x, int n, int *fieldwidth, int quote)
{
int xmax = 0;
int i, l;
for (i = 0; i < n; i++) {
if (x[i] == NA_STRING) {
l = quote ? R_print.na_width : R_print.na_width_noquote;
} else l = Rstrlen(x[i], quote) + (quote ? 2 : 0);
if (l > xmax) xmax = l;
}
*fieldwidth = xmax;
}
static void LeftMatrixColumnLabel(SEXP cl, int j, int w)
{
int l;
SEXP tmp;
if (!isNull(cl)) {
tmp= STRING_ELT(cl, j);
if(tmp == NA_STRING) l = R_print.na_width_noquote;
else l = Rstrlen(tmp, 0);
Rprintf("%*s%s%*s", R_print.gap, "",
EncodeString(tmp, l, 0, Rprt_adj_left), w-l, "");
}
else {
Rprintf("%*s[,%ld]%*s", R_print.gap, "", j+1, w-IndexWidth(j+1)-3, "");
}
}
static void MatrixRowLabel(SEXP rl, int i, int rlabw, int lbloff)
{
int l;
SEXP tmp;
if (!isNull(rl)) {
tmp= STRING_ELT(rl, i);
if(tmp == NA_STRING) l = R_print.na_width_noquote;
else l = Rstrlen(tmp, 0);
Rprintf("\n%*s%s%*s", lbloff, "",
EncodeString(tmp, l, 0, Rprt_adj_left),
rlabw-l-lbloff, "");
}
else {
Rprintf("\n%*s[%ld,]", rlabw-3-IndexWidth(i + 1), "", i+1);
}
}
static void RightMatrixColumnLabel(SEXP cl, int j, int w)
{
int l;
SEXP tmp;
if (!isNull(cl)) {
tmp = STRING_ELT(cl, j);
if(tmp == NA_STRING) l = R_print.na_width_noquote;
else l = Rstrlen(tmp, 0);
/* This does not work correctly at least on FC3
Rprintf("%*s", R_print.gap+w,
EncodeString(tmp, l, 0, Rprt_adj_right)); */
Rprintf("%*s%s", R_print.gap+w-l, "",
EncodeString(tmp, l, 0, Rprt_adj_right));
}
else {
Rprintf("%*s[,%ld]%*s", R_print.gap, "", j+1, w-IndexWidth(j+1)-3, "");
}
}
const char *EncodeString(SEXP s, int w, int quote, Rprt_adj justify)
{
int b, b0, i, j, cnt;
const char *p; char *q, buf[11];
cetype_t ienc = CE_NATIVE;
/* We have to do something like this as the result is returned, and
passed on by EncodeElement -- so no way could be end user be
responsible for freeing it. However, this is not thread-safe. */
static R_StringBuffer gBuffer = {NULL, 0, BUFSIZE};
R_StringBuffer *buffer = &gBuffer;
if (s == NA_STRING) {
p = quote ? CHAR(R_print.na_string) : CHAR(R_print.na_string_noquote);
cnt = i = (int)(quote ? strlen(CHAR(R_print.na_string)) :
strlen(CHAR(R_print.na_string_noquote)));
quote = 0;
} else {
#ifdef Win32
if(WinUTF8out) {
ienc = getCharCE(s);
if(ienc == CE_UTF8) {
p = CHAR(s);
i = Rstrlen(s, quote);
cnt = LENGTH(s);
} else {
p = translateChar0(s);
if(p == CHAR(s)) {
i = Rstrlen(s, quote);
cnt = LENGTH(s);
} else {
cnt = strlen(p);
i = Rstrwid(p, cnt, CE_NATIVE, quote);
}
ienc = CE_NATIVE;
}
} else
#endif
{
if(IS_BYTES(s)) {
p = CHAR(s);
cnt = (int) strlen(p);
const char *q;
char *pp = R_alloc(4*cnt+1, 1), *qq = pp, buf[5];
for (q = p; *q; q++) {
unsigned char k = (unsigned char) *q;
if (k >= 0x20 && k < 0x80) {
*qq++ = *q;
if (quote && *q == '"') cnt++;
} else {
snprintf(buf, 5, "\\x%02x", k);
for(j = 0; j < 4; j++) *qq++ = buf[j];
cnt += 3;
}
}
*qq = '\0';
p = pp;
i = cnt;
} else {
p = translateChar(s);
if(p == CHAR(s)) {
i = Rstrlen(s, quote);
cnt = LENGTH(s);
} else {
cnt = (int) strlen(p);
i = Rstrwid(p, cnt, CE_NATIVE, quote);
}
}
}
}
/* We need enough space for the encoded string, including escapes.
Octal encoding turns one byte into four.
\u encoding can turn a multibyte into six or ten,
but it turns 2/3 into 6, and 4 (and perhaps 5/6) into 10.
Let's be wasteful here (the worst case appears to be an MBCS with
one byte for an upper-plane Unicode point output as ten bytes,
but I doubt that such an MBCS exists: two bytes is plausible).
+2 allows for quotes, +6 for UTF_8 escapes.
*/
q = R_AllocStringBuffer(imax2(5*cnt+8, w), buffer);
b = w - i - (quote ? 2 : 0); /* total amount of padding */
if(justify == Rprt_adj_none) b = 0;
if(b > 0 && justify != Rprt_adj_left) {
b0 = (justify == Rprt_adj_centre) ? b/2 : b;
for(i = 0 ; i < b0 ; i++) *q++ = ' ';
b -= b0;
}
if(quote) *q++ = (char) quote;
if(mbcslocale || ienc == CE_UTF8) {
int j, res;
mbstate_t mb_st;
wchar_t wc;
unsigned int k; /* not wint_t as it might be signed */
#ifndef __STDC_ISO_10646__
Rboolean Unicode_warning = FALSE;
#endif
if(ienc != CE_UTF8) mbs_init(&mb_st);
#ifdef Win32
else if(WinUTF8out) { memcpy(q, UTF8in, 3); q += 3; }
#endif
for (i = 0; i < cnt; i++) {
res = (int)((ienc == CE_UTF8) ? utf8toucs(&wc, p):
mbrtowc(&wc, p, MB_CUR_MAX, NULL));
if(res >= 0) { /* res = 0 is a terminator */
k = wc;
/* To be portable, treat \0 explicitly */
if(res == 0) {k = 0; wc = L'\0';}
if(0x20 <= k && k < 0x7f && iswprint(wc)) {
switch(wc) {
case L'\\': *q++ = '\\'; *q++ = '\\'; p++;
break;
case L'\'':
case L'"':
if(quote == *p) *q++ = '\\'; *q++ = *p++;
break;
default:
for(j = 0; j < res; j++) *q++ = *p++;
break;
}
} else if (k < 0x80) {
/* ANSI Escapes */
switch(wc) {
case L'\a': *q++ = '\\'; *q++ = 'a'; break;
case L'\b': *q++ = '\\'; *q++ = 'b'; break;
case L'\f': *q++ = '\\'; *q++ = 'f'; break;
case L'\n': *q++ = '\\'; *q++ = 'n'; break;
case L'\r': *q++ = '\\'; *q++ = 'r'; break;
case L'\t': *q++ = '\\'; *q++ = 't'; break;
case L'\v': *q++ = '\\'; *q++ = 'v'; break;
case L'\0': *q++ = '\\'; *q++ = '0'; break;
default:
/* print in octal */
snprintf(buf, 5, "\\%03o", k);
for(j = 0; j < 4; j++) *q++ = buf[j];
break;
}
p++;
} else {
if(iswprint(wc)) {
/* The problem here is that wc may be
printable according to the Unicode tables,
but it may not be printable on the output
device concerned. */
for(j = 0; j < res; j++) *q++ = *p++;
} else {
#ifndef Win32
# ifndef __STDC_ISO_10646__
Unicode_warning = TRUE;
# endif
if(k > 0xffff)
snprintf(buf, 11, "\\U%08x", k);
else
#endif
snprintf(buf, 11, "\\u%04x", k);
j = (int) strlen(buf);
memcpy(q, buf, j);
q += j;
p += res;
}
i += (res - 1);
}
} else { /* invalid char */
snprintf(q, 5, "\\x%02x", *((unsigned char *)p));
q += 4; p++;
}
}
#ifndef __STDC_ISO_10646__
if(Unicode_warning)
warning(_("it is not known that wchar_t is Unicode on this platform"));
#endif
} else
for (i = 0; i < cnt; i++) {
/* ASCII */
if((unsigned char) *p < 0x80) {
if(*p != '\t' && isprint((int)*p)) { /* Windows has \t as printable */
switch(*p) {
case '\\': *q++ = '\\'; *q++ = '\\'; break;
case '\'':
case '"':
if(quote == *p) *q++ = '\\'; *q++ = *p; break;
default: *q++ = *p; break;
}
} else switch(*p) {
/* ANSI Escapes */
case '\a': *q++ = '\\'; *q++ = 'a'; break;
case '\b': *q++ = '\\'; *q++ = 'b'; break;
case '\f': *q++ = '\\'; *q++ = 'f'; break;
case '\n': *q++ = '\\'; *q++ = 'n'; break;
case '\r': *q++ = '\\'; *q++ = 'r'; break;
case '\t': *q++ = '\\'; *q++ = 't'; break;
case '\v': *q++ = '\\'; *q++ = 'v'; break;
case '\0': *q++ = '\\'; *q++ = '0'; break;
default:
/* print in octal */
snprintf(buf, 5, "\\%03o", (unsigned char) *p);
for(j = 0; j < 4; j++) *q++ = buf[j];
break;
}
p++;
} else { /* 8 bit char */
#ifdef Win32 /* It seems Windows does not know what is printable! */
*q++ = *p++;
#else
if(!isprint((int)*p & 0xff)) {
/* print in octal */
snprintf(buf, 5, "\\%03o", (unsigned char) *p);
for(j = 0; j < 4; j++) *q++ = buf[j];
p++;
} else *q++ = *p++;
#endif
}
}
#ifdef Win32
if(WinUTF8out && ienc == CE_UTF8) { memcpy(q, UTF8out, 3); q += 3; }
#endif
if(quote) *q++ = (char) quote;
if(b > 0 && justify != Rprt_adj_right) {
for(i = 0 ; i < b ; i++) *q++ = ' ';
}
*q = '\0';
return buffer->data;
}
SEXP attribute_hidden do_cat(SEXP call, SEXP op, SEXP args, SEXP rho)
{
cat_info ci;
RCNTXT cntxt;
SEXP objs, file, fill, sepr, labs, s;
int ifile;
Rconnection con;
int append;
int i, iobj, n, nobjs, pwidth, width, sepw, lablen, ntot, nlsep, nlines;
char buf[512];
const char *p = "";
checkArity(op, args);
/* Use standard printing defaults */
PrintDefaults();
objs = CAR(args);
args = CDR(args);
file = CAR(args);
ifile = asInteger(file);
con = getConnection(ifile);
if(!con->canwrite) /* if it is not open, we may not know yet */
error(_("cannot write to this connection"));
args = CDR(args);
sepr = CAR(args);
if (!isString(sepr))
error(_("invalid '%s' specification"), "sep");
nlsep = 0;
for (i = 0; i < LENGTH(sepr); i++)
if (strstr(CHAR(STRING_ELT(sepr, i)), "\n")) nlsep = 1; /* ASCII */
args = CDR(args);
fill = CAR(args);
if ((!isNumeric(fill) && !isLogical(fill)) || (length(fill) != 1))
error(_("invalid '%s' argument"), "fill");
if (isLogical(fill)) {
if (asLogical(fill) == 1)
pwidth = R_print.width;
else
pwidth = INT_MAX;
}
else pwidth = asInteger(fill);
if(pwidth <= 0) {
warning(_("non-positive 'fill' argument will be ignored"));
pwidth = INT_MAX;
}
args = CDR(args);
labs = CAR(args);
if (!isString(labs) && labs != R_NilValue)
error(_("invalid '%s' argument"), "labels");
lablen = length(labs);
args = CDR(args);
append = asLogical(CAR(args));
if (append == NA_LOGICAL)
error(_("invalid '%s' specification"), "append");
ci.wasopen = con->isopen;
ci.changedcon = switch_stdout(ifile, 0);
/* will open new connection if required, and check for writeable */
#ifdef Win32
/* do this after re-sinking output */
WinCheckUTF8();
#endif
ci.con = con;
/* set up a context which will close the connection if there is an error */
begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,
R_NilValue, R_NilValue);
cntxt.cend = &cat_cleanup;
cntxt.cenddata = &ci;
nobjs = length(objs);
width = 0;
ntot = 0;
nlines = 0;
for (iobj = 0; iobj < nobjs; iobj++) {
s = VECTOR_ELT(objs, iobj);
if (iobj != 0 && !isNull(s))
cat_printsep(sepr, ntot++);
n = length(s);
/* 0-length objects are ignored */
if (n > 0) {
if (labs != R_NilValue && (iobj == 0)
&& (asInteger(fill) > 0)) {
Rprintf("%s ", trChar(STRING_ELT(labs, nlines % lablen)));
/* FIXME -- Rstrlen allows for double-width chars */
width += Rstrlen(STRING_ELT(labs, nlines % lablen), 0) + 1;
nlines++;
}
if (isString(s))
p = trChar(STRING_ELT(s, 0));
else if (isSymbol(s)) /* length 1 */
p = CHAR(PRINTNAME(s));
else if (isVectorAtomic(s)) {
/* Not a string, as that is covered above.
Thus the maximum size is about 60.
The copy is needed as cat_newline might reuse the buffer.
Use strncpy is in case these assumptions change.
*/
p = EncodeElement0(s, 0, 0, OutDec);
strncpy(buf, p, 512); buf[511] = '\0';
p = buf;
}
#ifdef fixed_cat
else if (isVectorList(s)) {
/* FIXME: call EncodeElement() for every element of s.
Real Problem: `s' can be large;
should do line breaking etc.. (buf is of limited size)
*/
}
#endif
else
errorcall(call,
_("argument %d (type '%s') cannot be handled by 'cat'"),
1+iobj, type2char(TYPEOF(s)));
/* FIXME : cat(...) should handle ANYTHING */
size_t w = strlen(p);
cat_sepwidth(sepr, &sepw, ntot);
if ((iobj > 0) && (width + w + sepw > pwidth)) {
cat_newline(labs, &width, lablen, nlines);
nlines++;
}
for (i = 0; i < n; i++, ntot++) {
Rprintf("%s", p);
width += (int)(w + sepw);
if (i < (n - 1)) {
cat_printsep(sepr, ntot);
if (isString(s))
p = trChar(STRING_ELT(s, i+1));
else {
p = EncodeElement0(s, i+1, 0, OutDec);
strncpy(buf, p, 512); buf[511] = '\0';
p = buf;
}
w = (int) strlen(p);
cat_sepwidth(sepr, &sepw, ntot);
/* This is inconsistent with the version above.
As from R 2.3.0, fill <= 0 is ignored. */
if ((width + w + sepw > pwidth) && pwidth) {
cat_newline(labs, &width, lablen, nlines);
nlines++;
}
} else ntot--; /* we don't print sep after last, so don't advance */
}
}
}
if ((pwidth != INT_MAX) || nlsep)
Rprintf("\n");
/* end the context after anything that could raise an error but before
doing the cleanup so the cleanup doesn't get done twice */
endcontext(&cntxt);
cat_cleanup(&ci);
return R_NilValue;
}
SEXP attribute_hidden do_formatinfo(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP x;
int digits, nsmall, no = 1, w, d, e, wi, di, ei;
checkArity(op, args);
x = CAR(args);
R_xlen_t n = XLENGTH(x);
PrintDefaults();
digits = asInteger(CADR(args));
if (!isNull(CADR(args))) {
digits = asInteger(CADR(args));
if (digits == NA_INTEGER || digits < R_MIN_DIGITS_OPT
|| digits > R_MAX_DIGITS_OPT)
error(_("invalid '%s' argument"), "digits");
R_print.digits = digits;
}
nsmall = asInteger(CADDR(args));
if (nsmall == NA_INTEGER || nsmall < 0 || nsmall > 20)
error(_("invalid '%s' argument"), "nsmall");
w = 0;
d = 0;
e = 0;
switch (TYPEOF(x)) {
case RAWSXP:
formatRaw(RAW(x), n, &w);
break;
case LGLSXP:
formatLogical(LOGICAL(x), n, &w);
break;
case INTSXP:
formatInteger(INTEGER(x), n, &w);
break;
case REALSXP:
no = 3;
formatReal(REAL(x), n, &w, &d, &e, nsmall);
break;
case CPLXSXP:
no = 6;
wi = di = ei = 0;
formatComplex(COMPLEX(x), n, &w, &d, &e, &wi, &di, &ei, nsmall);
break;
case STRSXP:
for (R_xlen_t i = 0; i < n; i++)
if (STRING_ELT(x, i) != NA_STRING) {
int il = Rstrlen(STRING_ELT(x, i), 0);
if (il > w) w = il;
}
break;
default:
error(_("atomic vector arguments only"));
}
x = allocVector(INTSXP, no);
INTEGER(x)[0] = w;
if(no > 1) {
INTEGER(x)[1] = d;
INTEGER(x)[2] = e;
}
if(no > 3) {
INTEGER(x)[3] = wi;
INTEGER(x)[4] = di;
INTEGER(x)[5] = ei;
}
return x;
}
/* 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;
}
