From 7e367b3d8da17f31997066498eb547804e18b9ac Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sun, 28 Aug 2016 22:18:34 -0700 Subject: [PATCH] closer --- .../br/demo/bf/bf-expander-imperative.rkt | 43 +++++++++------ beautiful-racket/br/demo/bf/bf-expander.rkt | 55 ++++++++----------- beautiful-racket/br/demo/bf/bf-reader.rkt | 10 ++-- 3 files changed, 55 insertions(+), 53 deletions(-) diff --git a/beautiful-racket/br/demo/bf/bf-expander-imperative.rkt b/beautiful-racket/br/demo/bf/bf-expander-imperative.rkt index 5aead01..8a096ab 100644 --- a/beautiful-racket/br/demo/bf/bf-expander-imperative.rkt +++ b/beautiful-racket/br/demo/bf/bf-expander-imperative.rkt @@ -1,29 +1,38 @@ #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-macro (bf-program PROGRAM-ARG ...) + #'(void PROGRAM-ARG ...)) (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 arr (make-vector 30000 0)) +(define ptr 0) + +(define (current-byte) (vector-ref arr ptr)) -(define bf-vector (make-vector 30000 0)) -(define bf-pointer 0) +(define (set-current-byte! val) (vector-set! arr ptr val)) -(define (move-pointer how-far) (set! bf-pointer (+ bf-pointer how-far))) +(define (gt) (set! ptr (add1 ptr))) +(define (lt) (set! ptr (sub1 ptr))) +(define (plus) (set-current-byte! (add1 (current-byte)))) +(define (minus) (set-current-byte! (sub1 (current-byte)))) +(define (period) (write-byte (current-byte))) +(define (comma) (set-current-byte! (read-byte))) -(define (get-current-byte) (vector-ref bf-vector bf-pointer)) -(define (set-current-byte! val) (vector-set! bf-vector bf-pointer val)) +(define-macro-cases op + [(op ">") #'(gt)] + [(op "<") #'(lt)] + [(op "+") #'(plus)] + [(op "-") #'(minus)] + [(op ".") #'(period)] + [(op ",") #'(comma)]) +(provide op) (define-macro (loop LOOP-ARG ...) - #'(until (zero? (get-current-byte)) + #'(until (zero? (current-byte)) LOOP-ARG ...)) (provide loop) diff --git a/beautiful-racket/br/demo/bf/bf-expander.rkt b/beautiful-racket/br/demo/bf/bf-expander.rkt index 18549ab..ab0f695 100644 --- a/beautiful-racket/br/demo/bf/bf-expander.rkt +++ b/beautiful-racket/br/demo/bf/bf-expander.rkt @@ -5,32 +5,29 @@ PARSE-TREE)) (provide (rename-out [bf-module-begin #%module-begin])) -(define-macro (bf-program OP-OR-LOOP ...) - #'(define-values (vec ptr) - (run-args (list OP-OR-LOOP ...)))) +(define-macro (bf-program PROGRAM-ARG ...) + #'(void (fold-args (list PROGRAM-ARG ...) + (make-vector 30000 0) + 0))) (provide bf-program) -(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 (fold-args bf-args arr ptr) + (for/fold ([ap (list arr ptr)]) + ([bf-arg (in-list bf-args)]) + (apply bf-arg ap))) -(define (vector-set v p val) - (vector-set! v p val) - v) +(define (current-byte arr ptr) (vector-ref arr ptr)) -(define (vector-update v p func) - (vector-set v p (func (vector-ref v p)))) +(define (set-current-byte arr ptr val) + (vector-set! arr ptr val) + arr) -(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 (gt arr ptr) (list arr (add1 ptr))) +(define (lt arr ptr) (list arr (sub1 ptr))) +(define (plus arr ptr) (list (set-current-byte arr ptr (add1 (current-byte arr ptr))) ptr)) +(define (minus arr ptr) (list (set-current-byte arr ptr (sub1 (current-byte arr ptr))) ptr)) +(define (period arr ptr) (write-byte (current-byte arr ptr)) (list arr ptr)) +(define (comma arr ptr) (list (set-current-byte arr ptr (read-byte)) ptr)) (define-macro-cases op [(op ">") #'gt] @@ -41,14 +38,10 @@ [(op ",") #'comma]) (provide op) -(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 ...) - #'(make-looping-func (list LOOP-ARG ...))) -(provide loop) \ No newline at end of file + #'(lambda (arr ptr) + (for/fold ([ap (list arr ptr)]) + ([i (in-naturals)] + #:break (zero? (apply current-byte ap))) + (apply fold-args (list LOOP-ARG ...) ap)))) +(provide loop) diff --git a/beautiful-racket/br/demo/bf/bf-reader.rkt b/beautiful-racket/br/demo/bf/bf-reader.rkt index e5b1da6..2ae740e 100644 --- a/beautiful-racket/br/demo/bf/bf-reader.rkt +++ b/beautiful-racket/br/demo/bf/bf-reader.rkt @@ -3,18 +3,18 @@ (define (tokenize input-port) (define (next-token) - (define get-token - (lexer-src-pos + (define our-lexer + (lexer [(char-set "><-.,+[]") lexeme] [(char-complement (char-set "><-.,+[]")) - (token 'OTHER #:skip? #t)] + (token 'COMMENT #:skip? #t)] [(eof) eof])) - (get-token input-port)) + (our-lexer input-port)) next-token) (require "bf-parser.rkt") (define (read-syntax source-path input-port) (define parse-tree (parse source-path (tokenize input-port))) - (datum->syntax #f `(module bf-mod br/demo/bf/bf-expander + (datum->syntax #f `(module bf-mod br/demo/bf/bf-expander-imperative ,parse-tree))) (provide read-syntax)