diff --git a/beautiful-racket/br/demo/bf/bf-expander.rkt b/beautiful-racket/br/demo/bf/bf-expander.rkt index 2c16d60..18549ab 100644 --- a/beautiful-racket/br/demo/bf/bf-expander.rkt +++ b/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 - [(op ">") #'(move-pointer 1)] - [(op "<") #'(move-pointer -1)] - [(op "+") #'(set-current-byte! (add1 (get-current-byte)))] - [(op "-") #'(set-current-byte! (sub1 (get-current-byte)))] - [(op ".") #'(write-byte (get-current-byte))] - [(op ",") #'(set-current-byte! (read-byte))]) -(provide op) +(define (run-args bf-funcs + [vec-start (make-vector 30000 0)] + [pos-start 0]) + (for/fold ([vec vec-start] + [pos pos-start]) + ([bf-func (in-list bf-funcs)]) + (bf-func vec pos))) + +(define (vector-set v p val) + (vector-set! v p val) + v) -(define bf-vector (make-vector 30000 0)) -(define bf-pointer 0) +(define (vector-update v p func) + (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 (set-current-byte! val) (vector-set! bf-vector bf-pointer val)) +(define (make-looping-func args) + (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)) - LOOP-ARG ...)) + #'(make-looping-func (list LOOP-ARG ...))) (provide loop) \ No newline at end of file