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



    PROTECT(newcall = duplicate(cptr->call));
 
    class = R_data_class(obj, FALSE);
    nclass = length(class);
    for (i = 0; i < nclass; i++) {
	snprintf(buf, 512, "%s.%s", generic, CHAR(STRING_ELT(class, i)));
	method = install(buf);
	sxp = R_LookupMethod(method, rho, callrho, defrho);
	/* autoloading requires that promises be evaluated <TSL>*/
	if (TYPEOF(sxp) == PROMSXP){
	  PROTECT(tmp = eval(sxp, rho));
	  sxp = tmp;
	  UNPROTECT(1);
	}
	if (isFunction(sxp)) {
	    defineVar(install(".Generic"), mkString(generic), newrho);
	    if (i > 0) {

	    R_GlobalContext->callflag = CTXT_RETURN;
	    UNPROTECT(4);
	    return 1;
	}
    }
    snprintf(buf, 512, "%s.default", generic);
    method = install(buf);
    sxp = R_LookupMethod(method, rho, callrho, defrho);
    if (TYPEOF(sxp) == PROMSXP)
	sxp = eval(sxp, rho);
    if (isFunction(sxp)) {

/* "usemethod". Things like [ and [[ call usemethod directly, */
/* hence do_usemethod should just be an interface to usemethod. */
 
SEXP do_usemethod(SEXP call, SEXP op, SEXP args, SEXP env)
{
 
    SEXP ans, generic, obj;
    SEXP callenv, defenv;
    int nargs;
    RCNTXT *cptr;
 

    if (TYPEOF(generic) != STRSXP ||
	LENGTH(generic) < 1 ||
	strlen(CHAR(STRING_ELT(generic, 0))) == 0)
	errorcall(call, "first argument must be a generic name");
 
 
 
    if (usemethod(CHAR(STRING_ELT(generic, 0)), obj, call, CDR(args),
		  env, callenv, defenv, &ans) == 1) {
	UNPROTECT(1);
	PROTECT(ans);
	findcontext(CTXT_RETURN, env, ans);
	UNPROTECT(1);
    }
    else
	error("no applicable method for \"%s\"", CHAR(STRING_ELT(generic, 0)));
    return R_NilValue; /* NOT Used */
}
 
/*
   fixcall: fixes up the call when arguments to the function may

 
#define ARGUSED(x) LEVELS(x)
 
SEXP do_nextmethod(SEXP call, SEXP op, SEXP args, SEXP env)
{
    char buf[512], b[512], bb[512], tbuf[10];
    SEXP ans, s, t, class, method, matchedarg, generic, nextfun;
    SEXP sysp, m, formals, actuals, tmp, newcall;
    SEXP a, group, basename;
    SEXP callenv, defenv;
    RCNTXT *cptr;

 
    method = findVarInFrame3(R_GlobalContext->sysparent,install(".Method"), TRUE);
    if( method != R_UnboundValue) {
	if( !isString(method) )
	    error("Wrong value for .Method");
	for( i = 0; i < length(method); i++ ) {
	  snprintf(b, 512, "%s", CHAR(STRING_ELT(method, i)));
	  if( strlen(b) )
	    break;
	}
	/* for binary operators check that the second argument's method
	   is the same or absent */
	for(j=i;j<length(method); j++){
	  snprintf(bb, 512, "%s",CHAR(STRING_ELT(method, j)));
	  if (strlen(bb) && strcmp(b,bb))
	      warning("Incompatible methods ignored");
	}
    }
    else {
      snprintf(b, 512, "%s", CHAR(PRINTNAME(CAR(cptr->call))));
    }
 
    for (j = 0; j < length(class); j++) {
      snprintf(buf, 512, "%s.%s", CHAR(STRING_ELT(basename, 0)),
	CHAR(STRING_ELT(class, j)));
      if ( !strcmp(buf,b) )
	break;
    }
 

      j = 0;  /*no match so start with the first element of .Class */
 
    /* we need the value of i on exit from the for loop to figure out
	   how many classes to drop. */
    for (i = j ; i < length(class); i++) {
	    snprintf(buf, 512, "%s.%s", CHAR(STRING_ELT(generic, 0)),
		CHAR(STRING_ELT(class, i)));
	nextfun = R_LookupMethod(install(buf), env, callenv, defenv);
	if (TYPEOF(nextfun) == PROMSXP)
	    nextfun = eval(nextfun, env);
	if (isFunction(nextfun))
	    break;
	if (group !=R_UnboundValue){
	    /* if not Generic.foo, look for Group.foo */
	    snprintf(buf, 512, "%s.%s", CHAR(STRING_ELT(basename, 0)),
		CHAR(STRING_ELT(class, i)));
	    nextfun = R_LookupMethod(install(buf), env, callenv, defenv);
	    if (TYPEOF(nextfun) == PROMSXP)
		nextfun = eval(nextfun, env);
	    if(isFunction(nextfun))

	}
	if (isFunction(nextfun))
	    break;
    }
    if (!isFunction(nextfun)) {
	snprintf(buf, 512, "%s.default", CHAR(STRING_ELT(generic, 0)));
	nextfun = R_LookupMethod(install(buf), env, callenv, defenv);
	if (TYPEOF(nextfun) == PROMSXP)
	    nextfun = eval(nextfun, env);
	if (!isFunction(nextfun)) {
	    t = install(CHAR(STRING_ELT(generic, 0)));

Rev 25332	Rev 25628
Line 262...	Line 262...
262	`PROTECT(newcall = duplicate(cptr->call));`	262	`PROTECT(newcall = duplicate(cptr->call));`
263		263
264	`class = R_data_class(obj, FALSE);`	264	`class = R_data_class(obj, FALSE);`
265	`nclass = length(class);`	265	`nclass = length(class);`
266	`for (i = 0; i < nclass; i++) {`	266	`for (i = 0; i < nclass; i++) {`
267	`sprintf(buf, "%s.%s", generic, CHAR(STRING_ELT(class, i)));`	267	`snprintf(buf, 512, "%s.%s", generic, CHAR(STRING_ELT(class, i)));`
268	`method = install(buf);`	268	`method = install(buf);`
269	`sxp = R_LookupMethod(method, rho, callrho, defrho);`	269	`sxp = R_LookupMethod(method, rho, callrho, defrho);`
270	`/* autoloading requires that promises be evaluated <TSL>*/`	270	`/* autoloading requires that promises be evaluated <TSL>*/`
271	`if (TYPEOF(sxp)==PROMSXP){`	271	`if (TYPEOF(sxp) == PROMSXP){`
272	`PROTECT(tmp=eval(sxp, rho));`	272	`PROTECT(tmp = eval(sxp, rho));`
273	`sxp=tmp;`	273	`sxp = tmp;`
274	`UNPROTECT(1);`	274	`UNPROTECT(1);`
275	`}`	275	`}`
276	`if (isFunction(sxp)) {`	276	`if (isFunction(sxp)) {`
277	`defineVar(install(".Generic"), mkString(generic), newrho);`	277	`defineVar(install(".Generic"), mkString(generic), newrho);`
278	`if (i > 0) {`	278	`if (i > 0) {`
Line 299...	Line 299...
299	`R_GlobalContext->callflag = CTXT_RETURN;`	299	`R_GlobalContext->callflag = CTXT_RETURN;`
300	`UNPROTECT(4);`	300	`UNPROTECT(4);`
301	`return 1;`	301	`return 1;`
302	`}`	302	`}`
303	`}`	303	`}`
304	`sprintf(buf, "%s.default", generic);`	304	`snprintf(buf, 512, "%s.default", generic);`
305	`method = install(buf);`	305	`method = install(buf);`
306	`sxp = R_LookupMethod(method, rho, callrho, defrho);`	306	`sxp = R_LookupMethod(method, rho, callrho, defrho);`
307	`if (TYPEOF(sxp) == PROMSXP)`	307	`if (TYPEOF(sxp) == PROMSXP)`
308	`sxp = eval(sxp, rho);`	308	`sxp = eval(sxp, rho);`
309	`if (isFunction(sxp)) {`	309	`if (isFunction(sxp)) {`
Line 333...	Line 333...
333	`/* "usemethod". Things like [ and [[ call usemethod directly, */`	333	`/* "usemethod". Things like [ and [[ call usemethod directly, */`
334	`/* hence do_usemethod should just be an interface to usemethod. */`	334	`/* hence do_usemethod should just be an interface to usemethod. */`
335		335
336	`SEXP do_usemethod(SEXP call, SEXP op, SEXP args, SEXP env)`	336	`SEXP do_usemethod(SEXP call, SEXP op, SEXP args, SEXP env)`
337	`{`	337	`{`
338	`char buf[128];`	-
339	`SEXP ans, generic, obj;`	338	`SEXP ans, generic, obj;`
340	`SEXP callenv, defenv;`	339	`SEXP callenv, defenv;`
341	`int nargs;`	340	`int nargs;`
342	`RCNTXT *cptr;`	341	`RCNTXT *cptr;`
343		342
Line 381...	Line 380...
381	`if (TYPEOF(generic) != STRSXP \|\|`	380	`if (TYPEOF(generic) != STRSXP \|\|`
382	`LENGTH(generic) < 1 \|\|`	381	`LENGTH(generic) < 1 \|\|`
383	`strlen(CHAR(STRING_ELT(generic, 0))) == 0)`	382	`strlen(CHAR(STRING_ELT(generic, 0))) == 0)`
384	`errorcall(call, "first argument must be a generic name");`	383	`errorcall(call, "first argument must be a generic name");`
385		384
386	`strcpy(buf, CHAR(STRING_ELT(generic, 0)));`	-
387		-
388	`if (usemethod(buf, obj, call, CDR(args),`	385	`if (usemethod(CHAR(STRING_ELT(generic, 0)), obj, call, CDR(args),`
389	`env, callenv, defenv, &ans) == 1) {`	386	`env, callenv, defenv, &ans) == 1) {`
390	`UNPROTECT(1);`	387	`UNPROTECT(1);`
391	`PROTECT(ans);`	388	`PROTECT(ans);`
392	`findcontext(CTXT_RETURN, env, ans);`	389	`findcontext(CTXT_RETURN, env, ans);`
393	`UNPROTECT(1);`	390	`UNPROTECT(1);`
394	`}`	391	`}`
395	`else`	392	`else`
396	`error("no applicable method for \"%s\"", buf);`	393	`error("no applicable method for \"%s\"", CHAR(STRING_ELT(generic, 0)));`
397	`return R_NilValue; /* NOT Used */`	394	`return R_NilValue; /* NOT Used */`
398	`}`	395	`}`
399		396
400	`/*`	397	`/*`
401	`fixcall: fixes up the call when arguments to the function may`	398	`fixcall: fixes up the call when arguments to the function may`
Line 430...	Line 427...
430		427
431	`#define ARGUSED(x) LEVELS(x)`	428	`#define ARGUSED(x) LEVELS(x)`
432		429
433	`SEXP do_nextmethod(SEXP call, SEXP op, SEXP args, SEXP env)`	430	`SEXP do_nextmethod(SEXP call, SEXP op, SEXP args, SEXP env)`
434	`{`	431	`{`
435	`char buf[128], b[512], bb[512], tbuf[10];`	432	`char buf[512], b[512], bb[512], tbuf[10];`
436	`SEXP ans, s, t, class, method, matchedarg, generic, nextfun;`	433	`SEXP ans, s, t, class, method, matchedarg, generic, nextfun;`
437	`SEXP sysp, m, formals, actuals, tmp, newcall;`	434	`SEXP sysp, m, formals, actuals, tmp, newcall;`
438	`SEXP a, group, basename;`	435	`SEXP a, group, basename;`
439	`SEXP callenv, defenv;`	436	`SEXP callenv, defenv;`
440	`RCNTXT *cptr;`	437	`RCNTXT *cptr;`
Line 623...	Line 620...
623		620
624	`method = findVarInFrame3(R_GlobalContext->sysparent,install(".Method"), TRUE);`	621	`method = findVarInFrame3(R_GlobalContext->sysparent,install(".Method"), TRUE);`
625	`if( method != R_UnboundValue) {`	622	`if( method != R_UnboundValue) {`
626	`if( !isString(method) )`	623	`if( !isString(method) )`
627	`error("Wrong value for .Method");`	624	`error("Wrong value for .Method");`
628	`for( i=0; i<length(method); i++ ) {`	625	`for( i = 0; i < length(method); i++ ) {`
629	`sprintf(b,"%s", CHAR(STRING_ELT(method, i)));`	626	`snprintf(b, 512, "%s", CHAR(STRING_ELT(method, i)));`
630	`if( strlen(b) )`	627	`if( strlen(b) )`
631	`break;`	628	`break;`
632	`}`	629	`}`
633	`/* for binary operators check that the second argument's method`	630	`/* for binary operators check that the second argument's method`
634	`is the same or absent */`	631	`is the same or absent */`
635	`for(j=i;j<length(method); j++){`	632	`for(j=i;j<length(method); j++){`
636	`sprintf(bb,"%s",CHAR(STRING_ELT(method, j)));`	633	`snprintf(bb, 512, "%s",CHAR(STRING_ELT(method, j)));`
637	`if (strlen(bb) && strcmp(b,bb))`	634	`if (strlen(bb) && strcmp(b,bb))`
638	`warning("Incompatible methods ignored");`	635	`warning("Incompatible methods ignored");`
639	`}`	636	`}`
640	`}`	637	`}`
641	`else {`	638	`else {`
642	`sprintf(b,"%s", CHAR(PRINTNAME(CAR(cptr->call))));`	639	`snprintf(b, 512, "%s", CHAR(PRINTNAME(CAR(cptr->call))));`
643	`}`	640	`}`
644		641
645	`for (j = 0; j < length(class); j++) {`	642	`for (j = 0; j < length(class); j++) {`
646	`sprintf(buf,"%s.%s", CHAR(STRING_ELT(basename, 0)),`	643	`snprintf(buf, 512, "%s.%s", CHAR(STRING_ELT(basename, 0)),`
647	`CHAR(STRING_ELT(class, j)));`	644	`CHAR(STRING_ELT(class, j)));`
648	`if ( !strcmp(buf,b) )`	645	`if ( !strcmp(buf,b) )`
649	`break;`	646	`break;`
650	`}`	647	`}`
651		648
Line 655...	Line 652...
655	`j = 0; /no match so start with the first element of .Class /`	652	`j = 0; /no match so start with the first element of .Class /`
656		653
657	`/* we need the value of i on exit from the for loop to figure out`	654	`/* we need the value of i on exit from the for loop to figure out`
658	`how many classes to drop. */`	655	`how many classes to drop. */`
659	`for (i = j ; i < length(class); i++) {`	656	`for (i = j ; i < length(class); i++) {`
660	`sprintf(buf, "%s.%s", CHAR(STRING_ELT(generic, 0)),`	657	`snprintf(buf, 512, "%s.%s", CHAR(STRING_ELT(generic, 0)),`
661	`CHAR(STRING_ELT(class, i)));`	658	`CHAR(STRING_ELT(class, i)));`
662	`nextfun = R_LookupMethod(install(buf), env, callenv, defenv);`	659	`nextfun = R_LookupMethod(install(buf), env, callenv, defenv);`
663	`if (TYPEOF(nextfun) == PROMSXP)`	660	`if (TYPEOF(nextfun) == PROMSXP)`
664	`nextfun = eval(nextfun, env);`	661	`nextfun = eval(nextfun, env);`
665	`if (isFunction(nextfun))`	662	`if (isFunction(nextfun))`
666	`break;`	663	`break;`
667	`if (group !=R_UnboundValue){`	664	`if (group !=R_UnboundValue){`
668	`/* if not Generic.foo, look for Group.foo */`	665	`/* if not Generic.foo, look for Group.foo */`
669	`sprintf(buf, "%s.%s", CHAR(STRING_ELT(basename, 0)),`	666	`snprintf(buf, 512, "%s.%s", CHAR(STRING_ELT(basename, 0)),`
670	`CHAR(STRING_ELT(class, i)));`	667	`CHAR(STRING_ELT(class, i)));`
671	`nextfun = R_LookupMethod(install(buf), env, callenv, defenv);`	668	`nextfun = R_LookupMethod(install(buf), env, callenv, defenv);`
672	`if (TYPEOF(nextfun) == PROMSXP)`	669	`if (TYPEOF(nextfun) == PROMSXP)`
673	`nextfun = eval(nextfun, env);`	670	`nextfun = eval(nextfun, env);`
674	`if(isFunction(nextfun))`	671	`if(isFunction(nextfun))`
Line 676...	Line 673...
676	`}`	673	`}`
677	`if (isFunction(nextfun))`	674	`if (isFunction(nextfun))`
678	`break;`	675	`break;`
679	`}`	676	`}`
680	`if (!isFunction(nextfun)) {`	677	`if (!isFunction(nextfun)) {`
681	`sprintf(buf, "%s.default", CHAR(STRING_ELT(generic, 0)));`	678	`snprintf(buf, 512, "%s.default", CHAR(STRING_ELT(generic, 0)));`
682	`nextfun = R_LookupMethod(install(buf), env, callenv, defenv);`	679	`nextfun = R_LookupMethod(install(buf), env, callenv, defenv);`
683	`if (TYPEOF(nextfun) == PROMSXP)`	680	`if (TYPEOF(nextfun) == PROMSXP)`
684	`nextfun = eval(nextfun, env);`	681	`nextfun = eval(nextfun, env);`
685	`if (!isFunction(nextfun)) {`	682	`if (!isFunction(nextfun)) {`
686	`t = install(CHAR(STRING_ELT(generic, 0)));`	683	`t = install(CHAR(STRING_ELT(generic, 0)));`

The R Project SVN R

(root)/trunk/src/main/objects.c @ 28362 – Rev 25332 → 25628