Execute Brain****/Common Lisp

This is an implementation of Brainf*** written in Common Lisp.

<lang lisp>(defstruct bf-state

 (program)
 (program-counter 0)
 (memory (make-array 1 :initial-element 0 :adjustable t))
 (memory-pointer 0))

(defmacro with-bf-slots ((program-sym program-counter-sym

                         memory-sym memory-pointer-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)))
    ,@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) 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 := 0
       for index := bracket-index then (1+ index)
       when (>= index (length program))
         do (error "unmatched bracket")
       when (char= #\[ (elt program index))
         do (incf depth)
       when (char= #\] (elt program index))
         do (decf depth)
       until (zerop depth)
       finally (return index)))

(defun brainfuck-eval (state &optional (stream *standard-output*))

 (let ((places nil))
   (with-bf-slots (program pc mem ptr) state
     (loop while (< pc (length program)) do
       (case (elt 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) places)
                  (setf pc (matching-bracket-for program pc))))
         (#\] (setf pc (pop places)))
         (#\. (write-char (code-char (aref mem ptr)) stream)))
       (incf pc)))))

(defun bf (program) (brainfuck-eval (make-bf-state :program program)))

(defun bf-repl ()

 (loop do (fresh-line)
          (princ "BRAINFUCK> ")
          (bf (read-line))))</lang>