codetools/0000755000175100001440000000000011526312554012267 5ustar hornikuserscodetools/R/0000755000175100001440000000000011526312554012470 5ustar hornikuserscodetools/R/codetools.R0000644000175100001440000011545411526307633014622 0ustar hornikusers## WARNING: ## This code is a complete hack, may or may not work, etc.. ## Use your own risk. You have been warned. ## ## Environment utilities ## .BaseEnv <- if (exists("baseenv")) baseenv() else NULL .EmptyEnv <- if (exists("emptyenv")) emptyenv() else NULL is.emptyenv <- function(e) identical(e, .EmptyEnv) is.baseenv <- function(e) identical(e, .BaseEnv) mkHash <- function() new.env(hash = TRUE, parent = .EmptyEnv) ## ## Code walker ## walkCode <- function(e, w = makeCodeWalker()) { if (typeof(e) == "language") { if (typeof(e[[1]]) %in% c("symbol", "character")) { h <- w$handler(as.character(e[[1]]), w) if (! is.null(h)) h(e, w) else w$call(e, w) } else w$call(e, w) } else w$leaf(e, w) } makeCodeWalker <- function(..., handler = function (v, w) NULL, call = function(e, w) for (ee in as.list(e)) if (! missing(ee)) walkCode(ee, w), leaf = function(e, w) print(e)) list(handler = handler, call = call, leaf = leaf, ...) ## ## Call tree display ## showTree <- function(e, write = cat) { w <- makeCodeWalker(call = showTreeCall, leaf = showTreeLeaf, write = write) walkCode(e, w) w$write("\n") } showTreeCall <- function(e, w) { w$write("(") walkCode(e[[1]], w) for (a in as.list(e[-1])) { w$write(" ") if (missing(a)) w$write("") else walkCode(a, w) } w$write(")") } showTreeLeaf <- function(e, w) { if (typeof(e) == "symbol") { if (e == "(") w$write("\"(\"") else if (e == "{") w$write("\"{\"") else w$write(e) } else w$write(deparse(e)) } ## ## Call with current continuation ## if (! exists("callCC")) callCC <- function(fun) { value <- NULL delayedAssign("throw", return(value)) fun(function(v) { value <<- v; throw }) } ## ## Constant folding ## makeConstantFolder <- function(..., leaf = foldLeaf, handler = function(v, w) if (w$foldable(v, w)) foldCall, call = function(e, w) exitFolder(e, w), exit = function(e, w) stop0(paste("not a foldable expression:", deparse(e, width.cutoff = 500))), isLocal = function(v, w) FALSE, foldable = isFoldable, isConstant = isConstantValue, signal = function(e, msg, w) warning0(msg)) list(handler = handler, call = call, exit = exit, leaf = leaf, isLocal = isLocal, foldable = isFoldable, isConstant = isConstant, signal = signal, ...) exitFolder <- function(e, w) { w$exit(e, w) stop0("constant folding cannot continue") } constantFold <- function(e, env = NULL, fail = NULL) { job <- function(exit) { isLocal <- function(v, w) as.character(v) %in% env doExit <- function(e, w) exit(fail) w <- makeConstantFolder(isLocal = isLocal, exit = doExit) walkCode(e, w) } callCC(job) } constantFoldEnv <- function(e, env = .GlobalEnv, fail = NULL) { isLocal <- function(v, w) { vname <- as.character(v) while (! identical(env, .GlobalEnv)) { if (exists(vname, env, inherits = FALSE)) return(TRUE) env <- parent.env(env) } FALSE } job <- function(exit) { doExit <- function(e, w) exit(fail) w <- makeConstantFolder(isLocal = isLocal, exit = doExit) walkCode(e, w) } tryCatch(callCC(job), error = function(e) fail) } isConstantValue <- function(v, w) is.null(v) || (is.null(attributes(v)) && is.atomic(v)) || (is.list(v) && (identical(v, .Platform) || identical(v, .Machine))) isFoldable <- function(v, w) ((typeof(v) == "symbol" || typeof(v) == "character") && as.character(v) %in% foldFuns && ! w$isLocal(v, w)) foldFuns <- c("+", "-", "*", "/", "^", "(", ">", ">=", "==", "!=", "<", "<=", "||", "&&", "!", "|", "&", "%%", "sqrt", "log", "exp", "c", "as.integer", "vector", "integer","numeric","character", "rep", ":", "cos", "sin", "tan", "acos", "asin", "atan", "atan2", "is.R", "$", "[", "[[") constNames <- c("pi", "T", "F", ".Platform", ".Machine") foldLeaf <- function(e, w) { if (is.name(e) && as.character(e) %in% constNames && ! w$isLocal(e, w)) e <- get(as.character(e), envir = .BaseEnv) if (! w$isConstant(e)) exitFolder(e, w) e } foldCall <- function(e, w) { fname <- as.character(e[[1]]) if (fname == "$") { args <- list(walkCode(e[[2]], w), e[[3]]) foldable <- w$isConstant(args[[1]], w) } else { args <- lapply(e[-1], function(e) walkCode(e, w)) foldable <- all(sapply(args, w$isConstant, w)) } if (foldable) { msg <- try({ v <- do.call(fname, args); NULL }, silent = TRUE) if (! is.null(msg)) { w$signal(e, msg, w) exitFolder(e, w) } else if (w$isConstant(v, w)) v else exitFolder(e, w) } else exitFolder(e, w) } ## ## Finding local variables ## makeLocalsCollector <- function(..., leaf = function (e, w) character(0), handler = getCollectLocalsHandler, isLocal = function(v, w) FALSE, exit = function(e, msg, w) stop0(msg), collect = function(v, e, w) print(v)) makeCodeWalker(leaf = leaf, handler = handler, collect = collect, isLocal = isLocal) collectLocals <- function(e, collect) { w <- makeLocalsCollector(collect = collect) walkCode(e, w) } getCollectLocalsHandler <- function(v, w) { switch(v, "=" =, "<-" = collectLocalsAssignHandler, "for" = collectLocalsForHandler, "function" =, "~" = function(e, w) character(0), "local" = if (! w$isLocal(v, w)) collectLocalsLocalHandler, "expression" =, "Quote" =, # **** could add handler for bquote here that looks at the .()'s "quote" = if (! w$isLocal(v, w)) function(e, w) character(0), "delayedAssign" =, "assign" = function(e, w) if (length(e) == 3 && is.character(e[[2]]) && length(e[[2]]) == 1) { w$collect(e[[2]], e, w) walkCode(e[[3]], w) } else for (a in dropMissings(e[-1])) walkCode(a, w)) } dropMissings <- function(x) { lx <- as.list(x) ix <- rep(TRUE, length(x)) for (i in seq_along(ix)) { a <- lx[[i]] if (missing(a)) ix[i] <- FALSE } lx[ix] } collectLocalsAssignHandler <- function(e, w) { w$collect(getAssignedVar(e), e, w) walkCode(e[[2]], w) walkCode(e[[3]], w) } collectLocalsForHandler <- function(e, w) { signal <- function(msg) w$exit(e, msg, w) w$collect(as.character(checkSymOrString(e[[2]], signal)), e, w) walkCode(e[[3]], w) walkCode(e[[4]], w) } checkSymOrString <- function(e, signal = stop) { type <- typeof(e) if (type == "symbol" || type == "character") e else signal("not a symbol or string") } collectLocalsLocalHandler <- function(e, w) { if (length(e) == 2) # no explicit env character(0) else for (a in dropMissings(e[-1])) walkCode(a, w) } findLocalsList <- function(elist, envir = .BaseEnv) { localStopFuns <- c("expression", "quote", "Quote", "local") if (is.character(envir)) locals <- envir else locals <- localStopFuns[! sapply(localStopFuns,isBaseVar, envir)] specialSyntaxFuns <- c("~", "<-", "=", "for", "function") sf <- unique(c(locals, localStopFuns)) nsf <- length(sf) collect <- function(v, e, w) assign(v, TRUE, envir = env) isLocal <- function(v, w) as.character(v) %in% sf w <- makeLocalsCollector(collect = collect, isLocal = isLocal) repeat { env <- mkHash() for (e in elist) walkCode(e, w) isloc <- sapply(sf, exists, envir = env, inherits = FALSE) last.nsf <- nsf sf <- unique(c(locals, sf[isloc])) nsf <- length(sf) if (last.nsf == nsf) { vals <- ls(env, all.names = TRUE) rdsf <- vals %in% specialSyntaxFuns if (any(rdsf)) warning0(paste("local assignments to syntactic functions:", vals[rdsf])) return(vals) } } } findLocals <- function(e, envir = .BaseEnv) findLocalsList(list(e), envir) findOwnerEnv <- function(v, env, stop = NA, default = NA) { while (! identical(env, stop)) if (exists(v, envir = env, inherits = FALSE)) return(env) else if (is.emptyenv(env)) return(default) else env <- parent.env(env) default } isBaseVar <- function (v, env) { e <- findOwnerEnv(v, env) is.baseenv(e) || identical(e, .BaseNamespaceEnv) || v == "@<-" } findFuncLocals <- function(formals, body) findLocalsList(c(list(body), dropMissings(formals))) ## ## Assignment handling ## getAssignedVar <- function(e) { v <- e[[2]] if (missing(v)) stop0(paste("bad assignment:", pasteExpr(e))) else if (typeof(v) %in% c("symbol", "character")) as.character(v) else { while (typeof(v) == "language") { if (length(v) < 2) stop0(paste("bad assignment:", pasteExpr(e))) v <- v[[2]] if (missing(v)) stop0(paste("bad assignment:", pasteExpr(e))) } if (typeof(v) != "symbol") stop0(paste("bad assignment:", pasteExpr(e))) as.character(v) } } evalseq <- function(e) { if (typeof(e) == "language") { v <- evalseq(e[[2]]) e[[2]] <- as.name("*tmp*") c(v, list(e)) } else list(e) } apdef <- function(e) { v <- NULL tmp <- as.name("*tmp*") tmpv <- as.name("*tmpv*") while (typeof(e) == "language") { ef <- e ef[[1]] <- makeAssgnFcn(e[[1]]) if (typeof(ef[[2]]) == "language") ef[[2]] <- tmp ef$value <- tmpv v <- c(v, list(ef)) e <- e[[2]] } v } makeAssgnFcn <- function(fun) { if (typeof(fun) == "symbol" || typeof(fun) == "string") as.name(paste(as.character(fun), "<-", sep = "")) else { if (getRversion() >= "2.13.0" && typeof(fun) == "language" && typeof(fun[[1]]) == "symbol" && as.character(fun[[1]]) %in% c("::", ":::") && length(fun) == 3 && typeof(fun[[3]]) == "symbol") { fun[[3]] <- as.name(paste(as.character(fun[[3]]), "<-", sep = "")) fun } else stop(sQuote(deparse(fun)), " is not a valid function in complex assignments") } } flattenAssignment <- function(e) { if (typeof(e) == "language") list(evalseq(e[[2]]), apdef(e)) else list(NULL, NULL) } ## ## Collecting usage information ## makeUsageCollector <- function(fun, ..., name = NULL, enterLocal = doNothing, enterGlobal = doNothing, enterInternal = doNothing, startCollectLocals = doNothing, finishCollectLocals = doNothing, warn = warning0, signal = signalUsageIssue) { if (typeof(fun) != "closure") stop("only works for closures") makeCodeWalker(..., name = name, enterLocal = enterLocal, enterGlobal = enterGlobal, enterInternal = enterInternal, startCollectLocals = startCollectLocals, finishCollectLocals = finishCollectLocals, warn = warn, signal = signal, leaf = collectUsageLeaf, call = collectUsageCall, handler = getCollectUsageHandler, globalenv = environment(fun), env = environment(fun), name = NULL, srcfile = NULL, frow = NULL, lrow = NULL, isLocal = collectUsageIsLocal) } collectUsage <- function(fun, name = "", ...) { w <- makeUsageCollector(fun, ...) collectUsageFun(name, formals(fun), body(fun), w) } collectUsageLeaf <- function(v, w) { if (typeof(v) == "symbol") { vn <- as.character(v) if (v == "...") w$signal("... may be used in an incorrect context", w) else if (isDDSym(v)) { if (w$isLocal("...", w)) w$enterLocal("variable", "...", v, w) else w$signal(paste(v, "may be used in an incorrect context"), w) } else if (w$isLocal(vn, w)) w$enterLocal("variable", vn, v, w) else if (! vn %in% c("*tmp*", "*tmpv*")) w$enterGlobal("variable", vn, v, w) } } collectUsageArgs <- function(e, w) { for (a in dropMissings(e[-1])) if (typeof(a) == "symbol" && a == "...") { if (w$isLocal("...", w)) w$enterLocal("variable", "...", a, w) else w$signal(paste(a, "may be used in an incorrect context:", pasteExpr(e)), w) } else walkCode(a, w) } collectUsageCall <- function(e, w) { if (typeof(e[[1]]) %in% c("symbol", "character")) { fn <- as.character(e[[1]]) if (w$isLocal(fn, w)) w$enterLocal("function", fn, e, w) else w$enterGlobal("function", fn, e, w) } else walkCode(e[[1]], w) collectUsageArgs(e, w) } collectUsageFun <- function(name, formals, body, w) { w$name <- c(w$name, name) parnames <- names(formals) locals <- findFuncLocals(formals, body) w$env <- new.env(hash = TRUE, parent = w$env) for (n in c(parnames, locals)) assign(n, TRUE, w$env) w$startCollectLocals(parnames, locals, w) for (a in dropMissings(formals)) walkCode(a, w) walkCode(body, w) w$finishCollectLocals(w) } signalUsageIssue <- function(m, w) { if (!is.null(w$frow) && !is.na(w$frow)) { fname <- w$srcfile if (w$frow == w$lrow) loc <- paste(" (", fname, ":", w$frow, ")", sep = "") else loc <- paste(" (", fname, ":", w$frow, "-", w$lrow, ")", sep = "") } else loc <- NULL w$warn(paste(paste(w$name, collapse = " : "), ": ", m, loc, "\n", sep = "")) } # **** is this the right handling of ..n things? # **** signal (possible) error if used in wrong context? # **** also need error for ... when not present # **** maybe better done in leaf? collectUsageIsLocal <- function(v, w) { if (isDDSym(v)) v <- "..." ! is.baseenv(findOwnerEnv(v, w$env, stop = w$globalenv, default = .BaseEnv)) } doNothing <- function(...) NULL ## ## Usage collectors for some standard functions ## collectUsageHandlers <- mkHash() # 'where' is ignored for now addCollectUsageHandler <- function(v, where, fun) assign(v, fun, envir = collectUsageHandlers) getCollectUsageHandler <- function(v, w) if (exists(v, envir = collectUsageHandlers, inherits = FALSE) && (isBaseVar(v, w$env) || isStatsVar(v, w$env) || isUtilsVar(v, w$env) || # **** for now v == "Quote" )) # **** yet another glorious hack!!! get(v, envir = collectUsageHandlers) ##**** this is (yet another) temporary hack isStatsVar <- function(v, env) { e <- findOwnerEnv(v, env) if (exists(v, envir = e, inherits = FALSE, mode = "function")) { f <- get(v, envir = e, inherits = FALSE, mode = "function") identical(environment(f), getNamespace("stats")) } else FALSE } isUtilsVar <- function(v, env) { e <- findOwnerEnv(v, env) if (exists(v, envir = e, inherits = FALSE, mode = "function")) { f <- get(v, envir = e, inherits = FALSE, mode = "function") identical(environment(f), getNamespace("utils")) } else FALSE } isSimpleFunDef <- function(e, w) typeof(e[[2]]) != "language" && typeof(e[[3]]) == "language" && typeof(e[[3]][[1]]) %in% c("symbol", "character") && e[[3]][[1]] == "function" && isBaseVar("function", w$env) checkDotsAssignVar <- function(v, w) { if (v == "...") { w$signal("... may be used in an incorrect context", w) FALSE } else if (isDDSym(v)) { w$signal(paste(v, "may be used in an incorrect context"), w) FALSE } else TRUE } #**** proceeds even if "..." or "..1", etc--is that right? local({ h <- function(e, w) { w$enterGlobal("function", as.character(e[[1]]), e, w) v <- getAssignedVar(e) checkDotsAssignVar(v, w) w$enterLocal("<-", v, e, w) if (isSimpleFunDef(e, w)) collectUsageFun(v, e[[3]][[2]], e[[3]][[3]], w) else { if (typeof(e[[2]]) == "language") { fa <- flattenAssignment(e[[2]]) for (a in fa) for (b in a) walkCode(b, w) } walkCode(e[[3]], w) } } addCollectUsageHandler("<-", "base", h) addCollectUsageHandler("=", "base", h) }) #**** would be better to use match.call in most of these #**** proceeds even if "..." or "..1", etc--is that right? addCollectUsageHandler("<<-", "base", function(e, w) { w$enterGlobal("function", "<<-", e, w) v <- getAssignedVar(e) checkDotsAssignVar(v, w) if (w$isLocal(v, w)) w$enterLocal("<<-", v, e, w) else w$enterGlobal("<<-", v, e, w) if (typeof(e[[2]]) == "language") { fa <- flattenAssignment(e[[2]]) for (a in fa) for (b in a) walkCode(b, w) } walkCode(e[[3]], w) }) addCollectUsageHandler("for", "base", function(e, w) { w$enterGlobal("function", "for", e, w) v <- as.character(e[[2]]) w$enterLocal("for", v, e, w) walkCode(e[[3]], w) walkCode(e[[4]], w) }) addCollectUsageHandler("{", "base", function(e, w) { w$enterGlobal("function", "{", e, w) w$srcfile <- attr(e, "srcfile")$filename if (length(e)>1){ for ( i in 2 : length(e)){ if ( !is.null(attr(e, "srcref")[[i]])){ w$frow <- attr(e, "srcref")[[i]][[1]] w$lrow <- attr(e, "srcref")[[i]][[3]] } walkCode(e[[i]], w) } } }) #**** is this the right way to handle :: and ::: ?? #**** maybe record package/name space? local({ h <- function(e, w) w$enterGlobal("function", as.character(e[[1]]), e, w) addCollectUsageHandler("~", "base", h) addCollectUsageHandler("quote", "base", h) addCollectUsageHandler("Quote", "methods", h) addCollectUsageHandler("expression", "base", h) addCollectUsageHandler("::", "base", h) addCollectUsageHandler(":::", "base", h) }) #**** add counter to anonymous functions to distinguish?? addCollectUsageHandler("function", "base", function(e, w) collectUsageFun("", e[[2]], e[[3]], w)) addCollectUsageHandler("local", "base", function(e, w) { w$enterGlobal("function", "local", e, w) if (length(e) == 2) collectUsageFun("", NULL, e[[2]], w) else collectUsageArgs(e, w) }) addCollectUsageHandler("assign", "base", function(e, w) { w$enterGlobal("function", "assign", e, w) if (length(e) == 3 && is.character(e[[2]]) && length(e[[2]]) == 1) { w$enterLocal("<-", e[[2]], e, w) walkCode(e[[3]], w) } else collectUsageArgs(e, w) }) addCollectUsageHandler("with", "base", function(e, w) { w$enterGlobal("function", "with", e, w) if (identical(w$skipWith, TRUE)) walkCode(e[[2]], w) else collectUsageArgs(e, w) }) local({ h <- function(e, w) { w$enterGlobal("function", as.character(e[[1]]), e, w) walkCode(e[[2]], w) } addCollectUsageHandler("$", "base", h) addCollectUsageHandler("@", "base", h) }) local({ h <- function(e, w) { w$enterGlobal("function", as.character(e[[1]]), e, w) walkCode(e[[2]], w) walkCode(e[[4]], w) } addCollectUsageHandler("$<-", "base", h) addCollectUsageHandler("@<-", "base", h) }) addCollectUsageHandler(".Internal", "base", function(e, w) { w$enterGlobal("function", ".Internal", e, w) if (length(e) != 2) w$signal(paste("wrong number of arguments to '.Internal':", pasteExpr(e)), w) else if (typeof(e[[2]]) == "language") { w$enterInternal(e[[2]][[1]], e[[2]], w) collectUsageArgs(e[[2]], w) } else w$signal(paste("bad argument to '.Internal':", pasteExpr(e[[2]])), w) }) addCollectUsageHandler("substitute", "base", function(e, w) { w$enterGlobal("function", "substitute", e, w) if (length(e) > 3) w$signal("wrong number of arguments to 'substitute'", w) if (length(e) == 3) { a <- e[[3]] if (! missing(a)) walkCode(a, w) } }) addCollectUsageHandler("bquote", "base", function(e, w) { w$enterGlobal("function", "bquote", e, w) if (length(e) > 3) w$signal("wrong number of arguments to 'bquote'", w) if (length(e) == 3) { a <- e[[3]] if (! missing(a)) walkCode(a, w) } }) addCollectUsageHandler("library", "base", function(e, w) { w$enterGlobal("function", "library", e, w) if (length(e) > 2) for(a in dropMissings(e[-(1:2)])) walkCode(a, w) }) addCollectUsageHandler("require", "base", function(e, w) { w$enterGlobal("function", "require", e, w) if (length(e) > 2) for(a in dropMissings(e[-(1:2)])) walkCode(a, w) }) addCollectUsageHandler("data", "utils", function(e, w) { w$enterGlobal("function", "data", e, w) }) mkLinkHandler <- function(family, okLinks) { function(e, w) { w$enterGlobal("function", family, e, w) if (length(e) >= 2) { if (is.character(e[[2]])) { if (! (e[[2]] %in% okLinks)) w$signal(paste("link", sQuote(e[[2]]), "not available for", sQuote(family)), w) } else if (! is.name(e[[2]]) || ! as.character(e[[2]]) %in% okLinks) walkCode(e[[2]], w) } } } addCollectUsageHandler("detach", "base", function(e, w) { w$enterGlobal("function", "detach", e, w) if (length(e) > 2) for(a in dropMissings(e[-(1:2)])) walkCode(a, w) }) addCollectUsageHandler("binomial", "stats", mkLinkHandler("binomial", c("logit", "probit", "cloglog", "cauchit", "log"))) addCollectUsageHandler("gaussian", "stats", mkLinkHandler("gaussian", c("inverse", "log", "identity"))) addCollectUsageHandler("Gamma", "stats", mkLinkHandler("Gamma", c("inverse", "log", "identity"))) addCollectUsageHandler("poisson", "stats", mkLinkHandler("poisson", c("log", "identity", "sqrt"))) addCollectUsageHandler("quasibinomial", "stats", mkLinkHandler("quasibinomial", c("logit", "probit", "cloglog", "cauchit", "log"))) addCollectUsageHandler("quasipoisson", "stats", mkLinkHandler("quasipoisson", c("log", "identity", "sqrt"))) addCollectUsageHandler("quasi", "stats", function(e, w) { w$enterGlobal("function", "quasi", e, w) # **** don't look at arguments for now. Need to use match.call # **** to get this right and trap errors. Later ... }) addCollectUsageHandler("if", "base", function(e, w) { w$enterGlobal("function", "if", e, w) test <- constantFoldEnv(e[[2]], w$env) if (is.logical(test) && length(test) == 1 && ! is.na(test)) { walkCode(e[[2]], w) if (test) walkCode(e[[3]], w) else if (length(e) > 3) walkCode(e[[4]], w) } else collectUsageArgs(e, w) }) ## ## Finding globa variables ## findGlobals <- function(fun, merge = TRUE) { vars <- mkHash() funs <- mkHash() enter <- function(type, v, e, w) if (type == "function") assign(v, TRUE, funs) else assign(v, TRUE, vars) collectUsage(fun, enterGlobal = enter) fnames <- ls(funs, all.names = TRUE) vnames <- ls(vars, all.names = TRUE) if (merge) sort(unique(c(vnames, fnames))) else list(functions = fnames, variables = vnames) } ## ## Checking function and variable usage ## checkUsageStartLocals <- function(parnames, locals, w) { env <- w$env nplocals <- locals[! locals %in% parnames] attr(env, "checkUsageFrame") <- env # for sanity check mkentry <- function(parameter) { entry <- mkHash() assign("parameter", parameter, envir = entry) assign("assigns", 0, envir = entry) assign("varuses", 0, envir = entry) assign("funuses", 0, envir = entry) assign("funforms", NULL, envir = entry) assign("loopvars", 0, envir = entry) assign("srcinfo", NULL, envir = entry) entry } for (v in parnames) assign(v, mkentry(TRUE), envir = env) for (v in nplocals) assign(v, mkentry(FALSE), envir = env) } getLocalUsageEntry <- function(vn, w) { env <- findOwnerEnv(vn, w$env, stop = w$globalenv, default = .BaseEnv) if (is.baseenv(env)) stop("no local variable entry") if (! identical(env, attr(env, "checkUsageFrame"))) stop("sanity check on local usage frame failed") entry <- get(vn, envir = env, inherits = FALSE) if (! is.environment(entry)) stop("bad local variable entry") entry } getLocalUsageValue <- function(vn, which, w) get(which, getLocalUsageEntry(vn, w), inherits = FALSE) setLocalUsageValue <- function(vn, which, value, w) assign(which, value, envir = getLocalUsageEntry(vn, w)) incLocalUsageValue <- function(vn, which, w) { entry <- getLocalUsageEntry(vn, w) value <- get(which, entry, inherits = FALSE) assign(which, value + 1, entry) } incLocalSrcInfo <- function(vn, w) { entry <- getLocalUsageEntry(vn, w) value <- get("srcinfo", entry, inherits = FALSE) new <- list(srcfile = if (is.null(w$srcfile)) NA_character_ else w$srcfile, frow = if (is.null(w$frow)) NA_integer_ else w$frow, lrow = if (is.null(w$lrow)) NA_integer_ else w$lrow) new <- as.data.frame(new, stringsAsFactors = FALSE) if (is.null(value)) value <- new else value <- rbind(value, new) assign("srcinfo", value, entry) } addLocalFunDef <- function(vn, e, w) { entry <- getLocalUsageEntry(vn, w) value <- get("funforms", entry, inherits = FALSE) assign("funforms", c(value, list(e[[3]][[2]])), entry) } checkUsageEnterLocal <- function(type, n, e, w) { if (type %in% c("<-", "<<-") && isSimpleFunDef(e, w)) type <- "fundef" switch(type, "<-" =, "<<-" = incLocalUsageValue(n, "assigns", w), "variable" = incLocalUsageValue(n, "varuses", w), "function" = incLocalUsageValue(n, "funuses", w), "for" = incLocalUsageValue(n, "loopvars", w), "fundef" = addLocalFunDef(n, e, w)) incLocalSrcInfo(n,w) } suppressVar <- function(n, suppress) { if (is.logical(suppress)) { if (suppress) TRUE else FALSE } else n %in% suppress } #**** need test code #**** merge warnings? checkUsageFinishLocals <- function(w) { vars <- ls(w$env, all.names = TRUE) for (v in vars) { if (! suppressVar(v, w$suppressLocal)) { parameter <- getLocalUsageValue(v, "parameter", w) assigns <- getLocalUsageValue(v, "assigns", w) varuses <- getLocalUsageValue(v, "varuses", w) funuses <- getLocalUsageValue(v, "funuses", w) loopvars <- getLocalUsageValue(v, "loopvars", w) funforms <- getLocalUsageValue(v, "funforms", w) uses <- max(varuses, funuses, loopvars) srcinfo <- getLocalUsageValue(v, "srcinfo", w) w$srcfile <- srcinfo[1,"srcfile"] w$frow <- srcinfo[1,"frow"] w$lrow <- srcinfo[1,"lrow"] if (parameter) { if (! suppressVar(v, w$suppressParamAssigns) && assigns > 0) w$signal(paste("parameter", sQuote(v), "changed by assignment"), w) else if (! suppressVar(v, w$suppressParamUnused) && uses == 0 && v != "...") w$signal(paste("parameter", sQuote(v), "may not be used"), w) } else { if (uses == 0) { if (! suppressVar(v, w$suppressLocalUnused)) w$signal(paste("local variable", sQuote(v), "assigned but may not be used"), w) } else if (funuses > 0 && is.null(funforms)) { if (! suppressVar(v, w$suppressNoLocalFun)) w$signal(paste("local variable", sQuote(v), "used as function with no apparent", "local function definition"), w) } } if (! suppressVar(v, w$suppressFundefMismatch) && length(funforms) > 1) { first <- funforms[[1]] nfirst <- names(first) for (d in funforms[-1]) if (! identical(first, d) || ! identical(nfirst, names(d))) { w$signal(paste("multiple local function", "definitions for", sQuote(v), "with different formal arguments"), w) break } } } } } #**** warn if non-function used as variable (most likely get false positives) #**** merge warnings? checkUsageEnterGlobal <- function(type, n, e, w) { if (type == "function") { if (exists(n, envir = w$globalenv, mode = "function")) { # **** better call check here def <- get(n, envir = w$globalenv, mode = "function") if (typeof(def) == "closure") checkCall(def, e, function(m) w$signal(m, w)) else { isBuiltin <- typeof(def) == "builtin" checkPrimopCall(n, e, isBuiltin, function(m) w$signal(m, w)) } } else if (! suppressVar(n, w$suppressUndefined)) w$signal(paste("no visible global function definition for", sQuote(n)), w) } else if (type == "variable") { if (! exists(n, w$globalenv) && ! suppressVar(n, w$suppressUndefined)) w$signal(paste("no visible binding for global variable", sQuote(n)), w) } else if (type == "<<-") { if (! exists(n, w$globalenv)) w$signal(paste("no visible binding for '<<-' assignment to", sQuote(n)), w) } } dfltSuppressUndefined <- c(".Generic", ".Method", ".Class", ".split.valid.screens", ".split.cur.screen", ".split.saved.pars", ".split.screens", ".split.par.list", "last.dump") #**** merge undefined variable warnings per top level function (at least) #**** allow complete suppress or by name for all?? checkUsage <- function(fun, name = "", report = cat, all = FALSE, suppressLocal = FALSE, suppressParamAssigns = ! all, suppressParamUnused = !all, suppressFundefMismatch = FALSE, suppressLocalUnused = FALSE, suppressNoLocalFun = ! all, skipWith = FALSE, suppressUndefined = dfltSuppressUndefined, suppressPartialMatchArgs = TRUE) { if (is.null(getOption("warnPartialMatchArgs"))) options(warnPartialMatchArgs = FALSE) if (! suppressPartialMatchArgs) { oldOpts <- options(warnPartialMatchArgs = TRUE) on.exit(options(oldOpts)) } collectUsage(fun, name = name, warn = report, suppressLocal = suppressLocal, suppressParamAssigns = suppressParamAssigns, suppressParamUnused = suppressParamUnused, suppressFundefMismatch = suppressFundefMismatch, suppressLocalUnused = suppressLocalUnused, suppressNoLocalFun = suppressNoLocalFun, skipWith = skipWith, enterGlobal = checkUsageEnterGlobal, enterLocal = checkUsageEnterLocal, startCollectLocals = checkUsageStartLocals, finishCollectLocals = checkUsageFinishLocals, suppressUndefined = suppressUndefined, suppressPartialMatchArgs = suppressPartialMatchArgs) } checkUsageEnv <- function(env, ...) { for (n in ls(env, all.names=TRUE)) { v <- get(n, envir = env) if (typeof(v)=="closure") checkUsage(v, name = n, ...) } } checkUsagePackage <- function(pack, ...) { pname <- paste("package", pack, sep = ":") if (! pname %in% search()) stop("package must be loaded") if (pack %in% loadedNamespaces()) checkUsageEnv(getNamespace(pack), ...) else checkUsageEnv(as.environment(pname), ...) } #++++ check against internal arg count? primopArgCounts <- mkHash() anyMissing <- function(args) { for (i in 1:length(args)) { a <-args[[i]] if (missing(a)) return(TRUE) #**** better test? } return(FALSE) } noMissingAllowed <- c("c") checkPrimopCall <- function(fn, e, isBuiltin, signal = warning0) { if (anyMissing(e[-1])) { if (isBuiltin || fn %in% noMissingAllowed) signal(paste("missing arguments not allowed in calls to", sQuote(fn))) } if (exists(".GenericArgsEnv") && exists(fn, get(".GenericArgsEnv"))) { def <- get(fn, envir = get(".GenericArgsEnv")) checkCall(def, e, signal) } else if (exists(".ArgsEnv") && exists(fn, get(".ArgsEnv"))) { def <- get(fn, envir = get(".ArgsEnv")) checkCall(def, e, signal) } else if (exists(fn, envir = primopArgCounts, inherits = FALSE)) { argc <- get(fn, envir = primopArgCounts) if (! any(argc == (length(e) - 1))) { signal(paste("wrong number of arguments to", sQuote(fn))) FALSE } else TRUE } else TRUE } local({ zeroArgPrims <- c("break", "browser", "gc.time", "globalenv", "interactive", "nargs", "next", "proc.time") for (fn in zeroArgPrims) assign(fn, 0, envir = primopArgCounts) zeroOrOneArgPrims <- c("invisible") for (fn in zeroOrOneArgPrims) assign(fn, 0:1, envir = primopArgCounts) oneArgPrims <- c("!", "(", "abs", "sqrt", "cos", "sin", "tan", "acos", "asin", "atan", "Re", "Im", "Mod", "Arg", "Conj", "cosh", "sinh", "tanh", "acosh", "asinh", "atanh", "sign", "length", "repeat", ".Primitive", "class", "oldClass", "standardGeneric", "unclass", "ceiling", "floor", "trunc", "is.array", "is.atomic", "is.call", "is.character", "is.complex", "is.double", "is.environment", "is.expression", "is.finite", "is.function", "is.infinite", "is.integer", "is.language", "is.list", "is.loaded", "is.logical", "is.matrix", "is.na", "is.name", "is.nan", "is.null", "is.numeric", "is.object", "is.pairlist", "is.real", "is.recursive", "is.single", "is.symbol", "debug", "undebug", "as.character", "as.call", "as.environment", "attributes", "cumsum", "cumprod", "cummax", "cummin", "dim", "dimnames", "exp", "missing", "pos.to.env", ".primTrace", ".primUntrace", "symbol.C", "symbol.For") for (fn in oneArgPrims) assign(fn, 1, envir = primopArgCounts) oneOrTwoArgPrims <- c("+", "-") for (fn in oneOrTwoArgPrims) assign(fn, 1:2, envir = primopArgCounts) twoArgPrims <- c("*", "/", "%%", "^", "<", "<=", "==", ">", ">=", "|", "||", ":", "!=", "&", "&&", "%/%", "%*%", "while", "attr", "attributes<-", "class<-", "oldClass<-", "dim<-", "dimnames<-", "environment<-", "length<-", "reg.finalizer") for (fn in twoArgPrims) assign(fn, 2, envir = primopArgCounts) assign("on.exit", 0:2, primopArgCounts) }) matchName <- function(name, list) if (match(as.character(name), list, 0)) TRUE else FALSE findVar <- function(e, env) matchName(e, env) checkCall <- function(def, call, signal = warning0) { testMatch <- function(...) ## withCallingHandlers is used to capture partial argument ## matcing warnings if enabled. withCallingHandlers(match.call(def, call, FALSE), warning = function(w) { msg <- conditionMessage(w) signal(paste("warning in ", deparse(call, width.cutoff = 500), ": ", msg, sep="")) invokeRestart("muffleWarning") }) msg <- tryCatch({testMatch(); NULL}, error = function(e) conditionMessage(e)) if (! is.null(msg)) { emsg <- paste("possible error in ", deparse(call, width.cutoff = 500), ": ", msg, sep="") if (! is.null(signal)) signal(emsg) FALSE } else TRUE } ## ## Various utilities ## warning0 <- function(msg) warning(msg, call.=FALSE) stop0 <- function(msg) stop(msg, call.=FALSE) pasteExpr <- function(e, prefix = "\n ") { de <- deparse(e) if (length(de) == 1) sQuote(de) else paste(prefix, deparse(e), collapse="") } dotsOrMissing <- 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) } anyDots <- function(args) { for (i in 1:length(args)) { a <-args[[i]] if (! missing(a) && typeof(a) == "symbol" && a == "...") return(TRUE) } return(FALSE) } isDDSym <- function(name) { (is.symbol(name) || is.character(name)) && length(grep("^\\.\\.[[:digit:]]+$", as.character(name))) != 0 } codetools/man/0000755000175100001440000000000011526312554013042 5ustar hornikuserscodetools/man/findGlobals.Rd0000644000175100001440000000131211256323260015546 0ustar hornikusers\name{findGlobals} \title{Find Global Functions and Variables Used by a Closure} \usage{ findGlobals(fun, merge = TRUE) } \alias{findGlobals} \arguments{ \item{fun}{closure.} \item{merge}{logical} } \value{ Character vector if \code{merge} is true; otherwise, a list with \code{functions} and \code{variables} components. } \description{ Finds global functions and variables used by a closure. } \details{ The result is an approximation. R semantics only allow variables that might be local to be identified (and event that assumes no use of \code{assign} and \code{rm}). } \author{Luke Tierney} \examples{ findGlobals(findGlobals) findGlobals(findGlobals, merge = FALSE) } \keyword{programming} codetools/man/checkUsage.Rd0000644000175100001440000000575511463556710015413 0ustar hornikusers\name{checkUsage} \title{Check R Code for Possible Problems} \usage{ checkUsage(fun, name = "", report = cat, all = FALSE, suppressLocal = FALSE, suppressParamAssigns = !all, suppressParamUnused = !all, suppressFundefMismatch = FALSE, suppressLocalUnused = FALSE, suppressNoLocalFun = !all, skipWith = FALSE, suppressUndefined = dfltSuppressUndefined, suppressPartialMatchArgs = TRUE) checkUsageEnv(env, ...) checkUsagePackage(pack, ...) } \alias{checkUsage} \alias{checkUsageEnv} \alias{checkUsagePackage} \arguments{ \item{fun}{closure.} \item{name}{character; name of closure.} \item{env}{environment containing closures to check.} \item{pack}{character naming package to check.} \item{\dots}{options to be passed to \code{checkUsage}.} \item{report}{function to use to report possible problems.} \item{all}{logical; report all possible problems if TRUE.} \item{suppressLocal}{suppress all local variable warnings.} \item{suppressParamAssigns}{suppress warnings about assignments to formal parameters.} \item{suppressParamUnused}{suppress warnings about unused formal parameters.} \item{suppressFundefMismatch}{suppress warnings about multiple local function definitions with different formal argument lists} \item{suppressLocalUnused}{suppress warnings about unused local variables} \item{suppressNoLocalFun}{suppress warnings about using local variables as functions with no apparent local function definition} \item{skipWith}{logical; if true, do no examine code portion of \code{with} expressions.} \item{suppressUndefined}{suppress warnings about undefined global functions and variables.} \item{suppressPartialMatchArgs}{suppress warnings about partial argument matching} } \description{ Check R code for possible problems. } \details{ \code{checkUsage} checks a single R closure. Options control which possible problems to report. The default settings are moderately verbose. A first pass might use \code{suppressLocal=TRUE} to suppress all information related to local variable usage. The \code{suppressXYZ} values can either be scalar logicals or character vectors; then they are character vectors they only suppress problem reports for the variables with names in the vector. \code{checkUsageEnv} and \code{checkUsagePackage} are convenience functions that apply \code{checkUsage} to all closures in an environment or a package. \code{checkUsagePackage} requires that the package be loaded. If the package has a name space then the internal name space frame is checked. } \author{Luke Tierney} \examples{ checkUsage(checkUsage) checkUsagePackage("codetools",all=TRUE) \dontrun{checkUsagePackage("base",suppressLocal=TRUE)} } \keyword{programming} codetools/man/showTree.Rd0000644000175100001440000000075211256323260015131 0ustar hornikusers\name{showTree} \title{Print Lisp-Style Representation of R Expression} \usage{ showTree(e, write = cat) } \alias{showTree} \arguments{ \item{e}{R expression.} \item{write}{function of one argument to write the result.} } \description{ Prints a Lisp-style representation of R expression. This can be useful for understanding how some things are parsed. } \author{Luke Tierney} \examples{ showTree(quote(-3)) showTree(quote("x"<-1)) showTree(quote("f"(x))) } \keyword{programming} codetools/man/codetools.Rd0000644000175100001440000000370411256323260015324 0ustar hornikusers\name{codetools} \alias{codetools} \title{Low Level Code Analysis Tools for R} \usage{ collectLocals(e, collect) collectUsage(fun, name = "", ...) constantFold(e, env = NULL, fail = NULL) findFuncLocals(formals, body) findLocals(e, envir = .BaseEnv) findLocalsList(elist, envir = .BaseEnv) flattenAssignment(e) getAssignedVar(e) isConstantValue(v, w) makeCodeWalker(..., handler, call, leaf) makeLocalsCollector(..., leaf, handler, isLocal, exit, collect) makeUsageCollector(fun, ..., name, enterLocal, enterGlobal, enterInternal, startCollectLocals, finishCollectLocals, warn, signal) walkCode(e, w = makeCodeWalker()) } \alias{collectLocals} \alias{collectUsage} \alias{constantFold} \alias{findFuncLocals} \alias{findLocals} \alias{findLocalsList} \alias{flattenAssignment} \alias{getAssignedVar} \alias{isConstantValue} \alias{makeCodeWalker} \alias{makeConstantFolder} \alias{makeLocalsCollector} \alias{makeUsageCollector} \alias{walkCode} \arguments{ \item{e}{R expression.} \item{elist}{list of R expressions.} \item{v}{R object.} \item{fun}{closure.} \item{formals}{formal arguments of a closure.} \item{body}{body of a closure.} \item{name}{character.} \item{env}{character.} \item{envir}{environment.} \item{w}{code walker.} \item{\dots}{extra elements for code walker.} \item{collect}{function.} \item{fail}{function.} \item{handler}{function.} \item{call}{function.} \item{leaf}{function.} \item{isLocal}{function.} \item{exit}{function.} \item{enterLocal}{function.} \item{enterGlobal}{function.} \item{enterInternal}{function.} \item{startCollectLocals}{function.} \item{finishCollectLocals}{function.} \item{warn}{function.} \item{signal}{function.} } \description{ These functions provide some tools for analysing R code. Mainly indented to support the other tools in this package and byte code compilation. } \author{Luke Tierney} \keyword{programming} codetools/NAMESPACE0000644000175100001440000000057411455144435013516 0ustar hornikusersexport(walkCode,makeCodeWalker) export(showTree) export(makeConstantFolder,constantFold) export(isConstantValue) export(getAssignedVar) export(makeLocalsCollector,collectLocals) export(findLocals,findLocalsList) export(findFuncLocals) export(flattenAssignment) export(makeUsageCollector,collectUsage) export(findGlobals) export(checkUsage, checkUsageEnv, checkUsagePackage) codetools/DESCRIPTION0000644000175100001440000000053211526446340013776 0ustar hornikusersPackage: codetools Version: 0.2-8 Priority: recommended Author: Luke Tierney Description: Code analysis tools for R Title: Code Analysis Tools for R Depends: R (>= 2.1) Maintainer: Luke Tierney License: GPL Packaged: 2011-02-14 20:49:48 UTC; luke Repository: CRAN Date/Publication: 2011-02-15 09:52:32 codetools/tests/0000755000175100001440000000000011526312554013431 5ustar hornikuserscodetools/tests/tests.R0000644000175100001440000001007611476406466014734 0ustar hornikuserslibrary(codetools) assert <- function(e) if (! e) stop(paste("assertion failed:", deparse(substitute(e)))) local({ st <- function(e) { v <- NULL write <- function(x) v <<- paste(v, as.character(x), sep = "") showTree(e, write = write) v } assert(identical(st(quote(f(x))), "(f x)\n")) assert(identical(st(quote((x+y)*z)), "(* (\"(\" (+ x y)) z)\n")) assert(identical(st(quote(-3)), "(- 3)\n")) }) assert(identical(constantFold(quote(3)), 3)) assert(identical(constantFold(quote(1+2)), 3)) assert(identical(constantFold(quote(1+2+x)), NULL)) assert(identical(constantFold(quote(pi)), pi)) assert(identical(constantFold(quote(pi), "pi"), NULL)) assert(identical(constantFold(quote(pi), "pi", FALSE), FALSE)) assert(identical(getAssignedVar(quote("v"<-x)), "v")) assert(identical(getAssignedVar(quote(v<-x)), "v")) assert(identical(getAssignedVar(quote(f(v)<-x)), "v")) assert(identical(getAssignedVar(quote(f(g(v,2),1)<-x)), "v")) assert(identical(findLocals(quote(x<-1)), "x")) assert(identical(findLocals(quote(f(x)<-1)), "x")) assert(identical(findLocals(quote(f(g(x,2),1)<-1)), "x")) assert(identical(findLocals(quote(x<-y<-1)), c("x","y"))) assert(identical(findLocals(quote(local(x<-1,e))), "x")) assert(identical(findLocals(quote(local(x<-1))), character(0))) assert(identical(findLocals(quote({local<-1;local(x<-1)})), c("local", "x"))) assert(identical(findLocals(quote(local(x<-1,e)), "local"), "x")) local({ f <- function (f, x, y) { local <- f local(x <- y) x } assert(identical(findLocals(body(f)), c("local","x"))) }) local({ env <- new.env() assign("local", 1, env) assert(identical(findLocals(quote(local(x<-1,e)), env), "x")) }) assert(identical(findLocals(quote(assign(x, 3))), character(0))) assert(identical(findLocals(quote(assign("x", 3))), "x")) assert(identical(findLocals(quote(assign("x", 3, 4))), character(0))) local({ f<-function() { x <- 1; y <- 2} assert(identical(sort(findFuncLocals(formals(f),body(f))), c("x","y"))) f<-function(u = x <- 1) y <- 2 assert(identical(sort(findFuncLocals(formals(f),body(f))), c("x","y"))) }) assert(identical(flattenAssignment(quote(x)), list(NULL, NULL))) assert(identical(flattenAssignment(quote(f(x, 1))), list(list(quote(x)), list(quote("f<-"(x, 1, value = `*tmpv*`)))))) assert(identical(flattenAssignment(quote(f(g(x, 2), 1))), list(list(quote(x), quote(g(`*tmp*`, 2))), list(quote("f<-"(`*tmp*`, 1, value = `*tmpv*`)), quote("g<-"(x, 2, value = `*tmpv*`)))))) assert(identical(flattenAssignment(quote(f(g(h(x, 3), 2), 1))), list(list(quote(x), quote(h(`*tmp*`, 3)), quote(g(`*tmp*`, 2))), list(quote("f<-"(`*tmp*`, 1, value = `*tmpv*`)), quote("g<-"(`*tmp*`, 2, value = `*tmpv*`)), quote("h<-"(x, 3, value = `*tmpv*`)))))) assert(identical(flattenAssignment(quote(f(g(h(k(x, 4), 3), 2), 1))), list(list(quote(x), quote(k(`*tmp*`, 4)), quote(h(`*tmp*`, 3)), quote(g(`*tmp*`, 2))), list(quote("f<-"(`*tmp*`, 1, value = `*tmpv*`)), quote("g<-"(`*tmp*`, 2, value = `*tmpv*`)), quote("h<-"(`*tmp*`, 3, value = `*tmpv*`)), quote("k<-"(x, 4, value = `*tmpv*`)))))) if (getRversion() >= "2.13.0") assert(identical(flattenAssignment(quote(base::diag(x))), list(list(quote(x)), list(quote(base::`diag<-`(x, value = `*tmpv*`)))))) assert(! "y" %in% findGlobals(function() if (is.R()) x else y)) assert(identical(findGlobals(function() if (FALSE) x), "if")) # **** need more test cases here assert(identical(sort(findGlobals(function(x) { z <- 1; x + y + z})), sort(c("<-", "{", "+", "y")))) assert(identical(findGlobals(function() Quote(x)), "Quote"))