Rに慣れるために、Lispインタプリタを書いてみました。
元ねたはPeter Norvigの (How to Write a (Lisp) Interpreter (in Python)) （日本語訳: ((Pythonで) 書く (Lisp) インタプリタ)）です。
コード
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| ## 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") | |
| } | |
| } |
遊び方
コードを取ってきます。
$ git clone https://gist.github.com/5598108.git
Rインタプリタを起動してコードを読み込ませます。
repl() を実行するとLispの対話式インタプリタが起動します。
$ cd 5598108/
$ R -q
> source("lisp.R")
> repl()
lisp.R> (+ 1 2)
3
lisp.R> (define l (list 1 2 3))
(1 2 3)
lisp.R> (car l)
1
lisp.R> (cdr l)
(2 3)
lisp.R> (define add2 (lambda (x) (+ x 2)))
#<closure>
lisp.R> (add2 40)
42
lisp.R> (equal? (list 1 2) (list 1 (- 5 3)))
TRUE
lisp.R> (define map (lambda (f l) (if (null? l) (quote ()) (cons (f (car l)) (map f (cdr l))))))
#<closure>
lisp.R> (map add2 (list 10 20 30))
(12 22 32)
lisp.R>
感想
Rの言語機能（ファーストクラスの関数、レキシカルスコープ、クロージャなど）のおかげで、割と楽に書けたと思います。
ただリストの操作はちょっと面倒くさいかな、と思いました。
あと値渡しとか遅延評価とかでところどころはまりました。まだまだ慣れが必要です。
でも今回初めて使った機能がいくつかあって勉強になったし、何より言語処理系を作るのはとても楽しいです。
(追記)
続編を書きました。((Rで) 書く ((もっとRっぽい) Lisp) インタプリタ)
