diff --git a/br-bf/main.rkt b/br-bf/main.rkt index 0ed8e15..10dfa94 100644 --- a/br-bf/main.rkt +++ b/br-bf/main.rkt @@ -1,39 +1,27 @@ #lang br -(provide #%module-begin #%top-interaction - bf-program op loop) - -(module reader syntax/module-reader - #:language 'br-bf - #:read bf-read - #:read-syntax bf-read-syntax - ;; need this because we keep state, - ;; therefore expansion is "all or nothing" - #:whole-body-readers? #t - - (require "tokenizer.rkt" "parser.rkt") - (define (bf-read in) - (syntax->datum (bf-read-syntax #f in))) - - (define (bf-read-syntax src ip) - (define result (list (parse src (tokenize ip)))) - ;; prints out corresponding s-exp source - (for-each println (map syntax->datum result)) - result)) +(provide #%module-begin #%top-interaction bf-program op loop) + +(module reader br + (require "tokenizer.rkt" "parser.rkt" syntax/strip-context) + (provide read-syntax) + (define (read-syntax src-path src-port) + (define src-exprs (list (parse src-path (tokenize src-port)))) + ;; todo: why is `replace-context` necessary ; why does #'here work + (replace-context #'here + (inject-syntax ([#'( ...) src-exprs]) + #'(module bf-interpreter br-bf + ...))))) (define #'(bf-program ...) #'(begin ...)) (define-cases #'op - [#'(_ ">") #'(move-pointer 1)] - [#'(_ "<") #'(move-pointer -1)] - [#'(_ "+") #'(set-pointer-byte! (add1 (get-pointer-byte)))] - [#'(_ "-") #'(set-pointer-byte! (sub1 (get-pointer-byte)))] - [#'(_ ".") #'(write-byte (get-pointer-byte))] - [#'(_ ",") #'(set-pointer-byte! (read-byte))]) - -(define-cases f - [(_ arg) (add1 arg)] - [(_ arg1 arg2) (+ arg1 arg2)]) + [#'(_ ">") #'(move-pointer 1)] + [#'(_ "<") #'(move-pointer -1)] + [#'(_ "+") #'(set-pointer-byte! (add1 (get-pointer-byte)))] + [#'(_ "-") #'(set-pointer-byte! (sub1 (get-pointer-byte)))] + [#'(_ ".") #'(write-byte (get-pointer-byte))] + [#'(_ ",") #'(set-pointer-byte! (read-byte))]) (define #'(loop "[" ... "]") #'(until (zero? (get-pointer-byte)) @@ -44,11 +32,3 @@ (define (get-pointer-byte) (vector-ref bf-vector bf-pointer)) (define (set-pointer-byte! val) (vector-set! bf-vector bf-pointer val)) (define (move-pointer how-far) (set! bf-pointer (+ bf-pointer how-far))) - -(define (dump) - (displayln "") - (displayln bf-pointer) - (displayln bf-vector)) - - -