(defun compile-bf (program)
  (let ((loop-stack (list)))
    (let ((translated (loop for char across program appending
			   (case char
			     (#\> '((incf pointer)))
			     (#\< '((decf pointer)))
			     (#\+ '((incf (aref memory (wrap-pointer pointer)))))
			     (#\- '((decf (aref memory (wrap-pointer pointer)))))
			     (#\. '((format t "~a" (code-char (aref memory (wrap-pointer pointer))))))
			     (#\, '((setf (aref memory (wrap-pointer pointer)) (char-code (read-char)))))
			     (#\[ (let ((start-lbl (gensym "start"))  ;; generate labels for jumping
					(end-lbl (gensym "end")))

				    ;; save them on a stack
				    (push (cons start-lbl end-lbl)
					  loop-stack)
				    ;; generate loop header code
				    `((if (zerop (aref memory (wrap-pointer pointer)))
					  (go ,end-lbl))
				      ,start-lbl)))
			     
			     (#\] (let ((labels (pop loop-stack))) ;; pop labels off stack, causes error if stack is empty as a result of unbalanced brackets
				    (destructuring-bind (start-lbl . end-lbl) labels
				      ;; generate loop footer code
				      `((if (plusp (aref memory (wrap-pointer pointer)))
					    (go ,start-lbl))
					,end-lbl))))))))

      ;; run lisp compiler on generated lisp code
      (compile nil `(lambda () (let ((memory (make-array 30000 :initial-element 0))
				(pointer 0))
			    (labels ((wrap-pointer (ptr)
				       (mod ptr 30000)))
			      (tagbody
				 ,@translated))))))))