brainf*ck interpreter (recursive)

bf-rec.lisp

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

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

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

(defun bfr-run (str)
  (multiple-value-bind (l p) 
      (bf-rec (coerce str 'list) 0 (list 0) nil 0)
    (format t "~&~A:~A~%" l p)))