Logo Search packages:      
Sourcecode: r-base-core-ra version File versions  Download package

eval1.c

/*  eval1.c
 *
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 1995, 1996    Robert Gentleman and Ross Ihaka
 *  Copyright (C) 1998--2006    The R Development Core Team.
 *
 *  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, a copy is available at
 *  http://www.r-project.org/Licenses/
 */

/* <UTF8> char here is either ASCII or handled as a whole */

#undef HASHING

#ifdef HAVE_CONFIG_H
# include "config.h"
#endif
#include "Defn.h"
#include "Rinterface.h"
#include "Fileio.h"
#define JIT_INTERNAL 1
#include "jit.h"
#include "printsxp.h"

/* Apply SEXP op of type CLOSXP to actuals.
   RA_TODO I believe tmp should be volatile because is
   assigned to between longjmp and setjmp.
*/

SEXP applyClosure(SEXP call, SEXP op, SEXP arglist, SEXP rho, SEXP suppliedenv)
{
    SEXP body, formals, actuals, savedrho;
    volatile SEXP newrho;
    SEXP f, a, tmp;
    RCNTXT cntxt;

    /* formals = list of formal parameters */
    /* actuals = values to be bound to formals */
    /* arglist = the tagged list of arguments */

    formals = FORMALS(op);
    body = BODY(op);
    savedrho = CLOENV(op);

    /*  Set up a context with the call in it so error has access to it */

    begincontext(&cntxt, CTXT_RETURN, call, savedrho, rho, arglist, op);

    /*  Build a list which matches the actual (unevaluated) arguments
        to the formal paramters.  Build a new environment which
        contains the matched pairs.  Ideally this environment sould be
        hashed.  */

    PROTECT(actuals = matchArgs(formals, arglist, call));
    PROTECT(newrho = NewEnvironment(formals, actuals, savedrho));

    /*  Use the default code for unbound formals.  FIXME: It looks like
        this code should preceed the building of the environment so that
        this will also go into the hash table.  */

    /* This piece of code is destructively modifying the actuals list,
       which is now also the list of bindings in the frame of newrho.
       This is one place where internal structure of environment
       bindings leaks out of envir.c.  It should be rewritten
       eventually so as not to break encapsulation of the internal
       environment layout.  We can live with it for now since it only
       happens immediately after the environment creation.  LT */

    f = formals;
    a = actuals;
    while (f != RNIL) {
        if (CAR(a) == R_MissingArg && CAR(f) != R_MissingArg) {
            SETCAR(a, mkPROMISE(CAR(f), newrho));
            SET_MISSING(a, 2);
        }
        f = CDR(f);
        a = CDR(a);
    }

    /*  Fix up any extras that were supplied by usemethod. */

    if (suppliedenv != RNIL) {
        for (tmp = FRAME(suppliedenv); tmp != RNIL; tmp = CDR(tmp)) {
            for (a = actuals; a != RNIL; a = CDR(a))
                if (TAG(a) == TAG(tmp))
                    break;
            if (a == RNIL)
                /* Use defineVar instead of earlier version that added
                   bindings manually */
                defineVar(TAG(tmp), CAR(tmp), newrho);
        }
    }

    /*  Terminate the previous context and start a new one with the
        correct environment. */

    endcontext(&cntxt);

    /*  If we have a generic function we need to use the sysparent of
        the generic as the sysparent of the method because the method
        is a straight substitution of the generic.  */

    if( R_GlobalContext->callflag == CTXT_GENERIC )
        begincontext(&cntxt, CTXT_RETURN, call,
                     newrho, R_GlobalContext->sysparent, arglist, op);
    else
        begincontext(&cntxt, CTXT_RETURN, call, newrho, rho, arglist, op);

    /* The default return value is NULL.  FIXME: Is this really needed
       or do we always get a sensible value returned?  */

    tmp = RNIL;

    /* Debugging */

    SET_DEBUG(newrho, DEBUG(op));
    if (DEBUG(op)) {
        Rprintf("debugging in: ");
        PrintValueRec(call,rho);
        /* Is the body a bare symbol (PR#6804) */
        if (!isSymbol(body) & !isVectorAtomic(body)){
                /* Find out if the body is function with only one statement. */
                if (isSymbol(CAR(body)))
                        tmp = findFun(CAR(body), rho);
                else
                        tmp = eval(CAR(body), rho);
                if((TYPEOF(tmp) == BUILTINSXP || TYPEOF(tmp) == SPECIALSXP)
                   && !strcmp( PRIMNAME(tmp), "for")
                   && !strcmp( PRIMNAME(tmp), "{")
                   && !strcmp( PRIMNAME(tmp), "repeat")
                   && !strcmp( PRIMNAME(tmp), "while")
                        )
                        goto regdb;
        }
        Rprintf("debug: ");
        PrintValue(body);
        do_browser(call, op, arglist, newrho);
    }

 regdb:

    /*  It isn't completely clear that this is the right place to do
        this, but maybe (if the matchArgs above reverses the
        arguments) it might just be perfect.

        This will not currently work as the entry points in envir.c
        are static.
    */

#ifdef  HASHING
    {
        SEXP R_NewHashTable(int);
        SEXP R_HashFrame(SEXP);
        int nargs = length(arglist);
        HASHTAB(newrho) = R_NewHashTable(nargs);
        newrho = R_HashFrame(newrho);
    }
#endif
#undef  HASHING

    jitEnterClosure(call);

    /*  Set a longjmp target which will catch any explicit returns
        from the function body.  */

    if ((SETJMP(cntxt.cjmpbuf))) {
        if (R_ReturnedValue == R_RestartToken) {
            cntxt.callflag = CTXT_RETURN;  /* turn restart off */
            R_ReturnedValue = RNIL;  /* remove restart token */
            PROTECT(tmp = eval(body, newrho));
        }
        else
            PROTECT(tmp = R_ReturnedValue);
    }
    else {
        PROTECT(tmp = eval(body, newrho));
    }
    jitExitClosure(call);
    endcontext(&cntxt);

    if (DEBUG(op)) {
        Rprintf("exiting from: ");
        PrintValueRec(call, rho);
    }
    UNPROTECT(3);
    return (tmp);
}

/* **** FIXME: This code is factored out of applyClosure.  If we keep
   **** it we should change applyClosure to run through this routine
   **** to avoid code drift. */
static SEXP R_execClosure(SEXP call, SEXP op, SEXP arglist, SEXP rho,
                          SEXP newrho)
{
    SEXP body, tmp;
    RCNTXT cntxt;

    body = BODY(op);

    begincontext(&cntxt, CTXT_RETURN, call, newrho, rho, arglist, op);

    /* The default return value is NULL.  FIXME: Is this really needed
       or do we always get a sensible value returned?  */

    tmp = RNIL;

    /* Debugging */

    SET_DEBUG(newrho, DEBUG(op));
    if (DEBUG(op)) {
        Rprintf("debugging in: ");
        PrintValueRec(call,rho);
        /* Find out if the body is function with only one statement. */
        if (isSymbol(CAR(body)))
            tmp = findFun(CAR(body), rho);
        else
            tmp = eval(CAR(body), rho);
        if((TYPEOF(tmp) == BUILTINSXP || TYPEOF(tmp) == SPECIALSXP)
           && !strcmp( PRIMNAME(tmp), "for")
           && !strcmp( PRIMNAME(tmp), "{")
           && !strcmp( PRIMNAME(tmp), "repeat")
           && !strcmp( PRIMNAME(tmp), "while")
           )
            goto regdb;
        Rprintf("debug: ");
        PrintValue(body);
        do_browser(call,op,arglist,newrho);
    }

 regdb:

    /*  It isn't completely clear that this is the right place to do
        this, but maybe (if the matchArgs above reverses the
        arguments) it might just be perfect.  */

#ifdef  HASHING
#define HASHTABLEGROWTHRATE  1.2
    {
        SEXP R_NewHashTable(int, double);
        SEXP R_HashFrame(SEXP);
        int nargs = length(arglist);
        HASHTAB(newrho) = R_NewHashTable(nargs, HASHTABLEGROWTHRATE);
        newrho = R_HashFrame(newrho);
    }
#endif
#undef  HASHING

    jitEnterClosure(call);

    /*  Set a longjmp target which will catch any explicit returns
        from the function body.  */

    if ((SETJMP(cntxt.cjmpbuf))) {
        if (R_ReturnedValue == R_RestartToken) {
            cntxt.callflag = CTXT_RETURN;  /* turn restart off */
            R_ReturnedValue = RNIL;  /* remove restart token */
            PROTECT(tmp = eval(body, newrho));
        }
        else
            PROTECT(tmp = R_ReturnedValue);
    }
    else {
        PROTECT(tmp = eval(body, newrho));
    }
    jitExitClosure(call);
    endcontext(&cntxt);

    if (DEBUG(op)) {
        Rprintf("exiting from: ");
        PrintValueRec(call, rho);
    }
    UNPROTECT(1);
    return (tmp);
}

/* **** FIXME: Temporary code to execute S4 methods in a way that
   **** preserves lexical scope. */

static SEXP R_dot_Generic = NULL;
static SEXP R_dot_Method = NULL;
static SEXP R_dot_Methods = NULL;
static SEXP R_dot_defined = NULL;
static SEXP R_dot_target = NULL;

/* called from methods_list_dispatch.c */
SEXP R_execMethod(SEXP op, SEXP rho)
{
    SEXP call, arglist, callerenv, newrho, next, val;
    RCNTXT *cptr;

    if (R_dot_Generic == NULL) {
        R_dot_Generic = install(".Generic");
        R_dot_Method = install(".Method");
        R_dot_Methods = install(".Methods");
        R_dot_defined = install(".defined");
        R_dot_target = install(".target");
    }

    /* create a new environment frame enclosed by the lexical
       environment of the method */
    PROTECT(newrho = Rf_NewEnvironment(RNIL, RNIL, CLOENV(op)));

    /* copy the bindings for the formal environment from the top frame
       of the internal environment of the generic call to the new
       frame.  need to make sure missingness information is preserved
       and the environments for any default expression promises are
       set to the new environment.  should move this to envir.c where
       it can be done more efficiently. */
    for (next = FORMALS(op); next != RNIL; next = CDR(next)) {
        SEXP symbol =  TAG(next);
        R_varloc_t loc;
        int missing;
        loc = R_findVarLocInFrame(rho,symbol);
        if(loc == NULL)
            error(_("could not find symbol \"%s\" in environment of the generic function"),
                  CHAR(PRINTNAME(symbol)));
        missing = R_GetVarLocMISSING(loc);
        val = R_GetVarLocValue(loc);
        SET_FRAME(newrho, CONS(val, FRAME(newrho)));
        SET_TAG(FRAME(newrho), symbol);
        if (missing) {
            SET_MISSING(FRAME(newrho), missing);
            if (TYPEOF(val) == PROMSXP && PRENV(val) == rho) {
                SEXP deflt;
                SET_PRENV(val, newrho);
                /* find the symbol in the method, copy its expression
                 * to the promise */
                for(deflt = CAR(op); deflt != RNIL; deflt = CDR(deflt)) {
                    if(TAG(deflt) == symbol)
                        break;
                }
                if(deflt == RNIL)
                    error(_("symbol \"%s\" not in environment of method"),
                          CHAR(PRINTNAME(symbol)));
                SET_PRCODE(val, CAR(deflt));
            }
        }
    }

    /* copy the bindings of the spacial dispatch variables in the top
       frame of the generic call to the new frame */
    defineVar(R_dot_defined, findVarInFrame(rho, R_dot_defined), newrho);
    defineVar(R_dot_Method, findVarInFrame(rho, R_dot_Method), newrho);
    defineVar(R_dot_target, findVarInFrame(rho, R_dot_target), newrho);

    /* copy the bindings for .Generic and .Methods.  We know (I think)
       that they are in the second frame, so we could use that. */
    defineVar(R_dot_Generic, findVar(R_dot_Generic, rho), newrho);
    defineVar(R_dot_Methods, findVar(R_dot_Methods, rho), newrho);

    /* Find the calling context.  Should be R_GlobalContext unless
       profiling has inserted a CTXT_BUILTIN frame. */
    cptr = R_GlobalContext;
    if (cptr->callflag & CTXT_BUILTIN)
        cptr = cptr->nextcontext;

    /* The calling environment should either be the environment of the
       generic, rho, or the environment of the caller of the generic,
       the current sysparent. */
    callerenv = cptr->sysparent; /* or rho? */

    /* get the rest of the stuff we need from the current context,
       execute the method, and return the result */
    call = cptr->call;
    arglist = cptr->promargs;
    val = R_execClosure(call, op, arglist, callerenv, newrho);
    UNPROTECT(1);
    return val;
}

SEXP EnsureLocal(SEXP symbol, SEXP rho)
{
    SEXP vl;

    if ((vl = findVarInFrame3(rho, symbol, TRUE)) != R_UnboundValue) {
        vl = eval(symbol, rho); /* for promises */
        if(NAMED(vl) == 2) {
            PROTECT(vl = duplicate(vl));
            defineVar(symbol, vl, rho);
            UNPROTECT(1);
        }
        return vl;
    }

    vl = eval(symbol, ENCLOS(rho));
    if (vl == R_UnboundValue)
        error(_("object \"%s\" not found"), CHAR(PRINTNAME(symbol)));

    PROTECT(vl = duplicate(vl));
    defineVar(symbol, vl, rho);
    UNPROTECT(1);
    SET_NAMED(vl, 1);
    return vl;
}

/* Note: If val is a language object it must be protected */
/* to prevent evaluation.  As an example consider */
/* e <- quote(f(x=1,y=2); names(e) <- c("","a","b") */

static SEXP replaceCall(SEXP fun, SEXP val, SEXP args, SEXP rhs)
{
    SEXP tmp, ptmp;
    PROTECT(fun);
    PROTECT(args);
    PROTECT(rhs);
    PROTECT(val);
    ptmp = tmp = allocList(length(args)+3);
    UNPROTECT(4);
    SETCAR(ptmp, fun); ptmp = CDR(ptmp);
    SETCAR(ptmp, val); ptmp = CDR(ptmp);
    while(args != RNIL) {
        SETCAR(ptmp, CAR(args));
        SET_TAG(ptmp, TAG(args));
        ptmp = CDR(ptmp);
        args = CDR(args);
    }
    SETCAR(ptmp, rhs);
    SET_TAG(ptmp, install("value"));
    SET_TYPEOF(tmp, LANGSXP);
    return tmp;
}


static SEXP assignCall(SEXP op, SEXP symbol, SEXP fun,
                       SEXP val, SEXP args, SEXP rhs)
{
    PROTECT(op);
    PROTECT(symbol);
    val = replaceCall(fun, val, args, rhs);
    UNPROTECT(2);
    return lang3(op, symbol, val);
}


SEXP attribute_hidden do_paren(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    checkArity(op, args);
    if (jitCompiling())
        decJitUnresolved(1);
    return CAR(args);
}


SEXP attribute_hidden do_begin(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP s = RNIL;
    if (args != RNIL) {
        if (jitCompiling())
            decJitUnresolved(1);
        while (args != RNIL) {
            if (DEBUG(rho)) {
                Rprintf("debug: ");
                PrintValue(CAR(args));
                do_browser(call,op,args,rho);
            }
            s = eval(CAR(args), rho);
            args = CDR(args);
        }
    }
    return s;
}


SEXP attribute_hidden do_return(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP a, v, vals;
    int nv = 0;

    /* We do the evaluation here so that we can tag any untagged
       return values if they are specified by symbols. */

    /* this used to crash with missing args, so keep them and check later */
    PROTECT(vals = evalListKeepMissing(args, rho));
    a = args;
    v = vals;
    while (!isNull(a)) {
        nv += 1;
        if (CAR(a) == R_DotsSymbol)
            error(_("'...' not allowed in return"));
        if (isNull(TAG(a)) && isSymbol(CAR(a)))
            SET_TAG(v, CAR(a));
        a = CDR(a);
        v = CDR(v);
    }
    switch(nv) {
    case 0:
        v = RNIL;
        break;
    case 1:
        v = CAR(vals);
        break;
    default:
        warningcall(call, _("multi-argument returns are deprecated"));
        for (v = vals; v != RNIL; v = CDR(v)) {
            if (CAR(v) == R_MissingArg)
                errorcall(call, _("empty expression in return value"));
            if (NAMED(CAR(v)))
                SETCAR(v, duplicate(CAR(v)));
        }
        v = PairToVectorList(vals);
        break;
    }
    UNPROTECT(1);

    findcontext(CTXT_BROWSER | CTXT_FUNCTION, rho, v);

    return RNIL; /*NOTREACHED*/
}


SEXP attribute_hidden do_function(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP rval;

    if (TYPEOF(op) == PROMSXP) {
        op = evalPromise(op);
        SET_NAMED(op, 2);
    }
    if (length(args) < 2)
        WrongArgCount("lambda");
    CheckFormals(CAR(args));
    rval = mkCLOSXP(CAR(args), CADR(args), rho);
    setAttrib(rval, R_SourceSymbol, CADDR(args));
    return rval;
}


/*
 *  Assignments for complex LVAL specifications. This is the stuff that
 *  nightmares are made of ...  Note that "evalseq" preprocesses the LHS
 *  of an assignment.  Given an expression, it builds a list of partial
 *  values for the exression.  For example, the assignment x$a[3] <- 10
 *  with LHS x$a[3] yields the (improper) list:
 *
 *       (eval(x$a[3])  eval(x$a)  eval(x)  .  x)
 *
 *  (Note the terminating symbol).  The partial evaluations are carried
 *  out efficiently using previously computed components.
 */

/*
  For complex superassignment  x[y==z]<<-w
  we want x required to be nonlocal, y,z, and w permitted to be local or nonlocal.
*/

static SEXP evalseq(SEXP expr, SEXP rho, int forcelocal,  R_varloc_t tmploc)
{
    SEXP val, nval, nexpr;
    if (isNull(expr))
        error(_("invalid (NULL) left side of assignment"));
    if (isSymbol(expr)) {
        PROTECT(expr);
        if(forcelocal) {
            nval = EnsureLocal(expr, rho);
        }
        else {/* now we are down to the target symbol */
          nval = eval(expr, ENCLOS(rho));
        }
        UNPROTECT(1);
        return CONS(nval, expr);
    }
    else if (isLanguage(expr)) {
        PROTECT(expr);
        PROTECT(val = evalseq(CADR(expr), rho, forcelocal, tmploc));
        R_SetVarLocValue(tmploc, CAR(val));
        PROTECT(nexpr = LCONS(R_GetVarLocSymbol(tmploc), CDDR(expr)));
        PROTECT(nexpr = LCONS(CAR(expr), nexpr));
        nval = eval(nexpr, rho);
        UNPROTECT(4);
        return CONS(nval, val);
    }
    else error(_("target of assignment expands to non-language object"));
    return RNIL;        /*NOTREACHED*/
}

/* Main entry point for complex assignments */
/* We have checked to see that CAR(args) is a LANGSXP */

static const char * const asym[] = {":=", "<-", "<<-", "="};

static void tmp_cleanup(void *data)
{
    unbindVar(R_TmpvalSymbol, (SEXP) data);
}

static SEXP applydefine(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP expr, lhs, rhs, saverhs, tmp, tmp2;
    R_varloc_t tmploc;
    char buf[32];
    RCNTXT cntxt;

    expr = CAR(args);

    /*  It's important that the rhs get evaluated first because
        assignment is right associative i.e.  a <- b <- c is parsed as
        a <- (b <- c).  */

    PROTECT(saverhs = rhs = eval(CADR(args), rho));

    /*  FIXME: We need to ensure that this works for hashed
        environments.  This code only works for unhashed ones.  the
        syntax error here is a deliberate marker so I don't forget that
        this needs to be done.  The code used in "missing" will help
        here.  */

    /*  FIXME: This strategy will not work when we are working in the
        data frame defined by the system hash table.  The structure there
        is different.  Should we special case here?  */

    /*  We need a temporary variable to hold the intermediate values
        in the computation.  For efficiency reasons we record the
        location where this variable is stored.  */

    if (rho == R_BaseNamespace)
        errorcall(call, _("cannot do complex assignments in base namespace"));
    if (rho == R_BaseEnv)
        errorcall(call, _("cannot do complex assignments in base environment"));
    defineVar(R_TmpvalSymbol, RNIL, rho);
    tmploc = R_findVarLocInFrame(rho, R_TmpvalSymbol);
    /* Now set up a context to remove it when we are done, even in the
     * case of an error.  This all helps error() provide a better call.
     */
    begincontext(&cntxt, CTXT_CCODE, call, R_BaseEnv, R_BaseEnv,
                 RNIL, RNIL);
    cntxt.cend = &tmp_cleanup;
    cntxt.cenddata = rho;

    if (jitCompiling())
        jitAllowAssign(FALSE);

    /*  Do a partial evaluation down through the LHS. */
    lhs = evalseq(CADR(expr), rho,
                  PRIMVAL(op)==1 || PRIMVAL(op)==3, tmploc);

    PROTECT(lhs);
    PROTECT(rhs); /* To get the loop right ... */
    if (jitCompiling())
        jitAllowAssign(TRUE);

    while (isLanguage(CADR(expr))) {
        if (TYPEOF(CAR(expr)) != SYMSXP)
            error(_("invalid function in complex assignment"));
        if(strlen(CHAR(PRINTNAME(CAR(expr)))) + 3 > 32)
            error(_("overlong name in '%s'"), CHAR(PRINTNAME(CAR(expr))));
        sprintf(buf, "%s<-", CHAR(PRINTNAME(CAR(expr))));
        tmp = install(buf);
        UNPROTECT(1);
        R_SetVarLocValue(tmploc, CAR(lhs));
        PROTECT(tmp2 = mkPROMISE(rhs, rho));
        SET_PRVALUE(tmp2, rhs);
        PROTECT(rhs = replaceCall(tmp, R_GetVarLocSymbol(tmploc), CDDR(expr),
                                  tmp2));
        rhs = eval(rhs, rho);
        UNPROTECT(2);
        PROTECT(rhs);
        lhs = CDR(lhs);
        expr = CADR(expr);
    }
    if (TYPEOF(CAR(expr)) != SYMSXP)
        error(_("invalid function in complex assignment"));
    if(strlen(CHAR(PRINTNAME(CAR(expr)))) + 3 > 32)
        error(_("overlong name in '%s'"), CHAR(PRINTNAME(CAR(expr))));
    sprintf(buf, "%s<-", CHAR(PRINTNAME(CAR(expr))));
    R_SetVarLocValue(tmploc, CAR(lhs));
    PROTECT(tmp = mkPROMISE(CADR(args), rho));
    SET_PRVALUE(tmp, rhs);
    PROTECT(expr = assignCall(install(asym[PRIMVAL(op)]), CDR(lhs),
                              install(buf), R_GetVarLocSymbol(tmploc),
                              CDDR(expr), tmp));
    markSubassignAsNotJittable(expr);
    expr = eval(expr, rho);
    UNPROTECT(5);
    endcontext(&cntxt); /* which does not run the remove */
    unbindVar(R_TmpvalSymbol, rho);
#ifdef CONSERVATIVE_COPYING
    return duplicate(saverhs);
#else
    /* we do not duplicate the value, so to be conservative mark the
       value as NAMED = 2 */
    SET_NAMED(saverhs, 2);
    return saverhs;
#endif
}

/* Defunct in 1.5.0
SEXP attribute_hidden do_alias(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    checkArity(op,args);
    Rprintf(".Alias is deprecated; there is no replacement \n");
    SET_NAMED(CAR(args), 0);
    return CAR(args);
}
*/

/*  Assignment in its various forms  */

SEXP attribute_hidden do_set(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP s;
    if (length(args) != 2)
        WrongArgCount(asym[PRIMVAL(op)]);
    if (isString(CAR(args)))
        SETCAR(args, install(translateChar(STRING_ELT(CAR(args), 0))));

    switch (PRIMVAL(op)) {
    case 1: case 3:                                     /* <-, = */
        if (isSymbol(CAR(args))) {
            PROTECT(s = eval(CADR(args), rho));
#ifdef CONSERVATIVE_COPYING
            if (NAMED(s))
            {
                SEXP t;
                PROTECT(s);
                t = duplicate(s);
                UNPROTECT(1);
                s = t;
            }
            PROTECT(s);
            defineVar(CAR(args), s, rho);
            UNPROTECT(1);
            SET_NAMED(s, 1);
#else
            switch (NAMED(s)) {
            case 0: SET_NAMED(s, 1); break;
            case 1: SET_NAMED(s, 2); break;
            }
            defineVar(CAR(args), s, rho);
#endif
            UNPROTECT(1);
            R_Visible = FALSE;
            return (s);
        }
        else if (isLanguage(CAR(args))) {
            R_Visible = FALSE;
            return applydefine(call, op, args, rho);
        }
        else errorcall(call,
                       _("invalid (do_set) left-hand side to assignment"));
    case 2:                                             /* <<- */
        if (isSymbol(CAR(args))) {
            s = eval(CADR(args), rho);
            if (NAMED(s))
                s = duplicate(s);
            PROTECT(s);
            setVar(CAR(args), s, ENCLOS(rho));
            UNPROTECT(1);
            SET_NAMED(s, 1);
            R_Visible = FALSE;
            return s;
        }
        else if (isLanguage(CAR(args)))
            return applydefine(call, op, args, rho);
        else error(_("invalid assignment left-hand side"));

    default:
        UNIMPLEMENTED("do_set");

    }
    return RNIL;/*NOTREACHED*/
}


/* Evaluate each expression in "el" in the environment "rho".  This is */
/* a naturally recursive algorithm, but we use the iterative form below */
/* because it is does not cause growth of the pointer protection stack, */
/* and because it is a little more efficient. */

/* called in names.c and objects.c */

/* Prior to 2.4.0 this dropped missing elements */
SEXP attribute_hidden evalList(SEXP el, SEXP rho, SEXP op)
{
    SEXP ans, h, tail, orig = el;
    int n = 1;

    PROTECT(ans = tail = CONS(RNIL, RNIL));

    while (el != RNIL) {

        /* If we have a ... symbol, we look to see what it is bound to.
         * If its binding is Null (i.e. zero length)
         *      we just ignore it and return the cdr with all its expressions evaluated;
         * if it is bound to a ... list of promises,
         *      we force all the promises and then splice
         *      the list of resulting values into the return value.
         * Anything else bound to a ... symbol is an error
        */
        if (CAR(el) == R_DotsSymbol) {
            h = findVar(CAR(el), rho);
            if (TYPEOF(h) == DOTSXP || h == RNIL) {
                while (h != RNIL) {
                    SETCDR(tail, CONS(eval(CAR(h), rho), RNIL));
                    SET_TAG(CDR(tail), CreateTag(TAG(h)));
                    tail = CDR(tail);
                    h = CDR(h);
                }
            }
            else if (h != R_MissingArg)
                error(_("'...' used in an incorrect context"));
        } else if (CAR(el) != R_MissingArg) {
            SETCDR(tail, CONS(eval(CAR(el), rho), RNIL));
            tail = CDR(tail);
            SET_TAG(tail, CreateTag(TAG(el)));
        } else { /* It was a missing element */
            SEXP line = STRING_ELT(deparse1line(orig, 0), 0);
            PROTECT(line);
            if(op == RNIL)
                error(_("element %d is empty;\n   the part of the args "
                        "list of a builtin being evaluated was:\n   %s"),
                      n, CHAR(line)+4);
            else
                error(_("element %d is empty;\n   the part of the args "
                        "list of '%s' being evaluated was:\n   %s"),
                      n, PRIMNAME(op), CHAR(line)+4);
            UNPROTECT(1);
        }
        el = CDR(el);
        n++;
    }
    UNPROTECT(1);
    return CDR(ans);
}/* evalList() */


/* A slight variation of evaluating each expression in "el" in "rho". */
/* This is a naturally recursive algorithm, but we use the iterative */
/* form below because it is does not cause growth of the pointer */
/* protection stack, and because it is a little more efficient. */

SEXP attribute_hidden evalListKeepMissing(SEXP el, SEXP rho)
{
    SEXP ans, h, tail;

    PROTECT(ans = tail = CONS(RNIL, RNIL));

    while (el != RNIL) {

        /* If we have a ... symbol, we look to see what it is bound to.
         * If its binding is Null (i.e. zero length)
         *      we just ignore it and return the cdr with all its expressions evaluated;
         * if it is bound to a ... list of promises,
         *      we force all the promises and then splice
         *      the list of resulting values into the return value.
         * Anything else bound to a ... symbol is an error
        */
        if (CAR(el) == R_DotsSymbol) {
            h = findVar(CAR(el), rho);
            if (TYPEOF(h) == DOTSXP || h == RNIL) {
                while (h != RNIL) {
                    if (CAR(h) == R_MissingArg)
                        SETCDR(tail, CONS(R_MissingArg, RNIL));
                    else
                        SETCDR(tail, CONS(eval(CAR(h), rho), RNIL));
                    SET_TAG(CDR(tail), CreateTag(TAG(h)));
                    tail = CDR(tail);
                    h = CDR(h);
                }
            }
            else if(h != R_MissingArg)
                error(_("'...' used in an incorrect context"));
        }
        else if (CAR(el) == R_MissingArg) {
            SETCDR(tail, CONS(R_MissingArg, RNIL));
            tail = CDR(tail);
            SET_TAG(tail, CreateTag(TAG(el)));
        }
        else {
            SETCDR(tail, CONS(eval(CAR(el), rho), RNIL));
            tail = CDR(tail);
            SET_TAG(tail, CreateTag(TAG(el)));
        }
        el = CDR(el);
    }
    UNPROTECT(1);
    return CDR(ans);
}


/* Create a promise to evaluate each argument.  Although this is most */
/* naturally attacked with a recursive algorithm, we use the iterative */
/* form below because it is does not cause growth of the pointer */
/* protection stack, and because it is a little more efficient. */

SEXP attribute_hidden promiseArgs(SEXP el, SEXP rho)
{
    SEXP ans, h, tail;

    PROTECT(ans = tail = CONS(RNIL, RNIL));

    while(el != RNIL) {

        /* If we have a ... symbol, we look to see what it is bound to.
         * If its binding is Null (i.e. zero length)
         * we just ignore it and return the cdr with all its
         * expressions promised; if it is bound to a ... list
         * of promises, we repromise all the promises and then splice
         * the list of resulting values into the return value.
         * Anything else bound to a ... symbol is an error
         */

        /* Is this double promise mechanism really needed? */

        if (CAR(el) == R_DotsSymbol) {
            h = findVar(CAR(el), rho);
            if (TYPEOF(h) == DOTSXP || h == RNIL) {
                while (h != RNIL) {
                    SETCDR(tail, CONS(mkPROMISE(CAR(h), rho), RNIL));
                    SET_TAG(CDR(tail), CreateTag(TAG(h)));
                    tail = CDR(tail);
                    h = CDR(h);
                }
            }
            else if (h != R_MissingArg)
                error(_("'...' used in an incorrect context"));
        }
        else if (CAR(el) == R_MissingArg) {
            SETCDR(tail, CONS(R_MissingArg, RNIL));
            tail = CDR(tail);
            SET_TAG(tail, CreateTag(TAG(el)));
        }
        else {
            SETCDR(tail, CONS(mkPROMISE(CAR(el), rho), RNIL));
            tail = CDR(tail);
            SET_TAG(tail, CreateTag(TAG(el)));
        }
        el = CDR(el);
    }
    UNPROTECT(1);
    return CDR(ans);
}


/* Check that each formal is a symbol */

/* used in coerce.c */
void attribute_hidden CheckFormals(SEXP ls)
{
    if (isList(ls)) {
        for (; ls != RNIL; ls = CDR(ls))
            if (TYPEOF(TAG(ls)) != SYMSXP)
                goto err;
        return;
    }
 err:
    error(_("invalid formal argument list for \"function\""));
}



/* "eval" and "eval.with.vis" : Evaluate the first argument */
/* in the environment specified by the second argument. */

SEXP attribute_hidden do_eval(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP encl, x, xptr;
    volatile SEXP expr, env, tmp;

    int frame;
    RCNTXT cntxt;

    checkArity(op, args);
    expr = CAR(args);
    env = CADR(args);
    encl = CADDR(args);
    if (isNull(encl)) {
        /* This is supposed to be defunct, but has been kept here
           (and documented as such */
        encl = R_BaseEnv;
    } else if ( !isEnvironment(encl) )
        error(_("invalid '%s' argument"), "enclos");
    switch(TYPEOF(env)) {
    case NILSXP:
        env = encl;     /* so eval(expr, NULL, encl) works */
    case ENVSXP:
        PROTECT(env);   /* so we can unprotect 2 at the end */
        break;
    case LISTSXP:
        env = NewEnvironment(RNIL, duplicate(CADR(args)), encl);
        PROTECT(env);
        break;
    case VECSXP:
        x = VectorToPairList(CADR(args));
        for (xptr = x ; xptr != RNIL ; xptr = CDR(xptr))
            SET_NAMED(CAR(xptr) , 2);
        env = NewEnvironment(RNIL, x, encl);
        PROTECT(env);
        break;
    case INTSXP:
    case REALSXP:
        if (length(env) != 1)
            error(_("numeric 'envir' arg not of length one"));
        frame = asInteger(env);
        if (frame == NA_INTEGER)
            error(_("invalid '%s' argument"), "envir");
        PROTECT(env = R_sysframe(frame, R_GlobalContext));
        break;
    default:
        error(_("invalid '%s' argument"), "envir");
    }

    /* isLanguage include NILSXP, and that does not need to be
       evaluated
    if (isLanguage(expr) || isSymbol(expr) || isByteCode(expr)) { */
    if (TYPEOF(expr) == LANGSXP || TYPEOF(expr) == SYMSXP || isByteCode(expr)) {
        PROTECT(expr);
        begincontext(&cntxt, CTXT_RETURN, call, env, rho, args, op);
        if (!SETJMP(cntxt.cjmpbuf))
            expr = eval(expr, env);
        else {
            expr = R_ReturnedValue;
            if (expr == R_RestartToken) {
                cntxt.callflag = CTXT_RETURN;  /* turn restart off */
                error(_("restarts not supported in 'eval'"));
            }
        }
        endcontext(&cntxt);
        UNPROTECT(1);
    }
    else if (TYPEOF(expr) == EXPRSXP) {
        int i, n;
        PROTECT(expr);
        n = LENGTH(expr);
        tmp = RNIL;
        begincontext(&cntxt, CTXT_RETURN, call, env, rho, args, op);
        if (!SETJMP(cntxt.cjmpbuf))
            for(i = 0 ; i < n ; i++)
                tmp = eval(VECTOR_ELT(expr, i), env);
        else {
            tmp = R_ReturnedValue;
            if (tmp == R_RestartToken) {
                cntxt.callflag = CTXT_RETURN;  /* turn restart off */
                error(_("restarts not supported in 'eval'"));
            }
        }
        endcontext(&cntxt);
        UNPROTECT(1);
        expr = tmp;
    }
    else if( TYPEOF(expr) == PROMSXP ) {
        expr = eval(expr, rho);
    } /* else expr is returned unchanged */
    if (PRIMVAL(op)) { /* eval.with.vis(*) : */
        PROTECT(expr);
        PROTECT(env = allocVector(VECSXP, 2));
        PROTECT(encl = allocVector(STRSXP, 2));
        SET_STRING_ELT(encl, 0, mkChar("value"));
        SET_STRING_ELT(encl, 1, mkChar("visible"));
        SET_VECTOR_ELT(env, 0, expr);
        SET_VECTOR_ELT(env, 1, ScalarLogical(R_Visible));
        setAttrib(env, R_NamesSymbol, encl);
        expr = env;
        UNPROTECT(3);
    }
    UNPROTECT(1);
    return expr;
}


SEXP attribute_hidden do_recall(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    RCNTXT *cptr;
    SEXP s, ans ;
    cptr = R_GlobalContext;
    /* get the args supplied */
    while (cptr != NULL) {
        if (cptr->callflag == CTXT_RETURN && cptr->cloenv == rho)
            break;
        cptr = cptr->nextcontext;
    }
    args = cptr->promargs;
    /* get the env recall was called from */
    s = R_GlobalContext->sysparent;
    while (cptr != NULL) {
        if (cptr->callflag == CTXT_RETURN && cptr->cloenv == s)
            break;
        cptr = cptr->nextcontext;
    }
    if (cptr == NULL)
        error(_("'Recall' called from outside a closure"));

    /* If the function has been recorded in the context, use it
       otherwise search for it by name or evaluate the expression
       originally used to get it.
    */
    if (cptr->callfun != RNIL)
        PROTECT(s = cptr->callfun);
    else if( TYPEOF(CAR(cptr->call)) == SYMSXP)
        PROTECT(s = findFun(CAR(cptr->call), cptr->sysparent));
    else
        PROTECT(s = eval(CAR(cptr->call), cptr->sysparent));
    ans = applyClosure(cptr->call, s, args, cptr->sysparent, R_BaseEnv);
    UNPROTECT(1);
    return ans;
}


static SEXP evalArgs(SEXP el, SEXP rho, SEXP op, int dropmissing)
{
    if(dropmissing) return evalList(el, rho, op);
    else return evalListKeepMissing(el, rho);
}


/* DispatchOrEval is used in internal functions which dispatch to
 * object methods (e.g. "[" or "[[").  The code either builds promises
 * and dispatches to the appropriate method, or it evaluates the
 * (unevaluated) arguments it comes in with and returns them so that
 * the generic built-in C code can continue.

 * To call this an ugly hack would be to insult all existing ugly hacks
 * at large in the world.
 */
attribute_hidden
int DispatchOrEval(SEXP call, SEXP op, const char *generic, SEXP args,
                   SEXP rho, SEXP *ans, int dropmissing, int argsevald)
{
/* DispatchOrEval is called very frequently, most often in cases where
   no dispatching is needed and the isObject or the string-based
   pre-test fail.  To avoid degrading performance it is therefore
   necessary to avoid creating promises in these cases.  The pre-test
   does require that we look at the first argument, so that needs to
   be evaluated.  The complicating factor is that the first argument
   might come in with a "..." and that there might be other arguments
   in the "..." as well.  LT */

    SEXP x = RNIL;
    int dots = FALSE, nprotect = 0;;

    if( argsevald )
        {PROTECT(x = CAR(args)); nprotect++;}
    else {
        /* Find the object to dispatch on, dropping any leading
           ... arguments with missing or empty values.  If there are no
           arguments, RNIL is used. */
        for (; args != RNIL; args = CDR(args)) {
            if (CAR(args) == R_DotsSymbol) {
                SEXP h = findVar(R_DotsSymbol, rho);
                if (TYPEOF(h) == DOTSXP) {
                    /* just a consistency check */
                    if (TYPEOF(CAR(h)) != PROMSXP)
                        error(_("value in '...' is not a promise"));
                    dots = TRUE;
                    x = eval(CAR(h), rho);
                break;
                }
                else if (h != RNIL && h != R_MissingArg)
                    error(_("'...' used in an incorrect context"));
            }
            else {
                dots = FALSE;
            x = eval(CAR(args), rho);
            break;
            }
        }
        PROTECT(x); nprotect++;
    }
        /* try to dispatch on the object */
    if( isObject(x) ) {
        char *pt;
        /* Try for formal method. */
        if(IS_S4_OBJECT(x) && R_has_methods(op)) {
            SEXP value, argValue;
            /* create a promise to pass down to applyClosure  */
            if(!argsevald) {
                argValue = promiseArgs(args, rho);
                SET_PRVALUE(CAR(argValue), x);
            } else argValue = args;
            PROTECT(argValue); nprotect++;
            /* This means S4 dispatch */
            value = R_possible_dispatch(call, op, argValue, rho, TRUE);
            if(value) {
                *ans = value;
                UNPROTECT(nprotect);
                return 1;
            }
            else {
                /* go on, with the evaluated args.  Not guaranteed to have
                   the same semantics as if the arguments were not
                   evaluated, in special cases (e.g., arg values that are
                   LANGSXP).
                   The use of the promiseArgs is supposed to prevent
                   multiple evaluation after the call to possible_dispatch.
                */
                if (dots)
                    argValue = evalArgs(argValue, rho, op, dropmissing);
                else {
                    argValue = CONS(x, evalArgs(CDR(argValue), rho, op, dropmissing));
                    SET_TAG(argValue, CreateTag(TAG(args)));
                }
                PROTECT(args = argValue); nprotect++;
                argsevald = 1;
            }
        }
        if (TYPEOF(CAR(call)) == SYMSXP)
            pt = Rf_strrchr(CHAR(PRINTNAME(CAR(call))), '.');
        else
            pt = NULL;

        if (pt == NULL || strcmp(pt,".default")) {
            RCNTXT cntxt;
            SEXP pargs;
            PROTECT(pargs = promiseArgs(args, rho)); nprotect++;
            SET_PRVALUE(CAR(pargs), x);
            begincontext(&cntxt, CTXT_RETURN, call, rho, rho, pargs, op);
            if(usemethod(generic, x, call, pargs, rho, rho, R_BaseEnv, ans))
            {
                endcontext(&cntxt);
                UNPROTECT(nprotect);
                return 1;
            }
            endcontext(&cntxt);
        }
    }
    if(!argsevald) {
        if (dots)
            /* The first call argument was ... and may contain more than the
               object, so it needs to be evaluated here.  The object should be
               in a promise, so evaluating it again should be no problem. */
            *ans = evalArgs(args, rho, op, dropmissing);
        else {
            PROTECT(*ans = CONS(x, evalArgs(CDR(args), rho, op, dropmissing)));
            SET_TAG(*ans, CreateTag(TAG(args)));
            UNPROTECT(1);
        }
    }
    else *ans = args;
    UNPROTECT(nprotect);
    return 0;
}


/* gr needs to be protected on return from this function */
static void findmethod(SEXP Class, const char *group, const char *generic,
                       SEXP *sxp,  SEXP *gr, SEXP *meth, int *which,
                       char *buf, SEXP rho)
{
    int len, whichclass;

    len = length(Class);

    /* Need to interleave looking for group and generic methods */
    /* eg if class(x) is "foo" "bar" then x>3 should invoke */
    /* "Ops.foo" rather than ">.bar" */
    for (whichclass = 0 ; whichclass < len ; whichclass++) {
        const char *ss = translateChar(STRING_ELT(Class, whichclass));
        if(strlen(generic) + strlen(ss) + 2 > 512)
            error(_("class name too long in '%s'"), generic);
        sprintf(buf, "%s.%s", generic, ss);
        *meth = install(buf);
        *sxp = R_LookupMethod(*meth, rho, rho, R_BaseEnv);
        if (isFunction(*sxp)) {
            *gr = mkString("");
            break;
        }
        if(strlen(group) + strlen(ss) + 2 > 512)
            error(_("class name too long in '%s'"), group);
        sprintf(buf, "%s.%s", group, ss);
        *meth = install(buf);
        *sxp = R_LookupMethod(*meth, rho, rho, R_BaseEnv);
        if (isFunction(*sxp)) {
            *gr = mkString(group);
            break;
        }
    }
    *which = whichclass;
}

attribute_hidden
int DispatchGroup(const char* group, SEXP call, SEXP op, SEXP args, SEXP rho,
                  SEXP *ans)
{
    int i, j, nargs, lwhich, rwhich, set;
    SEXP lclass, s, t, m, lmeth, lsxp, lgr, newrho;
    SEXP rclass, rmeth, rgr, rsxp;
    char lbuf[512], rbuf[512], generic[128], *pt;
    Rboolean useS4 = TRUE, isOps = FALSE;

    /* pre-test to avoid string computations when there is nothing to
       dispatch on because either there is only one argument and it
       isn't an object or there are two or more arguments but neither
       of the first two is an object -- both of these cases would be
       rejected by the code following the string examination code
       below */
    if (args != RNIL && ! isObject(CAR(args)) &&
        (CDR(args) == RNIL || ! isObject(CADR(args))))
        return 0;

    isOps = strcmp(group, "Ops") == 0;

    /* try for formal method */
    if(length(args) == 1 && !IS_S4_OBJECT(CAR(args))) useS4 = FALSE;
    if(length(args) == 2 &&
       !IS_S4_OBJECT(CAR(args)) && !IS_S4_OBJECT(CADR(args))) useS4 = FALSE;
    if(useS4 && R_has_methods(op)) {
        SEXP value;
        /* Remove argument names to ensure positional matching */
        if(isOps)
            for(s = args; s != RNIL; s = CDR(s)) SET_TAG(s, RNIL);

        value = R_possible_dispatch(call, op, args, rho, FALSE);
        if(value) {
            *ans = value;
            return 1;
        }
        /* else go on to look for S3 methods */
    }

    /* check whether we are processing the default method */
    if ( isSymbol(CAR(call)) ) {
        if(strlen(CHAR(PRINTNAME(CAR(call)))) >= 512)
           error(_("call name too long in '%s'"), CHAR(PRINTNAME(CAR(call))));
        sprintf(lbuf, "%s", CHAR(PRINTNAME(CAR(call))) );
        pt = strtok(lbuf, ".");
        pt = strtok(NULL, ".");

        if( pt != NULL && !strcmp(pt, "default") )
            return 0;
    }

    if(isOps)
        nargs = length(args);
    else
        nargs = 1;

    if( nargs == 1 && !isObject(CAR(args)) )
        return 0;

    if(!isObject(CAR(args)) && !isObject(CADR(args)))
        return 0;

    if(strlen(PRIMNAME(op)) >= 128)
        error(_("generic name too long in '%s'"), PRIMNAME(op));
    sprintf(generic, "%s", PRIMNAME(op) );

    lclass = getAttrib(CAR(args), R_ClassSymbol);

    if( nargs == 2 )
        rclass = getAttrib(CADR(args), R_ClassSymbol);
    else
        rclass = RNIL;

    lsxp = RNIL; lgr = RNIL; lmeth = RNIL;
    rsxp = RNIL; rgr = RNIL; rmeth = RNIL;

    findmethod(lclass, group, generic, &lsxp, &lgr, &lmeth, &lwhich,
               lbuf, rho);
    PROTECT(lgr);

    if( nargs == 2 )
        findmethod(rclass, group, generic, &rsxp, &rgr, &rmeth,
                   &rwhich, rbuf, rho);
    else
        rwhich = 0;

    PROTECT(rgr);

    if( !isFunction(lsxp) && !isFunction(rsxp) ) {
        UNPROTECT(2);
        return 0; /* no generic or group method so use default*/
    }

    if( lsxp != rsxp ) {
        if( isFunction(lsxp) && isFunction(rsxp) ) {
            warning(_("Incompatible methods (\"%s\", \"%s\") for \"%s\""),
                    CHAR(PRINTNAME(lmeth)), CHAR(PRINTNAME(rmeth)), generic);
            UNPROTECT(2);
            return 0;
        }
        /* if the right hand side is the one */
        if( !isFunction(lsxp) ) { /* copy over the righthand stuff */
            lsxp = rsxp;
            lmeth = rmeth;
            lgr = rgr;
            lclass = rclass;
            lwhich = rwhich;
            strcpy(lbuf, rbuf);
        }
    }

    /* we either have a group method or a class method */

    PROTECT(newrho = allocSExp(ENVSXP));
    PROTECT(m = allocVector(STRSXP,nargs));
    s = args;
    for (i = 0 ; i < nargs ; i++) {
        t = getAttrib(CAR(s), R_ClassSymbol);
        set = 0;
        if (isString(t)) {
            for (j = 0 ; j < length(t) ; j++) {
                if (!strcmp(translateChar(STRING_ELT(t, j)),
                            translateChar(STRING_ELT(lclass, lwhich)))) {
                    SET_STRING_ELT(m, i, mkChar(lbuf));
                    set = 1;
                    break;
                }
            }
        }
        if( !set )
            SET_STRING_ELT(m, i, R_BlankString);
        s = CDR(s);
    }

    defineVar(install(".Method"), m, newrho);
    UNPROTECT(1);
    PROTECT(t = mkString(generic));
    defineVar(install(".Generic"), t, newrho);
    UNPROTECT(1);
    defineVar(install(".Group"), lgr, newrho);
    set = length(lclass) - lwhich;
    PROTECT(t = allocVector(STRSXP, set));
    for(j = 0 ; j < set ; j++ )
        SET_STRING_ELT(t, j, duplicate(STRING_ELT(lclass, lwhich++)));
    defineVar(install(".Class"), t, newrho);
    UNPROTECT(1);
    defineVar(install(".GenericCallEnv"), rho, newrho);
    defineVar(install(".GenericDefEnv"), R_BaseEnv, newrho);

    PROTECT(t = LCONS(lmeth, CDR(call)));

    /* the arguments have been evaluated; since we are passing them */
    /* out to a closure we need to wrap them in promises so that */
    /* they get duplicated and things like missing/substitute work. */

    PROTECT(s = promiseArgs(CDR(call), rho));
    if (length(s) != length(args))
        error(_("dispatch error"));
    for (m = s ; m != RNIL ; m = CDR(m), args = CDR(args) ) {
        SET_PRVALUE(CAR(m), CAR(args));
        /* ensure positional matching for operators */
        if(isOps) SET_TAG(m, RNIL);
    }

    *ans = applyClosure(t, lsxp, s, rho, newrho);
    UNPROTECT(5);
    return 1;
}

Generated by  Doxygen 1.6.0   Back to index