pull/2/head
Matthew Butterick 8 years ago
parent 1b1aecbb84
commit 7e367b3d8d

@ -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)

@ -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 ...)))
#'(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)

@ -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)

Loading…
Cancel
Save