bf interpreter in racket

bf.rkt

#lang racket

(define (tape-new)
  (cons 0 (make-vector 1 0)))

(define (tape-inc tape amount)
  (let ([pos (car tape)]
        [vec (cdr tape)])
    (vector*-set! vec pos (+ (vector-ref vec pos) amount))))

(define (tape-grow vec)
  (let* ([oldsz (vector*-length vec)]
         [newsz (* oldsz 2)]
         [newvec (make-vector newsz 0)])
    (vector-copy! newvec 0 vec)
    newvec))

(define (tape-move tape amount)
  (let* ([pos (car tape)]
         [vec (cdr tape)]
         [sz (vector*-length vec)]
         [newpos (+ pos amount)])
    (if (>= newpos sz)
        (cons newpos (tape-grow vec))
        (cons newpos vec))))

(define (tape-get tape)
  (vector*-ref (cdr tape) (car tape)))

(define (bf-parse cs)
  (define (bf-parse-inner ops cs)
    (if (empty? cs)
        (cons (reverse ops) '())
        (let ([c (car cs)]
              [cs (cdr cs)])
          (case c
            [(#\+) (bf-parse-inner (cons '(inc . 1) ops) cs)]
            [(#\-) (bf-parse-inner (cons '(inc . -1) ops) cs)]
            [(#\>) (bf-parse-inner (cons '(move . 1) ops) cs)]
            [(#\<) (bf-parse-inner (cons '(move . -1) ops) cs)]
            [(#\.) (bf-parse-inner (cons '(print) ops) cs)]
            [(#\[) (let* ([inner-result (bf-parse-inner '() cs)]
                          [loop-ops (car inner-result)]
                          [cs (cdr inner-result)])
                     (bf-parse-inner (cons `(loop . ,loop-ops) ops)
                                     cs))]
            [(() #\]) (cons (reverse ops) cs)]
            [else (bf-parse-inner ops cs)]))))

  (car (bf-parse-inner '() (string->list cs))))

(define (bf-run tape ops)
  (if (empty? ops)
      tape
      (let* ([op (car ops)]
             [ops (cdr ops)])
        (case (car op)
          [(inc)
           (tape-inc tape (cdr op))
           (bf-run tape ops)]
          [(move) (bf-run (tape-move tape (cdr op)) ops)]
          [(print)
           (display (integer->char (tape-get tape)))
           (flush-output)
           (bf-run tape ops)]
          [(loop)
           (define (do-loop tape loop-ops)
             (if (= 0 (tape-get tape))
                 (bf-run tape ops)
                 (do-loop (bf-run tape loop-ops) loop-ops)))
           (do-loop tape (cdr op))]))))

(let* ([filename (command-line #:args (filename) filename)]
       [text (call-with-input-file filename port->string #:mode 'text)]
       [ops (bf-parse text)]
       [tape (tape-new)])
  (bf-run tape ops))