Scheme Interpreter in R (more R-ish implementation of "lisp.R")

lispr.R

## Scheme Interpreter in R
## (more R-ish implementation of "lisp.R")

addGlobals <- function(env) {
    procs <- list("+" = sum,
                  "*" = prod,
                  "-" = function(...) Reduce(`-`, list(...)),
                  "/" = function(...) Reduce(`/`, list(...)),
                  "=" = `==`,
                  "eq?" = `==`,
                  "equal?" = identical,
                  "not" = `!`,
                  "cons" = function(x, y) append(list(x), y),
                  "car" = function(x) x[[1]],
                  "cdr" = function(x) x[-1],
                  "list?" = is.list,
                  "null?" = function(x) identical(x, list()),
                  "symbol?" = is.character
                  )

    rfname <- c(">", "<", ">=", "<=", "list", "length")
    rfunc <- list()
    rfunc[rfname] <- rfname
    procs <- append(procs, rfunc)

    for (name in names(procs)) assign(name, procs[[name]], envir=env)
}

evaluate <- function(x, env) {
    if (is.character(x)) {              # variable reference
        get(x, envir=env)
    } else if (!is.list(x)) {           # constant literal
        x
    } else if (identical(x[[1]], "quote")) { # (quote exp)
        x[[2]]
    } else if (identical(x[[1]], "if")) { # (if test conseq alt)
        test   <- x[[2]]
        conseq <- x[[3]]
        alt    <- x[[4]]
        if (evaluate(test, env)) {
            evaluate(conseq, env)
        } else {
            evaluate(alt, env)
        }
    } else if (identical(x[[1]], "set!")) { # (set! var exp)
        var <- x[[2]]
        exp <- x[[3]]
        assign(var, evaluate(exp, env), envir=env)
    } else if (identical(x[[1]], "define")) { # (define var exp)
        var <- x[[2]]
        exp <- x[[3]]
        assign(var, evaluate(exp, env), envir=env)
    } else if (identical(x[[1]], "lambda")) { # (lambda (var*) exp*)
        vars <- x[[2]]
        exps <- x[-c(1, 2)]
        function(...) {
            args = list(...)
            inner <- new.env(parent=env)
            for (i in seq(vars)) assign(vars[[i]], args[[i]], envir=inner)

            for (exp in exps) val <- evaluate(exp, inner)
            val
        }
    } else if (identical(x[[1]], "begin")) { # (begin exp*)
        for (exp in x[-1]) val <- evaluate(exp, env)
        val
    } else {                            # (proc exp*)
        xeval <- lapply(x, function(exp) evaluate(exp, env))
        proc <- xeval[[1]]
        exps <- xeval[-1]
        do.call(proc, exps)
    }
}

read <- function(s) {
    readFrom(tokenize(s), 1)[[1]]
}

parse <- read

tokenize <- function(s) {
    s <- gsub("\\(", " ( ", s)
    s <- gsub("\\)", " ) ", s)
    s <- sub("^\\s+", "", s)

    strsplit(s, "\\s+")[[1]]
}

readFrom <- function(tokens, i) {
    if (length(tokens) < i) stop("unexpected EOF while reading")

    if (tokens[i] == "(") {
        L <- list()
        i <- i + 1                      # skip "("
        while(tokens[i] != ")") {
            res <- readFrom(tokens, i)
            L <- append(L, res[1])
            i <- res[[2]]
        }
        i <- i + 1                      # skip ")"
        return(list(L, i))
    } else if (tokens[i] == ")") {
        stop("unexpected )")
    } else {
        return(list(atom(tokens[i]), i + 1))
    }
}

atom <- function(token) {
    num <- suppressWarnings(as.numeric(token))
    if (is.na(num)) token else num
}

toString <- function(exp) {
    if (is.list(exp)) {
        sprintf("(%s)", do.call(paste, lapply(exp, toString)))
    } else {
        tryCatch(as.character(exp),
                 error=function(e) sprintf("#<%s>", typeof(exp)))
    }
}

repl <- function(prompt='lispr> ', parent=.GlobalEnv) {
    env <- new.env(parent=parent)
    addGlobals(env)

    while(TRUE) {
        val <- evaluate(parse(readline(prompt)), env)
        cat(toString(val))
        cat("\n")
    }
}