The R Project SVN R

/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 */

/*  This module contains support for S-style generic */
/*  functions and "class" support.  Gag, barf ...  */

#include "Defn.h"

static SEXP GetObject(RCNTXT *cptr)
{
    SEXP s;
    s = CAR(cptr->promargs);
    if (TYPEOF(s) == PROMSXP) {
    if (PRVALUE(s) == R_UnboundValue) {
        s = eval(PREXPR(s), PRENV(s));
        PRVALUE(CAR(cptr->promargs)) = s;
    }
    else
        s = PRVALUE(s);
    }
    return(s);
}

static SEXP applyMethod(SEXP call, SEXP op, SEXP args, SEXP rho, SEXP newrho)
{
    SEXP ans;
    if (TYPEOF(op) == SPECIALSXP) {
    int save = R_PPStackTop;
    R_Visible = 1 - PRIMPRINT(op);
    ans = PRIMFUN(op) (call, op, args, rho);
    if (save != R_PPStackTop) {
        Rprintf("stack imbalance in %s, %d then %d\n",
            PRIMNAME(op), save, R_PPStackTop);
    }
    }
    else if (TYPEOF(op) == BUILTINSXP) {
    int save = R_PPStackTop;
    PROTECT(args = evalList(args, rho));
    R_Visible = 1 - PRIMPRINT(op);
    ans = PRIMFUN(op) (call, op, args, rho);
    UNPROTECT(1);
    if (save != R_PPStackTop) {
        Rprintf("stack imbalance in %s, %d then %d\n",
            PRIMNAME(op), save, R_PPStackTop);
    }
    }
    else if (TYPEOF(op) == CLOSXP) {
    ans = applyClosure(call, op, args, rho, newrho);
    }
    else 
    ans = R_NilValue;  /* for -Wall */
    return ans;
}


/* "newintoold" -  a destructive matching of arguments; */
/* newargs comes first; any element of oldargs with */
/* a name that matches a named newarg is deleted; the */
/* two resulting lists are appended and returned. */
/* S claims to do this (white book) but doesn't seem to. */

static SEXP newintoold(SEXP new, SEXP old)
{
    if (new == R_NilValue)
    return R_NilValue;
    CDR(new) = newintoold(CDR(new),old);
    while (old != R_NilValue) {
    if (TAG(old) != R_NilValue && TAG(old) == TAG(new)) {
        CAR(old) = CAR(new);
        return CDR(new);
    }
    old = CDR(old);
    }
    return new;
}

static SEXP matchmethargs(SEXP oldargs, SEXP newargs)
{
    newargs = newintoold(newargs, oldargs);
    return listAppend(oldargs, newargs);
}

/*  usemethod  -  calling functions need to evaluate the object
 *  (== 2nd argument).  They also need to ensure that the
 *  argument list is set up in the correct manner.
 *
 *    1. find the context for the calling function (i.e. the generic)
 *   this gives us the unevaluated arguments for the original call
 *
 *    2. create an environment for evaluating the method and insert
 *   a handful of variables (.Generic, .Class and .Method) into
 *   that environment. Also copy any variables in the env of the
 *   generic that are not formal (or actual) arguments.
 *
 *    3. fix up the argument list; it should be the arguments to the
 *   generic matched to the formals of the method to be invoked */

int usemethod(char *generic, SEXP obj, SEXP call, SEXP args,
          SEXP rho, SEXP *ans)
{
    SEXP class, method, sxp, t, s, matchedarg;
    SEXP op, formals, newrho, newcall;
    char buf[512];
    int i, j, nclass, matched;
    RCNTXT *cptr;

    /* Get the context which UseMethod was called from. */

    cptr = R_GlobalContext;
    if (cptr->callflag != CTXT_RETURN || cptr->cloenv != rho)
    error("UseMethod used in an inappropriate fashion\n");

    /* Create a new environment without any */
    /* of the formals to the generic in it. */

    PROTECT(newrho = allocSExp(ENVSXP));
    PROTECT(op = findFun(CAR(cptr->call), cptr->sysparent));
    if (TYPEOF(op) == CLOSXP) {
    formals = FORMALS(op);
    for (s = FRAME(cptr->cloenv); s != R_NilValue; s = CDR(s)) {
        matched = 0;
        for (t = formals; t != R_NilValue; t = CDR(t))
        if (TAG(t) == TAG(s))
            matched = 1;
        if (!matched)
        defineVar(TAG(s),CAR(s),newrho);
    }
    }

    PROTECT(matchedarg = cptr->promargs);
    PROTECT(newcall = duplicate(cptr->call));

    if (isObject(obj)) {
    class = getAttrib(obj, R_ClassSymbol);
    nclass = length(class);
    for (i = 0; i < nclass; i++) {
        sprintf(buf, "%s.%s", generic, CHAR(STRING(class)[i]));
        method = install(buf);
        sxp = findVar(method, rho);
        if (isFunction(sxp)) {
        defineVar(install(".Generic"), mkString(generic), newrho);
        if (i > 0) {
            PROTECT(t = allocVector(STRSXP, nclass - i));
            for (j = 0; j < length(t); j++, i++)
            STRING(t)[j] = STRING(class)[i];
            setAttrib(t, install("previous"), class);
            defineVar(install(".Class"), t, newrho);
            UNPROTECT(1);
        }
        else
            defineVar(install(".Class"), class, newrho);
        PROTECT(t = mkString(buf));
        defineVar(install(".Method"), t, newrho);
        UNPROTECT(1);
        t = newcall;
        CAR(t) = method;
        R_GlobalContext->callflag = CTXT_GENERIC;
        *ans = applyMethod(t, sxp, matchedarg, rho, newrho);
        R_GlobalContext->callflag = CTXT_RETURN;
        UNPROTECT(4);
        return 1;
        }
    }
    }
    sprintf(buf, "%s.default", generic);
    method = install(buf);
    sxp = findVar(method, rho);
    if (isFunction(sxp)) {
    defineVar(install(".Generic"), mkString(generic), newrho);
    defineVar(install(".Class"), R_NilValue, newrho);
    PROTECT(t = mkString(buf));
    defineVar(install(".Method"), t, newrho);
    UNPROTECT(1);
    t = newcall;
    CAR(t) = method;
    R_GlobalContext->callflag = CTXT_GENERIC;
    *ans = applyMethod(t, sxp, matchedarg, rho, newrho);
    R_GlobalContext->callflag = CTXT_RETURN;
    UNPROTECT(4);
    return 1;
    }
    UNPROTECT(4);
    cptr->callflag = CTXT_RETURN;
    return 0;
}

/* Note: "do_usemethod" is not the only entry point to */
/* "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)
{
    char buf[128];
    SEXP ans, meth, obj;
    int nargs;
    RCNTXT *cptr;

    nargs = length(args);

if (nargs < 0)
    errorcall(call, "corrupt internals!\n");

    if (nargs)
    PROTECT(meth = eval(CAR(args), env));
    else
    meth = R_MissingArg;

    if (nargs >= 2)
    PROTECT(obj = eval(CADR(args), env));
    else {
    cptr = R_GlobalContext;
    while (cptr != NULL) {
        if (cptr->callflag == CTXT_RETURN && cptr->cloenv == env)
        break;
        cptr = cptr->nextcontext;
    }
    if (cptr == NULL)
        error("UseMethod called from outside a closure\n");
    if (meth == R_MissingArg)
        PROTECT(meth = mkString(CHAR(PRINTNAME(CAR(cptr->call)))));
    PROTECT(obj = GetObject(cptr));
    }

    if (TYPEOF(meth) != STRSXP ||
    LENGTH(meth) < 1 ||
    strlen(CHAR(STRING(meth)[0])) == 0)
    errorcall(call, "first argument must be a method name\n");

    strcpy(buf, CHAR(STRING(meth)[0]));

    if (usemethod(buf, obj, call, CDR(args), env, &ans) == 1) {
    UNPROTECT(1);
    findcontext(CTXT_RETURN, env, ans);
    }
    else
    error("no applicable method for \"%s\"\n", buf);
    return R_NilValue; /* NOT Used */
}

/* If NextMethod has any arguments the first must be the generic */
/* the second the object and any remaining are matched with the */
/* formals of the chosen method. */

#define ARGUSED(x) LEVELS(x)

SEXP do_nextmethod(SEXP call, SEXP op, SEXP args, SEXP env)
{
    char buf[128];
    SEXP ans, s, t, class, method, matchedarg, generic, nextfun;
    SEXP sysp, m, formals, actuals, tmp, newcall;
    RCNTXT *cptr;
    int i,j;
    SEXP group,realgroup;

    cptr = R_GlobalContext;

    cptr->callflag = CTXT_GENERIC;

    /* get the env NextMethod was called from */
    sysp = R_GlobalContext->sysparent;
    while (cptr != NULL) {
    if (cptr->callflag == CTXT_RETURN && cptr->cloenv == sysp)
        break;
    cptr = cptr->nextcontext;
    }
    if (cptr == NULL)
    error("NextMethod called from outside a closure\n");

    PROTECT(newcall = duplicate(cptr->call));

    /* set up the arglist */
    s = findFun(CAR(cptr->call), cptr->sysparent);
    if (TYPEOF(s) != CLOSXP)
    errorcall(cptr->call, "function is not a closure\n");
    formals = FORMALS(s);
    actuals = matchArgs(formals, cptr->promargs);

    /* we can't duplicate because it would force the promises */
    /* so we do our own duplication of the promargs */
    PROTECT(matchedarg = allocList(length(cptr->promargs)));
    for (t = matchedarg, s = cptr->promargs; t != R_NilValue;
     t = CDR(t), s = CDR(s)) {
    CAR(t) = CAR(s);
    TAG(t) = TAG(s);
    }
    for (s = formals; s != R_NilValue; s = CDR(s))
    ARGUSED(s) = 0;
    for (t = matchedarg; t != R_NilValue; t = CDR(t)) {
    for (m = actuals, s = formals; m != R_NilValue; m = CDR(m), s = CDR(s))
        if ((CAR(m) == CAR(t)) && !ARGUSED(s)) {
        ARGUSED(s) = 1;
        if (CAR(m) == R_MissingArg) {
            tmp = findVarInFrame(FRAME(cptr->cloenv), TAG(s));
            if (tmp == R_MissingArg)
            break;
        }
        CAR(t) = mkPROMISE(TAG(s), cptr->cloenv);
        break;
        }
    }
    /*
      Now see if there were any other arguments passed in

      .Class is used to determine the next method; if it doesn't
      exist the first argument to the current method is used
      the second argument to NextMethod is another option but
      isn't currently used).
    */
    s = CADDR(args); /* this is ... and we need to see if it's bound */
    if (s == R_DotsSymbol) {
    t = findVarInFrame(FRAME(env), s);
    if (t != R_NilValue && t != R_MissingArg) {
        TYPEOF(t) = LISTSXP; /* a safe mutation */
        s = matchmethargs(matchedarg,t);
        UNPROTECT(1);
        PROTECT(matchedarg = s);
    }
    }
    else
    errorcall(call,"wrong argument ...\n");

    class = dynamicfindVar(install(".Class"), R_GlobalContext);

    if (class == R_UnboundValue) {
    s = GetObject(cptr);
    if (!isObject(s))
        errorcall(call, "object not specified\n");
    class = getAttrib(s, R_ClassSymbol);
    }

    generic = eval(CAR(args), env);
    if (generic == R_NilValue) {
    generic = dynamicfindVar(install(".Generic"), R_GlobalContext);
    if (generic == R_UnboundValue)
        generic = mkString(CHAR(PRINTNAME(CAR(cptr->call))));
    }
    PROTECT(generic);

    if (!isString(generic) || length(generic) > 1)
    errorcall(call,"invalid generic argument to NextMethod\n");
    if (strlen(CHAR(STRING(generic)[0])) == 0)
    errorcall(call,"generic function not specified\n");

    group = dynamicfindVar(install(".Group"), R_GlobalContext);
    PROTECT(realgroup = duplicate(group));
    if (group == R_UnboundValue){
    group = generic;
    realgroup = mkString("");
    }
    if (!isString(group) || length(group) > 1)
    errorcall(call, "invalid group argument found in NextMethod\n");
    if (strlen(CHAR(STRING(group)[0])) == 0)
    group = generic;

    /* we need the value of i on exit from the for loop to figure out
       how many classes to drop
    */

    nextfun = R_NilValue;
    /* jump over the current call */
    t = CAR(cptr->call);
    for (j = 0; j < length(class); j++) {
    sprintf(buf,"%s.%s", CHAR(STRING(group)[0]),
        CHAR(STRING(class)[j]));
    if (install(buf) == t)
        break;
    sprintf(buf,"%s.%s",CHAR(STRING(generic)[0]),
        CHAR(STRING(class)[j]));
    if (install(buf) == t)
        break;
    }

    for (i = j + 1; i < length(class); i++) {
    sprintf(buf, "%s.%s", CHAR(STRING(generic)[0]),
        CHAR(STRING(class)[i]));
    nextfun = findVar(install(buf),env);
    if (isFunction(nextfun))
        break;
    sprintf(buf,"%s.%s",CHAR(STRING(group)[0]),
        CHAR(STRING(class)[i]));
    nextfun = findVar(install(buf), env);
    if (isFunction(nextfun))
        break;
    }
    if (!isFunction(nextfun)) {
    sprintf(buf, "%s.default", CHAR(STRING(generic)[0]));
    nextfun = findVar(install(buf), env);
    if (!isFunction(nextfun)) {
        t = install(CHAR(STRING(generic)[0]));
        nextfun = findVar(t,env);
        if (!isFunction(nextfun))
        error("No method to invoke\n");
        if (TYPEOF(nextfun) == CLOSXP) {
        if (INTERNAL(t) != R_NilValue)
            nextfun = INTERNAL(t);
        else
            error("No method to invoke\n");
        }
    }
    }
    PROTECT(s = allocVector(STRSXP, length(class) - i));
    PROTECT(class = duplicate(class));
    PROTECT(m = allocSExp(ENVSXP));
    for (j = 0; j < length(s); j++)
    STRING(s)[j] = duplicate(STRING(class)[i++]);
    setAttrib(s, install("previous"), class);
    defineVar(install(".Class"), s, m);
    PROTECT(method = mkString(buf));
    defineVar(install(".Method"), method, m);
    method = install(buf);

    defineVar(install(".Generic"), generic, m);

    defineVar(install(".Group"), realgroup, m);

    CAR(newcall) = method;
    ans = applyMethod(newcall, nextfun, matchedarg, env, m);
    UNPROTECT(7);
    UNPROTECT(1);
    return(ans);
}

SEXP do_unclass(SEXP call, SEXP op, SEXP args, SEXP env)
{
    checkArity(op, args);
    if (isObject(CAR(args))) {
    CAR(args) = duplicate(CAR(args));
    setAttrib(CAR(args), R_ClassSymbol, R_NilValue);
    }
    return CAR(args);
}

/* InheritsClass  -  does an object inherit from a class */

int InheritsClass(SEXP x, char *name)
{
    SEXP class;
    int i, nclass;
    if (isObject(x)) {
    class = getAttrib(x, R_ClassSymbol);
    nclass = length(class);
    for (i = 0; i < nclass; i++)
        if (!strcmp(CHAR(STRING(class)[i]), name))
        return 1;
    }
    return 0;
}

void RemoveClass(SEXP x, char *name)
{
    SEXP class, newclass;
    int i, j, nclass, nmatch;

    if (isObject(x)) {
    PROTECT(x);
    class = getAttrib(x, R_ClassSymbol);
    nclass = length(class);
    nmatch = 0;
    for (i = 0; i < nclass; i++)
        if (!strcmp(CHAR(STRING(class)[i]), name))
        nmatch++;
    if (nmatch == nclass) {
        setAttrib(x, R_ClassSymbol, R_NilValue);
    }
    else if (nmatch > 0) {
        PROTECT(newclass = allocVector(STRSXP, nclass-nmatch));
        for (i = 0, j = 0; i < nclass; i++)
        if (strcmp(CHAR(STRING(class)[i]), name)) {
            STRING(newclass)[j++] = STRING(class)[i];
        }
        setAttrib(x, R_ClassSymbol, newclass);
        UNPROTECT(1);
    }
    UNPROTECT(1);
    }
}