The R Project SVN – R – Diff – /trunk/src/main/subscript.c



 */
attribute_hidden SEXP
vectorIndex(SEXP x, SEXP thesub, int start, int stop, int pok, SEXP call,
	    Rboolean dup)
{
 
 
 
 
    /* sanity check */
    if (dup && MAYBE_SHARED(x))
	error("should only be called in an assignment context.");
 
    for(int i = start; i < stop; i++) {
	if(!isVectorList(x) && !isPairList(x)) {
	    if (i)
		errorcall(call, _("recursive indexing failed at level %d\n"), i+1);
	    else
		errorcall(call, _("attempt to select more than one element in %s"), "vectorIndex");
	}
	PROTECT(x);
	SEXP cx, names = PROTECT(getAttrib(x, R_NamesSymbol));
	R_xlen_t offset = get1index(thesub, names, xlength(x), pok, i, call);
 
	UNPROTECT(2); /* x, names */
	if(offset < 0 || offset >= xlength(x))
	    errorcall(call, _("no such index at level %d\n"), i+1);
	if(isPairList(x)) {
#ifdef LONG_VECTOR_SUPPORT

		    }
		    if(k == 0.) {rv[i] = 0.; break;}
		    if (k > pdims[j]) {
			ECALL_OutOfBounds(x, j, (R_xlen_t)k, call);
		    }
		    rv[i] += (k - 1.) * (double)tdim;
		    tdim *= pdims[j];
		}
	    }
	} else {
	    s = coerceVector(s, INTSXP);

	if (R_FINITE(ii)) {
	    if (ii < min) min = ii;
	    if (ii > max) max = ii;
	} else isna = TRUE;
    }
    if (max >= (double)nx+1.) {
#ifndef LONG_VECTOR_SUPPORT
	if (max > INT_MAX) {
	    ECALL(call, _("subscript too large for 32-bit R"));
	}
#endif

	    SEXP indx = PROTECT(allocVector(LGLSXP, nx));
	    int *pindx = LOGICAL(indx);
	    for (i = 0; i < nx; i++) pindx[i] = 1;
	    for (i = 0; i < ns; i++) {
		double dx = ps[i];
		if (R_FINITE(dx) && dx <= -1  && -dx < (double)nx+1.) {
		    R_xlen_t ix = (R_xlen_t)(-dx - 1);
		    pindx[ix] = 0;
		}
	    }
	    s = logicalSubscript(indx, nx, nx, &stretch, call);

Rev 87180	Rev 87184
Line 344...	Line 344...
344	`*/`	344	`*/`
345	`attribute_hidden SEXP`	345	`attribute_hidden SEXP`
346	`vectorIndex(SEXP x, SEXP thesub, int start, int stop, int pok, SEXP call,`	346	`vectorIndex(SEXP x, SEXP thesub, int start, int stop, int pok, SEXP call,`
347	`Rboolean dup)`	347	`Rboolean dup)`
348	`{`	348	`{`
349	`int i;`	-
350	`R_xlen_t offset;`	-
351	`SEXP cx;`	-
352		-
353	`/* sanity check */`	349	`/* sanity check */`
354	`if (dup && MAYBE_SHARED(x))`	350	`if (dup && MAYBE_SHARED(x))`
355	`error("should only be called in an assignment context.");`	351	`error("should only be called in an assignment context.");`
356		352
357	`for(i = start; i < stop; i++) {`	353	`for(int i = start; i < stop; i++) {`
358	`if(!isVectorList(x) && !isPairList(x)) {`	354	`if(!isVectorList(x) && !isPairList(x)) {`
359	`if (i)`	355	`if (i)`
360	`errorcall(call, _("recursive indexing failed at level %d\n"), i+1);`	356	`errorcall(call, _("recursive indexing failed at level %d\n"), i+1);`
361	`else`	357	`else`
362	`errorcall(call, _("attempt to select more than one element in %s"), "vectorIndex");`	358	`errorcall(call, _("attempt to select more than one element in %s"), "vectorIndex");`
363	`}`	359	`}`
364	`PROTECT(x);`	360	`PROTECT(x);`
365	`SEXP names = PROTECT(getAttrib(x, R_NamesSymbol));`	361	`SEXP cx, names = PROTECT(getAttrib(x, R_NamesSymbol));`
366	`offset = get1index(thesub, names,`	362	`R_xlen_t offset = get1index(thesub, names, xlength(x), pok, i, call);`
367	`xlength(x), pok, i, call);`	-
368	`UNPROTECT(2); /* x, names */`	363	`UNPROTECT(2); /* x, names */`
369	`if(offset < 0 \|\| offset >= xlength(x))`	364	`if(offset < 0 \|\| offset >= xlength(x))`
370	`errorcall(call, _("no such index at level %d\n"), i+1);`	365	`errorcall(call, _("no such index at level %d\n"), i+1);`
371	`if(isPairList(x)) {`	366	`if(isPairList(x)) {`
372	`#ifdef LONG_VECTOR_SUPPORT`	367	`#ifdef LONG_VECTOR_SUPPORT`
Line 448...	Line 443...
448	`}`	443	`}`
449	`if(k == 0.) {rv[i] = 0.; break;}`	444	`if(k == 0.) {rv[i] = 0.; break;}`
450	`if (k > pdims[j]) {`	445	`if (k > pdims[j]) {`
451	`ECALL_OutOfBounds(x, j, (R_xlen_t)k, call);`	446	`ECALL_OutOfBounds(x, j, (R_xlen_t)k, call);`
452	`}`	447	`}`
453	`rv[i] += (k - 1.) * tdim;`	448	`rv[i] += (k - 1.) * (double)tdim;`
454	`tdim *= pdims[j];`	449	`tdim *= pdims[j];`
455	`}`	450	`}`
456	`}`	451	`}`
457	`} else {`	452	`} else {`
458	`s = coerceVector(s, INTSXP);`	453	`s = coerceVector(s, INTSXP);`
Line 802...	Line 797...
802	`if (R_FINITE(ii)) {`	797	`if (R_FINITE(ii)) {`
803	`if (ii < min) min = ii;`	798	`if (ii < min) min = ii;`
804	`if (ii > max) max = ii;`	799	`if (ii > max) max = ii;`
805	`} else isna = TRUE;`	800	`} else isna = TRUE;`
806	`}`	801	`}`
807	`if (max >= nx+1.) {`	802	`if (max >= (double)nx+1.) {`
808	`#ifndef LONG_VECTOR_SUPPORT`	803	`#ifndef LONG_VECTOR_SUPPORT`
809	`if (max > INT_MAX) {`	804	`if (max > INT_MAX) {`
810	`ECALL(call, _("subscript too large for 32-bit R"));`	805	`ECALL(call, _("subscript too large for 32-bit R"));`
811	`}`	806	`}`
812	`#endif`	807	`#endif`
Line 821...	Line 816...
821	`SEXP indx = PROTECT(allocVector(LGLSXP, nx));`	816	`SEXP indx = PROTECT(allocVector(LGLSXP, nx));`
822	`int *pindx = LOGICAL(indx);`	817	`int *pindx = LOGICAL(indx);`
823	`for (i = 0; i < nx; i++) pindx[i] = 1;`	818	`for (i = 0; i < nx; i++) pindx[i] = 1;`
824	`for (i = 0; i < ns; i++) {`	819	`for (i = 0; i < ns; i++) {`
825	`double dx = ps[i];`	820	`double dx = ps[i];`
826	`if (R_FINITE(dx) && dx <= -1 && -dx < nx+1.) {`	821	`if (R_FINITE(dx) && dx <= -1 && -dx < (double)nx+1.) {`
827	`R_xlen_t ix = (R_xlen_t)(-dx - 1);`	822	`R_xlen_t ix = (R_xlen_t)(-dx - 1);`
828	`pindx[ix] = 0;`	823	`pindx[ix] = 0;`
829	`}`	824	`}`
830	`}`	825	`}`
831	`s = logicalSubscript(indx, nx, nx, &stretch, call);`	826	`s = logicalSubscript(indx, nx, nx, &stretch, call);`

The R Project SVN R

(root)/trunk/src/main/subscript.c @ 28362 – Rev 87180 → 87184