-
Notifications
You must be signed in to change notification settings - Fork 306
/
BasicFunsList.R
160 lines (145 loc) · 6.45 KB
/
BasicFunsList.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
# File src/library/methods/R/BasicFunsList.R
# Part of the R package, https://www.R-project.org
#
# Copyright (C) 1995-2016 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 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.
#
# A copy of the GNU General Public License is available at
# https://www.R-project.org/Licenses/
## Lists of functions and expressions used in dispatch of functions
## defined internally (as .Primitive's) for which formal argument lists
## are not available, or for which a generic, if created,
## needs to have a special form (e.g., belonging to one of the
## predefined groups of functions).
##' The list is expanded in .makeBasicFuns() -> ./makeBasicFunsList.R by
##' adding the S4 group generics and the remaining primitives.
.BasicFunsList <-
list(
### subset/subassignment ops are regarded as language elements
"$" = structure(function(x, name)
{
name <- as.character(substitute(name))
standardGeneric("$")
}, signature = c("x"))
, "$<-" = structure(function(x, name, value)
{
name <- as.character(substitute(name))
standardGeneric("$<-")
}, signature = c("x", "value"))
, "[" = function(x, i, j, ..., drop = TRUE) standardGeneric("[")
, "[<-" = function(x, i, j, ..., value) standardGeneric("[<-")
, "[[" = function(x, i, j, ...) standardGeneric("[[")
, "[[<-" = function(x, i, j, ..., value) standardGeneric("[[<-")
### S4 generic via R_possible_dispatch in do_matprod
, "%*%" = function(x, y) standardGeneric("%*%")
, "crossprod" = function(x, y=NULL, ...) standardGeneric("crossprod")
, "tcrossprod"= function(x, y=NULL, ...) standardGeneric("tcrossprod")
, "xtfrm" = function(x) standardGeneric("xtfrm")
### these have a different arglist from the primitives
, "c" = structure(function(x, ...) standardGeneric("c"), signature="x")
, "all" = structure(function(x, ..., na.rm = FALSE) standardGeneric("all"),
signature="x")
, "any" = structure(function(x, ..., na.rm = FALSE) standardGeneric("any"),
signature="x")
, "sum" = structure(function(x, ..., na.rm = FALSE) standardGeneric("sum"),
signature="x")
, "prod" = structure(function(x, ..., na.rm = FALSE) standardGeneric("prod"),
signature="x")
, "max" = structure(function(x, ..., na.rm = FALSE) standardGeneric("max"),
signature="x")
, "min" = structure(function(x, ..., na.rm = FALSE) standardGeneric("min"),
signature="x")
, "range" = structure(function(x, ..., na.rm = FALSE) standardGeneric("range"),
signature="x")
## , "!" = function(e1) standardGeneric("!")
)
## the names of the basic funs with the style of "["
## R implements these in an inconsistent call mechanism, in which missing arguments
## are allowed, and significant, but argument names are not used. See callNextMethod
.BasicSubsetFunctions <- c("[", "[[", "[<-", "[[<-")
## create generic functions corresponding to the basic (primitive) functions
## but don't leave them as generics in the package. Instead store them in
## a named list to be used by setMethod, w/o forcing method dispatch on these
## functions.
.addBasicGeneric <-
function(funslist, f, fdef, group = list(), internal = FALSE,
internalArgs = names(formals(deflt)))
{
deflt <- .BaseNamespaceEnv[[f]]
## use the arguments of the base package function
##FIXME: should also deal with the functions having ... as the first
## argument, but needs to create a generic with different args from the deflt
## => constructing a call to the base function from the default
if(is.primitive(deflt)) {
signature <- attr(fdef, "signature") #typically NULL, but see the case for "$"
body(fdef, envir = topenv()) <-
substitute(standardGeneric(FNAME, DEFLT), list(FNAME=f, DEFLT=deflt))
}
else {
if (internal) {
## "forgets" the *defaults* of arguments, e.g. the "any" of as.vector():
## formals(deflt) <- setNames(rep(alist(x=), length(internalArgs)),
## internalArgs)
call <- as.call(c(as.name(f), lapply(internalArgs, as.name)))
body(deflt, envir = baseenv()) <-
substitute(.Internal(CALL), list(CALL=call))
}
fdef <- deflt
body(fdef, envir = topenv()) <-
substitute(standardGeneric(FNAME), list(FNAME=f))
}
deflt <- .derivedDefaultMethod(deflt, internal = if (internal) f)
if (internal) {
signature <- names(formals(deflt))[1L]
}
funslist[[f]] <- makeGeneric(f, fdef, deflt, group = group, package = "base",
signature = signature)
funslist
}
.ShortPrimitiveSkeletons <-
list( quote(f(x,i)), quote(fgets(x,i,value=value)))
.EmptyPrimitiveSkeletons <-
list( quote(f(x)), quote(fgets(x,value=value)))
## utilities to get and set the primitive generics.
## Version below uses the environment, not the list
## in order to work with namespace for methods package
# genericForPrimitive <- function(f, where = topenv(parent.frame())) {
# what <- methodsPackageMetaName("G", f)
# if(exists(what, where))
# get(what, where)
# else
# NULL
# }
# setGenericForPrimitive <-function(f, value, where = topenv(parent.frame()))
# assign(methodsPackageMetaName("G", f), value, where)
## temporary versions while primitives are still handled by a global table
isBaseFun <- function(fun) {
is.primitive(fun) || identical(environment(fun), .BaseNamespaceEnv)
}
inBasicFuns <- function(f) {
fun <- .BasicFunsList[[f]]
!is.null(fun) && !identical(fun, FALSE)
}
dispatchIsInternal <- function(fdef) {
is.primitive(fdef@default) || is(fdef@default, "internalDispatchMethod")
}
genericForBasic <- function(f, where = topenv(parent.frame()),
mustFind = TRUE)
{
ans <- .BasicFunsList[[f]]
## this element may not exist (yet, during loading), don't test null
if(mustFind && isFALSE(ans))
stop(gettextf("methods may not be defined for primitive function %s in this version of R",
sQuote(f)),
domain = NA)
ans
}