#  Automatically generated from ../noweb/compiler.nw.
#
#  File src/library/compiler/R/cmp.R
#  Part of the R package, http://www.R-project.org
#  Copyright (C) 2001-2012 Luke Tierney
#
#  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
#  http://www.r-project.org/Licenses/

##
## Compiler options
##

compilerOptions <- new.env(hash = TRUE, parent = emptyenv())
compilerOptions$optimize <- 2
compilerOptions$suppressAll <- FALSE
compilerOptions$suppressUndefined <-
    c(".Generic", ".Method", ".Random.seed", ".self")

getCompilerOption <- function(name, options = NULL) {
    if (name %in% names(options))
        options[[name]]
    else
        get(name, compilerOptions)
}


##
## General Utilities
##

pasteExpr <- function(e, prefix = "\n    ") {
    de <- deparse(e)
    if (length(de) == 1) sQuote(de)
    else paste(prefix, deparse(e), collapse="")
}

dots.or.missing <- function(args) {
    for (i in 1:length(args)) {
        a <-args[[i]]
        if (missing(a)) return(TRUE) #**** better test?
        if (typeof(a) == "symbol" && a == "...") return(TRUE)
    }
    return(FALSE)
}

any.dots <- function(args) {
    for (i in 1:length(args)) {
        a <-args[[i]]
        if (! missing(a) && typeof(a) == "symbol" && a == "...")
            return(TRUE)
    }
    return(FALSE)
}

is.ddsym <- function(name) {
    (is.symbol(name) || is.character(name)) &&
    length(grep("^\\.\\.[0-9]+$", as.character(name))) != 0
}


missingArgs <- function(args) {
    val <- logical(length(args))
    for (i in seq_along(args)) {
        a <- args[[i]]
        if (missing(a))
            val[i] <- TRUE
        else
            val[i] <- FALSE
    }
    val
}


##
## Environment utilities
##

frameTypes <- function(env) {
    top <- topenv(env)
    empty <- emptyenv()
    nl <- 0
    while (! identical(env, top)) {
        env <- parent.env(env)
        nl <- nl + 1
        if (identical(env, empty))
            stop("not a proper evaluation environment")
    }
    nn <- 0
    if (isNamespace(env)) {
        while (! identical(env, .GlobalEnv)) {
            env <- parent.env(env)
            nn <- nn + 1
            if (identical(env, empty))
                stop("not a proper evaluation environment")
        }
    }
    ng <- 0
    while (! identical(env, empty)) {
        env <- parent.env(env)
        ng <- ng + 1
    }
    rep(c("local", "namespace", "global"), c(nl, nn, ng))
}

## Given a symbol name and a namespace environment (or a namespace
## imports environment) find the namespace in which the symbol's value
## was originally defined. Returns NULL if the symbol is not found via
## the namespace.
findHomeNS <- function(sym, ns) {
    if (! isNamespace(ns)) {
        ## As a convenience this allows for 'ns' to be the imports fame
        ## of a namespace. It appears that these now have a 'name'
        ## attribute of the form 'imports:foo' if 'foo' is the
        ## namespace.
        name <- attr(ns, "name")
        if (is.null(name))
            stop("'ns' must be a namespace or a namespace imports environment")
        ns <- getNamespace(sub("imports:", "", attr(ns, "name")))
    }
    if (exists(sym, ns, inherits = FALSE))
        ns
    else if (exists(".__NAMESPACE__.", ns, inherits = FALSE)) {
        imports <- get(".__NAMESPACE__.", ns)$imports
        for (i in rev(seq_along(imports))) {
            iname <- names(imports)[i]
            ins <- getNamespace(iname)
            if (identical(imports[[i]], TRUE)) {
                if (identical(ins, .BaseNamespaceEnv))
                    exports <- .BaseNamespaceEnv
                else
                    exports <- get(".__NAMESPACE__.", ins)$exports
                if (exists(sym, exports, inherits = FALSE))
                    return(findHomeNS(sym, ins))
            }
            else {
                exports <- imports[[i]]
                pos <- match(sym, names(exports), 0)
                if (pos) {
                    ## If renaming has been used things get too
                    ## confusing so return NULL. (It is not clear if
                    ## renaming this is still supported by the
                    ## namespace code.)
                    if (sym == exports[pos])
                        return(findHomeNS(sym, ins))
                    else
                        return(NULL)
                }
            }
        }
        NULL
    }
    else NULL
}

packFrameName <- function(frame) {
    fname <- attr(frame, "name")
    if (is.character(fname))
        sub("package:", "", fname)
    else if (identical(frame , baseenv()))
        "base"
    else ""
}

nsName <- function(ns) {
    if (identical(ns, .BaseNamespaceEnv))
        "base"
    else {
        name <- ns$.__NAMESPACE__.$spec["name"]
        if (is.character(name))
            as.character(name) ## strip off names
        else ""
    }
}


##
## Finding possible local variables
##

getAssignedVar <- function(e) {
    v <- e[[2]]
    if (missing(v))
        stop(gettextf("bad assignment: %s", pasteExpr(e)),
             domain = NA)
    else if (typeof(v) %in% c("symbol", "character"))
        as.character(v)
    else {
        while (typeof(v) == "language") {
            if (length(v) < 2)
                stop(gettextf("bad assignment: %s", pasteExpr(e)),
                     domain = NA)
            v <- v[[2]]
            if (missing(v))
                stop(gettextf("bad assignment: %s", pasteExpr(e)),
                     domain = NA)
        }
        if (typeof(v) != "symbol")
            stop(gettextf("bad assignment: %s", pasteExpr(e)),
                 domain = NA)
        as.character(v)
    }
}

findLocals1 <- function(e, shadowed = character(0)) {
    if (typeof(e) == "language") {
        if (typeof(e[[1]]) %in% c("symbol", "character")) {
            v <- as.character(e[[1]])
            switch(v,
                   "=" =,
                   "<-" = unique(c(getAssignedVar(e),
                                   findLocalsList1(e[-1], shadowed))),
                   "for" = unique(c(as.character(e[2]),
                                    findLocalsList1(e[-2], shadowed))),
                   "delayedAssign" =,
                   "assign" = if (length(e) == 3 &&
                                  is.character(e[[2]]) &&
                                  length(e[[2]]) == 1)
                                  c(e[[2]], findLocals1(e[[3]], shadowed))
                              else findLocalsList1(e[1], shadowed),
                   "function" = character(0),
                   "~" = character(0),
                   "local" = if (! v %in% shadowed && length(e) == 2)
                                 character(0)
                             else findLocalsList1(e[-1], shadowed),
                   "expression" =,
                   "quote" = if (! v %in% shadowed)
                                 character(0)
                             else findLocalsList1(e[-1], shadowed),
                   findLocalsList1(e[-1], shadowed))
        }
         else findLocalsList1(e, shadowed)
    }
    else character(0)
}

findLocalsList1 <- function(elist, shadowed)
    unique(unlist(lapply(elist, findLocals1, shadowed)))

findLocals <- function(e, cntxt)
    findLocalsList(list(e), cntxt)

findLocalsList <- function(elist, cntxt) {
    initialShadowedFuns <- c("expression", "local", "quote")
    shadowed <- Filter(function(n) ! isBaseVar(n, cntxt), initialShadowedFuns)
    specialSyntaxFuns <- c("~", "<-", "=", "for", "function")
    sf <- initialShadowedFuns
    nsf <- length(sf)
    repeat {
        vals <- findLocalsList1(elist, sf)
        redefined <- sf %in% vals
        last.nsf <- nsf
        sf <- unique(c(shadowed, sf[redefined]))
        nsf <- length(sf)
        ## **** need to fix the termination condition used in codetools!!!
        if (last.nsf == nsf) {
            rdsf <- vals %in% specialSyntaxFuns
            if (any(rdsf)) {
                msg <- ngettext(sum(rdsf),
                                "local assignment to syntactic function: ",
                                "local assignments to syntactic functions: ")
                warning(msg, paste(vals[rdsf], collapse = ", "),
                        domain = NA)
            }
            return(vals)
        }
    }
}


##
## Compilation environment implementation
##

## Create a new compiler environment
## **** need to explain the structure
makeCenv <- function(env) {
    structure(list(extra = list(character(0)),
                   env = env,
                   ftypes = frameTypes(env)),
              class = "compiler_environment")
}

## Add vars to the top compiler environment frame
addCenvVars <- function(cenv, vars) {
    cenv$extra[[1]] <- union(cenv$extra[[1]], vars)
    cenv
}

## Add a new frame to a compiler environment
addCenvFrame <- function(cenv, vars) {
    cenv$extra <- c(list(character(0)), cenv$extra)
    cenv$env <- new.env(parent = cenv$env)
    cenv$ftypes <- c("local", cenv$ftypes)
    if (missing(vars))
        cenv
    else
        addCenvVars(cenv, vars)
}

## Find binding information for a variable (character or name).
## If a binding is found, return a list containing components
##   ftype -- one of "local", "namespace", "global"
##   value -- current value if available
##   frame -- frame containing the binding (not useful for "local" variables)
##   index -- index of the frame (1 for top, 2, for next one, etc.)
## Return NULL if no binding is found.
## **** drop the index, maybe value, to reduce cost? (query as needed?)
findCenvVar <- function(var, cenv) {
    if (typeof(var) == "symbol")
        var <- as.character(var)
    extra <- cenv$extra
    env <- cenv$env
    frame <- NULL
    for (i in seq_along(cenv$extra)) {
        if (var %in% extra[[i]] || exists(var, env, inherits = FALSE)) {
            frame <- env
            break
        }
        else
            env <- parent.env(env)
    }
    if (is.null(frame)) {
        empty <- emptyenv()
        while (! identical(env, empty)) {
            i <- i + 1
            if (exists(var, env, inherits = FALSE)) {
                frame <- env
                break
            }
            else
                env <- parent.env(env)
        }
    }
    if (! is.null(frame)) {
        if (exists(var, frame, inherits = FALSE) && var != "...") {
            value <- new.env(parent = emptyenv())
            delayedAssign("value", get(var, frame, inherits = FALSE),
                          assign.env = value)
        }
        else
            value <- NULL
        list(frame = frame, ftype = cenv$ftypes[i], value = value, index = i)
    }
    else
        NULL
}

isBaseVar <- function(var, cntxt) {
    info <- getInlineInfo(var, cntxt)
    (! is.null(info) &&
     (identical(info$frame, .BaseNamespaceEnv) ||
      identical(info$frame, baseenv())))
}

## augment compiler environment with function args and locals
funEnv <- function(forms, body, cntxt) {
    cntxt$env <- addCenvFrame(cntxt$env, names(forms))
    locals <- findLocalsList(c(forms, body), cntxt)
    addCenvVars(cntxt$env, locals)
}

## test whether a local version of a variable might exist
findLocVar <- function(var, cntxt) {
    cenv <- cntxt$env
    info <- findCenvVar(var, cenv)
    ! is.null(info) && info$ftype == "local"
}

## **** should this check for local functions as well?
findFunDef <- function(fun, cntxt) {
    cenv <- cntxt$env
    info <- findCenvVar(fun, cenv)
    if (! is.null(info$value) && is.function(info$value$value))
        info$value$value
    else
        NULL
}

findVar <- function(var, cntxt) {
    cenv <- cntxt$env
    info <- findCenvVar(var, cenv)
    ! is.null(info)
}


##
## Constant folding
##

maxConstSize <- 10

constModes <- c("numeric", "logical", "NULL", "complex", "character")

constNames <- c("pi", "T", "F")

checkConst <- function(e) {
    if (mode(e) %in% constModes && length(e) <= maxConstSize)
        list(value = e)
    else
        NULL
}

## Assumes all constants will be defined in base.
## Eventually allow other packages to define constants.
## Any variable with locked binding could be used if type is right.
## Allow local declaration of optimize, notinline declaration.
constantFoldSym <- function(var, cntxt) {
    var <- as.character(var)
    if (var %in% constNames && isBaseVar(var, cntxt))
        checkConst(get(var, .BaseNamespaceEnv))
    else NULL
}

## For now assume all foldable functions are in base
getFoldFun <- function(var, cntxt) {
    var <- as.character(var)
    if (var %in% foldFuns && isBaseVar(var, cntxt)) {
        val <- get(var, .BaseNamespaceEnv)
        if (is.function(val))
            val
        else
            NULL
    }
    else NULL
}

constantFoldCall <- function(e, cntxt) {
    fun <- e[[1]]
    if (typeof(fun) == "symbol") {
        ffun <- getFoldFun(fun, cntxt)
        if (! is.null(ffun)) {
            args <- as.list(e[-1])
            for (i in seq_along(args)) {
                a <- args[[i]]
                if (missing(a))
                    return(NULL)
                val <- constantFold(a, cntxt)
                if (! is.null(val))
                    args[i] <- list(val$value) ## **** in case value is NULL
                else return(NULL)
            }
            modes <- unlist(lapply(args, mode))
            if (all(modes %in% constModes)) {
                tryCatch(checkConst(do.call(ffun, args)),
                         error = function(e) NULL) ## **** issue warning??
            }
            else NULL
        }
        else NULL
    }
    else NULL
}

## **** rewrite using switch??
constantFold <- function(e, cntxt) {
    type = typeof(e)
    if (type == "language")
        constantFoldCall(e, cntxt)
    else if (type == "symbol")
        constantFoldSym(e, cntxt)
    else if (type == "promise")
        cntxt$stop(gettext("cannot constant fold literal promises"),
                   cntxt)
    else if (type == "bytecode")
        cntxt$stop(gettext("cannot constant fold literal bytecode objects"),
                   cntxt)
    else checkConst(e)
}

foldFuns <- c("+", "-", "*", "/", "^", "(",
              ">", ">=", "==", "!=", "<", "<=", "||", "&&", "!",
              "|", "&", "%%",
              "c", "rep", ":",
              "abs", "acos", "acosh", "asin", "asinh", "atan", "atan2",
              "atanh", "ceiling", "choose", "cos", "cosh", "exp", "expm1",
              "floor", "gamma", "lbeta", "lchoose", "lgamma", "log", "log10",
              "log1p", "log2", "max", "min", "prod", "range", "round",
              "seq_along", "seq.int", "seq_len", "sign", "signif",
              "sin", "sinh", "sqrt", "sum", "tan", "tanh", "trunc",
              "baseenv", "emptyenv", "globalenv",
              "Arg", "Conj", "Im", "Mod", "Re",
              "is.R")

languageFuns <- c("^", "~", "<", "<<-", "<=", "<-", "=", "==", ">", ">=",
                  "|", "||", "-", ":", "!", "!=", "/", "(", "[", "[<-", "[[",
                  "[[<-", "{", "@", "$", "$<-", "*", "&", "&&", "%/%", "%*%",
                  "%%", "+",
                  "::", ":::", "@<-",
                  "break", "for", "function", "if", "next", "repeat", "while",
                  "local", "return", "switch")


##
## Opcode constants
##

Opcodes.argc <- list(
BCMISMATCH.OP = 0,
RETURN.OP = 0,
GOTO.OP = 1,
BRIFNOT.OP = 2,
POP.OP = 0,
DUP.OP = 0,
PRINTVALUE.OP = 0,
STARTLOOPCNTXT.OP = 1,
ENDLOOPCNTXT.OP = 0,
DOLOOPNEXT.OP = 0,
DOLOOPBREAK.OP = 0,
STARTFOR.OP = 3,
STEPFOR.OP = 1,
ENDFOR.OP = 0,
SETLOOPVAL.OP = 0,
INVISIBLE.OP = 0,
LDCONST.OP = 1,
LDNULL.OP = 0,
LDTRUE.OP = 0,
LDFALSE.OP = 0,
GETVAR.OP = 1,
DDVAL.OP = 1,
SETVAR.OP = 1,
GETFUN.OP = 1,
GETGLOBFUN.OP = 1,
GETSYMFUN.OP = 1,
GETBUILTIN.OP = 1,
GETINTLBUILTIN.OP = 1,
CHECKFUN.OP = 0,
MAKEPROM.OP = 1,
DOMISSING.OP = 0,
SETTAG.OP = 1,
DODOTS.OP = 0,
PUSHARG.OP = 0,
PUSHCONSTARG.OP = 1,
PUSHNULLARG.OP = 0,
PUSHTRUEARG.OP = 0,
PUSHFALSEARG.OP = 0,
CALL.OP = 1,
CALLBUILTIN.OP = 1,
CALLSPECIAL.OP = 1,
MAKECLOSURE.OP = 1,
UMINUS.OP = 1,
UPLUS.OP = 1,
ADD.OP = 1,
SUB.OP = 1,
MUL.OP = 1,
DIV.OP = 1,
EXPT.OP = 1,
SQRT.OP = 1,
EXP.OP = 1,
EQ.OP = 1,
NE.OP = 1,
LT.OP = 1,
LE.OP = 1,
GE.OP = 1,
GT.OP = 1,
AND.OP = 1,
OR.OP = 1,
NOT.OP = 1,
DOTSERR.OP = 0,
STARTASSIGN.OP = 1,
ENDASSIGN.OP = 1,
STARTSUBSET.OP = 2,
DFLTSUBSET.OP = 0,
STARTSUBASSIGN.OP = 2,
DFLTSUBASSIGN.OP = 0,
STARTC.OP = 2,
DFLTC.OP = 0,
STARTSUBSET2.OP = 2,
DFLTSUBSET2.OP = 0,
STARTSUBASSIGN2.OP = 2,
DFLTSUBASSIGN2.OP = 0,
DOLLAR.OP = 2,
DOLLARGETS.OP = 2,
ISNULL.OP = 0,
ISLOGICAL.OP = 0,
ISINTEGER.OP = 0,
ISDOUBLE.OP = 0,
ISCOMPLEX.OP = 0,
ISCHARACTER.OP = 0,
ISSYMBOL.OP = 0,
ISOBJECT.OP = 0,
ISNUMERIC.OP = 0,
NVECELT.OP = 0,
NMATELT.OP = 0,
SETNVECELT.OP = 0,
SETNMATELT.OP = 0,
AND1ST.OP = 2,
AND2ND.OP = 1,
OR1ST.OP = 2,
OR2ND.OP = 1,
GETVAR_MISSOK.OP = 1,
DDVAL_MISSOK.OP = 1,
VISIBLE.OP = 0,
SETVAR2.OP = 1,
STARTASSIGN2.OP = 1,
ENDASSIGN2.OP = 1,
SETTER_CALL.OP = 2,
GETTER_CALL.OP = 1,
SWAP.OP = 0,
DUP2ND.OP = 0,
SWITCH.OP = 4,
RETURNJMP.OP = 0
)

Opcodes.names <- names(Opcodes.argc)

BCMISMATCH.OP <- 0
RETURN.OP <- 1
GOTO.OP <- 2
BRIFNOT.OP <- 3
POP.OP <- 4
DUP.OP <- 5
PRINTVALUE.OP <- 6
STARTLOOPCNTXT.OP <- 7
ENDLOOPCNTXT.OP <- 8
DOLOOPNEXT.OP <- 9
DOLOOPBREAK.OP <- 10
STARTFOR.OP <- 11
STEPFOR.OP <- 12
ENDFOR.OP <- 13
SETLOOPVAL.OP <- 14
INVISIBLE.OP <- 15
LDCONST.OP <- 16
LDNULL.OP <- 17
LDTRUE.OP <- 18
LDFALSE.OP <- 19
GETVAR.OP <- 20
DDVAL.OP <- 21
SETVAR.OP <- 22
GETFUN.OP <- 23
GETGLOBFUN.OP <- 24
GETSYMFUN.OP <- 25
GETBUILTIN.OP <- 26
GETINTLBUILTIN.OP <- 27
CHECKFUN.OP <- 28
MAKEPROM.OP <- 29
DOMISSING.OP <- 30
SETTAG.OP <- 31
DODOTS.OP <- 32
PUSHARG.OP <- 33
PUSHCONSTARG.OP <- 34
PUSHNULLARG.OP <- 35
PUSHTRUEARG.OP <- 36
PUSHFALSEARG.OP <- 37
CALL.OP <- 38
CALLBUILTIN.OP <- 39
CALLSPECIAL.OP <- 40
MAKECLOSURE.OP <- 41
UMINUS.OP <- 42
UPLUS.OP <- 43
ADD.OP <- 44
SUB.OP <- 45
MUL.OP <- 46
DIV.OP <- 47
EXPT.OP <- 48
SQRT.OP <- 49
EXP.OP <- 50
EQ.OP <- 51
NE.OP <- 52
LT.OP <- 53
LE.OP <- 54
GE.OP <- 55
GT.OP <- 56
AND.OP <- 57
OR.OP <- 58
NOT.OP <- 59
DOTSERR.OP <- 60
STARTASSIGN.OP <- 61
ENDASSIGN.OP <- 62
STARTSUBSET.OP <- 63
DFLTSUBSET.OP <- 64
STARTSUBASSIGN.OP <- 65
DFLTSUBASSIGN.OP <- 66
STARTC.OP <- 67
DFLTC.OP <- 68
STARTSUBSET2.OP <- 69
DFLTSUBSET2.OP <- 70
STARTSUBASSIGN2.OP <- 71
DFLTSUBASSIGN2.OP <- 72
DOLLAR.OP <- 73
DOLLARGETS.OP <- 74
ISNULL.OP <- 75
ISLOGICAL.OP <- 76
ISINTEGER.OP <- 77
ISDOUBLE.OP <- 78
ISCOMPLEX.OP <- 79
ISCHARACTER.OP <- 80
ISSYMBOL.OP <- 81
ISOBJECT.OP <- 82
ISNUMERIC.OP <- 83
NVECELT.OP <- 84
NMATELT.OP <- 85
SETNVECELT.OP <- 86
SETNMATELT.OP <- 87
AND1ST.OP <- 88
AND2ND.OP <- 89
OR1ST.OP <- 90
OR2ND.OP <- 91
GETVAR_MISSOK.OP <- 92
DDVAL_MISSOK.OP <- 93
VISIBLE.OP <- 94
SETVAR2.OP <- 95
STARTASSIGN2.OP <- 96
ENDASSIGN2.OP <- 97
SETTER_CALL.OP <- 98
GETTER_CALL.OP <- 99
SWAP.OP <- 100
DUP2ND.OP <- 101
SWITCH.OP <- 102
RETURNJMP.OP <- 103


##
## Code buffer implementation
##

make.codeBuf <- function(expr) {
    codeBuf <- list(.Internal(bcVersion()))
    codeCount <- 1
    putcode <- function(...) {
        new <- list(...)
        newLen <- length(new)
        while (codeCount + newLen > length(codeBuf))
            codeBuf <<- c(codeBuf, vector("list", length(codeBuf)))
        codeBuf[(codeCount + 1) : (codeCount + newLen)] <<- new
        codeCount <<- codeCount + newLen
    }
    getcode <- function() as.integer(codeBuf[1 : codeCount])
    constBuf <- vector("list", 1)
    constCount <- 0
    putconst <- function(x) {
        if (constCount == length(constBuf))
            constBuf <<- .Internal(growconst(constBuf))
        i <- .Internal(putconst(constBuf, constCount, x))
        if (i == constCount)
            constCount <<- constCount + 1
        i
    }
    getconst <- function()
        .Internal(getconst(constBuf, constCount))
    idx <- 0
    labels <- vector("list")
    makelabel <- function() { idx <<- idx + 1; paste0("L", idx) }
    putlabel <- function(name) labels[[name]] <<- codeCount
    patchlabels <- function() {
        offset <- function(lbl) {
            if (is.null(labels[[lbl]]))
                stop(gettextf("no offset recorded for label \"%s\"", lbl),
                     domain = NA)
            labels[[lbl]]
        }
        for (i in 1 : codeCount) {
            v <- codeBuf[[i]]
            if (is.character(v))
                codeBuf[[i]] <<- offset(v)
            else if (typeof(v) == "list") {
                off <- as.integer(lapply(v, offset))
                ci <- putconst(off)
                codeBuf[[i]] <<- ci
            }
        }
    }
    cb <- list(code = getcode,
               const = getconst,
               putcode = putcode,
               putconst = putconst,
               makelabel = makelabel,
               putlabel = putlabel,
               patchlabels = patchlabels)
    cb$putconst(expr) ## insert expression as first constant.
    cb
}

codeBufCode <- function(cb) {
    cb$patchlabels()
    .Internal(mkCode(cb$code(), cb$const()))
}

genCode <- function(e, cntxt, gen = NULL) {
    cb <- make.codeBuf(e)
    if (is.null(gen))
        cmp(e, cb, cntxt)
    else
        gen(cb, cntxt)
    codeBufCode(cb)
}


##
## Compiler contexts
##

make.toplevelContext <- function(cenv, options = NULL)
    structure(list(tailcall = TRUE,
                   needRETURNJMP = FALSE,
                   env = cenv,
                   optimize = getCompilerOption("optimize", options),
                   suppressAll = getCompilerOption("suppressAll", options),
                   suppressUndefined = getCompilerOption("suppressUndefined",
                                                         options),
                   call = NULL,
                   stop = function(msg, cntxt)
                       stop(simpleError(msg, cntxt$call)),
                   warn = function(x, cntxt) cat(paste("Note:", x, "\n"))),
              class = "compiler_context")

make.callContext <- function(cntxt, call) {
    cntxt$call <- call
    cntxt
}

make.promiseContext <- function(cntxt) {
    cntxt$tailcall <- TRUE
    cntxt$needRETURNJMP <- TRUE
    if (! is.null(cntxt$loop))
        cntxt$loop$gotoOK <- FALSE
    cntxt
}

make.functionContext <- function(cntxt, forms, body) {
    nenv <- funEnv(forms, body, cntxt)
    ncntxt <- make.toplevelContext(nenv)
    ncntxt$optimize <- cntxt$optimize
    ncntxt$suppressAll <- cntxt$suppressAll
    ncntxt$suppressUndefined <- cntxt$suppressUndefined
    ncntxt
}

make.nonTailCallContext <- function(cntxt) {
    cntxt$tailcall <- FALSE
    cntxt
}

make.argContext <- function(cntxt) {
    cntxt$tailcall <- FALSE
    if (! is.null(cntxt$loop))
        cntxt$loop$gotoOK <- FALSE
    cntxt
}

make.noValueContext <- function(cntxt) {
    cntxt$tailcall <- FALSE
    cntxt
}

make.loopContext <- function(cntxt, loop.label, end.label) {
    ncntxt <- make.noValueContext(cntxt)
    ncntxt$loop <- list(loop = loop.label, end = end.label, gotoOK = TRUE)
    ncntxt
}


##
## Compiler top level
##

cmp <- function(e, cb, cntxt) {
    ce <- constantFold(e, cntxt)
    if (is.null(ce)) {
        if (typeof(e) == "language")
            cmpCall(e, cb, cntxt)
        else if (typeof(e) == "symbol")
            cmpSym(e, cb, cntxt)
        else if (typeof(e) == "bytecode")
            cntxt$stop(gettext("cannot compile byte code literals in code"),
                       cntxt)
        else if (typeof(e) == "promise")
            cntxt$stop(gettext("cannot compile promise literals in code"),
                       cntxt)
        else
            cmpConst(e, cb, cntxt)
    }
    else
        cmpConst(ce$value, cb, cntxt)
}

cmpConst <- function(val, cb, cntxt) {
    if (identical(val, NULL))
        cb$putcode(LDNULL.OP)
    else if (identical(val, TRUE))
        cb$putcode(LDTRUE.OP)
    else if (identical(val, FALSE))
        cb$putcode(LDFALSE.OP)
    else {
        ci <- cb$putconst(val)
        cb$putcode(LDCONST.OP, ci)
    }
    if (cntxt$tailcall) cb$putcode(RETURN.OP)
}

cmpSym <- function(sym, cb, cntxt, missingOK = FALSE) {
    if (sym == "...") {
        notifyWrongDotsUse("...", cntxt)
        cb$putcode(DOTSERR.OP)
    }
    else if (is.ddsym(sym)) {
        if (! findLocVar("...", cntxt))
            notifyWrongDotsUse(sym, cntxt)
        ci <- cb$putconst(sym)
        if (missingOK)
            cb$putcode(DDVAL_MISSOK.OP, ci)
        else
            cb$putcode(DDVAL.OP, ci)
        if (cntxt$tailcall) cb$putcode(RETURN.OP)
    }
    else {
        if (! findVar(sym, cntxt))
            notifyUndefVar(sym, cntxt)
        ci <- cb$putconst(sym)
        if (missingOK)
            cb$putcode(GETVAR_MISSOK.OP, ci)
        else
            cb$putcode(GETVAR.OP, ci)
        if (cntxt$tailcall) cb$putcode(RETURN.OP)
    }
}

cmpCall <- function(call, cb, cntxt) {
    cntxt <- make.callContext(cntxt, call)
    fun <- call[[1]]
    args <- call[-1]
    if (typeof(fun) == "symbol") {
        if (! tryInline(call, cb, cntxt)) {
            if (findLocVar(fun, cntxt))
                notifyLocalFun(fun, cntxt)
            else {
                def <- findFunDef(fun, cntxt)
                if (is.null(def))
                    notifyUndefFun(fun, cntxt)
                else
                    checkCall(def, call, function(w) notifyBadCall(w, cntxt))
            }
            cmpCallSymFun(fun, args, call, cb, cntxt)
        }
    }
    else {
        ## **** this hack is needed for now because of the way the
        ## **** parser handles break() and next() calls
        if (typeof(fun) == "language" && typeof(fun[[1]]) == "symbol" &&
            as.character(fun[[1]]) %in% c("break", "next"))
            return(cmp(fun, cb, cntxt))
        cmpCallExprFun(fun, args, call, cb, cntxt)
    }
}

cmpCallSymFun <- function(fun, args, call, cb, cntxt) {
    ci <- cb$putconst(fun)
    cb$putcode(GETFUN.OP, ci)
    cmpCallArgs(args, cb, cntxt)
    ci <- cb$putconst(call)
    cb$putcode(CALL.OP, ci)
    if (cntxt$tailcall) cb$putcode(RETURN.OP)
}

cmpCallExprFun <- function(fun, args, call, cb, cntxt) {
    ncntxt <- make.nonTailCallContext(cntxt)
    cmp(fun, cb, ncntxt)
    cb$putcode(CHECKFUN.OP)
    cmpCallArgs(args, cb, cntxt)
    ci <- cb$putconst(call)
    cb$putcode(CALL.OP, ci)
    if (cntxt$tailcall) cb$putcode(RETURN.OP)
}

cmpCallArgs <- function(args, cb, cntxt) {
    names <- names(args)
    pcntxt <- make.promiseContext(cntxt)
    for (i in seq_along(args)) {
        a <- args[[i]]
        n <- names[[i]]
        if (missing(a)) { ## better test for missing??
            cb$putcode(DOMISSING.OP)
            cmpTag(n, cb)
        }
        else if (is.symbol(a) && a == "...") {
            if (! findLocVar("...", cntxt))
                notifyWrongDotsUse("...", cntxt)
            cb$putcode(DODOTS.OP)
        }
        else if (typeof(a) == "bytecode")
            cntxt$stop(gettext("cannot compile byte code literals in code"),
                       cntxt)
        else if (typeof(a) == "promise")
            cntxt$stop(gettext("cannot compile promise literals in code"),
                       cntxt)
        else {
            if (is.symbol(a) || typeof(a) == "language") {
                ci <- cb$putconst(genCode(a, pcntxt))
                cb$putcode(MAKEPROM.OP, ci)
            }
            else
                cmpConstArg(a, cb, cntxt)
            cmpTag(n, cb)
        }
    }
}

cmpConstArg <- function(a, cb, cntxt) {
    if (identical(a, NULL))
        cb$putcode(PUSHNULLARG.OP)
    else if (identical(a, TRUE))
        cb$putcode(PUSHTRUEARG.OP)
    else if (identical(a, FALSE))
        cb$putcode(PUSHFALSEARG.OP)
    else {
        ci <- cb$putconst(a)
        cb$putcode(PUSHCONSTARG.OP, ci)
    }
}

## **** clean up to use tryCatch
## **** figure out how to handler multi-line deparses
## ****     e.g. checkCall(`{`, quote({}))
## **** better design would capture error object, wrap it up, and pass it on
checkCall <- function(def, call, signal = warning) {
    if (typeof(def) %in% c("builtin", "special"))
        def <- args(def)
    if (typeof(def) != "closure" || any.dots(call))
        NA
    else {
        old <-options()$show.error.messages
        if (is.null(old)) old <- TRUE
        options(show.error.messages=FALSE)
        msg <- try({match.call(def, call); NULL})
        options(show.error.messages=old)
        if (! is.null(msg)) {
            msg <- sub("\n$", "", sub("^E.*: ", "", msg))
            emsg <- gettextf("possible error in '%s': %s",
                             deparse(call, 20)[1], msg)
            if (! is.null(signal)) signal(emsg)
            FALSE
        }
        else TRUE
    }
}

## **** need to handle ... and ..n arguments specially
## **** separate call opcode for calls with named args?
## **** for (a in e[[-1]]) ... goes into infinite loop

cmpTag <- function(n, cb) {
    if (! is.null(n) && n != "") {
        ci <- cb$putconst(as.name(n))
        cb$putcode(SETTAG.OP, ci)
    }
}


##
## Inlining mechanism
##

inlineHandlers <- new.env(hash = TRUE, parent = emptyenv())

setInlineHandler <- function(name, h, package = "base") {
    if (exists(name, inlineHandlers, inherits = FALSE)) {
        entry <- get(name, inlineHandlers)
        if (entry$package != package) {
            fmt <- "handler for '%s' is already defined for another package"
            stop(gettextf(fmt, name), domain = NA)
        }
    }
    entry <- list(handler = h, package = package)
    assign(name, entry, inlineHandlers)
}

getInlineHandler <- function(name, package = "base") {
    if (exists(name, inlineHandlers, inherits = FALSE)) {
        hinfo <- get(name, inlineHandlers)
        if (hinfo$package == package)
            hinfo$handler
        else NULL
    }
    else NULL
}

haveInlineHandler <- function(name, package = "base") {
    if (exists(name, inlineHandlers, inherits = FALSE)) {
        hinfo <- get(name, inlineHandlers)
        package == hinfo$package
    }
    else FALSE
}

## tryInline implements the rule permitting inlining as they stand now:
## Inlining is controlled by the optimize compiler option, with possible
## values 0, 1, 2, which mean
##
##   optimize = 0 -- no inlining
##   optimize = 1 -- can inline syntactically special functions and
##                   functions found via a namespace
##   optimize = 2 -- can inline any functions from case packages
##
## This can easily be modified to allow functions to do things like
##
##     declare(optimize = 2)
##
## or
##
##     declare(notinline = c("diag", "dim"))
##
## **** need to figure out if there is a sensible way to declare things at
## **** the package level

getInlineInfo <- function(name, cntxt) {
    optimize <- cntxt$optimize
    if (optimize > 0) {
        info <- findCenvVar(name, cntxt$env)
        if (is.null(info))
            NULL
        else {
            ftype <- info$ftype
            frame <- info$frame
            if (ftype == "namespace") {
                if (! isNamespace(frame)) {
                    ## should be the import frame of the current topenv
                    top <- topenv(cntxt$env$env)
                    if (! isNamespace(top) ||
                        ! identical(frame, parent.env(top)))
                        cntxt$stop(gettext("bad namespace import frame"))
                    frame <- top
                }
                info$package <- nsName(findHomeNS(name, frame))
                info
            }
            else if (ftype == "global" &&
                     (optimize >= 3 ||
                      (optimize >= 2 && name %in% languageFuns))) {
                info$package <- packFrameName(frame)
                info
            }
            else NULL
        }
    }
    else NULL
}

tryInline <- function(e, cb, cntxt) {
    name <- as.character(e[[1]])
    info <- getInlineInfo(name, cntxt)
    if (is.null(info))
        FALSE
    else {
        h <- getInlineHandler(name, info$package)
        if (! is.null(h))
            h(e, cb, cntxt)
        else FALSE
    }
}


##
## Inline handlers for some SPECIAL functions
##

setInlineHandler("function", function(e, cb, cntxt) {
    forms <- e[[2]]
    body <- e[[3]]
    ncntxt <- make.functionContext(cntxt, forms, body)
    cbody <- genCode(body, ncntxt)
    ci <- cb$putconst(list(forms, cbody))
    cb$putcode(MAKECLOSURE.OP, ci)
    if (cntxt$tailcall) cb$putcode(RETURN.OP)
    TRUE
})

setInlineHandler("{", function(e, cb, cntxt) {
    n <- length(e)
    if (n == 1)
        cmp(NULL, cb, cntxt)
    else {
        if (n > 2) {
            ncntxt <- make.noValueContext(cntxt)
            for (i in 2 : (n - 1)) {
                cmp(e[[i]], cb, ncntxt)
                cb$putcode(POP.OP)
            }
        }
        cmp(e[[n]], cb, cntxt)
    }
    TRUE
})

setInlineHandler("if", function(e, cb, cntxt) {
    ## **** test for missing, ...
    test <- e[[2]]
    then.expr <- e[[3]]
    if (length(e) == 4) {
        have.else.expr <- TRUE
        else.expr <- e[[4]]
    }
    else have.else.expr <- FALSE
    ct <- constantFold(test, cntxt)
    if (! is.null(ct) && is.logical(ct$value) && length(ct$value) == 1
        && ! is.na(ct$value)) {
        if (ct$value)
            cmp(then.expr, cb, cntxt)
        else if (have.else.expr)
            cmp(else.expr, cb, cntxt)
        else if (cntxt$tailcall) {
            cb$putcode(LDNULL.OP)
            cb$putcode(INVISIBLE.OP)
            cb$putcode(RETURN.OP)
        }
        else cb$putcode(LDNULL.OP)
        return(TRUE)
    }
    ncntxt <- make.nonTailCallContext(cntxt)
    cmp(test, cb, ncntxt)
    callidx <- cb$putconst(e)
    else.label <- cb$makelabel()
    cb$putcode(BRIFNOT.OP, callidx, else.label)
    cmp(then.expr, cb, cntxt)
    if (cntxt$tailcall) {
        cb$putlabel(else.label)
        if (have.else.expr)
            cmp(else.expr, cb, cntxt)
        else {
            cb$putcode(LDNULL.OP)
            cb$putcode(INVISIBLE.OP)
            cb$putcode(RETURN.OP)
        }
    }
    else {
        end.label <- cb$makelabel()
        cb$putcode(GOTO.OP, end.label)
        cb$putlabel(else.label)
        if (have.else.expr)
            cmp(else.expr, cb, cntxt)
        else
            cb$putcode(LDNULL.OP)
        cb$putlabel(end.label)
    }
    TRUE
})

setInlineHandler("&&", function(e, cb, cntxt) {
    ## **** arity check??
    ncntxt <- make.argContext(cntxt)
    callidx <- cb$putconst(e)
    label <- cb$makelabel()
    cmp(e[[2]], cb, ncntxt)
    cb$putcode(AND1ST.OP, callidx, label)
    cmp(e[[3]], cb, ncntxt)
    cb$putcode(AND2ND.OP, callidx)
    cb$putlabel(label)
    if (cntxt$tailcall)
        cb$putcode(RETURN.OP)
    TRUE
})

setInlineHandler("||", function(e, cb, cntxt) {
    ## **** arity check??
    ncntxt <- make.argContext(cntxt)
    callidx <- cb$putconst(e)
    label <- cb$makelabel()
    cmp(e[[2]], cb, ncntxt)
    cb$putcode(OR1ST.OP, callidx, label)
    cmp(e[[3]], cb, ncntxt)
    cb$putcode(OR2ND.OP, callidx)
    cb$putlabel(label)
    if (cntxt$tailcall)
        cb$putcode(RETURN.OP)
    TRUE
})


##
## Inline handlers for assignment expressions
##

setterInlineHandlers <- new.env(hash = TRUE, parent = emptyenv())

setSetterInlineHandler <- function(name, h, package = "base") {
    if (exists(name, setterInlineHandlers, inherits = FALSE)) {
        entry <- get(name, setterInlineHandlers)
        if (entry$package != package) {
            fmt <- "handler for '%s' is already defined for another package"
            stop(gettextf(fmt, name), domain = NA)
        }
    }
    entry <- list(handler = h, package = package)
    assign(name, entry, setterInlineHandlers)
}

getSetterInlineHandler <- function(name, package = "base") {
    if (exists(name, setterInlineHandlers, inherits = FALSE)) {
        hinfo <- get(name, setterInlineHandlers)
        if (hinfo$package == package)
            hinfo$handler
        else NULL
    }
    else NULL
}

trySetterInline <- function(afun, place, call, cb, cntxt) {
    name <- as.character(afun)
    info <- getInlineInfo(name, cntxt)
    if (is.null(info))
        FALSE
    else {
        h <- getSetterInlineHandler(name, info$package)
        if (! is.null(h))
            h(afun, place, call, cb, cntxt)
        else FALSE
    }
}

getterInlineHandlers <- new.env(hash = TRUE, parent = emptyenv())

setGetterInlineHandler <- function(name, h, package = "base") {
    if (exists(name, getterInlineHandlers, inherits = FALSE)) {
        entry <- get(name, getterInlineHandlers)
        if (entry$package != package) {
            fmt <- "handler for '%s' is already defined for another package"
            stop(gettextf(fmt, name), domain = NA)
        }
    }
    entry <- list(handler = h, package = package)
    assign(name, entry, getterInlineHandlers)
}

getGetterInlineHandler <- function(name, package = "base") {
    if (exists(name, getterInlineHandlers, inherits = FALSE)) {
        hinfo <- get(name, getterInlineHandlers)
        if (hinfo$package == package)
            hinfo$handler
        else NULL
    }
    else NULL
}

tryGetterInline <- function(call, cb, cntxt) {
    name <- as.character(call[[1]])
    info <- getInlineInfo(name, cntxt)
    if (is.null(info))
        FALSE
    else {
        h <- getGetterInlineHandler(name, info$package)
        if (! is.null(h))
            h(call, cb, cntxt)
        else FALSE
    }
}

cmpAssign <- function(e, cb, cntxt) {
    if (! checkAssign(e, cntxt))
        return(cmpSpecial(e, cb, cntxt))
    superAssign <- as.character(e[[1]]) == "<<-"
    lhs <- e[[2]]
    value <- e[[3]]
    symbol <- as.name(getAssignedVar(e))
    if (superAssign && ! findVar(symbol, cntxt))
        notifyNoSuperAssignVar(symbol, cntxt)
    if (is.name(lhs) || is.character(lhs))
        cmpSymbolAssign(symbol, value, superAssign, cb, cntxt)
    else if (typeof(lhs) == "language")
        cmpComplexAssign(symbol, lhs, value, superAssign, cb, cntxt)
    else cmpSpecial(e, cb, cntxt) # punt for now
}

flattenPlace <- function(place) {
    places <- NULL
    while (typeof(place) == "language") {
        if (length(place) < 2)
            stop("bad assignment 1")
        tplace <- place
        tplace[[2]] <- as.name("*tmp*")
        places <- c(places, list(tplace))
        place <- place[[2]]
    }
    if (typeof(place) != "symbol")
        stop("bad assignment 2")
    places
}

cmpGetterCall <- function(place, cb, cntxt) {
    ncntxt <- make.callContext(cntxt, place)
    fun <- place[[1]]
    if (typeof(fun) == "symbol") {
        if (! tryGetterInline(place, cb, ncntxt)) {
            ci <- cb$putconst(fun)
            cb$putcode(GETFUN.OP, ci)
            cb$putcode(PUSHNULLARG.OP)
            cmpCallArgs(place[-c(1, 2)], cb, ncntxt)
            cci <- cb$putconst(place)
            cb$putcode(GETTER_CALL.OP, cci)
            cb$putcode(SWAP.OP)
        }
    }
    else {
        cmp(fun, cb, ncntxt)
        cb$putcode(CHECKFUN.OP)
        cb$putcode(PUSHNULLARG.OP)
        cmpCallArgs(place[-c(1, 2)], cb, ncntxt)
        cci <- cb$putconst(place)
        cb$putcode(GETTER_CALL.OP, cci)
        cb$putcode(SWAP.OP)
    }
}

checkAssign <- function(e, cntxt) {
    if (length(e) != 3)
        FALSE
    else {
        place <- e[[2]]
        if (typeof(place) == "symbol" ||
            (typeof(place) == "character" && length(place) == 1))
            TRUE
        else {
            while (typeof(place) == "language") {
                fun <- place[[1]]
                if (typeof(fun) != "symbol" &&
                    ! (typeof(fun) == "language" && length(fun) == 3 &&
                       typeof(fun[[1]]) == "symbol" &&
                       as.character(fun[[1]]) %in% c("::", ":::"))) {
                    notifyBadAssignFun(fun, cntxt)
                    return(FALSE)
                }
                place = place[[2]]
            }
            if (typeof(place) == "symbol")
                TRUE
            else FALSE
        }
    }
}

cmpSymbolAssign <- function(symbol, value, superAssign, cb, cntxt) {
    ncntxt <- make.nonTailCallContext(cntxt)
    cmp(value, cb, ncntxt)
    ci <- cb$putconst(symbol)
    if (superAssign)
        cb$putcode(SETVAR2.OP, ci)
    else
        cb$putcode(SETVAR.OP, ci)
    if (cntxt$tailcall) {
        cb$putcode(INVISIBLE.OP)
        cb$putcode(RETURN.OP)
    }
    TRUE
}

cmpComplexAssign <- function(symbol, lhs, value, superAssign, cb, cntxt) {
    if (superAssign) {
        startOP <- STARTASSIGN2.OP
        endOP <- ENDASSIGN2.OP
    }
    else {
        if (! findVar(symbol, cntxt))
            notifyUndefVar(symbol, cntxt)
        startOP <- STARTASSIGN.OP
        endOP <- ENDASSIGN.OP
    }
    ncntxt <- make.nonTailCallContext(cntxt)
    cmp(value, cb, ncntxt)
    csi <- cb$putconst(symbol)
    cb$putcode(startOP, csi)

    ncntxt <- make.argContext(cntxt)
    flatPlace <- flattenPlace(lhs)
    for (p in rev(flatPlace[-1]))
        cmpGetterCall(p, cb, ncntxt)
    cmpSetterCall(flatPlace[[1]], value, cb, ncntxt)
    for (p in flatPlace[-1])
        cmpSetterCall(p, as.name("*vtmp*"), cb, ncntxt)

    cb$putcode(endOP, csi)
    if (cntxt$tailcall) {
        cb$putcode(INVISIBLE.OP)
        cb$putcode(RETURN.OP)
    }
    TRUE;
}

cmpSetterCall <- function(place, vexpr, cb, cntxt) {
    afun <- getAssignFun(place[[1]])
    acall <- as.call(c(afun, as.list(place[-1]), list(value = vexpr)))
    acall[[2]] <- as.name("*tmp*")
    ncntxt <- make.callContext(cntxt, acall)
    if (is.null(afun))
        ## **** warn instead and arrange for cmpSpecial?
        ## **** or generate code to signal runtime error?
        cntxt$stop(gettext("invalid function in complex assignment"))
    else if (typeof(afun) == "symbol") {
        if (! trySetterInline(afun, place, acall, cb, ncntxt)) {
            ci <- cb$putconst(afun)
            cb$putcode(GETFUN.OP, ci)
            cb$putcode(PUSHNULLARG.OP)
            cmpCallArgs(place[-c(1, 2)], cb, ncntxt)
            cci <- cb$putconst(acall)
            cvi <- cb$putconst(vexpr)
            cb$putcode(SETTER_CALL.OP, cci, cvi)
        }
    }
    else {
        cmp(afun, cb, ncntxt)
        cb$putcode(CHECKFUN.OP)
        cb$putcode(PUSHNULLARG.OP)
        cmpCallArgs(place[-c(1, 2)], cb, ncntxt)
        cci <- cb$putconst(acall)
        cvi <- cb$putconst(vexpr)
        cb$putcode(SETTER_CALL.OP, cci, cvi)
    }
}

getAssignFun <- function(fun) {
    if (typeof(fun) == "symbol")
        as.name(paste0(fun, "<-"))
    else {
        ## check for and handle foo::bar(x) <- y assignments here
        if (typeof(fun) == "language" && length(fun) == 3 &&
            (as.character(fun[[1]]) %in% c("::", ":::")) &&
            typeof(fun[[2]]) == "symbol" && typeof(fun[[3]]) == "symbol") {
            afun <- fun
            afun[[3]] <- as.name(paste0(fun[[3]],"<-"))
            afun
        }
        else NULL
    }
}

cmpSetterDispatch <- function(start.op, dflt.op, afun, place, call, cb, cntxt) {
    if (any.dots(place))
        FALSE ## punt
    else {
        ci <- cb$putconst(call)
        end.label <- cb$makelabel()
        cb$putcode(start.op, ci, end.label)
        if (length(place) > 2) {
            args <- place[-(1:2)]
            cmpBuiltinArgs(args, names(args), cb, cntxt, TRUE)
        }
        cb$putcode(dflt.op)
        cb$putlabel(end.label)
        TRUE
    }
}

setInlineHandler("<-", cmpAssign)
setInlineHandler("=", cmpAssign)
setInlineHandler("<<-", cmpAssign)

setSetterInlineHandler("$<-", function(afun, place, call, cb, cntxt) {
    if (any.dots(place) || length(place) != 3)
        FALSE
    else {
        sym <- place[[3]]
        if (is.character(sym))
            sym <- as.name(sym)
        if (is.name(sym)) {
            ci <- cb$putconst(call)
            csi <- cb$putconst(sym)
            cb$putcode(DOLLARGETS.OP, ci, csi)
            TRUE
        }
        else FALSE
    }
})

setSetterInlineHandler("[<-", function(afun, place, call, cb, cntxt)
    cmpSetterDispatch(STARTSUBASSIGN.OP, DFLTSUBASSIGN.OP,
                      afun, place, call, cb, cntxt))

setSetterInlineHandler("[[<-", function(afun, place, call, cb, cntxt)
    cmpSetterDispatch(STARTSUBASSIGN2.OP, DFLTSUBASSIGN2.OP,
                      afun, place, call, cb, cntxt))

cmpGetterDispatch <- function(start.op, dflt.op, call, cb, cntxt) {
    if (any.dots(call))
        FALSE ## punt
    else {
        ci <- cb$putconst(call)
        end.label <- cb$makelabel()
        cb$putcode(DUP2ND.OP)
        cb$putcode(start.op, ci, end.label)
        if (length(call) > 2) {
            args <- call[-(1:2)]
            cmpBuiltinArgs(args, names(args), cb, cntxt, TRUE)
        }
        cb$putcode(dflt.op)
        cb$putlabel(end.label)
        cb$putcode(SWAP.OP)
        TRUE
    }
}

setGetterInlineHandler("$", function(call, cb, cntxt) {
    if (any.dots(call) || length(call) != 3)
        FALSE
    else {
        sym <- call[[3]]
        if (is.character(sym))
            sym <- as.name(sym)
        if (is.name(sym)) {
            ci <- cb$putconst(call)
            csi <- cb$putconst(sym)
            cb$putcode(DUP2ND.OP)
            cb$putcode(DOLLAR.OP, ci, csi)
            cb$putcode(SWAP.OP)
            TRUE
        }
        else FALSE
    }
})

setGetterInlineHandler("[", function(call, cb, cntxt)
    cmpGetterDispatch(STARTSUBSET.OP, DFLTSUBSET.OP, call, cb, cntxt))

setGetterInlineHandler("[[", function(call, cb, cntxt)
    cmpGetterDispatch(STARTSUBSET2.OP, DFLTSUBSET2.OP, call, cb, cntxt))


##
## Inline handlers for loops
##

setInlineHandler("break", function(e, cb, cntxt) {
    if (is.null(cntxt$loop)) {
        notifyWrongBreakNext("break", cntxt)
        cmpSpecial(e, cb, cntxt)
    }
    else if (cntxt$loop$gotoOK) {
        cb$putcode(GOTO.OP, cntxt$loop$end)
        TRUE
    }
    else cmpSpecial(e, cb, cntxt)
})

setInlineHandler("next", function(e, cb, cntxt) {
    if (is.null(cntxt$loop)) {
        notifyWrongBreakNext("next", cntxt)
        cmpSpecial(e, cb, cntxt)
    }
    else if (cntxt$loop$gotoOK) {
        cb$putcode(GOTO.OP, cntxt$loop$loop)
        TRUE
    }
    else cmpSpecial(e, cb, cntxt)
})

isLoopStopFun <- function(fname, cntxt)
    (fname %in% c("function", "for", "while", "repeat") &&
     isBaseVar(fname, cntxt))

isLoopTopFun <- function(fname, cntxt)
    (fname %in% c("(", "{", "if") &&
     isBaseVar(fname, cntxt))

checkSkipLoopCntxtList <- function(elist, cntxt, breakOK) {
    for (a in as.list(elist))
        if (! missing(a) && ! checkSkipLoopCntxt(a, cntxt, breakOK))
            return(FALSE)
    TRUE
}

checkSkipLoopCntxt <- function(e, cntxt, breakOK = TRUE) {
    if (typeof(e) == "language") {
        fun <- e[[1]]
        if (typeof(fun) == "symbol") {
            fname <- as.character(fun)
            if (! breakOK && fname %in% c("break", "next"))
                FALSE
            else if (isLoopStopFun(fname, cntxt))
                TRUE
            else if (isLoopTopFun(fname, cntxt))
                checkSkipLoopCntxtList(e[-1], cntxt, breakOK)
            else
                checkSkipLoopCntxtList(e[-1], cntxt, FALSE)
        }
        else
            checkSkipLoopCntxtList(e, cntxt, FALSE)
    }
    else TRUE
}

setInlineHandler("repeat", function(e, cb, cntxt) {
    body <- e[[2]]
    if (checkSkipLoopCntxt(body, cntxt))
        cmpRepeatBody(body, cb, cntxt)
    else {
        cntxt$needRETURNJMP <- TRUE ## **** do this a better way
        code <- genCode(body, cntxt,
                        function(cb, cntxt) {
                            cmpRepeatBody(body, cb, cntxt)
                            cb$putcode(ENDLOOPCNTXT.OP)
                        })
        bi <- cb$putconst(code)
        cb$putcode(STARTLOOPCNTXT.OP, bi)
    }
    cb$putcode(LDNULL.OP)
    if (cntxt$tailcall) {
        cb$putcode(INVISIBLE.OP)
        cb$putcode(RETURN.OP)
    }
    TRUE
})

cmpRepeatBody <- function(body, cb, cntxt) {
    loop.label <- cb$makelabel()
    end.label <- cb$makelabel()
    cb$putlabel(loop.label)
    lcntxt <- make.loopContext(cntxt, loop.label, end.label)
    cmp(body, cb, lcntxt)
    cb$putcode(POP.OP)
    cb$putcode(GOTO.OP, loop.label)
    cb$putlabel(end.label)
}

setInlineHandler("while", function(e, cb, cntxt) {
    cond <- e[[2]]
    body <- e[[3]]
    if (checkSkipLoopCntxt(cond, cntxt) && checkSkipLoopCntxt(body, cntxt))
        cmpWhileBody(e, cond, body, cb, cntxt)
    else {
        cntxt$needRETURNJMP <- TRUE ## **** do this a better way
        code <- genCode(body, cntxt, ## **** expr isn't quite right
                        function(cb, cntxt) {
                            cmpWhileBody(e, cond, body, cb, cntxt)
                            cb$putcode(ENDLOOPCNTXT.OP)
                        })
        bi <- cb$putconst(code)
        cb$putcode(STARTLOOPCNTXT.OP, bi)
    }
    cb$putcode(LDNULL.OP)
    if (cntxt$tailcall) {
        cb$putcode(INVISIBLE.OP)
        cb$putcode(RETURN.OP)
    }
    TRUE
})

cmpWhileBody <- function(call, cond, body, cb, cntxt) {
    loop.label <- cb$makelabel()
    end.label <- cb$makelabel()
    cb$putlabel(loop.label)
    lcntxt <- make.loopContext(cntxt, loop.label, end.label)
    cmp(cond, cb, lcntxt)
    callidx <- cb$putconst(call)
    cb$putcode(BRIFNOT.OP, callidx, end.label)
    cmp(body, cb, lcntxt)
    cb$putcode(POP.OP)
    cb$putcode(GOTO.OP, loop.label)
    cb$putlabel(end.label)
}

setInlineHandler("for", function(e, cb, cntxt) {
    sym <- e[[2]]
    seq <- e[[3]]
    body <- e[[4]]
    if (! is.name(sym)) {
        ## not worth warning here since the parser should not allow this
        return(FALSE)
    }
    ncntxt <- make.nonTailCallContext(cntxt)
    cmp(seq, cb, ncntxt)
    ci <- cb$putconst(sym)
    callidx <- cb$putconst(e)
    if (checkSkipLoopCntxt(body, cntxt))
        cmpForBody(callidx, body, ci, cb, cntxt)
    else {
        cntxt$needRETURNJMP <- TRUE ## **** do this a better way
        ctxt.label <- cb$makelabel()
        cb$putcode(STARTFOR.OP, callidx, ci, ctxt.label)
        cb$putlabel(ctxt.label)
        code <- genCode(body, cntxt, ## **** expr isn't quite right
                        function(cb, cntxt) {
                            cmpForBody(NULL, body, NULL, cb, cntxt)
                            cb$putcode(ENDLOOPCNTXT.OP)
                        })
        bi <- cb$putconst(code)
        cb$putcode(STARTLOOPCNTXT.OP, bi)
    }
    cb$putcode(ENDFOR.OP)
    if (cntxt$tailcall) {
        cb$putcode(INVISIBLE.OP)
        cb$putcode(RETURN.OP)
    }
    TRUE
})

cmpForBody <- function(callidx, body, ci, cb, cntxt) {
    body.label <- cb$makelabel()
    loop.label <- cb$makelabel()
    end.label <- cb$makelabel()
    if (is.null(ci))
        cb$putcode(GOTO.OP, loop.label)
    else
        cb$putcode(STARTFOR.OP, callidx, ci, loop.label)
    cb$putlabel(body.label)
    lcntxt <- make.loopContext(cntxt, loop.label, end.label)
    cmp(body, cb, lcntxt)
    cb$putcode(POP.OP)
    cb$putlabel(loop.label)
    cb$putcode(STEPFOR.OP, body.label)
    cb$putlabel(end.label)
}


##
## Inline handlers for one and two argument primitives
##

cmpPrim1 <- function(e, cb, op, cntxt) {
    if (dots.or.missing(e[-1]))
        cmpBuiltin(e, cb, cntxt)
    else if (length(e) != 2) {
        notifyWrongArgCount(e[[1]], cntxt)
        cmpBuiltin(e, cb, cntxt)
    }
    else {
        ncntxt <- make.nonTailCallContext(cntxt)
        cmp(e[[2]], cb, ncntxt);
        ci <- cb$putconst(e)
        cb$putcode(op, ci)
        if (cntxt$tailcall)
            cb$putcode(RETURN.OP)
        TRUE
    }
}

cmpPrim2 <- function(e, cb, op, cntxt) {
    if (dots.or.missing(e[-1]))
        cmpBuiltin(e, cb, cntxt)
    else if (length(e) != 3) {
        notifyWrongArgCount(e[[1]], cntxt)
        cmpBuiltin(e, cb, cntxt)
    }
    else {
        ncntxt <- make.nonTailCallContext(cntxt)
        cmp(e[[2]], cb, ncntxt);
        ncntxt <- make.argContext(cntxt)
        cmp(e[[3]], cb, ncntxt)
        ci <- cb$putconst(e)
        cb$putcode(op, ci)
        if (cntxt$tailcall)
            cb$putcode(RETURN.OP)
        TRUE
    }
}

setInlineHandler("+", function(e, cb, cntxt) {
    if (length(e) == 3)
        cmpPrim2(e, cb, ADD.OP, cntxt)
    else
        cmpPrim1(e, cb, UPLUS.OP, cntxt)
})

setInlineHandler("-", function(e, cb, cntxt) {
    if (length(e) == 3)
        cmpPrim2(e, cb, SUB.OP, cntxt)
    else
        cmpPrim1(e, cb, UMINUS.OP, cntxt)
})

setInlineHandler("*", function(e, cb, cntxt)
    cmpPrim2(e, cb, MUL.OP, cntxt))

setInlineHandler("/", function(e, cb, cntxt)
    cmpPrim2(e, cb, DIV.OP, cntxt))

setInlineHandler("^", function(e, cb, cntxt)
    cmpPrim2(e, cb, EXPT.OP, cntxt))

setInlineHandler("exp", function(e, cb, cntxt)
    cmpPrim1(e, cb, EXP.OP, cntxt))

setInlineHandler("sqrt", function(e, cb, cntxt)
    cmpPrim1(e, cb, SQRT.OP, cntxt))

setInlineHandler("==", function(e, cb, cntxt)
   cmpPrim2(e, cb, EQ.OP, cntxt))

setInlineHandler("!=", function(e, cb, cntxt)
   cmpPrim2(e, cb, NE.OP, cntxt))

setInlineHandler("<", function(e, cb, cntxt)
   cmpPrim2(e, cb, LT.OP, cntxt))

setInlineHandler("<=", function(e, cb, cntxt)
   cmpPrim2(e, cb, LE.OP, cntxt))

setInlineHandler(">=", function(e, cb, cntxt)
   cmpPrim2(e, cb, GE.OP, cntxt))

setInlineHandler(">", function(e, cb, cntxt)
   cmpPrim2(e, cb, GT.OP, cntxt))

setInlineHandler("&", function(e, cb, cntxt)
   cmpPrim2(e, cb, AND.OP, cntxt))

setInlineHandler("|", function(e, cb, cntxt)
   cmpPrim2(e, cb, OR.OP, cntxt))

setInlineHandler("!", function(e, cb, cntxt)
   cmpPrim1(e, cb, NOT.OP, cntxt))


##
## Inline handlers for the left parenthesis function
##

setInlineHandler("(", function(e, cb, cntxt) {
    if (any.dots(e))
        cmpBuiltin(e, cb, cntxt) ## punt
    else if (length(e) != 2) {
        notifyWrongArgCount("(", cntxt)
        cmpBuiltin(e, cb, cntxt) ## punt
    }
    else if (cntxt$tailcall) {
        ncntxt <- make.nonTailCallContext(cntxt)
        cmp(e[[2]], cb, ncntxt)
        cb$putcode(VISIBLE.OP)
        cb$putcode(RETURN.OP)
        TRUE
    }
    else {
        cmp(e[[2]], cb, cntxt)
        TRUE
    }
})


##
## Inline handlers for general BUILTIN and SPECIAL functions
##

cmpBuiltin <- function(e, cb, cntxt, internal = FALSE) {
    fun <- e[[1]]
    args <- e[-1]
    names <- names(args)
    if (dots.or.missing(args))
        FALSE
    else {
        ci <- cb$putconst(fun)
        if (internal)
            cb$putcode(GETINTLBUILTIN.OP, ci)
        else
            cb$putcode(GETBUILTIN.OP, ci)
        cmpBuiltinArgs(args, names, cb, cntxt)
        ci <- cb$putconst(e)
        cb$putcode(CALLBUILTIN.OP, ci)
        if (cntxt$tailcall) cb$putcode(RETURN.OP)
        TRUE
    }
}

cmpBuiltinArgs <- function(args, names, cb, cntxt, missingOK = FALSE) {
    ncntxt <- make.argContext(cntxt)
    for (i in seq_along(args)) {
        a <- args[[i]]
        n <- names[[i]]
        if (missing(a)) {
            if (missingOK) {
                cb$putcode(DOMISSING.OP)
                cmpTag(n, cb)
            }
            else
                cntxt$stop(gettext("missing arguments are not allowed"), cntxt)
        }
        ## **** handle ... here ??
        else if (typeof(a) == "bytecode")
            cntxt$stop(gettext("cannot compile byte code literals in code"),
                       cntxt)
        else if (typeof(a) == "promise")
            cntxt$stop(gettext("cannot compile promise literals in code"),
                       cntxt)
        else {
            if (is.symbol(a)) {
                ca <- constantFold(a, cntxt)
                if (is.null(ca)) {
                    cmpSym(a, cb, ncntxt, missingOK)
                    cb$putcode(PUSHARG.OP)
                }
                else
                    cmpConstArg(ca$value, cb, cntxt)
            }
            else if (typeof(a) == "language") {
                cmp(a, cb, ncntxt)
                cb$putcode(PUSHARG.OP)
            }
            else
                cmpConstArg(a, cb, cntxt)
            cmpTag(n, cb)
        }
    }
}

cmpSpecial <- function(e, cb, cntxt) {
    fun <- e[[1]]
    if (typeof(fun) == "character")
        fun <- as.name(fun)
    ci <- cb$putconst(e)
    cb$putcode(CALLSPECIAL.OP, ci)
    if (cntxt$tailcall)
        cb$putcode(RETURN.OP)
    TRUE
}

setInlineHandler(".Internal", function(e, cb, cntxt) {
    ee <- e[[2]]
    sym <- ee[[1]]
    if (.Internal(is.builtin.internal(sym)))
        cmpBuiltin(ee, cb, cntxt, internal = TRUE)
    else
        cmpSpecial(e, cb, cntxt)
})


##
## Inline handlers for subsetting and related operators
##

cmpDispatch <- function(start.op, dflt.op, e, cb, cntxt, missingOK = TRUE) {
    if ((missingOK && any.dots(e)) ||
        (! missingOK && dots.or.missing(e)) ||
        length(e) == 1)
        cmpSpecial(e, cb, cntxt) ## punt
    else {
        ne <- length(e)
        oe <- e[[2]]
        if (missing(oe))
            cmpSpecial(e, cb, cntxt) ## punt
        else {
            ncntxt <- make.argContext(cntxt)
            cmp(oe, cb, ncntxt)
            ci <- cb$putconst(e)
            end.label <- cb$makelabel()
            cb$putcode(start.op, ci, end.label)
            if (ne > 2)
                cmpBuiltinArgs(e[-(1:2)], names(e)[-(1:2)], cb, cntxt,
                               missingOK)
            cb$putcode(dflt.op)
            cb$putlabel(end.label)
            if (cntxt$tailcall) cb$putcode(RETURN.OP)
            TRUE
        }
    }
}

setInlineHandler("[", function(e, cb, cntxt)
    cmpDispatch(STARTSUBSET.OP, DFLTSUBSET.OP, e, cb, cntxt))

# **** c() is now a BUILTIN
# setInlineHandler("c", function(e, cb, cntxt)
#     cmpDispatch(STARTC.OP, DFLTC.OP, e, cb, cntxt, FALSE))

setInlineHandler("[[", function(e, cb, cntxt)
    cmpDispatch(STARTSUBSET2.OP, DFLTSUBSET2.OP, e, cb, cntxt))

setInlineHandler("$", function(e, cb, cntxt) {
    if (any.dots(e) || length(e) != 3)
        cmpSpecial(e, cb, cntxt)
    else {
        sym <- if (is.character(e[[3]]))
            as.name(e[[3]]) else e[[3]]
        if (is.name(sym)) {
            ncntxt <- make.argContext(cntxt)
            cmp(e[[2]], cb, ncntxt)
            ci <- cb$putconst(e)
            csi <- cb$putconst(sym)
            cb$putcode(DOLLAR.OP, ci, csi)
            if (cntxt$tailcall) cb$putcode(RETURN.OP)
            TRUE
        }
        else cmpSpecial(e, cb, cntxt)
    }
})


##
## Inline handler for local() and return() functions
##

setInlineHandler("local", function(e, cb, cntxt) {
    if (length(e) == 2) {
        ee <- as.call(list(as.call(list(as.name("function"), NULL, e[[2]]))))
        cmp(ee, cb, cntxt)
        TRUE
    }
    else FALSE
})

setInlineHandler("return", function(e, cb, cntxt) {
    if (dots.or.missing(e) || length(e) > 2)
        cmpSpecial(e, cb, cntxt) ## **** punt for now
    else {
        if (length(e) == 1)
            val <- NULL
        else
            val <- e[[2]]
        ncntxt <- make.nonTailCallContext(cntxt)
        cmp(val, cb, ncntxt)
        if (cntxt$needRETURNJMP)
            cb$putcode(RETURNJMP.OP)
        else
            cb$putcode(RETURN.OP)
    }
    TRUE
})


##
## Inline handlers for the family of is.xyz primitives
##

cmpIs <- function(op, e, cb, cntxt) {
    if (any.dots(e) || length(e) != 2)
        cmpBuiltin(e, cb, cntxt)
    else {
        ## **** check that the function is a builtin somewhere??
        s<-make.argContext(cntxt)
        cmp(e[[2]], cb, s)
        cb$putcode(op)
        if (cntxt$tailcall) cb$putcode(RETURN.OP)
        TRUE
    }
}

setInlineHandler("is.character", function(e, cb, cntxt)
    cmpIs(ISCHARACTER.OP, e, cb, cntxt))
setInlineHandler("is.complex", function(e, cb, cntxt)
    cmpIs(ISCOMPLEX.OP, e, cb, cntxt))
setInlineHandler("is.double", function(e, cb, cntxt)
    cmpIs(ISDOUBLE.OP, e, cb, cntxt))
setInlineHandler("is.integer", function(e, cb, cntxt)
    cmpIs(ISINTEGER.OP, e, cb, cntxt))
setInlineHandler("is.logical", function(e, cb, cntxt)
    cmpIs(ISLOGICAL.OP, e, cb, cntxt))
setInlineHandler("is.name", function(e, cb, cntxt)
     cmpIs(ISSYMBOL.OP, e, cb, cntxt))
setInlineHandler("is.null", function(e, cb, cntxt)
    cmpIs(ISNULL.OP, e, cb, cntxt))
setInlineHandler("is.object", function(e, cb, cntxt)
    cmpIs(ISOBJECT.OP, e, cb, cntxt))
setInlineHandler("is.symbol", function(e, cb, cntxt)
    cmpIs(ISSYMBOL.OP, e, cb, cntxt))


##
## Default inline handlers for BUILTIN and SPECIAL functions
##

local({
    basevars <- ls('package:base', all = TRUE)
    types <- sapply(basevars, function(n) typeof(get(n)))
    for (s in basevars[types == "special"])
        if (! haveInlineHandler(s, "base"))
            setInlineHandler(s, cmpSpecial)
    for (b in basevars[types == "builtin"])
        if (! haveInlineHandler(b, "base"))
            setInlineHandler(b, cmpBuiltin)
})


##
## Inline handlers for some .Internal functions
##

simpleFormals <- function(def) {
    forms <- formals(def)
    if ("..." %in% names(forms))
        return(FALSE)
    for (d in as.list(forms)) {
        if (! missing(d)) {
            ## **** check constant folding
            if (typeof(d) %in% c("symbol", "language", "promise", "bytecode"))
                return(FALSE)
        }
    }
    TRUE
}

simpleArgs <- function(icall, fnames) {
    for (a in as.list(icall[-1])) {
        if (missing(a))
            return(FALSE)
        else if (typeof(a) == "symbol") {
            if (! (as.character(a) %in% fnames))
                return(FALSE)
        }
        else if (typeof(a) %in% c("language", "promise", "bytecode"))
            return(FALSE)
    }
    TRUE
}

is.simpleInternal <- function(def) {
    if (typeof(def) == "closure" && simpleFormals(def)) {
        b <- body(def)
        if (typeof(b) == "language" && length(b) == 2 && b[[1]] == "{")
            b <- b[[2]]
        if (typeof(b) == "language" &&
            typeof(b[[1]]) == "symbol" &&
            b[[1]] == ".Internal") {
            icall <- b[[2]]
            ifun <- icall[[1]]
            typeof(ifun) == "symbol" &&
            .Internal(is.builtin.internal(as.name(ifun))) &&
            simpleArgs(icall, names(formals(def)))
        }
        else FALSE
    }
    else FALSE
}

inlineSimpleInternalCall <- function(e, def) {
    if (! dots.or.missing(e) && is.simpleInternal(def)) {
        forms <- formals(def)
        fnames <- names(forms)
        b <- body(def)
        if (typeof(b) == "language" && length(b) == 2 && b[[1]] == "{")
            b <- b[[2]]
        icall <- b[[2]]
        defaults <- forms ## **** could strip missings but OK not to?
        cenv <- c(as.list(match.call(def, e, F))[-1], defaults)
        subst <- function(n)
            if (typeof(n) == "symbol") cenv[[as.character(n)]] else n
        args <- lapply(as.list(icall[-1]), subst)
        as.call(list(quote(.Internal), as.call(c(icall[[1]], args))))
    }
    else NULL
}

cmpSimpleInternal <- function(e, cb, cntxt) {
    if (any.dots(e))
        FALSE
    else {
        name <- as.character(e[[1]])
        def <- findFunDef(name, cntxt)
        if (! checkCall(def, e, NULL)) return(FALSE)
        call <- inlineSimpleInternalCall(e, def)
        if (is.null(call))
            FALSE
        else {
            cmp(call, cb, cntxt)
            TRUE
        }
    }
}

safeBaseInternals <- c("atan2", "besselY", "beta", "choose",
                       "drop", "inherits", "is.vector", "lbeta", "lchoose",
                       "nchar", "polyroot", "typeof", "vector", "which.max",
                       "which.min", "is.loaded", "identical")

for (i in safeBaseInternals) setInlineHandler(i,  cmpSimpleInternal)

safeStatsInternals <- c("dbinom", "dcauchy", "dgeom", "dhyper", "dlnorm",
                        "dlogis", "dnorm", "dpois", "dunif", "dweibull",
                        "fft", "mvfft", "pbinom", "pcauchy",
                        "pgeom", "phyper", "plnorm", "plogis", "pnorm",
                        "ppois", "punif", "pweibull", "qbinom", "qcauchy",
                        "qgeom", "qhyper", "qlnorm", "qlogis", "qnorm",
                        "qpois", "qunif", "qweibull", "rbinom", "rcauchy",
                        "rgeom", "rhyper", "rlnorm", "rlogis", "rnorm",
                        "rpois", "rsignrank",  "runif", "rweibull",
                        "rwilcox", "ptukey", "qtukey")

for (i in safeStatsInternals) setInlineHandler(i,  cmpSimpleInternal, "stats")


##
## Inline handler for switch
##

findActionIndex <- function(name, nm, miss) {
    start <- match(name, nm)
    aidx <- c(which(! miss), length(nm) + 1)
    min(aidx[aidx >= start])
}

setInlineHandler("switch", function(e, cb, cntxt) {
    if (length(e) < 2 || any.dots(e))
        cmpSpecial(e, cb, cntxt)
    else {
        ## **** check name on EXPR, if any, partially matches EXPR?
        expr <- e[[2]]
        cases <-e[-c(1, 2)]

        miss <- missingArgs(cases)
        nm <- names(cases)

        ## allow for corner cases like switch(x, 1) which always
        ## returns 1 if x is a character scalar.
        if (is.null(nm) && length(cases) == 1)
            nm <- ""

        ## collect information on named alternatives and check for
        ## multiple default cases.
        if (! is.null(nm)) {
            haveNames <- TRUE
            ndflt <- sum(nm == "")
            if (ndflt > 1) {
                notifyMultipleSwitchDefaults(ndflt, cntxt)
                ## **** punt back to interpreted version for now to get
                ## **** runtime error message for multiple defaults
                cmpSpecial(e, cb, cntxt)
                return(TRUE)
            }
            if (ndflt > 0)
                haveCharDflt <- TRUE
            else
                haveCharDflt <- FALSE
        }
        else {
            haveNames <- FALSE
            haveCharDflt <- FALSE
        }

        ## create the labels
        if (any(miss))
            missLabel <- cb$makelabel()
        dfltLabel <- cb$makelabel()

        lab <- function(m)
            if (m) missLabel
            else cb$makelabel()
        labels <- c(lapply(miss, lab), list(dfltLabel))

        if (! cntxt$tailcall)
            endLabel <- cb$makelabel()

        ## create the map from names to labels for a character switch
        if (haveNames) {
            unm <- unique(nm[nm != ""])
            if (haveCharDflt)
                unm <- c(unm, "")
            nlabels <- labels[unlist(lapply(unm, findActionIndex, nm, miss))]
            ## if there is no unnamed case to act as a default for a
            ## character switch then the numeric default becomes the
            ## character default as well.
            if (! haveCharDflt) {
                unm <- c(unm, "")
                nlabels <- c(nlabels, list(dfltLabel))
            }
        }
        else {
            unm <- NULL
            nlabels <- NULL
        }

        ## compile the EXPR argument
        ncntxt <- make.nonTailCallContext(cntxt)
        cmp(expr, cb, ncntxt)

        ## emit the SWITCH instruction
        cei <- cb$putconst(e)
        if (haveNames) {
            cni <- cb$putconst(unm)
            cb$putcode(SWITCH.OP, cei, cni, nlabels, labels)
        }
        else {
            cni <- cb$putconst(NULL)
            cb$putcode(SWITCH.OP, cei, cni, cni, labels)
        }

        ## emit code to signal an error if a numeric switch hist an
        ## empty alternative (fall through, as for character, might
        ## make more sense but that isn't the way switch() works)
        if (any(miss)) {
            cb$putlabel(missLabel)
            cmp(quote(stop("empty alternative in numeric switch")), cb, cntxt)
        }

        ## emit code for the default case
        cb$putlabel(dfltLabel)
        cb$putcode(LDNULL.OP)
        if (cntxt$tailcall) {
            cb$putcode(INVISIBLE.OP)
            cb$putcode(RETURN.OP)
        }
        else
            cb$putcode(GOTO.OP, endLabel)

        ## emit code for the non-empty alternatives
        for (i in seq_along(cases)) {
            if (! miss[i]) {
                cb$putlabel(labels[[i]])
                cmp(cases[[i]], cb, cntxt)
                if (! cntxt$tailcall)
                    cb$putcode(GOTO.OP, endLabel)
            }
        }

        if (! cntxt$tailcall)
            cb$putlabel(endLabel)
    }
    TRUE
})


##
## Inline handlers to control warnings
##

cmpMultiColon <- function(e, cb, cntxt) {
    if (! dots.or.missing(e) && length(e) == 3) {
        goodType <- function(a)
            typeof(a) == "symbol" ||
            (typeof(a) == "character" && length(a) == 1)
        fun <- e[[1]]
        x <- e[[2]]
        y <- e[[3]]
        if (goodType(x) && goodType(y)) {
            args <- list(as.character(x), as.character(y))
            cmpCallSymFun(fun, args, e, cb, cntxt)
            TRUE
        }
        else FALSE
    }
    else FALSE
}

setInlineHandler("::", cmpMultiColon)
setInlineHandler(":::", cmpMultiColon)

setSetterInlineHandler("@<-", function(afun, place, acall, cb, cntxt) {
    if (! dots.or.missing(place) && length(place) == 3 &&
        typeof(place[[3]]) == "symbol") {
        place[[3]] <- as.character(place[[3]])
        vexpr <- acall[[length(acall)]]
        cmpSetterCall(place, vexpr, cb, cntxt)
        TRUE
    }
    else FALSE
}, "methods")

setInlineHandler("with", function(e, cb, cntxt) {
    cntxt$suppressUndefined <- TRUE
    cmpCallSymFun(e[[1]], e[-1], e, cb, cntxt)
    TRUE
})

setInlineHandler("require", function(e, cb, cntxt) {
    cntxt$suppressUndefined <- TRUE
    cmpCallSymFun(e[[1]], e[-1], e, cb, cntxt)
    TRUE
})


##
## Compiler warnings
##

suppressAll <- function(cntxt)
    identical(cntxt$suppressAll, TRUE)

suppressUndef <- function(name, cntxt) {
    if (identical(cntxt$suppressAll, TRUE))
        TRUE
    else {
        suppress <- cntxt$suppressUndefined
        if (is.null(suppress))
            FALSE
        else if (identical(suppress, TRUE))
            TRUE
        else if (is.character(suppress) && as.character(name) %in% suppress)
            TRUE
        else FALSE
    }
}

notifyLocalFun <- function(fun, cntxt) {
    if (! suppressAll(cntxt))
        NULL
}

notifyUndefFun <- function(fun, cntxt) {
    if (! suppressUndef(fun, cntxt)) {
        msg <- gettextf("no visible global function definition for '%s'",
                        as.character(fun))
        cntxt$warn(msg, cntxt)
    }
}

notifyUndefVar <- function(var, cntxt) {
    if (! suppressUndef(var, cntxt)) {
        msg <- gettextf("no visible binding for global variable '%s'",
                        as.character(var))
        cntxt$warn(msg, cntxt)
    }
}

notifyNoSuperAssignVar <- function(symbol, cntxt) {
    if (! suppressAll(cntxt)) {
        msg <- gettextf("no visible binding for '<<-' assignment to '%s'",
                        as.character(symbol))
        cntxt$warn(msg, cntxt)
    }
}

notifyWrongArgCount <- function(fun, cntxt) {
    if (! suppressAll(cntxt))
        cntxt$warn(gettextf("wrong number of arguments to '%s'",
                            as.character(fun)),
                   cntxt)
}

notifyWrongDotsUse <- function(var, cntxt) {
    if (! suppressAll(cntxt))
        cntxt$warn(paste(var, "may be used in an incorrect context"), cntxt)
}

notifyWrongBreakNext <- function(fun, cntxt) {
    if (! suppressAll(cntxt)) {
        msg <- paste(fun, "may be used in wrong context: no loop is visible")
        cntxt$warn(msg, cntxt)
    }
}

notifyBadCall <- function(w, cntxt) {
    if (! suppressAll(cntxt))
        cntxt$warn(w, cntxt)
}

notifyBadAssignFun <- function(fun, cntxt) {
    if (! suppressAll(cntxt))
        cntxt$warn(gettext("invalid function in complex assignment"))
}

notifyMultipleSwitchDefaults <- function(ndflt, cntxt)
    if (! suppressAll(cntxt))
        cntxt$warn(gettext("more than one default provided in switch() call"),
                   cntxt)


##
## Compiler interface
##

compile <- function(e, env = .GlobalEnv, options = NULL) {
    cenv <- makeCenv(env)
    cntxt <- make.toplevelContext(cenv, options)
    cntxt$env <- addCenvVars(cenv, findLocals(e, cntxt))
    genCode(e, cntxt)
}

cmpfun <- function(f, options = NULL) {
    type <- typeof(f)
    if (type == "closure") {
        cntxt <- make.toplevelContext(makeCenv(environment(f)), options)
        ncntxt <- make.functionContext(cntxt, formals(f), body(f))
        b <- genCode(body(f), ncntxt)
        val <- .Internal(bcClose(formals(f), b, environment(f)))
        attrs <- attributes(f)
        if (! is.null(attrs))
            attributes(val) <- attrs
        if (isS4(f)) ## **** should this really be needed??
            val <- asS4(val)
        val
    }
    else if (typeof(f) == "builtin" || type == "special")
        f
    else stop("cannot compile a non-function")
}

tryCmpfun <- function(f)
    tryCatch(cmpfun(f), error = function(e) f)

cmpframe <- function(inpos, file) {
    expr.needed <- 1000
    expr.old <- options()$expressions
    if (expr.old < expr.needed)
       options(expressions = expr.needed)
    on.exit(options(expressions = expr.old))

    attach(NULL, name="<compiled>")
    inpos <- inpos + 1
    outpos <- 2
    on.exit(detach(pos=outpos), add=TRUE)

    for (f in ls(pos = inpos, all.names = TRUE)) {
        def <- get(f, pos = inpos)
        if (typeof(def) == "closure") {
                cat(gettextf("compiling '%s'", f), "\n", sep = "")
                fc <- cmpfun(def)
                assign(f, fc, pos=outpos)
        }
    }
    cat(gettextf("saving to file \"%s\" ... ", file))
    save(list = ls(pos = outpos, all.names = TRUE), file = file)
    cat(gettext("done"), "\n", sep = "")
}

cmplib <- function(package, file) {
    package <- as.character(substitute(package))
    pkgname <- paste("package", package, sep = ":")
    pos <- match(pkgname, search());
    if (missing(file))
        file <- paste0(package,".Rc")
    if (is.na(pos)) {
        library(package, character.only = TRUE)
        pos <- match(pkgname, search());
        on.exit(detach(pos=match(pkgname, search())))
    }
    cmpframe(pos, file)
}

cmpfile <- function(infile, outfile, ascii = FALSE, env = .GlobalEnv,
                    verbose = FALSE, options = NULL) {
    if (! is.environment(env) || ! identical(env, topenv(env)))
        stop("'env' must be a top level environment")
    if (missing(outfile)) {
        basename <- sub("\\.[a-zA-Z0-9]$", "", infile)
        outfile <- paste0(basename, ".Rc")
    }
    if (infile == outfile)
        stop("input and output file names are the same")
    forms <- parse(infile)
    nforms <- length(forms)
    if (nforms > 0) {
        expr.needed <- 1000
        expr.old <- options()$expressions
        if (expr.old < expr.needed) {
            options(expressions = expr.needed)
            on.exit(options(expressions = expr.old))
        }
        cforms <- vector("list", nforms)
        cenv <- makeCenv(env)
        cntxt <- make.toplevelContext(cenv, options)
        cntxt$env <- addCenvVars(cenv, findLocalsList(forms, cntxt))
        for (i in 1:nforms) {
            e <- forms[[i]]
            if (verbose) {
                if (typeof(e) == "language" && e[[1]] == "<-" &&
                    typeof(e[[3]]) == "language" && e[[3]][[1]] == "function")
                    cat(paste0("compiling function \"", e[[2]], "\"\n"))
                else
                    cat(paste("compiling expression", deparse(e, 20)[1],
                              "...\n"))
            }
            cforms[[i]] <- genCode(e, cntxt)
        }
        cat(gettextf("saving to file \"%s\" ... ", outfile))
        .Internal(save.to.file(cforms, outfile, ascii))
        cat(gettext("done"), "\n", sep = "")
    }
    else warning("empty input file; no output written");
    invisible(NULL)
}

loadcmp <- function (file, envir = .GlobalEnv, chdir = FALSE) {
    if (!(is.character(file) && file.exists(file)))
        stop(gettextf("file '%s' does not exist", file), domain = NA)
    exprs <- .Internal(load.from.file(file))
    if (length(exprs) == 0)
        return(invisible())
    if (chdir && (path <- dirname(file)) != ".") {
        owd <- getwd()
        on.exit(setwd(owd), add = TRUE)
        setwd(path)
    }
    for (i in exprs) {
        yy <- eval(i, envir)
    }
    invisible()
}

enableJIT <- function(level)
    .Internal(enableJIT(level))

compilePKGS <- function(enable)
    .Internal(compilePKGS(enable))

setCompilerOptions <- function(...) {
    options <- list(...)
    nm <- names(options)
    for (n in nm)
        if (! exists(n, compilerOptions))
            stop(gettextf("'%s' is not a valid compiler option", n),
                 domain = NA)
    old <- list()
    for (n in nm) {
        op <- options[[n]]
        switch(n,
               optimize = {
                   op <- as.integer(op)
                   if (length(op) == 1 && 0 <= op && op <= 3) {
                       old <- c(old, list(optimize =
                                          compilerOptions$optimize))
                       compilerOptions$optimize <- op
                   }
               },
               suppressAll = {
                   if (identical(op, TRUE) || identical(op, FALSE)) {
                       old <- c(old, list(suppressAll =
                                          compilerOptions$suppressAll))
                       compilerOptions$suppressAll <- op
                   }
               },
               suppressUndefined = {
                   if (identical(op, TRUE) || identical(op, FALSE) ||
                       is.character(op)) {
                       old <- c(old, list(suppressUndefined =
                                          compilerOptions$suppressUndefined))
                       compilerOptions$suppressUndefined <- op
                   }
               })
    }
    old
}

.onLoad <- function(libname, pkgname) {
    if (Sys.getenv("R_COMPILER_SUPPRESS_ALL") != "")
        setCompilerOptions(suppressAll = TRUE)
}


##
## Disassembler
##

bcDecode <- function(code) {
    n <- length(code)
    ncode <- vector("list", n)
    ncode[[1]] <- code[1] # version number
    i <- 2
    while (i <= n) {
        name<-Opcodes.names[code[i]+1]
        argc<-Opcodes.argc[[code[i]+1]]
        ncode[[i]] <- as.name(name)
        i<-i+1
        if (argc > 0)
            for (j in 1:argc) {
                ncode[[i]]<-code[i]
                i<-i+1
            }
    }
    ncode
}

disassemble <- function(code) {
    .CodeSym <- as.name(".Code")
    disasm.const<-function(x)
        if (typeof(x)=="list" && length(x) > 0 && identical(x[[1]], .CodeSym))
            disasm(x) else x
    disasm <-function(code) {
        code[[2]]<-bcDecode(code[[2]])
        code[[3]]<-lapply(code[[3]], disasm.const)
        code
    }
    if (typeof(code)=="closure") {
        code <- .Internal(bodyCode(code))
        if (typeof(code) != "bytecode")
            stop("function is not compiled")
    }
    dput(disasm(.Internal(disassemble(code))))
}