(defparameter *MEMORY-SIZE* 30000)
(defparameter *COMMANDS* '((> inc-pointer)
(< dec-pointer)
(+ inc-value)
(- dec-value)
(\. putchar)
(\, getchar)
([ loop-begin)
(] loop-end)))
(defun file-to-list (file)
(with-open-file (in file)
(when in
(loop for line = (read-line in nil)
while line collect line))))
(defun collect-string (lst)
(reduce #'(lambda (a b) (concatenate 'string a b)) lst))
(defun explode (sym)
(map 'list #'(lambda (c)
(intern (make-string 1 :initial-element c)))
(symbol-name sym)))
(defun string-symbolist (str)
(explode (intern (string-upcase str))))
(defun call (key alist)
(funcall (cdr (assoc key alist))))
(defun make-jump-table (code)
(do ((pos 0 (1+ pos))
(c code (cdr c))
(table (make-hash-table))
(stack nil))
((null c) table)
(case (car c)
(loop-begin (push pos stack))
(loop-end (let ((pop-pos (pop stack)))
(setf (gethash pos table) pop-pos)
(setf (gethash pop-pos table) pos))))))
(defun make-brainfuck-closure (code)
(let ((memory (make-array *MEMORY-SIZE* :initial-element 0))
(ptr 0)
(jump-table (make-jump-table code)))
(let* ((code-length (length code))
(program (make-array code-length :initial-contents code))
(prog-ptr 0))
(flet ((jump () (setq prog-ptr (gethash prog-ptr jump-table)) (decf prog-ptr)))
(let ((closure-alist
(list (cons 'inc-pointer #'(lambda () (incf ptr)))
(cons 'dec-pointer #'(lambda () (decf ptr)))
(cons 'inc-value #'(lambda () (incf (aref memory ptr))))
(cons 'dec-value #'(lambda () (decf (aref memory ptr))))
(cons 'putchar #'(lambda () (princ (code-char (aref memory ptr)))))
(cons 'getchar #'(lambda () (setq ptr (char-code (read-char)))))
(cons 'loop-begin
#'(lambda () (when (zerop (aref memory ptr)) (jump))))
(cons 'loop-end
#'(lambda () (unless (zerop (aref memory ptr)) (jump)))))))
(lambda ()
(when (< prog-ptr code-length)
(call (aref program prog-ptr) closure-alist)
(incf prog-ptr))))))))
(defun brainfuck (code)
(let ((step (make-brainfuck-closure code)))
(loop while (funcall step))))
(defun parse (code)
(mapcar #'(lambda (sym)
(cadr (assoc sym *COMMANDS*)))
code))
(defun get-code (file)
(string-symbolist (collect-string (file-to-list file))))
(defun main (args)
(unless args (error "第一引数にファイルを指定してください"))
(let ((code (get-code (car args))))
(brainfuck (parse code))))