The R Project SVN – R – Diff – /branches/R-exp-API/src/main/subscript.c



    int index = -1;
 
    if (i > 0)
	index = i - 1;
    else if (i == 0 || len < 2)
	error("attempt to select less than one element");
    else if (len == 2 && i > -3)
	index = 2 + i;
    else
	error("attempt to select more than one element");
    return(index);
}
 
int OneIndex(SEXP x, SEXP s, int len, int partial, SEXP *newname)
{
    SEXP names;
    int i, index, nx;
 
    if (length(s) > 1)
	error("attempt to select more than one element");
    if (length(s) < 1)
	error("attempt to select less than one element");
 
    index = -1;
    *newname = R_NilValue;
    switch(TYPEOF(s)) {
    case LGLSXP:

	if (index == -1)
	    index = nx;
	*newname = STRING(s)[0];
	break;
    default:
	error("invalid subscript type");
    }
    return index;
}
 
/* Get a single index for the [[ operator.

int get1index(SEXP s, SEXP names, int len, int pok)
{
    int index, i;
 
    if (length(s) > 1)
	error("attempt to select more than one element");
    if (length(s) < 1)
	error("attempt to select less than one element");
 
    index = -1;
    switch (TYPEOF(s)) {
    case LGLSXP:
    case INTSXP:

	    if (streql(CHAR(STRING(names)[i]), CHAR(PRINTNAME(s)))) {
		index = i;
		break;
	    }
    default:
	error("invalid subscript type");
    }
    return index;
}
 
/* Special Matrix Subscripting: Handles the case x[i] where */

	    if(INTEGER(s)[i + j * nrs] == NA_INTEGER) {
		INTEGER(rvec)[i] = NA_INTEGER;
		break;
	    }
	    if (INTEGER(s)[i + j * nrs] > INTEGER(dims)[j])
		error("subscript out of bounds");
	    INTEGER(rvec)[i] += (INTEGER(s)[i+j*nrs] - 1) * tdim;
	    tdim *= INTEGER(dims)[j];
	}
	/* transform to 1 based subscripting */
	if(INTEGER(rvec)[i] != NA_INTEGER)

    int canstretch, count, i, nmax;
    SEXP index;
    canstretch = *stretch;
#ifdef OLD
    if (ns > nx)
	error("subscript (%d) out of bounds, should be at most %d",
	      ns, nx);
#else
    if (!canstretch && ns > nx)
	error("(subscript) logical subscript too long");
    nmax = (ns > nx) ? ns : nx;
    *stretch = (ns > nx) ? ns : 0;
#endif
    if (ns == 0)
	return(allocVector(INTSXP, 0));

	    if (ii > max)
		max = ii;
	}
    }
    if (min < -nx)
	error("subscript out of bounds");
    if (max > nx) {
	if(canstretch) *stretch = max;
	else error("subscript out of bounds");
    }
    if (min < 0) {
	if (max == 0) return negativeSubscript(s, ns, nx);
	else error("only 0's may mix with negative subscripts");
    }
    else return positiveSubscript(s, ns, nx);
    return R_NilValue;
}
 

    	UNPROTECT(1);
	return tmp;
    case STRSXP:
	dnames = getAttrib(x, R_DimNamesSymbol);
	if (dnames == R_NilValue)
	    error("no dimnames attribute for array");
	dnames = VECTOR(dnames)[dim];
	return stringSubscript(s, ns, nd, dnames, &stretch);
    case SYMSXP:
	if (s == R_MissingArg)
	    return nullSubscript(nd);
    default:
	error("invalid subscript");
    }
    return R_NilValue;
}
 
/* Subscript creation.  The first thing we do is check to see */

	    if (s == R_MissingArg) {
		ans = nullSubscript(nx);
		break;
	    }
	default:
	    error("invalid subscript type");
	}
	UNPROTECT(1);
    }
    else error("subscripting on non-vector");
    return ans;
}

Rev 5603	Rev 5731
Line 27...	Line 27...
27	`int index = -1;`	27	`int index = -1;`
28		28
29	`if (i > 0)`	29	`if (i > 0)`
30	`index = i - 1;`	30	`index = i - 1;`
31	`else if (i == 0 \|\| len < 2)`	31	`else if (i == 0 \|\| len < 2)`
32	`error("attempt to select less than one element\n");`	32	`error("attempt to select less than one element");`
33	`else if (len == 2 && i > -3)`	33	`else if (len == 2 && i > -3)`
34	`index = 2 + i;`	34	`index = 2 + i;`
35	`else`	35	`else`
36	`error("attempt to select more than one element\n");`	36	`error("attempt to select more than one element");`
37	`return(index);`	37	`return(index);`
38	`}`	38	`}`
39		39
40	`int OneIndex(SEXP x, SEXP s, int len, int partial, SEXP *newname)`	40	`int OneIndex(SEXP x, SEXP s, int len, int partial, SEXP *newname)`
41	`{`	41	`{`
42	`SEXP names;`	42	`SEXP names;`
43	`int i, index, nx;`	43	`int i, index, nx;`
44		44
45	`if (length(s) > 1)`	45	`if (length(s) > 1)`
46	`error("attempt to select more than one element\n");`	46	`error("attempt to select more than one element");`
47	`if (length(s) < 1)`	47	`if (length(s) < 1)`
48	`error("attempt to select less than one element\n");`	48	`error("attempt to select less than one element");`
49		49
50	`index = -1;`	50	`index = -1;`
51	`*newname = R_NilValue;`	51	`*newname = R_NilValue;`
52	`switch(TYPEOF(s)) {`	52	`switch(TYPEOF(s)) {`
53	`case LGLSXP:`	53	`case LGLSXP:`
Line 100...	Line 100...
100	`if (index == -1)`	100	`if (index == -1)`
101	`index = nx;`	101	`index = nx;`
102	`*newname = STRING(s)[0];`	102	`*newname = STRING(s)[0];`
103	`break;`	103	`break;`
104	`default:`	104	`default:`
105	`error("invalid subscript type\n");`	105	`error("invalid subscript type");`
106	`}`	106	`}`
107	`return index;`	107	`return index;`
108	`}`	108	`}`
109		109
110	`/* Get a single index for the [[ operator.`	110	`/* Get a single index for the [[ operator.`
Line 113...	Line 113...
113	`int get1index(SEXP s, SEXP names, int len, int pok)`	113	`int get1index(SEXP s, SEXP names, int len, int pok)`
114	`{`	114	`{`
115	`int index, i;`	115	`int index, i;`
116		116
117	`if (length(s) > 1)`	117	`if (length(s) > 1)`
118	`error("attempt to select more than one element\n");`	118	`error("attempt to select more than one element");`
119	`if (length(s) < 1)`	119	`if (length(s) < 1)`
120	`error("attempt to select less than one element\n");`	120	`error("attempt to select less than one element");`
121		121
122	`index = -1;`	122	`index = -1;`
123	`switch (TYPEOF(s)) {`	123	`switch (TYPEOF(s)) {`
124	`case LGLSXP:`	124	`case LGLSXP:`
125	`case INTSXP:`	125	`case INTSXP:`
Line 153...	Line 153...
153	`if (streql(CHAR(STRING(names)[i]), CHAR(PRINTNAME(s)))) {`	153	`if (streql(CHAR(STRING(names)[i]), CHAR(PRINTNAME(s)))) {`
154	`index = i;`	154	`index = i;`
155	`break;`	155	`break;`
156	`}`	156	`}`
157	`default:`	157	`default:`
158	`error("invalid subscript type\n");`	158	`error("invalid subscript type");`
159	`}`	159	`}`
160	`return index;`	160	`return index;`
161	`}`	161	`}`
162		162
163	`/* Special Matrix Subscripting: Handles the case x[i] where */`	163	`/* Special Matrix Subscripting: Handles the case x[i] where */`
Line 181...	Line 181...
181	`if(INTEGER(s)[i + j * nrs] == NA_INTEGER) {`	181	`if(INTEGER(s)[i + j * nrs] == NA_INTEGER) {`
182	`INTEGER(rvec)[i] = NA_INTEGER;`	182	`INTEGER(rvec)[i] = NA_INTEGER;`
183	`break;`	183	`break;`
184	`}`	184	`}`
185	`if (INTEGER(s)[i + j * nrs] > INTEGER(dims)[j])`	185	`if (INTEGER(s)[i + j * nrs] > INTEGER(dims)[j])`
186	`error("subscript out of bounds\n");`	186	`error("subscript out of bounds");`
187	`INTEGER(rvec)[i] += (INTEGER(s)[i+jnrs] - 1) tdim;`	187	`INTEGER(rvec)[i] += (INTEGER(s)[i+jnrs] - 1) tdim;`
188	`tdim *= INTEGER(dims)[j];`	188	`tdim *= INTEGER(dims)[j];`
189	`}`	189	`}`
190	`/* transform to 1 based subscripting */`	190	`/* transform to 1 based subscripting */`
191	`if(INTEGER(rvec)[i] != NA_INTEGER)`	191	`if(INTEGER(rvec)[i] != NA_INTEGER)`
Line 210...	Line 210...
210	`int canstretch, count, i, nmax;`	210	`int canstretch, count, i, nmax;`
211	`SEXP index;`	211	`SEXP index;`
212	`canstretch = *stretch;`	212	`canstretch = *stretch;`
213	`#ifdef OLD`	213	`#ifdef OLD`
214	`if (ns > nx)`	214	`if (ns > nx)`
215	`error("subscript (%d) out of bounds, should be at most %d\n",`	215	`error("subscript (%d) out of bounds, should be at most %d",`
216	`ns, nx);`	216	`ns, nx);`
217	`#else`	217	`#else`
218	`if (!canstretch && ns > nx)`	218	`if (!canstretch && ns > nx)`
219	`error("(subscript) logical subscript too long\n");`	219	`error("(subscript) logical subscript too long");`
220	`nmax = (ns > nx) ? ns : nx;`	220	`nmax = (ns > nx) ? ns : nx;`
221	`*stretch = (ns > nx) ? ns : 0;`	221	`*stretch = (ns > nx) ? ns : 0;`
222	`#endif`	222	`#endif`
223	`if (ns == 0)`	223	`if (ns == 0)`
224	`return(allocVector(INTSXP, 0));`	224	`return(allocVector(INTSXP, 0));`
Line 296...	Line 296...
296	`if (ii > max)`	296	`if (ii > max)`
297	`max = ii;`	297	`max = ii;`
298	`}`	298	`}`
299	`}`	299	`}`
300	`if (min < -nx)`	300	`if (min < -nx)`
301	`error("subscript out of bounds\n");`	301	`error("subscript out of bounds");`
302	`if (max > nx) {`	302	`if (max > nx) {`
303	`if(canstretch) *stretch = max;`	303	`if(canstretch) *stretch = max;`
304	`else error("subscript out of bounds\n");`	304	`else error("subscript out of bounds");`
305	`}`	305	`}`
306	`if (min < 0) {`	306	`if (min < 0) {`
307	`if (max == 0) return negativeSubscript(s, ns, nx);`	307	`if (max == 0) return negativeSubscript(s, ns, nx);`
308	`else error("only 0's may mix with negative subscripts\n");`	308	`else error("only 0's may mix with negative subscripts");`
309	`}`	309	`}`
310	`else return positiveSubscript(s, ns, nx);`	310	`else return positiveSubscript(s, ns, nx);`
311	`return R_NilValue;`	311	`return R_NilValue;`
312	`}`	312	`}`
313		313
Line 386...	Line 386...
386	`UNPROTECT(1);`	386	`UNPROTECT(1);`
387	`return tmp;`	387	`return tmp;`
388	`case STRSXP:`	388	`case STRSXP:`
389	`dnames = getAttrib(x, R_DimNamesSymbol);`	389	`dnames = getAttrib(x, R_DimNamesSymbol);`
390	`if (dnames == R_NilValue)`	390	`if (dnames == R_NilValue)`
391	`error("no dimnames attribute for array\n");`	391	`error("no dimnames attribute for array");`
392	`dnames = VECTOR(dnames)[dim];`	392	`dnames = VECTOR(dnames)[dim];`
393	`return stringSubscript(s, ns, nd, dnames, &stretch);`	393	`return stringSubscript(s, ns, nd, dnames, &stretch);`
394	`case SYMSXP:`	394	`case SYMSXP:`
395	`if (s == R_MissingArg)`	395	`if (s == R_MissingArg)`
396	`return nullSubscript(nd);`	396	`return nullSubscript(nd);`
397	`default:`	397	`default:`
398	`error("invalid subscript\n");`	398	`error("invalid subscript");`
399	`}`	399	`}`
400	`return R_NilValue;`	400	`return R_NilValue;`
401	`}`	401	`}`
402		402
403	`/* Subscript creation. The first thing we do is check to see */`	403	`/* Subscript creation. The first thing we do is check to see */`
Line 442...	Line 442...
442	`if (s == R_MissingArg) {`	442	`if (s == R_MissingArg) {`
443	`ans = nullSubscript(nx);`	443	`ans = nullSubscript(nx);`
444	`break;`	444	`break;`
445	`}`	445	`}`
446	`default:`	446	`default:`
447	`error("invalid subscript type\n");`	447	`error("invalid subscript type");`
448	`}`	448	`}`
449	`UNPROTECT(1);`	449	`UNPROTECT(1);`
450	`}`	450	`}`
451	`else error("subscripting on non-vector\n");`	451	`else error("subscripting on non-vector");`
452	`return ans;`	452	`return ans;`
453	`}`	453	`}`

The R Project SVN R

(root)/branches/R-exp-API/src/main/subscript.c @ 77458 – Rev 5603 → 5731