refactoring

beautiful-racket-lib/br/define.rkt

@@ -64,10 +64,12 @@
        (when (member 'else all-but-last-pat-datums)
          (raise-syntax-error 'define-cases "else case must be last" (syntax->datum #'top-id.name))))
      (with-syntax* ([((pat . result-exprs) ... else-result-exprs)
-                     (syntax-case #'patexprs (syntax else)
-                       [(((syntax pat) result-expr) ... (else . else-result-exprs))
+                     (syntax-parse #'patexprs
+                       #:literals (syntax else)
+                       ;; syntax notation on pattern is optional
+                       [(((~or (syntax pat) pat) result-expr) ... (else . else-result-exprs))
                         #'((pat result-expr) ... else-result-exprs)]
-                       [(((syntax pat) result-expr) ...)
+                       [(((~or (syntax pat) pat) result-expr) ...)
                         #'((pat result-expr) ... (list (raise-syntax-error 'define-cases (format "no matching case for syntax pattern ~v" (syntax->datum stx)) (syntax->datum #'top-id.name))))])]
                     [LITERALS (generate-literals #'(pat ...))])
        #'(define-syntax top-id.name (λ (stx)
@@ -94,8 +96,8 @@
   (define foo-val 'got-foo-val)
   (define (foo-func) 'got-foo-func)
   (br:define-cases #'op
-                   [#'(_ "+") #''got-plus]
-                   [#'(_ _ARG) #''got-something-else]
+                   [(_ "+") #''got-plus]
+                   [(_ _ARG) #''got-something-else]
                    [#'(_) #'(foo-func)]
                    [#'_ #'foo-val])
   
@@ -295,17 +297,21 @@
 
 (define-syntax (br:define-macro stx)
   (syntax-case stx (syntax)
-    [(_ pat . body)
-     #'(br:define (syntax pat) . body)]))
+    [(_ (id . patargs) . body)
+     #'(br:define (syntax (id . patargs)) . body)]
+    [(_ id [pat . patbody] ...)
+     #'(br:define-cases (syntax id) [pat . patbody] ...)]))
 
 (define-syntax (br:define-macro-cases stx)
   (syntax-case stx (syntax)
-    [(_ pat . body)
-     #'(br:define-cases (syntax pat) . body)]))
+    [(_ id . body)
+     #'(br:define-cases (syntax id) . body)]))
 
 
 (module+ test
   (br:define-macro (add _x) #'(+ _x _x))
   (check-equal? (add 5) 10)
-  (br:define-macro-cases add-again [#'(_ X) #'(+ X X)])
-  (check-equal? (add-again 5) 10))
+  (br:define-macro-cases add-again [(_ X) #'(+ X X)])
+  (check-equal? (add-again 5) 10)
+  (br:define-macro add-3rd [(_ X) #'(+ X X)])
+  (check-equal? (add-3rd 5) 10))

beautiful-racket-lib/br/eopl.rkt

@@ -64,7 +64,7 @@
     [(_ _base-type _input-var
         [_subtype (_positional-var ...) . _body] ...
         [else . _else-body])
-     (inject-syntax ([#'(_subtype? ...) (suffix-ids #'(_subtype ...) "?")])
+     (inject-syntax ([#'(_subtype? ...) (suffix-id #'(_subtype ...) "?")])
                     #'(cond
                         [(_subtype? _input-var) (match-let ([(list _positional-var ...) (struct->list _input-var)])
                                                     . _body)] ...

beautiful-racket/br/demo/basic/expander.rkt

@@ -10,22 +10,23 @@
 
 (define-language-variables [A 0][B 0][C 0][D 0][E 0][F 0][G 0][H 0][I 0][J 0][K 0][L 0][M 0][N 0][O 0][P 0][Q 0][R 0][S 0][T 0][U 0][V 0][W 0][X 0][Y 0][Z 0][A$ ""][B$ ""][C$ ""][D$ ""][E$ ""][F$ ""][G$ ""][H$ ""][I$ ""][J$ ""][K$ ""][L$ ""][M$ ""][N$ ""][O$ ""][P$ ""][Q$ ""][R$ ""][S$ ""][T$ ""][U$ ""][V$ ""][W$ ""][X$ ""][Y$ ""][Z$ ""])
 
-(define #'(basic-module-begin _parse-tree ...)
+(define-macro (basic-module-begin SRC-EXPR ...)
   #'(#%module-begin
      (inject-language-variables (A B C D E F G H I J K L M N O P Q R S T U V W X Y Z A$ B$ C$ D$ E$ F$ G$ H$ I$ J$ K$ L$ M$ N$ O$ P$ Q$ R$ S$ T$ U$ V$ W$ X$ Y$ Z$)
-                                (println (quote _parse-tree ...))
-                                _parse-tree ...)))
+                                (println (quote SRC-EXPR ...))
+                                SRC-EXPR ...)))
 
 ; #%app and #%datum have to be present to make #%top work
-(define #'(basic-top . id)
+(define-macro (basic-top . ID)
   #'(begin
-      (displayln (format "got unbound identifier: ~a" 'id))
-      (procedure-rename (λ xs (cons 'id xs)) (string->symbol (format "undefined:~a" 'id)))))
+      (displayln (format "got unbound identifier: ~a" 'ID))
+      (procedure-rename (λ xs (cons 'ID xs)) (string->symbol (format "undefined:~a" 'ID)))))
 
-(define #'(program _line ...) #'(run (list _line ...)))
+(define-macro (program LINE ...) #'(run (list LINE ...)))
 
 
 (struct exn:line-not-found exn:fail ())
+(struct exn:program-end exn:fail ())
 
 
 (define (run lines)
@@ -39,9 +40,10 @@
       (exn:line-not-found
        (format "line number ~a not found in program" ln)
        (current-continuation-marks)))))
+  (with-handlers ([exn:program-end? (λ(exn) (void))])
+    (void
      (for/fold ([program-counter 0])
-            ([i (in-naturals)]
-             #:break (eq? program-counter 'end))
+               ([i (in-naturals)])
        (cond
          [(= program-counter (vector-length program-lines)) (basic:END)]
          [else
@@ -49,85 +51,73 @@
           (define maybe-next-line (and line-function (line-function)))
           (cond
             [(number? maybe-next-line) (line-number->index maybe-next-line)]
-         [(eq? 'end maybe-next-line) 'end]
-         [else (add1 program-counter)])]))
-  (void))
+            [else (add1 program-counter)])])))))
 
-(define #'(cr-line _arg ...) #'(begin _arg ...))
+(define-macro (cr-line ARG ...) #'(begin ARG ...))
 
 
 (define current-return-stack (make-parameter empty))
 
-(define-cases #'line
-  [#'(_ _NUMBER (statement-list (statement "GOSUB" _WHERE)))
-   #'(cons _NUMBER
+(define-macro line
+  [(_ NUMBER (statement-list (statement "GOSUB" WHERE)))
+   #'(cons NUMBER
            (λ _
              (let ([return-stack (current-return-stack)])
                (cond
                  [(or (empty? return-stack)
-                      (not (= _NUMBER (car return-stack))))
-                  (current-return-stack (cons _NUMBER (current-return-stack)))
-                  (basic:GOTO _WHERE)]
+                      (not (= NUMBER (car return-stack))))
+                  (current-return-stack (cons NUMBER (current-return-stack)))
+                  (basic:GOTO WHERE)]
                  [else (current-return-stack (cdr (current-return-stack)))]))))]
-  [#'(_ _NUMBER _STATEMENT-LIST) #'(cons _NUMBER (λ _ _STATEMENT-LIST))])
-
-(define-cases #'statement-list
-  [#'(_ _STATEMENT) #'(begin _STATEMENT)]
-  [#'(_ _STATEMENT ":" _STATEMENT-LIST) #'(begin _STATEMENT _STATEMENT-LIST)])
-
-(define-cases #'statement
-  [#'(statement _ID "=" _EXPR) #'(set! _ID _EXPR)]
-  ;[#'(statement "PRINT" ARG ...) #'(print ARG ...)]
-  ;[#'(statement "RETURN" ARG ...) #'(return ARG ...)]
-  ;[#'(statement "END" ARG ...) #'(end ARG ...)]
-  [#'(statement _proc-string _arg ...)
-   (inject-syntax ([#'PROC-ID (format-datum "basic:~a" #'_proc-string)])
-                  #'(PROC-ID _arg ...))])
-
-(define-cases #'basic:IF
-  [#'(_ _COND "THEN" _TRUE-RESULT "ELSE" _FALSE-RESULT)
-   #'(if (true? _COND)
-         _TRUE-RESULT
-         _FALSE-RESULT)]
-  [#'(_ _COND "THEN" _TRUE-RESULT)
-   #'(when (true? _COND)
-       _TRUE-RESULT)])
-
-(define-cases #'value
-  [#'(value "(" _EXPR ")") #'_EXPR]
-  [#'(value _ID "(" _ARG ... ")") #'(_ID _ARG ...)]
-  [#'(value _ID-OR-DATUM) #'_ID-OR-DATUM])
+  [(_ NUMBER STATEMENT-LIST) #'(cons NUMBER (λ _ STATEMENT-LIST))])
+
+(define-macro statement-list
+  [(_ STATEMENT) #'(begin STATEMENT)]
+  [(_ STATEMENT ":" STATEMENT-LIST) #'(begin STATEMENT STATEMENT-LIST)])
+
+(define-macro statement
+  [(statement ID "=" EXPR) #'(set! ID EXPR)]
+  [(statement PROC-STRING ARG ...)
+   (with-pattern
+    ([PROC-ID (prefix-id "basic:" #'PROC-STRING)])
+    #'(PROC-ID ARG ...))])
+
+(define-macro basic:IF
+  [(_ COND "THEN" TRUE-RESULT "ELSE" FALSE-RESULT)
+   #'(if (true? COND)
+         TRUE-RESULT
+         FALSE-RESULT)]
+  [(_ COND "THEN" TRUE-RESULT)
+   #'(when (true? COND)
+       TRUE-RESULT)])
 
 (define true? (compose1 not zero?))
 (define (cond->int cond) (if cond 1 0))
 (define (basic:and . args) (cond->int (andmap true? args)))
 (define (basic:or . args) (cond->int (ormap true? args)))
 
-(define-cases #'expr-list
-  [#'(_ _EXPR) #'_EXPR]
-  [#'(_ _EXPR "," _EXPR-LIST) #'(_EXPR _EXPR-LIST)])
+(define-macro expr
+  [(_ COMP-EXPR "AND" SUBEXPR) #'(basic:and COMP-EXPR SUBEXPR)]
+  [(_ COMP-EXPR "OR" SUBEXPR) #'(basic:or COMP-EXPR SUBEXPR)]
+  [(_ COMP-EXPR) #'COMP-EXPR])
 
-(define-cases #'expr
-  [#'(_ _COMP-EXPR "AND" _SUBEXPR) #'(basic:and _COMP-EXPR _SUBEXPR)]
-  [#'(_ _COMP-EXPR "OR" _SUBEXPR) #'(basic:or _COMP-EXPR _SUBEXPR)]
-  [#'(_ _COMP-EXPR) #'_COMP-EXPR])
+(define-macro comp-expr
+  [(_ LEXPR "=" REXPR) #'(comp-expr LEXPR "equal?" REXPR)] ; special case because = is overloaded
+  [(_ LEXPR OP-STR REXPR) (with-pattern ([OP (replace-context #'here (prefix-id #'OP-STR))])
+                                        #'(cond->int (OP LEXPR REXPR)))]
+  [(_ ARG) #'ARG])
 
-(define-cases #'comp-expr
-  [#'(_ _LEXPR "=" _REXPR) #'(comp-expr _LEXPR "equal?" _REXPR)] ; special case because = is overloaded
-  [#'(_ _LEXPR _op _REXPR) (inject-syntax ([#'OP (string->symbol (syntax->datum #'_op))])
-                                          #'(cond->int (OP _LEXPR _REXPR)))]
-  [#'(_ _ARG) #'_ARG])
 (define <> (compose1 not equal?))
 
-(define-cases #'sum
-  [#'(_ _TERM "+" _SUM) #'(+ _TERM _SUM)]
-  [#'(_ _TERM "-" _SUM) #'(- _TERM _SUM)]
-  [#'(_ _TERM) #'_TERM])
+(define-macro sum
+  [(_ TERM "+" SUM) #'(+ TERM SUM)]
+  [(_ TERM "-" SUM) #'(- TERM SUM)]
+  [(_ TERM) #'TERM])
 
-(define-cases #'product
-  [#'(_ _value "*" _product) #'(* _value _product)]
-  [#'(_ _value "/" _product) #'(/ _value _product)]
-  [#'(_ _value) #'_value])
+(define-macro product
+  [(_ VALUE "*" PRODUCT) #'(* VALUE PRODUCT)]
+  [(_ VALUE "/" PRODUCT) #'(/ VALUE PRODUCT)]
+  [(_ VALUE) #'VALUE])
 
 (define print-list list)
 
@@ -140,23 +130,26 @@
     [(list print-list-item ...) (for-each displayln print-list-item)]))
 
 (define (TAB num) (make-string num #\space))
-(define #'(INT _ARG ...) #'(inexact->exact (truncate (expr _ARG ...))))
+(define-macro (INT _ARG ...) #'(inexact->exact (truncate (expr _ARG ...))))
 (define (SIN num) (sin num))
 (define (ABS num) (inexact->exact (abs num)))
 (define (RND num) (* (random) num))
 
-(define-cases #'basic:INPUT
-  [#'(_ _PRINT-LIST ";" _ID)
+(define-macro basic:INPUT
+  [(_ PRINT-LIST ";" _ID)
    #'(begin
-       (basic:PRINT (append _PRINT-LIST (list ";")))
+       (basic:PRINT (append PRINT-LIST (list ";")))
        (basic:INPUT _ID))]
-  [#'(_ _ID) #'(set! _ID (let* ([str (read-line)]
+  [(_ ID) #'(set! ID (let* ([str (read-line)]
                             [num (string->number str)])
-                           (if num num str)))])
+                       (or num str)))])
 
 (define (basic:GOTO where) where)
 
 (define (basic:RETURN) (car (current-return-stack)))
 
 (define (basic:END)
-  'end)
+  (raise
+   (exn:program-end
+    ""
+    (current-continuation-marks))))

beautiful-racket/br/demo/basic/parser.rkt

@@ -26,10 +26,9 @@ sum : product [("+" | "-") sum]
 
 product : value [("*" | "/") product]
 
-expr-list : expr ["," expr-list]*
-
-value : ID ["(" expr-list ")"]
-| "(" expr ")"
+@value : ID | id-expr
+| /"(" expr /")"
 | STRING
 | NUMBER
 
+/id-expr : ID [/"(" expr [/"," expr]* /")"]

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

@@ -1,36 +1,34 @@
 #lang br
 
-(define #'(bf-module-begin _PARSE-TREE ...)
+(define-macro (bf-module-begin SRC-EXPR ...)
   #'(#%module-begin
-     _PARSE-TREE ...)) 
-(provide (rename-out [bf-module-begin #%module-begin])
-         #%top-interaction)
+     SRC-EXPR ...)) 
+(provide (rename-out [bf-module-begin #%module-begin]))
 
-(define #'(bf-program _OP-OR-LOOP ...)
-  #'(begin _OP-OR-LOOP ...))
+(define-macro (bf-program OP-OR-LOOP ...)
+  #'(begin OP-OR-LOOP ...))
 (provide bf-program)
 
-(define-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))])
+(define-macro 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 bf-vector (make-vector 30000 0))
 (define bf-pointer 0)
 
-(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 (get-current-byte)
-  (vector-ref bf-vector bf-pointer))
-(define (set-current-byte! val)
-  (vector-set! bf-vector bf-pointer val))
+(define (get-current-byte) (vector-ref bf-vector bf-pointer))
+(define (set-current-byte! val)  (vector-set! bf-vector bf-pointer val))
 
-(define #'(loop "[" _OP-OR-LOOP ... "]")
+(define-macro (loop LOOP-ARG ...)
   #'(until (zero? (get-current-byte))
-           _OP-OR-LOOP ...))
+           LOOP-ARG ...))
 (provide loop)
+
+(provide #%top-interaction)

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

@@ -1,4 +1,4 @@
 #lang brag
 bf-program : (op | loop)*
 op : ">" | "<" | "+" | "-" | "." | ","
-loop : "[" (op | loop)* "]"
+loop : /"[" (op | loop)* /"]"

beautiful-racket/br/demo/stacker-test.rkt

@@ -0,0 +1,6 @@
+#lang reader br/demo/stacker
+push 4
+push 8
++
+push 3
+*

beautiful-racket/br/demo/stacker.rkt

@@ -1,33 +1,29 @@
 #lang br
+
 (define (read-syntax source-path input-port)
   (define src-strs (remove-blank-lines (port->lines input-port)))
   (define (make-datum str) (format-datum '(dispatch ~a) str))
   (define src-exprs (map make-datum src-strs))
   (strip-context
-   (inject-syntax ([#'(_SRC-EXPR ...) src-exprs])
+   (with-pattern ([(SRC-EXPR ...) (map make-datum src-strs)])
                  #'(module stacker-mod br/demo/stacker
-                      _SRC-EXPR ...))))
+                     SRC-EXPR ...))))
 (provide read-syntax)
 
-(define #'(stacker-module-begin _READER-LINE ...)
+(define-macro (stacker-module-begin READER-LINE ...)
   #'(#%module-begin
-     _READER-LINE ...
+     READER-LINE ...
      (display (first stack))))
 (provide (rename-out [stacker-module-begin #%module-begin]))
-(provide #%top-interaction)
 
 (define stack empty)
 (define (push num) (set! stack (cons num stack)))
 (provide push)
 
-(define (dispatch arg-1 [arg-2 #f])
-  (cond
-    [(number? arg-2) (push arg-2)]
-    [else
-     (define op arg-1)
-     (define op-result (op (first stack) (second stack)))
-     (set! stack (cons op-result (drop stack 2)))]))
+(define-cases dispatch
+  [(_ push num) (push num)]
+  [(_ op) (define op-result (op (first stack) (second stack)))
+          (set! stack (cons op-result (drop stack 2)))])
 (provide dispatch)
 
-(provide + *)
-(provide #%app #%datum)
+(provide + * #%app #%datum #%top-interaction)