works

br-bf/bf-test-sexp.rkt

@@ -1,2 +1,2 @@
 #lang s-exp br-bf
-(bf-program (op "+") (op "+") (op "+") (op "+") (op "+") (op "+") (op "+") (op (loop "[" (op ">") (op "+") (op "+") (op "+") (op "+") (op "+") (op "<") (op "-") "]")) (op ">") (op "."))
+(bf-program (op "+") (op "+") (op "+") (op "+") (op "+") (op "+") (op "+") (loop "[" (op ">") (op "+") (op "+") (op "+") (op "+") (op "+") (op "<") (op "-") "]") (op ">") (op "."))

br-bf/main.rkt

@@ -20,30 +20,30 @@
     (for-each println (map syntax->datum result))
     result))
 
-(define #'(bf-program <op> ...)
+(define #'(bf-program <op-or-loop> ...)
-  #'(begin <op> ...))
+  #'(begin <op-or-loop> ...))
-
+
-(define #'(op <arg>)
+(define-cases #'op
-  (syntax-case #'(op <arg>) ()
+    [#'(_ ">") #'(move-pointer 1)]
-    [(op ">") #'(move-pointer 1)]
+    [#'(_ "<") #'(move-pointer -1)]
-    [(op "<") #'(move-pointer -1)]
+    [#'(_ "+") #'(set-pointer-byte! (add1 (get-pointer-byte)))]
-    [(op "+") #'(set-pointer-byte! (add1 (pointer-byte)))]
+    [#'(_ "-") #'(set-pointer-byte! (sub1 (get-pointer-byte)))]
-    [(op "-") #'(set-pointer-byte! (sub1 (pointer-byte)))]
+    [#'(_ ".") #'(write-byte (get-pointer-byte))]
-    [(op ".") #'(write-byte (pointer-byte))]
+    [#'(_ ",") #'(set-pointer-byte! (read-byte))])
-    [(op ",") #'(set-pointer-byte! (read-byte))]
+
-    [else #'<arg>])) ; <arg> must therefore be a loop
+(define-cases f
-
+  [(_ arg) (add1 arg)]
-(define #'(loop "[" <op> ... "]")
+  [(_ arg1 arg2) (+ arg1 arg2)])
-  #'(until (zero? (pointer-byte))
+
-           <op> ...))
+(define #'(loop "[" <op-or-loop> ... "]")
-
+  #'(until (zero? (get-pointer-byte))
-(define bf-vector (make-vector 10 0))
+           <op-or-loop> ...))
+
+(define bf-vector (make-vector 1000 0))
 (define bf-pointer 0)
-(define (pointer-byte) (vector-ref bf-vector bf-pointer))
+(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 (move-pointer how-far)
-  (set! bf-pointer (+ bf-pointer how-far)))
 
 (define (dump)
   (displayln "")

br-bf/parser.rkt

@@ -2,6 +2,19 @@
 ;; use uppercase TOKEN-IDENTIFIERS for classes of tokens
 ;; too numerous to indicate individually
 ;; (e.g., numbers, strings)
-bf-program : op*
+
-op : ">" | "<" | "+" | "-" | "." | "," | loop
+bf-program : (op | loop)*
-loop : "[" op* "]"
+op : ">" | "<" | "+" | "-" | "." | ","
+loop : "[" (op | loop)* "]"
+
+
+;; Alternate ways of specifying grammar
+;; bf-program : op*
+;; op : ">" | "<" | "+" | "-" | "." | "," | loop
+;; loop : "[" op* "]"
+
+;; bf-program : expr*
+;; expr : op | loop
+;; op : ">" | "<" | "+" | "-" | "." | ","
+;; loop : "[" bf-program "]"
+

br/define.rkt

@@ -75,3 +75,38 @@
                                #'(zam x x))) (foo 42)) 84) 
   ;; todo: error from define not trapped by check-exn 
   #;(check-exn exn:fail:syntax? (λ _ (br:define (#'times stx stx2) #'*))))
+
+
+;; todo: support `else` case
+(define-syntax (br:define-cases stx)
+  (syntax-parse stx
+    #:literals (syntax)
+    ; (define-cases #'foo [#'(_ arg) #'(+ arg arg)] [#'(_ 42 bar) #'42] ...)
+    [(_ (syntax top-id) [(syntax (_ pat-arg ... . rest-arg)) body ...] ...) 
+     #'(define-syntax top-id (λ (stx)
+                               (define result
+                                 (syntax-case stx ()
+                                   [(_ pat-arg ... . rest-arg) body ...] ...))
+                               (if (not (syntax? result))
+                                   (datum->syntax stx result)
+                                   result)))]
+    
+    [(_ top-id [(_ pat-arg ... . rest-arg) body ...] ...)
+     #'(define top-id
+         (case-lambda
+           [(pat-arg ... . rest-arg) body ...] ...))]))
+
+(module+ test
+  (br:define-cases #'op
+    [#'(_ "+") #''got-plus]
+    [#'(_ arg) #''got-something-else])
+
+  (check-equal? (op "+") 'got-plus)
+  (check-equal? (op 42) 'got-something-else)
+  
+  (br:define-cases f
+    [(_ arg) (add1 arg)]
+    [(_ arg1 arg2) (+ arg1 arg2)])
+
+  (check-equal? (f 42) 43)
+  (check-equal? (f 42 5) 47))