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))

(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 ."

 (cond ((>= (bf-state-memory-pointer state)
            (length (bf-state-memory state)))
        (adjust-array (bf-state-memory state)
                      (1+ (bf-state-memory-pointer state))
                      :initial-element 0))
       ((minusp (bf-state-memory-pointer state))
        (let ((extent (- (bf-state-memory-pointer state))))
          (incf (bf-state-memory-pointer state) extent)
          (let ((old-memory (copy-seq (bf-state-memory state))))
            (setf (bf-state-memory state)
                  (make-array (+ (length old-memory) extent)))
            (setf (subseq (bf-state-memory state) 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 ((program (bf-state-program state))
       (places nil))
   (loop while (< (bf-state-program-counter state) (length program)) do
     (case (elt program (bf-state-program-counter state))
       (#\+ (incf (elt (bf-state-memory state) (bf-state-memory-pointer state))))
       (#\- (decf (elt (bf-state-memory state) (bf-state-memory-pointer state))))
       (#\> (incf (bf-state-memory-pointer state)) (adjust-memory state))
       (#\< (decf (bf-state-memory-pointer state)) (adjust-memory state))
       (#\[ (if (/= 0 (elt (bf-state-memory state) (bf-state-memory-pointer state)))
                (push (1- (bf-state-program-counter state)) places)
                (setf (bf-state-program-counter state)
                      (matching-bracket-for program (bf-state-program-counter state)))))
       (#\] (setf (bf-state-program-counter state) (pop places)))
       (#\. (write-char (code-char (elt (bf-state-memory state)
                                        (bf-state-memory-pointer state)))
                        stream)))
     (incf (bf-state-program-counter state)))))

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

(defun bf-repl ()

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