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



    /* pre-test to avoid expensive operations if clearly not needed -- LT */
    if (ATTRIB(vec) == R_NilValue &&
	! (TYPEOF(vec) == LISTSXP || TYPEOF(vec) == LANGSXP))
	return R_NilValue;
 
 
    if (isString(name)) name = installTrChar(STRING_ELT(name, 0));
 
 
    /* special test for c(NA, n) rownames of data frames: */
    if (name == R_RowNamesSymbol) {
	SEXP s = getAttrib0(vec, R_RowNamesSymbol);
	if(isInteger(s) && LENGTH(s) == 2 && INTEGER(s)[0] == NA_INTEGER) {

{
    PROTECT(vec);
    PROTECT(name);
 
    if (isString(name)) {
 
	name = installTrChar(STRING_ELT(name, 0));
 
    }
    if (val == R_NilValue) {
	UNPROTECT(2);
	return removeAttrib(vec, name);
    }

	i = 0;
	for (s = vec; s != R_NilValue; s = CDR(s), i++)
	    if (STRING_ELT(val, i) != R_NilValue
		&& STRING_ELT(val, i) != R_NaString
		&& *CHAR(STRING_ELT(val, i)) != 0) /* test of length */
		SET_TAG(s, installTrChar(STRING_ELT(val, i)));
	    else
		SET_TAG(s, R_NilValue);
    }
    else if (isVector(vec) || IS_S4_OBJECT(vec))
	/* Normal case */

    installAttrib(vec, R_DimNamesSymbol, val);
    if (isList(vec) && k == 1) {
	top = VECTOR_ELT(val, 0);
	i = 0;
	for (val = vec; !isNull(val); val = CDR(val))
	    SET_TAG(val, installTrChar(STRING_ELT(top, i++)));
    }
    UNPROTECT(2);
    return vec;
}
 

		break;
	    }
	}
	for (i = 0; i < nattrs; i++) {
	    if (i == i0) continue;
	    setAttrib(object, installTrChar(STRING_ELT(names, i)),
		      VECTOR_ELT(attrs, i));
	}
    }
    UNPROTECT(1);
    return object;

	error(_("attempt to set slot on NULL object"));
#endif
    PROTECT(obj); PROTECT(value);
    /* Ensure that name is a symbol */
    if(isString(name) && LENGTH(name) == 1)
	name = installTrChar(STRING_ELT(name, 0));
    if(TYPEOF(name) == CHARSXP)
	name = installTrChar(name);
    if(!isSymbol(name) )
	error(_("invalid type or length for slot name"));
 
    if(!s_dot_Data)		/* initialize */
	init_slot_handling();

    nlist = CADR(args);
    /* Do some checks here -- repeated in R_do_slot, but on repeat the
     * test expression should kick out on the first element. */
    if(!(isSymbol(nlist) || (isString(nlist) && LENGTH(nlist) == 1)))
	error(_("invalid type or length for slot name"));
    if(isString(nlist)) nlist = installTrChar(STRING_ELT(nlist, 0));
    PROTECT(object = eval(CAR(args), env));
    if(!s_dot_Data) init_slot_handling();
    if(nlist != s_dot_Data && !IS_S4_OBJECT(object)) {
	klass = getAttrib(object, R_ClassSymbol);
	if(length(klass) == 0)

Rev 63181	Rev 63223
Line 161...	Line 161...
161	`/* pre-test to avoid expensive operations if clearly not needed -- LT */`	161	`/* pre-test to avoid expensive operations if clearly not needed -- LT */`
162	`if (ATTRIB(vec) == R_NilValue &&`	162	`if (ATTRIB(vec) == R_NilValue &&`
163	`! (TYPEOF(vec) == LISTSXP \|\| TYPEOF(vec) == LANGSXP))`	163	`! (TYPEOF(vec) == LISTSXP \|\| TYPEOF(vec) == LANGSXP))`
164	`return R_NilValue;`	164	`return R_NilValue;`
165		165
166	`const void *vmax = vmaxget();`	-
167	`if (isString(name)) name = install(translateChar(STRING_ELT(name, 0)));`	166	`if (isString(name)) name = installTrChar(STRING_ELT(name, 0));`
168	`vmaxset(vmax);`	-
169		167
170	`/* special test for c(NA, n) rownames of data frames: */`	168	`/* special test for c(NA, n) rownames of data frames: */`
171	`if (name == R_RowNamesSymbol) {`	169	`if (name == R_RowNamesSymbol) {`
172	`SEXP s = getAttrib0(vec, R_RowNamesSymbol);`	170	`SEXP s = getAttrib0(vec, R_RowNamesSymbol);`
173	`if(isInteger(s) && LENGTH(s) == 2 && INTEGER(s)[0] == NA_INTEGER) {`	171	`if(isInteger(s) && LENGTH(s) == 2 && INTEGER(s)[0] == NA_INTEGER) {`
Line 223...	Line 221...
223	`{`	221	`{`
224	`PROTECT(vec);`	222	`PROTECT(vec);`
225	`PROTECT(name);`	223	`PROTECT(name);`
226		224
227	`if (isString(name)) {`	225	`if (isString(name)) {`
228	`const void *vmax = vmaxget();`	-
229	`name = install(translateChar(STRING_ELT(name, 0)));`	226	`name = installTrChar(STRING_ELT(name, 0));`
230	`vmaxset(vmax);`	-
231	`}`	227	`}`
232	`if (val == R_NilValue) {`	228	`if (val == R_NilValue) {`
233	`UNPROTECT(2);`	229	`UNPROTECT(2);`
234	`return removeAttrib(vec, name);`	230	`return removeAttrib(vec, name);`
235	`}`	231	`}`
Line 858...	Line 854...
858	`i = 0;`	854	`i = 0;`
859	`for (s = vec; s != R_NilValue; s = CDR(s), i++)`	855	`for (s = vec; s != R_NilValue; s = CDR(s), i++)`
860	`if (STRING_ELT(val, i) != R_NilValue`	856	`if (STRING_ELT(val, i) != R_NilValue`
861	`&& STRING_ELT(val, i) != R_NaString`	857	`&& STRING_ELT(val, i) != R_NaString`
862	`&& CHAR(STRING_ELT(val, i)) != 0) / test of length */`	858	`&& CHAR(STRING_ELT(val, i)) != 0) / test of length */`
863	`SET_TAG(s, install(translateChar(STRING_ELT(val, i))));`	859	`SET_TAG(s, installTrChar(STRING_ELT(val, i)));`
864	`else`	860	`else`
865	`SET_TAG(s, R_NilValue);`	861	`SET_TAG(s, R_NilValue);`
866	`}`	862	`}`
867	`else if (isVector(vec) \|\| IS_S4_OBJECT(vec))`	863	`else if (isVector(vec) \|\| IS_S4_OBJECT(vec))`
868	`/* Normal case */`	864	`/* Normal case */`
Line 987...	Line 983...
987	`installAttrib(vec, R_DimNamesSymbol, val);`	983	`installAttrib(vec, R_DimNamesSymbol, val);`
988	`if (isList(vec) && k == 1) {`	984	`if (isList(vec) && k == 1) {`
989	`top = VECTOR_ELT(val, 0);`	985	`top = VECTOR_ELT(val, 0);`
990	`i = 0;`	986	`i = 0;`
991	`for (val = vec; !isNull(val); val = CDR(val))`	987	`for (val = vec; !isNull(val); val = CDR(val))`
992	`SET_TAG(val, install(translateChar(STRING_ELT(top, i++))));`	988	`SET_TAG(val, installTrChar(STRING_ELT(top, i++)));`
993	`}`	989	`}`
994	`UNPROTECT(2);`	990	`UNPROTECT(2);`
995	`return vec;`	991	`return vec;`
996	`}`	992	`}`
997		993
Line 1233...	Line 1229...
1233	`break;`	1229	`break;`
1234	`}`	1230	`}`
1235	`}`	1231	`}`
1236	`for (i = 0; i < nattrs; i++) {`	1232	`for (i = 0; i < nattrs; i++) {`
1237	`if (i == i0) continue;`	1233	`if (i == i0) continue;`
1238	`setAttrib(object, install(translateChar(STRING_ELT(names, i))),`	1234	`setAttrib(object, installTrChar(STRING_ELT(names, i)),`
1239	`VECTOR_ELT(attrs, i));`	1235	`VECTOR_ELT(attrs, i));`
1240	`}`	1236	`}`
1241	`}`	1237	`}`
1242	`UNPROTECT(1);`	1238	`UNPROTECT(1);`
1243	`return object;`	1239	`return object;`
Line 1629...	Line 1625...
1629	`error(_("attempt to set slot on NULL object"));`	1625	`error(_("attempt to set slot on NULL object"));`
1630	`#endif`	1626	`#endif`
1631	`PROTECT(obj); PROTECT(value);`	1627	`PROTECT(obj); PROTECT(value);`
1632	`/* Ensure that name is a symbol */`	1628	`/* Ensure that name is a symbol */`
1633	`if(isString(name) && LENGTH(name) == 1)`	1629	`if(isString(name) && LENGTH(name) == 1)`
1634	`name = install(translateChar(STRING_ELT(name, 0)));`	1630	`name = installTrChar(STRING_ELT(name, 0));`
1635	`if(TYPEOF(name) == CHARSXP)`	1631	`if(TYPEOF(name) == CHARSXP)`
1636	`name = install(translateChar(name));`	1632	`name = installTrChar(name);`
1637	`if(!isSymbol(name) )`	1633	`if(!isSymbol(name) )`
1638	`error(_("invalid type or length for slot name"));`	1634	`error(_("invalid type or length for slot name"));`
1639		1635
1640	`if(!s_dot_Data) /* initialize */`	1636	`if(!s_dot_Data) /* initialize */`
1641	`init_slot_handling();`	1637	`init_slot_handling();`
Line 1671...	Line 1667...
1671	`nlist = CADR(args);`	1667	`nlist = CADR(args);`
1672	`/* Do some checks here -- repeated in R_do_slot, but on repeat the`	1668	`/* Do some checks here -- repeated in R_do_slot, but on repeat the`
1673	`* test expression should kick out on the first element. */`	1669	`* test expression should kick out on the first element. */`
1674	`if(!(isSymbol(nlist) \|\| (isString(nlist) && LENGTH(nlist) == 1)))`	1670	`if(!(isSymbol(nlist) \|\| (isString(nlist) && LENGTH(nlist) == 1)))`
1675	`error(_("invalid type or length for slot name"));`	1671	`error(_("invalid type or length for slot name"));`
1676	`if(isString(nlist)) nlist = install(translateChar(STRING_ELT(nlist, 0)));`	1672	`if(isString(nlist)) nlist = installTrChar(STRING_ELT(nlist, 0));`
1677	`PROTECT(object = eval(CAR(args), env));`	1673	`PROTECT(object = eval(CAR(args), env));`
1678	`if(!s_dot_Data) init_slot_handling();`	1674	`if(!s_dot_Data) init_slot_handling();`
1679	`if(nlist != s_dot_Data && !IS_S4_OBJECT(object)) {`	1675	`if(nlist != s_dot_Data && !IS_S4_OBJECT(object)) {`
1680	`klass = getAttrib(object, R_ClassSymbol);`	1676	`klass = getAttrib(object, R_ClassSymbol);`
1681	`if(length(klass) == 0)`	1677	`if(length(klass) == 0)`

The R Project SVN R

(root)/trunk/src/main/attrib.c – Rev 63181 → 63223