Create a gist now

Instantly share code, notes, and snippets.

@igjit /lispr.R
Last active Nov 22, 2016

What would you like to do?
Scheme Interpreter in R (more R-ish implementation of "lisp.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")
}
}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment