Execute Brain****/Common Lisp

This is an implementation of Brainf*** written in Common Lisp.
(defstruct bf-state
  (program)
  (program-counter 0)
  (memory (make-array 1 :initial-element 0 :adjustable t))
  (memory-pointer 0)
  (stack))

(defmacro with-bf-slots ((program-sym program-counter-sym 
                          memory-sym memory-pointer-sym
                          stack-sym)
                         obj-expr &body body)
 "Macro to replace cumbersome structure slot references with
local lexical macros resembling local variables."
  `(symbol-macrolet ((,program-sym (bf-state-program ,obj-expr))
                     (,program-counter-sym (bf-state-program-counter ,obj-expr))
                     (,memory-sym (bf-state-memory ,obj-expr))
                     (,memory-pointer-sym (bf-state-memory-pointer ,obj-expr))
                     (,stack-sym (bf-state-stack ,obj-expr)))
     ,@body))

(defun adjust-memory (state)
 "Modifies memory and memory-pointer such that memory-pointer is
a valid index to the memory array. If it is too large, the array
is extended; if it is negative, the array is extended, its
contents are shifted forward and the memory-pointer is incremented,
by an amount to make the memory ."
  (with-bf-slots (program pc mem ptr stack) state
    (cond ((>= ptr (length mem))
           (adjust-array mem (1+ ptr) :initial-element 0))
          ((minusp ptr)
           (let ((extent (- ptr)))
             (incf ptr extent)
             (let ((old-memory (copy-seq mem)))
               (setf mem (make-array (+ (length old-memory) extent)))
               (setf (subseq mem extent) old-memory)))))))
 
(defun matching-bracket-for (program bracket-index)
  (loop with depth = 1
        for index from (1+ bracket-index)
        when (>= index (length program))
          do (error "unmatched [ bracket")
        do (case (aref program index)
             (#\[ (incf depth))
             (#\] (decf depth)))
        until (zerop depth)
        finally (return index)))
 
(defun brainfuck-eval (state &optional (stream *standard-output*))
  (with-bf-slots (program pc mem ptr stack) state
    (loop while (< pc (length program)) do
      (case (aref program pc)
        (#\+ (incf (aref mem ptr)))
        (#\- (decf (aref mem ptr)))
        (#\> (incf ptr) (adjust-memory state))
        (#\< (decf ptr) (adjust-memory state))
        (#\[ (if (/= 0 (aref mem ptr))
                 (push (1- pc) stack)
                 (setf pc (matching-bracket-for program pc))))
        (#\] (setf pc (pop stack)))
        (#\. (write-char (code-char (aref mem ptr)) stream)))
      (incf pc))))

(defun brainfuck-compile-guts (program &optional (start 0) (until-bracket nil))
  (loop for insn from start below (length program)
        appending (case (aref program insn)
                    (#\+ `((incf (aref mem ptr))))
                    (#\- `((decf (aref mem ptr))))
                    (#\> `((incf ptr) (adjust-memory state)))
                    (#\< `((decf ptr) (adjust-memory state)))
                    (#\[ (let ((end (matching-bracket-for program insn)))
                           (prog1 
                             `((do () ((= 0 (aref mem ptr)))
                               ,@(brainfuck-compile-guts program (1+ insn) end)))
                             (setf insn end))))
                    (#\] (if until-bracket
                           (if (= until-bracket insn)
                             (loop-finish)
                             (error "internal problem matching brackets"))
                           (error "extra ] bracket")))
                    (#\. `((write-char (code-char (aref mem ptr)) stream))))))
    
(defun brainfuck-compile (program)
  (compile nil `(lambda (&optional (stream *standard-output*))
                  (let ((state (make-bf-state :program ,program)))
                    (with-bf-slots (program pc mem ptr stack) state
                                   ,@(brainfuck-compile-guts program))
                    (values)))))

(defun bf (program) 
  (if (and (not (zerop (length program)))
           (char= #\! (aref program 0)))
    (funcall (brainfuck-compile program))
    (brainfuck-eval (make-bf-state :program program))))
 
(defun bf-repl ()
  "read-eval-print loop for bf. Code prefixed with ! is compiled, otherwise interpreted"
  (loop do (fresh-line)
           (princ "BRAINFUCK> ")
           (bf (read-line))))