The R Project SVN R

/*

 *  R : A Computer Language for Statistical Data Analysis

 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka

 *  Copyright (C) 2002-2017  The R Foundation

 *  Copyright (C) 1999-2018  The R 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, 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

 *  https://www.R-project.org/Licenses/

 */

/*  This module contains support for S-style generic */

/*  functions and "class" support.  Gag, barf ...  */

#ifdef HAVE_CONFIG_H

#include <config.h>

#endif

#define R_USE_SIGNALS 1

#include <Defn.h>

#include <Internal.h>

#include <R_ext/RS.h> /* for Calloc, Realloc and for S4 object bit */

static SEXP GetObject(RCNTXT *cptr)

{

    SEXP s, b, formals, tag;

    b = cptr->callfun;

    if (TYPEOF(b) != CLOSXP) error(_("generic 'function' is not a function"));

    formals = FORMALS(b);

    tag = TAG(formals);

    if (tag != R_NilValue && tag != R_DotsSymbol) {

	s = NULL;

	/** exact matches **/

	for (b = cptr->promargs ; b != R_NilValue ; b = CDR(b))

	    if (TAG(b) != R_NilValue && pmatch(tag, TAG(b), 1)) {

		if (s != NULL)

		    error(_("formal argument \"%s\" matched by multiple actual arguments"), tag);

		else

		    s = CAR(b);

	    }

	if (s == NULL)

	    /** partial matches **/

	    for (b = cptr->promargs ; b != R_NilValue ; b = CDR(b))

		if (TAG(b) != R_NilValue && pmatch(tag, TAG(b), 0)) {

		    if ( s != NULL)

			error(_("formal argument \"%s\" matched by multiple actual arguments"), tag);

		    else

			s = CAR(b);

		}

	if (s == NULL)

	    /** first untagged argument **/

	    for (b = cptr->promargs ; b != R_NilValue ; b = CDR(b))

		if (TAG(b) == R_NilValue )

		{

		    s = CAR(b);

		    break;

		}

	if (s == NULL)

	    s = CAR(cptr->promargs);

/*

	    error("failed to match argument for dispatch");

*/

    }

    else

	s = CAR(cptr->promargs);

    if (TYPEOF(s) == PROMSXP) {

	if (PRVALUE(s) == R_UnboundValue)

	    s = eval(s, R_BaseEnv);

	else

	    s = PRVALUE(s);

    }

    return(s);

}

static SEXP applyMethod(SEXP call, SEXP op, SEXP args, SEXP rho, SEXP newvars)

{

    SEXP ans;

    if (TYPEOF(op) == SPECIALSXP) {

	int save = R_PPStackTop, flag = PRIMPRINT(op);

	const void *vmax = vmaxget();

	R_Visible = flag != 1;

	ans = PRIMFUN(op) (call, op, args, rho);

	if (flag < 2) R_Visible = flag != 1;

	check_stack_balance(op, save);

	vmaxset(vmax);

    }

    /* In other places we add a context to builtins when profiling,

       but we have not bothered here (as there seem to be no primitives

       used as methods, and this would have to be a primitive to be

       found).

     */

    else if (TYPEOF(op) == BUILTINSXP) {

	int save = R_PPStackTop, flag = PRIMPRINT(op);

	const void *vmax = vmaxget();

	PROTECT(args = evalList(args, rho, call, 0));

	R_Visible = flag != 1;

	ans = PRIMFUN(op) (call, op, args, rho);

	if (flag < 2) R_Visible = flag != 1;

	UNPROTECT(1);

	check_stack_balance(op, save);

	vmaxset(vmax);

    }

    else if (TYPEOF(op) == CLOSXP) {

	ans = applyClosure(call, op, args, rho, newvars);

    }

    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;

    SETCDR(_new, newintoold(CDR(_new),old));

    while (old != R_NilValue) {

	if (TAG(old) != R_NilValue && TAG(old) == TAG(_new)) {

	    SETCAR(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);

}

/* R_MethodsNamespace is initialized to R_GlobalEnv when R is

   initialized.  If it set to the methods namespace when the latter is

   loaded, and back to R_GlobalEnv when it is unloaded. */

#ifdef S3_for_S4_warn /* not currently used */

static SEXP s_check_S3_for_S4 = NULL;

void R_warn_S3_for_S4(SEXP method) {

  SEXP call;

  if(!s_check_S3_for_S4)

    s_check_S3_for_S4 = install(".checkS3forS4");

  PROTECT(call = lang2(s_check_S3_for_S4, method));

  eval(call, R_MethodsNamespace);

  UNPROTECT(1);

}

#endif

static SEXP findFunInEnvRange(SEXP symbol, SEXP rho, SEXP target)

{

    SEXP vl;

    while(rho != R_EmptyEnv) {

	vl = findVarInFrame3(rho, symbol, TRUE);

	if (vl != R_UnboundValue) {

	    if (TYPEOF(vl) == PROMSXP) {

		PROTECT(vl);

		vl = eval(vl, rho);

		UNPROTECT(1);

	    }

	    if ((TYPEOF(vl) == CLOSXP ||

		 TYPEOF(vl) == BUILTINSXP ||

		 TYPEOF(vl) == SPECIALSXP))

		return (vl);

	}

	if(rho == target)

	    return (R_UnboundValue);

	else

	    rho = ENCLOS(rho);

    }

    return (R_UnboundValue);

}

static SEXP findFunWithBaseEnvAfterGlobalEnv(SEXP symbol, SEXP rho)

{

    SEXP vl;

    while(rho != R_EmptyEnv) {

	vl = findVarInFrame3(rho, symbol, TRUE);

	if (vl != R_UnboundValue) {

	    if (TYPEOF(vl) == PROMSXP) {

		PROTECT(vl);

		vl = eval(vl, rho);

		UNPROTECT(1);

	    }

	    if ((TYPEOF(vl) == CLOSXP ||

		 TYPEOF(vl) == BUILTINSXP ||

		 TYPEOF(vl) == SPECIALSXP))

		return (vl);

	}

	if(rho == R_GlobalEnv)

	    rho = R_BaseEnv;

	else

	    rho = ENCLOS(rho);

    }

    return (R_UnboundValue);

}

/*  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 */

attribute_hidden

SEXP R_LookupMethod(SEXP method, SEXP rho, SEXP callrho, SEXP defrho)

{

    SEXP val, top = R_NilValue;	/* -Wall */

    static SEXP s_S3MethodsTable = NULL;

    static int lookup_baseenv_after_globalenv = -1;

    static int lookup_report_search_path_uses = -1;

    char *lookup;

    PROTECT_INDEX validx;

    if (TYPEOF(callrho) != ENVSXP) {

	if (TYPEOF(callrho) == NILSXP)

	    error(_("use of NULL environment is defunct"));

	else

	    error(_("bad generic call environment"));

    }

    if (defrho == R_BaseEnv)

	defrho = R_BaseNamespace;

    else if (TYPEOF(defrho) != ENVSXP) {

	if (TYPEOF(defrho) == NILSXP)

	    error(_("use of NULL environment is defunct"));

	else

	    error(_("bad generic definition environment"));

    }

    if(lookup_baseenv_after_globalenv == -1) {

	lookup = getenv("_R_S3_METHOD_LOOKUP_BASEENV_AFTER_GLOBALENV_");

	lookup_baseenv_after_globalenv = 

	    ((lookup != NULL) && StringFalse(lookup)) ? 0 : 1;

    }

    if(lookup_report_search_path_uses == -1) {

	lookup = getenv("_R_S3_METHOD_LOOKUP_REPORT_SEARCH_PATH_USES_");

	lookup_report_search_path_uses = 

	    ((lookup != NULL) && StringTrue(lookup)) ? 1 : 0;

    }

    /* This evaluates promises */

    PROTECT(top = topenv(R_NilValue, callrho));

    val = findFunInEnvRange(method, callrho, top);

    if(val != R_UnboundValue) {

	UNPROTECT(1); /* top */

	return val;

    }

    PROTECT_WITH_INDEX(val, &validx);

    /* We assume here that no one registered a non-function */

    if (!s_S3MethodsTable)

	s_S3MethodsTable = install(".__S3MethodsTable__.");

    SEXP table = findVarInFrame3(defrho, s_S3MethodsTable, TRUE);

    if (TYPEOF(table) == PROMSXP) {

	PROTECT(table);

	table = eval(table, R_BaseEnv);

	UNPROTECT(1); /* table */

    }

    if (TYPEOF(table) == ENVSXP) {

	PROTECT(table);

	REPROTECT(val = findVarInFrame3(table, method, TRUE), validx);

	UNPROTECT(1); /* table */

	if (TYPEOF(val) == PROMSXP) 

	    REPROTECT(val = eval(val, rho), validx);

	if(val != R_UnboundValue) {

	    UNPROTECT(2); /* top, val */

	    return val;

	}

    } 

    if(lookup_baseenv_after_globalenv) {

	if (top == R_GlobalEnv)

	    top = R_BaseEnv;

	else

	    top = ENCLOS(top);

	REPROTECT(val = findFunWithBaseEnvAfterGlobalEnv(method, top),

	          validx);

    }

    else if(lookup_report_search_path_uses) {

	if(top != R_GlobalEnv) 

	    REPROTECT(val = findFunInEnvRange(method, ENCLOS(top),

	                                      R_GlobalEnv), validx);

	if(val == R_UnboundValue) {

	    REPROTECT(val = findFunInEnvRange(method, ENCLOS(R_GlobalEnv),

	                                      R_EmptyEnv), validx);

	    if((val != R_UnboundValue) && 

	       (CLOENV(val) != R_BaseNamespace) &&

	       (CLOENV(val) != R_BaseEnv)) {

		/* Note that we do not really know where on the search

		   path we found the method. */

		REprintf("S3 method lookup found '%s' on search path \n",

			 CHAR(PRINTNAME(method)));

	    }

	}

    }

    else

	REPROTECT(val = findFunInEnvRange(method, ENCLOS(top), R_EmptyEnv),

	          validx);

    UNPROTECT(2); /* top, val */

    return val;

}

#ifdef UNUSED

static int match_to_obj(SEXP arg, SEXP obj) {

  return (arg == obj) ||

    (TYPEOF(arg) == PROMSXP && PRVALUE(arg) == obj);

}

#endif

/* look up the class name in the methods package table of S3 classes

   which should be explicitly converted when an S3 method is applied

   to an object from an S4 subclass.

*/

int isBasicClass(const char *ss) {

    static SEXP s_S3table = NULL;

    if(!s_S3table) {

      s_S3table = findVarInFrame3(R_MethodsNamespace, install(".S3MethodsClasses"), TRUE);

      if(s_S3table == R_UnboundValue)

	error(_("no '.S3MethodsClass' table, cannot use S4 objects with S3 methods ('methods' package not attached?)"));

      if (TYPEOF(s_S3table) == PROMSXP)  /* findVar... ignores lazy data */

	s_S3table = eval(s_S3table, R_MethodsNamespace);

    }

    if(s_S3table == R_UnboundValue)

      return FALSE; /* too screwed up to do conversions */

    return findVarInFrame3(s_S3table, install(ss), FALSE) != R_UnboundValue;

}

/* Note that ./attrib.c 's S4_extends() has an alternative

   'sanity check for methods package available' */

Rboolean R_has_methods_attached(void) {

    return(

	isMethodsDispatchOn() &&

	// based on unlockBinding() in ../library/methods/R/zzz.R  {since 2003}:

	!R_BindingIsLocked(install(".BasicFunsList"), R_MethodsNamespace));

}

static R_INLINE

SEXP addS3Var(SEXP vars, SEXP name, SEXP value) {

    SEXP res = CONS(value, vars);

    SET_TAG(res, name);

    return res;

}

attribute_hidden

SEXP createS3Vars(SEXP dotGeneric, SEXP dotGroup, SEXP dotClass, SEXP dotMethod,

		  SEXP dotGenericCallEnv, SEXP dotGenericDefEnv) {

    SEXP v = R_NilValue;

    v = addS3Var(v, R_dot_GenericDefEnv, dotGenericDefEnv);

    v = addS3Var(v, R_dot_GenericCallEnv, dotGenericCallEnv);

    v = addS3Var(v, R_dot_Group, dotGroup);

    v = addS3Var(v, R_dot_Method, dotMethod);

    v = addS3Var(v, R_dot_Class, dotClass);

    v = addS3Var(v, R_dot_Generic, dotGeneric);

    return v;

}

static

SEXP dispatchMethod(SEXP op, SEXP sxp, SEXP dotClass, RCNTXT *cptr, SEXP method,

		    const char *generic, SEXP rho, SEXP callrho, SEXP defrho) {

    SEXP newvars = PROTECT(createS3Vars(

	PROTECT(mkString(generic)),

	R_BlankScalarString,

	dotClass,

	PROTECT(ScalarString(PRINTNAME(method))),

	callrho,

	defrho

    ));

    /* Create a new environment without any */

    /* of the formals to the generic in it. */

    if (TYPEOF(op) == CLOSXP) {

	SEXP formals = FORMALS(op);

	SEXP s, t;

	int matched;

	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;

		    break;

		}

	    if (!matched) {

		UNPROTECT(1); /* newvars */

		newvars = PROTECT(CONS(CAR(s), newvars));

		SET_TAG(newvars, TAG(s));

	    }

	}

    }

    /* Debug a method when debugging the generic. When called via UseMethod or

       NextMethod, RSTEP(op) will always be zero because the bit is cleared by

       applyClosure. We thus approximate and enter the debugger also when

       RDEBUG(rho) is set. */

    if ((RDEBUG(op) && R_current_debug_state()) || RSTEP(op) || RDEBUG(rho))

	SET_RSTEP(sxp, 1);

    SEXP newcall =  PROTECT(shallow_duplicate(cptr->call));

    SETCAR(newcall, method);

    R_GlobalContext->callflag = CTXT_GENERIC;

    SEXP matchedarg = PROTECT(cptr->promargs); /* ? is this PROTECT needed ? */

    SEXP ans = applyMethod(newcall, sxp, matchedarg, rho, newvars);

    R_GlobalContext->callflag = CTXT_RETURN;

    UNPROTECT(5); /* "generic,method", newvars, newcall, matchedarg */

    return ans;

}

attribute_hidden

int usemethod(const char *generic, SEXP obj, SEXP call, SEXP args,

	      SEXP rho, SEXP callrho, SEXP defrho, SEXP *ans)

{

    SEXP klass, method, sxp;

    SEXP op;

    int i, nclass;

    RCNTXT *cptr;

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

    cptr = R_GlobalContext;

    op = cptr->callfun;

    PROTECT(klass = R_data_class2(obj));

    nclass = length(klass);

    for (i = 0; i < nclass; i++) {

	const void *vmax = vmaxget();

	const char *ss = translateChar(STRING_ELT(klass, i));

	method = installS3Signature(generic, ss);

	vmaxset(vmax);

	sxp = R_LookupMethod(method, rho, callrho, defrho);

	if (isFunction(sxp)) {

	    if(method == R_SortListSymbol && CLOENV(sxp) == R_BaseNamespace)

		continue; /* kludge because sort.list is not a method */

	    PROTECT(sxp);

	    if (i > 0) {

		SEXP dotClass = PROTECT(stringSuffix(klass, i));

		setAttrib(dotClass, R_PreviousSymbol, klass);

		*ans = dispatchMethod(op, sxp, dotClass, cptr, method, generic,

				      rho, callrho, defrho);

		UNPROTECT(1); /* dotClass */

	    } else {

		*ans = dispatchMethod(op, sxp, klass, cptr, method, generic,

				      rho, callrho, defrho);

	    }

	    UNPROTECT(2); /* klass, sxp */

	    return 1;

	}

    }

    method = installS3Signature(generic, "default");

    PROTECT(sxp = R_LookupMethod(method, rho, callrho, defrho));

    if (isFunction(sxp)) {

	*ans = dispatchMethod(op, sxp, R_NilValue, cptr, method, generic,

			      rho, callrho, defrho);

	UNPROTECT(2); /* klass, sxp */

	return 1;

    }

    UNPROTECT(2); /* klass, sxp */

    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.

*/

/* This is a primitive SPECIALSXP */

SEXP attribute_hidden NORET do_usemethod(SEXP call, SEXP op, SEXP args, SEXP env)

{

    SEXP ans, generic = R_NilValue /* -Wall */, obj, val;

    SEXP callenv, defenv;

    SEXP argList;

    RCNTXT *cptr;

    static SEXP do_usemethod_formals = NULL;

    static int lookup_use_topenv_as_defenv = -1;

    char *lookup;

    if (do_usemethod_formals == NULL)

	do_usemethod_formals = allocFormalsList2(install("generic"),

						 install("object"));

    PROTECT(argList = matchArgs_NR(do_usemethod_formals, args, call));

    if (CAR(argList) == R_MissingArg)

	errorcall(call, _("there must be a 'generic' argument"));

    else

	PROTECT(generic = eval(CAR(argList), env));

    if(!isString(generic) || LENGTH(generic) != 1)

	errorcall(call, _("'generic' argument must be a character string"));

    if(lookup_use_topenv_as_defenv == -1) {

	lookup = getenv("_R_S3_METHOD_LOOKUP_USE_TOPENV_AS_DEFENV_");

	lookup_use_topenv_as_defenv = 

	    ((lookup != NULL) && StringFalse(lookup)) ? 0 : 1;

    }

    /* get environments needed for dispatching.

       callenv = environment from which the generic was called

       defenv = environment where the generic was defined */

    cptr = R_GlobalContext;

    if ( !(cptr->callflag & CTXT_FUNCTION) || cptr->cloenv != env)

	errorcall(call, _("'UseMethod' used in an inappropriate fashion"));

    callenv = cptr->sysparent;

    /* 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.)

    */

    if(lookup_use_topenv_as_defenv) {

	defenv = topenv(R_NilValue, env);

    } else {

	val = findVar1(installTrChar(STRING_ELT(generic, 0)),

		       ENCLOS(env), FUNSXP, TRUE); /* That has evaluated

						    * promises */

	if(TYPEOF(val) == CLOSXP) defenv = CLOENV(val);

	else defenv = R_BaseNamespace;

    }

    if (CADR(argList) != R_MissingArg)

	PROTECT(obj = eval(CADR(argList), env));

    else

	PROTECT(obj = GetObject(cptr));

    if (usemethod(translateChar(STRING_ELT(generic, 0)), obj, call, CDR(args),

		  env, callenv, defenv, &ans) == 1) {

	UNPROTECT(3); /* obj, generic, argList */

	findcontext(CTXT_RETURN, env, ans); /* does not return */

    }

    else {

	SEXP klass;

	int nclass;

	char cl[1000];

	PROTECT(klass = R_data_class2(obj));

	nclass = length(klass);

	if (nclass == 1)

	    strcpy(cl, translateChar(STRING_ELT(klass, 0)));

	else {

	    strcpy(cl, "c('");

	    for (int i = 0; i < nclass; i++) {

		if (i > 0) strcat(cl, "', '");

		strcat(cl, translateChar(STRING_ELT(klass, i)));

	    }

	    strcat(cl, "')");

	}

	errorcall(call, _("no applicable method for '%s' applied to an object of class \"%s\""),

		  translateChar(STRING_ELT(generic, 0)), cl);

    }

}

/*

   fixcall: fixes up the call when arguments to the function may

   have changed; for now we only worry about tagged args, appending

   them if they are not already there

*/

static SEXP fixcall(SEXP call, SEXP args)

{

    SEXP s, t;

    int found;

    for(t = args; t != R_NilValue; t = CDR(t)) {

	if(TAG(t) != R_NilValue) {

		found = 0;

		for(s = call; CDR(s) != R_NilValue; s = CDR(s))

		    if(TAG(CDR(s)) == TAG(t)) {

			found = 1;

			break;

		    }

		if( !found ) {

			SETCDR(s, allocList(1));

			SET_TAG(CDR(s), TAG(t));

			SETCAR(CDR(s), duplicate(CAR(t)));

		}

	}

    }

    return call;

}

/*

   equalS3Signature: compares "signature" and "left.right"

   all arguments must be non-null

*/

static

Rboolean equalS3Signature(const char *signature, const char *left,

			 const char *right) {

    const char *s = signature;

    const char *a;

    for(a = left; *a; s++, a++) {

	if (*s != *a)

	    return FALSE;

    }

    if (*s++ != '.')

	return FALSE;

    for(a = right; *a; s++, a++) {

	if (*s != *a)

	    return FALSE;

    }

    return (*s == 0) ? TRUE : FALSE;

}

static R_INLINE SEXP getPrimitive(SEXP symbol)

{

    SEXP value = SYMVALUE(symbol);

    if (TYPEOF(value) == PROMSXP) {

	PROTECT(value);

	value = eval(value, R_GlobalEnv);

	UNPROTECT(1);

	ENSURE_NAMEDMAX(value);

    }

    if (TYPEOF(value) == BUILTINSXP || TYPEOF(value) == SPECIALSXP)

        return value;

    if (TYPEOF(value) == CLOSXP) {

	/* probably means a package redefined the base function so

	   try to get the real thing from the internal table of

	   primitives */

	value = R_Primitive(CHAR(PRINTNAME(symbol)));

    } else

	value = R_NilValue;

    return value;

}

/* 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. */

/* This is a special .Internal */

SEXP attribute_hidden do_nextmethod(SEXP call, SEXP op, SEXP args, SEXP env)

{

    const char *sb, *sg, *sk;

    SEXP ans, s, t, klass, method, matchedarg, generic;

    SEXP nextfun, nextfunSignature;

    SEXP sysp, formals, newcall;

    SEXP group, basename;

    SEXP callenv, defenv;

    RCNTXT *cptr;

    int i, j;

    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_FUNCTION && cptr->cloenv == sysp) break;

	cptr = cptr->nextcontext;

    }

    if (cptr == NULL)

	error(_("'NextMethod' called from outside a function"));

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

    /* eg get("print.ts")(1) or do.call() */

    if (TYPEOF(CAR(cptr->call)) != SYMSXP)

       error(_("'NextMethod' called from an anonymous function"));

    readS3VarsFromFrame(sysp, &generic, &group, &klass, &method,

			&callenv, &defenv);

    /* Find dispatching environments. Promises shouldn't occur, but

       check to be on the safe side.  If the variables are not in the

       environment (the method was called outside a method dispatch)

       then chose reasonable defaults. */

    if (TYPEOF(callenv) == PROMSXP)

	callenv = eval(callenv, R_BaseEnv);

    else if (callenv == R_UnboundValue)

	callenv = env;

    if (TYPEOF(defenv) == PROMSXP) defenv = eval(defenv, R_BaseEnv);

    else if (defenv == R_UnboundValue) defenv = R_GlobalEnv;

    /* set up the arglist */

    s = cptr->callfun;

    if (TYPEOF(s) != CLOSXP){ /* R_LookupMethod looked for a function */

	if (s == R_UnboundValue)

	    error(_("no calling generic was found: was a method called directly?"));

	else

	    errorcall(R_NilValue,

		  _("'function' is not a function, but of type %d"),

		  TYPEOF(s));

    }

    /* get formals and actuals; attach the names of the formals to

       the actuals, expanding any ... that occurs */

    formals = FORMALS(s);

    PROTECT(matchedarg = patchArgsByActuals(formals, cptr->promargs, cptr->cloenv));

    /*

      Now see if there were any other arguments passed in

      Currently we seem to only allow named args to change

      or to be added, this is at variance with p. 470 of the

      White Book

    */

    s = CADDR(args); /* this is ... and we need to see if it's bound */

    if (s == R_DotsSymbol) {

	t = findVarInFrame3(env, s, TRUE);

	if (t != R_NilValue && t != R_MissingArg) {

	    SET_TYPEOF(t, LISTSXP); /* a safe mutation */

	    s = matchmethargs(matchedarg, t);

	    UNPROTECT(1);

	    PROTECT(matchedarg = s);

	    newcall = fixcall(newcall, matchedarg);

	}

    }

    else

	error(_("wrong argument ..."));

    /*

      .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).

    */

    if (klass == R_UnboundValue) {

	/* we can get the object from actuals directly, but this

	   branch seems to be very cold if not dead */

	s = GetObject(cptr);

	if (!isObject(s)) error(_("object not specified"));

	klass = getAttrib(s, R_ClassSymbol);

    }

    /* the generic comes from either the sysparent or it's named */

    if (generic == R_UnboundValue)

	generic = eval(CAR(args), env);

    if (generic == R_NilValue)

	error(_("generic function not specified"));

    PROTECT(generic);

    if (!isString(generic) || LENGTH(generic) != 1)

	error(_("invalid generic argument to 'NextMethod'"));

    if (CHAR(STRING_ELT(generic, 0))[0] == '\0')

	error(_("generic function not specified"));

    /* determine whether we are in a Group dispatch */

    /* determine the root: either the group or the generic will be it */

    if (group == R_UnboundValue) {

	group = R_BlankScalarString;

	basename = generic;

    } else {

	if (!isString(group) || LENGTH(group) != 1)

	    error(_("invalid 'group' argument found in 'NextMethod'"));

	if (CHAR(STRING_ELT(group, 0))[0] == '\0') basename = generic;

	else basename = group;

    }

    PROTECT(group);

    nextfun = R_NilValue;

    nextfunSignature = R_NilValue;

    /*

       Find the method currently being invoked and jump over the current call

       If t is R_UnboundValue then we called the current method directly

    */

    const void *vmax = vmaxget(); /* needed for translateChar */

    const char *b = NULL;

    if (method != R_UnboundValue) {

	if (!isString(method))

	    error(_("wrong value for .Method"));

	for(i = 0; i < LENGTH(method); i++) {

	    b = translateChar(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++) {

	    const char *bb = translateChar(STRING_ELT(method, j));

	    if (strlen(bb) && strcmp(b,bb))

		warning(_("Incompatible methods ignored"));

	}

    }

    else {

	b = CHAR(PRINTNAME(CAR(cptr->call)));

    }

    sb = translateChar(STRING_ELT(basename, 0));

    Rboolean foundSignature = FALSE;

    for (j = 0; j < LENGTH(klass); j++) {

	sk = translateChar(STRING_ELT(klass, j));

	if (equalS3Signature(b, sb, sk)) { /* b == sb.sk */

	    foundSignature = TRUE;

	    break;

	}

    }

    if (foundSignature) /* we found a match and start from there */

      j++;

    else

      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. */

    sg = translateChar(STRING_ELT(generic, 0));

    for (i = j ; i < LENGTH(klass); i++) {

	sk = translateChar(STRING_ELT(klass, i));

	nextfunSignature = installS3Signature(sg, sk);

	nextfun = R_LookupMethod(nextfunSignature, env, callenv, defenv);

	if (isFunction(nextfun)) break;

	if (group != R_UnboundValue) {

	    /* if not Generic.foo, look for Group.foo */

	    nextfunSignature = installS3Signature(sb, sk);

	    nextfun = R_LookupMethod(nextfunSignature, env, callenv, defenv);

	    if(isFunction(nextfun))

		break;

	}

	if (isFunction(nextfun))

	    break;

    }

    if (!isFunction(nextfun)) {

	nextfunSignature = installS3Signature(sg, "default");

	nextfun = R_LookupMethod(nextfunSignature, env, callenv, defenv);

	/* If there is no default method, try the generic itself,

	   provided it is primitive or a wrapper for a .Internal

	   function of the same name.

	 */

	if (!isFunction(nextfun)) {

	    t = install(sg);

	    nextfun = findVar(t, env);

	    if (TYPEOF(nextfun) == PROMSXP) {

		PROTECT(nextfun);

		nextfun = eval(nextfun, env);

		UNPROTECT(1);

	    }

	    if (!isFunction(nextfun))

		error(_("no method to invoke"));

	    if (TYPEOF(nextfun) == CLOSXP) {

		if (INTERNAL(t) != R_NilValue)

		    nextfun = INTERNAL(t);

		else {

		    nextfun = getPrimitive(t);

		    if (nextfun == R_NilValue)

		        error(_("no method to invoke"));

		}

	    }

	}

    }

    PROTECT(nextfun);

    PROTECT(s = stringSuffix(klass, i));

    setAttrib(s, R_PreviousSymbol, klass);

    /* 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,  PRINTNAME(nextfunSignature));

	}

    } else

	PROTECT(method = PRINTNAME(nextfunSignature));

    SEXP newvars = PROTECT(createS3Vars(

	generic,

	group,

	s,

	method,

	callenv,

	defenv

    ));

    SETCAR(newcall, nextfunSignature);

    /* applyMethod expects that the parent of the caller is the caller

       of the generic, so fixup by brute force. This should fix

       PR#15267 --pd */

    R_GlobalContext->sysparent = callenv;

    ans = applyMethod(newcall, nextfun, matchedarg, env, newvars);

    vmaxset(vmax);

    UNPROTECT(8);

    return(ans);

}

/* primitive */

SEXP attribute_hidden do_unclass(SEXP call, SEXP op, SEXP args, SEXP env)

{

    checkArity(op, args);

    check1arg(args, call, "x");

    if (isObject(CAR(args))) {

	switch(TYPEOF(CAR(args))) {

	case ENVSXP:

	    errorcall(call, _("cannot unclass an environment"));

	    break;

	case EXTPTRSXP:

	    errorcall(call, _("cannot unclass an external pointer"));

	    break;

	default:

	    break;