122 lines
4.8 KiB
R
122 lines
4.8 KiB
R
library(codetools)
|
|
assert <- function(e)
|
|
if (! e) stop(paste("assertion failed:", deparse(substitute(e))))
|
|
local({
|
|
st <- function(e) {
|
|
v <- NULL
|
|
write <- function(x)
|
|
v <<- paste(v, as.character(x), sep = "")
|
|
showTree(e, write = write)
|
|
v
|
|
}
|
|
assert(identical(st(quote(f(x))), "(f x)\n"))
|
|
assert(identical(st(quote((x+y)*z)), "(* (\"(\" (+ x y)) z)\n"))
|
|
assert(identical(st(quote(-3)), "(- 3)\n"))
|
|
})
|
|
assert(identical(constantFold(quote(3)), 3))
|
|
assert(identical(constantFold(quote(1+2)), 3))
|
|
assert(identical(constantFold(quote(1+2+x)), NULL))
|
|
assert(identical(constantFold(quote(pi)), pi))
|
|
assert(identical(constantFold(quote(pi), "pi"), NULL))
|
|
assert(identical(constantFold(quote(pi), "pi", FALSE), FALSE))
|
|
assert(identical(getAssignedVar(quote("v"<-x)), "v"))
|
|
assert(identical(getAssignedVar(quote(v<-x)), "v"))
|
|
assert(identical(getAssignedVar(quote(f(v)<-x)), "v"))
|
|
assert(identical(getAssignedVar(quote(f(g(v,2),1)<-x)), "v"))
|
|
assert(identical(findLocals(quote(x<-1)), "x"))
|
|
assert(identical(findLocals(quote(f(x)<-1)), "x"))
|
|
assert(identical(findLocals(quote(f(g(x,2),1)<-1)), "x"))
|
|
assert(identical(findLocals(quote(x<-y<-1)), c("x","y")))
|
|
assert(identical(findLocals(quote(local(x<-1,e))), "x"))
|
|
assert(identical(findLocals(quote(local(x<-1))), character(0)))
|
|
assert(identical(findLocals(quote({local<-1;local(x<-1)})), c("local", "x")))
|
|
assert(identical(findLocals(quote(local(x<-1,e)), "local"), "x"))
|
|
local({
|
|
f <- function (f, x, y) {
|
|
local <- f
|
|
local(x <- y)
|
|
x
|
|
}
|
|
assert(identical(findLocals(body(f)), c("local","x")))
|
|
})
|
|
local({
|
|
env <- new.env()
|
|
assign("local", 1, env)
|
|
assert(identical(findLocals(quote(local(x<-1,e)), env), "x"))
|
|
})
|
|
assert(identical(findLocals(quote(assign(x, 3))), character(0)))
|
|
assert(identical(findLocals(quote(assign("x", 3))), "x"))
|
|
assert(identical(findLocals(quote(assign("x", 3, 4))), character(0)))
|
|
local({
|
|
f<-function() { x <- 1; y <- 2}
|
|
assert(identical(sort(findFuncLocals(formals(f),body(f))), c("x","y")))
|
|
f<-function(u = x <- 1) y <- 2
|
|
assert(identical(sort(findFuncLocals(formals(f),body(f))), c("x","y")))
|
|
})
|
|
assert(identical(flattenAssignment(quote(x)), list(NULL, NULL)))
|
|
assert(identical(flattenAssignment(quote(f(x, 1))),
|
|
list(list(quote(x)),
|
|
list(quote("f<-"(x, 1, value = `*tmpv*`))))))
|
|
assert(identical(flattenAssignment(quote(f(g(x, 2), 1))),
|
|
list(list(quote(x), quote(g(`*tmp*`, 2))),
|
|
list(quote("f<-"(`*tmp*`, 1, value = `*tmpv*`)),
|
|
quote("g<-"(x, 2, value = `*tmpv*`))))))
|
|
assert(identical(flattenAssignment(quote(f(g(h(x, 3), 2), 1))),
|
|
list(list(quote(x),
|
|
quote(h(`*tmp*`, 3)),
|
|
quote(g(`*tmp*`, 2))),
|
|
list(quote("f<-"(`*tmp*`, 1, value = `*tmpv*`)),
|
|
quote("g<-"(`*tmp*`, 2, value = `*tmpv*`)),
|
|
quote("h<-"(x, 3, value = `*tmpv*`))))))
|
|
assert(identical(flattenAssignment(quote(f(g(h(k(x, 4), 3), 2), 1))),
|
|
list(list(quote(x),
|
|
quote(k(`*tmp*`, 4)),
|
|
quote(h(`*tmp*`, 3)),
|
|
quote(g(`*tmp*`, 2))),
|
|
list(quote("f<-"(`*tmp*`, 1, value = `*tmpv*`)),
|
|
quote("g<-"(`*tmp*`, 2, value = `*tmpv*`)),
|
|
quote("h<-"(`*tmp*`, 3, value = `*tmpv*`)),
|
|
quote("k<-"(x, 4, value = `*tmpv*`))))))
|
|
if (getRversion() >= "2.13.0")
|
|
assert(identical(flattenAssignment(quote(base::diag(x))),
|
|
list(list(quote(x)),
|
|
list(quote(base::`diag<-`(x, value = `*tmpv*`))))))
|
|
assert(identical(findGlobals(function() if (FALSE) x), "if"))
|
|
# **** need more test cases here
|
|
assert(identical(sort(findGlobals(function(x) { z <- 1; x + y + z})),
|
|
sort(c("<-", "{", "+", "y"))))
|
|
|
|
assert(identical(findGlobals(function() Quote(x)), "Quote"))
|
|
## bquote test cases (from Dirk Schumacher)
|
|
checkUsage(function() {
|
|
s <- as.symbol("y")
|
|
bquote(
|
|
`for`(.(s), 1, x)
|
|
)
|
|
}, report = stop)
|
|
|
|
checkUsage(function() {
|
|
x <- 1
|
|
bquote(.(x) * y)
|
|
}, report = stop)
|
|
|
|
checkUsage(function() {
|
|
x <- 1
|
|
bquote(.(x * 1) * y)
|
|
}, report = stop)
|
|
|
|
|
|
## more bquote tests
|
|
checkUsage(function(x) bquote(.(x) + y), report = stop)
|
|
tools::assertError(checkUsage(function() bquote(.(x)), report = stop))
|
|
|
|
## ensure within is skipped under skipWith=TRUE
|
|
col_edit <- function(x) {
|
|
x <- within(x, key <- val + 1)
|
|
x
|
|
}
|
|
# NB: suppressLocal=TRUE needed to ignore 'key' being "unused". TODO: Fix this.
|
|
checkUsage(col_edit, skipWith = TRUE, suppressLocal = TRUE, report = stop)
|
|
# now with suppressLocal=FALSE, fail
|
|
tools::assertError(checkUsage(col_edit, skipWith = TRUE, report = stop))
|