closer

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 ...)
+(define-macro (bf-program PROGRAM-ARG ...)
-  #'(begin OP-OR-LOOP ...))
+  #'(void PROGRAM-ARG ...))
 (provide bf-program)
 
-(define-macro-cases op
+(define arr (make-vector 30000 0))
-  [(op ">") #'(move-pointer 1)]
+(define ptr 0)
-  [(op "<") #'(move-pointer -1)]
+
-  [(op "+") #'(set-current-byte! (add1 (get-current-byte)))]
+(define (current-byte) (vector-ref arr ptr))
-  [(op "-") #'(set-current-byte! (sub1 (get-current-byte)))]
-  [(op ".") #'(write-byte (get-current-byte))]
-  [(op ",") #'(set-current-byte! (read-byte))])
-(provide op)
 
-(define bf-vector (make-vector 30000 0))
+(define (set-current-byte! val) (vector-set! arr ptr val))
-(define bf-pointer 0)
 
-(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-macro-cases op
-(define (set-current-byte! val)  (vector-set! bf-vector bf-pointer val))
+  [(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)

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-macro (bf-program PROGRAM-ARG ...)
-  #'(define-values (vec ptr)
+  #'(void (fold-args (list PROGRAM-ARG ...)
-      (run-args (list OP-OR-LOOP ...))))
+                     (make-vector 30000 0)
+                     0)))
 (provide bf-program)
 
-(define (run-args bf-funcs
+(define (fold-args bf-args arr ptr)
-                  [vec-start (make-vector 30000 0)]
+  (for/fold ([ap (list arr ptr)])
-                  [pos-start 0])
+            ([bf-arg (in-list bf-args)])
-  (for/fold ([vec vec-start]
+    (apply bf-arg ap)))
-             [pos pos-start])
-            ([bf-func (in-list bf-funcs)])
-    (bf-func vec pos)))
 
-(define (vector-set v p val)
+(define (current-byte arr ptr) (vector-ref arr ptr))
-  (vector-set! v p val)
-  v)
 
-(define (vector-update v p func)
+(define (set-current-byte arr ptr val)
-  (vector-set v p (func (vector-ref v p))))
+  (vector-set! arr ptr val)
+  arr)
 
-(define (gt v p) (values v (add1 p)))
+(define (gt arr ptr) (list arr (add1 ptr)))
-(define (lt v p) (values v (sub1 p)))
+(define (lt arr ptr) (list arr (sub1 ptr)))
-(define (plus v p) (values (vector-update v p add1) p))
+(define (plus arr ptr) (list (set-current-byte arr ptr (add1 (current-byte arr ptr))) ptr))
-(define (minus v p) (values (vector-update v p sub1) p))
+(define (minus arr ptr) (list (set-current-byte arr ptr (sub1 (current-byte arr ptr))) ptr))
-(define (period v p) (write-byte (vector-ref v p)) (values v p))
+(define (period arr ptr) (write-byte (current-byte arr ptr)) (list arr ptr))
-(define (comma v p) (values (vector-set v p (read-byte)) p))
+(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)

beautiful-racket/br/demo/bf/bf-reader.rkt

@@ -3,18 +3,18 @@
 
 (define (tokenize input-port)
   (define (next-token)
-    (define get-token
+    (define our-lexer
-      (lexer-src-pos
+      (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)