The R Project SVN R

Rev

Rev 74684 | Rev 78184 | Go to most recent revision | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
2 r 1 
/*
1016 maechler 2 
 *  R : A Computer Language for Statistical Data Analysis
74145 maechler 3 
 *  Copyright (C) 1997--2018  The R Core Team
2 r 4 
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
5 
 *
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
8 
 *  the Free Software Foundation; either version 2 of the License, or
9 
 *  (at your option) any later version.
10 
 *
11 
 *  This program is distributed in the hope that it will be useful,
12 
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
13 
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14 
 *  GNU General Public License for more details.
15 
 *
16 
 *  You should have received a copy of the GNU General Public License
42307 ripley 17 
 *  along with this program; if not, a copy is available at
68947 ripley 18 
 *  https://www.R-project.org/Licenses/
47040 maechler 19 
 *
20 
 * EXPORTS:
21 
 *
22 
 *  OneIndex()        -- used for "[[<-" in ./subassign.c
23 
 *  get1index()       -- used for "[["   in ./subassign.c & subset.c
63166 luke 24 
 *  vectorIndex()     -- used for "[[" and "[[<-" with a vector arg
47040 maechler 25 
 
26 
 *  mat2indsub()      -- for "mat[i]"     "    "            "
27 
 
49592 murdoch 28 
 *  makeSubscript()   -- for "[" and "[<-" in ./subset.c and ./subassign.c,
29 
 *			 and "[[<-" with a scalar in ./subassign.c
47040 maechler 30 
 *  arraySubscript()  -- for "[i,j,..." and "[<-..." in ./subset.c, ./subassign.c
2 r 31 
 */
32 
 
5187 hornik 33 
#ifdef HAVE_CONFIG_H
7701 hornik 34 
#include <config.h>
5187 hornik 35 
#endif
36 
 
41686 ripley 37 
#include <Defn.h>
2 r 38 
 
67645 urbaneks 39 
#include <R_ext/Itermacros.h>
40 
 
41 
/* interval at which to check interrupts, a guess (~subsecond on current hw) */
42 
#define NINTERRUPT 10000000
43 
 
41686 ripley 44 
/* We might get a call with R_NilValue from subassignment code */
69576 maechler 45 
#define ECALL(call, yy)     if(call == R_NilValue) error(yy);    else errorcall(call, yy);
46 
#define ECALL3(call, yy, A) if(call == R_NilValue) error(yy, A); else errorcall(call, yy, A);
41686 ripley 47 
 
59113 ripley 48 
/* This allows for the unusual case where x is of length 2,
49 
   and x[[-m]] selects one element for m = 1, 2.
50 
   So 'len' is only used if it is 2 and i is negative.
51 
*/
52 
static R_INLINE int integerOneIndex(int i, R_xlen_t len, SEXP call)
41680 ripley 53 
{
10921 maechler 54 
    int indx = -1;
4562 pd 55 
 
59113 ripley 56 
    if (i > 0) /* a regular 1-based index from R */
10921 maechler 57 
	indx = i - 1;
41686 ripley 58 
    else if (i == 0 || len < 2) {
69576 maechler 59 
	ECALL3(call, _("attempt to select less than one element in %s"), "integerOneIndex");
41686 ripley 60 
    } else if (len == 2 && i > -3)
10921 maechler 61 
	indx = 2 + i;
41686 ripley 62 
    else {
69576 maechler 63 
	ECALL3(call, _("attempt to select more than one element in %s"), "integerOneIndex");
41686 ripley 64 
    }
59113 ripley 65 
    return indx;
4562 pd 66 
}
67 
 
47040 maechler 68 
/* Utility used (only in) do_subassign2_dflt(), i.e. "[[<-" in ./subassign.c : */
59057 ripley 69 
R_xlen_t attribute_hidden
74145 maechler 70 
OneIndex(SEXP x, SEXP s, R_xlen_t nx, int partial, SEXP *newname,
59095 ripley 71 
	 int pos, SEXP call)
1839 ihaka 72 
{
73 
    SEXP names;
74145 maechler 74 
    R_xlen_t i, indx;
63181 ripley 75 
    const void *vmax;
2 r 76 
 
41686 ripley 77 
    if (pos < 0 && length(s) > 1) {
69576 maechler 78 
	ECALL3(call, _("attempt to select more than one element in %s"), "OneIndex");
41686 ripley 79 
    }
80 
    if (pos < 0 && length(s) < 1) {
69576 maechler 81 
	ECALL3(call, _("attempt to select less than one element in %s"), "OneIndex");
41686 ripley 82 
    }
45446 ripley 83 
 
22883 ripley 84 
    if(pos < 0) pos = 0;
1839 ihaka 85 
 
10921 maechler 86 
    indx = -1;
1839 ihaka 87 
    *newname = R_NilValue;
88 
    switch(TYPEOF(s)) {
89 
    case LGLSXP:
90 
    case INTSXP:
74145 maechler 91 
	indx = integerOneIndex(INTEGER_ELT(s, pos), nx, call);
1839 ihaka 92 
	break;
93 
    case REALSXP:
74145 maechler 94 
	indx = integerOneIndex((int)REAL_ELT(s, pos), nx, call);
1839 ihaka 95 
	break;
96 
    case STRSXP:
63181 ripley 97 
	vmax = vmaxget();
74145 maechler 98 
	names = getAttrib(x, R_NamesSymbol);
1839 ihaka 99 
	if (names != R_NilValue) {
74145 maechler 100 
	    PROTECT(names);
1839 ihaka 101 
	    /* Try for exact match */
43389 ripley 102 
	    for (i = 0; i < nx; i++) {
103 
		const char *tmp = translateChar(STRING_ELT(names, i));
104 
		if (!tmp[0]) continue;
105 
		if (streql(tmp, translateChar(STRING_ELT(s, pos)))) {
10921 maechler 106 
		    indx = i;
1839 ihaka 107 
		    break;
108 
		}
43389 ripley 109 
	    }
73114 maechler 110 
	    // Try for partial match -- not ever used in current R (partial is 0)
10921 maechler 111 
	    if (partial && indx < 0) {
59096 ripley 112 
		size_t l = strlen(translateChar(STRING_ELT(s, pos)));
1839 ihaka 113 
		for(i = 0; i < nx; i++) {
43389 ripley 114 
		    const char *tmp = translateChar(STRING_ELT(names, i));
115 
		    if (!tmp[0]) continue;
59096 ripley 116 
		    if(!strncmp(tmp, translateChar(STRING_ELT(s, pos)), l)) {
10921 maechler 117 
			if(indx == -1 )
118 
			    indx = i;
1839 ihaka 119 
			else
10921 maechler 120 
			    indx = -2;
1839 ihaka 121 
		    }
122 
		}
123 
	    }
74145 maechler 124 
	    UNPROTECT(1); /* names */
1839 ihaka 125 
	}
10921 maechler 126 
	if (indx == -1)
127 
	    indx = nx;
22883 ripley 128 
	*newname = STRING_ELT(s, pos);
63181 ripley 129 
	vmaxset(vmax);
1839 ihaka 130 
	break;
131 
    case SYMSXP:
63181 ripley 132 
	vmax = vmaxget();
1839 ihaka 133 
	names = getAttrib(x, R_NamesSymbol);
134 
	if (names != R_NilValue) {
68392 luke 135 
	    PROTECT(names);
1839 ihaka 136 
	    for (i = 0; i < nx; i++)
40705 ripley 137 
		if (streql(translateChar(STRING_ELT(names, i)),
138 
			   translateChar(PRINTNAME(s)))) {
10921 maechler 139 
		    indx = i;
1839 ihaka 140 
		    break;
141 
		}
68392 luke 142 
	    UNPROTECT(1); /* names */
1839 ihaka 143 
	}
10921 maechler 144 
	if (indx == -1)
145 
	    indx = nx;
73521 luke 146 
	*newname = PRINTNAME(s);
63181 ripley 147 
	vmaxset(vmax);
1839 ihaka 148 
	break;
149 
    default:
69576 maechler 150 
	ECALL3(call, _("invalid subscript type '%s'"), type2char(TYPEOF(s)));
1839 ihaka 151 
    }
10921 maechler 152 
    return indx;
1839 ihaka 153 
}
154 
 
59113 ripley 155 
/* used here and in subset.c and subassign.c */
59057 ripley 156 
R_xlen_t attribute_hidden
59095 ripley 157 
get1index(SEXP s, SEXP names, R_xlen_t len, int pok, int pos, SEXP call)
10718 maechler 158 
{
59113 ripley 159 
/* Get a single index for the [[ and [[<- operators.
160 
   Checks that only one index is being selected.
161 
   Returns -1 for no match.
162 
 
163 
   s is the subscript
164 
   len is the length of the object or dimension, with names its (dim)names.
165 
   pos is len-1 or -1 for [[, -1 for [[<-
166 
     -1 means use the only element of length-1 s.
10718 maechler 167 
   pok : is "partial ok" ?
59113 ripley 168 
	 if pok is -1, warn if partial matching occurs, but allow.
10718 maechler 169 
*/
59057 ripley 170 
    int  warn_pok = 0;
41784 ripley 171 
    const char *ss, *cur_name;
59057 ripley 172 
    R_xlen_t indx;
63181 ripley 173 
    const void *vmax;
2 r 174 
 
41670 rgentlem 175 
    if (pok == -1) {
45446 ripley 176 
	pok = 1;
177 
	warn_pok = 1;
41670 rgentlem 178 
    }
179 
 
22883 ripley 180 
    if (pos < 0 && length(s) != 1) {
41686 ripley 181 
	if (length(s) > 1) {
69576 maechler 182 
	    ECALL3(call, _("attempt to select more than one element in %s"), "get1index");
41686 ripley 183 
	} else {
69576 maechler 184 
	    ECALL3(call, _("attempt to select less than one element in %s"), "get1index");
41686 ripley 185 
	}
29363 ripley 186 
    } else
41686 ripley 187 
	if(pos >= length(s)) {
188 
	    ECALL(call, _("internal error in use of recursive indexing"));
189 
	}
22883 ripley 190 
    if(pos < 0) pos = 0;
10921 maechler 191 
    indx = -1;
1839 ihaka 192 
    switch (TYPEOF(s)) {
193 
    case LGLSXP:
194 
    case INTSXP:
59057 ripley 195 
    {
73567 luke 196 
	int i = INTEGER_ELT(s, pos);
59113 ripley 197 
	if (i != NA_INTEGER)
198 
	    indx = integerOneIndex(i, len, call);
1839 ihaka 199 
	break;
59057 ripley 200 
    }
1839 ihaka 201 
    case REALSXP:
59057 ripley 202 
    {
73567 luke 203 
	double dblind = REAL_ELT(s, pos);
59057 ripley 204 
	if(!ISNAN(dblind)) {
59113 ripley 205 
	    /* see comment above integerOneIndex */
206 
	    if (dblind > 0) indx = (R_xlen_t)(dblind - 1);
59057 ripley 207 
	    else if (dblind == 0 || len < 2) {
69576 maechler 208 
		ECALL3(call, _("attempt to select less than one element in %s"), "get1index <real>");
59057 ripley 209 
	    } else if (len == 2 && dblind > -3)
59113 ripley 210 
		indx = (R_xlen_t)(2 + dblind);
59057 ripley 211 
	    else {
69576 maechler 212 
		ECALL3(call, _("attempt to select more than one element in %s"), "get1index <real>");
59057 ripley 213 
	    }
214 
	}
1839 ihaka 215 
	break;
59057 ripley 216 
    }
1839 ihaka 217 
    case STRSXP:
40705 ripley 218 
	/* NA matches nothing */
219 
	if(STRING_ELT(s, pos) == NA_STRING) break;
43389 ripley 220 
	/* "" matches nothing: see names.Rd */
221 
	if(!CHAR(STRING_ELT(s, pos))[0]) break;
45446 ripley 222 
 
1839 ihaka 223 
	/* Try for exact match */
63181 ripley 224 
	vmax = vmaxget();
40705 ripley 225 
	ss = translateChar(STRING_ELT(s, pos));
59057 ripley 226 
	for (R_xlen_t i = 0; i < xlength(names); i++)
40705 ripley 227 
	    if (STRING_ELT(names, i) != NA_STRING) {
228 
		if (streql(translateChar(STRING_ELT(names, i)), ss)) {
35796 ripley 229 
		    indx = i;
230 
		    break;
231 
		}
1839 ihaka 232 
	    }
233 
	/* Try for partial match */
10921 maechler 234 
	if (pok && indx < 0) {
59095 ripley 235 
	    size_t len = strlen(ss);
59057 ripley 236 
	    for(R_xlen_t i = 0; i < xlength(names); i++) {
40705 ripley 237 
		if (STRING_ELT(names, i) != NA_STRING) {
45446 ripley 238 
		    cur_name = translateChar(STRING_ELT(names, i));
41670 rgentlem 239 
		    if(!strncmp(cur_name, ss, len)) {
240 
			if(indx == -1) {/* first one */
35796 ripley 241 
			    indx = i;
45446 ripley 242 
			    if (warn_pok) {
41686 ripley 243 
				if (call == R_NilValue)
244 
				    warning(_("partial match of '%s' to '%s'"),
41674 ripley 245 
					    ss, cur_name);
41686 ripley 246 
				else
45446 ripley 247 
				    warningcall(call,
41686 ripley 248 
						_("partial match of '%s' to '%s'"),
249 
						ss, cur_name);
250 
			    }
45446 ripley 251 
			}
41670 rgentlem 252 
			else {
35796 ripley 253 
			    indx = -2;/* more than one partial match */
45446 ripley 254 
			    if (warn_pok) /* already given context */
255 
				warningcall(R_NilValue,
41680 ripley 256 
					    _("further partial match of '%s' to '%s'"),
41674 ripley 257 
					    ss, cur_name);
45446 ripley 258 
			    break;
259 
			}
35796 ripley 260 
		    }
544 pd 261 
		}
1839 ihaka 262 
	    }
2 r 263 
	}
63181 ripley 264 
	vmaxset(vmax);
1839 ihaka 265 
	break;
266 
    case SYMSXP:
63181 ripley 267 
	vmax = vmaxget();
59057 ripley 268 
	for (R_xlen_t i = 0; i < xlength(names); i++)
35796 ripley 269 
	    if (STRING_ELT(names, i) != NA_STRING &&
45446 ripley 270 
		streql(translateChar(STRING_ELT(names, i)),
40705 ripley 271 
		       CHAR(PRINTNAME(s)))) {
10921 maechler 272 
		indx = i;
63181 ripley 273 
		vmaxset(vmax);
1839 ihaka 274 
		break;
275 
	    }
72958 maechler 276 
	break;
1839 ihaka 277 
    default:
69576 maechler 278 
	ECALL3(call, _("invalid subscript type '%s'"), type2char(TYPEOF(s)));
1839 ihaka 279 
    }
10921 maechler 280 
    return indx;
2 r 281 
}
282 
 
59113 ripley 283 
/* This is used for [[ and [[<- with a vector of indices of length > 1 .
68754 maechler 284 
   x is a list or pairlist, and it is indexed recusively from
59113 ripley 285 
   level start to level stop-1.  ( 0...len-1 or 0..len-2 then len-1).
65021 luke 286 
   For [[<- it needs to duplicate if substructure might be shared.
59113 ripley 287 
 */
49597 ripley 288 
SEXP attribute_hidden
63166 luke 289 
vectorIndex(SEXP x, SEXP thesub, int start, int stop, int pok, SEXP call,
68754 maechler 290 
	    Rboolean dup)
49592 murdoch 291 
{
59095 ripley 292 
    int i;
293 
    R_xlen_t offset;
63166 luke 294 
    SEXP cx;
49592 murdoch 295 
 
63166 luke 296 
    /* sanity check */
65021 luke 297 
    if (dup && MAYBE_SHARED(x))
63166 luke 298 
	error("should only be called in an assignment context.");
299 
 
49592 murdoch 300 
    for(i = start; i < stop; i++) {
52828 ripley 301 
	if(!isVectorList(x) && !isPairList(x)) {
302 
	    if (i)
303 
		errorcall(call, _("recursive indexing failed at level %d\n"), i+1);
304 
	    else
69576 maechler 305 
		errorcall(call, _("attempt to select more than one element in %s"), "vectorIndex");
52828 ripley 306 
	}
68250 luke 307 
	PROTECT(x);
68094 luke 308 
	SEXP names = PROTECT(getAttrib(x, R_NamesSymbol));
309 
	offset = get1index(thesub, names,
68923 ripley 310 
			   xlength(x), pok, i, call);
68250 luke 311 
	UNPROTECT(2); /* x, names */
59095 ripley 312 
	if(offset < 0 || offset >= xlength(x))
49592 murdoch 313 
	    errorcall(call, _("no such index at level %d\n"), i+1);
314 
	if(isPairList(x)) {
59123 ripley 315 
#ifdef LONG_VECTOR_SUPPORT
59118 ripley 316 
	    if (offset > R_SHORT_LEN_MAX)
59095 ripley 317 
		error("invalid subscript for pairlist");
59123 ripley 318 
#endif
63166 luke 319 
	    cx = nthcdr(x, (int) offset);
74021 luke 320 
	    RAISE_NAMED(CAR(x), NAMED(x));
63166 luke 321 
	    x = CAR(cx);
65021 luke 322 
	    if (dup && MAYBE_SHARED(x)) {
72506 kalibera 323 
		PROTECT(cx);
64970 luke 324 
		x = shallow_duplicate(x);
63185 luke 325 
		SETCAR(cx, x);
72506 kalibera 326 
		UNPROTECT(1); /* cx */
63166 luke 327 
	    }
49592 murdoch 328 
	} else {
63166 luke 329 
	    cx = x;
49592 murdoch 330 
	    x = VECTOR_ELT(x, offset);
74021 luke 331 
	    RAISE_NAMED(x, NAMED(cx));
65021 luke 332 
	    if (dup && MAYBE_SHARED(x)) {
72506 kalibera 333 
		PROTECT(cx);
64970 luke 334 
		x = shallow_duplicate(x);
63166 luke 335 
		SET_VECTOR_ELT(cx, offset, x);
72506 kalibera 336 
		UNPROTECT(1); /* cx */
63166 luke 337 
	    }
68923 ripley 338 
	}
49592 murdoch 339 
    }
340 
    return x;
341 
}
342 
 
60312 ripley 343 
/* Special Matrix Subscripting: Handles the case x[i] where
344 
   x is an n-way array and i is a matrix with n columns.
345 
   This code returns a vector containing the subscripts
346 
   to be extracted when x is regarded as unravelled.
2 r 347 
 
60312 ripley 348 
   Negative indices are not allowed.
59057 ripley 349 
 
60312 ripley 350 
   A zero/NA anywhere in a row will cause a zero/NA in the same
351 
   position in the result.
352 
*/
353 
 
354 
 
41680 ripley 355 
SEXP attribute_hidden mat2indsub(SEXP dims, SEXP s, SEXP call)
2 r 356 
{
60312 ripley 357 
    int nrs = nrows(s);
59057 ripley 358 
    R_xlen_t NR = nrs;
1839 ihaka 359 
    SEXP rvec;
73567 luke 360 
    int ndim = LENGTH(dims);
73729 luke 361 
    const int *pdims = INTEGER_RO(dims);
2 r 362 
 
73567 luke 363 
    if (ncols(s) != ndim) {
41686 ripley 364 
	ECALL(call, _("incorrect number of columns in matrix subscript"));
365 
    }
45446 ripley 366 
 
59095 ripley 367 
#ifdef LONG_VECTOR_SUPPORT
60312 ripley 368 
    /* Check if it is a long vector we need to index */
60314 ripley 369 
    R_xlen_t len = 1;
73567 luke 370 
    for (int j = 0; j < ndim; j++)  len *= pdims[j];
2 r 371 
 
60312 ripley 372 
    if(len > R_SHORT_LEN_MAX) {
59095 ripley 373 
	PROTECT(rvec = allocVector(REALSXP, nrs));
60312 ripley 374 
	double *rv = REAL(rvec);
375 
	for (int i = 0; i < nrs; i++) rv[i] = 1.; // 1-based.
376 
	if (TYPEOF(s) == REALSXP) {
377 
	    for (int i = 0; i < nrs; i++) {
378 
		R_xlen_t tdim = 1;
73729 luke 379 
		const double *ps = REAL_RO(s);
73567 luke 380 
		for (int j = 0; j < ndim; j++) {
381 
		    double k = ps[i + j * NR];
60312 ripley 382 
		    if(ISNAN(k)) {rv[i] = NA_REAL; break;}
383 
		    if(k < 0) {
384 
			ECALL(call, _("negative values are not allowed in a matrix subscript"));
385 
		    }
386 
		    if(k == 0.) {rv[i] = 0.; break;}
73567 luke 387 
		    if (k > pdims[j]) {
60312 ripley 388 
			ECALL(call, _("subscript out of bounds"));
389 
		    }
390 
		    rv[i] += (k - 1.) * tdim;
73567 luke 391 
		    tdim *= pdims[j];
59095 ripley 392 
		}
60312 ripley 393 
	    }
394 
	} else {
395 
	    s = coerceVector(s, INTSXP);
73729 luke 396 
	    const int *ps = INTEGER_RO(s);
60312 ripley 397 
	    for (int i = 0; i < nrs; i++) {
398 
		R_xlen_t tdim = 1;
73567 luke 399 
		for (int j = 0; j < ndim; j++) {
400 
		    int k = ps[i + j * NR];
60312 ripley 401 
		    if(k == NA_INTEGER) {rv[i] = NA_REAL; break;}
402 
		    if(k < 0) {
403 
			ECALL(call, _("negative values are not allowed in a matrix subscript"));
404 
		    }
405 
		    if(k == 0) {rv[i] = 0.; break;}
73567 luke 406 
		    if (k > pdims[j]) {
60312 ripley 407 
			ECALL(call, _("subscript out of bounds"));
408 
		    }
409 
		    rv[i] += (double) ((k - 1) * tdim);
73567 luke 410 
		    tdim *= pdims[j];
59095 ripley 411 
		}
1839 ihaka 412 
	    }
59095 ripley 413 
	}
414 
    } else
415 
#endif
416 
    {
417 
	PROTECT(rvec = allocVector(INTSXP, nrs));
60312 ripley 418 
	int *iv = INTEGER(rvec);
419 
	for (int i = 0; i < nrs; i++) iv[i] = 1; // 1-based.
59095 ripley 420 
	s = coerceVector(s, INTSXP);
73567 luke 421 
	int *ps = INTEGER(s);
60312 ripley 422 
	for (int i = 0; i < nrs; i++) {
59095 ripley 423 
	    int tdim = 1;
73567 luke 424 
	    for (int j = 0; j < ndim; j++) {
425 
		int k = ps[i + j * NR];
60312 ripley 426 
		if(k == NA_INTEGER) {iv[i] = NA_INTEGER; break;}
59095 ripley 427 
		if(k < 0) {
428 
		    ECALL(call, _("negative values are not allowed in a matrix subscript"));
429 
		}
60312 ripley 430 
		if(k == 0) {iv[i] = 0; break;}
73567 luke 431 
		if (k > pdims[j]) {
59095 ripley 432 
		    ECALL(call, _("subscript out of bounds"));
433 
		}
60312 ripley 434 
		iv[i] += (k - 1) * tdim;
73567 luke 435 
		tdim *= pdims[j];
41686 ripley 436 
	    }
2 r 437 
	}
1839 ihaka 438 
    }
59095 ripley 439 
 
1839 ihaka 440 
    UNPROTECT(1);
60312 ripley 441 
    return rvec;
2 r 442 
}
443 
 
50896 falcon 444 
/*
445 
Special Matrix Subscripting: For the case x[i] where x is an n-way
446 
array and i is a character matrix with n columns, this code converts i
447 
to an integer matrix by matching against the dimnames of x. NA values
448 
in any row of i propagate to the result.  Unmatched entries result in
449 
a subscript out of bounds error.  */
450 
 
451 
SEXP attribute_hidden strmat2intmat(SEXP s, SEXP dnamelist, SEXP call)
452 
{
453 
    /* XXX: assumes all args are protected */
59057 ripley 454 
    int nr = nrows(s), i, j, v;
455 
    R_xlen_t idx, NR = nr;
50896 falcon 456 
    SEXP dnames, snames, si, sicol, s_elt;
457 
    PROTECT(snames = allocVector(STRSXP, nr));
59057 ripley 458 
    PROTECT(si = allocVector(INTSXP, xlength(s)));
50896 falcon 459 
    dimgets(si, getAttrib(s, R_DimSymbol));
73567 luke 460 
    int *psi = INTEGER(si);
50896 falcon 461 
    for (i = 0; i < length(dnamelist); i++) {
68923 ripley 462 
	dnames = VECTOR_ELT(dnamelist, i);
463 
	for (j = 0; j < nr; j++)
464 
	    SET_STRING_ELT(snames, j, STRING_ELT(s, j + (i * NR)));
465 
	PROTECT(sicol = match(dnames, snames, 0));
466 
	for (j = 0; j < nr; j++) {
73567 luke 467 
	    v = INTEGER_ELT(sicol, j);
68923 ripley 468 
	    idx = j + (i * NR);
469 
	    s_elt = STRING_ELT(s, idx);
470 
	    if (s_elt == NA_STRING) v = NA_INTEGER;
471 
	    if (!CHAR(s_elt)[0]) v = 0; /* disallow "" match */
472 
	    if (v == 0) errorcall(call, _("subscript out of bounds"));
73567 luke 473 
	    psi[idx] = v;
68923 ripley 474 
	}
475 
	UNPROTECT(1);
50896 falcon 476 
    }
477 
    UNPROTECT(2);
478 
    return si;
479 
}
480 
 
59097 ripley 481 
static SEXP nullSubscript(R_xlen_t n)
2 r 482 
{
10921 maechler 483 
    SEXP indx;
59097 ripley 484 
#ifdef LONG_VECTOR_SUPPORT
59118 ripley 485 
    if (n > R_SHORT_LEN_MAX) {
68923 ripley 486 
	indx = allocVector(REALSXP, n);
73567 luke 487 
	double *pindx = REAL(indx);
59097 ripley 488 
	for (R_xlen_t i = 0; i < n; i++)
73567 luke 489 
	    pindx[i] = (double)(i + 1);
68754 maechler 490 
    } else
59097 ripley 491 
#endif
492 
    {
493 
	indx = allocVector(INTSXP, n);
73567 luke 494 
	int *pindx = INTEGER(indx);
59097 ripley 495 
	for (int i = 0; i < n; i++)
73567 luke 496 
	    pindx[i] = i + 1;
59097 ripley 497 
    }
10921 maechler 498 
    return indx;
2 r 499 
}
500 
 
59088 ripley 501 
 
68754 maechler 502 
static SEXP
59095 ripley 503 
logicalSubscript(SEXP s, R_xlen_t ns, R_xlen_t nx, R_xlen_t *stretch, SEXP call)
2 r 504 
{
67645 urbaneks 505 
    R_xlen_t count, i, nmax, i1, i2;
59046 ripley 506 
    int canstretch;
10921 maechler 507 
    SEXP indx;
59097 ripley 508 
    canstretch = *stretch > 0;
41686 ripley 509 
    if (!canstretch && ns > nx) {
510 
	ECALL(call, _("(subscript) logical subscript too long"));
511 
    }
4288 ihaka 512 
    nmax = (ns > nx) ? ns : nx;
513 
    *stretch = (ns > nx) ? ns : 0;
59065 ripley 514 
    if (ns == 0) return(allocVector(INTSXP, 0));
73729 luke 515 
    const int *ps = LOGICAL_RO(s);    /* Calling LOCICAL_RO here may force a
516 
					 large allocation, but no larger than
517 
					 the one made by R_alloc below. This
518 
					 could use rewriting to better handle
519 
					 a sparse logical index. */
59065 ripley 520 
#ifdef LONG_VECTOR_SUPPORT
59118 ripley 521 
    if (nmax > R_SHORT_LEN_MAX) {
68923 ripley 522 
	if (ns == nmax) { /* no recycling - use fast single-index code */
68754 maechler 523 
	    const void *vmax = vmaxget();
524 
	    double *buf = (double *) R_alloc(nmax, sizeof(double));
525 
	    count = 0;
73567 luke 526 
	    R_ITERATE_CHECK(NINTERRUPT, nmax, i,
527 
		if (ps[i]) {
528 
		    if (ps[i] == NA_LOGICAL)
529 
			buf[count++] = NA_REAL;
530 
		    else
531 
			buf[count++] = (double)(i + 1);
68754 maechler 532 
		});
68923 ripley 533 
	    PROTECT(indx = allocVector(REALSXP, count));
534 
	    memcpy(REAL(indx), buf, sizeof(double) * count);
535 
	    vmaxset(vmax);
536 
	    UNPROTECT(1);
537 
	    return indx;
538 
	}
59065 ripley 539 
	count = 0;
67645 urbaneks 540 
	/* we only need to scan s once even if we recycle,
541 
	   just remember the total count as well as
542 
	   the count for the last incomplete chunk (if any) */
543 
	i1 = (ns < nmax) ? (nmax % ns) : 0;
68754 maechler 544 
	if (i1 > 0) { /* last recycling chunk is incomplete -
67645 urbaneks 545 
			 we have to get the truncated count as well */
546 
	    R_xlen_t rem = 0;
547 
	    for (i = 0; i < ns; i++) {
548 
		if (i == i1) rem = count;
73567 luke 549 
		if (ps[i]) count++;
67645 urbaneks 550 
	    }
551 
	    count = count * (nmax / ns) + rem;
552 
	} else { /* nested recycling, total is sufficient */
553 
	    for (i = 0; i < ns; i++)
73567 luke 554 
		if (ps[i]) count++;
67645 urbaneks 555 
	    count *= nmax / ns;
556 
	}
68187 luke 557 
	PROTECT(indx = allocVector(REALSXP, count));
73567 luke 558 
	double *pindx = REAL(indx);
59065 ripley 559 
	count = 0;
73567 luke 560 
	MOD_ITERATE_CHECK(NINTERRUPT, nmax, ns, nmax, i, i1, i2,
561 
	    if (ps[i1]) {
562 
		if (ps[i1] == NA_LOGICAL)
563 
		    pindx[count++] = NA_REAL;
564 
		else
565 
		    pindx[count++] = (double)(i + 1);
68923 ripley 566 
	    });
67645 urbaneks 567 
 
68187 luke 568 
	UNPROTECT(1);
59065 ripley 569 
	return indx;
570 
    }
571 
#endif
68754 maechler 572 
// else --- the same code for  non-long vectors --------------------------
573 
    if (ns == nmax) {  /* no recycling - use fast single-index code */
574 
	const void *vmax = vmaxget();
575 
	int *buf = (int *) R_alloc(nmax, sizeof(int));
576 
	count = 0;
73567 luke 577 
	R_ITERATE_CHECK(NINTERRUPT, nmax, i,
578 
	    if (ps[i]) {
579 
		if (ps[i] == NA_LOGICAL)
580 
		    buf[count++] = NA_INTEGER;
581 
		else
582 
		    buf[count++] = (int)(i + 1);
68754 maechler 583 
	    });
584 
	PROTECT(indx = allocVector(INTSXP, count));
585 
	memcpy(INTEGER(indx), buf, sizeof(int) * count);
586 
	vmaxset(vmax);
587 
	UNPROTECT(1);
588 
	return indx;
589 
    }
590 
 
1839 ihaka 591 
    count = 0;
67645 urbaneks 592 
    /* we only need to scan s once even if we recycle,
593 
       just remember the total count as well as
594 
       the count for the last incomplete chunk (if any) */
595 
    i1 = (ns < nmax) ? (nmax % ns) : 0;
68754 maechler 596 
    if (i1 > 0) { /* last recycling chunk is incomplete -
67645 urbaneks 597 
		     we have to get the truncated count as well */
598 
	R_xlen_t rem = 0;
599 
	for (i = 0; i < ns; i++) {
600 
	    if (i == i1) rem = count;
73567 luke 601 
	    if (ps[i]) count++;
67645 urbaneks 602 
	}
603 
	count = count * (nmax / ns) + rem;
68754 maechler 604 
    } else { /* nested recycling, total is sufficient */
67645 urbaneks 605 
	for (i = 0; i < ns; i++)
73567 luke 606 
	    if (ps[i]) count++;
67645 urbaneks 607 
	count *= nmax / ns;
608 
    }
68187 luke 609 
    PROTECT(indx = allocVector(INTSXP, count));
73567 luke 610 
    int *pindx = INTEGER(indx);
1839 ihaka 611 
    count = 0;
73567 luke 612 
    MOD_ITERATE_CHECK(NINTERRUPT, nmax, ns, nmax, i, i1, i2,
613 
	if (ps[i1]) {
614 
	    if (ps[i1] == NA_LOGICAL)
615 
		pindx[count++] = NA_INTEGER;
616 
	    else
617 
		pindx[count++] = (int)(i + 1);
68923 ripley 618 
	});
67645 urbaneks 619 
 
68187 luke 620 
    UNPROTECT(1);
10921 maechler 621 
    return indx;
2 r 622 
}
623 
 
59046 ripley 624 
static SEXP negativeSubscript(SEXP s, R_xlen_t ns, R_xlen_t nx, SEXP call)
2 r 625 
{
27383 rgentlem 626 
    SEXP indx;
59095 ripley 627 
    R_xlen_t stretch = 0;
59046 ripley 628 
    R_xlen_t i;
38545 ripley 629 
    PROTECT(indx = allocVector(LGLSXP, nx));
73567 luke 630 
    int *pindx = LOGICAL(indx);
1839 ihaka 631 
    for (i = 0; i < nx; i++)
73567 luke 632 
	pindx[i] = 1;
73729 luke 633 
    const int *ps = INTEGER_RO(s);
28762 pd 634 
    for (i = 0; i < ns; i++) {
73567 luke 635 
	int ix = ps[i];
28762 pd 636 
	if (ix != 0 && ix != NA_INTEGER && -ix <= nx)
73567 luke 637 
	    pindx[-ix - 1] = 0;
28762 pd 638 
    }
41680 ripley 639 
    s = logicalSubscript(indx, nx, nx, &stretch, call);
1839 ihaka 640 
    UNPROTECT(1);
641 
    return s;
2 r 642 
}
643 
 
59046 ripley 644 
static SEXP positiveSubscript(SEXP s, R_xlen_t ns, R_xlen_t nx)
2 r 645 
{
10921 maechler 646 
    SEXP indx;
59046 ripley 647 
    R_xlen_t i, zct = 0;
73729 luke 648 
    const int *ps = INTEGER_RO(s);
73567 luke 649 
    for (i = 0; i < ns; i++) if (ps[i] == 0) zct++;
1839 ihaka 650 
    if (zct) {
27383 rgentlem 651 
	indx = allocVector(INTSXP, (ns - zct));
73567 luke 652 
	int *pindx = INTEGER(indx);
27383 rgentlem 653 
	for (i = 0, zct = 0; i < ns; i++)
73567 luke 654 
	    if (ps[i] != 0)
655 
		pindx[zct++] = ps[i];
27383 rgentlem 656 
	return indx;
59065 ripley 657 
 
59057 ripley 658 
    } else return s;
2 r 659 
}
660 
 
68754 maechler 661 
static SEXP
59095 ripley 662 
integerSubscript(SEXP s, R_xlen_t ns, R_xlen_t nx, R_xlen_t *stretch, SEXP call)
2 r 663 
{
59046 ripley 664 
    R_xlen_t i;
73694 luke 665 
    int ii, neg, max, canstretch;
28766 ripley 666 
    Rboolean isna = FALSE;
59097 ripley 667 
    canstretch = *stretch > 0;
1839 ihaka 668 
    *stretch = 0;
73694 luke 669 
    neg = FALSE;
1839 ihaka 670 
    max = 0;
73729 luke 671 
    const int *ps = INTEGER_RO(s);
1839 ihaka 672 
    for (i = 0; i < ns; i++) {
73567 luke 673 
	ii = ps[i];
73694 luke 674 
	if (ii < 0) {
675 
	    if (ii == NA_INTEGER)
676 
		isna = TRUE;
677 
	    else
678 
		neg = TRUE;
679 
	}
680 
	else if (ii > max)
681 
	    max = ii;
1839 ihaka 682 
    }
683 
    if (max > nx) {
27383 rgentlem 684 
	if(canstretch) *stretch = max;
41686 ripley 685 
	else {
686 
	    ECALL(call, _("subscript out of bounds"));
687 
	}
1839 ihaka 688 
    }
73694 luke 689 
    if (neg) {
41680 ripley 690 
	if (max == 0 && !isna) return negativeSubscript(s, ns, nx, call);
41686 ripley 691 
	else {
692 
	    ECALL(call, _("only 0's may be mixed with negative subscripts"));
693 
	}
1839 ihaka 694 
    }
27383 rgentlem 695 
    else return positiveSubscript(s, ns, nx);
696 
    return R_NilValue;
2 r 697 
}
698 
 
68754 maechler 699 
static SEXP
59095 ripley 700 
realSubscript(SEXP s, R_xlen_t ns, R_xlen_t nx, R_xlen_t *stretch, SEXP call)
59065 ripley 701 
{
702 
    R_xlen_t i;
703 
    int canstretch;
704 
    double ii, min, max;
705 
    Rboolean isna = FALSE;
59097 ripley 706 
    canstretch = *stretch > 0;
59065 ripley 707 
    *stretch = 0;
708 
    min = 0;
709 
    max = 0;
73729 luke 710 
    const double *ps = REAL_RO(s);
59065 ripley 711 
    for (i = 0; i < ns; i++) {
73567 luke 712 
	ii = ps[i];
59065 ripley 713 
	if (R_FINITE(ii)) {
714 
	    if (ii < min) min = ii;
715 
	    if (ii > max) max = ii;
716 
	} else isna = TRUE;
717 
    }
718 
    if (max > nx) {
60200 ripley 719 
#ifndef LONG_VECTOR_SUPPORT
720 
	if (max > INT_MAX) {
59065 ripley 721 
	    ECALL(call, _("subscript too large for 32-bit R"));
722 
	}
723 
#endif
59095 ripley 724 
	if(canstretch) *stretch = (R_xlen_t) max;
59065 ripley 725 
	else {
726 
	    ECALL(call, _("subscript out of bounds"));
727 
	}
728 
    }
729 
    if (min < 0) {
730 
	if (max == 0 && !isna) {
731 
	    SEXP indx;
59095 ripley 732 
	    R_xlen_t stretch = 0;
59065 ripley 733 
	    double dx;
734 
	    R_xlen_t i, ix;
735 
	    PROTECT(indx = allocVector(LGLSXP, nx));
73567 luke 736 
	    int *pindx = LOGICAL(indx);
737 
	    for (i = 0; i < nx; i++) pindx[i] = 1;
59065 ripley 738 
	    for (i = 0; i < ns; i++) {
73567 luke 739 
		dx = ps[i];
59065 ripley 740 
		if (R_FINITE(dx) && dx != 0  && -dx <= nx) {
73114 maechler 741 
		    ix = (R_xlen_t)(-dx - 1);
73567 luke 742 
		    pindx[ix] = 0;
59080 ripley 743 
		}
59065 ripley 744 
	    }
745 
	    s = logicalSubscript(indx, nx, nx, &stretch, call);
746 
	    UNPROTECT(1);
747 
	    return s;
748 
	} else {
749 
	    ECALL(call, _("only 0's may be mixed with negative subscripts"));
750 
	}
751 
    } else {
752 
	/* Only return a REALSXP index if we need to */
753 
	SEXP indx;
754 
	R_xlen_t i, cnt = 0;
755 
	Rboolean int_ok = TRUE;
59080 ripley 756 
	/* NB, indices will be truncated eventually,
757 
	   so need to do that to take '0' into account */
59065 ripley 758 
	for (i = 0; i < ns; i++) {
73567 luke 759 
	    double ds = ps[i];
59574 luke 760 
#ifdef OLDCODE_LONG_VECTOR
59065 ripley 761 
	    if (!R_FINITE(ds)) {
59123 ripley 762 
		if (ds > INT_MAX) int_ok = FALSE;
59065 ripley 763 
		cnt++;
59080 ripley 764 
	    } else if ((R_xlen_t) ds != 0) cnt++;
59574 luke 765 
#else
64252 ripley 766 
	    if (R_FINITE(ds) && ds > INT_MAX) int_ok = FALSE;
767 
	    if (!R_FINITE(ds) || (R_xlen_t) ds != 0) cnt++;
59574 luke 768 
#endif
59065 ripley 769 
	}
770 
	if (int_ok) {
771 
	    indx = allocVector(INTSXP, cnt);
73567 luke 772 
	    int *pindx = INTEGER(indx);
59065 ripley 773 
	    for (i = 0, cnt = 0; i < ns; i++) {
73567 luke 774 
		double ds = ps[i];
59080 ripley 775 
		int ia;
776 
		if (!R_FINITE(ds)) ia = NA_INTEGER;
59097 ripley 777 
		else ia = (int) ds;
73567 luke 778 
		if (ia != 0) pindx[cnt++] = ia;
59065 ripley 779 
	    }
780 
	} else {
781 
	    indx = allocVector(REALSXP, cnt);
73567 luke 782 
	    double *pindx = REAL(indx);
59080 ripley 783 
	    for (i = 0, cnt = 0; i < ns; i++) {
73567 luke 784 
		double ds = ps[i];
785 
		if (!R_FINITE(ds) || (R_xlen_t) ds != 0) pindx[cnt++] = ds;
59080 ripley 786 
	    }
59065 ripley 787 
	}
788 
	return indx;
789 
    }
790 
    return R_NilValue;
791 
}
792 
 
29363 ripley 793 
/* This uses a couple of horrible hacks in conjunction with
794 
 * VectorAssign (in subassign.c).  If subscripting is used for
795 
 * assignment, it is possible to extend a vector by supplying new
796 
 * names, and we want to give the extended vector those names, so they
51067 ripley 797 
 * are returned as the use.names attribute. Also, unset elements of the vector
29363 ripley 798 
 * of new names (places where a match was found) are indicated by
51067 ripley 799 
 * setting the element of the newnames vector to NULL.
29363 ripley 800 
*/
801 
 
802 
/* The original code (pre 2.0.0) used a ns x nx loop that was too
803 
 * slow.  So now we hash.  Hashing is expensive on memory (up to 32nx
804 
 * bytes) so it is only worth doing if ns * nx is large.  If nx is
805 
 * large, then it will be too slow unless ns is very small.
806 
 */
807 
 
41680 ripley 808 
static SEXP
59046 ripley 809 
stringSubscript(SEXP s, R_xlen_t ns, R_xlen_t nx, SEXP names,
59095 ripley 810 
		R_xlen_t *stretch, SEXP call)
2 r 811 
{
74684 ripley 812 
    SEXP indx, indexnames = R_NilValue;
59088 ripley 813 
    R_xlen_t i, j, nnames, extra, sub;
59097 ripley 814 
    int canstretch = *stretch > 0;
39595 murdoch 815 
    /* product may overflow, so check factors as well. */
59066 ripley 816 
    Rboolean usehashing = ( ((ns > 1000 && nx) || (nx > 1000 && ns)) || (ns * nx > 15*nx + ns) );
29363 ripley 817 
 
1839 ihaka 818 
    PROTECT(s);
819 
    PROTECT(names);
820 
    nnames = nx;
821 
    extra = nnames;
2 r 822 
 
29363 ripley 823 
    /* Process each of the subscripts. First we compare with the names
824 
     * on the vector and then (if there is no match) with each of the
825 
     * previous subscripts, since (if assigning) we may have already
826 
     * added an element of that name. (If we are not assigning, any
827 
     * nonmatch will have given an error.)
828 
     */
2 r 829 
 
29363 ripley 830 
    if(usehashing) {
831 
	/* must be internal, so names contains a character vector */
35796 ripley 832 
	/* NB: this does not behave in the same way with respect to ""
833 
	   and NA names: they will match */
73729 luke 834 
	PROTECT(indx = match(names, s, 0)); /**** guaranteed to be fresh???*/
35796 ripley 835 
	/* second pass to correct this */
73567 luke 836 
	int *pindx = INTEGER(indx);
35796 ripley 837 
	for (i = 0; i < ns; i++)
838 
	    if(STRING_ELT(s, i) == NA_STRING || !CHAR(STRING_ELT(s, i))[0])
74660 lawrence 839 
		pindx[i] = 0;
29363 ripley 840 
    } else {
841 
	PROTECT(indx = allocVector(INTSXP, ns));
73567 luke 842 
	int *pindx = INTEGER(indx);
29363 ripley 843 
	for (i = 0; i < ns; i++) {
844 
	    sub = 0;
845 
	    if (names != R_NilValue) {
846 
		for (j = 0; j < nnames; j++) {
59066 ripley 847 
		    SEXP names_j = STRING_ELT(names, j);
29363 ripley 848 
		    if (NonNullStringMatch(STRING_ELT(s, i), names_j)) {
849 
			sub = j + 1;
850 
			break;
851 
		    }
1839 ihaka 852 
		}
27383 rgentlem 853 
	    }
73567 luke 854 
	    pindx[i] = (int) sub;
2 r 855 
	}
29363 ripley 856 
    }
857 
 
73567 luke 858 
    int *pindx = INTEGER(indx);
74660 lawrence 859 
    SEXP sindx = NULL;
29363 ripley 860 
    for (i = 0; i < ns; i++) {
73567 luke 861 
	sub = pindx[i];
1839 ihaka 862 
	if (sub == 0) {
74660 lawrence 863 
	    if (sindx == NULL) {
864 
		sindx = PROTECT(match(s, s, 0));
865 
		indexnames = PROTECT(allocVector(VECSXP, ns));
866 
		for (int z = 0; z < ns; z++)
867 
		    SET_VECTOR_ELT(indexnames, z, R_NilValue);
868 
	    }
869 
	    int j = INTEGER(sindx)[i] - 1;
870 
	    if(STRING_ELT(s, i) != NA_STRING && CHAR(STRING_ELT(s, i))[0]) {
871 
		sub = pindx[j];
872 
		SET_VECTOR_ELT(indexnames, i, STRING_ELT(s, j));
873 
	    }
1839 ihaka 874 
	}
875 
	if (sub == 0) {
41686 ripley 876 
	    if (!canstretch) {
877 
		ECALL(call, _("subscript out of bounds"));
878 
	    }
1839 ihaka 879 
	    extra += 1;
880 
	    sub = extra;
51067 ripley 881 
	    SET_VECTOR_ELT(indexnames, i, STRING_ELT(s, i));
1839 ihaka 882 
	}
73567 luke 883 
	pindx[i] = (int) sub;
1839 ihaka 884 
    }
38655 ripley 885 
    /* We return the new names as the names attribute of the returned
886 
       subscript vector. */
29363 ripley 887 
    if (extra != nnames)
51067 ripley 888 
	setAttrib(indx, R_UseNamesSymbol, indexnames);
74660 lawrence 889 
    if (sindx != NULL) {
890 
	UNPROTECT(2);
891 
    }
8505 pd 892 
    if (canstretch)
893 
	*stretch = extra;
74660 lawrence 894 
    UNPROTECT(3);
10921 maechler 895 
    return indx;
2 r 896 
}
897 
 
29363 ripley 898 
/* Array Subscripts.
14913 rgentlem 899 
    dim is the dimension (0 to k-1)
29363 ripley 900 
    s is the subscript list,
14913 rgentlem 901 
    dims is the dimensions of x
902 
    dng is a function (usually getAttrib) that obtains the dimnames
29363 ripley 903 
    x is the array to be subscripted.
14913 rgentlem 904 
*/
2 r 905 
 
59086 ripley 906 
attribute_hidden SEXP
59066 ripley 907 
int_arraySubscript(int dim, SEXP s, SEXP dims, SEXP x, SEXP call)
2 r 908 
{
59095 ripley 909 
    int nd, ns;
910 
    R_xlen_t stretch = 0;
14913 rgentlem 911 
    SEXP dnames, tmp;
1839 ihaka 912 
    ns = length(s);
73567 luke 913 
    nd = INTEGER_ELT(dims, dim);
2 r 914 
 
1839 ihaka 915 
    switch (TYPEOF(s)) {
916 
    case NILSXP:
917 
	return allocVector(INTSXP, 0);
918 
    case LGLSXP:
41680 ripley 919 
	return logicalSubscript(s, ns, nd, &stretch, call);
1839 ihaka 920 
    case INTSXP:
41680 ripley 921 
	return integerSubscript(s, ns, nd, &stretch, call);
1839 ihaka 922 
    case REALSXP:
59118 ripley 923 
	/* We don't yet allow subscripts > R_SHORT_LEN_MAX */
45446 ripley 924 
	PROTECT(tmp = coerceVector(s, INTSXP));
41680 ripley 925 
	tmp = integerSubscript(tmp, ns, nd, &stretch, call);
45446 ripley 926 
	UNPROTECT(1);
2504 pd 927 
	return tmp;
1839 ihaka 928 
    case STRSXP:
59066 ripley 929 
	dnames = getAttrib(x, R_DimNamesSymbol);
41686 ripley 930 
	if (dnames == R_NilValue) {
931 
	    ECALL(call, _("no 'dimnames' attribute for array"));
932 
	}
10172 luke 933 
	dnames = VECTOR_ELT(dnames, dim);
59066 ripley 934 
	return stringSubscript(s, ns, nd, dnames, &stretch, call);
1839 ihaka 935 
    case SYMSXP:
936 
	if (s == R_MissingArg)
937 
	    return nullSubscript(nd);
938 
    default:
69576 maechler 939 
	ECALL3(call, _("invalid subscript type '%s'"), type2char(TYPEOF(s)));
1839 ihaka 940 
    }
941 
    return R_NilValue;
2 r 942 
}
943 
 
59066 ripley 944 
/* This is used by packages arules, cba, proxy and seriation. */
945 
typedef SEXP AttrGetter(SEXP x, SEXP data);
946 
typedef SEXP (*StringEltGetter)(SEXP x, int i);
947 
 
38676 ripley 948 
SEXP
36990 ripley 949 
arraySubscript(int dim, SEXP s, SEXP dims, AttrGetter dng,
950 
	       StringEltGetter strg, SEXP x)
29363 ripley 951 
{
59066 ripley 952 
    return int_arraySubscript(dim, s, dims, x, R_NilValue);
29363 ripley 953 
}
954 
 
1839 ihaka 955 
/* Subscript creation.  The first thing we do is check to see */
956 
/* if there are any user supplied NULL's, these result in */
957 
/* returning a vector of length 0. */
15317 rgentlem 958 
/* if stretch is zero on entry then the vector x cannot be
959 
   "stretched",
960 
   otherwise, stretch returns the new required length for x
961 
*/
2 r 962 
 
63630 luke 963 
SEXP attribute_hidden
59095 ripley 964 
makeSubscript(SEXP x, SEXP s, R_xlen_t *stretch, SEXP call)
2 r 965 
{
63630 luke 966 
    if (! (isVector(x) || isList(x) || isLanguage(x))) {
41686 ripley 967 
	ECALL(call, _("subscripting on non-vector"));
968 
    }
15317 rgentlem 969 
 
63630 luke 970 
    R_xlen_t nx = xlength(x);
15317 rgentlem 971 
 
972 
    /* special case for simple indices -- does not duplicate */
73567 luke 973 
    if (IS_SCALAR(s, INTSXP)) {
974 
	int i = SCALAR_IVAL(s);
975 
	if (0 < i && i <= nx) {
976 
	    *stretch = 0;
977 
	    return s;
10782 luke 978 
	}
73567 luke 979 
    }
980 
    else if (IS_SCALAR(s, REALSXP)) {
981 
	double di = SCALAR_DVAL(s);
982 
	if (1 <= di && di <= nx) {
983 
	    *stretch = 0;
984 
	    /* We could only return a REALSXP if the value is too
985 
	       large for an INTSXP, but, as the calling code can
986 
	       handle REALSXP indices, returning the REALSXP
987 
	       avoids an allocation. */
988 
	    return s;
63630 luke 989 
	}
15317 rgentlem 990 
    }
63630 luke 991 
 
73567 luke 992 
    R_xlen_t ns = xlength(s);
63630 luke 993 
    SEXP ans = R_NilValue;
15317 rgentlem 994 
    switch (TYPEOF(s)) {
995 
    case NILSXP:
996 
	*stretch = 0;
997 
	ans = allocVector(INTSXP, 0);
998 
	break;
999 
    case LGLSXP:
41680 ripley 1000 
	ans = logicalSubscript(s, ns, nx, stretch, call);
15317 rgentlem 1001 
	break;
1002 
    case INTSXP:
42414 ripley 1003 
	ans = integerSubscript(s, ns, nx, stretch, call);
1004 
	break;
15317 rgentlem 1005 
    case REALSXP:
59065 ripley 1006 
	ans = realSubscript(s, ns, nx, stretch, call);
15317 rgentlem 1007 
	break;
1008 
    case STRSXP:
1009 
    {
75532 kalibera 1010 
	SEXP names = PROTECT(getAttrib(x, R_NamesSymbol));
15317 rgentlem 1011 
	/* *stretch = 0; */
59066 ripley 1012 
	ans = stringSubscript(s, ns, nx, names, stretch, call);
75532 kalibera 1013 
	UNPROTECT(1); /* names */
63630 luke 1014 
	break;
15317 rgentlem 1015 
    }
1016 
    case SYMSXP:
1017 
	*stretch = 0;
1018 
	if (s == R_MissingArg) {
1019 
	    ans = nullSubscript(nx);
1839 ihaka 1020 
	    break;
2 r 1021 
	}
15317 rgentlem 1022 
    default:
69576 maechler 1023 
	ECALL3(call, _("invalid subscript type '%s'"), type2char(TYPEOF(s)));
1839 ihaka 1024 
    }
1025 
    return ans;
2 r 1026 
}