
setGeneric <-
  ## Define `name' to be a generic  function, for which methods will be defined.
  ##
  ## If there is already a non-generic function of this name, it will be used
  ## to define the generic unless `def' is supplied, and the current
  ## function will become the default method for the generic.
  ##
  ## If `def' is supplied, this defines the generic function.  The
  ## default method for a new generic will usually be an existing
  ## non-generic.  See the .Rd page
  ##
    function(name, def = NULL, group = list(), valueClass = character(),
             where = topenv(parent.frame()),
             package = NULL, signature = NULL,
             useAsDefault = NULL, genericFunction = NULL)
{
    if(exists(name, "package:base") &&
       typeof(get(name, "package:base")) != "closure") { # primitives

        fdef <- getGeneric(name) # will fail if this can't have methods
        msg <- gettextf("\"%s\" is a primitive function;  methods can be defined, but the generic function is implicit, and cannot be changed.", name)
        if(nargs() > 1)
            stop(msg, domain = NA)
        ## generics for primitives are global, so can & must always be cached
        .cacheGeneric(name, fdef)
        return(name)
    }
    stdGenericBody <- substitute(standardGeneric(NAME), list(NAME = name))
    ## get the current function which may already be a generic
    fdef <- getFunction(name, mustFind = FALSE, where = where)
    if(is.null(fdef) && !isNamespace(where))
        fdef <- getFunction(name, mustFind = FALSE)
    if(is.null(fdef) && is.function(useAsDefault))
        fdef <- useAsDefault
    ## Use the previous function definition to get the default
    ## and to set the package if not supplied.
    doUncache <- FALSE
    if(is.object(fdef) && is(fdef, "genericFunction")) {
        doUncache <- TRUE
        oldDef <- fdef
        prevDefault <- finalDefaultMethod(fdef@default)
        if(is.null(package))
            package <- fdef@package
    }
    else if(is.function(fdef)) {
        prevDefault <- fdef
        if(is.null(package))
            package <- getPackageName(environment(fdef))
    }
    else
        prevDefault <- NULL
    if(is.primitive(fdef)) ## get the pre-defined version
        fdef <- getGeneric(name, where = where)
    else if(is.function(fdef))
        body(fdef, envir = as.environment(where)) <- stdGenericBody
    if(!is.null(def)) {
        if(is.primitive(def) || !is.function(def))
            stop(gettextf("if the `def' argument is supplied, it must be a function that calls standardGeneric(\"%s\") to dispatch methods", name), domain = NA)
        fdef <- def
        if(is.null(genericFunction) && .NonstandardGenericTest(body(fdef), name, stdGenericBody))
            genericFunction <- new("nonstandardGenericFunction") # force this class for fdef
    }
    if(is.null(package) || nchar(package) == 0)
        ## either no previous def'n or failed to find its package name
        package <- getPackageName(where)
    if(is.null(fdef))
        stop("must supply a function skeleton, explicitly or via an existing function")
    if(!(is.object(fdef) && is(fdef, "genericFunction"))) {
        if(is.function(useAsDefault))
            fdeflt <- useAsDefault
        else if(identical(useAsDefault, FALSE))
            fdeflt <- NULL
        else
            fdeflt <- prevDefault
        if(is.function(fdeflt))
            fdeflt <- .derivedDefaultMethod(fdeflt)
        fdef <- makeGeneric(name, fdef, fdeflt, group=group, valueClass=valueClass,
                            package = package, signature = signature,
                            genericFunction = genericFunction)
    }
    if(doUncache)
      .uncacheGeneric(name, oldDef)
    assign(name, fdef, where)
    .cacheGeneric(name, fdef)
    if(!.UsingMethodsTables() &&
       length(fdef@group)> 0 && !is.null(getGeneric(fdef@group[[1]], where = where)))
        methods <- getAllMethods(name, fdef, where)
    else
        methods <- fdef@default # empty or containing the default
    assignMethodsMetaData(name, methods, fdef, where)
    name
}

##
## make a generic function object corresponding to the given function name.
##

isGeneric <-
  ## Is there a function named `f', and if so, is it a generic?
  ##
  ## If the `fdef' argument is supplied, take this as the definition of the
  ## generic, and test whether it is really a generic, with `f' as the name of
  ## the generic.  (This argument is not available in S-Plus.)
  function(f, where = topenv(parent.frame()), fdef = NULL, getName = FALSE)
{
    if(is.null(fdef))
        fdef <- .getGenericFromCache(f, where)
    if(is.null(fdef))
        fdef <- getFunction(f, where=where, mustFind = FALSE)
    if(is.null(fdef))
      return(FALSE)
    ## check primitives. These are never stored as explicit generic functions.
    ## The definition of isGeneric for them is that methods metadata exists,
    ## either on this database or anywhere (where == -1)
    if(!identical(typeof(fdef), "closure"))
      return(exists(mlistMetaName(f, "base"))) # all primitives are on package base
    if(!is(fdef, "genericFunction"))
        return(FALSE)
    gen <- fdef@generic
    if(getName)
        return(gen)
    else if(missing(f) || .identC(gen, f))
        return(TRUE)
    else {
        warning(gettextf("function \"%s\" appears to be a generic function, but with generic name \"%s\"", f, gen), domain = NA)
        return(FALSE)
    }
}

removeGeneric <-
  ## Remove the generic function of this name, specifically the first version
  ## encountered from environment where
  ##
    function(f, where = topenv(parent.frame()))
{
    ev <- fdef <- NULL
    allEv <- findFunction(f, where = where)
    for(maybeEv in allEv) {
        fdef <- get(f, maybeEv)
        if(is(fdef, "genericFunction")) {
            ev <- maybeEv
            break
        }
    }
    found <- is(fdef, "genericFunction")
    if(found) {
        .uncacheGeneric(f, fdef)
        removeMethodsObject(f, where)
        rm(list = fdef@generic, pos = where)
    }
    else {
        if(!is.character(f))
            f <- deparse(f)
        warning(gettextf("generic function \"%s\" not found for removal", f),
                domain = NA)
    }
    return(found)
}


getMethods <-
    ## The list of methods for the specified generic.  If the function is not
    ## a generic function, returns NULL.
    ## The `f' argument can be either the character string name of the generic
    ## or the object itself.
    ##
    ## The `where' argument optionally says where to look for the function, if
    ## `f' is given as the name.
    ## Methods objects are kept during the session in a special environment.
    ## Inside this environment, individual methods are added and updated as
    ## they are found (for example, a method that is inherited is stored,
    ## again, under the actual signature).  These updates speed up the
    ## method search; however, they are not stored with the original generic
    ## function, since they might change in future sessions.

  ## Note for methods tables.  The function getMethods() continues to
  ## return a methods list object, even when methods tables are being
  ## used for dispatch, but now this is the metadata from where, and
  ## _not_ a fully merged list, since avoiding this computation ws a
  ## major motivation for the tables.

    function(f, where = topenv(parent.frame()))
{
    nowhere <- missing(where) # remember it now, R changes the truth later!
    if(is.character(f))
        fdef <- getGeneric(f, where = where)
    else if(is(f, "genericFunction")) {
        if(nowhere)
          where <- .genEnv(f)
        fdef <- f
        f <- fdef@generic
    }
    else
        stop(gettextf("invalid argument \"f\", expected a function or its name, got an object of class \"%s\"", class(f)), domain = NA)
    if(!is.null(fdef)) { # else NULL
        ## getMethods() always returns a methods  list.  When using
        ## methods tables, this only makes sense as the metadata from
        ## where (by default, the location of the generic)
        if(.UsingMethodsTables()) {
            gwhere <-  ( if(nowhere)
                        findFunction(f, TRUE, where)[[1]] # can't be empty since fdef is nonnull
                        else where)
            value <- getMethodsMetaData(f, where = gwhere)
            if(is.null(value)) # return empty methods list
              new("MethodsList", argument = fdef@default@argument)
            else
              value
        }
        else
          getMethodsForDispatch(f, fdef)
    }
}

getMethodsForDispatch <- function(f, fdef)
{
  ev <- environment(fdef)
    if(.UsingMethodsTables())
        .getMethodsTable(fdef, ev)
    else {
        if(exists(".Methods", envir = ev, inherits = FALSE))
            get(".Methods", envir = ev) ## else NULL
    }
}

## some functions used in MethodsListSelect, that must be safe against recursive
## method selection.  TODO:  wouldn't need this if methods package had a name space

.existsBasic <- get("exists", "package:base")
.getBasic <- get("get", "package:base")
.evBasic <- get("environment", "package:base")
.assignBasic <- get("assign", "package:base")
.setIfBase <- function(f, fdef, mlist) {
    if(is.null(f))
        FALSE
    else {
        found <- .existsBasic(f, "package:base")
        if(found) {
            ## force (default) computation of mlist in MethodsListSelect
            .assignBasic(".Methods", envir = .evBasic(fdef), .getBasic(f, "package:base"))
        }
        found
    }
}

##NB used internally in MethodsListSelect.  Must NOT use the standard version
## to prevent recursion
.getMethodsForDispatch <- function(f, fdef) {
    ev <- .evBasic(fdef)
    if(.existsBasic(".Methods", envir = ev)) {
        .getBasic(".Methods", envir = ev)
    }
    else
        NULL
}

.setMethodsForDispatch <- function(f, fdef, mlist) {
    ev <- environment(fdef)
    if(!is(fdef, "genericFunction") ||
       !exists(".Methods", envir = ev, inherits = FALSE))
        stop(gettextf("internal error: did not get a valid generic function object for function \"%s\"", f), domain = NA)
    assign(".Methods", envir = ev, mlist)
}

cacheMethod <-
  ## cache the given definition in the method metadata for f
  ## Support function:  DON'T USE DIRECTLY (does no checking)
  function(f, sig, def, args = names(sig), fdef) {
    ev <- environment(fdef)
    if(.UsingMethodsTables())
      .cacheMethodInTable(fdef, sig, def, .getMethodsTable(fdef, ev))
    else {
      methods <- get(".Methods", envir = ev)
      methods <- insertMethod(methods, sig, args, def, TRUE)
      assign(".Methods", methods, envir = ev)
      deflt <- finalDefaultMethod(methods)
      if(is.primitive(deflt))
        setPrimitiveMethods(f, deflt, "set", fdef, methods)
      methods
    }
  }


setMethod <-
## Define a method for the specified combination of generic function and signature.
## The method is stored in the methods meta-data of the specified database.
  ##
  ## Note that assigning methods anywhere but the global environment (`where==1') will
  ## not have a permanent effect beyond the current R session.
  function(f, signature = character(), definition, where = topenv(parent.frame()), valueClass = NULL,
           sealed = FALSE)
{
    ## Methods are stored in metadata in database where.  A generic function will be
    ## assigned if there is no current generic, and the function is NOT a primitive.
    ## Primitives are dispatched from the main C code, and an explicit generic NEVER
    ## is assigned for them.
    if(is.function(f) && is(f, "genericFunction")) {
        ## (two-part test to deal with bootstrapping of methods package)
        fdef <- f
        f <- fdef@generic
        gwhere <- .genEnv(f)
    }
    else if(is.function(f)) {
          if(is.primitive(f)) {
            f <- .primname(f)
            fdef <- genericForPrimitive(f)
            gwhere <- .genEnv(f)
         }
          else
            stop("A function for argument \"f\" must be a generic function")
    }
      ## slight subtlety:  calling getGeneric vs calling isGeneric
    ## For primitive functions, getGeneric returns the (hidden) generic function,
    ## even if no methods have been defined.  An explicit generic MUST NOT be
    ## for these functions, dispatch is done inside the evaluator.
    else {
        where <- as.environment(where)
        gwhere <- .genEnv(f, where)
        fdef <- getGeneric(f, where = if(identical(gwhere, baseenv())) where else gwhere)
    }
    if(.lockedForMethods(fdef, where))
        stop(gettextf("the environment \"%s\" is locked; cannot assign methods for function \"%s\"", getPackageName(where), f), domain = NA)
    hasMethods <- !is.null(fdef)
    deflt <- getFunction(f, generic = FALSE, mustFind = FALSE, where = where)
    ## where to insert the methods in generic
    if(identical(gwhere, baseenv())) {
        allWhere <- findFunction(f, where = where)
        generics <-logical(length(allWhere))
        if(length(allWhere)>0) { # put methods into existing generic
            for(i in seq_along(allWhere)) {
                fi <- get(f, allWhere[[i]])
                geni <- is(fi, "genericFunction")
                generics[[i]] <- geni
                if(!geni && is.null(deflt))
                    deflt <- fi
            }
        }
        if(any(generics)) {
            ## try to add method to the existing generic, but if the corresponding
            ## environment is sealed, must create a new generic in where
            gwhere <- as.environment(allWhere[generics][[1]])
            if(.lockedForMethods(fdef, gwhere)) {
                if(identical(as.environment(where), gwhere))
                    stop(gettextf("the 'where' environment (%s) is a locked namespace; cannot assign methods there",
                                  getPackageName(where)), domain = NA)
                msg <-
                    gettextf("copying the generic function \"%s\" to environment \"%s\", because the previous version was in a sealed namespace (%s)",
                             f,
                             getPackageName(where),
                             getPackageName(gwhere))
                message(strwrap(msg), domain = NA)
                assign(f, fdef, where)
                gwhere <- where
            }
        }
    }
    if(!hasMethods)
      fdef <- deflt
    if(is.null(fdef))
      stop(gettextf("no existing definition for function \"%s\"", f),
           domain = NA)
    if(!hasMethods) {
        message(gettextf("Creating a new generic function for \"%s\" in \"%s\"",
                         f, getPackageName(where)),
                domain = NA)
        ## create using the visible non-generic as a pattern and default method
        setGeneric(f, where = where)
        fdef <- getGeneric(f, where = where)
    }
    else if(identical(gwhere, NA)) {
        ## better be a primitive since getGeneric returned a generic, but none was found
        if(is.null(elNamed(.BasicFunsList, f)))
            stop(gettextf("apparent internal error: a generic function was found for \"%s\", but no corresponding object was found searching from \"%s\"",
                          f, getPackageName(where)), domain = NA)
        if(!isGeneric(f))
          setGeneric(f) #  turn on this generic and cache it.
    }
    if(isSealedMethod(f, signature, fdef))
        stop(gettextf("the method for function \"%s\" and signature %s is sealed and cannot be re-defined", f, .signatureString(fdef, signature)), domain = NA)
    signature <- matchSignature(signature, fdef, where)
    switch(typeof(definition),
           closure = {
               fnames <- formalArgs(fdef)
               mnames <- formalArgs(definition)
               if(!identical(mnames, fnames)) {
                   ## omitted classes in method => "missing"
                   fullSig <- conformMethod(signature, mnames, fnames, f)
                   if(!identical(fullSig, signature)) {
                       formals(definition, envir = environment(definition)) <- formals(fdef)
                       signature <- fullSig
                   }
                   ## extra classes in method => use "..." to rematch
                   definition <- rematchDefinition(definition, fdef, mnames, fnames, signature)
               }
               definition <- matchDefaults(definition, fdef) # use generic's defaults if none in method
           },
           builtin = , special = {
             ## the only primitive methods allowed are those equivalent
             ## to the default, for generics that were primitives before
             ## and will be dispatched by C code.
             if(!identical(definition, deflt))
                stop("primitive functions cannot be methods; they must be enclosed in a regular function")
           },
           "NULL" = {

           },
           stop(gettextf("invalid method definition: expected a function, got an object of class \"%s\"", class(definition)), domain = NA)
           )
    fenv <- environment(fdef)
    ## check length against active sig. length, reset if necessary in .addToMetaTable
    nSig <- .getGenericSigLength(fdef, fenv, TRUE)
    signature <- .matchSigLength(signature, fdef, fenv, TRUE)
    margs  <- (fdef@signature)[1:length(signature)]
    definition <- asMethodDefinition(definition, signature, sealed)
    if(is(definition, "MethodDefinition"))
      definition@generic <- fdef@generic
    whereMethods <- .getOrMakeMethodsList(f, where, fdef)
    whereMethods <- insertMethod(whereMethods, signature, margs, definition)
    allMethods <- getMethodsForDispatch(f, fdef)
    if(is.environment(allMethods)) {
        ## cache in both direct and inherited tables
      .cacheMethodInTable(fdef, signature, definition, allMethods) #direct
      .cacheMethodInTable(fdef, signature, definition) # inherited, by default
      if(!identical(where, baseenv()))
         .addToMetaTable(fdef, signature, definition,where, nSig)
    }
    else # but currently unused (9/06)-- should be deleted after testing
      allMethods <- insertMethod(allMethods, signature, margs, definition)
    resetGeneric(f, fdef, allMethods, gwhere, deflt) # Note: gwhere not used by resetGeneric
    ## assigns the methodslist object
    ## and deals with flags for primitives & for updating group members
    if(!identical(where, baseenv()))
        assignMethodsMetaData(f, whereMethods, fdef, where, deflt)
    f
}

removeMethod <- function(f, signature = character(), where = topenv(parent.frame())) {
    if(is.function(f)) {
      if(is(f, "genericFunction"))
         { fdef <- f; f <- f@generic}
      else if(is.primitive(f))
        { f <- .primname(f); fdef <- genericForPrimitive(f)}
      else
        stop("Function supplied as argument \"f\" must be a generic")
    }
    else
      fdef <- getGeneric(f, where = where)
    if(is.null(fdef)) {
        warning(gettextf("no generic function \"'%s\" found", f), domain = NA)
        return(FALSE)
    }
    if(is.null(getMethod(fdef, signature, optional=TRUE))) {
        warning(gettextf("no method found for function \"%s\" and signature %s",
                         fdef@generic,
                         paste(dQuote(signature), collapse =", ")),
                domain = NA)
        return(FALSE)
    }
    setMethod(f, signature, NULL, where = where)
    TRUE
}

## an extension to removeMethod that resets inherited methods as well
.undefineMethod <- function(f, signature = character(), where = topenv(parent.frame())) {
    fdef <- getGeneric(f, where = where)
    if(is.null(fdef)) {
        warning(gettextf("no generic function \"%s\" found", f), domain = NA)
        return(FALSE)
    }
    if(!is.null(getMethod(fdef, signature, optional=TRUE)))
      setMethod(f, signature, NULL, where = where)
  }

findMethod <- function(f, signature, where = topenv(parent.frame())) {
    fM <- mlistMetaName(f)
    where <- .findAll(fM, where)
    found <- logical(length(where))
    for(i in seq_along(where)) {
        wherei <- where[[i]]
        mi <- get(fM, wherei, inherits=FALSE)
        mi <- getMethod(f, signature, where = wherei, optional = TRUE, mlist = mi)
        found[i] <- is(mi, "function")
        if(found[i] && is.environment(wherei))
            simple <- FALSE
    }
    value <- where[found]
    ## to conform to the API, try to return a numeric or character vector
    ## if possible
    what <- sapply(value, class)
    if(identical(what, "numeric") || identical(what, "character"))
        unlist(value)
    else
        value
}

getMethod <-
  ## Return the function that is defined as the method for this generic function and signature
  ## (classes to be matched to the arguments of the generic function).
  function(f, signature = character(), where = topenv(parent.frame()), optional = FALSE,
           mlist, fdef = getGeneric(f, !optional, where = where))
{
    if(!is(fdef, "genericFunction")) # must be the optional case, else an error in getGeneric
        return(NULL)
    if(missing(mlist)) {
        if(missing(where))
            mlist <- getMethodsForDispatch(f, fdef)
        else
            mlist <- getMethods(f, where)
    }
    if(is.environment(mlist)) {
        value <- .findMethodInTable(signature, mlist, fdef)
        if(is.null(value) && !optional)
          stop(gettextf('No method found for function "%s" and signature %s',
                        f, paste(signature, collapse = ", ")))
        return(value)
    }
    i <- 1
    argNames <- fdef@signature
    signature <- matchSignature(signature, fdef)
    Classes <- signature # a copy just for possible error message
    while(length(signature) > 0 && is(mlist, "MethodsList")) {
        if(!identical(argNames[[i]], as.character(mlist@argument)))
            stop(gettextf("apparent inconsistency in the methods for function \"%s\"; argument \"%s\" in the signature corresponds to \"%s\" in the methods list object",
                          .genericName(f), argNames[[i]], as.character(mlist@argument)), domain = NA)
        Class <- signature[[1]]
        signature <- signature[-1]
        methods <- slot(mlist, "methods")
        mlist <- elNamed(methods, Class)# may be function, MethodsList or NULL
        i <- i + 1
    }
    if(length(signature) == 0) {
        ## process the implicit remaining "ANY" elements
        if(is(mlist, "MethodsList"))
            mlist <- finalDefaultMethod(mlist)
        if(is(mlist, "function"))
            return(mlist) # the only successful outcome
    }
    if(optional)
        mlist                           ## may be NULL or a MethodsList object
    else {
        ## for friendliness, look for (but don't return!) an S3 method
        if(length(Classes) == 1 && exists(paste(.genericName(f), Classes, sep="."), where))
            stop(gettextf("no S4 method for function \"%s\" and signature %s; consider getS3method() if you wanted the S3 method",
                          .genericName(f), Classes), domain = NA)
        if(length(Classes) > 0) {
            length(argNames) <- length(Classes)
            Classes <- paste(argNames," = \"", unlist(Classes),
                             "\"", sep = "", collapse = ", ")
        }
        else
            Classes <- "\"ANY\""
        stop(gettextf("no method defined for function \"%s\" and signature %s",
                      .genericName(f), Classes), domain = NA)
    }
}

dumpMethod <-
  ## Dump the method for this generic function and signature.
  ## The resulting source file will recreate the method.
  function(f, signature=character(), file = defaultDumpName(f, signature),
           where = -1,
           def = getMethod(f, signature, where=where, optional = TRUE))
{
    if(!is.function(def))
        def <- getMethod(f, character(), where=where, optional = TRUE)
    if(file != "")
        sink(file)
    cat("setMethod(\"", f, "\", ", deparse(signature), ",\n", sep="")
    dput(def)
    cat(")\n", sep="")
    if(file != "")
        sink()
    file
}


selectMethod <-
  ## Returns the method (a function) that R would use to evaluate a call to this generic,
  ## with arguments corresponding to the specified signature.
  ##
  ## f = the name of the generic function
  ## env = an environment, in which the class corresponding to each argument
  ##       is assigned with the argument's name.
  ## optional = If TRUE, and no explicit selection results, return result anyway. else error
  ## mlist = Optional MethodsList object to use in the search.
    function(f, signature, optional = FALSE,
             useInherited = TRUE,
             mlist = (if(is.null(fdef)) NULL else getMethodsForDispatch(f, fdef)),
             fdef = getGeneric(f, !optional))
{
    if(is.environment(mlist))  {# using methods tables
        fenv <- environment(fdef)
        nsig <- .getGenericSigLength(fdef, fenv, FALSE)
        if(length(signature) < nsig)
          signature[(length(signature)+1):nsig] <- "ANY"
        if(missing(useInherited))
          useInherited <- is.na(match(signature, "ANY"))
        allmethods <- .getMethodsTable(fdef, fenv, FALSE, TRUE)
        method <- .findMethodInTable(signature, mlist, fdef)
        if(is.null(method)) {
            if(any(useInherited))
              ## look in the supplied (usually standard) table, cache w. inherited
              methods <- .findInheritedMethods(signature, fdef,
                                               mtable = allmethods,
                                               table = mlist,
                                               useInherited = useInherited)
            else # just look in the direct table
              methods <- list()
            if(length(methods)>0)
              return(methods[[1]])
            else if(optional)
              return(NULL)
            else stop(gettextf("No method found for signature %s", paste(signature,
                                                                        collapse=", ")))
        }
        else
          return(method)
  }
    evalArgs <- is.environment(signature)
    if(evalArgs)
        env <- signature
    else if(length(names(signature)) == length(signature))
        env <- sigToEnv(signature, fdef)
    else if(is.character(signature)) {
        argNames <-  formalArgs(fdef)
        length(argNames) <- length(signature)
        argNames <- argNames[is.na(match(argNames, "..."))]
        names(signature) <- argNames
        env <- sigToEnv(signature, fdef)
    }
    else
        stop("signature must be a vector of classes or an environment")
    if(is.null(mlist)) {
        if(optional)
            return(mlist)
        else
            stop(gettextf('"%s" has no methods defined', f), domain = NA)
    }
    selection <- .Call("R_selectMethod", f, env, mlist, evalArgs, PACKAGE = "methods")
    if(is.null(selection) && !identical(useInherited, FALSE)) {
      ## do the inheritance computations to update the methods list, try again.
      ##
      ## assign the updated information to the method environment
      fEnv <- environment(fdef)
      if(exists(".SelectMethodOn", fEnv, inherits = FALSE))
          ##<FIXME> This should have been eliminated now
          ## we shouldn't be doing method selection on a function used in method selection!
          ## Having name spaces for methods will prevent this happening -- until then
          ## force a return of the original default method
          return(finalDefaultMethod(mlist, f))
      assign(".SelectMethodOn", TRUE, fEnv)
      on.exit(rm(.SelectMethodOn, envir = fEnv))
      ##</FIXME>
      mlist <- MethodsListSelect(f, env, mlist, NULL, evalArgs = evalArgs,
                                 useInherited = useInherited, resetAllowed = FALSE)
      if(is(mlist, "MethodsList"))
          selection <- .Call("R_selectMethod", f, env, mlist, evalArgs, PACKAGE = "methods")
    }
    if(is(selection, "function"))
        selection
    else if(is(selection, "MethodsList")) {
      if(optional)
        selection
      else
        stop("no unique method corresponding to this signature")
    }
    else {
        if(optional)
            selection
        else
            stop("unable to match signature to methods")
    }
}

hasMethod <-
  ## returns `TRUE' if `f' is the name of a generic function with an (explicit or inherited) method for
  ## this signature.
  function(f, signature = character(), where = .genEnv(f, topenv(parent.frame())))
{
    fdef <- getGeneric(f, where = where)
    if(is.null(fdef))
        FALSE
    else
        !is.null(selectMethod(f, signature, optional = TRUE, fdef = fdef))
}

existsMethod <-
  ## returns `TRUE' if `f' is the name of a generic function with an (explicit) method for
  ## this signature.
  function(f, signature = character(), where = topenv(parent.frame()))
{
    fdef <- getGeneric(f, FALSE, where = where)
    if(is.null(fdef))
      FALSE
    else  {
        if(missing(where))
          method <- getMethod(f, signature, fdef = fdef, optional = TRUE)
        else
          method <- getMethod(f, signature, where = where, optional = TRUE)
        !is.null(method)
    }
}

dumpMethods <-
  ## Dump all the methods for this generic.
  ##
  ## If `signature' is supplied only the methods matching this initial signature
  ## are dumped.  (This feature is not found in S-Plus:  don't use it if you want
  ## compatibility.)
  function(f, file = "", signature = character(), methods, where = topenv(parent.frame()) )
{
    if(missing(methods))
        methods <-  getMethods(f, where = where)
    if(file != "")
        sink(file)
    on.exit(if(file!="")
            sink())
    for(what in names(methods)) {
        el <- methods[[what]]
        if(is.function(el))
            dumpMethod(f, c(signature, what), file = "", def = el)
        else
            dumpMethods(f, "", c(signature, what), el, where)
    }
}

signature <-
  ## A named list of classes to be matched to arguments of a generic function.
  ## It is recommended to supply signatures to `setMethod' via a call to `signature',
  ## to make clear which arguments are being used to select this method.
  ## It works, however, just to give a vector of character strings, which will
  ## be associated with the formal arguments of the function, in order.  The advantage
  ## of using `signature' is to provide a check on which arguments you meant, as well
  ## as clearer documentation in your method specification.  In addition, `signature'
  ## checks that each of the elements is a single character string.
  function(...)
{
    value <- list(...)
    names <- names(value)
    for(i in seq_along(value)) {
        sigi <- el(value, i)
        if(!is.character(sigi) || length(sigi) != 1)
            stop(gettextf("bad class specified for element %d (should be a single character string)", i), domain = NA)
    }
      value <- as.character(value)
      names(value) <- names
      value
}

showMethods <-
    ## Show all the methods for the specified function.
    ##
    ## If `where' is supplied, the definition from that database will
    ## be used; otherwise, the current definition is used (which will
    ## include inherited methods that have arisen so far in the
    ## session).
    ##
    ## The output style is different from S-Plus in that it does not
    ## show the database from which the definition comes, but can
    ## optionally include the method definitions, if `includeDefs == TRUE'.
    ##
    function(f = character(), where = topenv(parent.frame()), classes = NULL,
             includeDefs = FALSE, inherited = TRUE,
             showEmpty, printTo = stdout())
{
    if(missing(showEmpty))
      showEmpty <- !missing(f)
    if(identical(printTo, FALSE)) {
        tmp <- tempfile()
        on.exit(unlink(tmp))
        con <- file(tmp, "w")
    }
    else con <- printTo
    ## must resolve showEmpty in line; using an equivalent default
    ## fails because R resets the "missing()" result for f later on (grumble)
    if(is(f, "function"))
        f <- as.character(substitute(f))
    if(!is(f, "character"))
        stop(gettextf("first argument should be the name(s) of generic functions (got object of class \"%s\")", class(f)), domain = NA)
    if(length(f)==0) {
        f <- if(missing(where)) getGenerics() else getGenerics(where)
    }
    if(length(f) == 0)
	cat(file = con, "No applicable functions\n")
    else if(length(f) > 1) {
        if(identical(printTo, FALSE))
          stop(gettextf("The special case of printTo=FALSE only works when a single generic function is specified"))
        for(ff in f) { ## recall for each
            fdef <- getGeneric(ff, where = where)
            if(is.null(fdef))
                next
            Recall(ff, where=where, classes=classes,
                   includeDefs=includeDefs, inherited=inherited,
                   showEmpty=showEmpty, printTo=printTo)
        }

    }
    else { ## f of length 1 --- the "working horse" :
        out <- paste("\nFunction \"", f, "\":\n", sep="")
        if(!isGeneric(f, where))
            cat(file = con, out, "<not a generic function>\n")
        else {
            if(.UsingMethodsTables()) {
		## maybe no output for showEmpty=FALSE
		.showMethodsTable(getGeneric(f, where = where), includeDefs, inherited,
				  classes = classes, showEmpty = showEmpty,
				  printTo = con)
            }
            else {
              mlist <-  getMethods(f, where)
              if(is.null(mlist))
                cat(file = con, out, "<no applicable methods>\n")
              else {
                ##NotYet         linML <- linearizeMlist(mlist, inherited,
                ##NotYet                                  drop.empty4class = classes)
                ##NotYet         ##_ if(showEmpty || length(linML@methods) > 0) {
                ##NotYet             cat(file = con, out)
                ##NotYet             showMlist(linML = linML, includeDefs = includeDefs,
                ##NotYet                       printTo = con)
                ##NotYet         ##_ }
                cat(file = con, out)
                showMlist(mlist, includeDefs, inherited, classes, printTo = con)
              }
            }
        }
    }
    if(identical(printTo, FALSE)) {
        close(con)
        readLines(tmp)
    }
    else
      invisible(printTo)
}

## this should be made obsolete
removeMethodsObject <-
    function(f, where = topenv(parent.frame()))
{
    fdef <- getGeneric(f, where=where)
    if(!is(fdef, "genericFunction")) {
      warning(gettextf(
    "No generic function found for \"%s\"; no action taken in removeMethodsObject", f))
      return(FALSE)
  }
  what <- mlistMetaName(f, fdef@package)
  if(!exists(what, where))
      return(FALSE)
  where <- as.environment(where)
  if(environmentIsLocked(where)) {
      warning(gettextf("the environment/package \"%s\" is locked; cannot remove methods data for \"%s\"",
                       getPackageName(where), f), domain = NA)
      return(FALSE)
  }
  rm(list = what, pos = where)
  TRUE
}


removeMethods <-
  ## removes all the methods defined for this generic function.  Returns `TRUE' if
  ## `f' was a generic function, `FALSE' (silently) otherwise.
  ##
  ## If there is a default method, the function will be re-assigned as
  ## a simple function with this definition; otherwise, it will be removed.  The
  ## assignment or removal can be controlled by optional argument `where', which
  ## defaults to the first element of the search list having a function called `f'.
  function(f, where = topenv(parent.frame()), all = TRUE)
{
    ## NOTE:  The following is more delicate than one would like, all because of
    ## methods for primitive functions.  For those, no actual generic function exists,
    ## but isGeneric(f) is TRUE if there are methods.  We have to get the default from
    ## the methods object BEFORE calling removeMethodsObject, in case there are no more
    ## methods left afterwards. AND we can't necessarily use the same default "where"
    ## location for methods object and generic, for the case of primitive functions.
    ## And missing(where) only works in R BEFORE the default is calculated.  Hence
    ## the peculiar order of computations and the explicit use of missing(where).
    fdef <- getGeneric(f, where = where)
    if(!is(fdef, "genericFunction")) {
        warning(gettextf("\"%s\" is not a generic function in \"%s\"; methods not removed",
                f, getPackageName(where)), domain = NA)
        return(FALSE)
    }

    methods <- getMethodsForDispatch(f, fdef) # list or table
    if(is.environment(methods)) {
##      remove(list=objects(methods, all=TRUE), envir = methods)
      mlist <- getMethods(fdef) # always a methods list
    }
    else
      mlist <- methods
    default <- getMethod(fdef, "ANY", optional = TRUE)
    fMetaName <- mlistMetaName(fdef)
    allWhere <- .findAll(fMetaName, where)
    if(!all)
        allWhere <- allWhere[1]
    value <- rep(TRUE, length(allWhere))
    for(i in seq_along(allWhere)) {
        db <- allWhere[[i]]
        obj <- get(fMetaName, db)
        ## remove non-empty methods list objects
        if(is(obj, "MethodsList") && length(obj@methods)>0)
            value[[i]] <- removeMethodsObject(f, where = db)
    }
    ## cacheGenericsMetaData is called to clear primitive methods if there
    ## are none for this generic on other databases.
    cacheGenericsMetaData(f, fdef, FALSE, where)
    .uncacheGeneric(f, fdef) # in case it gets removed or re-assigned
   allWhere <- allWhere[value] # process functions only where methods successfully removed
    for(i in seq_along(allWhere)) {
        db <- as.environment(allWhere[[i]])
        if(isGeneric(f, db)) { # note use of isGeneric to work for primitives
            if(environmentIsLocked(db)) {
                warning(gettextf("cannot restore previous version of \"%s\" in locked environment/package \"%s\"",
                        f, getPackageName(db)), domain = NA)
                value[[i]] <- FALSE
            }
            ## restore the original function if one was used as default
            if(is(default, "derivedDefaultMethod")) {
                default <- as(default, "function") # strict, removes slots
                rm(list=f, pos = db)
                if(!existsFunction(f, FALSE, db)) {
                    message(gettextf("restoring default function definition of \"%s\"",
                                     f), domain = NA)
                    assign(f, default, db)
                }
                ## else the generic is removed, nongeneric will be found elsewhere
            }
            ## else, leave the generic in place
            else {
                mlist@methods <- mlist@allMethods <- list()
                resetGeneric(f, fdef, methods, db, default)
                assignMethodsMetaData(f, mlist, fdef, db, default)
            }
            break
        }
    }
    any(value)
}


resetGeneric <- function(f, fdef = getGeneric(f, where = where), mlist = getMethodsForDispatch(f, fdef), where = topenv(parent.frame()), deflt = finalDefaultMethod(mlist)) {
    if(!is(fdef, "genericFunction")) {
        if(missing(mlist)) {
            warning(gettextf("cannot reset \"%s\", the definition is not a generic function object", f), domain = NA)
            return(NULL)
        }
        else
            stop(gettextf("error in updating generic function \"%s\"; the function definition is not a generic function (class \"%s\")", f, class(fdef)),
                 domain = NA)
    }
    ## uncache
    if(is.environment(mlist))
        .updateMethodsInTable(fdef, where, "reset")
    else {
        mlist@allMethods <- mlist@methods
        .genericAssign(f, fdef, mlist, where, deflt)
    }
    f
}

setReplaceMethod <-
  function(f, ..., where = topenv(parent.frame()))
  setMethod(paste(f, "<-", sep=""), ..., where = where)

setGroupGeneric <-
    ## create a group generic function for this name.
    function(name, def = NULL, group = list(), valueClass = character(),
             knownMembers = list(), package = getPackageName(where), where = topenv(parent.frame()))
{
    if(is.null(def)) {
        def <- getFunction(name, where = where)
        if(isGroup(name, fdef = def)) {
            if(nargs() == 1) {
                message(gettextf("function \"%s\" is already a group generic; no change",
                                 name),
                        domain = NA)
                return(name)
            }
        }
    }
    ## By definition, the body must generate an error.
    body(def, envir = environment(def)) <- substitute(
              stop(MSG, domain = NA),
              list(MSG = gettextf("function \"%s\" is a group generic; do not call it directly", name)))
    if(is.character(knownMembers))
        knownMembers <- as.list(knownMembers) # ? or try to find them?
    setGeneric(name, def, group = group, valueClass = valueClass,
               package = package, useAsDefault = FALSE,
               genericFunction =
                 new("groupGenericFunction", def, groupMembers = knownMembers),
               where = where)
    name
}

isGroup <-
  function(f, where = topenv(parent.frame()), fdef = getGeneric(f, where = where))
  {
    is(fdef, "groupGenericFunction")
  }

callGeneric <- function(...)
{
    frame <- sys.parent()
    envir <- parent.frame()

    # the  lines below this comment do what the previous version
    # did in the expression fdef <- sys.function(frame)
    if(exists(".Generic", envir = envir, inherits = FALSE))
      fname <- get(".Generic", envir = envir)
    else # but probably an error
      fname <- sys.call(frame)[[1]]
    fdef <- get(as.character(fname), env = envir)

    if(is.primitive(fdef)) {
        if(nargs() == 0)
            stop("'callGeneric' with a primitive needs explicit arguments (no formal args defined)")
        else {
            fname <- sys.call(frame)[[1]]
            call <- substitute(fname(...))
        }
    }
    else {
        env <- environment(fdef)
        if(!exists(".Generic", env, inherits = FALSE))
            stop("'callGeneric' must be called from a generic function or method")
        f <- get(".Generic", env, inherits = FALSE)
        fname <- as.name(f)
        if(nargs() == 0) {
            call <- sys.call(frame)
            call <- match.call(fdef, call)
            anames <- names(call)
            matched <- !is.na(match(anames, names(formals(fdef))))
            for(i in seq_along(anames))
                if(matched[[i]])
                    call[[i]] <- as.name(anames[[i]])
        }
        else {
            call <- substitute(fname(...))
        }
    }
    eval(call, sys.frame(sys.parent()))
}

initMethodDispatch <- function(where = topenv(parent.frame()))
    .Call("R_initMethodDispatch", as.environment(where),
          PACKAGE = "methods")# C-level initialization

isSealedMethod <- function(f, signature, fdef = getGeneric(f, FALSE, where = where), where = topenv(parent.frame())) {
    fNonGen <- getFunction(f, FALSE, FALSE, where = where)
    if(!is.primitive(fNonGen)) {
        mdef <- getMethod(f, signature, optional = TRUE)
        return(is(mdef, "SealedMethodDefinition"))
    }
    ## else, a primitive
    if(is(fdef, "genericFunction"))
        signature <- matchSignature(signature, fdef)
    if(length(signature)==0)
        TRUE # default method for primitive
    else {
        sealed <- !is.na(match(signature[[1]], .BasicClasses))
        if(sealed &&
           (!is.na(match("Ops", c(f, getGroup(f, TRUE))))
            || !is.na(match(f, c("%*%", "crossprod")))))
            ## Ops methods are only sealed if both args are basic classes
            sealed <- sealed && (length(signature) > 1) &&
                      !is.na(match(signature[[2]], .BasicClasses))
        sealed
    }
}

.lockedForMethods <- function(fdef, env) {
    ## the env argument is NULL if setMethod is only going to assign into the
    ## table of the generic function, and not to assign methods list object
    if(is.null(env) || !environmentIsLocked(env))
        return(FALSE) #? can binding be locked and envir. not?
    name <- fdef@generic
    package <- fdef@package
    objs <- c(name, mlistMetaName(name, package))
    for(obj in objs) {
        hasIt <- exists(obj, env, inherits = FALSE)
        ## the method object may be bound, or a new one may be needed
        ## in which case the env. better not be locked
        if((!hasIt || bindingIsLocked(obj, env)))
            return(TRUE)
    }
    FALSE
}
