Scheme Interpreter in R (an R port of the Peter Norvig's "lis.py")

lisp.R

## Scheme Interpreter in R
## (an R port of the Peter Norvig's "lis.py")

Env <- setRefClass('Env',
                   fields = c(".outer", ".dict"),
                   methods = list(
                     initialize = function(outer=NULL) {
                       .outer <<- outer
                       .dict <<- list()
                     },
                     get = function(key) {
                       .dict[[key]]
                     },
                     set = function(key, value) {
                       if (is.list(key)) {
                         .dict[unlist(key)] <<- value
                       } else {
                         .dict[[key]] <<- value
                       }
                     },
                     find = function(key) {
                       if (!is.null(.dict[[key]])) .self else .outer$find(key)
                     }
                     ))

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

  rfname <- c(">", "<", ">=", "<=",
              "list", "length")
  rfunc <- lapply(rfname,
                function(name) {
                  n <- name
                  function(x) do.call(n, x)
                })
  names(rfunc) <- rfname
  procs <- append(procs, rfunc)

  env$set(as.list(names(procs)), procs)
}

eval <- function(x, env) {
  if (is.character(x)) {                # variable reference
    env$find(x)$get(x)
  } else if (!is.list(x)) {             # constant literal
    x
  } else if (identical(x[[1]], "quote")) { # (quote exp)
    x[-1][[1]]
  } else if (identical(x[[1]], "if")) { # (if test conseq alt)
    test   <- x[[2]]
    conseq <- x[[3]]
    alt    <- x[[4]]
    if (eval(test, env)) {
      eval(conseq, env)
    } else {
      eval(alt, env)
    }
  } else if (identical(x[[1]], "set!")) { # (set! var exp)
    var <- x[[2]]
    exp <- x[[3]]
    env$find(var)$set(var, eval(exp, env))
  } else if (identical(x[[1]], "define")) { # (define var exp)
    var <- x[[2]]
    exp <- x[[3]]
    env$set(var, eval(exp, env))
  } else if (identical(x[[1]], "lambda")) { # (lambda (var*) exp*)
    vars <- x[[2]]
    exps <- x[-c(1, 2)]
    function(args) {
      inner <- Env$new(env)
      inner$set(vars, args)
      for (exp in exps) val <- eval(exp, inner)
      val
    }
  } else if (identical(x[[1]], "begin")) { # (begin exp*)
    for (exp in x[-1]) val <- eval(exp, env)
    val
  } else {                              # (proc exp*)
    xeval <- lapply(x, function(exp) eval(exp, env))
    proc <- xeval[[1]]
    exps <- xeval[-1]
    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)) {
    paste("(", do.call(paste, lapply(exp, toString)), ")", sep="")
  } else {
    tryCatch(as.character(exp),
             error=function(e) paste("#<", typeof(exp), ">", sep=""))
  }
}

repl <- function(prompt='lisp.R> ') {
  env <- Env$new()
  addGlobals(env)

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