The R Project SVN R

Rev

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