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



/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 1997--2018  The R Core Team
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or

    return indx;
}
 
/* Utility used (only in) do_subassign2_dflt(), i.e. "[[<-" in ./subassign.c : */
R_xlen_t attribute_hidden
OneIndex(SEXP x, SEXP s, R_xlen_t nx, int partial, SEXP *newname,
	 int pos, SEXP call)
{
    SEXP names;
    R_xlen_t i, indx;
    const void *vmax;
 
    if (pos < 0 && length(s) > 1) {
	ECALL3(call, _("attempt to select more than one element in %s"), "OneIndex");
    }

    indx = -1;
    *newname = R_NilValue;
    switch(TYPEOF(s)) {
    case LGLSXP:
    case INTSXP:
	indx = integerOneIndex(INTEGER_ELT(s, pos), nx, call);
	break;
    case REALSXP:
	indx = integerOneIndex((int)REAL_ELT(s, pos), nx, call);
	break;
    case STRSXP:
	vmax = vmaxget();
 
	names = getAttrib(x, R_NamesSymbol);
	if (names != R_NilValue) {
	    PROTECT(names);
	    /* Try for exact match */
	    for (i = 0; i < nx; i++) {
		const char *tmp = translateChar(STRING_ELT(names, i));
		if (!tmp[0]) continue;
		if (streql(tmp, translateChar(STRING_ELT(s, pos)))) {

			else
			    indx = -2;
		    }
		}
	    }
	    UNPROTECT(1); /* names */
	}
 
	if (indx == -1)
	    indx = nx;
	*newname = STRING_ELT(s, pos);
	vmaxset(vmax);
	break;
    case SYMSXP:
	vmax = vmaxget();
 
	names = getAttrib(x, R_NamesSymbol);
	if (names != R_NilValue) {
	    PROTECT(names);
	    for (i = 0; i < nx; i++)
		if (streql(translateChar(STRING_ELT(names, i)),

Rev 74021	Rev 74145
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) 1997--2017 The R Core Team`	3	`* Copyright (C) 1997--2018 The R Core Team`
4	`* Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka`	4	`* Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka`
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`
8	`* the Free Software Foundation; either version 2 of the License, or`	8	`* the Free Software Foundation; either version 2 of the License, or`
Line 65...	Line 65...
65	`return indx;`	65	`return indx;`
66	`}`	66	`}`
67		67
68	`/* Utility used (only in) do_subassign2_dflt(), i.e. "[[<-" in ./subassign.c : */`	68	`/* Utility used (only in) do_subassign2_dflt(), i.e. "[[<-" in ./subassign.c : */`
69	`R_xlen_t attribute_hidden`	69	`R_xlen_t attribute_hidden`
70	`OneIndex(SEXP x, SEXP s, R_xlen_t len, int partial, SEXP *newname,`	70	`OneIndex(SEXP x, SEXP s, R_xlen_t nx, int partial, SEXP *newname,`
71	`int pos, SEXP call)`	71	`int pos, SEXP call)`
72	`{`	72	`{`
73	`SEXP names;`	73	`SEXP names;`
74	`R_xlen_t i, indx, nx;`	74	`R_xlen_t i, indx;`
75	`const void *vmax;`	75	`const void *vmax;`
76		76
77	`if (pos < 0 && length(s) > 1) {`	77	`if (pos < 0 && length(s) > 1) {`
78	`ECALL3(call, _("attempt to select more than one element in %s"), "OneIndex");`	78	`ECALL3(call, _("attempt to select more than one element in %s"), "OneIndex");`
79	`}`	79	`}`
Line 86...	Line 86...
86	`indx = -1;`	86	`indx = -1;`
87	`*newname = R_NilValue;`	87	`*newname = R_NilValue;`
88	`switch(TYPEOF(s)) {`	88	`switch(TYPEOF(s)) {`
89	`case LGLSXP:`	89	`case LGLSXP:`
90	`case INTSXP:`	90	`case INTSXP:`
91	`indx = integerOneIndex(INTEGER_ELT(s, pos), len, call);`	91	`indx = integerOneIndex(INTEGER_ELT(s, pos), nx, call);`
92	`break;`	92	`break;`
93	`case REALSXP:`	93	`case REALSXP:`
94	`indx = integerOneIndex((int)REAL_ELT(s, pos), len, call);`	94	`indx = integerOneIndex((int)REAL_ELT(s, pos), nx, call);`
95	`break;`	95	`break;`
96	`case STRSXP:`	96	`case STRSXP:`
97	`vmax = vmaxget();`	97	`vmax = vmaxget();`
98	`nx = xlength(x);`	-
99	`names = PROTECT(getAttrib(x, R_NamesSymbol));`	98	`names = getAttrib(x, R_NamesSymbol);`
100	`if (names != R_NilValue) {`	99	`if (names != R_NilValue) {`
-		100	`PROTECT(names);`
101	`/* Try for exact match */`	101	`/* Try for exact match */`
102	`for (i = 0; i < nx; i++) {`	102	`for (i = 0; i < nx; i++) {`
103	`const char *tmp = translateChar(STRING_ELT(names, i));`	103	`const char *tmp = translateChar(STRING_ELT(names, i));`
104	`if (!tmp[0]) continue;`	104	`if (!tmp[0]) continue;`
105	`if (streql(tmp, translateChar(STRING_ELT(s, pos)))) {`	105	`if (streql(tmp, translateChar(STRING_ELT(s, pos)))) {`
Line 119...	Line 119...
119	`else`	119	`else`
120	`indx = -2;`	120	`indx = -2;`
121	`}`	121	`}`
122	`}`	122	`}`
123	`}`	123	`}`
-		124	`UNPROTECT(1); /* names */`
124	`}`	125	`}`
125	`UNPROTECT(1); /* names */`	-
126	`if (indx == -1)`	126	`if (indx == -1)`
127	`indx = nx;`	127	`indx = nx;`
128	`*newname = STRING_ELT(s, pos);`	128	`*newname = STRING_ELT(s, pos);`
129	`vmaxset(vmax);`	129	`vmaxset(vmax);`
130	`break;`	130	`break;`
131	`case SYMSXP:`	131	`case SYMSXP:`
132	`vmax = vmaxget();`	132	`vmax = vmaxget();`
133	`nx = xlength(x);`	-
134	`names = getAttrib(x, R_NamesSymbol);`	133	`names = getAttrib(x, R_NamesSymbol);`
135	`if (names != R_NilValue) {`	134	`if (names != R_NilValue) {`
136	`PROTECT(names);`	135	`PROTECT(names);`
137	`for (i = 0; i < nx; i++)`	136	`for (i = 0; i < nx; i++)`
138	`if (streql(translateChar(STRING_ELT(names, i)),`	137	`if (streql(translateChar(STRING_ELT(names, i)),`

The R Project SVN R

(root)/trunk/src/main/subscript.c @ 77458 – Rev 74021 → 74145