初brainf*ck

Rubyで作る奇妙なプログラミング言語 ~Esoteric Language~

まず付録を読んでから戻って、Whitespaceまで読了したのでとりあえずBrainf*ckをCLで書いてみる。
折角なのでループを再帰にしてみたりset系の命令を排して書いてみたりしたけど意味は全くないというか遅くなるだけ。ネタです。

(defun subnth (x n xs)
  (let ((len (length xs)))
    (if (<= len n) xs
        (nconc (butlast xs (- len n)) `(,x) (cdr (nthcdr n xs))))))

(defun jump (code)
  (if (null code) (error "error: unmatch parenthesis")
      (case (car code)
        (#\] (cdr code))
        (#\[ (jump (jump (cdr code))))
        (t (jump (cdr code))))))

(defun bf-rec (code pos tape ret)
  (if (null code)
      (values tape pos)
      (flet ((_ (e &key ((:code c) (cdr code)) ((:pos p) pos) ((:ret r) ret))
               (bf-rec c p e r)))
        (case (car code)
          (#\+ (_ (subnth (1+ #1=(nth pos tape)) pos tape)))
          (#\- (_ (subnth (1- #1#) pos tape)))
          (#\. (princ (code-char #1#)) (_ tape))
          (#\, (_ (subnth (char-code (read-char)) pos tape)))
          (#\< (_ tape :pos (1- pos)))
          (#\> (_ (if (< (1+ pos) (length tape)) tape (append tape '(0)))
		  :pos (1+ pos)))
          (#\[ (if (= 0 #1#)
                   (_ tape :code (jump (cdr code)))
                   (_ tape :ret (cons (cdr code) ret))))
          (#\] (if (= 0 #1#)
                   (_ tape :ret (cdr ret))
                   (if ret (_ tape :code (car ret))
                       (error "error: unmatch parenthesis"))))
          (t (_ tape))))))

評価が終わるとテープの最後の状態とポジションを多値で返します。
]へのジャンプだけ別関数になってるのがとてもかっこわるい。

とりあえず実行

(defun bf-test ()
  (let ((tape '(0)))
    (macrolet ((run (str)
		 `(multiple-value-bind (l p) 
		      (bf-rec (coerce ,str 'list) 0 tape nil)
		    (format t "~&~A:~A~%" l p))))
      (run "++++++++[>++++++++<-]>+.")
      (run "+++++++++[>++++++++>+++++++++++>+++++<<<-]>.>++.+++++++..+++.>-.---
            ---------.<++++++++.--------.+++.------.--------.>+.")
      (run "++++[>,.<-]"))))

結果

CL-USER> (bf-test)
A
(0 65):1
Hello, world!
(0 72 100 33):3
asdfjkl;
asdf
(0 102):0
NIL

できたできた。後でマクロ版を書く。