The R Project SVN – R – Diff – /branches/R-classInheritance/src/main/objects.c



    if(!isString(generic) || length(generic) != 1)
	errorcall(call, _("first argument must be a character string"));
    /* We need to find the generic to find out where it is defined.
       This is set up to avoid getting caught by things like
 
	mycoef <- function(x)
       {
	   mycoef <- function(x) stop("not this one")
	   UseMethod("mycoef")
       }
 
	The generic need not be a closure (Henrik Bengtsson writes
	UseMethod("$"), although only functions are documented.)
    */

		   ENCLOS(env), FUNSXP, TRUE); /* That has evaluated promises */
    if(TYPEOF(val) == CLOSXP) defenv = CLOENV(val);
    else defenv = R_BaseNamespace;
/*
    if(defenv !=  ENCLOS(env)) {
	printf("*** problem ***\n");
	PrintValue(generic);
	PrintValue(ENCLOS(env));
    }
*/
 

    setAttrib(s, install("previous"), klass);
    defineVar(install(".Class"), s, m);
    /* It is possible that if a method was called directly that
	'method' is unset */
    if (method != R_UnboundValue) {
	/* for Ops we need `method' to be a vector */
	PROTECT(method = duplicate(method));
	for(j = 0; j < length(method); j++) {
	    if (strlen(CHAR(STRING_ELT(method,j))))
		SET_STRING_ELT(method, j,  mkChar(buf));
	}
    } else
	PROTECT(method = mkString(buf));
    defineVar(install(".Method"), method, m);
    defineVar(install(".GenericCallEnv"), callenv, m);
    defineVar(install(".GenericDefEnv"), defenv, m);

   When called from the first the arguments have been enclosed in
   promises, but not from the other two: there all the arguments have
   already been evaluated.
 */
SEXP attribute_hidden
R_possible_dispatch(SEXP call, SEXP op, SEXP args, SEXP rho,
		    Rboolean promisedArgs)
{
    SEXP fundef, value, mlist=R_NilValue, s, a, b;
    int offset;
    prim_methods_t current;

    fundef = prim_generics[offset];
    if(!fundef || TYPEOF(fundef) != CLOSXP)
	error(_("primitive function \"%s\" has been set for methods but no generic function supplied"),
	      PRIMNAME(op));
    /* To do:  arrange for the setting to be restored in case of an
       error in method search */
    if(!promisedArgs) {
	PROTECT(s = promiseArgs(CDR(call), rho));
	if (length(s) != length(args)) error(_("dispatch error"));
	for (a = args, b = s; a != R_NilValue; a = CDR(a), b = CDR(b))
	    SET_PRVALUE(CAR(b), CAR(a));

    static SEXP R_packageSymbol = NULL;
    if(!s_virtual) {
	s_virtual = Rf_install("virtual");
	s_prototype = Rf_install("prototype");
	s_className = Rf_install("className");
	R_packageSymbol = install("package");
    }
    if(!class_def)
	error(_("C level NEW macro called with null class definition pointer"));
    e = R_do_slot(class_def, s_virtual);
    if(asLogical(e) != 0)  { /* includes NA, TRUE, or anything other than FALSE */

SEXP R_setS4Object(SEXP object, SEXP onOff)
{
    Rboolean flag = asLogical(onOff);
    /* wanted     return asS4(object, flag); */
    if(flag == IS_S4_OBJECT(object))
	return object;
    if(NAMED(object) == 2)
	object = duplicate(object);
    if(flag) SET_S4_OBJECT(object);
    else UNSET_S4_OBJECT(object);
    return object;
}
 

}
 
SEXP asS4(SEXP s, Rboolean flag)
{
    if(flag == IS_S4_OBJECT(s))
	return s;
    if(NAMED(s) == 2)
	s = duplicate(s);
    if(flag) SET_S4_OBJECT(s);
    else UNSET_S4_OBJECT(s);
    return s;
}

Rev 44195	Rev 45446
Line 350...	Line 350...
350	`if(!isString(generic) \|\| length(generic) != 1)`	350	`if(!isString(generic) \|\| length(generic) != 1)`
351	`errorcall(call, _("first argument must be a character string"));`	351	`errorcall(call, _("first argument must be a character string"));`
352	`/* We need to find the generic to find out where it is defined.`	352	`/* We need to find the generic to find out where it is defined.`
353	`This is set up to avoid getting caught by things like`	353	`This is set up to avoid getting caught by things like`
354		354
355	`mycoef <- function(x)`	355	`mycoef <- function(x)`
356	`{`	356	`{`
357	`mycoef <- function(x) stop("not this one")`	357	`mycoef <- function(x) stop("not this one")`
358	`UseMethod("mycoef")`	358	`UseMethod("mycoef")`
359	`}`	359	`}`
360		360
361	`The generic need not be a closure (Henrik Bengtsson writes`	361	`The generic need not be a closure (Henrik Bengtsson writes`
362	`UseMethod("$"), although only functions are documented.)`	362	`UseMethod("$"), although only functions are documented.)`
363	`*/`	363	`*/`
Line 365...	Line 365...
365	`ENCLOS(env), FUNSXP, TRUE); /* That has evaluated promises */`	365	`ENCLOS(env), FUNSXP, TRUE); /* That has evaluated promises */`
366	`if(TYPEOF(val) == CLOSXP) defenv = CLOENV(val);`	366	`if(TYPEOF(val) == CLOSXP) defenv = CLOENV(val);`
367	`else defenv = R_BaseNamespace;`	367	`else defenv = R_BaseNamespace;`
368	`/*`	368	`/*`
369	`if(defenv != ENCLOS(env)) {`	369	`if(defenv != ENCLOS(env)) {`
370	`printf("* problem *\n");`	370	`printf("* problem *\n");`
371	`PrintValue(generic);`	371	`PrintValue(generic);`
372	`PrintValue(ENCLOS(env));`	372	`PrintValue(ENCLOS(env));`
373	`}`	373	`}`
374	`*/`	374	`*/`
375		375
Line 718...	Line 718...
718	`setAttrib(s, install("previous"), klass);`	718	`setAttrib(s, install("previous"), klass);`
719	`defineVar(install(".Class"), s, m);`	719	`defineVar(install(".Class"), s, m);`
720	`/* It is possible that if a method was called directly that`	720	`/* It is possible that if a method was called directly that`
721	`'method' is unset */`	721	`'method' is unset */`
722	`if (method != R_UnboundValue) {`	722	`if (method != R_UnboundValue) {`
723	/* for Ops we need `method' to be a vector */	723	/* for Ops we need `method' to be a vector */
724	`PROTECT(method = duplicate(method));`	724	`PROTECT(method = duplicate(method));`
725	`for(j = 0; j < length(method); j++) {`	725	`for(j = 0; j < length(method); j++) {`
726	`if (strlen(CHAR(STRING_ELT(method,j))))`	726	`if (strlen(CHAR(STRING_ELT(method,j))))`
727	`SET_STRING_ELT(method, j, mkChar(buf));`	727	`SET_STRING_ELT(method, j, mkChar(buf));`
728	`}`	728	`}`
729	`} else`	729	`} else`
730	`PROTECT(method = mkString(buf));`	730	`PROTECT(method = mkString(buf));`
731	`defineVar(install(".Method"), method, m);`	731	`defineVar(install(".Method"), method, m);`
732	`defineVar(install(".GenericCallEnv"), callenv, m);`	732	`defineVar(install(".GenericCallEnv"), callenv, m);`
733	`defineVar(install(".GenericDefEnv"), defenv, m);`	733	`defineVar(install(".GenericDefEnv"), defenv, m);`
Line 1201...	Line 1201...
1201	`When called from the first the arguments have been enclosed in`	1201	`When called from the first the arguments have been enclosed in`
1202	`promises, but not from the other two: there all the arguments have`	1202	`promises, but not from the other two: there all the arguments have`
1203	`already been evaluated.`	1203	`already been evaluated.`
1204	`*/`	1204	`*/`
1205	`SEXP attribute_hidden`	1205	`SEXP attribute_hidden`
1206	`R_possible_dispatch(SEXP call, SEXP op, SEXP args, SEXP rho,`	1206	`R_possible_dispatch(SEXP call, SEXP op, SEXP args, SEXP rho,`
1207	`Rboolean promisedArgs)`	1207	`Rboolean promisedArgs)`
1208	`{`	1208	`{`
1209	`SEXP fundef, value, mlist=R_NilValue, s, a, b;`	1209	`SEXP fundef, value, mlist=R_NilValue, s, a, b;`
1210	`int offset;`	1210	`int offset;`
1211	`prim_methods_t current;`	1211	`prim_methods_t current;`
Line 1251...	Line 1251...
1251	`fundef = prim_generics[offset];`	1251	`fundef = prim_generics[offset];`
1252	`if(!fundef \|\| TYPEOF(fundef) != CLOSXP)`	1252	`if(!fundef \|\| TYPEOF(fundef) != CLOSXP)`
1253	`error(_("primitive function \"%s\" has been set for methods but no generic function supplied"),`	1253	`error(_("primitive function \"%s\" has been set for methods but no generic function supplied"),`
1254	`PRIMNAME(op));`	1254	`PRIMNAME(op));`
1255	`/* To do: arrange for the setting to be restored in case of an`	1255	`/* To do: arrange for the setting to be restored in case of an`
1256	`error in method search */`	1256	`error in method search */`
1257	`if(!promisedArgs) {`	1257	`if(!promisedArgs) {`
1258	`PROTECT(s = promiseArgs(CDR(call), rho));`	1258	`PROTECT(s = promiseArgs(CDR(call), rho));`
1259	`if (length(s) != length(args)) error(_("dispatch error"));`	1259	`if (length(s) != length(args)) error(_("dispatch error"));`
1260	`for (a = args, b = s; a != R_NilValue; a = CDR(a), b = CDR(b))`	1260	`for (a = args, b = s; a != R_NilValue; a = CDR(a), b = CDR(b))`
1261	`SET_PRVALUE(CAR(b), CAR(a));`	1261	`SET_PRVALUE(CAR(b), CAR(a));`
Line 1310...	Line 1310...
1310	`static SEXP R_packageSymbol = NULL;`	1310	`static SEXP R_packageSymbol = NULL;`
1311	`if(!s_virtual) {`	1311	`if(!s_virtual) {`
1312	`s_virtual = Rf_install("virtual");`	1312	`s_virtual = Rf_install("virtual");`
1313	`s_prototype = Rf_install("prototype");`	1313	`s_prototype = Rf_install("prototype");`
1314	`s_className = Rf_install("className");`	1314	`s_className = Rf_install("className");`
1315	`R_packageSymbol = install("package");`	1315	`R_packageSymbol = install("package");`
1316	`}`	1316	`}`
1317	`if(!class_def)`	1317	`if(!class_def)`
1318	`error(_("C level NEW macro called with null class definition pointer"));`	1318	`error(_("C level NEW macro called with null class definition pointer"));`
1319	`e = R_do_slot(class_def, s_virtual);`	1319	`e = R_do_slot(class_def, s_virtual);`
1320	`if(asLogical(e) != 0) { /* includes NA, TRUE, or anything other than FALSE */`	1320	`if(asLogical(e) != 0) { /* includes NA, TRUE, or anything other than FALSE */`
Line 1374...	Line 1374...
1374	`SEXP R_setS4Object(SEXP object, SEXP onOff)`	1374	`SEXP R_setS4Object(SEXP object, SEXP onOff)`
1375	`{`	1375	`{`
1376	`Rboolean flag = asLogical(onOff);`	1376	`Rboolean flag = asLogical(onOff);`
1377	`/* wanted return asS4(object, flag); */`	1377	`/* wanted return asS4(object, flag); */`
1378	`if(flag == IS_S4_OBJECT(object))`	1378	`if(flag == IS_S4_OBJECT(object))`
1379	`return object;`	1379	`return object;`
1380	`if(NAMED(object) == 2)`	1380	`if(NAMED(object) == 2)`
1381	`object = duplicate(object);`	1381	`object = duplicate(object);`
1382	`if(flag) SET_S4_OBJECT(object);`	1382	`if(flag) SET_S4_OBJECT(object);`
1383	`else UNSET_S4_OBJECT(object);`	1383	`else UNSET_S4_OBJECT(object);`
1384	`return object;`	1384	`return object;`
1385	`}`	1385	`}`
1386		1386
Line 1401...	Line 1401...
1401	`}`	1401	`}`
1402		1402
1403	`SEXP asS4(SEXP s, Rboolean flag)`	1403	`SEXP asS4(SEXP s, Rboolean flag)`
1404	`{`	1404	`{`
1405	`if(flag == IS_S4_OBJECT(s))`	1405	`if(flag == IS_S4_OBJECT(s))`
1406	`return s;`	1406	`return s;`
1407	`if(NAMED(s) == 2)`	1407	`if(NAMED(s) == 2)`
1408	`s = duplicate(s);`	1408	`s = duplicate(s);`
1409	`if(flag) SET_S4_OBJECT(s);`	1409	`if(flag) SET_S4_OBJECT(s);`
1410	`else UNSET_S4_OBJECT(s);`	1410	`else UNSET_S4_OBJECT(s);`
1411	`return s;`	1411	`return s;`
1412	`}`	1412	`}`

The R Project SVN R

(root)/branches/R-classInheritance/src/main/objects.c @ 77458 – Rev 44195 → 45446