rewrite bf expander

pull/2/head
Matthew Butterick 8 years ago
parent 8e917003bc
commit 202f6c9c12

@ -1,29 +1,54 @@
#lang br/quicklang #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 ...) (define-macro (bf-program OP-OR-LOOP ...)
#'(begin OP-OR-LOOP ...)) #'(define-values (vec ptr)
(run-args (list OP-OR-LOOP ...))))
(provide bf-program) (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 ...) (define-macro (loop LOOP-ARG ...)
#'(until (zero? (get-current-byte)) #'(make-looping-func (list LOOP-ARG ...)))
LOOP-ARG ...))
(provide loop) (provide loop)
Loading…
Cancel
Save