Welcome to the CHICKEN Scheme pasting service

(use (srfi 4 13))

(define-record machine cells idx program pc)

(define mem-size (make-parameter 3000))

(define (load-from-file file)
  (let ((code 
         (string-concatenate
          (with-input-from-file file read-lines))))
    (make-machine
     (make-u8vector (mem-size) 0)
     0
     code
     0)))

(define (find-loop-start pc prog)
  (let ((idx (string-index-right prog #\[ (- (string-length prog) pc))))
    (if (not idx)
        (error "missing open [ for ] in row " pc)
        idx)))

(define (find-loop-end pc prog)
  (let loop ((pc pc)
             (open-parens 0))
    (cond ((< open-parens 0)
           (error "One ] too many in " (sub1 pc)))
          ((> pc (string-length prog))
           (error "Unexpected end of file"))
          ((equal? (string-ref prog pc)
                   #\[)
           (loop (add1 pc)
                 (add1 open-parens)))
          ((equal? (string-ref prog pc)
                    #\])
           (if (= 0 (sub1 open-parens))
               pc
               (loop (add1 pc)
                     (sub1 open-parens))))
          (else (loop (add1 pc) open-parens)))))

(define (bf-eval m)
  (case (string-ref (machine-program m) (machine-pc m))
    ((#\>) (if (> (add1 (machine-idx m)) (mem-size))
               (error "Runaway data pointer at " (machine-pc m))
               (machine-idx-set! m (add1 (machine-idx m)))))
    ((#\<)  (if (> 0 (sub1 (machine-idx m)))
                (error "Reading past the start of cells at " (machine-pc m))
                (machine-idx-set! m (sub1 (machine-idx m)))))
    ((#\+) (let ((curr (u8vector-ref (machine-cells m) (machine-idx m))))
             (u8vector-set! (machine-cells m) (machine-idx m) (modulo (add1 curr) 256))))
    ((#\-) (let ((curr (u8vector-ref (machine-cells m) (machine-idx m))))
             (u8vector-set! (machine-cells m) (machine-idx m) (modulo  (sub1 curr) 256))))
    ((#\.) (display (integer->char (u8vector-ref (machine-cells m) (machine-idx m)))))
    ((#\,) (let ((c (read-char)))
             (u8vector-set! (machine-cells m) (machine-idx m) c)))
    ((#\[) (if (zero? (u8vector-ref (machine-cells m) (machine-idx m)))
               (machine-pc-set! m (find-loop-end (machine-pc m) (machine-program m)))))
    ((#\]) (if (not (zero? (u8vector-ref (machine-cells m) (machine-idx m))))
               (machine-pc-set! m (find-loop-start (machine-pc m) (machine-program m)))))
    (else (error "Unknown command " (string-ref (machine-program m) (machine-pc m)))))
  (machine-pc-set! m (add1 (machine-pc m)))
  (if (< (machine-pc m)
         (string-length (machine-program m)))
      (bf-eval m)))