From 706e20b5fb9dc5d5c11ef51a33de3a0e477753c3 Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Wed, 15 Feb 2017 18:05:48 -0800
Subject: [PATCH] fiddle with `case-pattern`

---
 beautiful-racket-demo/basic-demo-2/if.rkt     | 23 +++++++++++++++----
 beautiful-racket-demo/basic-demo-2/lexer.rkt  |  2 +-
 beautiful-racket-demo/basic-demo-2/parser.rkt |  6 ++---
 beautiful-racket-lib/br/syntax.rkt            | 20 ++++++++++++----
 4 files changed, 38 insertions(+), 13 deletions(-)

diff --git a/beautiful-racket-demo/basic-demo-2/if.rkt b/beautiful-racket-demo/basic-demo-2/if.rkt
index 147d5db..67f26be 100644
--- a/beautiful-racket-demo/basic-demo-2/if.rkt
+++ b/beautiful-racket-demo/basic-demo-2/if.rkt
@@ -2,11 +2,24 @@
 (require "go.rkt")
 (provide b-if b-comp-expr b-logic-expr)
 
-;; b-if : /"if" b-expr /"then" b-expr [/"else" b-expr]
-(define (b-if cond-expr then-expr [else-expr #f])
-  (cond
-    [(not (zero? cond-expr)) (b-goto then-expr)]
-    [else-expr => b-goto]))
+
+#|
+explain why this won't work due to premature eval of THEN & ELSE
+(define (b-if COND THEN ELSE)
+  (let ([result (if (not (zero? COND))
+                     THEN
+                     ELSE)])
+    (when (exact-positive-integer? result)
+      (b-goto result))))
+|#
+
+(define-macro-cases b-if
+  [(_ COND THEN) #'(b-if COND THEN #f)]
+  [(_ COND THEN ELSE) #'(let ([result (if (not (zero? COND))
+                                          THEN
+                                          ELSE)])
+                          (when (exact-positive-integer? result)
+                            (b-goto result)))])
 
 (define bool-int (λ (val) (if val 1 0)))
 (define bi= (compose1 bool-int =))
diff --git a/beautiful-racket-demo/basic-demo-2/lexer.rkt b/beautiful-racket-demo/basic-demo-2/lexer.rkt
index 0a181a4..5e08a4b 100644
--- a/beautiful-racket-demo/basic-demo-2/lexer.rkt
+++ b/beautiful-racket-demo/basic-demo-2/lexer.rkt
@@ -3,7 +3,7 @@
 
 (define-lex-abbrev digits (:+ (char-set "0123456789")))
 
-(define-lex-abbrev reserved-terms (:or "print" "goto" "end" "+" ":" ";" "let" "=" "input" "-" "*" "/" "^" "mod" "(" ")" "def" "if" "then" "else" "and" "or" "<" ">" "!" "gosub" "return" "for" "to" "step" "next"))
+(define-lex-abbrev reserved-terms (:or "print" "goto" "end" "+" ":" ";" "let" "=" "input" "-" "*" "/" "^" "mod" "(" ")" "def" "if" "then" "else" "and" "or" "not" "<" ">" "<>" "gosub" "return" "for" "to" "step" "next"))
 
 (define basic-lexer
   (lexer-srcloc
diff --git a/beautiful-racket-demo/basic-demo-2/parser.rkt b/beautiful-racket-demo/basic-demo-2/parser.rkt
index d099f85..5d4b21e 100644
--- a/beautiful-racket-demo/basic-demo-2/parser.rkt
+++ b/beautiful-racket-demo/basic-demo-2/parser.rkt
@@ -12,7 +12,7 @@ b-print : /"print" [b-printable] (/";" [b-printable])*
 @b-printable : STRING | b-expr
 b-goto : /"goto" b-expr
 b-let : [/"let"] b-id /"=" (STRING | b-expr)
-b-if : /"if" b-expr /"then" b-expr [/"else" b-expr]
+b-if : /"if" b-expr /"then" (b-statement | b-expr) [/"else" (b-statement | b-expr)]
 b-gosub : /"gosub" b-expr
 b-return : /"return"
 b-input : /"input" b-id
@@ -22,8 +22,8 @@ b-for : /"for" b-id /"=" b-expr /"to" b-expr [/"step" b-expr]
 b-next : /"next" [b-id]
 
 b-expr : b-logic-expr 
-b-logic-expr : [b-logic-expr ("and" | "or")] b-comp-expr
-b-comp-expr : [b-comp-expr ("=" | "<" | ">")] b-sum
+b-logic-expr : [b-logic-expr ("and"|"or"|"not")] b-comp-expr
+b-comp-expr : [b-comp-expr ("="|"<"|">"|"<>")] b-sum
 b-sum : [b-sum ("+"|"-")] b-product
 b-product : [b-product ("*"|"/"|"mod")] b-neg
 b-neg : ["-"] b-expt
diff --git a/beautiful-racket-lib/br/syntax.rkt b/beautiful-racket-lib/br/syntax.rkt
index dc6933c..35808b9 100644
--- a/beautiful-racket-lib/br/syntax.rkt
+++ b/beautiful-racket-lib/br/syntax.rkt
@@ -26,10 +26,22 @@
   (require rackunit))
 
 
-(define-macro (syntax-match STX-ARG [(syntax PATTERN) BODY ...] ...)
-  #'(syntax-case STX-ARG ()
-      [PATTERN BODY ...] ...))
-
+(define-macro-cases case-pattern
+  [(_ STX-ARG
+      [PAT . BODY]
+      ...
+      [else . ELSEBODY]) (with-syntax ([(LITERAL ...) (generate-literals #'(PAT ...))])
+                           #'(syntax-case STX-ARG (LITERAL ...)
+                               [PAT . BODY]
+                               ...
+                               [else . ELSEBODY]))]
+  [(_ STX-ARG
+      PAT+BODY
+      ...) #'(case-pattern STX-ARG
+                           PAT+BODY
+                           ...
+                           [else (raise-syntax-error 'case-pattern
+                                                     (format "unable to match pattern for ~v" (syntax->datum STX-ARG)))])])
 
 (define-macro-cases with-pattern
   [(_ () . BODY) #'(begin . BODY)]