The R Project SVN R

Rev

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

Rev 48399 Rev 48415
Line 1... Line 1...
1 
/*
 1 
/*
2 
 *  R : A Computer Language for Statistical Data Analysis
 2 
 *  R : A Computer Language for Statistical Data Analysis
3 
 *  Copyright (C) 2002-9     the R Development Core Team
 3 
 *  Copyright (C) 2002--2009     the R Development Core Team
4 
 *
 4 
 *
5 
 *  This program is free software; you can redistribute it and/or modify
 5 
 *  This program is free software; you can redistribute it and/or modify
6 
 *  it under the terms of the GNU General Public License as published by
 6 
 *  it under the terms of the GNU General Public License as published by
7 
 *  the Free Software Foundation; either version 2 of the License, or
 7 
 *  the Free Software Foundation; either version 2 of the License, or
8 
 *  (at your option) any later version.
 8 
 *  (at your option) any later version.
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, _this, a[MAXNARGS], tmp, ans /* -Wall */ = R_NilValue;
 78 
    SEXP format, _this, a[MAXNARGS], 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_)				\
Line 104... Line 104...
104 
    if(nargs >= MAXNARGS)
 104 
    if(nargs >= MAXNARGS)
105 
	error(_("only %d arguments are allowed"), MAXNARGS);
 105 
	error(_("only %d arguments are allowed"), MAXNARGS);
106 
 
 106 
 
107 
    /* record the args for possible coercion and later re-ordering */
 107 
    /* record the args for possible coercion and later re-ordering */
108 
    for(i = 0; i < nargs; i++, args = CDR(args)) {
 108 
    for(i = 0; i < nargs; i++, args = CDR(args)) {
- 
 
 109 
	SEXPTYPE t_ai;
109 
	a[i] = CAR(args);
 110 
	a[i] = CAR(args);
- 
 
 111 
	if((t_ai = TYPEOF(a[i])) == LANGSXP || t_ai == SYMSXP) /* << maybe add more .. */
- 
 
 112 
	    error(_("invalid type of argument[%d]: '%s'"),
- 
 
 113 
		  i+1, CHAR(type2str(t_ai)));
110 
	lens[i] = length(a[i]);
 114 
	lens[i] = length(a[i]);
111 
	if(lens[i] == 0) return allocVector(STRSXP, 0);
 115 
	if(lens[i] == 0) return allocVector(STRSXP, 0);
112 
    }
 116 
    }
113 
 
 117 
 
114 
#define CHECK_maxlen							\
 118 
#define CHECK_maxlen							\
Line 231... Line 235...
231 
			    sprintf(bit, fmt, star_arg);
 235 
			    sprintf(bit, fmt, star_arg);
232 
			else
 236 
			else
233 
			    strcpy(bit, fmt);
 237 
			    strcpy(bit, fmt);
234 
			/* was sprintf(..)  for which some compiler warn */
 238 
			/* was sprintf(..)  for which some compiler warn */
235 
		    } else {
 239 
		    } else {
- 
 
 240 
			Rboolean did_this = FALSE;
236 
			if(nthis < 0) {
 241 
			if(nthis < 0) {
237 
			    if (cnt >= nargs) error(_("too few arguments"));
 242 
			    if (cnt >= nargs) error(_("too few arguments"));
238 
			    nthis = cnt++;
 243 
			    nthis = cnt++;
239 
			}
 244 
			}
240 
			_this = a[nthis];
 245 
			_this = a[nthis];
Line 249... Line 254...
249 
				error(_("the '%*' constructed 'fmt2' length exceeds maximum of %d"),
 254 
				error(_("the '%*' constructed 'fmt2' length exceeds maximum of %d"),
250 
				      MAXLINE);
 255 
				      MAXLINE);
251 
			    fmtp = fmt2;
 256 
			    fmtp = fmt2;
252 
			} else fmtp = fmt;
 257 
			} else fmtp = fmt;
253 
 
 258 
 
- 
 
 259 
#define CHECK_this_length						\
- 
 
 260 
			PROTECT(_this);					\
- 
 
 261 
			thislen = length(_this);			\
- 
 
 262 
			if(thislen == 0)				\
- 
 
 263 
			    error(_("coercion has changed vector length to 0"))
- 
 
 264 
 
254 
			/* Now let us see if some minimal coercion
 265 
			/* Now let us see if some minimal coercion
255 
			   would be sensible, but only do so once, for ns = 0: */
 266 
			   would be sensible, but only do so once, for ns = 0: */
256 
			if(ns == 0) {
 267 
			if(ns == 0) {
257 
			    Rboolean do_check;
 268 
			    SEXP tmp; Rboolean do_check;
258 
			    switch(*findspec(fmtp)) {
 269 
			    switch(*findspec(fmtp)) {
259 
			    case 'd':
 270 
			    case 'd':
260 
			    case 'i':
 271 
			    case 'i':
261 
			    case 'x':
 272 
			    case 'x':
262 
			    case 'X':
 273 
			    case 'X':
Line 273... Line 284...
273 
			    case 'e':
 284 
			    case 'e':
274 
			    case 'f':
 285 
			    case 'f':
275 
			    case 'g':
 286 
			    case 'g':
276 
			    case 'E':
 287 
			    case 'E':
277 
			    case 'G':
 288 
			    case 'G':
278 
				if(TYPEOF(_this) != REALSXP) {
 289 
				if(TYPEOF(_this) != REALSXP &&
- 
 
 290 
				   /* no automatic as.double(<string>) : */
- 
 
 291 
				   TYPEOF(_this) != STRSXP) {
279 
				    PROTECT(tmp = lang2(install("as.double"), _this));
 292 
				    PROTECT(tmp = lang2(install("as.double"), _this));
280 
#define COERCE_THIS_TO_A						\
 293 
#define COERCE_THIS_TO_A						\
281 
				    _this = eval(tmp, env);		\
 294 
				    _this = eval(tmp, env);		\
282 
				    UNPROTECT(1);			\
 295 
				    UNPROTECT(1);			\
283 
				    PROTECT(a[nthis] = _this);		\
 296 
				    PROTECT(a[nthis] = _this);		\
284 
				    nprotect++;				\
 297 
				    nprotect++;				\
- 
 
 298 
				    did_this = TRUE;			\
- 
 
 299 
				    CHECK_this_length;			\
285 
				    do_check = (lens[nthis] == maxlen);	\
 300 
				    do_check = (lens[nthis] == maxlen);	\
286 
				    lens[nthis] = length(_this); /* may have changed! */ \
 301 
				    lens[nthis] = thislen; /* may have changed! */ \
287 
				    if(do_check && lens[nthis] < maxlen) { \
 302 
				    if(do_check && thislen < maxlen) {	\
288 
					CHECK_maxlen;			\
 303 
					CHECK_maxlen;			\
289 
				    }
 304 
				    }
290 
 
 305 
 
291 
				    COERCE_THIS_TO_A
 306 
				    COERCE_THIS_TO_A
292 
				}
 307 
				}
Line 299... Line 314...
299 
				}
 314 
				}
300 
				break;
 315 
				break;
301 
			    default:
 316 
			    default:
302 
				break;
 317 
				break;
303 
			    }
 318 
			    }
304 
			}
 319 
			} /* ns == 0 (first-time only) */
305 
 
 320 
 
306 
			PROTECT(_this);
 321 
			if(!did_this)
307 
			thislen = length(_this);
 - 
 
308 
			if(thislen == 0)
 322 
			    CHECK_this_length;
309 
			    error(_("coercion has changed vector length to 0"));
 - 
 
310 
 
 323 
 
311 
			switch(TYPEOF(_this)) {
 324 
			switch(TYPEOF(_this)) {
312 
			case LGLSXP:
 325 
			case LGLSXP:
313 
			    {
 326 
			    {
314 
				int x = LOGICAL(_this)[ns % thislen];
 327 
				int x = LOGICAL(_this)[ns % thislen];