brainfuck interpreter in scheme

bf.rkt

(define (new-bf)
  (let ((tape (make-vector 30000 0))(ptr 0))
    (define (reset [sz 30000]) (set! tape (make-vector sz 0)) (set! ptr 0))
    (define (b>) (set! ptr (add1 ptr)))
    (define (b<) (set! ptr (sub1 ptr)))
    (define (b+) (vector-set! tape ptr (add1 (vector-ref tape ptr))))
    (define (b-) (vector-set! tape ptr (sub1 (vector-ref tape ptr))))
    (define (p) (write-byte (vector-ref tape ptr)))
    (define (g) (vector-set! tape ptr (read-byte)))
    (define ops `((#\..,p)(#\,.,g)(#\>.,b>)(#\<.,b<)(#\+.,b+)(#\-.,b-)))
    (define (fuck-char char) (cond ((assoc char ops) => (lambda(_)((cdr _))))))
    (define (find-cb code pos dir)
      (let loop ((ctr 0) (p (+ pos dir)))
        (let ((c (case (string-ref code p)((#\[)(add1 ctr))((#\])(sub1 ctr))(else ctr))))
          (if (= c (- dir)) p (loop c (+ p dir))))))
    (define (fuck code)
      (let ((clen (string-length code)))
        (let loop ((p 0))
          (unless (>= p clen)
            (if (eq? (string-ref code p) #\[)
                (let* ((bp (find-cb code p 1)) (lc (substring code (add1 p) bp)))
                  (let l () (unless (= 0 (vector-ref tape ptr)) (fuck lc) (l)))
                  (loop (add1 bp)))
                (begin (fuck-char (string-ref code p)) (loop (add1 p))))))))
    (lambda(m)(case m ((fuck)fuck)((reset)(reset))((state)(values ptr tape))))))
(define bf (new-bf))
((bf 'fuck) "++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.------.--------.>+.>.")
; => prints "Hello World!"