The R Project SVN R

Rev

Rev 48378 | Rev 48415 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 48378 Rev 48399
Line 73... Line 73...
73 
       bit will hold numeric formats and %<w>s, so be quite small. */
 73 
       bit will hold numeric formats and %<w>s, so be quite small. */
74 
    char fmt[MAXLINE+1], fmt2[MAXLINE+10], *fmtp, bit[MAXLINE+1],
 74 
    char fmt[MAXLINE+1], fmt2[MAXLINE+10], *fmtp, bit[MAXLINE+1],
75 
	*outputString, *formatString;
 75 
	*outputString, *formatString;
76 
    size_t n, cur, chunk;
 76 
    size_t n, cur, chunk;
77 
 
 77 
 
78 
    SEXP format, ans, _this, a[MAXNARGS], tmp;
 78 
    SEXP format, _this, a[MAXNARGS], tmp, ans /* -Wall */ = R_NilValue;
79 
    int ns, maxlen, lens[MAXNARGS], nthis, nstar, star_arg = 0;
 79 
    int ns, maxlen, lens[MAXNARGS], nthis, nstar, star_arg = 0;
80 
    static R_StringBuffer outbuff = {NULL, 0, MAXELTSIZE};
 80 
    static R_StringBuffer outbuff = {NULL, 0, MAXELTSIZE};
81 
    Rboolean has_star, use_UTF8;
 81 
    Rboolean has_star, use_UTF8;
82 
 
 82 
 
83 
#define TRANSLATE_CHAR(_STR_, _i_)				\
 83 
#define TRANSLATE_CHAR(_STR_, _i_)				\
84 
    (char *)((use_UTF8)						\
 84 
    (char *)((use_UTF8)						\
85 
	     ? translateCharUTF8(STRING_ELT(_STR_, _i_))	\
 85 
	     ? translateCharUTF8(STRING_ELT(_STR_, _i_))	\
86 
	     : translateChar    (STRING_ELT(_STR_, _i_)))
 86 
	     : translateChar    (STRING_ELT(_STR_, _i_)))
87 
 
 87 
 
- 
 
 88 
#define _my_sprintf(_X_)						\
- 
 
 89 
    {									\
- 
 
 90 
	int nc = snprintf(bit, MAXLINE+1, fmtp, _X_);			\
- 
 
 91 
	if (nc > MAXLINE)						\
- 
 
 92 
	    error(_("required resulting string length %d is > maximal %d"), \
- 
 
 93 
		  nc, MAXLINE);						\
- 
 
 94 
    }
- 
 
 95 
 
88 
    nargs = length(args);
 96 
    nargs = length(args);
89 
    /* grab the format string */
 97 
    /* grab the format string */
90 
    format = CAR(args);
 98 
    format = CAR(args);
91 
    if (!isString(format))
 99 
    if (!isString(format))
92 
	error(_("'fmt' is not a character vector"));
 100 
	error(_("'fmt' is not a character vector"));
Line 220... Line 228...
220 
		    if (fmt[strlen(fmt) - 1] == '%') {
 228 
		    if (fmt[strlen(fmt) - 1] == '%') {
221 
			/* handle % with formatting options */
 229 
			/* handle % with formatting options */
222 
			if (has_star)
 230 
			if (has_star)
223 
			    sprintf(bit, fmt, star_arg);
 231 
			    sprintf(bit, fmt, star_arg);
224 
			else
 232 
			else
225 
			    sprintf(bit, fmt);
 233 
			    strcpy(bit, fmt);
- 
 
 234 
			/* was sprintf(..)  for which some compiler warn */
226 
		    } else {
 235 
		    } else {
227 
			if(nthis < 0) {
 236 
			if(nthis < 0) {
228 
			    if (cnt >= nargs) error(_("too few arguments"));
 237 
			    if (cnt >= nargs) error(_("too few arguments"));
229 
			    nthis = cnt++;
 238 
			    nthis = cnt++;
230 
			}
 239 
			}
231 
			_this = a[nthis];
 240 
			_this = a[nthis];
232 
			if (has_star) {
 241 
			if (has_star) {
233 
			    char *p, *q = fmt2;
 242 
			    int nf; char *p, *q = fmt2;
234 
			    for (p = fmt; *p; p++)
 243 
			    for (p = fmt; *p; p++)
235 
				if (*p == '*') q += sprintf(q, "%d", star_arg);
 244 
				if (*p == '*') q += sprintf(q, "%d", star_arg);
236 
				else *q++ = *p;
 245 
				else *q++ = *p;
237 
			    *q = '\0';
 246 
			    *q = '\0';
- 
 
 247 
			    nf = strlen(fmt2);
- 
 
 248 
			    if (nf > MAXLINE)
- 
 
 249 
				error(_("the '%*' constructed 'fmt2' length exceeds maximum of %d"),
- 
 
 250 
				      MAXLINE);
238 
			    fmtp = fmt2;
 251 
			    fmtp = fmt2;
239 
			} else fmtp = fmt;
 252 
			} else fmtp = fmt;
240 
 
 253 
 
241 
			/* Now let us see if some minimal coercion
 254 
			/* Now let us see if some minimal coercion
242 
			   would be sensible, but only do so once, for ns = 0: */
 255 
			   would be sensible, but only do so once, for ns = 0: */
Line 298... Line 311...
298 
			switch(TYPEOF(_this)) {
 311 
			switch(TYPEOF(_this)) {
299 
			case LGLSXP:
 312 
			case LGLSXP:
300 
			    {
 313 
			    {
301 
				int x = LOGICAL(_this)[ns % thislen];
 314 
				int x = LOGICAL(_this)[ns % thislen];
302 
				if (checkfmt(fmtp, "di"))
 315 
				if (checkfmt(fmtp, "di"))
303 
				    error("%s",
 316 
				    error(_("invalid format '%s'; %s"), fmtp,
304 
					  _("use format %d or %i for logical objects"));
 317 
					  _("use format %d or %i for logical objects"));
305 
				if (x == NA_LOGICAL) {
 318 
				if (x == NA_LOGICAL) {
306 
				    fmtp[strlen(fmtp)-1] = 's';
 319 
				    fmtp[strlen(fmtp)-1] = 's';
307 
				    sprintf(bit, fmtp, "NA");
 320 
				    _my_sprintf("NA")
308 
				} else {
 321 
				} else {
309 
				    sprintf(bit, fmtp, x);
 322 
				    _my_sprintf(x)
310 
				}
 323 
				}
311 
				break;
 324 
				break;
312 
			    }
 325 
			    }
313 
			case INTSXP:
 326 
			case INTSXP:
314 
			    {
 327 
			    {
315 
				int x = INTEGER(_this)[ns % thislen];
 328 
				int x = INTEGER(_this)[ns % thislen];
316 
				if (checkfmt(fmtp, "dixX"))
 329 
				if (checkfmt(fmtp, "dixX"))
317 
				    error("%s",
 330 
				    error(_("invalid format '%s'; %s"), fmtp,
318 
					  _("use format %d, %i, %x or %X for integer objects"));
 331 
					  _("use format %d, %i, %x or %X for integer objects"));
319 
				if (x == NA_INTEGER) {
 332 
				if (x == NA_INTEGER) {
320 
				    fmtp[strlen(fmtp)-1] = 's';
 333 
				    fmtp[strlen(fmtp)-1] = 's';
321 
				    sprintf(bit, fmtp, "NA");
 334 
				    _my_sprintf("NA")
322 
				} else {
 335 
				} else {
323 
				    sprintf(bit, fmtp, x);
 336 
				    _my_sprintf(x)
324 
				}
 337 
				}
325 
				break;
 338 
				break;
326 
			    }
 339 
			    }
327 
			case REALSXP:
 340 
			case REALSXP:
328 
			    {
 341 
			    {
329 
				double x = REAL(_this)[ns % thislen];
 342 
				double x = REAL(_this)[ns % thislen];
330 
				if (checkfmt(fmtp, "aAfeEgG"))
 343 
				if (checkfmt(fmtp, "aAfeEgG"))
331 
				    error("%s",
 344 
				    error(_("invalid format '%s'; %s"), fmtp,
332 
					  _("use format %f, %e, %g or %a for numeric objects"));
 345 
					  _("use format %f, %e, %g or %a for numeric objects"));
333 
				if (R_FINITE(x)) {
 346 
				if (R_FINITE(x)) {
334 
				    sprintf(bit, fmtp, x);
 347 
				    _my_sprintf(x)
335 
				} else {
 348 
				} else {
336 
				    char *p = Rf_strchr(fmtp, '.');
 349 
				    char *p = Rf_strchr(fmtp, '.');
337 
				    if (p) {
 350 
				    if (p) {
338 
					*p++ = 's'; *p ='\0';
 351 
					*p++ = 's'; *p ='\0';
339 
				    } else
 352 
				    } else
340 
					fmtp[strlen(fmtp)-1] = 's';
 353 
					fmtp[strlen(fmtp)-1] = 's';
341 
				    if (ISNA(x)) {
 354 
				    if (ISNA(x)) {
342 
					if (strcspn(fmtp, " ") < strlen(fmtp))
 355 
					if (strcspn(fmtp, " ") < strlen(fmtp))
343 
					    sprintf(bit, fmtp, " NA");
 356 
					    _my_sprintf(" NA")
344 
					else
 357 
					else
345 
					    sprintf(bit, fmtp, "NA");
 358 
					    _my_sprintf("NA")
346 
				    } else if (ISNAN(x)) {
 359 
				    } else if (ISNAN(x)) {
347 
					if (strcspn(fmtp, " ") < strlen(fmtp))
 360 
					if (strcspn(fmtp, " ") < strlen(fmtp))
348 
					    sprintf(bit, fmtp, " NaN");
 361 
					    _my_sprintf(" NaN")
349 
					else
 362 
					else
350 
					    sprintf(bit, fmtp, "NaN");
 363 
					    _my_sprintf("NaN")
351 
				    } else if (x == R_PosInf) {
 364 
				    } else if (x == R_PosInf) {
352 
					if (strcspn(fmtp, "+") < strlen(fmtp))
 365 
					if (strcspn(fmtp, "+") < strlen(fmtp))
353 
					    sprintf(bit, fmtp, "+Inf");
 366 
					    _my_sprintf("+Inf")
354 
					else if (strcspn(fmtp, " ") < strlen(fmtp))
 367 
					else if (strcspn(fmtp, " ") < strlen(fmtp))
355 
					    sprintf(bit, fmtp, " Inf");
 368 
					    _my_sprintf(" Inf")
356 
					else
 369 
					else
357 
					    sprintf(bit, fmtp, "Inf");
 370 
					    _my_sprintf("Inf")
358 
				    } else if (x == R_NegInf)
 371 
				    } else if (x == R_NegInf)
359 
					sprintf(bit, fmtp, "-Inf");
 372 
					_my_sprintf("-Inf")
360 
				}
 373 
				}
361 
				break;
 374 
				break;
362 
			    }
 375 
			    }
363 
			case STRSXP:
 376 
			case STRSXP:
364 
			    /* NA_STRING will be printed as 'NA' */
 377 
			    /* NA_STRING will be printed as 'NA' */
365 
			    if (checkfmt(fmtp, "s"))
 378 
			    if (checkfmt(fmtp, "s"))
- 
 
 379 
				error(_("invalid format '%s'; %s"), fmtp,
366 
				error("%s", _("use format %s for character objects"));
 380 
				      _("use format %s for character objects"));
367 
 
 381 
 
368 
			    ss = TRANSLATE_CHAR(_this, ns % thislen);
 382 
			    ss = TRANSLATE_CHAR(_this, ns % thislen);
369 
			    if(fmtp[1] != 's') {
 383 
			    if(fmtp[1] != 's') {
370 
				if(strlen(ss) > MAXLINE)
 384 
				if(strlen(ss) > MAXLINE)
371 
				    warning(_("likely truncation of character string to %d characters"),
 385 
				    warning(_("likely truncation of character string to %d characters"),
372 
					    MAXLINE-1);
 386 
					    MAXLINE-1);
373 
				snprintf(bit, MAXLINE, fmtp, ss);
 387 
				_my_sprintf(ss)
374 
				bit[MAXLINE] = '\0';
 388 
				bit[MAXLINE] = '\0';
375 
				ss = NULL;
 389 
				ss = NULL;
376 
			    }
 390 
			    }
377 
			    break;
 391 
			    break;
378 
 
 392