View | Details | Raw Unified | Return to bug 16932 | Differences between
and this patch

Collapse All | Expand All

(-)seq.c (-37 / +68 lines)
Lines 1-7 Link Here
1
/*
1
/*
2
 *  R : A Computer Language for Statistical Data Analysis
2
 *  R : A Computer Language for Statistical Data Analysis
3
 *  Copyright (C) 1995-1998  Robert Gentleman and Ross Ihaka
3
 *  Copyright (C) 1995-1998  Robert Gentleman and Ross Ihaka
4
 *  Copyright (C) 1998-2016  The R Core Team.
4
 *  Copyright (C) 1998-2017  The R Core Team.
5
 *
5
 *
6
 *  This program is free software; you can redistribute it and/or modify
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
7
 *  it under the terms of the GNU General Public License as published by
Lines 175-187 Link Here
175
    return seq_colon(n1, n2, call);
175
    return seq_colon(n1, n2, call);
176
}
176
}
177
177
178
#ifdef LONG_VECTOR_SUPPORT
179
#define gi(t, i) (R_xlen_t) REAL(t)[i]
180
#else
181
#define gi(t, i) INTEGER(t)[i]
182
#endif
183
178
/* rep.int(x, times) for a vector times */
184
/* rep.int(x, times) for a vector times */
179
static SEXP rep2(SEXP s, SEXP ncopy)
185
static SEXP rep2(SEXP s, SEXP ncopy)
180
{
186
{
181
    R_xlen_t i, na, nc, n;
187
    R_xlen_t i, na, nc, n, j;
182
    int j;
183
    SEXP a, t;
188
    SEXP a, t;
184
189
190
#ifdef LONG_VECTOR_SUPPORT
191
    PROTECT(t = coerceVector(ncopy, REALSXP));
192
193
    nc = xlength(ncopy);
194
    na = 0;
195
    for (i = 0; i < nc; i++) {
196
//	if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
197
	if (!R_FINITE(REAL(t)[i]) || REAL(t)[i] < 0)
198
	    error(_("invalid '%s' value"), "times");
199
	na += (R_xlen_t) REAL(t)[i];
200
    }
201
#else
185
    PROTECT(t = coerceVector(ncopy, INTSXP));
202
    PROTECT(t = coerceVector(ncopy, INTSXP));
186
203
187
    nc = xlength(ncopy);
204
    nc = xlength(ncopy);
Lines 192-197 Link Here
192
	    error(_("invalid '%s' value"), "times");
209
	    error(_("invalid '%s' value"), "times");
193
	na += INTEGER(t)[i];
210
	na += INTEGER(t)[i];
194
    }
211
    }
212
#endif
195
213
196
/*    R_xlen_t ni = NINTERRUPT, ratio;
214
/*    R_xlen_t ni = NINTERRUPT, ratio;
197
    if(nc > 0) {
215
    if(nc > 0) {
Lines 204-238 Link Here
204
    case LGLSXP:
222
    case LGLSXP:
205
	for (i = 0; i < nc; i++) {
223
	for (i = 0; i < nc; i++) {
206
//	    if ((i+1) % ni == 0) R_CheckUserInterrupt();
224
//	    if ((i+1) % ni == 0) R_CheckUserInterrupt();
207
	    for (j = 0; j < INTEGER(t)[i]; j++)
225
	    for (j = 0; j < gi(t, i); j++)
208
		LOGICAL(a)[n++] = LOGICAL(s)[i];
226
		LOGICAL(a)[n++] = LOGICAL(s)[i];
209
	}
227
	}
210
	break;
228
	break;
211
    case INTSXP:
229
    case INTSXP:
212
	for (i = 0; i < nc; i++) {
230
	for (i = 0; i < nc; i++) {
213
//	    if ((i+1) % ni == 0) R_CheckUserInterrupt();
231
//	    if ((i+1) % ni == 0) R_CheckUserInterrupt();
214
	    for (j = 0; j < INTEGER(t)[i]; j++)
232
	    for (j = 0; j < gi(t, i); j++)
215
		INTEGER(a)[n++] = INTEGER(s)[i];
233
		INTEGER(a)[n++] = INTEGER(s)[i];
216
	}
234
	}
217
	break;
235
	break;
218
    case REALSXP:
236
    case REALSXP:
219
	for (i = 0; i < nc; i++) {
237
	for (i = 0; i < nc; i++) {
220
//	    if ((i+1) % ni == 0) R_CheckUserInterrupt();
238
//	    if ((i+1) % ni == 0) R_CheckUserInterrupt();
221
	    for (j = 0; j < INTEGER(t)[i]; j++)
239
	    for (j = 0; j < gi(t, i); j++)
222
		REAL(a)[n++] = REAL(s)[i];
240
		REAL(a)[n++] = REAL(s)[i];
223
	}
241
	}
224
	break;
242
	break;
225
    case CPLXSXP:
243
    case CPLXSXP:
226
	for (i = 0; i < nc; i++) {
244
	for (i = 0; i < nc; i++) {
227
//	    if ((i+1) % ni == 0) R_CheckUserInterrupt();
245
//	    if ((i+1) % ni == 0) R_CheckUserInterrupt();
228
	    for (j = 0; j < INTEGER(t)[i]; j++)
246
	    for (j = 0; j < gi(t, i); j++)
229
		COMPLEX(a)[n++] = COMPLEX(s)[i];
247
		COMPLEX(a)[n++] = COMPLEX(s)[i];
230
	}
248
	}
231
	break;
249
	break;
232
    case STRSXP:
250
    case STRSXP:
233
	for (i = 0; i < nc; i++) {
251
	for (i = 0; i < nc; i++) {
234
//	    if ((i+1) % ni == 0) R_CheckUserInterrupt();
252
//	    if ((i+1) % ni == 0) R_CheckUserInterrupt();
235
	    for (j = 0; j < INTEGER(t)[i]; j++)
253
	    for (j = 0; j < gi(t, i); j++)
236
		SET_STRING_ELT(a, n++, STRING_ELT(s, i));
254
		SET_STRING_ELT(a, n++, STRING_ELT(s, i));
237
	}
255
	}
238
	break;
256
	break;
Lines 241-247 Link Here
241
	for (i = 0; i < nc; i++) {
259
	for (i = 0; i < nc; i++) {
242
//	    if ((i+1) % ni == 0) R_CheckUserInterrupt();
260
//	    if ((i+1) % ni == 0) R_CheckUserInterrupt();
243
	    SEXP elt = lazy_duplicate(VECTOR_ELT(s, i));
261
	    SEXP elt = lazy_duplicate(VECTOR_ELT(s, i));
244
	    for (j = 0; j < INTEGER(t)[i]; j++)
262
	    for (j = 0; j < gi(t, i); j++)
245
		SET_VECTOR_ELT(a, n++, elt);
263
		SET_VECTOR_ELT(a, n++, elt);
246
	    if (j > 1) SET_NAMED(elt, 2);
264
	    if (j > 1) SET_NAMED(elt, 2);
247
	}
265
	}
Lines 249-255 Link Here
249
    case RAWSXP:
267
    case RAWSXP:
250
	for (i = 0; i < nc; i++) {
268
	for (i = 0; i < nc; i++) {
251
//	    if ((i+1) % ni == 0) R_CheckUserInterrupt();
269
//	    if ((i+1) % ni == 0) R_CheckUserInterrupt();
252
	    for (j = 0; j < INTEGER(t)[i]; j++)
270
	    for (j = 0; j < gi(t, i); j++)
253
		RAW(a)[n++] = RAW(s)[i];
271
		RAW(a)[n++] = RAW(s)[i];
254
	}
272
	}
255
	break;
273
	break;
Lines 334-340 Link Here
334
	      type2char(TYPEOF(s)));
352
	      type2char(TYPEOF(s)));
335
353
336
    nc = xlength(ncopy); // might be 0
354
    nc = xlength(ncopy); // might be 0
337
    if (nc != 1 && nc == xlength(s))
355
    if (nc == xlength(s))
338
	PROTECT(a = rep2(s, ncopy));
356
	PROTECT(a = rep2(s, ncopy));
339
    else {
357
    else {
340
	if (nc != 1) error(_("invalid '%s' value"), "times");
358
	if (nc != 1) error(_("invalid '%s' value"), "times");
Lines 434-440 Link Here
434
452
435
/* rep(), allowing for both times and each ;
453
/* rep(), allowing for both times and each ;
436
 * -----  nt == length(times) ;  if (nt == 1)  'times' is *not* accessed  */
454
 * -----  nt == length(times) ;  if (nt == 1)  'times' is *not* accessed  */
437
static SEXP rep4(SEXP x, SEXP times, R_xlen_t len, int each, R_xlen_t nt)
455
static SEXP rep4(SEXP x, SEXP times, R_xlen_t len, R_xlen_t each, R_xlen_t nt)
438
{
456
{
439
    SEXP a;
457
    SEXP a;
440
    R_xlen_t lx = xlength(x);
458
    R_xlen_t lx = xlength(x);
Lines 455-461 Link Here
455
	else {
473
	else {
456
	    for(i = 0, k = 0, k2 = 0; i < lx; i++) {
474
	    for(i = 0, k = 0, k2 = 0; i < lx; i++) {
457
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
475
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
458
		for(j = 0, sum = 0; j < each; j++) sum += INTEGER(times)[k++];
476
		for(j = 0, sum = 0; j < each; j++) sum += gi(times, k++);
459
		for(k3 = 0; k3 < sum; k3++) {
477
		for(k3 = 0; k3 < sum; k3++) {
460
		    LOGICAL(a)[k2++] = LOGICAL(x)[i];
478
		    LOGICAL(a)[k2++] = LOGICAL(x)[i];
461
		    if(k2 == len) goto done;
479
		    if(k2 == len) goto done;
Lines 472-478 Link Here
472
	else {
490
	else {
473
	    for(i = 0, k = 0, k2 = 0; i < lx; i++) {
491
	    for(i = 0, k = 0, k2 = 0; i < lx; i++) {
474
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
492
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
475
		for(j = 0, sum = 0; j < each; j++) sum += INTEGER(times)[k++];
493
		for(j = 0, sum = 0; j < each; j++) sum += gi(times, k++);
476
		for(k3 = 0; k3 < sum; k3++) {
494
		for(k3 = 0; k3 < sum; k3++) {
477
		    INTEGER(a)[k2++] = INTEGER(x)[i];
495
		    INTEGER(a)[k2++] = INTEGER(x)[i];
478
		    if(k2 == len) goto done;
496
		    if(k2 == len) goto done;
Lines 489-495 Link Here
489
	else {
507
	else {
490
	    for(i = 0, k = 0, k2 = 0; i < lx; i++) {
508
	    for(i = 0, k = 0, k2 = 0; i < lx; i++) {
491
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
509
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
492
		for(j = 0, sum = 0; j < each; j++) sum += INTEGER(times)[k++];
510
		for(j = 0, sum = 0; j < each; j++) sum += gi(times, k++);
493
		for(k3 = 0; k3 < sum; k3++) {
511
		for(k3 = 0; k3 < sum; k3++) {
494
		    REAL(a)[k2++] = REAL(x)[i];
512
		    REAL(a)[k2++] = REAL(x)[i];
495
		    if(k2 == len) goto done;
513
		    if(k2 == len) goto done;
Lines 506-512 Link Here
506
	else {
524
	else {
507
	    for(i = 0, k = 0, k2 = 0; i < lx; i++) {
525
	    for(i = 0, k = 0, k2 = 0; i < lx; i++) {
508
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
526
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
509
		for(j = 0, sum = 0; j < each; j++) sum += INTEGER(times)[k++];
527
		for(j = 0, sum = 0; j < each; j++) sum += gi(times, k++);
510
		for(k3 = 0; k3 < sum; k3++) {
528
		for(k3 = 0; k3 < sum; k3++) {
511
		    COMPLEX(a)[k2++] = COMPLEX(x)[i];
529
		    COMPLEX(a)[k2++] = COMPLEX(x)[i];
512
		    if(k2 == len) goto done;
530
		    if(k2 == len) goto done;
Lines 523-529 Link Here
523
	else {
541
	else {
524
	    for(i = 0, k = 0, k2 = 0; i < lx; i++) {
542
	    for(i = 0, k = 0, k2 = 0; i < lx; i++) {
525
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
543
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
526
		for(j = 0, sum = 0; j < each; j++) sum += INTEGER(times)[k++];
544
		for(j = 0, sum = 0; j < each; j++) sum += gi(times, k++);
527
		for(k3 = 0; k3 < sum; k3++) {
545
		for(k3 = 0; k3 < sum; k3++) {
528
		    SET_STRING_ELT(a, k2++, STRING_ELT(x, i));
546
		    SET_STRING_ELT(a, k2++, STRING_ELT(x, i));
529
		    if(k2 == len) goto done;
547
		    if(k2 == len) goto done;
Lines 541-547 Link Here
541
	else {
559
	else {
542
	    for(i = 0, k = 0, k2 = 0; i < lx; i++) {
560
	    for(i = 0, k = 0, k2 = 0; i < lx; i++) {
543
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
561
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
544
		for(j = 0, sum = 0; j < each; j++) sum += INTEGER(times)[k++];
562
		for(j = 0, sum = 0; j < each; j++) sum += gi(times, k++);
545
		for(k3 = 0; k3 < sum; k3++) {
563
		for(k3 = 0; k3 < sum; k3++) {
546
		    SET_VECTOR_ELT(a, k2++, VECTOR_ELT(x, i));
564
		    SET_VECTOR_ELT(a, k2++, VECTOR_ELT(x, i));
547
		    if(k2 == len) goto done;
565
		    if(k2 == len) goto done;
Lines 558-564 Link Here
558
	else {
576
	else {
559
	    for(i = 0, k = 0, k2 = 0; i < lx; i++) {
577
	    for(i = 0, k = 0, k2 = 0; i < lx; i++) {
560
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
578
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
561
		for(j = 0, sum = 0; j < each; j++) sum += INTEGER(times)[k++];
579
		for(j = 0, sum = 0; j < each; j++) sum += gi(times, k++);
562
		for(k3 = 0; k3 < sum; k3++) {
580
		for(k3 = 0; k3 < sum; k3++) {
563
		    RAW(a)[k2++] = RAW(x)[i];
581
		    RAW(a)[k2++] = RAW(x)[i];
564
		    if(k2 == len) goto done;
582
		    if(k2 == len) goto done;
Lines 582-589 Link Here
582
SEXP attribute_hidden do_rep(SEXP call, SEXP op, SEXP args, SEXP rho)
600
SEXP attribute_hidden do_rep(SEXP call, SEXP op, SEXP args, SEXP rho)
583
{
601
{
584
    SEXP ans, x, times = R_NilValue;
602
    SEXP ans, x, times = R_NilValue;
585
    int each = 1, nprotect = 3;
603
    int nprotect = 3;
586
    R_xlen_t i, lx, len = NA_INTEGER, nt;
604
    R_xlen_t i, lx, len = NA_INTEGER, each = 1, nt;
587
    static SEXP do_rep_formals = NULL;
605
    static SEXP do_rep_formals = NULL;
588
606
589
    /* includes factors, POSIX[cl]t, Date */
607
    /* includes factors, POSIX[cl]t, Date */
Lines 624-632 Link Here
624
	warningcall(call, _("first element used of '%s' argument"),
642
	warningcall(call, _("first element used of '%s' argument"),
625
		    "length.out");
643
		    "length.out");
626
644
645
    double seach = asReal(CADDDR(args));
646
    if (R_FINITE(seach)) {
647
    if (seach < 0)
648
	errorcall(call, _("invalid '%s' argument"), "each");
649
    each = (R_xlen_t) seach;
650
    } else {
627
    each = asInteger(CADDDR(args));
651
    each = asInteger(CADDDR(args));
628
    if(each != NA_INTEGER && each < 0)
652
    if(each != NA_INTEGER && each < 0)
629
	errorcall(call, _("invalid '%s' argument"), "each");
653
	errorcall(call, _("invalid '%s' argument"), "each");
654
    }
630
    if(length(CADDDR(args)) != 1)
655
    if(length(CADDDR(args)) != 1)
631
	warningcall(call, _("first element used of '%s' argument"), "each");
656
	warningcall(call, _("first element used of '%s' argument"), "each");
632
    if(each == NA_INTEGER) each = 1;
657
    if(each == NA_INTEGER) each = 1;
Lines 652-688 Link Here
652
	nt = 1;
677
	nt = 1;
653
    } else {
678
    } else {
654
	R_xlen_t sum = 0;
679
	R_xlen_t sum = 0;
655
	nt = CADR(args) == R_MissingArg ? 1 : XLENGTH(CADR(args));
680
#ifdef LONG_VECTOR_SUPPORT
681
	if(CADR(args) == R_MissingArg) PROTECT(times = ScalarReal(1));
682
	else PROTECT(times = coerceVector(CADR(args), REALSXP));
683
#else
684
	if(CADR(args) == R_MissingArg) PROTECT(times = ScalarInteger(1));
685
	else PROTECT(times = coerceVector(CADR(args), INTSXP));
686
#endif
687
	nprotect++;
688
	nt = XLENGTH(times);
656
	if(nt == 1) {
689
	if(nt == 1) {
657
	    R_xlen_t it;
690
	    R_xlen_t it;
658
	    if(CADR(args) == R_MissingArg) it = 1; else {
659
		if(!isVectorAtomic(CADR(args))) {
660
		    warningcall(call, _("'%s' is not an atomic vector.  This is deprecated."),
661
				"times");
662
		    PROTECT(times = coerceVector(CADR(args), REALSXP)); nprotect++;
663
		} else times = CADR(args);
664
#ifdef LONG_VECTOR_SUPPORT
691
#ifdef LONG_VECTOR_SUPPORT
665
		double rt = asReal(times); // asReal(CADR(args));
692
		double rt = REAL(times)[0];
666
		if (!R_FINITE(rt) || rt < 0)
693
		if (!R_FINITE(rt) || rt < 0)
667
		    errorcall(call, _("invalid '%s' argument"), "times");
694
		    errorcall(call, _("invalid '%s' argument"), "times");
668
		it = (R_xlen_t) rt;
695
		it = (R_xlen_t) rt;
669
#else
696
#else
670
		it = asInteger(times); // asInteger(CADR(args));
697
		it = INTEGER(times)[0];
671
		if (it == NA_INTEGER || it < 0)
698
		if (it == NA_INTEGER || it < 0)
672
		    errorcall(call, _("invalid '%s' argument"), "times");
699
		    errorcall(call, _("invalid '%s' argument"), "times");
673
#endif
700
#endif
674
	    }
675
	    len = lx * it * each;
701
	    len = lx * it * each;
676
	} else { // nt != 1 -- only for this case 'times' is accessed, here and in rep4()
702
	} else { // nt != 1
677
	    if(nt != lx * each)
703
	    if(nt != lx * each)
678
		errorcall(call, _("invalid '%s' argument"), "times");
704
		errorcall(call, _("invalid '%s' argument"), "times");
679
	    // FIXME: 1. allow large int., i.e. REALSXP; would need even more changes in rep4()
680
	    //        2. this does still work with  list(1,2) [which should be deprecated]
681
	    PROTECT(times = coerceVector(CADR(args), INTSXP)); nprotect++;
682
	    for(i = 0; i < nt; i++) {
705
	    for(i = 0; i < nt; i++) {
683
		int it = INTEGER(times)[i];
706
		R_xlen_t it;
707
#ifdef LONG_VECTOR_SUPPORT
708
		double rt = REAL(times)[i];
709
		if (!R_FINITE(rt) || rt < 0)
710
		    errorcall(call, _("invalid '%s' argument"), "times");
711
		it = (R_xlen_t) rt;
712
#else
713
		it = INTEGER(times)[i];
684
		if (it == NA_INTEGER || it < 0)
714
		if (it == NA_INTEGER || it < 0)
685
		    errorcall(call, _("invalid '%s' argument"), "times");
715
		    errorcall(call, _("invalid '%s' argument"), "times");
716
#endif
686
		sum += it;
717
		sum += it;
687
	    }
718
	    }
688
	    len = sum;
719
	    len = sum;
Lines 695-701 Link Here
695
    SEXP xn = PROTECT(getAttrib(x, R_NamesSymbol));
726
    SEXP xn = PROTECT(getAttrib(x, R_NamesSymbol));
696
    nprotect++;
727
    nprotect++;
697
    PROTECT(ans = rep4(x, times, len, each, nt));
728
    PROTECT(ans = rep4(x, times, len, each, nt));
698
    if (length(xn) > 0)
729
    if (xlength(xn) > 0)
699
	setAttrib(ans, R_NamesSymbol, rep4(xn, times, len, each, nt));
730
	setAttrib(ans, R_NamesSymbol, rep4(xn, times, len, each, nt));
700
731
701
#ifdef _S4_rep_keepClass
732
#ifdef _S4_rep_keepClass

Return to bug 16932