threaded brainfuck interpreter

(eval-when (:load-toplevel :execute :compile-toplevel)
  (defun mkstr (&rest args)
    (with-output-to-string (s)
      (dolist (a args) (princ a s))))

  (defun symb (&rest args)
    (values (intern (apply #'mkstr args)))))


(defun remove-whitespace (string)
  (remove-if (lambda (c)
               (or (char-equal #\  c)
                   (char-equal #\Newline c))) string))



(defun translate (bf-string)
  "Translates a string of brainfuck into a list of lisp expressions"
  (let ((prog '())
        (loop-idx 0)
        (loop-stack '()))
    (loop for char across (remove-whitespace bf-string) do
         (let ((val (case char
                      (#\> '(inc-pointer 1))
                      (#\< '(dec-pointer 1))
                      (#\+ '(inc-cell 1))
                      (#\- '(dec-cell 1))
                      (#\. '(pr-cell))
                      (#\, '(rd-cell))
                      ;; create a tag for goto, a start-loop
                      ;; invocation, push a new loop onto stack, and
                      ;; increment the loop counter
                      (#\[ (progn (push (symb 'start loop-idx) prog)
                                  (push loop-idx loop-stack)
                                  (incf loop-idx)
                                  `(start-loop ,(1- loop-idx))))

                      ;; create a tag, a end-loop invocation,
                      ;; and pop the stack
                      (#\] (let ((closed-loop (pop loop-stack)))
                             (push `(end-loop ,closed-loop) prog)
                             (symb 'end closed-loop))))))
           (if val (push val prog))))
    (values loop-idx (reverse prog))))


;;; (translate "++<<[++->]++>>[-]")

;;-> (TAGBODY
;;     (INC-CELL 1)
;;     (INC-CELL 1)
;;     (DEC-POINTER 1)
;;     (DEC-POINTER 1)
;;   START0               ;; loop start tag/label
;;     (START-LOOP 0)
;;     (INC-CELL 1)
;;     (INC-CELL 1)
;;     (DEC-CELL 1)
;;     (INC-POINTER 1)
;;     (END-LOOP 0)
;;   END0                 ;; loop end tag/label
;;     (INC-CELL 1)
;;     (INC-CELL 1)
;;     (INC-POINTER 1)
;;     (INC-POINTER 1)
;;   START1
;;     (START-LOOP 1)
;;     (DEC-CELL 1)
;;     (END-LOOP 1)
;;   END1)



(defmacro interpret (string)
  "Create a brainfuck memory pointer and environment, and expand
  the translated brainfuck into the let body"
  `(let ((mp 0)
         (mem (make-array 30000 :element-type '(integer 0 255))))
     (declare (optimize (speed 3) (safety 0) (debug 0))
              (type ((simple-array '(integer 0 255) (30000)) mem)
                    (fixnum mp)))
     (tagbody ,@(multiple-value-bind (loop-count body) (translate string)
                                     (declare (ignore loop-count))
                                     body))))


;;  (macroexpand-1 (interpret "++<<[++->]++>>[-]"))

;; (*LET ((MP FIXNUM 0) (MEM (MAKE-ARRAY 30000 :ELEMENT-TYPE '(INTEGER 0 255))))
;;   (DECLARE (OPTIMIZE (SPEED 3) (SAFETY 0) (DEBUG 0)))
;;   (TAGBODY
;;     (INC-CELL 1)
;;     (INC-CELL 1)
;;     (DEC-POINTER 1)
;;     (DEC-POINTER 1)
;;    START0
;;     (START-LOOP 0)
;;     (INC-CELL 1)
;;     (INC-CELL 1)
;;     (DEC-CELL 1)
;;     (INC-POINTER 1)
;;     (END-LOOP 0)
;;    END0
;;     (INC-CELL 1)
;;     (INC-CELL 1)
;;     (INC-POINTER 1)
;;     (INC-POINTER 1)
;;    START1
;;     (START-LOOP 1)
;;     (DEC-CELL 1)
;;     (END-LOOP 1)
;;    END1))


(defmacro inc-pointer (arg)
  `(incf mp ,arg))

(defmacro inc-cell (arg)
  `(incf (aref mem mp) ,arg))

(defmacro dec-pointer (arg)
  `(decf mp ,arg))

(defmacro dec-cell (arg)
  `(decf (aref mem mp) ,arg))

(defmacro clear-cell ()
  `(setf (aref mem mp) 0))

(defmacro pr-cell ()
  `(progn
     (princ (code-char (aref mem mp)))
     ;(force-output)
     ))

(defmacro rd-cell ()
  `(progn
     (setf (aref mem mp) (char-code (read-char)))
     (force-output)))


(defmacro end-loop (loop-idx)
  `(if (not (zerop (aref mem mp)))
       (go ,(symb 'start loop-idx))))

(defmacro start-loop (loop-idx)
  `(if (zerop (aref mem mp))
       (go ,(symb 'end loop-idx))))





(defun optimizable-p (el)
  (and (consp el)
       (not (or (eql 'pr-cell (car el))
                (eql 'rd-cell (car el))
                (eql 'start-loop (car el))
                (eql 'end-loop (car el))
                (eql 'clear-cell (car el))))))


(defun optimize-bf (prog)
  "Accumulates repeated commands and optimizes out zero loops (e.g. [-] )"
  (let ((program '()))
    (loop for idx from 0 to (1- (length prog)) do
         (let* ((el (elt prog idx)))
           (if (and (consp el)
                      (eql 'start-loop (car el))
                      (< (+ 2 idx) (length prog))
                      (consp (elt prog (+ 2 idx)))
                      (eql 'end-loop (car (elt prog (+ 2 idx)))))
               (progn (pop program)
                      (setf idx (+ 3  idx))
                      (push '(clear-cell) program))
               (push el program))))
    (setf program (nreverse program))

    (let ((opti-prog '())
          (cur-type '())
          (cur-num 0))
      (declare (optimize speed))

      (loop for el in program do
           (if (not (optimizable-p el))
               (progn
                 (when cur-type
                   (push `(,cur-type ,cur-num) opti-prog))

                 (setf cur-type nil
                       cur-num 0)
                 (push el opti-prog))

               (if (not cur-type)
                   (setf cur-type (car el)
                         cur-num 1)

                   (if (eq cur-type (car el))
                       (incf cur-num)

                       (progn
                         (push `(,cur-type ,cur-num) opti-prog)
                         (setf cur-type (car el)
                               cur-num 1))))))

      (nreverse opti-prog))))


(defmacro fast-interpret (string)
  `(*let ((mp fixnum 0)
          (mem (make-array 30000 :element-type '(integer 0 255))))
     (declare (optimize (speed 3) (safety 0) (debug 0)))
     (tagbody ,@(multiple-value-bind (loop-count body) (translate string)
                                     (declare (ignore loop-count))
                                     (optimize-bf body)))))


;;  (macroexpand-1 (fast-interpret "++<<[++->]++>>[-]"))

;; (*LET ((MP FIXNUM 0) (MEM (MAKE-ARRAY 30000 :ELEMENT-TYPE '(INTEGER 0 255))))
;;   (DECLARE (OPTIMIZE (SPEED 3) (SAFETY 0) (DEBUG 0)))
;;   (SYMBOL-MACROLET ((CELL (AREF MEM MP)))
;;     (TAGBODY
;;       (INC-CELL 2)
;;       (DEC-POINTER 2)
;;      START0
;;       (START-LOOP 0)
;;       (INC-CELL 2)
;;       (DEC-CELL 1)
;;       (INC-POINTER 1)
;;       (END-LOOP 0)
;;      END0
;;       (INC-CELL 2)
;;       (INC-POINTER 2)
;;      START1
;;       (START-LOOP 1)
;;       (DEC-CELL 1)
;;       (END-LOOP 1)
;;      END1)))