rewrite bf expander

beautiful-racket/br/demo/bf/bf-expander.rkt

@@ -1,29 +1,54 @@
 #lang br/quicklang
  
-(provide #%module-begin)
+(define-macro (bf-module-begin PARSE-TREE)
+  #'(#%module-begin
+     PARSE-TREE))
+(provide (rename-out [bf-module-begin #%module-begin]))
 
 (define-macro (bf-program OP-OR-LOOP ...)
-  #'(begin OP-OR-LOOP ...))
+  #'(define-values (vec ptr)
+      (run-args (list OP-OR-LOOP ...))))
 (provide bf-program)
 
-(define-macro-cases op
+(define (run-args bf-funcs
-  [(op ">") #'(move-pointer 1)]
+                  [vec-start (make-vector 30000 0)]
-  [(op "<") #'(move-pointer -1)]
+                  [pos-start 0])
-  [(op "+") #'(set-current-byte! (add1 (get-current-byte)))]
+  (for/fold ([vec vec-start]
-  [(op "-") #'(set-current-byte! (sub1 (get-current-byte)))]
+             [pos pos-start])
-  [(op ".") #'(write-byte (get-current-byte))]
+            ([bf-func (in-list bf-funcs)])
-  [(op ",") #'(set-current-byte! (read-byte))])
+    (bf-func vec pos)))
-(provide op)
+
+(define (vector-set v p val)
+  (vector-set! v p val)
+  v)
 
-(define bf-vector (make-vector 30000 0))
+(define (vector-update v p func)
-(define bf-pointer 0)
+  (vector-set v p (func (vector-ref v p))))
 
-(define (move-pointer how-far) (set! bf-pointer (+ bf-pointer how-far)))
+(define (gt v p) (values v (add1 p)))
+(define (lt v p) (values v (sub1 p)))
+(define (plus v p) (values (vector-update v p add1) p))
+(define (minus v p) (values (vector-update v p sub1) p))
+(define (period v p) (write-byte (vector-ref v p)) (values v p))
+(define (comma v p) (values (vector-set v p (read-byte)) p))
+
+(define-macro-cases op
+  [(op ">") #'gt]
+  [(op "<") #'lt]
+  [(op "+") #'plus]
+  [(op "-") #'minus]
+  [(op ".") #'period]
+  [(op ",") #'comma])
+(provide op)
 
-(define (get-current-byte) (vector-ref bf-vector bf-pointer))
+(define (make-looping-func args)
-(define (set-current-byte! val)  (vector-set! bf-vector bf-pointer val))
+  (lambda (v p)
+    (for/fold ([vec v]
+               [pos p])
+              ([i (in-naturals)]
+               #:break (zero? (vector-ref vec pos)))
+      (run-args args vec pos))))
 
 (define-macro (loop LOOP-ARG ...)
-  #'(until (zero? (get-current-byte))
+  #'(make-looping-func (list LOOP-ARG ...)))
-           LOOP-ARG ...))
 (provide loop)