brainfuck implementation improvement.

(defmacro instruction-case (op &body clauses)
  "Maps symbolic instruction names to their internal code (characters):
move-left  <
move-right >
increment  +
decrement  -
read       ,
write      .
while      [
end        ]
"
  `(case ,op
     ,@(mapcar (lambda (clause)
                 (let ((instruction (ecase (first clause)
                                      (move-right #\>)
                                      (move-left  #\<)
                                      (increment  #\+)
                                      (decrement  #\-)
                                      (read       #\,)
                                      (write      #\.)
                                      (while      #\[)
                                      (end        #\])
                                      (otherwise  otherwise)))
                       (body        (rest clause)))
                   `(,instruction ,@body))))))


(defun bfparse (pgm)
  (loop
    with result = '()
    with stack = '()
    for ch across pgm
    do (instruction-case ch
         (move-right (push '(%forward  1) result))
         (move-left  (push '(%backward 1) result))
         (increment  (push '(%inc 1 0) result))
         (decrement  (push '(%dec 1 0) result))
         (read       (push '(%readc 0) result))
         (write      (push '(%princ 0) result))
         (while      (push result stack) (setf result (list '%while-nz)))
         (end        (setf result (cons (nreverse result) (pop stack)))))
    finally (progn (when stack (error "Missing closing brackets"))
                   (return-from bfparse (nreverse result)))))


(defun bfvm-run (vm &key verbose)
  (let* ((mem (bfvm-mem vm))
         (mc  (bfvm-mc  vm))
         (pgm (bfvm-pgm vm))
         (pc  (bfvm-pc  vm))
         (lpgm (length pgm))
         (lmem (length mem)))
    (macrolet ((in-range-p (counter limit) `(< -1 ,counter ,limit)))
      (unwind-protect
           (loop while (and (in-range-p pc lpgm) (in-range-p mc lmem)) do
             (when verbose
               (format *trace-output*
                       "PC:~5,'0D IR:~C M[~5,'0D]:~2,'0X  ~:*~4@A  ~4@A  ~C~%"
                       pc
                       (if (char= (char pgm pc) #\newline)
                           #\space
                           (char pgm pc))
                       mc
                       (aref mem mc)
                       (if (<= 128 (aref mem mc))
                           (- (aref mem mc) 256)
                           (aref mem mc))
                       (if (graphic-char-p (code-char (aref mem mc)))
                           (code-char (aref mem mc))
                           #\space))
               (force-output *trace-output*))
             (instruction-case (char pgm pc)
               (move-right  (incf mc)
                            (incf pc))
               (move-left   (decf mc)
                            (incf pc))
               (increment   (setf (aref mem mc) (mod (1+ (aref mem mc)) 256))
                            (incf pc))
               (decrement   (setf (aref mem mc) (mod (1- (aref mem mc)) 256))
                            (incf pc))
               (read        (princ (code-char (aref mem mc)))
                            (incf pc))
               (write       (setf (aref mem mc) (mod (char-code (read-char)) 256))
                            (incf pc))
               (while       (if (zerop (aref mem mc))
                                (setf pc (find-matching-close pgm pc +1 #\[ #\]))
                                (incf pc)))
               (end         (if (zerop (aref mem mc))
                                (incf pc)
                                (setf pc (find-matching-close pgm pc -1 #\] #\[))))
               (otherwise  (incf pc))))
        (setf (bfvm-mc vm) mc
              (bfvm-pc vm) pc))))
  (values))