(declaim (optimize (speed 3) (safety 1) (debug 3)))

(defun peek-for-multiple-characters (stream character character-weight op-name start-value)
  (list op-name
        (+ start-value
           (loop while (eql (peek-char nil stream nil nil) character)
                 sum character-weight
                 do (read-char stream)))))

(defun read-bf-program (stream)
  (loop for char = (read-char stream nil nil)
        until (or (null char) (char= char #\]))
        when (case char
               (#\+ (peek-for-multiple-characters stream #\+  1 'tape-inc   1))
               (#\- (peek-for-multiple-characters stream #\- -1 'tape-inc  -1))
               (#\> (peek-for-multiple-characters stream #\>  1 'tape-move  1))
               (#\< (peek-for-multiple-characters stream #\< -1 'tape-move -1))
               (#\. '(tape-print))
               (#\[ (list 'tape-loop (read-bf-program stream))))
          collect it))

(defun compile-bf-program (program)
  `(lambda ()
     (declare (optimize (speed 3) (safety 0) (debug 1)))
     (let ((tape (make-array 4096 :element-type 'fixnum))
	   (position 2048))
       (declare (fixnum position)
		((simple-array fixnum (*)) tape))
       ,@(%compile-bf-program program))))

(defun %compile-bf-program (program)
  (loop for op in program
        collect (ecase (first op)
                  (tape-inc `(incf (aref tape position)
                                   ,(second op)))
                  (tape-move `(incf position ,(second op)))
                  (tape-print `(write-char
                                (code-char (aref tape position))))
                  (tape-loop `(loop while (plusp (aref tape position))
                                    do (progn ,@(%compile-bf-program (second op))))))))

(defun run (program)
  (funcall (compile 'nil (compile-bf-program program))))

(defun bench (&key (file "./bench.b"))
  (with-open-file (stream file)
    (time (run (read-bf-program stream)))))