##
## Assignment tests
##

library(compiler)

## Local assignment

### symbol
x <- 1
eval(compile(quote(x <- 2)))
stopifnot(x == 2)

### closure
`f<-` <- function(x, i, value) { x[i] <- value; x }
x <- 1
eval(compile(quote(f(x, 1) <- 2)))
stopifnot(x == 2)

### SPECIAL
`f<-` <- `[<-`
x <- 1
eval(compile(quote(f(x, 1) <- 2)))
stopifnot(x == 2)

### BUILTIN
`f<-` <- `names<-`
x <- 1
eval(compile(quote(f(x) <- "foo")))
stopifnot(identical(x, structure(1, names = "foo")))

## Super assignment

### symbol
x <- 1
eval(compile(quote((function() x <<- 2)())))
stopifnot(x == 2)

### closure
`f<-` <- function(x, i, value) { x[i] <- value; x }
x <- 1
eval(compile(quote((function() f(x, 1) <<- 2)())))
stopifnot(x == 2)

### SPECIAL
`f<-` <- `[<-`
x <- 1
eval(compile(quote((function() f(x, 1) <<- 2)())))
stopifnot(x == 2)

### BUILTIN
`f<-` <- `names<-`
x <- 1
eval(compile(quote((function() f(x) <<- "foo")())))
stopifnot(identical(x, structure(1, names = "foo")))

## Dollargets

### Default
x <- list(a = 1)
eval(compile(quote(x$a <- 2)))
stopifnot(identical(x, list(a = 2)))

### Dispatch
x <- structure(list(a = 1), class = "foo")
y <- NULL
`$<-.foo` <- function(x, tag, value) { y <<- list(tag, value); x }
eval(compile(quote(x$a <- 2)))
stopifnot(identical(y, list("a", 2)))

## Subassign

### Default
x <- 1
eval(compile(quote(x[1] <- 2)))
stopifnot(identical(x, 2))

### Dispatching
x <- structure(list(NULL), class = "foo")
y <- NULL
`[<-.foo` <- function(x, k, value) { y <<- rep(value, k); x }
eval(compile(quote(x[2] <- 3)))
stopifnot(identical(y, rep(3, 2)))

#### Missing args
x <- c(1, 2, 3)
eval(compile(quote(x[] <- c(4, 5, 6))))
stopifnot(identical(x, c(4, 5, 6)))

### Named args
x <- structure(list(NULL), class = "foo")
y <- NULL
`[<-.foo` <- function(x, k, value) { y <<- names(sys.call()[-1]); x }
eval(compile(quote(x[k = 2] <- 3)))
stopifnot(identical(y, c("", "k", "value")))

## Subassign2

### Default
x <- list(NULL)
eval(compile(quote(x[[1]] <- list(1))))
stopifnot(identical(x, list(list(1))))

### Dispatching
x <- structure(list(), class = "foo")
y <- 1
`[[<-.foo` <- function(x, i, value) { y[i] <<- value; x }
eval(compile(quote(x[[1]] <- 3)))
stopifnot(identical(y, 3))

## Nested assignments
x <- list(a = list(b = 1))
eval(compile(quote(x$a$b <- 2)))
stopifnot(identical(x, list(a = list(b = 2))))

x <- list(1, list(2))
eval(compile(quote(x[[1]][] <- 2)))
eval(compile(quote(x[[2]][[1]] <- 3)))
stopifnot(identical(x, list(2, list(3))))


## checkAssign
checkAssign <- compiler:::checkAssign
cenv <- compiler:::makeCenv(.GlobalEnv)
cntxt <- compiler:::make.toplevelContext(cenv, list(suppressAll = TRUE))
stopifnot(identical(checkAssign(quote(x <- 1), cntxt), TRUE))
stopifnot(identical(checkAssign(quote("x" <- 1), cntxt), TRUE))
stopifnot(identical(checkAssign(quote(3 <- 1), cntxt), FALSE))
stopifnot(identical(checkAssign(quote(f(x) <- 1), cntxt), TRUE))
stopifnot(identical(checkAssign(quote((f())(x) <- 1), cntxt), FALSE))
stopifnot(identical(checkAssign(quote(f(g(x)) <- 1), cntxt), TRUE))
stopifnot(identical(checkAssign(quote(f(g("x")) <- 1), cntxt), FALSE))


## flattenPlace
flattenPlace <- compiler:::flattenPlace
stopifnot(identical(flattenPlace(quote(f(g(h(x, k), j), i)))$places,
                    list(quote(f(`*tmp*`, i)),
                         quote(g(`*tmp*`, j)),
                         quote(h(`*tmp*`, k)))))
stopifnot(identical(flattenPlace(quote(f(g(h(x, k), j), i)))$origplaces,
                    list(quote(f(g(h(x, k), j), i)),
                         quote(g(h(x, k), j)),
                         quote(h(x, k)))))

## getAssignFun
getAssignFun <- compiler:::getAssignFun
stopifnot(identical(getAssignFun(quote(f)), quote(`f<-`)))
stopifnot(identical(getAssignFun("f"), NULL))
stopifnot(identical(getAssignFun(quote(f(x))), NULL))
stopifnot(identical(getAssignFun(quote(base::diag)), quote(base::`diag<-`)))
stopifnot(identical(getAssignFun(quote(base:::diag)), quote(base:::`diag<-`)))
library(compiler)

options(keep.source=TRUE)

## very minimal
x <- 2
stopifnot(eval(compile(quote(x + 1))) == 3)

## simple code generation
checkCode <- function(expr, code, optimize = 2) {
    v <- compile(expr, options = list(optimize = optimize))
    d <- .Internal(disassemble(v))[[2]][-1]
    dd <- as.integer(eval(substitute(code), getNamespace("compiler")))
    identical(d, dd)
}
x <- 2
stopifnot(checkCode(quote(x + 1),
                    c(GETVAR.OP, 1L,
                      LDCONST.OP, 2L,
                      ADD.OP, 0L,
                      RETURN.OP)))
f <- function(x) x
checkCode(quote({f(1); f(2)}),
          c(GETFUN.OP, 1L,
            PUSHCONSTARG.OP, 3L,
            CALL.OP, 4L,
            POP.OP,
            GETFUN.OP, 1L,
            PUSHCONSTARG.OP, 6L,
            CALL.OP, 7L,
            RETURN.OP))


## names and ... args
f <- function(...) list(...)
stopifnot(identical(f(1, 2), cmpfun(f)(1, 2)))

f <- function(...) list(x = ...)
stopifnot(identical(f(1, 2), cmpfun(f)(1, 2)))


## substitute and argument constant folding
f <- function(x) substitute(x)
g <- function() f(1 + 2)
v1 <- g()
f <- cmpfun(f)
g <- cmpfun(g)
v2 <- g()
stopifnot(identical(v1, v2))


## simple loops
sr <- function(x) {
    n <- length(x)
    i <- 1
    s <- 0
    repeat {
        if (i > n) break
        s <- s + x[i]
        i <- i + 1
    }
    s
}
sw <- function(x) {
    n <- length(x)
    i <- 1
    s <- 0
    while (i <= n) {
        s <- s + x[i]
        i <- i + 1
    }
    s
}
sf <- function(x) {
    s <- 0
    for (y in x)
        s <- s + y
    s
}
src <- cmpfun(sr)
swc <- cmpfun(sw)
sfc <- cmpfun(sf)
x <- 1 : 5
stopifnot(src(x) == sr(x))
stopifnot(swc(x) == sw(x))
stopifnot(sfc(x) == sf(x))


## Check that the handlers have been associated with the correct package
h <- ls(compiler:::inlineHandlers, all.names = TRUE)
p <- sub("package:", "", sapply(h, find))
pp <- sapply(h, function(n) get(n, compiler:::inlineHandlers)$package)
# stopifnot(identical(p, pp))


## Check assumption about simple .Internals
## These are .External calls now.
## stopifnot(all(sapply(compiler:::safeStatsInternals,
##                      function(f)
##                      compiler:::is.simpleInternal(get(f, "package:stats")))))

stopifnot(all(sapply(compiler:::safeBaseInternals,
                     function(f)
                     compiler:::is.simpleInternal(get(f, "package:base")))))

library(compiler)

##
## Test code for constant folding
##

makeCenv <- compiler:::makeCenv
checkConst <- compiler:::checkConst
constantFoldSym <- compiler:::constantFoldSym
constantFold <- compiler:::constantFold

## using a global environment
ce <- makeCenv(.GlobalEnv)
stopifnot(identical(constantFoldSym(quote(pi), list(env = ce, optimize = 3)),
                    checkConst(base::pi)))
stopifnot(identical(constantFoldSym(quote(pi), list(env = ce, optimize = 2)),
                    NULL))
stopifnot(identical(constantFoldSym(quote(pi), list(env = ce, optimize = 1)),
                    NULL))
stopifnot(identical(constantFoldSym(quote(pi), list(env = ce, optimize = 0)),
                    NULL))
stopifnot(identical(constantFold(quote(1 + 2), list(optimize = 3, env = ce)),
                    checkConst(1 + 2)))
stopifnot(identical(constantFold(quote(1 + 2), list(optimize = 2, env = ce)),
                    checkConst(1 + 2)))
stopifnot(identical(constantFold(quote(1 + 2), list(optimize = 1, env = ce)),
                    NULL))
stopifnot(identical(constantFold(quote(1 + 2), list(optimize = 0, env = ce)),
                    NULL))
stopifnot(identical(constantFold(quote(sqrt(2)), list(optimize = 3, env = ce)),
                    checkConst(sqrt(2))))
stopifnot(identical(constantFold(quote(sqrt(2)), list(optimize = 2, env = ce)),
                    NULL))
stopifnot(identical(constantFold(quote(sqrt(2)), list(optimize = 1, env = ce)),
                    NULL))
stopifnot(identical(constantFold(quote(sqrt(2)), list(optimize = 0, env = ce)),
                    NULL))

## using a namespace environment
ce <- makeCenv(getNamespace("stats"))
stopifnot(identical(constantFoldSym(quote(pi), list(env = ce, optimize = 3)),
                    list(value = base::pi)))
stopifnot(identical(constantFoldSym(quote(pi), list(env = ce, optimize = 2)),
                    list(value = base::pi)))
stopifnot(identical(constantFoldSym(quote(pi), list(env = ce, optimize = 1)),
                    checkConst(base::pi)))
stopifnot(identical(constantFoldSym(quote(pi), list(env = ce, optimize = 0)),
                    NULL))
stopifnot(identical(constantFold(quote(1 + 2), list(optimize = 3, env = ce)),
                    checkConst(1 + 2)))
stopifnot(identical(constantFold(quote(1 + 2), list(optimize = 2, env = ce)),
                    checkConst(1 + 2)))
stopifnot(identical(constantFold(quote(1 + 2), list(optimize = 1, env = ce)),
                    checkConst(1 + 2)))
stopifnot(identical(constantFold(quote(1 + 2), list(optimize = 0, env = ce)),
                    NULL))
stopifnot(identical(constantFold(quote(sqrt(2)), list(optimize = 3, env = ce)),
                    checkConst(sqrt(2))))
stopifnot(identical(constantFold(quote(sqrt(2)), list(optimize = 2, env = ce)),
                    checkConst(sqrt(2))))
stopifnot(identical(constantFold(quote(sqrt(2)), list(optimize = 1, env = ce)),
                    checkConst(sqrt(2))))
stopifnot(identical(constantFold(quote(sqrt(2)), list(optimize = 0, env = ce)),
                    NULL))
library(compiler)

# set to TRUE for debugging
only.print <- FALSE

testError <- function(expr, handler) {
    err <- tryCatch(expr, error = handler)
    stopifnot(identical(err, TRUE))
}

testWarning <- function(expr, handler) {
    warn <- tryCatch(expr, warning = handler)
    stopifnot(identical(warn, TRUE))
}

w <- function(expr, call = substitute(expr)) {
    if (only.print)
       testWarning(expr = expr, handler = function(e) {
           cat("WARNING-MESSAGE: \"", e$message, "\"\nWARNING-CALL: ", deparse(e$call), "\n", sep="")
           TRUE
       })
    else
       testWarning(expr = expr, handler = function(e) {
           stopifnot(identical(e$call, call))
           TRUE
       })
}

e <- function(expr, call = substitute(expr)) {
    if (only.print)
       testError(expr = expr, handler = function(e) {
           cat("ERROR-MESSAGE: \"", e$message, "\"\nERROR-CALL: ", deparse(e$call), "\n", sep="")
           TRUE
       })
    else
       testError(expr = expr, handler = function(e) {
           stopifnot(identical(e$call, call))
           TRUE
       })
}

f <- function(x = 1:2,
        y = -1,
        z = c(a=1, b=2, c=2, d=3),
        u = list(inner = c(a=1,b=2,c=3,d=4)),
        v = list(),
        ...) {


    w(x[1:3] <- 11:12)
        # quote(`[<-`(x, 1:3, value = 11:12))
    w(min(...))
    w(sqrt(y))

    e(names(z[1:2]) <- c("X", "Y", "Z"))
        # quote(`names<-`(z[1:2], value = c("X", "Y", "Z"))
    e(names(z[c(-1,1)]) <- c("X", "Y", "Z"),
        # quote(z[c(-1, 1)])) <=== this would be nice, but not possible at the moment
        quote(`*tmp*`[c(-1, 1)]))
    w(names(u$inner)[2:4] <- v[1:2] <- c("X", "Y", "Z", "U")[1:2])
        # quote(`[<-`(names(u$inner), 2:4, value = v[1:2] <- c("X", "Y", "Z", "U")[1:2]))

    ##_ Not anymore, as stopifnot() massages its error/warning message:
    ##_ e(stopifnot(is.numeric(dummy)))
}

old=options()

oldoptimize <- getCompilerOption("optimize")
oldjit <- enableJIT(3)

for (opt in 2:3) {
    setCompilerOptions(optimize=opt)
    f()
}

## test that AST and compiler errors/warnings agree

enableJIT(0)
testexpr <- function(fun) {
  resast <- tryCatch(fun(), error = function(e) e, warning = function(e) e)
  cfun <- cmpfun(fun)
  rescmp <- tryCatch(cfun(), error = function(e) e, warning = function(e) e)

  show(resast)
  show(rescmp)

  stopifnot(identical(resast, rescmp))
}

testexpr(function() { dummy()$e })
testexpr(function() { beta(-1, NULL) })
testexpr(function() { inherits(1, log) })

enableJIT(oldjit)
setCompilerOptions(optimize = oldoptimize)

library(compiler)

##
## Tests for findHomeNS()
##

findHomeNS <- compiler:::findHomeNS

## return value for an undefinded variable should be NULL
stopifnot(is.null(findHomeNS("foo", getNamespace("stats"))))
stopifnot(is.null(findHomeNS("foo", parent.env(getNamespace("stats")))))
stopifnot(is.null(findHomeNS("foo", getNamespace("base"))))

## + is found in .BaseNamespaceEnv for stats or base
stopifnot(identical(findHomeNS("+", getNamespace("stats")),
                    .BaseNamespaceEnv))
stopifnot(identical(findHomeNS("+", parent.env(getNamespace("stats"))),
                    .BaseNamespaceEnv))
stopifnot(identical(findHomeNS("+", getNamespace("base")),
                    .BaseNamespaceEnv))

## dnorm is defined in stats
stopifnot(identical(findHomeNS("dnorm", getNamespace("stats")),
                    getNamespace("stats")))
stopifnot(identical(findHomeNS("dnorm", parent.env(getNamespace("stats"))),
                    getNamespace("stats")))
stopifnot(is.null(findHomeNS("dnorm", getNamespace("base"))))

## par is available via the stats namespace since stats imports graphics
stopifnot(identical(findHomeNS("par", getNamespace("stats")),
                    getNamespace("graphics")))
stopifnot(identical(findHomeNS("par", parent.env(getNamespace("stats"))),
                    getNamespace("graphics")))
stopifnot(is.null(findHomeNS("par", getNamespace("base"))))

## palette is one of a small set of selective imports from grDevices
stopifnot(identical(findHomeNS("palette", getNamespace("stats")),
                    getNamespace("grDevices")))
stopifnot(identical(findHomeNS("palette", parent.env(getNamespace("stats"))),
                    getNamespace("grDevices")))
stopifnot(is.null(findHomeNS("palette", getNamespace("base"))))


##
## Tests for getAssignedVar
##

getAssignedVar <- compiler:::getAssignedVar
stopifnot(identical(getAssignedVar(quote("v"<-x)), "v"))
stopifnot(identical(getAssignedVar(quote(v<-x)), "v"))
stopifnot(identical(getAssignedVar(quote(f(v)<-x)), "v"))
stopifnot(identical(getAssignedVar(quote(f(g(v,2),1)<-x)), "v"))


##
## Tests for findLocals
##

findLocals <- compiler:::findLocals
cenv <- compiler:::makeCenv(.GlobalEnv)
cntxt <- compiler:::make.toplevelContext(cenv, NULL)

stopifnot(identical(findLocals(quote(x<-1), cntxt), "x"))
stopifnot(identical(findLocals(quote(f(x)<-1), cntxt), "x"))
stopifnot(identical(findLocals(quote(f(g(x,2),1)<-1), cntxt), "x"))
stopifnot(identical(findLocals(quote(x<-y<-1), cntxt), c("x","y")))
stopifnot(identical(findLocals(quote(local(x<-1,e)), cntxt), "x"))
stopifnot(identical(findLocals(quote(local(x<-1)), cntxt), character(0)))
stopifnot(identical(findLocals(quote({local<-1;local(x<-1)}), cntxt),
                    c("local", "x")))

local({
    f <- function (f, x, y) {
        local <- f
        local(x <- y)
        x
    }
    stopifnot(identical(findLocals(body(f), cntxt), c("local","x")))
})

local({
    cenv <- compiler:::addCenvVars(cenv, "local")
    cntxt <- compiler:::make.toplevelContext(cenv, NULL)
    stopifnot(identical(findLocals(quote(local(x<-1,e)), cntxt), "x"))
})

stopifnot(identical(findLocals(quote(assign(x, 3)), cntxt), character(0)))
stopifnot(identical(findLocals(quote(assign("x", 3)), cntxt), "x"))
stopifnot(identical(findLocals(quote(assign("x", 3, 4)), cntxt), character(0)))
library(compiler)

oldJIT <- enableJIT(3)

## need a test of level 1 to make sure functions are compiled

## need more tests here

repeat { break }

while(TRUE) break

for (i in 1:10) i

enableJIT(oldJIT)

library(compiler)

f <- function(x) x

g <- function(x) repeat if (x) f(return(1)) else return(2)
gc <- cmpfun(g)
stopifnot(identical(g(TRUE), gc(TRUE)))
stopifnot(identical(g(FALSE), gc(FALSE)))

h <- function(x) { repeat if (x) f(return(1)) else break; 2 }
hc <- cmpfun(h)
stopifnot(identical(h(TRUE), hc(TRUE)))
stopifnot(identical(h(FALSE), hc(FALSE)))

k <- function(x) { repeat if (x) return(1) else f(break); 2 }
kc <- cmpfun(k)
stopifnot(identical(k(TRUE), kc(TRUE)))
stopifnot(identical(k(FALSE), kc(FALSE)))

## **** need more variations on this.

## this would give an error prior to fixing a binding cache bug
f <- function(x) { for (y in x) { z <- y; g(break) } ; z }
g <- function(x) x
cmpfun(f)(c(1,2,3))

library(compiler)

# This tests tracking of source file references

options(keep.source=TRUE)
ln <- function() attr(sys.call(), "srcref")[1]

# NOTE: the block below is sensitive to formatting (newlines)

code <- quote({
    start <- ln()
    plus1 <- ln()                          # start + 1
    stopifnot(identical(plus1, start+1L))
    {
        plus4 <- ln()                         # start + 4
    }
    stopifnot(identical(plus4, start+4L))
    plus9 <- 0
    f <- function() {
        plus9 <<- ln()                       # start + 9
    }
    f()
    stopifnot(identical(plus9, start+9L))
    g <- function(x = ln()) x              # start + 13
    plus13 <- g()
    stopifnot(identical(plus13, start+13L))
    plus16 <- g(ln())                      # start + 16
    stopifnot(identical(plus16, start+13L) || identical(plus16, start+16L)) ### NOTE: see compatibility note below
    for(i in 1) plus18 <- ln()             # start + 18
    stopifnot(identical(plus18, start+18L))
    for(i in 1) { plus20 <- ln() }         # start + 20
    stopifnot(identical(plus20, start+20L))
    for(i in 1) {
        plus23 <- ln()                       # start + 23
    }
    stopifnot(identical(plus23, start+23L))
    ff <- function() for(i in 1) return(ln()) # start + 26
    plus26 <- ff()
    stopifnot(identical(plus26, start+26L))
    ff1 <- function() {
        for(i in 1) return(ln())             # start + 30
    }
    plus30 <- ff1()
    stopifnot(identical(plus30, start+30L))
})

## Compatibility note
##
## in the example above, "plus16" with the AST interpreter gets line number
## start+13, but with the compiler, it gets start+16.  The latter seems to
## be more correct, as line start+16 is where the spelling of "ln()" is.

oldoptimize <- getCompilerOption("optimize")
oldjit <- enableJIT(0)

l <- function() 1
body(l) <- code

for(jit in 0:2) {
    enableJIT(jit)
    for (opt in 0:3) {
        if (opt >=2 || jit <=2) {
            setCompilerOptions(optimize=opt)
            eval(code)
            eval(compile(code))
            body(l) <- code
            l()
            body(l) <- code
            cmpfun(l)()
            local(eval(code))
            do.call("local", list(code))
        }
    }
}

setCompilerOptions(optimize = oldoptimize)
enableJIT(oldjit)
library(compiler)

ev <- function(expr)
    tryCatch(withVisible(eval(expr, parent.frame(), baseenv())),
             error = function(e) conditionMessage(e))

f <- function(x) switch(x, x = 1, y = , z = 3, , w =, 6, v = )
fc <- cmpfun(f)

stopifnot(identical(ev(quote(fc("x"))), ev(quote(f("x")))))
stopifnot(identical(ev(quote(fc("A"))), ev(quote(f("A")))))

stopifnot(identical(ev(quote(fc(0))), ev(quote(f(0)))))
stopifnot(identical(ev(quote(fc(1))), ev(quote(f(1)))))
stopifnot(identical(ev(quote(fc(2))), ev(quote(f(2)))))
stopifnot(identical(ev(quote(fc(3))), ev(quote(f(3)))))
stopifnot(identical(ev(quote(fc(4))), ev(quote(f(4)))))
stopifnot(identical(ev(quote(fc(5))), ev(quote(f(5)))))
stopifnot(identical(ev(quote(fc(6))), ev(quote(f(6)))))
stopifnot(identical(ev(quote(fc(7))), ev(quote(f(7)))))
stopifnot(identical(ev(quote(fc(8))), ev(quote(f(8)))))


g <- function(x) switch(x, x = 1, y = , z = 3, w =, 5, v = )
gc <- cmpfun(g)

stopifnot(identical(ev(quote(gc("x"))), ev(quote(g("x")))))
stopifnot(identical(ev(quote(gc("y"))), ev(quote(g("y")))))
stopifnot(identical(ev(quote(gc("z"))), ev(quote(g("z")))))
stopifnot(identical(ev(quote(gc("w"))), ev(quote(g("w")))))
stopifnot(identical(ev(quote(gc("v"))), ev(quote(g("v")))))
stopifnot(identical(ev(quote(gc("A"))), ev(quote(g("A")))))

stopifnot(identical(ev(quote(gc(0))), ev(quote(g(0)))))
stopifnot(identical(ev(quote(gc(1))), ev(quote(g(1)))))
stopifnot(identical(ev(quote(gc(2))), ev(quote(g(2)))))
stopifnot(identical(ev(quote(gc(3))), ev(quote(g(3)))))
stopifnot(identical(ev(quote(gc(4))), ev(quote(g(4)))))
stopifnot(identical(ev(quote(gc(5))), ev(quote(g(5)))))
stopifnot(identical(ev(quote(gc(6))), ev(quote(g(6)))))
stopifnot(identical(ev(quote(gc(7))), ev(quote(g(7)))))


h <- function(x) switch(x, x = 1, y = , z = 3)
hc <- cmpfun(h)

stopifnot(identical(ev(quote(hc("x"))), ev(quote(h("x")))))
stopifnot(identical(ev(quote(hc("y"))), ev(quote(h("y")))))
stopifnot(identical(ev(quote(hc("z"))), ev(quote(h("z")))))
stopifnot(identical(ev(quote(hc("A"))), ev(quote(h("A")))))

stopifnot(identical(ev(quote(hc(0))), ev(quote(h(0)))))
stopifnot(identical(ev(quote(hc(1))), ev(quote(h(1)))))
stopifnot(identical(ev(quote(hc(2))), ev(quote(h(2)))))
stopifnot(identical(ev(quote(hc(3))), ev(quote(h(3)))))
stopifnot(identical(ev(quote(hc(4))), ev(quote(h(4)))))


k <- function(x) switch(x, x = 1, y = 2, z = 3)
kc <- cmpfun(k)

stopifnot(identical(ev(quote(kc("x"))), ev(quote(k("x")))))
stopifnot(identical(ev(quote(kc("y"))), ev(quote(k("y")))))
stopifnot(identical(ev(quote(kc("z"))), ev(quote(k("z")))))
stopifnot(identical(ev(quote(kc("A"))), ev(quote(k("A")))))

stopifnot(identical(ev(quote(kc(0))), ev(quote(k(0)))))
stopifnot(identical(ev(quote(kc(1))), ev(quote(k(1)))))
stopifnot(identical(ev(quote(kc(2))), ev(quote(k(2)))))
stopifnot(identical(ev(quote(kc(3))), ev(quote(k(3)))))
stopifnot(identical(ev(quote(kc(4))), ev(quote(k(4)))))


l <- function(x) switch(x, "a", "b", "c")
lc <- cmpfun(l)

ce <- function(expr) tryCatch(expr, error = function(e) "Error")

## both of these should raise errors but the messages will differ
stopifnot(identical(ce(lc("A")), ce(l("A"))))

stopifnot(identical(ev(quote(lc(0))), ev(quote(l(0)))))
stopifnot(identical(ev(quote(lc(1))), ev(quote(l(1)))))
stopifnot(identical(ev(quote(lc(2))), ev(quote(l(2)))))
stopifnot(identical(ev(quote(lc(3))), ev(quote(l(3)))))
stopifnot(identical(ev(quote(lc(4))), ev(quote(l(4)))))

l <- function(x) switch(x)
lc <- cmpfun(l)

cw <- function(expr) tryCatch(expr, warning = function(w) w)

stopifnot(identical(cw(l(1)), cw(lc(1))))
stopifnot(identical(cw(l("A")), cw(lc("A"))))
suppressWarnings(stopifnot(identical(withVisible(l(1)),
                                     withVisible(lc(1)))))
suppressWarnings(stopifnot(identical(withVisible(l("A")),
                                     withVisible(lc("A")))))
## Check that R_Visible is being set properly.

library(compiler)
vcheck <- function(expr)
    stopifnot(withVisible(eval(compile(substitute(expr))))$visible)

asfoo <- function(x) structure(x, class = "foo")
xfoo <- asfoo(1)

## FastMath1
vcheck(sqrt(invisible(2)))
vcheck(exp(invisible(2)))
vcheck(sqrt(invisible(2L)))
vcheck(exp(invisible(2L)))
vcheck(sqrt(invisible(xfoo)))
vcheck(exp(invisible(xfoo)))

## FastUnary
vcheck(+ invisible(2))
vcheck(- invisible(2))
vcheck(+ invisible(2L))
vcheck(- invisible(2L))
vcheck(+ invisible(xfoo))
vcheck(- invisible(xfoo))

## FastBinary
vcheck(1 + invisible(2))
vcheck(1 - invisible(2))
vcheck(3 * invisible(2))
vcheck(1 / invisible(2))
vcheck(3 ^ invisible(2))
vcheck(1 + invisible(2L))
vcheck(1L + invisible(2))
vcheck(1 + invisible(xfoo))

## FastRelop2
vcheck(1 == invisible(2))
vcheck(1 != invisible(2))
vcheck(1 < invisible(2))
vcheck(1 <= invisible(2))
vcheck(1 >= invisible(2))
vcheck(1 > invisible(2))
vcheck(1 > invisible(2L))
vcheck(1L > invisible(2L))
vcheck(1 > invisible(xfoo))

## Builtin2
vcheck(1 & invisible(2))
vcheck(0 | invisible(2))
vcheck(0 | invisible(2L))
vcheck(0L | invisible(2L))
vcheck(0 | invisible(xfoo))

## Builtin1
vcheck(! invisible(2))
vcheck(! invisible(2L))
vcheck(! invisible(xfoo))

## DO_VECSUBSET
vcheck(1[invisible(1)])
vcheck(xfoo[invisible(1)])

## MATSUBSET_PTR
vcheck(matrix(1)[1, invisible(1)])
vcheck(asfoo(matrix(1))[1, invisible(1)])

## SUBSET_N_PTR
vcheck(array(1, c(1, 1, 1))[1, 1, invisible(1)])
vcheck(asfoo(array(1, c(1, 1, 1)))[1, 1, invisible(1)])

## DO_DFLTDISPATCH
vcheck(invisible(1)[])
vcheck(matrix(1)[,invisible(1)])
## not sure how to trigger [[ issue
vcheck(c(invisible(2)))
vcheck(xfoo[])

## DOLLAR
vcheck(invisible(list(x = 1))$x)
`$.foo` <- function(x, y) invisible(x)
vcheck(xfoo$bar)

## ISINTEGER
vcheck(is.integer(invisible(1)))
vcheck(is.integer(invisible(xfoo)))

## DO_ISTYPE
vcheck(is.logical(invisible(1)))
vcheck(is.double(invisible(1)))
vcheck(is.complex(invisible(1)))
vcheck(is.character(invisible(1)))
vcheck(is.symbol(invisible(1)))

## DO_ISTEST
vcheck(is.null(invisible(1)))
vcheck(is.object(invisible(1)))
vcheck(is.numeric(invisible(1)))

## &&, ||
vcheck(invisible(TRUE) || FALSE)
vcheck(FALSE || invisible(FALSE))
vcheck(invisible(FALSE) && FALSE)
vcheck(TRUE && invisible(TRUE))

## LOG, LOGBASE, MATH1
vcheck(log(invisible(2)))
vcheck(log(2, invisible(2)))
vcheck(log(invisible(xfoo)))
vcheck(log(xfoo, invisible(2)))
vcheck(sin(invisible(2)))
vcheck(cos(invisible(2)))

## DOTCALL

## COLON, SEQLEN, SEQALONG
vcheck(1 : invisible(2))
vcheck(1 : invisible(xfoo))
vcheck(seq_len(invisible(2)))
vcheck(seq_len(invisible(xfoo)))
vcheck(seq_along(invisible(1)))
vcheck(seq_along(invisible(xfoo)))
