The R Project SVN R

Rev

Rev 51245 | Rev 51267 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 51245 Rev 51265
Line 395... Line 395...
395 
/* This is a primitive SPECIALSXP */
 395 
/* This is a primitive SPECIALSXP */
396 
SEXP attribute_hidden do_usemethod(SEXP call, SEXP op, SEXP args, SEXP env)
 396 
SEXP attribute_hidden do_usemethod(SEXP call, SEXP op, SEXP args, SEXP env)
397 
{
 397 
{
398 
    SEXP ans, generic = R_NilValue /* -Wall */, obj, val;
 398 
    SEXP ans, generic = R_NilValue /* -Wall */, obj, val;
399 
    SEXP callenv, defenv;
 399 
    SEXP callenv, defenv;
400 
    int nargs;
 400 
    SEXP ap, argList;
401 
    RCNTXT *cptr;
 401 
    RCNTXT *cptr;
402 
 
 402 
 
- 
 
 403 
    PROTECT(ap = list2(R_NilValue, R_NilValue));
- 
 
 404 
    SET_TAG(ap,  install("generic"));
- 
 
 405 
    SET_TAG(CDR(ap), install("object"));
- 
 
 406 
    PROTECT(argList =  matchArgs(ap, args, call));
403 
    nargs = length(args);
 407 
    if (CAR(argList) == R_MissingArg)
- 
 
 408 
	errorcall(call, _("there must be a 'generic' argument"));
- 
 
 409 
    else
- 
 
 410 
	PROTECT(generic = eval(CAR(argList), env));
- 
 
 411 
    if(!isString(generic) || length(generic) != 1)
- 
 
 412 
	errorcall(call, _("'generic' argument must be a character string"));
404 
 
 413 
 
405 
    if (nargs < 0)
 - 
 
406 
	errorcall(call, _("corrupt internals!"));
 - 
 
407 
 
 414 
 
408 
    /* get environments needed for dispatching.
 415 
    /* get environments needed for dispatching.
409 
       callenv = environment from which the generic was called
 416 
       callenv = environment from which the generic was called
410 
       defenv = environment where the generic was defined */
 417 
       defenv = environment where the generic was defined */
411 
    cptr = R_GlobalContext;
 418 
    cptr = R_GlobalContext;
412 
    if ( !(cptr->callflag & CTXT_FUNCTION) || cptr->cloenv != env)
 419 
    if ( !(cptr->callflag & CTXT_FUNCTION) || cptr->cloenv != env)
413 
	errorcall(call, _("'UseMethod' used in an inappropriate fashion"));
 420 
	errorcall(call, _("'UseMethod' used in an inappropriate fashion"));
414 
    callenv = cptr->sysparent;
 421 
    callenv = cptr->sysparent;
415 
    if (nargs)
 - 
 
416 
	PROTECT(generic = eval(CAR(args), env));
 - 
 
417 
    else
 - 
 
418 
	errorcall(call, _("there must be a first argument"));
 - 
 
419 
    if(!isString(generic) || length(generic) != 1)
 - 
 
420 
	errorcall(call, _("first argument must be a character string"));
 - 
 
421 
    /* We need to find the generic to find out where it is defined.
 422 
    /* We need to find the generic to find out where it is defined.
422 
       This is set up to avoid getting caught by things like
 423 
       This is set up to avoid getting caught by things like
423 
 
 424 
 
424 
	mycoef <- function(x)
 425 
	mycoef <- function(x)
425 
       {
 426 
       {
Line 432... Line 433...
432 
    */
 433 
    */
433 
    val = findVar1(install(translateChar(STRING_ELT(generic, 0))),
 434 
    val = findVar1(install(translateChar(STRING_ELT(generic, 0))),
434 
		   ENCLOS(env), FUNSXP, TRUE); /* That has evaluated promises */
 435 
		   ENCLOS(env), FUNSXP, TRUE); /* That has evaluated promises */
435 
    if(TYPEOF(val) == CLOSXP) defenv = CLOENV(val);
 436 
    if(TYPEOF(val) == CLOSXP) defenv = CLOENV(val);
436 
    else defenv = R_BaseNamespace;
 437 
    else defenv = R_BaseNamespace;
437 
/*
 - 
 
438 
    if(defenv !=  ENCLOS(env)) {
 - 
 
439 
	printf("*** problem ***\n");
 - 
 
440 
	PrintValue(generic);
 - 
 
441 
	PrintValue(ENCLOS(env));
 - 
 
442 
    }
 - 
 
443 
*/
 - 
 
444 
 
 438 
 
445 
    if (nargs > 2)  /* R-lang says there should be a warning */
 - 
 
446 
	warningcall(call, _("arguments after the first two are ignored"));
 - 
 
447 
    if (nargs >= 2)
 439 
    if (CADR(argList) != R_MissingArg)
448 
	PROTECT(obj = eval(CADR(args), env));
 440 
	PROTECT(obj = eval(CADR(argList), env));
449 
    else {
 441 
    else {
450 
	cptr = R_GlobalContext;
 442 
	cptr = R_GlobalContext;
451 
	while (cptr != NULL) {
 443 
	while (cptr != NULL) {
452 
	    if ( (cptr->callflag & CTXT_FUNCTION) && cptr->cloenv == env)
 444 
	    if ( (cptr->callflag & CTXT_FUNCTION) && cptr->cloenv == env)
453 
		break;
 445 
		break;
454 
	    cptr = cptr->nextcontext;
 446 
	    cptr = cptr->nextcontext;
455 
	}
 447 
	}
456 
	if (cptr == NULL)
 448 
	if (cptr == NULL)
457 
	    errorcall(call, _("'UseMethod' called from outside a closure"));
 449 
	    errorcall(call, _("'UseMethod' called from outside a closure"));
458 
	/* if (generic == R_MissingArg)
 - 
 
459 
	   PROTECT(generic = mkString(CHAR(PRINTNAME(CAR(cptr->call))))); */
 - 
 
460 
	PROTECT(obj = GetObject(cptr));
 450 
	PROTECT(obj = GetObject(cptr));
461 
    }
 451 
    }
462 
 
 452 
 
463 
    if (TYPEOF(generic) != STRSXP ||
 453 
    if (TYPEOF(generic) != STRSXP ||
464 
	LENGTH(generic) < 1 ||
 454 
	LENGTH(generic) < 1 ||
465 
	CHAR(STRING_ELT(generic, 0))[0] == '\0')
 455 
	CHAR(STRING_ELT(generic, 0))[0] == '\0')
466 
	errorcall(call, _("first argument must be a generic name"));
 456 
	errorcall(call, _("first argument must be a generic name"));
467 
 
 457 
 
468 
    if (usemethod(translateChar(STRING_ELT(generic, 0)), obj, call, CDR(args),
 458 
    if (usemethod(translateChar(STRING_ELT(generic, 0)), obj, call, CDR(args),
469 
		  env, callenv, defenv, &ans) == 1) {
 459 
		  env, callenv, defenv, &ans) == 1) {
470 
	UNPROTECT(1); /* obj */
 460 
	UNPROTECT(3); /* obj, ap, argList */
471 
	PROTECT(ans);
 461 
	PROTECT(ans);
472 
	findcontext(CTXT_RETURN, env, ans); /* does not return */
 462 
	findcontext(CTXT_RETURN, env, ans); /* does not return */
473 
	UNPROTECT(1);
 - 
 
474 
    }
 463 
    }
475 
    else {
 464 
    else {
476 
	SEXP klass;
 465 
	SEXP klass;
477 
	int nclass;
 466 
	int nclass;
478 
	char cl[1000];
 467 
	char cl[1000];
Line 489... Line 478...
489 
	    }
 478 
	    }
490 
	    strcat(cl, "')");
 479 
	    strcat(cl, "')");
491 
	}
 480 
	}
492 
	errorcall(call, _("no applicable method for '%s' applied to an object of class \"%s\""),
 481 
	errorcall(call, _("no applicable method for '%s' applied to an object of class \"%s\""),
493 
		  translateChar(STRING_ELT(generic, 0)), cl);
 482 
		  translateChar(STRING_ELT(generic, 0)), cl);
494 
	UNPROTECT(1); /* NOT Used */
 - 
 
495 
    }
 483 
    }
- 
 
 484 
    /* Not reached */
496 
    return R_NilValue; /* NOT Used */
 485 
    return R_NilValue;
497 
}
 486 
}
498 
 
 487 
 
499 
/*
 488 
/*
500 
   fixcall: fixes up the call when arguments to the function may
 489 
   fixcall: fixes up the call when arguments to the function may
501 
   have changed; for now we only worry about tagged args, appending
 490 
   have changed; for now we only worry about tagged args, appending