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



    PROTECT(klass = R_data_class2(obj));
    sort_list = install("sort.list");
 
    nclass = length(klass);
    for (i = 0; i < nclass; i++) {
	const void *vmax = vmaxget();
        const char *ss = translateChar(STRING_ELT(klass, i));
	if(strlen(generic) + strlen(ss) + 2 > 512)
	    error(_("class name too long in '%s'"), generic);
	snprintf(buf, 512, "%s.%s", generic, ss);
	method = install(buf);
	vmaxset(vmax);
	sxp = R_LookupMethod(method, rho, callrho, defrho);
	if (isFunction(sxp)) {
	    if(method == sort_list && CLOENV(sxp) == R_BaseNamespace)
		continue; /* kludge because sort.list is not a method */
            if( RDEBUG(op) || RSTEP(op) )

 * @return if which is false, logical TRUE or FALSE
 *	   if which is true, integer vector of length(what) ..
 */
static SEXP inherits3(SEXP x, SEXP what, SEXP which)
{
    const void *vmax = vmaxget();
    SEXP klass, rval = R_NilValue /* -Wall */;
 
    if(IS_S4_OBJECT(x))
	PROTECT(klass = R_data_class2(x));
    else
	PROTECT(klass = R_data_class(x, FALSE));
    int nclass = length(klass);

		}
		break;
	    }
	}
    }
    vmaxset(vmax);
    if(!isvec) {
    	UNPROTECT(1);
	return mkFalse();
    }
    UNPROTECT(2);

{
    /* dispatch the non-generic definition of `name'.  Used to trap
       calls to standardGeneric during the loading of the methods package */
    SEXP e, value, rho, fun, symbol;
    RCNTXT *cptr;
    const void *vmax = vmaxget();
 
    /* find a non-generic function */
    symbol = install(translateChar(asChar(name)));
    for(rho = ENCLOS(env); rho != R_EmptyEnv;
	rho = ENCLOS(rho)) {
	fun = findVarInFrame3(rho, symbol, TRUE);

    SETCAR(e, fun);
    /* evaluate a call the non-generic with the same arguments and from
       the same environment as the call to the generic version */
    value = eval(e, cptr->sysparent);
    UNPROTECT(1);
    vmaxset(vmax);
    return value;
}
 
 
static SEXP get_this_generic(SEXP args);

/* This is used in the methods package, in src/methods_list_dispatch.c */
SEXP R_set_prim_method(SEXP fname, SEXP op, SEXP code_vec, SEXP fundef,
		       SEXP mlist)
{
    const char *code_string;
    const void *vmax = vmaxget();
    if(!isValidString(code_vec))
	error(_("argument 'code' must be a character string"));
    code_string = translateChar(asChar(code_vec));
    /* with a NULL op, turns all primitive matching off or on (used to avoid possible infinite
     recursion in methods computations*/

	    break;
	}
	return value;
    }
    do_set_prim_method(op, code_string, fundef, mlist);
    vmaxset(vmax);
    return fname;
}
 
SEXP R_primitive_methods(SEXP op)
{
    int offset = PRIMOFFSET(op);

	    }
	}
    }
    UNPROTECT(1);
    vmaxset(vmax);
 
    return value;
}
 
/* Could there be methods for this op?	Checks
   only whether methods are currently being dispatched and, if so,
   whether methods are currently defined for this op. */

/* in Rinternals.h */
SEXP R_do_new_object(SEXP class_def)
{
    static SEXP s_virtual = NULL, s_prototype, s_className;
    SEXP e, value;
    const void *vmax = vmaxget();
    if(!s_virtual) {
	s_virtual = install("virtual");
	s_prototype = install("prototype");
	s_className = install("className");
    }

    if(TYPEOF(value) == S4SXP || getAttrib(e, R_PackageSymbol) != R_NilValue)
    { /* Anything but an object from a base "class" (numeric, matrix,..) */
	setAttrib(value, R_ClassSymbol, e);
	SET_S4_OBJECT(value);
    }
    vmaxset(vmax);
    return value;
}
 
Rboolean attribute_hidden R_seemsOldStyleS4Object(SEXP object)
{

Rev 63176	Rev 63181
Line 306...	Line 306...
306	`PROTECT(klass = R_data_class2(obj));`	306	`PROTECT(klass = R_data_class2(obj));`
307	`sort_list = install("sort.list");`	307	`sort_list = install("sort.list");`
308		308
309	`nclass = length(klass);`	309	`nclass = length(klass);`
310	`for (i = 0; i < nclass; i++) {`	310	`for (i = 0; i < nclass; i++) {`
-		311	`const void *vmax = vmaxget();`
311	`const char *ss = translateChar(STRING_ELT(klass, i));`	312	`const char *ss = translateChar(STRING_ELT(klass, i));`
312	`if(strlen(generic) + strlen(ss) + 2 > 512)`	313	`if(strlen(generic) + strlen(ss) + 2 > 512)`
313	`error(_("class name too long in '%s'"), generic);`	314	`error(_("class name too long in '%s'"), generic);`
314	`snprintf(buf, 512, "%s.%s", generic, ss);`	315	`snprintf(buf, 512, "%s.%s", generic, ss);`
315	`method = install(buf);`	316	`method = install(buf);`
-		317	`vmaxset(vmax);`
316	`sxp = R_LookupMethod(method, rho, callrho, defrho);`	318	`sxp = R_LookupMethod(method, rho, callrho, defrho);`
317	`if (isFunction(sxp)) {`	319	`if (isFunction(sxp)) {`
318	`if(method == sort_list && CLOENV(sxp) == R_BaseNamespace)`	320	`if(method == sort_list && CLOENV(sxp) == R_BaseNamespace)`
319	`continue; /* kludge because sort.list is not a method */`	321	`continue; /* kludge because sort.list is not a method */`
320	`if( RDEBUG(op) \|\| RSTEP(op) )`	322	`if( RDEBUG(op) \|\| RSTEP(op) )`
Line 851...	Line 853...
851	`* @return if which is false, logical TRUE or FALSE`	853	`* @return if which is false, logical TRUE or FALSE`
852	`* if which is true, integer vector of length(what) ..`	854	`* if which is true, integer vector of length(what) ..`
853	`*/`	855	`*/`
854	`static SEXP inherits3(SEXP x, SEXP what, SEXP which)`	856	`static SEXP inherits3(SEXP x, SEXP what, SEXP which)`
855	`{`	857	`{`
-		858	`const void *vmax = vmaxget();`
856	`SEXP klass, rval = R_NilValue /* -Wall */;`	859	`SEXP klass, rval = R_NilValue /* -Wall */;`
-		860
857	`if(IS_S4_OBJECT(x))`	861	`if(IS_S4_OBJECT(x))`
858	`PROTECT(klass = R_data_class2(x));`	862	`PROTECT(klass = R_data_class2(x));`
859	`else`	863	`else`
860	`PROTECT(klass = R_data_class(x, FALSE));`	864	`PROTECT(klass = R_data_class(x, FALSE));`
861	`int nclass = length(klass);`	865	`int nclass = length(klass);`
Line 891...	Line 895...
891	`}`	895	`}`
892	`break;`	896	`break;`
893	`}`	897	`}`
894	`}`	898	`}`
895	`}`	899	`}`
-		900	`vmaxset(vmax);`
896	`if(!isvec) {`	901	`if(!isvec) {`
897	`UNPROTECT(1);`	902	`UNPROTECT(1);`
898	`return mkFalse();`	903	`return mkFalse();`
899	`}`	904	`}`
900	`UNPROTECT(2);`	905	`UNPROTECT(2);`
Line 1076...	Line 1081...
1076	`{`	1081	`{`
1077	/* dispatch the non-generic definition of `name'. Used to trap	1082	/* dispatch the non-generic definition of `name'. Used to trap
1078	`calls to standardGeneric during the loading of the methods package */`	1083	`calls to standardGeneric during the loading of the methods package */`
1079	`SEXP e, value, rho, fun, symbol;`	1084	`SEXP e, value, rho, fun, symbol;`
1080	`RCNTXT *cptr;`	1085	`RCNTXT *cptr;`
-		1086	`const void *vmax = vmaxget();`
-		1087
1081	`/* find a non-generic function */`	1088	`/* find a non-generic function */`
1082	`symbol = install(translateChar(asChar(name)));`	1089	`symbol = install(translateChar(asChar(name)));`
1083	`for(rho = ENCLOS(env); rho != R_EmptyEnv;`	1090	`for(rho = ENCLOS(env); rho != R_EmptyEnv;`
1084	`rho = ENCLOS(rho)) {`	1091	`rho = ENCLOS(rho)) {`
1085	`fun = findVarInFrame3(rho, symbol, TRUE);`	1092	`fun = findVarInFrame3(rho, symbol, TRUE);`
Line 1112...	Line 1119...
1112	`SETCAR(e, fun);`	1119	`SETCAR(e, fun);`
1113	`/* evaluate a call the non-generic with the same arguments and from`	1120	`/* evaluate a call the non-generic with the same arguments and from`
1114	`the same environment as the call to the generic version */`	1121	`the same environment as the call to the generic version */`
1115	`value = eval(e, cptr->sysparent);`	1122	`value = eval(e, cptr->sysparent);`
1116	`UNPROTECT(1);`	1123	`UNPROTECT(1);`
-		1124	`vmaxset(vmax);`
1117	`return value;`	1125	`return value;`
1118	`}`	1126	`}`
1119		1127
1120		1128
1121	`static SEXP get_this_generic(SEXP args);`	1129	`static SEXP get_this_generic(SEXP args);`
Line 1163...	Line 1171...
1163	`/* This is used in the methods package, in src/methods_list_dispatch.c */`	1171	`/* This is used in the methods package, in src/methods_list_dispatch.c */`
1164	`SEXP R_set_prim_method(SEXP fname, SEXP op, SEXP code_vec, SEXP fundef,`	1172	`SEXP R_set_prim_method(SEXP fname, SEXP op, SEXP code_vec, SEXP fundef,`
1165	`SEXP mlist)`	1173	`SEXP mlist)`
1166	`{`	1174	`{`
1167	`const char *code_string;`	1175	`const char *code_string;`
-		1176	`const void *vmax = vmaxget();`
1168	`if(!isValidString(code_vec))`	1177	`if(!isValidString(code_vec))`
1169	`error(_("argument 'code' must be a character string"));`	1178	`error(_("argument 'code' must be a character string"));`
1170	`code_string = translateChar(asChar(code_vec));`	1179	`code_string = translateChar(asChar(code_vec));`
1171	`/* with a NULL op, turns all primitive matching off or on (used to avoid possible infinite`	1180	`/* with a NULL op, turns all primitive matching off or on (used to avoid possible infinite`
1172	`recursion in methods computations*/`	1181	`recursion in methods computations*/`
Line 1182...	Line 1191...
1182	`break;`	1191	`break;`
1183	`}`	1192	`}`
1184	`return value;`	1193	`return value;`
1185	`}`	1194	`}`
1186	`do_set_prim_method(op, code_string, fundef, mlist);`	1195	`do_set_prim_method(op, code_string, fundef, mlist);`
-		1196	`vmaxset(vmax);`
1187	`return(fname);`	1197	`return fname;`
1188	`}`	1198	`}`
1189		1199
1190	`SEXP R_primitive_methods(SEXP op)`	1200	`SEXP R_primitive_methods(SEXP op)`
1191	`{`	1201	`{`
1192	`int offset = PRIMOFFSET(op);`	1202	`int offset = PRIMOFFSET(op);`
Line 1359...	Line 1369...
1359	`}`	1369	`}`
1360	`}`	1370	`}`
1361	`}`	1371	`}`
1362	`UNPROTECT(1);`	1372	`UNPROTECT(1);`
1363	`vmaxset(vmax);`	1373	`vmaxset(vmax);`
-		1374
1364	`return(value);`	1375	`return value;`
1365	`}`	1376	`}`
1366		1377
1367	`/* Could there be methods for this op? Checks`	1378	`/* Could there be methods for this op? Checks`
1368	`only whether methods are currently being dispatched and, if so,`	1379	`only whether methods are currently being dispatched and, if so,`
1369	`whether methods are currently defined for this op. */`	1380	`whether methods are currently defined for this op. */`
Line 1512...	Line 1523...
1512	`/* in Rinternals.h */`	1523	`/* in Rinternals.h */`
1513	`SEXP R_do_new_object(SEXP class_def)`	1524	`SEXP R_do_new_object(SEXP class_def)`
1514	`{`	1525	`{`
1515	`static SEXP s_virtual = NULL, s_prototype, s_className;`	1526	`static SEXP s_virtual = NULL, s_prototype, s_className;`
1516	`SEXP e, value;`	1527	`SEXP e, value;`
-		1528	`const void *vmax = vmaxget();`
1517	`if(!s_virtual) {`	1529	`if(!s_virtual) {`
1518	`s_virtual = install("virtual");`	1530	`s_virtual = install("virtual");`
1519	`s_prototype = install("prototype");`	1531	`s_prototype = install("prototype");`
1520	`s_className = install("className");`	1532	`s_className = install("className");`
1521	`}`	1533	`}`
Line 1532...	Line 1544...
1532	`if(TYPEOF(value) == S4SXP \|\| getAttrib(e, R_PackageSymbol) != R_NilValue)`	1544	`if(TYPEOF(value) == S4SXP \|\| getAttrib(e, R_PackageSymbol) != R_NilValue)`
1533	`{ /* Anything but an object from a base "class" (numeric, matrix,..) */`	1545	`{ /* Anything but an object from a base "class" (numeric, matrix,..) */`
1534	`setAttrib(value, R_ClassSymbol, e);`	1546	`setAttrib(value, R_ClassSymbol, e);`
1535	`SET_S4_OBJECT(value);`	1547	`SET_S4_OBJECT(value);`
1536	`}`	1548	`}`
-		1549	`vmaxset(vmax);`
1537	`return value;`	1550	`return value;`
1538	`}`	1551	`}`
1539		1552
1540	`Rboolean attribute_hidden R_seemsOldStyleS4Object(SEXP object)`	1553	`Rboolean attribute_hidden R_seemsOldStyleS4Object(SEXP object)`
1541	`{`	1554	`{`

The R Project SVN R

(root)/trunk/src/main/objects.c @ 63243 – Rev 63176 → 63181