The R Project SVN R

Rev

Rev 76974 | Rev 78204 | Go to most recent revision | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
2 r 1 
/*
465 maechler 2 
 *  R : A Computer Language for Statistical Data Analysis
76889 maechler 3 
 *  Copyright (C) 1997--2019  The R Core Team
2 r 4 
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
5 
 *
6 
 *  This program is free software; you can redistribute it and/or modify
7 
 *  it under the terms of the GNU General Public License as published by
8 
 *  the Free Software Foundation; either version 2 of the License, or
9 
 *  (at your option) any later version.
10 
 *
11 
 *  This program is distributed in the hope that it will be useful,
12 
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
13 
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14 
 *  GNU General Public License for more details.
15 
 *
16 
 *  You should have received a copy of the GNU General Public License
42307 ripley 17 
 *  along with this program; if not, a copy is available at
68947 ripley 18 
 *  https://www.R-project.org/Licenses/
1895 ihaka 19 
 *
20 
 *
21 
 *  See ./printutils.c	 for general remarks on Printing
22 
 *                       and the Encode.. utils.
23 
 *
24 
 *  See ./format.c	 for the  format_Foo_  functions.
2 r 25 
 */
26 
 
5187 hornik 27 
#ifdef HAVE_CONFIG_H
7701 hornik 28 
#include <config.h>
5187 hornik 29 
#endif
30 
 
2 r 31 
#include "Defn.h"
60667 ripley 32 
#include <Internal.h>
33 
 
41631 ripley 34 
#define imax2(x, y) ((x < y) ? y : x)
41899 ripley 35 
 
2 r 36 
#include "Print.h"
41899 ripley 37 
#include "RBufferUtils.h"
38 
static R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
2 r 39 
 
57795 maechler 40 
/*
41 
  .Internal(paste (args, sep, collapse))
42 
  .Internal(paste0(args, collapse))
43 
 
1895 ihaka 44 
 * do_paste uses two passes to paste the arguments (in CAR(args)) together.
465 maechler 45 
 * The first pass calculates the width of the paste buffer,
46 
 * then it is alloc-ed and the second pass stuffs the information in.
47 
 */
43724 ripley 48 
 
45446 ripley 49 
/* Note that NA_STRING is not handled separately here.  This is
43724 ripley 50 
   deliberate -- see ?paste -- and implicitly coerces it to "NA"
51 
*/
36990 ripley 52 
SEXP attribute_hidden do_paste(SEXP call, SEXP op, SEXP args, SEXP env)
2 r 53 
{
41495 rgentlem 54 
    SEXP ans, collapse, sep, x;
59046 ripley 55 
    int sepw, u_sepw, ienc;
56 
    R_xlen_t i, j, k, maxlen, nx, pwidth;
57795 maechler 57 
    const char *s, *cbuf, *csep=NULL, *u_csep=NULL;
45847 ripley 58 
    char *buf;
57795 maechler 59 
    Rboolean allKnown, anyKnown, use_UTF8, use_Bytes,
59046 ripley 60 
	sepASCII = TRUE, sepUTF8 = FALSE, sepBytes = FALSE, sepKnown = FALSE,
57795 maechler 61 
	use_sep = (PRIMVAL(op) == 0);
50880 ripley 62 
    const void *vmax;
2 r 63 
 
1895 ihaka 64 
    checkArity(op, args);
465 maechler 65 
 
54753 ripley 66 
    /* We use formatting and so we must initialize printing. */
2 r 67 
 
54049 ripley 68 
    PrintDefaults();
2 r 69 
 
1895 ihaka 70 
    /* Check the arguments */
2 r 71 
 
1895 ihaka 72 
    x = CAR(args);
73 
    if (!isVectorList(x))
41686 ripley 74 
	error(_("invalid first argument"));
59046 ripley 75 
    nx = xlength(x);
2 r 76 
 
57795 maechler 77 
    if(use_sep) { /* paste(..., sep, .) */
78 
	sep = CADR(args);
79 
	if (!isString(sep) || LENGTH(sep) <= 0 || STRING_ELT(sep, 0) == NA_STRING)
80 
	    error(_("invalid separator"));
81 
	sep = STRING_ELT(sep, 0);
82 
	csep = translateChar(sep);
59177 ripley 83 
	u_sepw = sepw = (int) strlen(csep); // will be short
57795 maechler 84 
	sepASCII = strIsASCII(csep);
85 
	sepKnown = ENC_KNOWN(sep) > 0;
86 
	sepUTF8 = IS_UTF8(sep);
87 
	sepBytes = IS_BYTES(sep);
88 
	collapse = CADDR(args);
89 
    } else { /* paste0(..., .) */
90 
	u_sepw = sepw = 0; sep = R_NilValue;/* -Wall */
91 
	collapse = CADR(args);
92 
    }
1895 ihaka 93 
    if (!isNull(collapse))
43724 ripley 94 
	if(!isString(collapse) || LENGTH(collapse) <= 0 ||
95 
	   STRING_ELT(collapse, 0) == NA_STRING)
41686 ripley 96 
	    error(_("invalid '%s' argument"), "collapse");
43466 ripley 97 
    if(nx == 0)
98 
	return (!isNull(collapse)) ? mkString("") : allocVector(STRSXP, 0);
2 r 99 
 
45446 ripley 100 
 
43466 ripley 101 
    /* Maximum argument length, coerce if needed */
2 r 102 
 
1895 ihaka 103 
    maxlen = 0;
104 
    for (j = 0; j < nx; j++) {
43466 ripley 105 
	if (!isString(VECTOR_ELT(x, j))) {
106 
	    /* formerly in R code: moved to C for speed */
107 
	    SEXP call, xj = VECTOR_ELT(x, j);
108 
	    if(OBJECT(xj)) { /* method dispatch */
71844 luke 109 
		PROTECT(call = lang2(R_AsCharacterSymbol, xj));
43466 ripley 110 
		SET_VECTOR_ELT(x, j, eval(call, env));
111 
		UNPROTECT(1);
112 
	    } else if (isSymbol(xj))
113 
		SET_VECTOR_ELT(x, j, ScalarString(PRINTNAME(xj)));
114 
	    else
115 
		SET_VECTOR_ELT(x, j, coerceVector(xj, STRSXP));
116 
 
117 
	    if (!isString(VECTOR_ELT(x, j)))
76889 maechler 118 
		error(_("non-string argument to .Internal(%s)"), PRIMNAME(op));
43466 ripley 119 
	}
68586 ripley 120 
	if(XLENGTH(VECTOR_ELT(x, j)) > maxlen)
121 
	    maxlen = XLENGTH(VECTOR_ELT(x, j));
1895 ihaka 122 
    }
123 
    if(maxlen == 0)
24842 ripley 124 
	return (!isNull(collapse)) ? mkString("") : allocVector(STRSXP, 0);
1895 ihaka 125 
 
126 
    PROTECT(ans = allocVector(STRSXP, maxlen));
127 
 
128 
    for (i = 0; i < maxlen; i++) {
43724 ripley 129 
	/* Strategy for marking the encoding: if all inputs (including
130 
	 * the separator) are ASCII, so is the output and we don't
131 
	 * need to mark.  Otherwise if all non-ASCII inputs are of
132 
	 * declared encoding, we should mark.
133 
	 * Need to be careful only to include separator if it is used.
134 
	 */
54753 ripley 135 
	anyKnown = FALSE; allKnown = TRUE; use_UTF8 = FALSE; use_Bytes = FALSE;
43724 ripley 136 
	if(nx > 1) {
45847 ripley 137 
	    allKnown = sepKnown || sepASCII;
138 
	    anyKnown = sepKnown;
139 
	    use_UTF8 = sepUTF8;
54753 ripley 140 
	    use_Bytes = sepBytes;
43724 ripley 141 
	}
45446 ripley 142 
 
1895 ihaka 143 
	pwidth = 0;
1839 ihaka 144 
	for (j = 0; j < nx; j++) {
68586 ripley 145 
	    k = XLENGTH(VECTOR_ELT(x, j));
45847 ripley 146 
	    if (k > 0) {
147 
		SEXP cs = STRING_ELT(VECTOR_ELT(x, j), i % k);
148 
		if(IS_UTF8(cs)) use_UTF8 = TRUE;
54753 ripley 149 
		if(IS_BYTES(cs)) use_Bytes = TRUE;
45847 ripley 150 
	    }
1820 ihaka 151 
	}
54753 ripley 152 
	if (use_Bytes) use_UTF8 = FALSE;
50880 ripley 153 
	vmax = vmaxget();
45847 ripley 154 
	for (j = 0; j < nx; j++) {
68586 ripley 155 
	    k = XLENGTH(VECTOR_ELT(x, j));
45847 ripley 156 
	    if (k > 0) {
54753 ripley 157 
		if(use_Bytes)
158 
		    pwidth += strlen(CHAR(STRING_ELT(VECTOR_ELT(x, j), i % k)));
159 
		else if(use_UTF8)
45847 ripley 160 
		    pwidth += strlen(translateCharUTF8(STRING_ELT(VECTOR_ELT(x, j), i % k)));
161 
		else
162 
		    pwidth += strlen(translateChar(STRING_ELT(VECTOR_ELT(x, j), i % k)));
50880 ripley 163 
		vmaxset(vmax);
45847 ripley 164 
	    }
165 
	}
57795 maechler 166 
	if(use_sep) {
167 
	    if (use_UTF8 && !u_csep) {
168 
		u_csep = translateCharUTF8(sep);
59177 ripley 169 
		u_sepw = (int) strlen(u_csep); // will be short
57795 maechler 170 
	    }
171 
	    pwidth += (nx - 1) * (use_UTF8 ? u_sepw : sepw);
45847 ripley 172 
	}
59046 ripley 173 
	if (pwidth > INT_MAX)
174 
	    error(_("result would exceed 2^31-1 bytes"));
41899 ripley 175 
	cbuf = buf = R_AllocStringBuffer(pwidth, &cbuff);
50880 ripley 176 
	vmax = vmaxget();
1895 ihaka 177 
	for (j = 0; j < nx; j++) {
68586 ripley 178 
	    k = XLENGTH(VECTOR_ELT(x, j));
1895 ihaka 179 
	    if (k > 0) {
43724 ripley 180 
		SEXP cs = STRING_ELT(VECTOR_ELT(x, j), i % k);
45847 ripley 181 
		if (use_UTF8) {
182 
		    s = translateCharUTF8(cs);
183 
		    strcpy(buf, s);
184 
		    buf += strlen(s);
185 
		} else {
54753 ripley 186 
		    s = use_Bytes ? CHAR(cs) : translateChar(cs);
45847 ripley 187 
		    strcpy(buf, s);
188 
		    buf += strlen(s);
189 
		    allKnown = allKnown && (strIsASCII(s) || (ENC_KNOWN(cs)> 0));
190 
		    anyKnown = anyKnown || (ENC_KNOWN(cs)> 0);
191 
		}
1895 ihaka 192 
	    }
57795 maechler 193 
	    if (sepw != 0 && j != nx - 1) {
45847 ripley 194 
		if (use_UTF8) {
195 
		    strcpy(buf, u_csep);
196 
		    buf += u_sepw;
197 
		} else {
198 
		    strcpy(buf, csep);
199 
		    buf += sepw;
200 
		}
1895 ihaka 201 
	    }
50880 ripley 202 
	    vmax = vmaxget();
2 r 203 
	}
45412 ripley 204 
	ienc = 0;
45847 ripley 205 
	if(use_UTF8) ienc = CE_UTF8;
54753 ripley 206 
	else if(use_Bytes) ienc = CE_BYTES;
45847 ripley 207 
	else if(anyKnown && allKnown) {
44986 ripley 208 
	    if(known_to_be_latin1) ienc = CE_LATIN1;
209 
	    if(known_to_be_utf8) ienc = CE_UTF8;
43724 ripley 210 
	}
44986 ripley 211 
	SET_STRING_ELT(ans, i, mkCharCE(cbuf, ienc));
1895 ihaka 212 
    }
2 r 213 
 
1895 ihaka 214 
    /* Now collapse, if required. */
2 r 215 
 
59075 ripley 216 
    if(collapse != R_NilValue && (nx = XLENGTH(ans)) > 0) {
10172 luke 217 
	sep = STRING_ELT(collapse, 0);
45847 ripley 218 
	use_UTF8 = IS_UTF8(sep);
54753 ripley 219 
	use_Bytes = IS_BYTES(sep);
220 
	for (i = 0; i < nx; i++) {
45847 ripley 221 
	    if(IS_UTF8(STRING_ELT(ans, i))) use_UTF8 = TRUE;
54753 ripley 222 
	    if(IS_BYTES(STRING_ELT(ans, i))) use_Bytes = TRUE;
223 
	}
224 
	if(use_Bytes) {
225 
	    csep = CHAR(sep);
226 
	    use_UTF8 = FALSE;
227 
	} else if(use_UTF8)
45847 ripley 228 
	    csep = translateCharUTF8(sep);
229 
	else
230 
	    csep = translateChar(sep);
59177 ripley 231 
	sepw = (int) strlen(csep);
43724 ripley 232 
	anyKnown = ENC_KNOWN(sep) > 0;
44094 ripley 233 
	allKnown = anyKnown || strIsASCII(csep);
1895 ihaka 234 
	pwidth = 0;
50880 ripley 235 
	vmax = vmaxget();
1895 ihaka 236 
	for (i = 0; i < nx; i++)
50880 ripley 237 
	    if(use_UTF8) {
45847 ripley 238 
		pwidth += strlen(translateCharUTF8(STRING_ELT(ans, i)));
50880 ripley 239 
		vmaxset(vmax);
54753 ripley 240 
	    } else /* already translated */
45847 ripley 241 
		pwidth += strlen(CHAR(STRING_ELT(ans, i)));
1895 ihaka 242 
	pwidth += (nx - 1) * sepw;
59046 ripley 243 
	if (pwidth > INT_MAX)
244 
	    error(_("result would exceed 2^31-1 bytes"));
41899 ripley 245 
	cbuf = buf = R_AllocStringBuffer(pwidth, &cbuff);
50880 ripley 246 
	vmax = vmaxget();
1895 ihaka 247 
	for (i = 0; i < nx; i++) {
248 
	    if(i > 0) {
45446 ripley 249 
		strcpy(buf, csep);
1895 ihaka 250 
		buf += sepw;
251 
	    }
45847 ripley 252 
	    if(use_UTF8)
253 
		s = translateCharUTF8(STRING_ELT(ans, i));
254 
	    else /* already translated */
255 
		s = CHAR(STRING_ELT(ans, i));
45446 ripley 256 
	    strcpy(buf, s);
2584 ihaka 257 
	    while (*buf)
258 
		buf++;
45446 ripley 259 
	    allKnown = allKnown &&
50880 ripley 260 
		(strIsASCII(s) || (ENC_KNOWN(STRING_ELT(ans, i)) > 0));
261 
	    anyKnown = anyKnown || (ENC_KNOWN(STRING_ELT(ans, i)) > 0);
262 
	    if(use_UTF8) vmaxset(vmax);
2 r 263 
	}
45446 ripley 264 
	UNPROTECT(1);
45847 ripley 265 
	ienc = CE_NATIVE;
266 
	if(use_UTF8) ienc = CE_UTF8;
54753 ripley 267 
	else if(use_Bytes) ienc = CE_BYTES;
45847 ripley 268 
	else if(anyKnown && allKnown) {
44986 ripley 269 
	    if(known_to_be_latin1) ienc = CE_LATIN1;
270 
	    if(known_to_be_utf8) ienc = CE_UTF8;
43724 ripley 271 
	}
272 
	PROTECT(ans = allocVector(STRSXP, 1));
44986 ripley 273 
	SET_STRING_ELT(ans, 0, mkCharCE(cbuf, ienc));
1895 ihaka 274 
    }
41899 ripley 275 
    R_FreeStringBufferL(&cbuff);
1895 ihaka 276 
    UNPROTECT(1);
277 
    return ans;
2 r 278 
}
279 
 
76958 ripley 280 
/*
77234 ripley 281 
  Encoding support added for R 4.0.0.  One would normally expect file
76958 ripley 282 
  paths (and their components) to be in the session encoding, but on
283 
  Windows there is some support for Unicode paths encoded (inside R) in UTF-8.
76974 ripley 284 
 
285 
  This should not do translations with escapes.
76958 ripley 286 
 */
43466 ripley 287 
SEXP attribute_hidden do_filepath(SEXP call, SEXP op, SEXP args, SEXP env)
288 
{
289 
    checkArity(op, args);
290 
 
291 
    /* Check the arguments */
292 
 
76958 ripley 293 
    SEXP x = CAR(args);
43466 ripley 294 
    if (!isVectorList(x))
295 
	error(_("invalid first argument"));
76958 ripley 296 
    int nx = length(x);
297 
    if (nx == 0) return allocVector(STRSXP, 0);
43466 ripley 298 
 
76958 ripley 299 
    SEXP sep = CADR(args);
43724 ripley 300 
    if (!isString(sep) || LENGTH(sep) <= 0 || STRING_ELT(sep, 0) == NA_STRING)
43466 ripley 301 
	error(_("invalid separator"));
302 
    sep = STRING_ELT(sep, 0);
76958 ripley 303 
    const char *csep = CHAR(sep);
304 
    int sepw = (int) strlen(csep); /* hopefully 1 */
43466 ripley 305 
 
306 
    /* Any zero-length argument gives zero-length result */
76958 ripley 307 
    int maxlen = 0, nzero = 0;
308 
    for (int j = 0; j < nx; j++) {
43466 ripley 309 
	if (!isString(VECTOR_ELT(x, j))) {
310 
	    SEXP call, xj = VECTOR_ELT(x, j);
311 
	    if(OBJECT(xj)) { /* method dispatch */
71844 luke 312 
		PROTECT(call = lang2(R_AsCharacterSymbol, xj));
43466 ripley 313 
		SET_VECTOR_ELT(x, j, eval(call, env));
314 
		UNPROTECT(1);
315 
	    } else if (isSymbol(xj))
316 
		SET_VECTOR_ELT(x, j, ScalarString(PRINTNAME(xj)));
317 
	    else
318 
		SET_VECTOR_ELT(x, j, coerceVector(xj, STRSXP));
319 
 
320 
	    if (!isString(VECTOR_ELT(x, j)))
76889 maechler 321 
		error(_("non-string argument to .Internal(%s)"), PRIMNAME(op));
43466 ripley 322 
	}
76958 ripley 323 
	int ln = LENGTH(VECTOR_ELT(x, j));
324 
	if (ln == 0) {nzero++; break;}
325 
	if (ln > maxlen) maxlen = ln;
43466 ripley 326 
    }
76958 ripley 327 
    if (nzero || maxlen == 0) return allocVector(STRSXP, 0);
43466 ripley 328 
 
76974 ripley 329 
    for (int j = 0; j < nx; j++) {
330 
	int k = LENGTH(VECTOR_ELT(x, j));
331 
	for (int i = 0; i < k; i++) {
332 
	    SEXP cs = STRING_ELT(VECTOR_ELT(x, j), i);
333 
	    if (IS_BYTES(cs))
334 
		error(_("strings with \"bytes\" encoding are not allowed"));
335 
	}
336 
    }
76958 ripley 337 
    SEXP ans = PROTECT(allocVector(STRSXP, maxlen));
43466 ripley 338 
 
76958 ripley 339 
    for (int i = 0; i < maxlen; i++) {
340 
	Rboolean use_UTF8;
341 
	if (utf8locale)
342 
	    use_UTF8 = TRUE;
343 
	else {
344 
	    use_UTF8 = FALSE;
345 
	    for (int j = 0; j < nx; j++) {
346 
		int k = LENGTH(VECTOR_ELT(x, j));
347 
		SEXP cs = STRING_ELT(VECTOR_ELT(x, j), i % k);
348 
		if(IS_UTF8(cs)) {use_UTF8 = TRUE; break;}
349 
		if(!latin1locale && IS_LATIN1(cs)) {use_UTF8 = TRUE; break;}
350 
	    }
43466 ripley 351 
	}
76958 ripley 352 
	int pwidth = 0;
353 
	for (int j = 0; j < nx; j++) {
354 
	    int k = LENGTH(VECTOR_ELT(x, j));
355 
	    SEXP cs = STRING_ELT(VECTOR_ELT(x, j), i % k);
356 
	    if(use_UTF8)
76974 ripley 357 
		pwidth += (int) strlen(trCharUTF8(cs));
76958 ripley 358 
	    else
76974 ripley 359 
		pwidth += (int) strlen(translateCharFP(cs));
76958 ripley 360 
	}
43466 ripley 361 
	pwidth += (nx - 1) * sepw;
76958 ripley 362 
	char *buf = R_AllocStringBuffer(pwidth, &cbuff);
363 
	const char *cbuf = buf;
364 
	for (int j = 0; j < nx; j++) {
365 
	    int k = LENGTH(VECTOR_ELT(x, j));
366 
	    // k == 0 already handled above
367 
	    SEXP cs = STRING_ELT(VECTOR_ELT(x, j), i % k);
368 
	    const char *s;
369 
	    if (use_UTF8)
76974 ripley 370 
		s = trCharUTF8(cs);
76958 ripley 371 
	    else
76974 ripley 372 
		s = translateCharFP(cs);
76958 ripley 373 
	    strcpy(buf, s);
374 
	    buf += strlen(s);
43466 ripley 375 
	    if (j != nx - 1 && sepw != 0) {
45446 ripley 376 
		strcpy(buf, csep);
43466 ripley 377 
		buf += sepw;
378 
	    }
379 
	}
65057 ripley 380 
#ifdef Win32
65085 ripley 381 
	// Trailing seps are invalid for file paths except for / and d:/
65057 ripley 382 
	if(streql(csep, "/") || streql(csep, "\\")) {
65085 ripley 383 
	    if(buf > cbuf) {
384 
		buf--;
385 
		if(*buf == csep[0] && buf > cbuf &&
386 
		   (buf != cbuf+2 || cbuf[1] != ':')) *buf = '\0';
387 
	    }
65057 ripley 388 
	}
389 
#endif
76958 ripley 390 
	SET_STRING_ELT(ans, i, mkCharCE(cbuf, use_UTF8 ? CE_UTF8 : 0));
43466 ripley 391 
    }
392 
    R_FreeStringBufferL(&cbuff);
393 
    UNPROTECT(1);
394 
    return ans;
395 
}
396 
 
45446 ripley 397 
/* format.default(x, trim, digits, nsmall, width, justify, na.encode,
68557 maechler 398 
		  scientific, decimal.mark) */
36990 ripley 399 
SEXP attribute_hidden do_format(SEXP call, SEXP op, SEXP args, SEXP env)
2 r 400 
{
35263 ripley 401 
    SEXP l, x, y, swd;
60241 ripley 402 
    int il, digits, trim = 0, nsmall = 0, wd = 0, adj = -1, na, sci = 0;
1895 ihaka 403 
    int w, d, e;
54025 ripley 404 
    int wi, di, ei, scikeep;
41784 ripley 405 
    const char *strp;
60241 ripley 406 
    R_xlen_t i, n;
2 r 407 
 
35262 ripley 408 
    checkArity(op, args);
54049 ripley 409 
    PrintDefaults();
54025 ripley 410 
    scikeep = R_print.scipen;
45446 ripley 411 
 
45639 maechler 412 
    if (isEnvironment(x = CAR(args))) {
66659 maechler 413 
	return mkString(EncodeEnvironment(x));
45639 maechler 414 
    }
415 
    else if (!isVector(x))
76889 maechler 416 
	error(_("first argument must be atomic or environment"));
35263 ripley 417 
    args = CDR(args);
418 
 
419 
    trim = asLogical(CAR(args));
35262 ripley 420 
    if (trim == NA_INTEGER)
41686 ripley 421 
	error(_("invalid '%s' argument"), "trim");
35263 ripley 422 
    args = CDR(args);
423 
 
424 
    if (!isNull(CAR(args))) {
425 
	digits = asInteger(CAR(args));
45446 ripley 426 
	if (digits == NA_INTEGER || digits < R_MIN_DIGITS_OPT
35284 ripley 427 
	    || digits > R_MAX_DIGITS_OPT)
41686 ripley 428 
	    error(_("invalid '%s' argument"), "digits");
35263 ripley 429 
	R_print.digits = digits;
430 
    }
431 
    args = CDR(args);
432 
 
433 
    nsmall = asInteger(CAR(args));
35262 ripley 434 
    if (nsmall == NA_INTEGER || nsmall < 0 || nsmall > 20)
41686 ripley 435 
	error(_("invalid '%s' argument"), "nsmall");
35263 ripley 436 
    args = CDR(args);
2 r 437 
 
35263 ripley 438 
    if (isNull(swd = CAR(args))) wd = 0; else wd = asInteger(swd);
439 
    if(wd == NA_INTEGER)
41686 ripley 440 
	error(_("invalid '%s' argument"), "width");
35263 ripley 441 
    args = CDR(args);
1895 ihaka 442 
 
35263 ripley 443 
    adj = asInteger(CAR(args));
35290 ripley 444 
    if(adj == NA_INTEGER || adj < 0 || adj > 3)
41686 ripley 445 
	error(_("invalid '%s' argument"), "justify");
35284 ripley 446 
    args = CDR(args);
35263 ripley 447 
 
35284 ripley 448 
    na = asLogical(CAR(args));
35290 ripley 449 
    if(na == NA_LOGICAL)
41686 ripley 450 
	error(_("invalid '%s' argument"), "na.encode");
35371 ripley 451 
    args = CDR(args);
452 
    if(LENGTH(CAR(args)) != 1)
41686 ripley 453 
	error(_("invalid '%s' argument"), "scientific");
35371 ripley 454 
    if(isLogical(CAR(args))) {
455 
	int tmp = LOGICAL(CAR(args))[0];
456 
	if(tmp == NA_LOGICAL) sci = NA_INTEGER;
76925 maechler 457 
	else sci = tmp > 0 ? -99 : 310;
35371 ripley 458 
    } else if (isNumeric(CAR(args))) {
459 
	sci = asInteger(CAR(args));
460 
    } else
41686 ripley 461 
	error(_("invalid '%s' argument"), "scientific");
35371 ripley 462 
    if(sci != NA_INTEGER) R_print.scipen = sci;
68557 maechler 463 
    args = CDR(args);
464 
    // copy/paste from "OutDec" part of ./options.c
465 
    if (TYPEOF(CAR(args)) != STRSXP || LENGTH(CAR(args)) != 1)
466 
	error(_("invalid '%s' argument"), "decimal.mark");
467 
    char *my_OutDec;
468 
    if(STRING_ELT(CAR(args), 0) == NA_STRING)
469 
	my_OutDec = OutDec; // default
470 
    else {
471 
	static char sdec[11];
68558 maechler 472 
// not warning here by default for now
473 
#ifdef _WARN_decimal_mark_non_1
68557 maechler 474 
	if(R_nchar(STRING_ELT(CAR(args), 0), Chars,
475 
		   /* allowNA = */ FALSE, /* keepNA = */ FALSE,
476 
		   "decimal.mark") != 1) // will become an error
477 
	    warning(_("'decimal.mark' must be a string of one character"));
68558 maechler 478 
#endif
68557 maechler 479 
	strncpy(sdec, CHAR(STRING_ELT(CAR(args), 0)), 10);
480 
	sdec[10] = '\0';
481 
	my_OutDec = sdec;
482 
    }
35284 ripley 483 
 
60241 ripley 484 
    if ((n = XLENGTH(x)) <= 0) {
35590 ripley 485 
	PROTECT(y = allocVector(STRSXP, 0));
486 
    } else {
487 
	switch (TYPEOF(x)) {
1895 ihaka 488 
 
35590 ripley 489 
	case LGLSXP:
490 
	    PROTECT(y = allocVector(STRSXP, n));
491 
	    if (trim) w = 0; else formatLogical(LOGICAL(x), n, &w);
492 
	    w = imax2(w, wd);
493 
	    for (i = 0; i < n; i++) {
494 
		strp = EncodeLogical(LOGICAL(x)[i], w);
495 
		SET_STRING_ELT(y, i, mkChar(strp));
496 
	    }
497 
	    break;
1895 ihaka 498 
 
35590 ripley 499 
	case INTSXP:
500 
	    PROTECT(y = allocVector(STRSXP, n));
501 
	    if (trim) w = 0;
502 
	    else formatInteger(INTEGER(x), n, &w);
503 
	    w = imax2(w, wd);
504 
	    for (i = 0; i < n; i++) {
505 
		strp = EncodeInteger(INTEGER(x)[i], w);
506 
		SET_STRING_ELT(y, i, mkChar(strp));
507 
	    }
508 
	    break;
2 r 509 
 
35590 ripley 510 
	case REALSXP:
511 
	    formatReal(REAL(x), n, &w, &d, &e, nsmall);
512 
	    if (trim) w = 0;
513 
	    w = imax2(w, wd);
514 
	    PROTECT(y = allocVector(STRSXP, n));
515 
	    for (i = 0; i < n; i++) {
68557 maechler 516 
		strp = EncodeReal0(REAL(x)[i], w, d, e, my_OutDec);
35590 ripley 517 
		SET_STRING_ELT(y, i, mkChar(strp));
518 
	    }
519 
	    break;
2 r 520 
 
35590 ripley 521 
	case CPLXSXP:
522 
	    formatComplex(COMPLEX(x), n, &w, &d, &e, &wi, &di, &ei, nsmall);
523 
	    if (trim) wi = w = 0;
524 
	    w = imax2(w, wd); wi = imax2(wi, wd);
525 
	    PROTECT(y = allocVector(STRSXP, n));
526 
	    for (i = 0; i < n; i++) {
68557 maechler 527 
		strp = EncodeComplex(COMPLEX(x)[i], w, d, e, wi, di, ei, my_OutDec);
35590 ripley 528 
		SET_STRING_ELT(y, i, mkChar(strp));
529 
	    }
530 
	    break;
2 r 531 
 
35590 ripley 532 
	case STRSXP:
533 
	{
534 
	    /* this has to be different from formatString/EncodeString as
535 
	       we don't actually want to encode here */
57795 maechler 536 
	    const char *s;
51398 ripley 537 
	    char *q;
35590 ripley 538 
	    int b, b0, cnt = 0, j;
40704 ripley 539 
	    SEXP s0, xx;
45446 ripley 540 
 
40704 ripley 541 
	    /* This is clumsy, but it saves rewriting and re-testing
542 
	       this complex code */
543 
	    PROTECT(xx = duplicate(x));
544 
	    for (i = 0; i < n; i++) {
545 
		SEXP tmp =  STRING_ELT(xx, i);
54753 ripley 546 
		if(IS_BYTES(tmp)) {
547 
		    const char *p = CHAR(tmp), *q;
548 
		    char *pp = R_alloc(4*strlen(p)+1, 1), *qq = pp, buf[5];
549 
		    for (q = p; *q; q++) {
550 
			unsigned char k = (unsigned char) *q;
551 
			if (k >= 0x20 && k < 0x80) {
552 
			    *qq++ = *q;
553 
			} else {
554 
			    snprintf(buf, 5, "\\x%02x", k);
555 
			    for(int j = 0; j < 4; j++) *qq++ = buf[j];
556 
			}
557 
		    }
558 
		    *qq = '\0';
559 
		    s = pp;
560 
		} else s = translateChar(tmp);
40704 ripley 561 
		if(s != CHAR(tmp)) SET_STRING_ELT(xx, i, mkChar(s));
562 
	    }
45446 ripley 563 
 
564 
	    w = wd;
35590 ripley 565 
	    if (adj != Rprt_adj_none) {
566 
		for (i = 0; i < n; i++)
40704 ripley 567 
		    if (STRING_ELT(xx, i) != NA_STRING)
568 
			w = imax2(w, Rstrlen(STRING_ELT(xx, i), 0));
35590 ripley 569 
		    else if (na) w = imax2(w, R_print.na_width);
570 
	    } else w = 0;
571 
	    /* now calculate the buffer size needed, in bytes */
35263 ripley 572 
	    for (i = 0; i < n; i++)
40704 ripley 573 
		if (STRING_ELT(xx, i) != NA_STRING) {
574 
		    il = Rstrlen(STRING_ELT(xx, i), 0);
575 
		    cnt = imax2(cnt, LENGTH(STRING_ELT(xx, i)) + imax2(0, w-il));
68557 maechler 576 
		} else if (na)
577 
		    cnt = imax2(cnt, R_print.na_width + imax2(0, w-R_print.na_width));
59752 ripley 578 
	    R_CheckStack2(cnt+1);
51398 ripley 579 
	    char buff[cnt+1];
35590 ripley 580 
	    PROTECT(y = allocVector(STRSXP, n));
581 
	    for (i = 0; i < n; i++) {
40704 ripley 582 
		if(!na && STRING_ELT(xx, i) == NA_STRING) {
35590 ripley 583 
		    SET_STRING_ELT(y, i, NA_STRING);
584 
		} else {
585 
		    q = buff;
40704 ripley 586 
		    if(STRING_ELT(xx, i) == NA_STRING) s0 = R_print.na_string;
587 
		    else s0 = STRING_ELT(xx, i) ;
35590 ripley 588 
		    s = CHAR(s0);
589 
		    il = Rstrlen(s0, 0);
590 
		    b = w - il;
591 
		    if(b > 0 && adj != Rprt_adj_left) {
592 
			b0 = (adj == Rprt_adj_centre) ? b/2 : b;
593 
			for(j = 0 ; j < b0 ; j++) *q++ = ' ';
594 
			b -= b0;
595 
		    }
596 
		    for(j = 0; j < LENGTH(s0); j++) *q++ = *s++;
597 
		    if(b > 0 && adj != Rprt_adj_right)
598 
			for(j = 0 ; j < b ; j++) *q++ = ' ';
599 
		    *q = '\0';
600 
		    SET_STRING_ELT(y, i, mkChar(buff));
35263 ripley 601 
		}
602 
	    }
1895 ihaka 603 
	}
68418 luke 604 
	UNPROTECT(2); /* xx , y */
605 
	PROTECT(y);
1895 ihaka 606 
	break;
35590 ripley 607 
	default:
41686 ripley 608 
	    error(_("Impossible mode ( x )")); y = R_NilValue;/* -Wall */
35590 ripley 609 
	}
1895 ihaka 610 
    }
35262 ripley 611 
    if((l = getAttrib(x, R_DimSymbol)) != R_NilValue) {
1895 ihaka 612 
	setAttrib(y, R_DimSymbol, l);
35262 ripley 613 
	if((l = getAttrib(x, R_DimNamesSymbol)) != R_NilValue)
614 
	    setAttrib(y, R_DimNamesSymbol, l);
615 
    } else if((l = getAttrib(x, R_NamesSymbol)) != R_NilValue)
616 
	setAttrib(y, R_NamesSymbol, l);
617 
 
54025 ripley 618 
    /* In case something else forgets to set PrintDefaults(), PR#14477 */
619 
    R_print.scipen = scikeep;
620 
 
68418 luke 621 
    UNPROTECT(1); /* y */
1895 ihaka 622 
    return y;
2 r 623 
}
624 
 
625 
/* format.info(obj)  --> 3 integers  (w,d,e) with the formatting information
626 
 *			w = total width (#{chars}) per item
627 
 *			d = #{digits} to RIGHT of "."
465 maechler 628 
 *			e = {0:2}.   0: Fixpoint;
2 r 629 
 *				   1,2: exponential with 2/3 digit expon.
4928 maechler 630 
 *
631 
 * for complex : 2 x 3 integers for (Re, Im)
2 r 632 
 */
1895 ihaka 633 
 
36990 ripley 634 
SEXP attribute_hidden do_formatinfo(SEXP call, SEXP op, SEXP args, SEXP env)
2 r 635 
{
1895 ihaka 636 
    SEXP x;
60241 ripley 637 
    int digits, nsmall, no = 1, w, d, e, wi, di, ei;
35281 ripley 638 
 
1895 ihaka 639 
    checkArity(op, args);
640 
    x = CAR(args);
60241 ripley 641 
    R_xlen_t n = XLENGTH(x);
54049 ripley 642 
    PrintDefaults();
35281 ripley 643 
 
644 
    if (!isNull(CADR(args))) {
645 
	digits = asInteger(CADR(args));
45446 ripley 646 
	if (digits == NA_INTEGER || digits < R_MIN_DIGITS_OPT
35284 ripley 647 
	    || digits > R_MAX_DIGITS_OPT)
41686 ripley 648 
	    error(_("invalid '%s' argument"), "digits");
35281 ripley 649 
	R_print.digits = digits;
650 
    }
651 
    nsmall = asInteger(CADDR(args));
652 
    if (nsmall == NA_INTEGER || nsmall < 0 || nsmall > 20)
41686 ripley 653 
	error(_("invalid '%s' argument"), "nsmall");
35281 ripley 654 
 
1895 ihaka 655 
    w = 0;
656 
    d = 0;
657 
    e = 0;
658 
    switch (TYPEOF(x)) {
659 
 
35281 ripley 660 
    case RAWSXP:
661 
	formatRaw(RAW(x), n, &w);
662 
	break;
663 
 
1895 ihaka 664 
    case LGLSXP:
665 
	formatLogical(LOGICAL(x), n, &w);
666 
	break;
667 
 
668 
    case INTSXP:
669 
	formatInteger(INTEGER(x), n, &w);
670 
	break;
671 
 
672 
    case REALSXP:
35281 ripley 673 
	no = 3;
25241 ripley 674 
	formatReal(REAL(x), n, &w, &d, &e, nsmall);
1895 ihaka 675 
	break;
676 
 
677 
    case CPLXSXP:
35281 ripley 678 
	no = 6;
1895 ihaka 679 
	wi = di = ei = 0;
25241 ripley 680 
	formatComplex(COMPLEX(x), n, &w, &d, &e, &wi, &di, &ei, nsmall);
1895 ihaka 681 
	break;
682 
 
683 
    case STRSXP:
60241 ripley 684 
	for (R_xlen_t i = 0; i < n; i++)
35281 ripley 685 
	    if (STRING_ELT(x, i) != NA_STRING) {
60241 ripley 686 
		int il = Rstrlen(STRING_ELT(x, i), 0);
35281 ripley 687 
		if (il > w) w = il;
688 
	    }
1895 ihaka 689 
	break;
690 
 
691 
    default:
41686 ripley 692 
	error(_("atomic vector arguments only"));
1895 ihaka 693 
    }
35281 ripley 694 
    x = allocVector(INTSXP, no);
1895 ihaka 695 
    INTEGER(x)[0] = w;
35281 ripley 696 
    if(no > 1) {
697 
	INTEGER(x)[1] = d;
698 
	INTEGER(x)[2] = e;
699 
    }
700 
    if(no > 3) {
1895 ihaka 701 
	INTEGER(x)[3] = wi;
702 
	INTEGER(x)[4] = di;
703 
	INTEGER(x)[5] = ei;
704 
    }
705 
    return x;
2 r 706 
}