Lisp macros to convert brainfuck code into lisp code

brainfuck.lisp

; the zipper storing the interpreter's memory
(defvar *memory* (cons () (loop for i from 1 to 32768 collecting 0)))
; convenience function to reset global memory to all zeros
(defun reset-memory ()
  (setf *memory* (cons () (loop for i from 1 to 32768 collecting 0))))
(defmacro with-blank-memory (&rest body)
  `(let ((*memory* (cons () (loop for i from 1 to 32768 collecting 0))))
    ,@body))
; the forward portion of the memory zipper
(defmacro forward ()
  `(cdr *memory*))
; the backward portion of the memory zipper
(defmacro backward ()
  `(car *memory*))
; increment the first element of the list in *memory*'s second list
; (the brainfuck + operator)

(defmacro f+ ()
  `(incf (first (forward))))
; decrement the first element of the list in *memory*'s second list
; (the brainfuck - operator)
(defmacro f- ()
  `(decf (first (forward))))
; move one element from *memory*'s second list to its first, moving the location
; of the data pointer forward by one
; (the brainfuck > operator)
(defmacro f> ()
  `(push (pop (forward)) (backward)))
; move one element from *memory*'s second list to its first, moving the location
; of the data pointer backwards by one
; (the brainfuck < operator)
(defmacro f< ()
  `(push (pop (backward)) (forward)))
; print the ascii character corresponding to the first position in memory
; (the brainfuck . operator)
(defmacro f. ()
  `(format t "~c" (code-char (first (forward)))))
; read a character and put its ascii value into the first position in memory
; (the brainfuck , operator)
(defmacro f\, ()
  `(setf (car (cdr *memory*)) (char-code (read-char))))

; Just print an H directly using the macros, proof of concept
(progn (loop for i from 1 to 72 collecting (f+))
       (f.))

; Returns the appropriate macro to use for a particular brainfuck character
; i.e., (fmacro #\+) => (f+)
(defun fmacro (c)
  (list (intern (concatenate 'string "F" (string c)))))

; Returns the substring containing the first bracket-enclosed section
; i.e. (match-bracket "[a[bcd]][ef]") => "[a[bcd]]"
(defun match-bracket (str)
  (let ((depth 0) (out (make-array 0 :fill-pointer 0 :adjustable t :element-type 'character)))
    (loop for c across str
          do (vector-push-extend c out)
          when (char= c (code-char 91))
          do (incf depth)
          when (char= c (code-char 93))
          do (decf depth)
          until (= depth 0))
    out))

; creates lisp code from brainfuck code
;
; first, convert whatever we get into a string.
; then, loop over that string:
;  for each character ",.<>+-", append the appropriate macro call onto the list
;   of things to do.
;  for each [, call floop on the inside of the bracketed loop section
;  if we encounter a ], it's an error: any matched ]s are removed by the subseq
;   calls.
(defmacro f (code)
  (let ((str (string code)))
    `(progn ,@(loop for i from 0
            until (>= i (length str))
            for c = (elt str i)
            for sub = (let ((around (match-bracket (subseq str i))))
                        (if (> (length around) 2)
                          (subseq around 1 (1- (length around)))
                          ""))
            when (char= c (code-char 91))
            collect `(floop ,sub) and do (incf i (1+ (length sub)))
            when (char= c (code-char 93))
            do (format t "ERROR: UNMATCHED ]") and return nil
            unless (char= c (code-char 91))
            collect (fmacro c)))))

; run the brainfuck code with a new definition of the dynamic variable *memory*
; so that global state is not affected
(defmacro brainf*ck (code)
  `(with-blank-memory (f ,code)))

; repeat a section of brainfuck code until the current cell's value is zero
(defmacro floop (code)
  `(do
     ()
     ((= 0 (first (forward))))
     (f ,code)))

; test code: prints Hello World!
(brainf*ck |++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.------.--------.>+.>.|)

; make sure it expands properly
(macroexpand-1 '(f |++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.------.--------.>+.>.|))

; use the brainfuck code generation macros to define multiplication
; this is rather absurd...
(defun bfmult (x y)
  (with-blank-memory
    (setf (first (forward)) x)
    (setf (first (cdr (forward))) y)
    (f |[->[->+>+<<]>>[->+<]<[-<+>]<<]>>>>|)
    (first (forward))))

; oh look, it works!
(bfmult 40000 5)