some things

.travis.yml

@@ -14,6 +14,8 @@ env:
 #    - RACKET_VERSION=6.2
     - RACKET_VERSION=6.3
     - RACKET_VERSION=6.4
+    - RACKET_VERSION=6.5
+    - RACKET_VERSION=6.6
     - RACKET_VERSION=HEAD
 
 # You may want to test against certain versions of Racket, without

beautiful-racket-lib/br/cond.rkt

@@ -0,0 +1,36 @@
+#lang racket/base
+(require (for-syntax racket/base br/syntax)
+         br/define)
+(provide (all-defined-out))
+
+(define-macro (until COND EXPR ...)
+  #'(let loop ()
+      (unless COND
+        EXPR ...
+        (loop))))
+
+(define-macro (while COND EXPR ...)
+  #'(let loop ()
+      (when COND
+        EXPR ...
+        (loop))))
+
+(define-macro (forever . EXPRS)
+  ;; todo: would be better with a syntax parameter
+  (with-pattern
+   ([stop (datum->syntax #'EXPRS 'stop)])
+   #'(let/ec stop
+       (while #t
+              . EXPRS))))
+
+(module+ test
+  (require rackunit)
+  (check-equal? (let ([x 5])
+                  (until (zero? x)
+                         (set! x (- x 1)))
+                  x) 0)
+  (check-equal? (let ([x 5])
+                  (while (positive? x)
+                         (set! x (- x 1)))
+                  x) 0))
+

beautiful-racket-lib/br/conditional.rkt

@@ -1,15 +0,0 @@
-#lang racket/base
-(require (for-syntax racket/base))
-(provide (all-defined-out))
-
-(define-syntax-rule (until cond expr ...)
-  (let loop ()
-    (unless cond
-      expr ...
-      (loop))))
-
-(define-syntax-rule (while cond expr ...)
-  (let loop ()
-    (when cond
-      expr ...
-      (loop))))

beautiful-racket-lib/br/datum.rkt

@@ -1,31 +1,29 @@
 #lang racket/base
 (require (for-syntax racket/base br/syntax) br/define)
-(provide (all-defined-out))
+(provide (except-out (all-defined-out) string->datum))
 
 ;; read "foo bar" the same way as "(foo bar)" 
-;; other "bar" is dropped, which is too astonishing
+;; otherwise "bar" is dropped, which is too astonishing
 (define (string->datum str)
-  (let ([result (read (open-input-string (format "(~a)" str)))])
+  (if (positive? (string-length str))
-    (if (= (length result) 1)
+      (let ([result (read (open-input-string (format "(~a)" str)))])
-        (car result)
+        (if (= (length result) 1)
-        result)))
+            (car result)
+            result))
+      (void)))
 
-#;(define-syntax format-datum
+(define (datum? x)
-    (λ(stx)
+  (or (list? x) (symbol? x)))
-      (syntax-case stx (quote datum)
-        [(_ (quote <datum-template>) <arg> ...)
-         #'(format-datum (datum <datum-template>) <arg> ...)]
-        [(_ (datum datum-template) <arg> ...)
-         (syntax-let ([#'format-string (format "~a" (syntax->datum #'datum-template))])
-                     #'(string->datum (apply format format-string (map (λ(arg) (if (syntax? arg)
-                                                                                   (syntax->datum arg)
-                                                                                   arg)) (list <arg> ...)))))])))
 
 (define (format-datum datum-template . args)
   (string->datum (apply format (format "~a" datum-template) (map (λ(arg) (if (syntax? arg)
                                                                              (syntax->datum arg)
                                                                              arg)) args))))
 
+;; todo: rephrase errors from `format` or `map` in terms of `format-datums`
+(define (format-datums datum-template . argss)
+  (apply map (λ args (apply format-datum datum-template args)) argss))
+
 (module+ test
   (require rackunit syntax/datum)
   (check-equal? (string->datum "foo") 'foo)
@@ -36,4 +34,5 @@
   (check-equal? (format-datum '(~a-bar-~a) #'foo #'zam) '(foo-bar-zam))
   (check-equal? (format-datum (datum (~a-bar-~a)) "foo" "zam") '(foo-bar-zam))
   (check-equal? (format-datum '~a "foo") 'foo)
-  (check-equal? (format-datum (datum ~a) "foo") 'foo))
+  (check-equal? (format-datum (datum ~a) "foo") 'foo)
+  (check-equal? (format-datums '(put ~a) '("foo" "zam")) '((put foo) (put zam))))

beautiful-racket-lib/br/debug.rkt

@@ -1,17 +1,26 @@
 #lang racket/base
-(require (for-syntax racket/base racket/syntax))
+(require (for-syntax racket/base br/syntax)
+         br/define)
 (provide (all-defined-out))
 
-(define-syntax (report stx)
+(define-macro-cases report
-  (syntax-case stx ()
+  [(_ EXPR) #'(report EXPR EXPR)]
-    [(_ expr) #'(report expr expr)]
+  [(_ EXPR NAME)
-    [(_ expr name)
+   #'(let ([expr-result EXPR]) 
-     #'(let ([expr-result expr]) 
+       (eprintf "~a = ~v\n" 'NAME expr-result)
-         (eprintf "~a = ~v\n" 'name expr-result)
+       expr-result)])
-         expr-result)]))
 
-(define-syntax-rule (define-multi-version multi-name name)
+(define-macro-cases report-datum
-  (define-syntax-rule (multi-name x (... ...))
+  [(_ STX-EXPR)
-    (begin (name x) (... ...))))
+   (with-pattern ([datum (syntax->datum #'STX-EXPR)])
+     #'(report-datum STX-EXPR datum))]
+  [(_ STX-EXPR NAME)
+   #'(let () 
+       (eprintf "~a = ~v\n" 'NAME (syntax->datum STX-EXPR))
+       STX-EXPR)])
+
+(define-macro (define-multi-version MULTI-NAME NAME)
+  #'(define-macro (MULTI-NAME X (... ...))
+      #'(begin (NAME X) (... ...))))
 
 (define-multi-version report* report)

beautiful-racket-lib/br/define.rkt

@@ -1,284 +1,262 @@
 #lang racket/base
-(require (for-syntax racket/list racket/base syntax/parse racket/syntax syntax/datum syntax/strip-context racket/string) sugar/define)
+(require
-(provide (all-defined-out))
+  racket/function
+  (for-syntax racket/base
+              syntax/parse
+              br/private/syntax-flatten
+              syntax/define))
+(provide (all-defined-out)
+         (for-syntax with-shared-id))
 
-;; everything is prefixed br: whether it needs it or not so it can be stripped by #lang br
+(module+ test
+  (require rackunit))
 
-(define-for-syntax (syntax-flatten stx)
-  (flatten
-   (let loop ([stx stx])
-     (define maybe-list (syntax->list stx))
-     (if maybe-list
-         (map loop maybe-list)
-         stx))))
 
-(define-for-syntax (generate-literals pats)
+(define-syntax (define+provide stx)
-  ;; generate literals for any symbols that are not ... or _ or _underscore-prefixed
+  (with-syntax ([(id lambda-exp)
-  (define pattern-arg-prefixer "_")
+                 (let-values ([(id-stx body-exp-stx)
-  (for/list ([pat-arg (in-list (syntax-flatten pats))]
+                               (normalize-definition stx (datum->syntax stx 'λ) #t #t)])
-             #:when (let ([pat-datum (syntax->datum pat-arg)])
+                   (list id-stx body-exp-stx))])
-                      (and (symbol? pat-datum)
+    #'(begin
-                           (not (member pat-datum '(... _ else))) ; exempted from literality
+        (provide id)
-                           (not (string-prefix? (symbol->string pat-datum) pattern-arg-prefixer)))))
+        (define id lambda-exp))))
-            pat-arg))
+
 
-;; expose the caller context within br:define macros with syntax parameter
 (begin-for-syntax
+  (define (upcased-and-capitalized? str)
+    (and (equal? (string-upcase str) str)
+         (not (equal? (string-downcase (substring str 0 1)) (substring str 0 1)))))
+
+  (define (generate-literals pats)
+    ;; generate literals for any symbols that are not ... or _ 
+    (define pattern-arg-prefixer "_")
+    (for*/list ([pat-arg (in-list (syntax-flatten pats))]
+                [pat-datum (in-value (syntax->datum pat-arg))]
+                #:when (and (symbol? pat-datum)
+                            (not (member pat-datum '(... _))) ; exempted from literality
+                            (not (upcased-and-capitalized? (symbol->string pat-datum)))))
+               pat-arg)))
+
+(begin-for-syntax
+  ;; expose the caller context within br:define macros with syntax parameter
   (require (for-syntax racket/base) racket/stxparam)
-  (provide caller-stx shared-syntax)
+  (provide caller-stx)
-  (define-syntax-parameter caller-stx (λ(stx) (error 'caller-stx-not-parameterized)))
+  (define-syntax-parameter caller-stx (λ(stx) (error 'caller-stx-not-parameterized))))
-  (define-syntax-parameter shared-syntax (λ(stx) (error 'shared-syntax-not-parameterized))))
 
 
-(define-syntax (br:define-cases stx)
+(define-syntax (define-cases stx)
-  (define-syntax-class syntaxed-id
-    #:literals (syntax)
-    #:description "id in syntaxed form"
-    (pattern (syntax name:id)))
-  
-  (define-syntax-class syntaxed-thing
-    #:literals (syntax)
-    #:description "some datum in syntaxed form"
-    (pattern (syntax thing:expr)))
-  
   (syntax-parse stx
     #:literals (syntax)
-    
+    [(_ id:id)
-    ;; defective for syntax or function
+     (raise-syntax-error 'define-cases "no cases given" (syntax->datum #'id))]
-    [(_ top-id)
+    [(_ id:id [(_ . pat-args:expr) . body:expr] ...)
-     (raise-syntax-error 'define-cases "no cases given" (syntax->datum #'top-id))]
+     #'(define id
-    
-    ;; defective for syntax
-    [(_ (sid:syntaxed-id . _) . _)  ; (define (#'f1 stx) expr ...)
-     (raise-syntax-error 'define-cases "definition of a syntax transformer must use lambda notation, because otherwise it's too easy to confuse the compile-time shape and the run-time shape" (syntax->datum #'sid.name))]
-    
-    ;; syntax matcher
-    [(_ top-id:syntaxed-id . patexprs)
-     ;; todo: rephrase this check as a syntax-parse pattern above
-     (let ([all-but-last-pat-datums (map syntax->datum (syntax->list (syntax-case #'patexprs ()
-                                                                       [((pat result) ... last-one) #'(pat ...)])))])
-       (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))
-                        #'((pat result-expr) ... else-result-exprs)]
-                       [(((syntax 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)
-                                      (define result
-                                        (syntax-case stx LITERALS
-                                          [pat (syntax-parameterize ([caller-stx (make-rename-transformer #'stx)])
-                                                 (syntax-parameterize ([shared-syntax (make-shared-syntax-macro caller-stx)])
-                                                   . result-exprs))] ...
-                                          [else . else-result-exprs]))
-                                      (if (syntax? result)
-                                          result
-                                          (datum->syntax #'top-id.name result)))))]
-    
-    ;; function matcher
-    [(_ top-id:id [(_ . pat-args) . body] ...)
-     #'(define top-id
          (case-lambda
            [pat-args . body] ...
-           [else (raise-syntax-error 'define-cases "no matching case for argument pattern" (object-name top-id))]))]))
+           [rest-pat (apply raise-arity-error 'id (normalize-arity (map length '(pat-args ...))) rest-pat)]))]
+    [else (raise-syntax-error
+           'define-cases
+           "no matching case for calling pattern"
+           (syntax->datum stx))]))
 
 
 (module+ test
-  (require rackunit)
+  (define-cases f
-  (define foo-val 'got-foo-val)
+    [(_ arg) (add1 arg)]
-  (define (foo-func) 'got-foo-func)
+    [(_ arg1 arg2) (+ arg1 arg2)]
-  (br:define-cases #'op
+    [(_ . any) 'boing])
-                   [#'(_ "+") #''got-plus]
-                   [#'(_ _ARG) #''got-something-else]
-                   [#'(_) #'(foo-func)]
-                   [#'_ #'foo-val])
-  
-  (check-equal? (op "+") 'got-plus)
-  (check-equal? (op 42) 'got-something-else)
-  (check-equal? (op) 'got-foo-func)
-  (check-equal? op 'got-foo-val)
-  
-  (br:define-cases #'elseop
-                   [#'(_ _arg) #''got-arg]
-                   [else #''got-else])
-  
-  (check-equal? (elseop "+") 'got-arg)
-  (check-equal? (elseop "+" 42) 'got-else)
-  
- (check-exn exn:fail:syntax? (λ _ (expand-once #'(br:define-cases #'badelseop
-                                               [else #''got-else]
-                                               [#'(_ _arg) #''got-arg]))))
-  
-  (br:define-cases f
-                   [(_ arg) (add1 arg)]
-                   [(_ arg1 arg2) (+ arg1 arg2)])
-  
   (check-equal? (f 42) 43)
   (check-equal? (f 42 5) 47)
+  (check-equal? (f 42 5 'zonk) 'boing)
 
-  (check-exn exn:fail:syntax? (λ _ (expand-once #'(br:define-cases (#'times stx stx2) #'*)))))
+  (define-cases f-one-arg
+    [(_ arg) (add1 arg)])
+  (check-exn exn:fail:contract:arity? (λ _ (f-one-arg 1 2 3))))
 
 
-
+(define-syntax-rule (debug-define-macro (ID . PAT-ARGS) BODY)
-
+  (define-macro (ID . PAT-ARGS)
-(define-syntax (br:define stx)
+    #`(begin
-  
+        (for-each displayln
-  ;;todo: share syntax classes
+                  (list
-  
+                   (format "input pattern = #'~a" '#,'(ID . PAT-ARGS))
-  (define-syntax-class syntaxed-id
+                   (format "output pattern = #'~a" (cadr '#,'BODY))
-    #:literals (syntax)
+                   (format "invoked as = ~a" (syntax->datum #'(ID . PAT-ARGS)))
-    #:description "id in syntaxed form"
+                   (format "expanded as = ~a" '#,(syntax->datum BODY))
-    (pattern (syntax name:id)))
+                   (format "evaluated as = ~a" #,BODY)))
-  
+        #,BODY)))
-  (define-syntax-class syntaxed-thing
-    #:literals (syntax)
-    #:description "some datum in syntaxed form"
-    (pattern (syntax thing:expr)))
-  
-  (syntax-parse stx
-    #:literals (syntax)
-    
-    ;; syntax
-    [(_ (syntax (id . pat-args)) . body) ; (define #'(foo arg) #'(+ arg arg))
-     #'(br:define-cases (syntax id) [(syntax (_ . pat-args)) . body])]
-    
-    [(_ sid:syntaxed-id sid2:syntaxed-id) ; (define #'f1 #'f2)
-     #'(define-syntax sid.name (make-rename-transformer sid2))]
-    
-    [(_ (syntax id) (syntax thing)) ; (define #'f1 #'42)
-     #'(br:define-cases (syntax id) [#'_ (syntax thing)])]
-    
-    [(_ (sid:syntaxed-id stx-arg ...) . exprs)  ; (define (#'f1 stx) expr ...)
-     (raise-syntax-error 'define "definition of a syntax transformer must use lambda notation, because otherwise it's too easy to confuse the compile-time shape and the run-time shape" (syntax->datum #'sid.name))]
-    
-    [(_ sid:syntaxed-id (λ (stx-arg ...) . exprs)) ; (define #'f1 (λ(stx) expr ...)
-     #:fail-when (not (= (length (syntax->datum #'(stx-arg ...))) 1))
-     (raise-syntax-error 'define "did not get exactly one argument for macro" (syntax->datum #'(stx-arg ...)))
-     (with-syntax ([(first-stx-arg other ...) #'(stx-arg ...)])
-     #'(define-syntax (sid.name first-stx-arg) . exprs))]
-    
-    [(_ . args) #'(define . args)]))
-
-(module+ test
-  (require rackunit)
-  (br:define #'plus (λ(stx) #'+))
-  (check-equal? (plus 42) +)
-  (br:define #'plusser #'plus)
-  (check-equal? (plusser 42) +)
-  (check-equal? plusser +)
-  (br:define #'(times [nested _ARG]) #'(* _ARG _ARG))
-  (check-equal? (times [nested 10]) 100)
-  (br:define #'timeser #'times)
-  (check-equal? (timeser [nested 12]) 144)
-  (br:define #'fortytwo #'42)
-  (check-equal? fortytwo 42)
-  (check-equal? (let ()
-                  (br:define #'(foo _X)
-                             (with-syntax ([zam +])
-                               #'(zam _X _X))) (foo 42)) 84) 
-  (check-exn exn:fail:syntax? (λ _ (expand-once #'(br:define (#'times stx stx2) #'*))))
-  (begin
-    (br:define #'(redefine _id) #'(define _id 42))
-    (redefine zoombar)
-    (check-equal? zoombar 42))
-  
-  ;; use caller-stx parameter to introduce identifier unhygienically
-  (br:define #'(zam _arg1 _arg2 _arg3)
-             (with-syntax ([dz (datum->syntax caller-stx 'dirty-zam)])
-               #`(define dz 'got-dirty-zam)))
-  
-  (zam 'this 'that 42)
-  (check-equal? dirty-zam 'got-dirty-zam))
-
-
-(define-syntax-rule (br:debug-define (syntax (id . pat-args)) body-exp)
-  (br:define #'(id . pat-args)
-             #`(begin
-                 (for-each displayln
-                           (list
-                            (format "input pattern = #'~a" '#,'(id . pat-args))
-                            (format "output pattern = #'~a" (cadr '#,'body-exp))
-                            (format "invoked as = ~a" (syntax->datum #'(id . pat-args)))
-                            (format "expanded as = ~a" '#,(syntax->datum body-exp))
-                            (format "evaluated as = ~a" #,body-exp)))
-                 #,body-exp)))
 
 
 (module+ test
   (require rackunit racket/port)
   (parameterize ([current-output-port (open-output-nowhere)])
     (check-equal? (let ()
-                    (br:debug-define #'(foo _X _Y _Z)
+                    (debug-define-macro (foo X Y Z)
-                                     #'(apply + (list _X _Y _Z)))
+                                        #'(apply + (list X Y Z)))
                     (foo 1 2 3)) 6)  
     (check-equal? (let ()
-                    (br:debug-define #'(foo _X ...) #'(apply * (list _X ...)))
+                    (debug-define-macro (foo X ...) #'(apply * (list X ...)))
                     (foo 10 11 12)) 1320)))
 
 
-
-(define-syntax-rule (br:define+provide . args)
-  (define+provide . args))
-
-
-(define-for-syntax (expand-macro mac)
-  (syntax-disarm (local-expand mac 'expression #f) #f))
-
-
-(define-syntax (br:define-inverting stx)
-  (syntax-case stx (syntax)
-    [(_ (syntax (_id . _pat-args)) . _syntaxexprs)
-     #'(br:define-cases-inverting (syntax _id)
-                                  [(syntax (_ . _pat-args)) . _syntaxexprs])]))
-
 (begin-for-syntax
   (begin-for-syntax
     (require (for-syntax racket/base))
-    (define-syntax (make-shared-syntax-macro stx)
+    (define-syntax-rule (make-shared-syntax-macro caller-stx)
-      (syntax-case stx ()
+      #'(syntax-rules stx
-        [(_ caller-stx)
+          [(_ form)
-         #'(λ(stx) (syntax-case stx ()
+           #'(datum->syntax caller-stx (if (syntax? form)
-                     [(_ form)
+                                           (syntax-e form)
-                      #'(datum->syntax caller-stx (if (syntax? form)
+                                           form))]))))
-                                                      (syntax-e form)
-                                                      form))]))]))))
 
-(define-syntax (br:define-cases-inverting stx)
+(module+ test
-  (syntax-case stx (syntax)
+  (define-macro (dirty-maker ARG)
-    [(_ (syntax _id) [(syntax _patarg) . _bodyexprs] ...)
+    (with-syntax ([dirty-bar (datum->syntax caller-stx 'dirty-bar)])
-     (with-syntax ([LITERALS (generate-literals #'(_patarg ...))])
+      #'(define dirty-bar (* ARG 2))))
-       #'(define-syntax (_id stx)
+  (dirty-maker 42)
-           (syntax-case stx ()
+  (check-equal? dirty-bar 84))
-             [(_id . rest)
+
-              (let ([expanded-stx (with-syntax ([expanded-macros (map expand-macro (syntax->list #'rest))])
+
-                                  #'(_id . expanded-macros))])
+(begin-for-syntax
-                (define result
+  (define-syntax-rule (with-shared-id (id ...) . body)
-                  (syntax-case expanded-stx LITERALS
+    (with-syntax ([id (datum->syntax caller-stx 'id)] ...)
-                    [_patarg (syntax-parameterize ([caller-stx (make-rename-transformer #'stx)])
+      . body)))
-                            (syntax-parameterize ([shared-syntax (make-shared-syntax-macro caller-stx)])
+
-                              . _bodyexprs))] ...
+
-                    [else (raise-syntax-error 'define-cases-inverting (format "no matching case for syntax pattern ~v" (syntax->datum stx)) (syntax->datum #'_id))]))
+;; `syntax-parse` classes shared by `define-macro` and `define-macro-cases`
-                (if (syntax? result)
+(begin-for-syntax
-                    result
+  (require syntax/parse)
-                    (datum->syntax #'_id result)))])))]))
+  (define-syntax-class syntaxed-id
+    #:literals (syntax quasisyntax)
+    #:description "id in syntaxed form"
+    (pattern ([~or syntax quasisyntax] name:id)))
+  
+  (define-syntax-class syntaxed-thing
+    #:literals (syntax quasisyntax)
+    #:description "some datum in syntaxed form"
+    (pattern ([~or syntax quasisyntax] thing:expr)))
+
+  (define-syntax-class else-clause
+    #:literals (else)
+    (pattern [else . body:expr]))
+
+  (define-syntax-class transformer-func
+    #:literals (lambda λ)
+    (pattern ([~or lambda λ] (arg:id) . body:expr))))
+
+
+(define-syntax (define-macro stx)
+  (syntax-parse stx
+    [(_ id:id stxed-id:syntaxed-id)
+     #'(define-syntax id (make-rename-transformer stxed-id))]
+    [(_ id:id func:transformer-func)
+     #'(define-syntax id func)]
+    [(_ id:id func-id:id)
+     #'(define-syntax id func-id)]
+    [(_ id:id stxed-thing:syntaxed-thing) 
+     #'(define-macro id (λ (stx) stxed-thing))]
+    [(_ (id:id . patargs:expr) . body:expr)
+     #'(define-macro-cases id [(id . patargs) (begin . body)])]
+    [else (raise-syntax-error
+           'define-macro
+           "no matching case for calling pattern"
+           (syntax->datum stx))]))
+
+
+(define-syntax (define-macro-cases stx)  
+  (syntax-parse stx
+    [(_ id:id)
+     (raise-syntax-error 'define-macro-cases "no cases given" (syntax->datum #'id))]
+    [(_ id:id leading-pat:expr ... else-pat:else-clause trailing-pat0:expr trailing-pat:expr ...)
+     (raise-syntax-error 'define-macro-cases "`else` clause must be last" (syntax->datum #'id))]
+    [(_ id:id (pat:expr . result-exprs:expr) ... else-clause:else-clause)
+     (with-syntax ([LITERALS (generate-literals #'(pat ...))])
+       #'(define-macro id
+           (λ (stx)
+             (define result
+               (syntax-parameterize ([caller-stx (make-rename-transformer #'stx)])
+                 (syntax-case stx LITERALS
+                   [pat . result-exprs] ...
+                   else-clause)))
+             (if (syntax? result)
+                 result
+                 (datum->syntax #'id result)))))]
+    [(_ id:id pat-clause:expr ...) ; macro without `else` clause will reach this branch
+     #'(define-macro-cases id
+         pat-clause ...
+         [else (raise-syntax-error
+                'id
+                "no matching case for calling pattern"
+                (syntax->datum caller-stx))])]
+    [else (raise-syntax-error
+           'define-macro-cases
+           "no matching case for calling pattern"
+           (syntax->datum stx))]))
 
 
 (module+ test
-  ;; an inverting macro expands its arguments.
+  (define-macro plus (λ(stx) #'+))
-  ;; so `foo` does not get `(falsy a) (falsy b) (falsy c)` as arguments,
+  (check-equal? (plus 42) +)
-  ;; but rather the result of their expansion, namely `((#f a) (#f b) (#f c))`
+  (define-macro plusser #'plus)
-  ;; and `tree` does not get `(foo (#f a) (#f b) (#f c))` as its first argument,
+  (check-equal? (plusser 42) +)
-  ;; but rather the result of its expansion, namely (a b c).
+  (check-equal? plusser +)
-  (br:define-inverting #'(tree (_id ...) _vals)
+  (define-macro (times [nested ARG]) #`(* ARG ARG))
-                       #'(let ()
+  (check-equal? (times [nested 10]) 100)
-                           (define-values (_id ...) _vals)
+  (define-macro timeser #'times)
-                           (list _id ...)))
+  (check-equal? (timeser [nested 12]) 144)
+  (define-macro fortytwo #`42)
+  (check-equal? fortytwo 42)
+  (check-equal? (let ()
+                  (define-macro (foo X)
+                    (with-syntax ([zam +])
+                      #'(zam X X))) (foo 42)) 84) 
+  (begin
+    (define-macro (redefine ID) #'(define ID 42))
+    (redefine zoombar)
+    (check-equal? zoombar 42))
   
-  (br:define-cases-inverting #'foo
+  ;; use caller-stx parameter to introduce identifier unhygienically
-                             [#'(_ (#f _id) ...) #'(_id ...)])
+  (define-macro (zam ARG1 ARG2 ARG3)
+    (with-syntax ([dz (datum->syntax caller-stx 'dirty-zam)])
+      #`(define dz 'got-dirty-zam)))
   
-  (define-syntax-rule (falsy id) (#f id))
+  (zam 'this 'that 42)
+  (check-equal? dirty-zam 'got-dirty-zam)
   
-  (check-equal? (tree (foo (falsy a) (falsy b) (falsy c)) (values 1 2 3)) '(1 2 3)))
+  (define-macro (add X) #'(+ X X))
+  (check-equal? (add 5) 10)
+  (define-macro-cases add-again [(_ X) #'(+ X X)])
+  (check-equal? (add-again 5) 10)
+  (define-macro-cases add-3rd [(_ X) #'(+ X X)])
+  (check-equal? (add-3rd 5) 10)
+  (define-macro add-4th #'add-3rd)
+  (check-equal? (add-4th 5) 10)
+  (define foo-val 'got-foo-val)
+  (define (foo-func) 'got-foo-func)
+  (define-macro-cases op
+    [(_ "+") #''got-plus]
+    [(_ ARG) #''got-something-else]
+    [(_) #'(foo-func)]
+    [_ #'foo-val])
+  
+  (check-equal? (op "+") 'got-plus)
+  (check-equal? (op 42) 'got-something-else)
+  (check-equal? (op) 'got-foo-func)
+  (check-equal? op 'got-foo-val)
+  
+  (define-macro-cases elseop
+    [(_ ARG) #''got-arg]
+    [else #''got-else])
+  
+  (check-equal? (elseop "+") 'got-arg)
+  (check-equal? (elseop "+" 42) 'got-else)
+
+  (check-exn exn:fail:syntax? (λ _ (expand-once #'(define-macro-cases no-cases))))
+
+  (check-exn exn:fail:syntax? (λ _ (expand-once #'(define-macro-cases badelseop
+                                                    [else #''got-else]
+                                                    [(_ _arg) #''got-arg]))))
+
+  (define-macro-cases no-else-macro
+    [(_ ARG) #''got-arg])
+  (check-exn exn:fail:syntax? (λ _ (expand-once #'(no-else-macro 'arg1 'arg2)))))

beautiful-racket-lib/br/eopl.rkt

@@ -1,97 +0,0 @@
-#lang br
-(require racket/struct (for-syntax br/datum))
-(provide define-datatype cases occurs-free?)
-
-#;(begin
-    (struct lc-exp () #:transparent)
-    
-    (struct var-exp lc-exp (var) #:transparent
-      #:guard (λ(var name)
-                (unless (symbol? var)
-                  (error name (format "arg ~a not ~a" var 'symbol?)))
-                (values var)))
-    
-    (struct lambda-exp lc-exp (bound-var body) #:transparent
-      #:guard (λ(bound-var body name)
-                (unless (symbol? bound-var)
-                  (error name (format "arg ~a not ~a" bound-var 'symbol?)))
-                (unless (lc-exp? body)
-                  (error name (format "arg ~a not ~a" body 'lc-exp?)))
-                (values bound-var body)))
-    
-    (struct app-exp lc-exp (rator rand) #:transparent
-      #:guard (λ(rator rand name)
-                (unless (lc-exp? rator)
-                  (error name (format "arg ~a not ~a" rator 'lc-exp?)))
-                (unless (lc-exp? rand)
-                  (error name (format "arg ~a not ~a" rand 'lc-exp?)))
-                (values rator rand))))
-
-
-(define #'(define-datatype _base-type _base-type-predicate?
-            (_subtype [_field _field-predicate?] ...) ...)
-  #'(begin
-      (struct _base-type () #:transparent #:mutable)
-      (struct _subtype _base-type (_field ...) #:transparent #:mutable
-        #:guard (λ(_field ... name)
-                  (unless (_field-predicate? _field)
-                    (error name (format "arg ~a is not ~a" _field '_field-predicate?))) ...
-                  (values _field ...))) ...))
-
-
-(define-datatype lc-exp lc-exp?
-  (var-exp [var symbol?])
-  (lambda-exp [bound-var symbol?] [body lc-exp?])
-  (app-exp [rator lc-exp?] [rand lc-exp?]))
-
-
-#;(define (occurs-free? search-var exp)
-    (cond
-      [(var-exp? exp) (let ([var (var-exp-var exp)])
-                        (eqv? var  search-var))]
-      [(lambda-exp? exp) (let ([bound-var (lambda-exp-bound-var exp)]
-                               [body (lambda-exp-body exp)])
-                           (and (not (eqv? search-var bound-var))
-                                (occurs-free? search-var body)))]
-      [(app-exp? exp) (let ([rator (app-exp-rator exp)]
-                            [rand (app-exp-rand exp)])
-                        (or
-                         (occurs-free? search-var rator)
-                         (occurs-free? search-var rand)))]))
-
-(define-syntax (cases stx)
-  (syntax-case stx (else)
-    [(_ <base-type> <input-var>
-        [<subtype> (<positional-var> ...) <body> ...] ...
-        [else <else-body> ...])
-     (inject-syntax ([#'(<subtype?> ...) (map-syntax (λ(s) (format-datum '~a? s)) #'(<subtype> ...))])
-                    #'(cond
-                        [(<subtype?> <input-var>) (match-let ([(list <positional-var> ...) (struct->list <input-var>)])
-                                                    <body> ...)] ...
-                                                                 [else <else-body> ...]))]
-    [(_ <base-type> <input-var>
-        <subtype-case> ...)
-     #'(cases <base-type> <input-var>
-         <subtype-case> ...
-         [else (void)])]))
-
-
-(define (occurs-free? search-var exp)
-  (cases lc-exp exp
-    [var-exp (var) (eqv? var search-var)]
-    [lambda-exp (bound-var body)
-                (and (not (eqv? search-var bound-var))
-                     (occurs-free? search-var body))]
-    [app-exp (rator rand)
-             (or
-              (occurs-free? search-var rator)
-              (occurs-free? search-var rand))]))
-
-
-(module+ test
-  (require rackunit)
-  (check-true (occurs-free? 'foo (var-exp 'foo)))
-  (check-false (occurs-free? 'foo (var-exp 'bar)))
-  (check-false (occurs-free? 'foo (lambda-exp 'foo (var-exp 'bar))))
-  (check-true (occurs-free? 'foo (lambda-exp 'bar (var-exp 'foo))))
-  (check-true (occurs-free? 'foo (lambda-exp 'bar (lambda-exp 'zim (lambda-exp 'zam (var-exp 'foo)))))))

beautiful-racket-lib/br/experimental/eopl.rkt

@@ -0,0 +1,73 @@
+#lang br
+(require racket/struct (for-syntax br/datum))
+(provide define-datatype cases occurs-free?)
+
+(define-macro (define-datatype BASE-TYPE BASE-TYPE-PREDICATE?
+                (SUBTYPE [FIELD FIELD-PREDICATE?] ...) ...)
+  #'(begin
+      (struct BASE-TYPE () #:transparent #:mutable)
+      (struct SUBTYPE BASE-TYPE (FIELD ...) #:transparent #:mutable
+        #:guard (λ(FIELD ... name)
+                  (unless (FIELD-PREDICATE? FIELD)
+                    (error name (format "arg ~a is not ~a" FIELD 'FIELD-PREDICATE?))) ...
+                  (values FIELD ...))) ...))
+
+
+(define-datatype lc-exp lc-exp?
+  (var-exp [var symbol?])
+  (lambda-exp [bound-var symbol?] [body lc-exp?])
+  (app-exp [rator lc-exp?] [rand lc-exp?]))
+
+
+#;(define-syntax (cases stx)
+    (syntax-case stx (else)
+      [(_ _base-type INPUT-VAR
+          [SUBTYPE (POSITIONAL-VAR ...) . _body] ...
+          [else . _else-body])
+       (inject-syntax ([#'(_subtype? ...) (suffix-id #'(SUBTYPE ...) "?")])
+                      #'(cond
+                          [(_subtype? INPUT-VAR) (match-let ([(list POSITIONAL-VAR ...) (struct->list INPUT-VAR)])
+                                                   . _body)] ...
+                                                             [else . _else-body]))]
+      [(_ _base-type INPUT-VAR
+          SUBTYPE-CASE ...)
+       #'(cases _base-type INPUT-VAR
+           SUBTYPE-CASE ...
+           [else (void)])]))
+
+
+(define-macro-cases cases
+  [(_ BASE-TYPE INPUT-VAR
+      [SUBTYPE (POSITIONAL-VAR ...) . BODY] ...
+      [else . ELSE-BODY])
+   (with-syntax ([(SUBTYPE? ...) (suffix-id #'(SUBTYPE ...) "?")])
+     #'(cond
+         [(SUBTYPE? INPUT-VAR) (match-let ([(list POSITIONAL-VAR ...) (struct->list INPUT-VAR)])
+                                 . BODY)] ...
+                                          [else . ELSE-BODY]))]
+  [(_ BASE-TYPE INPUT-VAR
+      SUBTYPE-CASE ...)
+   #'(cases BASE-TYPE INPUT-VAR
+       SUBTYPE-CASE ...
+       [else (void)])])
+
+
+(define (occurs-free? search-var exp)
+  (cases lc-exp exp
+    [var-exp (var) (eqv? var search-var)]
+    [lambda-exp (bound-var body)
+                (and (not (eqv? search-var bound-var))
+                     (occurs-free? search-var body))]
+    [app-exp (rator rand)
+             (or
+              (occurs-free? search-var rator)
+              (occurs-free? search-var rand))]))
+
+
+(module+ test
+  (require rackunit)
+  (check-true (occurs-free? 'foo (var-exp 'foo)))
+  (check-false (occurs-free? 'foo (var-exp 'bar)))
+  (check-false (occurs-free? 'foo (lambda-exp 'foo (var-exp 'bar))))
+  (check-true (occurs-free? 'foo (lambda-exp 'bar (var-exp 'foo))))
+  (check-true (occurs-free? 'foo (lambda-exp 'bar (lambda-exp 'zim (lambda-exp 'zam (var-exp 'foo)))))))

beautiful-racket-lib/br/experimental/scope.rkt

@@ -0,0 +1,127 @@
+#lang racket/base
+(require (for-syntax racket/base br/syntax racket/syntax) syntax/strip-context racket/function)
+(provide (all-defined-out))
+
+(define (->syntax x)
+  (if (syntax? x) x (datum->syntax #f x)))
+
+
+(define (context stx)
+  (hash-ref (syntax-debug-info stx) 'context))
+
+(define-syntax-rule (scopes stx)
+  (format "~a = ~a" 'stx
+          (cons (syntax->datum stx)
+                (for/list ([scope (in-list (context stx))])
+                          scope))))
+
+(define (syntax-find stx stx-or-datum)
+  (unless (syntax? stx)
+    (raise-argument-error 'syntax-find "not given syntax object as first argument" stx))
+  (define datum
+    (cond [(syntax? stx-or-datum) (syntax->datum stx-or-datum)]
+          [(symbol? stx-or-datum) stx-or-datum]
+          [else (raise-argument-error 'syntax-find "not given syntax or datum as second argument" stx-or-datum)]))
+  (let/ec exit
+    (let loop ([so stx])
+      (cond
+        [(eq? (syntax->datum so) datum) (exit so)]
+        [(syntax->list so) => (curry map loop)]))))
+
+(define-syntax (define-scope stx)
+  (syntax-case stx ()
+    [(_ id)
+     #'(define-scope id ())]
+    [(_ id scope-ids)
+     (with-syntax ([id-sis (suffix-id #'id "-sis")]
+                   [add-id (prefix-id "add-" #'id)]
+                   [flip-id (prefix-id "flip-" #'id)]
+                   [id-binding-form (suffix-id #'id "-binding-form")]
+                   [define-id (prefix-id "define-" #'id)]
+                   [with-id-identifiers (infix-id "with-" #'id "-identifiers")]
+                   [let-id-syntax (infix-id "let-" #'id "-syntax")]
+                   [with-id-binding-form (infix-id "with-" #'id "-binding-form")]
+                   [remove-id (prefix-id "remove-" #'id)]
+                   [id? (suffix-id #'id "?")]
+                   [id* (suffix-id #'id "*")]
+                   [(scope-id-sis ...) (suffix-id #'scope-ids "-sis")])
+       #'(begin
+           (define id-sis
+             (let ([sis-in (list scope-id-sis ...)])
+               (if (pair? sis-in)
+                   (apply append sis-in)
+                   (list
+                    (let ([si (make-syntax-introducer #t)])
+                      (list (procedure-rename (curryr si 'add) 'add-id)
+                            (procedure-rename (curryr si 'flip) 'flip-id)
+                            (procedure-rename (curryr si 'remove) 'remove-id)))))))
+           (define add-id (λ(x) ((apply compose1 (map car id-sis)) (->syntax x))))
+           (define flip-id (λ(x) ((apply compose1 (map cadr id-sis)) (->syntax x))))
+           (define remove-id (λ(x) ((apply compose1 (map caddr id-sis)) (->syntax x))))
+           (define (id x) (add-id (datum->syntax #f (syntax-e (->syntax x)))))
+           (define (id-binding-form x) (syntax-local-introduce (id x)))
+           (define (id* x) (replace-context (add-id (datum->syntax #f '_)) (->syntax x)))
+           (define (id? x)
+             (and
+              (member (car (context (add-id (datum->syntax #f '_))))
+                      (context (->syntax x)))
+              #t))
+           (define-syntax-rule (with-id-identifiers (name (... ...)) . body)
+             (with-syntax ([name (id* 'name)] (... ...)) . body))
+           (define-syntax-rule (with-id-binding-form  (name (... ...)) . body)
+             (with-syntax ([name (id-binding-form 'name)] (... ...)) . body))
+           (define-syntax-rule (let-id-syntax ([pat val] (... ...)) . body)
+             (let-syntax ([pat (id* val)] (... ...)) . body))))]))
+
+(define (scopes-equal? stxl stxr)
+  ;; "A bound-identifier=? comparison checks that two identifiers have exactly the same scope sets"
+  (bound-identifier=? (datum->syntax stxl '_) (datum->syntax stxr '_)))
+
+
+(module+ test
+  (require rackunit)
+  (define-scope red)
+  
+  (define stx (datum->syntax #f 'x))
+  
+  (define red-stx (add-red stx))
+  (define double-red-stx (add-red (add-red stx)))
+  
+  
+  (check-false (red? stx))
+  (check-true (red? red-stx))
+  (check-true (red? double-red-stx))
+  (check-false (scopes-equal? stx red-stx))
+  (check-true (scopes-equal? red-stx double-red-stx))
+  (check-false (scopes-equal? red-stx (remove-red double-red-stx)))
+  
+  
+  (define-scope blue) ; scope addition is commutative
+  (define blue-stx (blue stx))
+  (check-true (scopes-equal? (add-blue red-stx) (add-red blue-stx)))
+  (check-true (scopes-equal? (remove-red (add-blue red-stx)) (remove-red (add-red blue-stx))))
+  
+  
+  (define-scope green) ; replace scopes at outer layer
+  (check-true (scopes-equal? (green red-stx) (green blue-stx)))
+  
+  
+  ;; replace scopes everywhere
+  (check-true (scopes-equal? (car (syntax->list (green* #`(#,blue-stx #,red-stx))))
+                             (car (syntax->list (green* #`(#,red-stx #,blue-stx))))))
+  
+  ;; todo: test flipping
+  
+  
+  (define-scope purple (red blue))
+  
+  (check-true (purple? (add-purple stx)))
+  (check-true (scopes-equal? (purple (green stx)) (add-blue (remove-green (add-red (add-green (add-blue stx))))))))
+
+
+(define-syntax (with-scopes stx)
+  (syntax-case stx (syntax)
+    [(_ (scope-id) (syntax expr))
+     (with-syntax ([add-scope-id (format-id #'scope-id "add-~a" #'scope-id)])
+       #'(add-scope-id expr))]))
+

beautiful-racket-lib/br/get-info.rkt

@@ -0,0 +1,19 @@
+#lang racket
+(provide (all-defined-out))
+
+(require racket/class)
+(define (indenter t pos)
+  (with-handlers ([exn:fail? (λ(exn) #f)]) ; this function won't work until gui-lib 1.26
+    (send t compute-racket-amount-to-indent pos (λ(x)
+                                                  (case x
+                                                    [("with-pattern" "with-shared-id") 'lambda]
+                                                    [("define-macro") 'define]
+                                                    [else #f])))))
+
+(define (br-get-info key default default-filter)
+  (case key
+    #;[(color-lexer)
+       (dynamic-require 'syntax-color/default-lexer 'default-lexer)]
+    [(drracket:indentation) indenter]
+    [else
+     (default-filter key default)]))

beautiful-racket-lib/br/main.rkt

@@ -1,26 +1,22 @@
 #lang racket/base
 (require racket/provide racket/list racket/string racket/format racket/match racket/port
-         br/define br/syntax br/datum br/debug br/conditional
+         br/define br/syntax br/datum br/debug br/cond racket/function
          (for-syntax racket/base racket/syntax br/syntax br/debug br/define))
-(provide (except-out (all-from-out racket/base) define)
+(provide (all-from-out racket/base)
          (all-from-out racket/list racket/string racket/format racket/match racket/port
-                       br/syntax br/datum br/debug br/conditional)
+                       br/syntax br/datum br/debug br/cond racket/function br/define)
          (for-syntax (all-from-out racket/base racket/syntax br/syntax br/debug))
-         (for-syntax caller-stx shared-syntax) ; from br/define
+         (for-syntax caller-stx with-shared-id)) ; from br/define
-         (filtered-out
-          (λ (name)
-            (let ([pat (regexp "^br:")])
-              (and (regexp-match? pat name)
-                   (regexp-replace pat name ""))))
-          (combine-out (all-from-out br/define))))
          
 ;; todo: activate at-exp reader by default
 
-(define (remove-blank-lines strs)
+(provide evaluate)
-  (filter (λ(str) (regexp-match #px"\\S" str)) strs))
+(define-macro (evaluate DATUM)
-
+  #'(begin
-(provide remove-blank-lines)
+      (define-namespace-anchor nsa)
-
+      (eval DATUM (namespace-anchor->namespace nsa))))
 
 (module reader syntax/module-reader
-  #:language 'br)
+  #:language 'br
+  #:info br-get-info
+  (require br/get-info))

beautiful-racket-lib/br/private/syntax-flatten.rkt

@@ -0,0 +1,12 @@
+#lang racket/base
+(require racket/list)
+(provide (all-defined-out))
+
+(define (syntax-flatten stx)
+  (flatten
+   (let loop ([stx stx])
+     (let* ([stx-unwrapped (syntax-e stx)]
+            [maybe-pair (and (pair? stx-unwrapped) (flatten stx-unwrapped))])
+       (if maybe-pair
+           (map loop maybe-pair)
+           stx)))))

beautiful-racket-lib/br/quicklang.rkt

@@ -0,0 +1,31 @@
+#lang br
+(require (for-syntax racket/list sugar/debug))
+(provide (except-out (all-from-out br) #%module-begin)
+         (rename-out [quicklang-mb #%module-begin]))
+
+(define-macro (quicklang-mb . EXPRS)
+  (define-values
+    (kw-pairs other-exprs)
+    (let loop ([kw-pairs null][exprs (syntax->list #'EXPRS)])
+      (if (and (pair? exprs) (keyword? (syntax-e (car exprs))))
+          (loop (cons (cons (string->symbol (keyword->string (syntax-e (car exprs))))
+                            (cadr exprs)) ; leave val in stx form so local binding is preserved
+                      kw-pairs)
+                (cddr exprs))
+          (values kw-pairs exprs))))
+  (define reserved-keywords '(provide))
+  (define (reserved? kw-pair) (memq (car kw-pair) reserved-keywords))
+  (define-values (reserved-kwpairs other-kwpairs) (partition reserved? kw-pairs))
+  (with-pattern ([((KW . VAL) ...) other-kwpairs]
+                 [(PROVIDED-ID ...) (or (assq 'provide reserved-kwpairs) null)])
+    #`(#%module-begin
+       (provide PROVIDED-ID ...)
+       (provide (rename-out [VAL KW]) ...)
+       (provide #%top #%app #%datum #%top-interaction)
+       . #,(datum->syntax #'EXPRS other-exprs #'EXPRS))))
+
+
+(module reader syntax/module-reader
+  #:language 'br/quicklang
+  #:info br-get-info
+  (require br/get-info))

beautiful-racket-lib/br/reader-utils.rkt

@@ -1,43 +1,41 @@
 #lang racket/base
-(require (for-syntax racket/base racket/syntax) syntax/strip-context)
+(require (for-syntax racket/base racket/syntax br/syntax) br/define syntax/strip-context)
 (provide define-read-and-read-syntax)
 
 ;; `define-read-functions` simplifies support for the standard reading API,
 ;; which asks for `read` and `read-syntax`.
 ;; in general, `read` is just the datum from the result of `read-syntax`.
 
-(define-syntax (define-read-and-read-syntax calling-site-stx)
+(define-macro (define-read-and-read-syntax (PATH PORT) BODY ...)
-  (syntax-case calling-site-stx ()
+  (let ([internal-prefix (gensym)])
-    [(_ (PATH PORT) BODY ...)
+    (with-syntax ([READ (datum->syntax caller-stx 'read)]
-     (let ([internal-prefix (gensym)])
+                  [READ-SYNTAX (datum->syntax caller-stx 'read-syntax)]
-       (with-syntax ([READ (datum->syntax calling-site-stx 'read)]
+                  ;; use prefixed names to prevent namespace collisions with possibly existing `read` & `read-syntax`
-                     [READ-SYNTAX (datum->syntax calling-site-stx 'read-syntax)]
+                  [INTERNAL-READ (format-id #'here "~a-~a" internal-prefix 'read)]
-                     ;; use prefixed names to prevent namespace collisions with possibly existing `read` & `read-syntax`
+                  [INTERNAL-READ-SYNTAX (format-id #'here "~a-~a" internal-prefix 'read-syntax)])
-                     [INTERNAL-READ (format-id #'here "~a-~a" internal-prefix 'read)]
+      #'(begin           
-                     [INTERNAL-READ-SYNTAX (format-id #'here "~a-~a" internal-prefix 'read-syntax)])
+          (provide (rename-out [INTERNAL-READ READ]
-         #'(begin           
+                               [INTERNAL-READ-SYNTAX READ-SYNTAX]))
-             (provide (rename-out [INTERNAL-READ READ]
+          (define (calling-site-function PATH PORT)
-                                  [INTERNAL-READ-SYNTAX READ-SYNTAX]))
+            BODY ...) ; don't care whether this produces datum or syntax
-             (define (calling-site-function PATH PORT)
-               BODY ...) ; don't care whether this produces datum or syntax
              
-             (define INTERNAL-READ-SYNTAX
+          (define INTERNAL-READ-SYNTAX
-               (procedure-rename (λ (path port) ; rename proc so it looks right in the REPL (otherwise retains internal prefix name)
+            (procedure-rename (λ (path port) ; rename proc so it looks right in the REPL (otherwise retains internal prefix name)
-                                   ;; because `read-syntax` must produce syntax
+                                ;; because `read-syntax` must produce syntax
-                                   ;; coerce a datum result to syntax if needed (à la `with-syntax`)
+                                ;; coerce a datum result to syntax if needed (à la `with-syntax`)
-                                   (define result-syntax (let ([output (calling-site-function path port)])
+                                (define result-syntax (let ([output (calling-site-function path port)])
-                                                           (if (syntax? output)
+                                                        (if (syntax? output)
-                                                               output 
+                                                            output 
-                                                               (datum->syntax #f output))))
+                                                            (datum->syntax #f output))))
-                                   ;; because `read-syntax` must produce syntax without context
+                                ;; because `read-syntax` must produce syntax without context
-                                   ;; see http://docs.racket-lang.org/guide/hash-lang_reader.html
+                                ;; see http://docs.racket-lang.org/guide/hash-lang_reader.html
-                                   ;; "a `read-syntax` function should return a syntax object with no lexical context"
+                                ;; "a `read-syntax` function should return a syntax object with no lexical context"
-                                   (strip-context result-syntax)) 'READ-SYNTAX)) 
+                                (strip-context result-syntax)) 'READ-SYNTAX)) 
              
-             (define INTERNAL-READ
+          (define INTERNAL-READ
-               (procedure-rename (λ (port)
+            (procedure-rename (λ (port)
-                                   ; because `read` must produce a datum
+                                ; because `read` must produce a datum
-                                   (let ([output (calling-site-function #f port)])
+                                (let ([output (calling-site-function #f port)])
-                                     (if (syntax? output)
+                                  (if (syntax? output)
-                                         (syntax->datum output)
+                                      (syntax->datum output)
-                                         output))) 'READ)))))]))
+                                      output))) 'READ))))))

beautiful-racket-lib/br/scribblings/br.scrbl

@@ -1,65 +1,417 @@
 #lang scribble/manual
-@(require (for-label br/conditional))
+@(require (for-label racket/base racket/contract br))
+
+@(require scribble/eval)
+
+@(define my-eval (make-base-eval))
+@(my-eval `(require br racket/stxparam))
+
 
 @title[#:style 'toc]{Beautiful Racket}
 
 @author[(author+email "Matthew Butterick" "mb@mbtype.com")]
 
 
-Beautiful Racket @link["http://beautifulracket.com"]{is a book} about making programming languages with Racket.
+
+@link["http://beautifulracket.com"]{@italic{Beautiful Racket}} is a book about making programming languages with Racket.
 
 This library provides the @tt{#lang br} teaching language used in the book, as well as supporting modules that can be used in other programs.
 
+This library is designed to smooth over some of the small idiosyncrasies and inconsistencies in Racket, so that those new to Racket are more likely to say ``ah, that makes sense'' rather than ``huh? what?''
 
-@;defmodulelang[br]
+@;{
+@section{The @tt{br} language(s)}
 
-@tt{#lang br} is a teaching language designed to smooth over some of the small idiosyncrasies and inconsistencies in Racket, so that those new to Racket will say ``ah, that makes sense'' rather than ``huh? what?'' @tt{#lang br} is not meant to hide the true nature of Racket, but rather defer certain parts of the learning curve.
+@defmodulelang[br]
+
+
+@defmodulelang[br/quicklang]
+}
 
-To that end, this documentation not only explains the functions and forms in the Beautiful Racket library, but also how they depart from traditional or idiomatic Racket. (BTW ``Beautiful Racket'' is the name of the book, not an implication that the rest of Racket is less than beautiful. It is! But one thing at a time.)
 
 @section{Conditionals}
 
-@defmodule[br/conditional]
+@defmodule[br/cond]
 
-@defform[(while cond body ...)]
+@defform[(while cond body ...)]{
-Loop over @racket[_body] expressions as long as @racket[_cond] is not @racket[#f]. If @racket[_cond] starts out @racket[#f], @racket[_body] expressions are not evaluated.
+Loop over @racket[body] as long as @racket[cond] is not @racket[#f]. If @racket[cond] starts out @racket[#f], @racket[body] is never evaluated.
 
-@defform[(until cond body ...)]
+@examples[#:eval my-eval
-Loop over @racket[_body] expressions until @racket[_cond] is not @racket[#f]. If @racket[_cond] starts out @racket[#f], @racket[_body] expressions are not evaluated.
+(let ([x 42])
+  (while (positive? x)
+         (set! x (- x 1)))
+  x)
+(let ([x 42])
+  (while (negative? x)
+         (unleash-zombie-army))
+  x)
+]
+}
 
+@defform[(until cond body ...)]{
+Loop over @racket[body] until @racket[cond] is not @racket[#f]. If @racket[cond] starts out not @racket[#f], @racket[body] is never evaluated.
+
+@examples[#:eval my-eval
+(let ([x 42])
+  (until (zero? x)
+         (set! x (- x 1)))
+  x)
+(let ([x 42])
+  (until (= 42 x)
+         (destroy-galaxy))
+  x)
+]
+}
 
 @section{Datums}
 
 @defmodule[br/datum]
 
+A @defterm{datum} is a literal representation of a single unit of Racket code, also known as an @defterm{S-expression}. Unlike a string, a datum preserves the internal structure of the S-expression. Meaning, if the S-expression is a single value, or list-shaped, or tree-shaped, so is its corresponding datum. 
+
+Datums are made with @racket[quote] or its equivalent notation, the @litchar{'} prefix (see @secref["quote" #:doc '(lib "scribblings/guide/guide.scrbl")]).
+
+When I use ``datum'' in its specific Racket sense, I use ``datums'' as its plural rather than ``data'' because that term has an existing, more generic meaning. 
+
 @defproc[
 (format-datum
-[datum-template symbol?]
+[datum-form (or/c list? symbol?)]
-[arg any/c?] ...)
+[val any/c?] ...)
-datum?]
+(or/c list? symbol?)]{
-tk
+Similar to @racket[format], but the template @racket[datum-form] is a datum, rather than a string, and the function returns a datum, rather than a string. Otherwise, the same formatting escapes can be used in the template (see @racket[fprintf]).
+
+Two special cases. First, a string that describes a list of datums is parenthesized so the result is a single datum. Second, an empty string returns @racket[void] (not @racket[#f], because that's a legitimate datum).
+
+@examples[#:eval my-eval
+(format-datum '42)
+(format-datum '~a "foo")
+(format-datum '(~a ~a) "foo" 42)
+(format-datum '~a "foo bar zam")
+(void? (format-datum '~a ""))
+(format-datum '~a #f)
+]
+}
+
+@defproc[
+(format-datums
+[datum-form (or/c list? symbol?)]
+[vals (listof any/c?)] ...)
+(listof (or/c list? symbol?))]{
+Like @racket[format-datum], but applies @racket[datum-form] to the lists of @racket[vals] in similar way to @racket[map], where values for the format string are taken from the lists of @racket[vals] in parallel. This means that a) @racket[datum-form] must accept as many arguments as there are lists of @racket[vals], and b) the lists of @racket[vals] must all have the same number of items.
+
+@examples[#:eval my-eval
+(format-datums '~a '("foo" "bar" "zam"))
+(format-datums '(~a 42) '("foo" "bar" "zam"))
+(format-datums '(~a ~a) '("foo" "bar" "zam") '(42 43 44))
+(format-datums '42 '("foo" "bar" "zam"))
+(format-datums '(~a ~a) '("foo" "bar" "zam") '(42))
+]
+}
 
 
 @section{Debugging}
 
 @defmodule[br/debug]
 
-TK
+
+@defform*[[
+(report expr) 
+(report expr maybe-name)
+]]{
+Print the name and value of @racket[expr] to @racket[current-error-port], but also return the evaluated result of @racket[expr] as usual. This lets you see the value of an expression or variable at runtime without disrupting any of the surrounding code. Optionally, you can use @racket[maybe-name] to change the name shown in @racket[current-error-port].
+
+For instance, suppose you wanted to see how @racket[first-condition?] was being evaluted in this expression:
+
+@racketblock[
+(if (and (first-condition? x) (second-condition? x))
+  (one-thing)
+  (other-thing))]
+
+You can wrap it in @racket[report] and find out:
+
+@racketblock[
+(if (and (report (first-condition? x)) (second-condition? x))
+  (one-thing)
+  (other-thing))]
+
+This code will run the same way as before. But when it reaches @racket[first-condition?], you willl see in @racket[current-error-port]:
+
+@racketerror{(first-condition? x) = #t}
+
+You can also add standalone calls to @racket[report] as a debugging aid at points where the return value will be irrelevant, for instance:
+
+@racketblock[
+(report x x-before-function)
+(if (and (report (first-condition? x)) (second-condition? x))
+  (one-thing)
+  (other-thing))]
+
+@racketerror{x-before-function = 42
+@(linebreak)(first-condition? x) = #t}
+
+But be careful — in the example below, the result of the @racket[if] expression will be skipped in favor of the last expression, which will be the value of @racket[x]:
+
+@racketblock[
+(if (and (report (first-condition? x)) (second-condition? x))
+  (one-thing)
+  (other-thing))
+  (report x)]
+
+
+@defform[(report* expr ...)]
+Apply @racket[report] separately to each @racket[expr] in the list.
+
+
+@defform*[((report-datum stx-expr) (report-datum stx-expr maybe-name))]
+A variant of @racket[report] for use with @secref["stx-obj" #:doc '(lib "scribblings/guide/guide.scrbl")]. Rather than print the whole object (as @racket[report] would), @racket[report-datum] prints only the datum inside the syntax object, but the return value is the whole syntax object.
+}
 
 @section{Define}
 
 @defmodule[br/define]
 
-TK
+@defform[
+(define-cases id 
+  [pat body ...+] ...+)
+]
+Define a function that behaves differently depending on how many arguments are supplied (also known as @seclink["Evaluation_Order_and_Arity" #:doc '(lib "scribblings/guide/guide.scrbl")]{@italic{arity}}). Like @racket[cond], you can have any number of branches. Each branch starts with a @racket[_pat] that accepts a certain number of arguments. If the current invocation of the function matches the number of arguments in @racket[_pat], then the @racket[_body] on the right-hand side is evaluated. If there is no matching case, an arity error arises. (Derived from @racket[case-lambda], whose notation you might prefer.)
+
+@examples[#:eval my-eval
+(define-cases f
+  [(f arg1) (* arg1 arg1)]
+  [(f arg1 arg2) (* arg1 arg2)]
+  [(f arg1 arg2 arg3 arg4) (* arg1 arg2 arg3 arg4)])
+
+(f 4)
+(f 6 7)
+(f 1 2 3 4)
+(f "three" "arguments" "will-trigger-an-error")
+
+(define-cases f2
+  [(f2) "got zero args"]
+  [(f2 . args) (format "got ~a args" (length args))])
+
+(f2)
+(f2 6 7)
+(f2 1 2 3 4)
+(f2 "three" "arguments" "will-not-trigger-an-error-this-time")
+
+]
+
+
+@defform*[
+#:literals (syntax lambda stx)
+[
+(define-macro id (syntax other-id)) 
+(define-macro id (lambda (arg-id) result-expr ...+))
+(define-macro id transformer-id)
+(define-macro id (syntax result-expr)) 
+(define-macro (id pat-arg ...) expr ...+) 
+]]
+Create a macro using one of the subforms above, which are explained below:
+
+@specsubform[#:literals (define-macro syntax lambda stx) 
+(define-macro id (syntax other-id))]{
+If the first argument is an identifier @racket[id] and the second a syntaxed identifier that looks like @racket[(syntax other-id)], create a rename transformer, which is a fancy term for ``macro that replaces @racket[id] with @racket[other-id].'' (This subform is equivalent to @racket[make-rename-transformer].)
+
+Why do we need rename transformers? Because an ordinary macro operates on its whole calling expression (which it receives as input) like @racket[(macro-name this-arg that-arg . and-so-on)]. By contrast, a rename transformer operates only on the identifier itself (regardless of where that identifier appears in the code). It's like making one identifier into an alias for another identifier.
+
+Below, notice how the rename transformer, operating in the macro realm, approximates the behavior of a run-time assignment. 
+
+@examples[#:eval my-eval
+(define foo 'foo-value)
+(define bar foo)
+bar
+(define-macro zam-macro #'foo)
+zam-macro
+(define add +)
+(add 20 22)
+(define-macro sum-macro #'+)
+(sum-macro 20 22)
+]
+}
+
+
+@specsubform[#:literals (define-macro lambda stx) 
+(define-macro id (lambda (arg-id) result-expr ...+))]{
+If the first argument is an @racket[id] and the second a single-argument function, create a macro called @racket[id] that uses the function as a syntax transformer. This function must return a @seclink["stx-obj" #:doc '(lib "scribblings/guide/guide.scrbl")]{syntax object}, otherwise you'll trigger an error. Beyond that, the function can do whatever you like. (This subform is equivalent to @racket[define-syntax].)
+
+@examples[#:eval my-eval
+(define-macro nice-sum (lambda (stx) #'(+ 2 2)))
+nice-sum
+(define-macro not-nice (lambda (stx) '(+ 2 2)))
+not-nice
+]
+}
+
+@specsubform[#:literals (define-macro lambda stx) 
+(define-macro id transformer-id)]{
+Similar to the previous subform, but @racket[transformer-id] holds an existing transformer function. Note that @racket[transformer-id] needs to be visible during compile time (aka @italic{phase 1}), so use @racket[define-for-syntax] or equivalent.
+
+@examples[#:eval my-eval
+(define-for-syntax summer-compile-time (lambda (stx) #'(+ 2 2)))
+(define-macro nice-summer summer-compile-time)
+nice-summer
+(define summer-run-time (lambda (stx) #'(+ 2 2)))
+(define-macro not-nice-summer summer-run-time)
+]
+}
+
+@specsubform[#:literals (define-macro) 
+(define-macro id syntax-object)
+#:contracts ([syntax-object syntax?])]{
+If the first argument is an @racket[id] and the second a @racket[syntax-object], create a syntax transformer that returns @racket[syntax-object]. This is just alternate notation for the previous subform, wrapping @racket[syntax-object] inside a function body. The effect is to create a macro from @racket[id] that always returns @racket[syntax-object], regardless of how it's invoked. Not especially useful within programs. Mostly handy for making quick macros at the REPL.
+
+@examples[#:eval my-eval
+(define-macro bad-listener #'"what?")
+bad-listener
+(bad-listener)
+(bad-listener "hello")
+(bad-listener 1 2 3 4)
+]
+
+}
+
+@specsubform[#:literals (define-macro) 
+(define-macro (id pat-arg ...) result-expr ...+)]{
+If the first argument is a @seclink["stx-patterns" #:doc '(lib "scribblings/reference/reference.scrbl")]
+{syntax pattern} starting with @racket[id], then create a syntax transformer for this pattern using @racket[result-expr ...] as the return value. As usual, @racket[result-expr ...] needs to return a @seclink["stx-obj" #:doc '(lib "scribblings/guide/guide.scrbl")]{syntax object} or you'll get an error.
+
+The syntax-pattern notation is the same as @racket[syntax-case], with one key difference. If a @racket[pat-arg] has a @tt{CAPITALIZED-NAME}, it's treated as a named wildcard (meaning, it will match any expression in that position, and can be subsequently referred to by that name). Otherwise, @racket[pat-arg] is treated as a literal (meaning, it will only match the same expression). 
+
+For instance, the @racket[sandwich] macro below requires three arguments, and the third must be @racket[please], but the other two are wildcards:
+
+@examples[#:eval my-eval
+(define-macro (sandwich TOPPING FILLING please)
+  #'(format "I love ~a with ~a." 'FILLING 'TOPPING))
+
+(sandwich brie ham)
+(sandwich brie ham now)
+(sandwich brie ham please)
+(sandwich banana bacon please)
+
+]
+
+The ellipsis @racket[...] can be used with a wildcard to match a list of arguments. Please note: though a wildcard standing alone must match one argument, once you add an ellipsis, it's allowed to match zero:
+
+@examples[#:eval my-eval
+(define-macro (pizza TOPPING ...)
+  #'(string-join (cons "Waiter!"
+                       (list (format "More ~a!" 'TOPPING) ...))
+                 " "))
+
+(pizza mushroom)
+(pizza mushroom pepperoni)
+(pizza)
+]
+
+The capitalization requirement for a wildcard @racket[pat-arg] makes it easy to mix literals and wildcards in one pattern. But it also makes it easy to mistype a pattern and not get the wildcard you were expecting. Below, @racket[bad-squarer] doesn't work because @racket[any-number] is meant to be a wildcard. But it's not capitalized, so it's considered a literal, and it triggers an error:
+
+@examples[#:eval my-eval
+(define-macro (bad-squarer any-number)
+  #'(* any-number any-number))
+(bad-squarer +10i)
+]
+
+The error is cleared when the argument is capitalized, thus making it a wilcard:
+
+@examples[#:eval my-eval
+(define-macro (good-squarer ANY-NUMBER)
+  #'(* ANY-NUMBER ANY-NUMBER))
+(good-squarer +10i)
+]
+
+@;{You can use the special identifier @racket[caller-stx] — available only within the body of @racket[define-macro] — to access the original input argument to the macro.}
+
+@;{todo: fix this example. complains that caller-stx is unbound}
+@;{
+@examples[#:eval my-eval
+(require (for-syntax br))
+(define-macro (inspect ARG ...)
+  #`(displayln
+     (let ([calling-pattern '#,(syntax->datum caller-stx)])
+     (format "Called as ~a with ~a args"
+             calling-pattern
+             (length (cdr calling-pattern))))))
+
+(inspect)
+(inspect 42)
+(inspect "foo" "bar")
+(inspect #t #f #f #t)
+]
+}
+
+This subform of @racket[define-macro] is useful for macros that have one calling pattern. To make a macro with multiple calling patterns, see @racket[define-macro-cases].
+}
+
+
+@defform[
+(define-macro-cases id 
+  [pattern result-expr ...+] ...+) 
+]{
+Create a macro called @racket[id] with multiple branches, each with a @racket[pattern] on the left and @racket[result-expr]  on the right. The input to the macro is tested against each @racket[pattern]. If it matches, then @racket[result-expr] is evaluated.
+
+As with @racket[define-macro], wildcards in each syntax pattern must be @tt{CAPITALIZED}. Everything else is treated as a literal match, except for the ellipsis @racket[...] and the wildcard @racket[_].
+
+@examples[#:eval my-eval
+(define-macro-cases yogurt
+  [(yogurt) #'(displayln (format "No toppings? Really?"))]
+  [(yogurt TOPPING) 
+   #'(displayln (format "Sure, you can have ~a." 'TOPPING))]
+  [(yogurt TOPPING ANOTHER-TOPPING ... please)
+   #'(displayln (format "Since you asked nicely, you can have ~a toppings." 
+   (length '(TOPPING ANOTHER-TOPPING ...))))]
+  [(yogurt TOPPING ANOTHER-TOPPING ...)
+   #'(displayln (format "Whoa! Rude people only get one topping."))])
+
+(yogurt)
+(yogurt granola)
+(yogurt coconut almonds hot-fudge brownie-bites please)
+(yogurt coconut almonds)
+]
+
+}
 
 @section{Reader utilities}
 
 @defmodule[br/reader-utils]
 
-TK
+@defform[
+(define-read-and-read-syntax (path-id port-id) 
+  reader-result-expr ...+)
+]{
+For use within a language reader. Automatically @racket[define] and @racket[provide] the @racket[read] and @racket[read-syntax] functions needed for the reader's public interface. @racket[reader-result-expr] can return either a syntax object or a datum (which will be converted to a syntax object). 
 
+The generated @racket[read-syntax] function takes two arguments, a path and an input port. It returns a syntax object stripped of all bindings.
+
+The generated @racket[read] function takes one argument, an input port. It calls @racket[read-syntax] and converts the result to a datum.
+
+
+@examples[#:eval my-eval
+(module sample-reader racket/base
+  (require br/reader-utils racket/list)
+  (define-read-and-read-syntax (path port)
+    (add-between
+     (for/list ([datum (in-port read port)])
+              datum)
+     'whee)))
+
+(require (prefix-in sample: 'sample-reader))
+
+(define string-port (open-input-string "(+ 2 2) 'hello"))
+(sample:read-syntax 'no-path string-port)
+
+(define string-port-2 (open-input-string "(+ 2 2) 'hello"))
+(sample:read string-port-2)
+]
+
+
+}
+
+@;{
 @section{Syntax}
 
 @defmodule[br/syntax]
 
 TK
+}

beautiful-racket-lib/br/syntax.rkt

@@ -1,34 +1,115 @@
 #lang racket/base
-(require (for-syntax racket/base syntax/parse) syntax/strip-context)
+(require (for-syntax racket/base racket/syntax)
-(provide (all-defined-out) (all-from-out syntax/strip-context))
+         racket/list
+         racket/syntax
+         br/define
+         br/private/syntax-flatten)
+(provide (all-defined-out)
+         syntax-flatten)
+
+(module+ test
+  (require rackunit))
 
 
-(define-syntax (syntax-match stx)
+(define-macro (syntax-match STX-ARG [(syntax PATTERN) BODY ...] ...)
-  (syntax-case stx (syntax)
+  #'(syntax-case STX-ARG ()
-    [(_ stx-arg [(syntax pattern) body ...] ...)
+      [PATTERN BODY ...] ...))
-     #'(syntax-case stx-arg ()
-         [pattern body ...] ...)]))
-
-(define-syntax (add-syntax stx)
-  ;; todo: permit mixing of two-arg and one-arg binding forms
-  ;; one-arg form allows you to inject an existing syntax object using its current name
-  (syntax-case stx (syntax)
-    [(_ ([(syntax sid) sid-stx] ...) body ...)
-     #'(with-syntax ([sid sid-stx] ...) body ...)]
-    ;; todo: limit `sid` to be an identifier
-    [(_ ([sid] ...) body ...)
-     #'(with-syntax ([sid sid] ...) body ...)]))
-
-(define-syntax syntax-let (make-rename-transformer #'add-syntax))
-
-(define-syntax inject-syntax (make-rename-transformer #'add-syntax))
-
-(define-syntax (map-syntax stx)
-  (syntax-case stx ()
-    [(_ <proc> <arg> ...)
-     #'(map <proc> (if (and (syntax? <arg>) (list? (syntax-e <arg>)))
-                       (syntax->list <arg>)
-                       <arg>) ...)]))
 
 
-#;(define-syntax syntax-variable (make-rename-transformer #'format-id))
+(define-macro-cases with-pattern
+  [(_ () . BODY) #'(begin . BODY)]
+  [(_ ([SID SID-STX] STX ...) . BODY)
+   #'(with-syntax ([SID SID-STX])
+       (with-pattern (STX ...) . BODY))]
+  [(_ ([SID] STX ...) . BODY) ; standalone id
+   #'(with-pattern ([SID SID] STX ...) . BODY)]) ; convert to previous case
+
+
+(define (check-syntax-list-argument caller-name arg)
+  (cond
+    [(and (syntax? arg) (syntax->list arg))]
+    [(list? arg) arg]
+    [else (raise-argument-error caller-name "list of syntax, or syntaxed list" arg)]))
+
+
+(define-macro (define-listy-macro MACRO-ID LIST-FUNC)
+  #'(define-macro (MACRO-ID STX-LIST LITERALS . MATCHERS)
+      #'(LIST-FUNC
+         (λ(stx-item)
+           (with-handlers ([exn:fail:syntax? (λ (exn) #f)])
+             (syntax-case stx-item LITERALS
+               . MATCHERS)))
+         (check-syntax-list-argument 'MACRO-ID STX-LIST))))
+
+(define-listy-macro syntax-case-partition partition)
+(define-listy-macro syntax-case-filter filter)
+(define-listy-macro syntax-case-map map)
+
+
+(define-macro (reformat-id FMT ID0 ID ...)
+  #'(format-id ID0 FMT ID0 ID ...))
+
+
+(define-macro (format-string FMT ID0 ID ...)
+  #'(datum->syntax ID0 (format FMT (syntax->datum ID0) (syntax->datum ID) ...)))
+
+
+(define-macro (->unsyntax X)
+  #'(if (syntax? X)
+        (syntax->datum X)
+        X))
+
+
+(define-macro (prefix-id PREFIX ... BASE-OR-BASES)
+  #'(let* ([bobs BASE-OR-BASES]
+           [got-single? (and (not (list? bobs)) (not (syntax->list bobs)))]
+           [bases (if got-single?
+                      (list bobs)
+                      bobs)]
+           [result (syntax-case-map
+                    bases ()
+                    [base (format-id #'base "~a~a"
+                                     (string-append (format "~a" (->unsyntax PREFIX)) ...)
+                                     (syntax-e #'base))])])
+      (if got-single? (car result) result)))
+
+
+(define-macro (infix-id PREFIX BASE-OR-BASES SUFFIX ...)
+  #'(let* ([bobs BASE-OR-BASES]
+           [got-single? (and (not (list? bobs)) (not (syntax->list bobs)))]
+           [bases (if got-single?
+                      (list bobs)
+                      bobs)]
+           [result (syntax-case-map
+                    bases ()
+                    [base (format-id #'base "~a~a~a"
+                                     (->unsyntax PREFIX)
+                                     (syntax-e #'base)
+                                     (string-append (format "~a" (->unsyntax SUFFIX)) ...))])])
+      (if got-single? (car result) result)))
+
+
+(define-macro (suffix-id BASE-OR-BASES SUFFIX ...)
+  #'(infix-id "" BASE-OR-BASES SUFFIX ...))
+
+
+(define-macro-cases syntax-property*
+  [(_ STX 'PROP0) ; read one
+   #'(syntax-property STX 'PROP0)]
+  [(_ STX 'PROP0 'PROP ...) ; read multiple
+   #'(cons (syntax-property* STX 'PROP0)
+           (let ([result (syntax-property* STX 'PROP ...)])
+             (if (pair? result)
+                 result
+                 (list result))))]
+  [(_ STX ['PROP0 VAL0 . PRESERVED0]) ; write one
+   #'(syntax-property STX 'PROP0 VAL0 . PRESERVED0)]
+  [(_ STX ['PROP0 VAL0 . PRESERVED0] ['PROP VAL . PRESERVED] ...) ; write multiple
+   #'(syntax-property* (syntax-property STX 'PROP0 VAL0 . PRESERVED0) ['PROP VAL . PRESERVED] ...)])
+
+
+(module+ test
+  (define x (syntax-property* #'foo ['bar #t] ['zam 'boni]))
+  (check-false (syntax-property* x 'foo))
+  (check-true (syntax-property* x 'bar))
+  (check-equal? (syntax-property* x 'foo 'bar 'zam) '(#f #t boni)))

beautiful-racket-lib/br/verbose-app.rkt

@@ -0,0 +1,10 @@
+#lang br
+(require (prefix-in br: (only-in br #%app)))
+(provide #%app)
+
+(define-macro (#%app APP ARG ...)
+  #'(let ()
+      (br:#%app displayln (br:#%app format "handling subexpressions in ~a" '(APP ARG ...)))
+      (define result (br:#%app APP ARG ...))
+      (br:#%app displayln (br:#%app format "evaluating ~a = ~a" '(APP ARG ...) result ))
+      result))

beautiful-racket-lib/info.rkt

@@ -2,5 +2,7 @@
 (define collection 'multi)
 
 (define version "0.01")
-(define deps '("base" "sugar"))
+(define deps '("base"
+               "sugar"
+               "gui-lib"))
 (define build-deps '("racket-doc" "rackunit-lib" "scribble-lib"))

beautiful-racket/br/demo/basic/3dplot.bas

@@ -0,0 +1,19 @@
+#lang br/demo/basic
+
+1 PRINT TAB(32);"3D PLOT"
+2 PRINT TAB(15);"CREATIVE COMPUTING  MORRISTOWN, NEW JERSEY"
+3 PRINT:PRINT:PRINT
+5 DEF FNA(Z)=30*EXP(-Z*Z/100)
+100 PRINT
+110 FOR X=-30 TO 30 STEP 1.5
+120 L=0
+130 Y1=5*INT(SQR(900-X*X)/5)
+140 FOR Y=Y1 TO -Y1 STEP -5
+150 Z=INT(25+FNA(SQR(X*X+Y*Y))-.7*Y)
+160 IF Z<=L THEN 190
+170 L=Z
+180 PRINT TAB(Z);"*";
+190 NEXT Y
+200 PRINT
+210 NEXT X
+300 END

beautiful-racket/br/demo/basic/amazing.bas

@@ -0,0 +1,140 @@
+#lang br/demo/basic
+
+10 PRINT TAB(28);"AMAZING PROGRAM"
+20 PRINT TAB(15);"CREATIVE COMPUTING  MORRISTOWN, NEW JERSEY"
+30 PRINT:PRINT:PRINT:PRINT
+100 INPUT "WHAT ARE YOUR WIDTH AND LENGTH";HMAX,VMAX
+102 IF HMAX<>1 AND VMAX<>1 THEN 110
+104 PRINT "MEANINGLESS DIMENSIONS.  TRY AGAIN.":GOTO 100
+110 DIM W(HMAX,VMAX),V(HMAX,VMAX)
+120 PRINT
+130 PRINT
+140 PRINT
+150 PRINT
+160 Q=0:Z=0:X=INT(RND(1)*HMAX+1)
+165 FOR I=1 TO HMAX
+170 IF I=X THEN 173
+171 PRINT "+--";:GOTO 180
+173 PRINT "+  ";
+180 NEXT I
+190 PRINT "+"
+195 C=1:W(X,1)=C:C=C+1
+200 R=X:S=1:GOTO 260
+210 IF R<>HMAX THEN 240
+215 IF S<>VMAX THEN 230
+220 R=1:S=1:GOTO 250
+230 R=1:S=S+1:GOTO 250
+240 R=R+1
+250 IF W(R,S)=0 THEN 210
+260 IF R-1=0 THEN 530
+265 IF W(R-1,S)<>0 THEN 530
+270 IF S-1=0 THEN 390
+280 IF W(R,S-1)<>0 THEN 390
+290 IF R=HMAX THEN 330
+300 IF W(R+1,S)<>0 THEN 330
+310 X=INT(RND(1)*3+1)
+320 ON X GOTO 790,820,860
+330 IF S<>HMAX THEN 340
+334 IF Z=1 THEN 370
+338 Q=1:GOTO 350
+340 IF W(R,S+1)<>0 THEN 370
+350 X=INT(RND(1)*3+1)
+360 ON X GOTO 790,820,910
+370 X=INT(RND(1)*2+1)
+380 ON X GOTO 790,820
+390 IF R=HMAX THEN 470
+400 IF W(R+1,S)<>0 THEN 470
+405 IF S<>VMAX THEN 420
+410 IF Z=1 THEN 450
+415 Q=1:GOTO 430
+420 IF W(R,S+1)<>0 THEN 450
+430 X=INT(RND(1)*3+1)
+440 ON X GOTO 790,860,910
+450 X=INT(RND(1)*2+1)
+460 ON X GOTO 790,860
+470 IF S<>VMAX THEN 490
+480 IF Z=1 THEN 520
+485 Q=1:GOTO 500
+490 IF W(R,S+1)<>0 THEN 520
+500 X=INT(RND(1)*2+1)
+510 ON X GOTO 790,910
+520 GOTO 790
+530 IF S-1=0 THEN 670
+540 IF W(R,S-1)<>0 THEN 670
+545 IF R=HMAX THEN 610
+547 IF W(R+1,S)<>0 THEN 610
+550 IF S<>VMAX THEN 560
+552 IF Z=1 THEN 590
+554 Q=1:GOTO 570
+560 IF W(R,S+1)<>0 THEN 590
+570 X=INT(RND(1)*3+1)
+580 ON X GOTO 820,860,910
+590 X=INT(RND(1)*2+1)
+600 ON X GOTO 820,860
+610 IF S<>VMAX THEN 630
+620 IF Z=1 THEN 660
+625 Q=1:GOTO 640
+630 IF W(R,S+1)<>0 THEN 660
+640 X=INT(RND(1)*2+1)
+650 ON X GOTO 820,910
+660 GOTO 820
+670 IF R=HMAX THEN 740
+680 IF W(R+1,S)<>0 THEN 740
+685 IF S<>VMAX THEN 700
+690 IF Z=1 THEN 730
+695 Q=1:GOTO 830
+700 IF W(R,S+1)<>0 THEN 730
+710 X=INT(RND(1)*2+1)
+720 ON X GOTO 860,910
+730 GOTO 860
+740 IF S<>VMAX THEN 760
+750 IF Z=1 THEN 780
+755 Q=1:GOTO 770
+760 IF W(R,S+1)<>0 THEN 780
+770 GOTO 910
+780 GOTO 1000
+790 W(R-1,S)=C
+800 C=C+1:V(R-1,S)=2:R=R-1
+810 IF C=HMAX*VMAX+1 THEN 1010
+815 Q=0:GOTO 260
+820 W(R,S-1)=C
+830 C=C+1
+840 V(R,S-1)=1:S=S-1:IF C=HMAX*VMAX+1 THEN 1010
+850 Q=0:GOTO 260
+860 W(R+1,S)=C
+870 C=C+1:IF V(R,S)=0 THEN 880
+875 V(R,S)=3:GOTO 890
+880 V(R,S)=2
+890 R=R+1
+900 IF C=HMAX*VMAX+1 THEN 1010
+905 GOTO 530
+910 IF Q=1 THEN 960
+920 W(R,S+1)=C:C=C+1:IF V(R,S)=0 THEN 940
+930 V(R,S)=3:GOTO 950
+940 V(R,S)=1
+950 S=S+1:IF C=HMAX*VMAX+1 THEN 1010
+955 GOTO 260
+960 Z=1
+970 IF V(R,S)=0 THEN 980
+975 V(R,S)=3:Q=0:GOTO 1000
+980 V(R,S)=1:Q=0:R=1:S=1:GOTO 250
+1000 GOTO 210
+1010 FOR J=1 TO VMAX
+1011 PRINT "|";
+1012 FOR I=1 TO HMAX
+1013 IF V(I,J)<2 THEN 1030
+1020 PRINT "   ";
+1021 GOTO 1040
+1030 PRINT "  |";
+1040 NEXT I
+1041 PRINT
+1043 FOR I=1 TO HMAX
+1045 IF V(I,J)=0 THEN 1060
+1050 IF V(I,J)=2 THEN 1060
+1051 PRINT "+  ";
+1052 GOTO 1070
+1060 PRINT "+--";
+1070 NEXT I
+1071 PRINT "+"
+1072 NEXT J
+1073 END

beautiful-racket/br/demo/basic/bounce.bas

@@ -0,0 +1,55 @@
+#lang br/demo/basic
+
+10 PRINT TAB(33);"BOUNCE"
+20 PRINT TAB(15);"CREATIVE COMPUTING  MORRISTOWN, NEW JERSEY"
+30 PRINT:PRINT:PRINT
+90 DIM T(20)
+100 PRINT "THIS SIMULATION LETS YOU SPECIFY THE INITIAL VELOCITY"
+110 PRINT "OF A BALL THROWN STRAIGHT UP, AND THE COEFFICIENT OF"
+120 PRINT "ELASTICITY OF THE BALL.  PLEASE USE A DECIMAL FRACTION"
+130 PRINT "COEFFICIENCY (LESS THAN 1)."
+131 PRINT
+132 PRINT "YOU ALSO SPECIFY THE TIME INCREMENT TO BE USED IN"
+133 PRINT "'STROBING' THE BALL'S FLIGHT (TRY .1 INITIALLY)."
+134 PRINT
+135 INPUT "TIME INCREMENT (SEC)";S2
+140 PRINT
+150 INPUT "VELOCITY (FPS)";V
+160 PRINT
+170 INPUT "COEFFICIENT";C
+180 PRINT
+182 PRINT "FEET"
+184 PRINT
+186 S1=INT(70/(V/(16*S2)))
+190 FOR I=1 TO S1
+200 T(I)=V*C^(I-1)/16
+210 NEXT I
+220 FOR H=INT(-16*(V/32)^2+V^2/32+.5) TO 0 STEP -.5
+221 IF INT(H)<>H THEN 225
+222 PRINT H;
+225 L=0
+230 FOR I=1 TO S1
+240 FOR TI=0 TO T(I) STEP S2
+245 L=L+S2
+250 IF ABS(H-(.5*(-32)*TI^2+V*C^(I-1)*TI))>.25 THEN 270
+260 PRINT TAB(L/S2);"0";
+270 NEXT TI
+275 TI=T(I+1)/2
+276 IF -16*TI^2+V*C^(I-1)*TI<H THEN 290
+280 NEXT I
+290 PRINT
+300 NEXT H
+310 PRINT TAB(1);
+320 FOR I=1 TO INT(L+1)/S2+1
+330 PRINT ".";
+340 NEXT I
+350 PRINT
+355 PRINT " 0";
+360 FOR I=1 TO INT(L+.9995)
+380 PRINT TAB(INT(I/S2));I;
+390 NEXT I
+400 PRINT
+410 PRINT TAB(INT(L+1)/(2*S2)-2);"SECONDS"
+420 PRINT
+430 GOTO 135
+440 END

beautiful-racket/br/demo/basic/chemist.bas

@@ -1,29 +1,30 @@
 #lang br/demo/basic
 
-3 PRINT TAB(33);"CHEMIST"
+3 print TAB(33);"Chemist"
-6 PRINT TAB(15);"CREATIVE COMPUTING  MORRISTOWN, NEW JERSEY"
+6 print TAB(15);"Creative Computing | Morristown, New Jersey"
-8 PRINT:PRINT:PRINT
+8 print:print:print
-10 PRINT "THE FICTITIOUS CHECMICAL KRYPTOCYANIC ACID CAN ONLY BE"
+10 print "The fictitious chemical kryptocyanic acid can only be"
-20 PRINT "DILUTED BY THE RATIO OF 7 PARTS WATER TO 3 PARTS ACID."
+20 print "diluted by the ratio of 7 parts water to 3 parts acid."
-30 PRINT "IF ANY OTHER RATIO IS ATTEMPTED, THE ACID BECOMES UNSTABLE"
+30 print "if any other ratio is attempted, the acid becomes unstable"
-40 PRINT "AND SOON EXPLODES.  GIVEN THE AMOUNT OF ACID, YOU MUST"
+40 print "and soon explodes. Given the amount of acid, you must"
-50 PRINT "DECIDE WHO MUCH WATER TO ADD FOR DILUTION.  IF YOU MISS"
+50 print "decide who much water to add for dilution. If you miss,"
-60 PRINT "YOU FACE THE CONSEQUENCES."
+60 print "you face the consequences."
-100 A=INT(RND(1)*50)
+100 A=INT(RND(50))
 110 W=7*A/3
-120 PRINT A;"LITERS OF KRYPTOCYANIC ACID.  HOW MUCH WATER";
+115 if A=1 then P="liter" else P="liters"
-130 INPUT R
+120 print A; " "; P ; " of kryptocyanic acid. How much water?";
+130 input R
 140 D=ABS(W-R)
-150 IF D>W/20 THEN 200
+150 if D>W/20 then 200
-160 PRINT " GOOD JOB! YOU MAY BREATHE NOW, BUT DON'T INHALE THE FUMES!"
+160 print "Good job! You may breathe now, but don't inhale the fumes!"
-170 PRINT
+170 print
-180 GOTO 100
+180 goto 100
-200 PRINT " SIZZLE!  YOU HAVE JUST BEEN DESALINATED INTO A BLOB"
+200 print "Sizzle! You have just been desalinated into a blob"
-210 PRINT " OF QUIVERING PROTOPLASM!"
+210 print "of quivering protoplasm!"
 220 T=T+1
-230 IF T=9 THEN 260
+230 if T=3 then 260
-240 PRINT " HOWEVER, YOU MAY TRY AGAIN WITH ANOTHER LIFE."
+240 print "However, you may try again with another life."
-250 GOTO 100
+250 goto 100
-260 PRINT " YOUR 9 LIVES ARE USED, BUT YOU WILL BE LONG REMEMBERED FOR"
+260 print "Your 3 lives are used, but you will be long remembered for"
-270 PRINT " YOUR CONTRIBUTIONS TO THE FIELD OF COMIC BOOK CHEMISTRY."
+270 print "your contributions to the field of comic-book chemistry."
-280 END
+280 end

beautiful-racket/br/demo/basic/dim.bas

@@ -0,0 +1,7 @@
+#lang br/demo/basic
+
+5 A=5
+10 DIM A(A)
+20 PRINT A /* this should print 5 */
+30 PRINT A(0)
+40 PRINT A(5)

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

@@ -1,162 +1,271 @@
 #lang br
+(require (for-syntax syntax/strip-context))
 (provide #%top-interaction #%app #%datum
          (rename-out [basic-module-begin #%module-begin])
          (rename-out [basic-top #%top])
          (all-defined-out))
-(require br/stxparam (for-syntax br/datum))
 
 ; BASIC implementation details
 ; http://www.atariarchives.org/basicgames/showpage.php?page=i12
 
-(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$ ""])
+(begin-for-syntax
+  (require racket/list)
+  (define (gather-unique-ids stx)
+    (remove-duplicates (map syntax->datum (filter (λ(s) (syntax-property s 'id)) (syntax-flatten stx))) eq?)))
 
-(define #'(basic-module-begin _parse-tree ...)
+(define-macro (basic-module-begin (basic-program PROGRAM-LINE ...))
-  #'(#%module-begin
+  (with-pattern ([(UNIQUE-ID ...)
-     (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$)
+                  (map (compose1 syntax-local-introduce (λ(id) (datum->syntax #f id)))
-                                (println (quote _parse-tree ...))
+                       (gather-unique-ids #'(PROGRAM-LINE ...)))])
-                                _parse-tree ...)))
+    #'(#%module-begin
+       (define UNIQUE-ID 0) ...
+       (provide UNIQUE-ID ...)
+       (run PROGRAM-LINE ... (line #f (statement "end"))))))
 
 ; #%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))
+      (displayln (format "got unbound identifier: ~a" 'ID))
-      (procedure-rename (λ xs (cons 'id xs)) (string->symbol (format "undefined:~a" 'id)))))
+      (procedure-rename (λ xs (cons 'ID xs)) (string->symbol (format "undefined:~a" 'ID)))))
-
-(define #'(program _line ...) #'(run (list _line ...)))
-
 
 (struct exn:line-not-found exn:fail ())
+(define (raise-line-not-found-error ln)
+  (raise
+   (exn:line-not-found
+    (format "line number ~a not found in program" ln)
+    (current-continuation-marks))))
 
+(struct end-program-signal exn:fail ())
+(define (raise-end-program-signal)
+  (raise (end-program-signal "" (current-continuation-marks))))
 
-(define (run lines)
+(struct end-line-signal exn:fail ())
-  (define program-lines (list->vector (filter (λ(ln) (not (equal? ln "cr"))) lines)))
+(define (raise-end-line-signal)
-  (define (line-number->index ln)
+  (raise (end-line-signal "" (current-continuation-marks))))
+
+(define (run . line-list)
+  (define lines (list->vector line-list))
+  (define (find-index ln)
     (or
-     (for/or ([idx (in-range (vector-length program-lines))])
+     (for/or ([idx (in-range (vector-length lines))])
-             (and (= (car (vector-ref program-lines idx)) ln)
+             (and (= ($line-number (vector-ref lines idx)) ln)
                   idx))
-     (raise
+     (raise-line-not-found-error ln)))
-      (exn:line-not-found
+  (void
-       (format "line number ~a not found in program" ln)
+   (with-handlers ([end-program-signal? void])
-       (current-continuation-marks)))))
+     (for/fold ([program-counter 0])
-  (for/fold ([program-counter 0])
+               ([i (in-naturals)])
-            ([i (in-naturals)]
+       (let* ([line-thunk ($line-thunk (vector-ref lines program-counter))]
-             #:break (eq? program-counter 'end))
+              [maybe-line-number (line-thunk)])
-    (cond
+         (if (number? maybe-line-number)
-      [(= program-counter (vector-length program-lines)) (basic:END)]
+             (find-index maybe-line-number)
-      [else
+             (add1 program-counter)))))))
-       (define line-function (cdr (vector-ref program-lines program-counter)))
-       (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))
 
-(define #'(cr-line _arg ...) #'(begin _arg ...))
+(define return-stack empty)
 
+(define (basic:gosub where)
+  (let/cc return-k
+    (set! return-stack (cons return-k return-stack))
+    (basic:goto where)))
 
-(define current-return-stack (make-parameter empty))
+(define current-line (make-parameter #f))
+(struct $line (number thunk))
+(define-macro (line NUMBER . STATEMENTS)
+  #'($line NUMBER (λ ()
+                    (current-line NUMBER)
+                    (with-handlers ([end-line-signal? (λ _ #f)]
+                                    [end-program-signal? raise]
+                                    [exn:fail? (λ(exn)
+                                                 (displayln (format "in line ~a" NUMBER))
+                                                 (raise exn))])
+                      . STATEMENTS))))
 
-(define-cases #'line
+(define-macro-cases statement
-  [#'(_ _NUMBER (statement-list (statement "GOSUB" _WHERE)))
+  [(statement ID "=" EXPR) #'(basic:let ID EXPR)]
-   #'(cons _NUMBER
+  [(statement PROC-NAME . ARGS)
-           (λ _
+   (with-pattern
-             (let ([return-stack (current-return-stack)])
+       ([PROC-ID (prefix-id "basic:" #'PROC-NAME)])
-               (cond
+     #'(PROC-ID . ARGS))])
-                 [(or (empty? return-stack)
-                      (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
+(define-macro-cases basic:let
-  [#'(_ _STATEMENT) #'(begin _STATEMENT)]
+  [(_ (id-expr ID) EXPR)
-  [#'(_ _STATEMENT ":" _STATEMENT-LIST) #'(begin _STATEMENT _STATEMENT-LIST)])
+   #'(begin
+       #;(displayln (format "setting ~a = ~a in ~a" 'ID EXPR (current-line)))
+       (set! ID EXPR))]
+  [(_ (id-expr ID DIM-IDX ...) EXPR)
+   #'(array-set! ID DIM-IDX ... EXPR)])
 
-(define-cases #'statement
+(define-macro-cases basic:if
-  [#'(statement _ID "=" _EXPR) #'(set! _ID _EXPR)]
+  [(_ COND-EXPR TRUE-EXPR FALSE-EXPR)
-  ;[#'(statement "PRINT" ARG ...) #'(print ARG ...)]
+   #'(if (true? COND-EXPR)
-  ;[#'(statement "RETURN" ARG ...) #'(return ARG ...)]
+         TRUE-EXPR
-  ;[#'(statement "END" ARG ...) #'(end ARG ...)]
+         FALSE-EXPR)]
-  [#'(statement _proc-string _arg ...)
+  [(_ COND-EXPR TRUE-EXPR)
-   (inject-syntax ([#'PROC-ID (format-datum "basic:~a" #'_proc-string)])
+   #'(if (true? COND-EXPR)
-                  #'(PROC-ID _arg ...))])
+         TRUE-EXPR
-
+         (raise-end-line-signal))]) ; special short-circuit rule for one-armed conditional
-(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])
 
 (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
+(define-macro-cases id-expr
-  [#'(_ _EXPR) #'_EXPR]
+  [(_ ID) #'(cond
-  [#'(_ _EXPR "," _EXPR-LIST) #'(_EXPR _EXPR-LIST)])
+              [(procedure? ID) (ID)]
+              [(array? ID) (array-ref ID (make-vector (array-rank ID) 0))] ; no subscript => zeroth element
+              [else ID])]
+  [(_ ID EXPR0 EXPR ...) #'(cond
+                             [(procedure? ID) (ID EXPR0 EXPR ...)]
+                             [(array? ID) (array-ref ID EXPR0 EXPR ...)]
+                             [else (error 'id-expr-confused)])])
 
-(define-cases #'expr
+(define-macro-cases expr
-  [#'(_ _COMP-EXPR "AND" _SUBEXPR) #'(basic:and _COMP-EXPR _SUBEXPR)]
+  [(_ COMP-EXPR) #'COMP-EXPR]
-  [#'(_ _COMP-EXPR "OR" _SUBEXPR) #'(basic:or _COMP-EXPR _SUBEXPR)]
+  [(_ COMP-EXPR "and" SUBEXPR) #'(basic:and COMP-EXPR SUBEXPR)]
-  [#'(_ _COMP-EXPR) #'_COMP-EXPR])
+  [(_ COMP-EXPR "or" SUBEXPR) #'(basic:or COMP-EXPR SUBEXPR)])
+
+(define-macro-cases comp-expr
+  [(_ SUM) #'SUM]
+  [(_ SUM "=" COMP-EXPR)
+   #'(cond->int (equal? SUM COMP-EXPR))] ; special case because `=` is overloaded in basic
+  [(_ SUM OP-STR COMP-EXPR)
+   (with-pattern
+       ([OP (replace-context #'here (prefix-id #'OP-STR))])
+     #'(cond->int (OP SUM COMP-EXPR)))])
 
-(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
+(define-macro-cases sum
-  [#'(_ _TERM "+" _SUM) #'(+ _TERM _SUM)]
+  [(_ SUM) #'SUM]
-  [#'(_ _TERM "-" _SUM) #'(- _TERM _SUM)]
+  [(_ SUM "+" PRODUCT) #'(+ SUM PRODUCT)]
-  [#'(_ _TERM) #'_TERM])
+  [(_ SUM "-" PRODUCT) #'(- SUM PRODUCT)])
 
-(define-cases #'product
+(define-macro-cases product
-  [#'(_ _value "*" _product) #'(* _value _product)]
+  [(_ "-" VALUE) #'(- VALUE)]
-  [#'(_ _value "/" _product) #'(/ _value _product)]
+  [(_ VALUE) #'VALUE]
-  [#'(_ _value) #'_value])
+  [(_ PRODUCT "*" VALUE) #'(* PRODUCT VALUE)]
+  [(_ PRODUCT "/" VALUE) #'(/ PRODUCT VALUE)])
+
+(define-macro-cases power
+  [(_ BASE) #'BASE]
+  [(_ BASE POWER) #'(expt BASE POWER)])
+
+(define-macro-cases number
+  [(_ "-" NUM) #'(- NUM)]
+  [(_ NUM) #'NUM])
+
+(define-macro-cases id-val
+  [(_ "-" ID) #'(- ID)]
+  [(_ ID) #'ID])
 
 (define print-list list)
 
-(define (basic:PRINT args)
+(define (basic:print [args #f])
-  (match args
+  (define (println [x ""])
-    [(list) (displayln "")]
+    (define xstr (format "~a" x))
-    [(list print-list-item ... ";" pl) (begin (for-each display print-list-item)
+    (displayln xstr)
-                                              (basic:PRINT pl))]
+    (set! current-print-position 0))
-    [(list print-list-item ... ";") (for-each display print-list-item)]
+  (define (print x)
-    [(list print-list-item ...) (for-each displayln print-list-item)]))
+    (define xstr (format "~a" x))
+    (display xstr)
+    (set! current-print-position (+ current-print-position (string-length xstr))))
   
-(define (TAB num) (make-string num #\space))
+  (match args
-(define #'(INT _ARG ...) #'(inexact->exact (truncate (expr _ARG ...))))
+    [#f (println)]
+    [(list print-list-items ... ";" pl)
+     (begin
+       (for-each
+        (λ(pli)
+          (print (if (number? pli)
+                     (format "~a " pli)
+                     pli)))
+        print-list-items)
+       (basic:print pl))]
+    [(list print-list-items ... ";") (for-each print print-list-items)]
+    [(list print-list-items ...)
+     (for-each println print-list-items)]))
+
+(define current-print-position 0)
+(define (TAB num) (make-string (max 0 (INT (- num current-print-position))) #\space))
+(define (INT num) (inexact->exact (truncate num)))
 (define (SIN num) (sin num))
 (define (ABS num) (inexact->exact (abs num)))
 (define (RND num) (* (random) num))
+(define (EXP num) (exp num))
+(define (SQR num) (sqrt num))
 
-(define-cases #'basic:INPUT
+(define-macro-cases basic:input
-  [#'(_ _PRINT-LIST ";" _ID)
+  [(_ (print-list . PL-ITEMS) ID ...)
    #'(begin
-       (basic:PRINT (append _PRINT-LIST (list ";")))
+       (basic:print (append (print-list . PL-ITEMS) (list ";")))
-       (basic:INPUT _ID))]
+       (basic:input ID) ...)]
-  [#'(_ _ID) #'(set! _ID (let* ([str (read-line)]
+  [(_ ID ...) #'(begin
-                                [num (string->number str)])
+                  (set! ID (let* ([str (read-line)]
-                           (if num num str)))])
+                                  [num (string->number (string-trim str))])
+                             (or num str))) ...)])
 
-(define (basic:GOTO where) where)
+(define (basic:goto where) where)
 
-(define (basic:RETURN) (car (current-return-stack)))
+(define-macro-cases basic:on
+  [(_ TEST-EXPR "goto" OPTION ...)
+   #'(basic:goto (list-ref (list OPTION ...) (sub1 TEST-EXPR)))]
+  [(_ TEST-EXPR "gosub" OPTION ...)
+   #'(basic:gosub (list-ref (list OPTION ...) (sub1 TEST-EXPR)))])
 
-(define (basic:END)
+
-  'end)
+(define (basic:return)
+  (define return-k (car return-stack))
+  (set! return-stack (cdr return-stack))
+  (return-k #f))
+
+(define (basic:stop) (basic:end))
+(define (basic:end) (raise-end-program-signal))
+
+(require srfi/25)
+
+(define-macro (basic:dim (id-expr ID EXPR ...) ...)
+  #'(begin
+      (set! ID (make-array (apply shape (append (list 0 (add1 EXPR)) ...)))) ...))
+
+(define for-stack empty)
+
+(define (push-for-stack thunk)
+  (set! for-stack (cons thunk for-stack)))
+
+(define (pop-for-stack)
+  (set! for-stack (cdr for-stack)))
+
+(define (in-closed-interval? x left right)
+  (define cmp (if (< left right) <= >=))
+  (cmp left x right))
+
+(define-macro-cases basic:for
+  [(_ VAR START-VALUE END-VALUE)
+   #'(basic:for VAR START-VALUE END-VALUE 1)]
+  [(_ VAR START-VALUE END-VALUE STEP-VALUE)
+   #'(begin
+       (statement (id-expr VAR) "=" START-VALUE) ; initialize the loop counter
+       (let/cc return-k ; create a return point
+         (push-for-stack (cons 'VAR
+                               (λ () ; thunk that increments counter & teleports back to beginning of loop
+                                 (define next-val (+ VAR STEP-VALUE))
+                                 (if (next-val . in-closed-interval? . START-VALUE END-VALUE)
+                                     (begin
+                                       (set! VAR next-val)
+                                       (return-k #f)) ; return value for subsequent visits to line
+                                     (pop-for-stack)))))
+         #f))]) ; return value for first visit to line
+
+(define (handle-next [which #f])
+  (unless (pair? for-stack) (error 'next "for-stack is empty"))
+  (define for-thunk (cdr (if which
+                             (assq which for-stack)
+                             (car for-stack))))
+  (for-thunk))
+
+(define-macro (basic:next VAR ...)
+  #'(handle-next 'VAR ...))
+
+(define-macro (basic:def DEF-ID LAMBDA-ID EXPR)
+  #'(set! DEF-ID (λ (LAMBDA-ID) EXPR)))

beautiful-racket/br/demo/basic/for.bas

@@ -0,0 +1,8 @@
+#lang br/demo/basic
+10 for A=1 to 3 
+20 print A
+21 for B=5 to 8
+22 print B
+23 next B
+30 next A
+40 print "yay"

beautiful-racket/br/demo/basic/gosub.bas

@@ -1,9 +1,9 @@
 #lang br/demo/basic
 10 GOSUB 50
-15 PRINT "BOOM"
+15 PRINT "2 of 3"
 17 GOSUB 30
 20 END
-30 PRINT "YAY"
+30 PRINT "3 of 3"
 40 RETURN
-50 PRINT "50"
+50 PRINT "1 of 3"
 55 RETURN

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

@@ -0,0 +1,2 @@
+#lang racket
+(require "for.bas")

beautiful-racket/br/demo/basic/on.bas

@@ -0,0 +1,11 @@
+#lang br/demo/basic
+10 X = 3
+20 on X gosub 210, 220, 230
+21 print "yay"
+22 end
+210 print "one"
+211 return
+220 print "two"
+221 return
+230 print "three"
+231 return

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

@@ -1,35 +1,45 @@
 #lang brag
 
-;; recursive rules destucture easily in the expander
+basic-program : line*
-program : [CR]* [line [CR line]*] [CR]*
 
-line: NUMBER statement-list
+line: NUMBER statement [/":" statement]*
 
-statement-list : statement [":" statement-list]
+statement : "def" id /"(" id /")" /"=" expr
+| "dim" id-expr [/"," id-expr]*
+| "end" | "stop"
+| "gosub" expr
+| "goto" expr
+| "on" expr ("gosub" | "goto") expr [/"," expr]*
+| "if" expr /"then" (statement | expr) [/"else" (statement | expr)]
+| "input" [print-list /";"] id [/"," id]*
+| [/"let"] id-expr "=" expr
+| "print" [print-list]
+| "return"
+| "for" id /"=" expr /"to" expr [/"step" expr]
+| "next" [id]
 
-statement : "END"
+print-list : expr [[";"] [print-list]]
-| "GOSUB" NUMBER
-| "GOTO" expr
-| "IF" expr "THEN" (statement | expr) ["ELSE" (statement | expr)]
-| "INPUT" [print-list ";"] ID
-| ID "=" expr ; change: make "LET" opt
-| "PRINT" print-list
-| "RETURN"
 
-print-list : [expr [";" [print-list]]]
+expr : comp-expr [("and" | "or") expr]
-
-expr : comp-expr [("AND" | "OR") expr]
 
 comp-expr : sum [("=" | ">" | ">=" | "<" | "<=" | "<>") comp-expr]
 
-sum : product [("+" | "-") sum]
+sum : [sum ("+" | "-")] product
 
-product : value [("*" | "/") product]
+product : [product ("*" | "/")] power
 
-expr-list : expr ["," expr-list]*
+power : value [/"^" value]
 
-value : ID ["(" expr-list ")"]
+@value : id-val
-| "(" expr ")"
+| id-expr
+| /"(" expr /")"
+| number
 | STRING
-| NUMBER
 
+id-expr : id [/"(" expr [/"," expr]* /")"]
+
+@id : ID
+
+id-val : ["-"] id-expr
+
+number : ["-"] NUMBER

beautiful-racket/br/demo/basic/sinewave.bas

@@ -1,6 +1,19 @@
 #lang br/demo/basic
 
-1 A = 2
+10 PRINT TAB(30);"SINE WAVE"
-10 PRINT A < 2
+20 PRINT TAB(15);"CREATIVE COMPUTING  MORRISTOWN, NEW JERSEY"
-12 C$ = "string thing"
+30 PRINT: PRINT: PRINT: PRINT: PRINT
-15 PRINT A;: PRINT C$
+40 REMARKABLE PROGRAM BY DAVID AHL
+50 B=0
+100 REM  START LONG LOOP
+110 FOR T=0 TO 40 STEP .25
+120 A=INT(26+25*SIN(T))
+130 PRINT TAB(A);
+140 IF B=1 THEN 180
+150 PRINT "CREATIVE"
+160 B=1
+170 GOTO 200
+180 PRINT "COMPUTING"
+190 B=0
+200 NEXT T
+999 END

beautiful-racket/br/demo/basic/tabs.bas

@@ -0,0 +1,5 @@
+#lang br/demo/basic
+
+5 print 30; "foo"
+10 PRINT TAB(10);"*";
+20 PRINT TAB(15);"*";

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

@@ -6,28 +6,29 @@
 
 (define-lex-abbrevs
   (natural (repetition 1 +inf.0 numeric))
-  (number (union (seq (? "-") natural)
+;; don't lex the leading "-": muddles "-X" and "Y-X"
-                 (seq (? "-") (? natural) (seq "." natural))))
+  (number (union (seq natural)
+                 (seq (? natural) (seq "." natural))))
   (quoted-string (seq "\"" (repetition 0 +inf.0 (char-complement "\"")) "\"")))
 
 (define (tokenize input-port)
   (define (next-token)
     (define get-token
-      (lexer
+      (lexer-src-pos
        [(eof) eof]
-       [(union #\tab #\space
+       [(seq "/*" (complement (seq any-string "*/" any-string)) "*/") (get-token input-port)]
-               (seq number " REM" (repetition 1 +inf.0 (char-complement #\newline)) #\newline)) (get-token input-port)]
+       [(union #\tab #\space #\newline
-       [(seq #\newline (repetition 0 +inf.0 whitespace)) (token 'CR "cr")]
+               (seq number " REM" (repetition 0 +inf.0 (char-complement #\newline)) #\newline)) (get-token input-port)]
-       [(union "PRINT" "FOR" "TO" "STEP" "IF" "GOTO"
+       [(union "PRINT" "print" "FOR" "for" "TO" "to" "STEP" "step" "IF" "if"
-               "INPUT" "LET" "NEXT"  "RETURN"
+               "GOTO" "goto" "INPUT" "input" "LET" "let" "NEXT" "next"
-               "CLEAR" "LIST" "RUN" "END"
+               "RETURN" "return" "CLEAR" "clear" "LIST" "list" "RUN" "run"
-               "THEN" "ELSE" "GOSUB" "AND" "OR"
+               "END" "end" "THEN" "then" "ELSE" "else" "GOSUB" "gosub"
-               ";" "=" "(" ")" "+" "-" "*" "/"
+               "AND" "and" "OR" "or" "STOP" "stop" "LET" "let" "DEF" "def" "DIM" "dim" "ON" "on"
-               "<=" ">=" "<>" "<" ">" "=" ":") lexeme]
+               ";" "=" "(" ")" "+" "-" "*" "/" "^"
-       [(union ",") (get-token input-port)]
+               "<=" ">=" "<>" "<" ">" "=" ":" ",") (string-downcase lexeme)]
        [number (token 'NUMBER (string->number lexeme))]
-       [(seq (repetition 1 +inf.0 upper-case) (? "$")) (token 'ID (string->symbol lexeme))]
+       [(seq upper-case (repetition 0 +inf.0 (or upper-case numeric)) (? "$")) (token 'ID (string->symbol lexeme))]
-       [upper-case (token 'UPPERCASE (string->symbol lexeme))]
        [quoted-string (token 'STRING (string-trim lexeme "\""))]))
     (get-token input-port))  
   next-token)
+

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

@@ -1,3 +1,3 @@
 #lang reader "bf-reader.rkt"
 Greatest language ever!
-++++++++[>++++++++<-]>.
+++++-+++-++-++[>++++-+++-++-++<-]>.[

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

@@ -0,0 +1,39 @@
+#lang br/quicklang
+ 
+(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-ARG ...)
+  #'(void OP-OR-LOOP-ARG ...))
+(provide bf-program)
+
+(define-macro (loop "[" OP-OR-LOOP-ARG ... "]")
+  #'(until (zero? (current-byte))
+           OP-OR-LOOP-ARG ...))
+(provide loop)
+
+(define-macro-cases op
+  [(op ">") #'(gt)]
+  [(op "<") #'(lt)]
+  [(op "+") #'(plus)]
+  [(op "-") #'(minus)]
+  [(op ".") #'(period)]
+  [(op ",") #'(comma)])
+(provide op)
+
+(define arr (make-vector 30000 0))
+(define ptr 0)
+
+(define (current-byte) (vector-ref arr ptr))
+
+(define (set-current-byte! val) (vector-set! arr ptr val))
+
+(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)))
+

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

@@ -1,36 +1,60 @@
-#lang br
+#lang br/quicklang
  
-(define #'(bf-module-begin _PARSE-TREE ...)
+(define-macro (bf-module-begin PARSE-TREE)
   #'(#%module-begin
-     _PARSE-TREE ...)) 
+     PARSE-TREE))
-(provide (rename-out [bf-module-begin #%module-begin])
+(provide (rename-out [bf-module-begin #%module-begin]))
-         #%top-interaction)
 
-(define #'(bf-program _OP-OR-LOOP ...)
+(define (fold-funcs apl bf-funcs)
-  #'(begin _OP-OR-LOOP ...))
+  (for/fold ([current-apl apl])
+            ([bf-func (in-list bf-funcs)])
+    (apply bf-func current-apl)))
+
+(define-macro (bf-program OP-OR-LOOP-ARG ...)
+  #'(begin
+      (define first-apl (list (make-vector 30000 0) 0))
+      (void (fold-funcs first-apl (list OP-OR-LOOP-ARG ...)))))
 (provide bf-program)
 
-(define-cases #'op
+(define-macro (loop "[" OP-OR-LOOP-ARG ... "]")
-  [#'(op ">") #'(move-pointer 1)]
+  #'(lambda (arr ptr)
-  [#'(op "<") #'(move-pointer -1)]
+      (for/fold ([current-apl (list arr ptr)])
-  [#'(op "+") #'(set-current-byte! (add1 (get-current-byte)))]
+                ([i (in-naturals)]
-  [#'(op "-") #'(set-current-byte! (sub1 (get-current-byte)))]
+                 #:break (zero? (apply current-byte
-  [#'(op ".") #'(write-byte (get-current-byte))]
+                                       current-apl)))
-  [#'(op ",") #'(set-current-byte! (read-byte))])
+        (fold-funcs current-apl (list OP-OR-LOOP-ARG ...)))))
+(provide loop)
+
+(define-macro-cases op
+  [(op ">") #'gt]
+  [(op "<") #'lt]
+  [(op "+") #'plus]
+  [(op "-") #'minus]
+  [(op ".") #'period]
+  [(op ",") #'comma])
 (provide op)
 
-(define bf-vector (make-vector 30000 0))
+(define (current-byte arr ptr) (vector-ref arr ptr))
-(define bf-pointer 0)
 
-(define (move-pointer how-far)
+(define (set-current-byte arr ptr val)
-  (set! bf-pointer (+ bf-pointer how-far)))
+  (vector-set! arr ptr val)
+  arr)
 
-(define (get-current-byte)
+(define (gt arr ptr) (list arr (add1 ptr)))
-  (vector-ref bf-vector bf-pointer))
+(define (lt arr ptr) (list arr (sub1 ptr)))
-(define (set-current-byte! val)
+
-  (vector-set! bf-vector bf-pointer val))
+(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 #'(loop "[" _OP-OR-LOOP ... "]")
-  #'(until (zero? (get-current-byte))
-           _OP-OR-LOOP ...))
-(provide loop)

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

@@ -1,21 +1,20 @@
-#lang br
+#lang br/quicklang
-(require parser-tools/lex brag/support)
-(define (tokenize input-port)
-  (define (next-token)
-    (define get-token
-      (lexer
-       [(char-set "><-.,+[]") lexeme]
-       [(char-complement (char-set "><-.,+[]")) 
-         (token 'OTHER #:skip? #t)]
-       [(eof) eof]))
-    (get-token input-port))  
-  next-token)
-
 (require "bf-parser.rkt")
-(define (read-syntax source-path input-port)
+
-  (define parse-tree (parse source-path (tokenize input-port)))
+(define (read-syntax path port)
-  (strip-context
+  (define parse-tree (parse path (tokenize port)))
-    (inject-syntax ([#'PARSE-TREE parse-tree])
+  (define module-datum `(module bf-mod br/demo/bf/bf-expander
-                  #'(module bf-mod br/demo/bf/bf-expander
+                          ,parse-tree))
-                      PARSE-TREE))))
+  (datum->syntax #f module-datum))
 (provide read-syntax)
+
+(require parser-tools/lex brag/support)
+(define (tokenize port)
+  (define (next-token)
+    (define our-lexer
+      (lexer
+       [(eof) eof]
+       [(char-set "><-.,+[]") lexeme]
+       [any-char (next-token)]))
+    (our-lexer port))  
+  next-token)

beautiful-racket/br/demo/chip8.rkt

@@ -3,7 +3,7 @@
 ; http://devernay.free.fr/hacks/chip8/C8TECH10.HTM
 ; http://mattmik.com/files/chip8/mastering/chip8.html
 
-(define (explode-bytes val)
+(define (split-bytes val)
   (cond
     [(zero? val) (list 0)]
     [else
@@ -17,60 +17,95 @@
 
 (module+ test
   (require rackunit)
-  (check-equal? (explode-bytes #x2B45) (list #x2 #xB #x4 #x5))
+  (check-equal? (split-bytes #x2B45) (list #x2 #xB #x4 #x5))
-  (check-equal? (explode-bytes #xCD) (list #xC #xD))
+  (check-equal? (split-bytes #xCD) (list #xC #xD))
-  (check-equal? (explode-bytes #xA) (list #xA))
+  (check-equal? (split-bytes #xA) (list #xA))
-  (check-equal? (explode-bytes #x0) (list #x0)))
+  (check-equal? (split-bytes #x0) (list #x0)))
 
-(define (glue-bytes bytes)
+(define (join-bytes bytes)
   (for/sum ([b (in-list (reverse bytes))]
             [i (in-naturals)])
            (* b (expt 16 i))))
 
 (module+ test
-  (check-equal? #x2B45 (glue-bytes (list #x2 #xB #x4 #x5)))
+  (check-equal? #x2B45 (join-bytes (list #x2 #xB #x4 #x5)))
-  (check-equal? #xCD (glue-bytes (list #xC #xD)))
+  (check-equal? #xCD (join-bytes (list #xC #xD)))
-  (check-equal? #xA (glue-bytes (list #xA)))
+  (check-equal? #xA (join-bytes (list #xA)))
-  (check-equal? #x0 (glue-bytes (list #x0))))
+  (check-equal? #x0 (join-bytes (list #x0))))
 
-(define-syntax (define-memory-vector stx)
+(define-macro (define-memory-vector ID [FIELD LENGTH SIZE] ...)
-  (syntax-case stx ()
+  (with-pattern
-    [(_ ID [FIELD LENGTH SIZE] ...)
+   ([(PREFIXED-ID ...)  (prefix-id #'ID "-" #'(FIELD ...))]
-     (with-syntax ([(ID-FIELD-REF ...) (map (λ(field) (format-id stx "~a-~a-ref" #'ID field)) (syntax->list #'(FIELD ...)))]
+    [(PREFIXED-ID-REF ...) (suffix-id #'(PREFIXED-ID ...) "-ref")]
-                   [(ID-FIELD-SET! ...) (map (λ(field) (format-id stx "~a-~a-set!" #'ID field)) (syntax->list #'(FIELD ...)))]
+    [(PREFIXED-ID-SET! ...) (suffix-id #'(PREFIXED-ID ...) "-set!")]
-                   [(FIELD-OFFSET ...) (reverse (cdr
+    [(FIELD-OFFSET ...) (reverse (cdr
-                                                 (for/fold ([offsets '(0)])
+                                  (for/fold ([accum-stxs (list #'0)])
-                                                           ([len (in-list (syntax->list #'(LENGTH ...)))]
+                                            ([len-size-stx (in-list (syntax->list #'((LENGTH SIZE) ...)))])
-                                                            [size (in-list  (syntax->list #'(SIZE ...)))])
+                                    (cons (with-pattern
-                                                   (cons (+ (syntax-local-eval #`(* #,len #,size)) (car offsets)) offsets))))])
+                                           ([accum (car accum-stxs)]
-       #'(begin
+                                            [(len size) len-size-stx])
-           (define ID (make-vector (+ (* LENGTH SIZE) ...)))
+                                           #'(+ (* len size) accum)) accum-stxs))))])
-           (define (ID-FIELD-REF idx)
+   #'(begin
-             (unless (< idx LENGTH)
+       (define ID (make-vector (+ (* LENGTH SIZE) ...)))
-               (raise-argument-error 'ID-FIELD-REF (format "index less than field length ~a" LENGTH) idx))
+       (define (PREFIXED-ID-REF idx)
-             (glue-bytes
+         (unless (< idx LENGTH)
-              (for/list ([i (in-range SIZE)])
+           (raise-argument-error 'PREFIXED-ID-REF (format "index less than field length ~a" LENGTH) idx))
-                        (vector-ref ID (+ FIELD-OFFSET i idx)))))
+         (join-bytes
-           ...
+          (for/list ([i (in-range SIZE)])
-           (define (ID-FIELD-SET! idx val)
+                    (vector-ref ID (+ FIELD-OFFSET i idx)))))
-             (unless (< idx LENGTH)
+       ...
-               (raise-argument-error 'ID-FIELD-SET! (format "index less than field length ~a" LENGTH) idx))
+       (define (PREFIXED-ID-SET! idx val)
-             (unless (< val (expt 16 SIZE))
+         (unless (< idx LENGTH)
-               (raise-argument-error 'ID-FIELD-SET! (format "value less than field size ~a" (expt 16 SIZE)) val))
+           (raise-argument-error 'PREFIXED-ID-SET! (format "index less than field length ~a" LENGTH) idx))
-             (for ([i (in-range SIZE)]
+         (unless (< val (expt 16 SIZE))
-                   [b (in-list (explode-bytes val))])
+           (raise-argument-error 'PREFIXED-ID-SET! (format "value less than field size ~a" (expt 16 SIZE)) val))
-                  (vector-set! ID (+ FIELD-OFFSET i idx) b))) ...))]))
+         (for ([i (in-range SIZE)]
+               [b (in-list (split-bytes val))])
+              (vector-set! ID (+ FIELD-OFFSET i idx) b))) ...)))
 
-(define-memory-vector chip 
+(define-memory-vector chip8 
   [opcode 1 2] ; two bytes
   [memory 4096 1] ; one byte per
   [V 16 1] ; one byte per
-  [I 3 1] ; index register, 0x000 to 0xFFF
+  [I 2 1] ; index register, 0x000 to 0xFFF (1.5 bytes)
-  [pc 3 1] ; program counter, 0x000 to 0xFFF
+  [pc 2 1] ; program counter, 0x000 to 0xFFF (1.5 bytes)
   [gfx (* 64 32) 1] ; pixels
   [delay_timer 1 1]
   [sound_timer 1 1]
   [stack 16 2] ; 2 bytes each
-  [sp 1 1] ; stack pointer
+  [sp 1 2] ; stack pointer
   [key 16 1]) ; keys
 
+;; Set up render system and register input callbacks
+;(setup-graphics chip8)
+;(setup-input chip8)
+
+;; Initialize the Chip8 system and load the game into the memory
+#;(define (initialize c)
+  ;; Initialize registers and memory once
+  )
+
+;(initialize chip8)
+;(load-game chip8 "pong")
+
+
+#;(define (emulate-cycle c)
+;    // Fetch Opcode
+;  // Decode Opcode
+;  // Execute Opcode
+; 
+;  // Update timers
+
+    )
+
+;; Emulation loop
+#;(let loop ()
+  ;; Emulate one cycle
+  (emulate-cycle chip8)
+  ;; If the draw flag is set, update the screen
+  (when (draw-flag? chip8)
+    (draw-graphics chip8))
+  
+  ;; Store key press state (Press and Release)
+  (set-keys chip8)
+  (loop))

beautiful-racket/br/demo/funstacker-h2.rkt

@@ -0,0 +1,33 @@
+#lang br/quicklang
+
+(define (read-syntax path port)
+  (define args (port->lines port))
+  (define arg-datums (filter-not void? (format-datums '~a args)))
+  (define module-datum `(module stacker-mod br/demo/funstacker
+                          (nestify null ,@arg-datums)))
+  (datum->syntax #f module-datum))
+(provide read-syntax)
+
+(define-macro (stacker-module-begin HANDLE-ARGS-EXPR)
+  #'(#%module-begin
+     (display (first HANDLE-ARGS-EXPR))))
+(provide (rename-out [stacker-module-begin #%module-begin]))
+
+(require (for-syntax sugar/debug))
+(define-macro-cases nestify
+  [(nestify ARG0) #'ARG0]
+  [(nestify ARG0 ARG1 ARG ...) #'(nestify (h3 ARG0 ARG1) ARG ...)])
+(provide nestify)
+     
+(define (h3 stack arg)
+  (cond
+    [(number? arg) (cons arg stack)]
+    [(or (equal? * arg) (equal? + arg))
+     (define op-result (arg (first stack) (second stack)))
+     (cons op-result (drop stack 2))]))
+
+(provide + * null)
+
+(module+ test 
+  (require rackunit)
+  #;(check-equal? (with-output-to-string (λ () (dynamic-require "funstacker-test.rkt" #f))) "36"))

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

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

beautiful-racket/br/demo/funstacker.rkt

@@ -0,0 +1,31 @@
+#lang br/quicklang
+
+(define (read-syntax path port)
+  (define args (port->lines port))
+  (define arg-datums (format-datums '~a args))
+  (define module-datum `(module stacker-mod br/demo/funstacker
+                          (handle-args ,@arg-datums)))
+  (datum->syntax #f module-datum))
+(provide read-syntax)
+
+(define-macro (funstacker-module-begin HANDLE-ARGS-EXPR)
+  #'(#%module-begin
+     (display (first HANDLE-ARGS-EXPR))))
+(provide (rename-out [funstacker-module-begin #%module-begin]))
+
+(define (handle-args . args)
+  (for/fold ([stack-acc empty])
+            ([arg (filter-not void? args)])
+    (cond
+      [(number? arg) (cons arg stack-acc)]
+      [(or (equal? * arg) (equal? + arg))
+       (define op-result
+         (arg (first stack-acc) (second stack-acc)))
+       (cons op-result (drop stack-acc 2))])))
+(provide handle-args)
+
+(provide + *)
+
+(module+ test 
+  (require rackunit)
+  (check-equal? (with-output-to-string (λ () (dynamic-require "funstacker-test.rkt" #f))) "36"))

beautiful-racket/br/demo/hdl-tst/expander.rkt

@@ -1,84 +1,100 @@
-#lang br
+#lang br/quicklang
-(provide #%top-interaction #%module-begin #%datum (rename-out [my-top #%top]) #%app
+(require (for-syntax br/syntax racket/string) rackunit racket/file)
-         (all-defined-out))
+(provide #%module-begin (all-defined-out))
 
-; #%app and #%datum have to be present to make #%top work
-(define #'(my-top . id)
-  #'(begin
-      (displayln (format "got unbound identifier: ~a" 'id))
-      (procedure-rename (λ xs (cons 'id xs)) (string->symbol (format "undefined:~a" 'id)))))
 
-(define-inverting #'(tst-program _arg ...)
+(define (print-cell val fmt)
-  #'(begin 
+  (match-define (list _ radix-letter number-strings) (regexp-match #px"^%(.)(.*)$" fmt)) ; like %B1.16.1
-      _arg ...))
+  (match-define (list left-margin width right-margin) (map string->number (string-split number-strings ".")))
+  (cond
+    [(number? val)
+     (define radix (case radix-letter
+                     [("B") 2]))
+     (string-append (make-string left-margin #\space)
+                    (~r val #:min-width width #:pad-string "0" #:base radix)
+                    (make-string right-margin #\space))]
+    [(string? val) (~a val #:min-width (+ left-margin width right-margin) #:pad-string " " #:align 'center)]
+    [else (error 'unknown-value)]))
 
-(define-for-syntax output-here #'output-here)
 
-(define-inverting #'(header-expr (_filename-string _procname) (_colid ... _outid) ";")
+(define (print-line output-filename cells)
-  (inject-syntax ([#'shared-procname (shared-syntax #'_procname)]
+  (with-output-to-file output-filename
-                  [#'output (shared-syntax 'output)])
+    (λ () (printf (format "~a\n" (string-join cells "|" #:before-first "|" #:after-last "|"))))
+    #:mode 'text
+    #:exists 'append))
+
+(module+ test
+  (require rackunit)
+  (define a 123)
+  (check-equal? (print-cell a "%B1.16.1") " 0000000001111011 ")
+  (check-equal? (print-cell "out" "%B1.16.1") "       out        ")
+  (check-equal? (print-cell "out" "%B3.1.3") "  out  ")
+  (check-equal? (print-cell "in" "%B3.1.3") "  in   "))
+
+
+(define-for-syntax chip-prefix #f)
+
+
+(define-macro (tst-program EXPR ...)
+  (with-shared-id
+   (compare-files)
+   #'(begin
+       EXPR ...
+       (compare-files))))
+
+
+(define-macro (load-expr CHIPFILE-STRING)
+  (set! chip-prefix (string-replace (syntax->datum #'CHIPFILE-STRING) ".hdl" ""))
+  (with-pattern
+   ([CHIPFILE.RKT (format-string "~a.rkt" #'CHIPFILE-STRING)])
+   #'(require CHIPFILE.RKT)))
+
+
+(define-macro (output-file-expr OUTPUT-FILE-STRING)
+  (with-shared-id
+   (output-file output-filename)
+   #'(begin
+       (define output-filename OUTPUT-FILE-STRING)
+       (with-output-to-file output-filename
+         (λ () (printf ""))
+         #:mode 'text
+         #:exists 'replace))))
+
+
+(define-macro (compare-to-expr COMPARE-FILE-STRING)
+  (with-shared-id
+   (compare-files output-filename)
+   #'(define (compare-files)
+       (check-equal? (file->lines output-filename) (file->lines COMPARE-FILE-STRING)))))
+
+
+(define-macro (output-list-expr (COL-NAME FORMAT-SPEC) ...)
+  (with-shared-id
+   (eval-result eval-chip output output-filename)
+   (with-pattern
+    ([(COL-ID ...) (suffix-id #'(COL-NAME ...))]
+     [(CHIP-COL-ID ...) (prefix-id chip-prefix "-" #'(COL-NAME ...))])
     #'(begin
-        (provide (all-defined-out))
+        (define (output COL-ID ...)
-        (define shared-procname (dynamic-require (findf file-exists? (list _filename-string (format "~a.rkt" _filename-string))) 'shared-procname))
+          (print-line output-filename (map print-cell (list COL-ID ...) (list FORMAT-SPEC ...))))
-        (display-header '_colid ... '_outid)
+        (define eval-result #f)
-        (define _colid (make-parameter 0)) ...
+        (define (eval-chip) (list (CHIP-COL-ID) ...))
-        (define (_outid)
+        (output COL-NAME ...)))))
-          (keyword-apply shared-procname
-                         (map (compose1 string->keyword symbol->string) (list '_colid ...))
-                         (list (_colid) ...) null))
-        
-        (define (output)
-          (display-values (_colid) ... (_outid))))))
-
-(define-inverting #'(load-expr "load" (_filename-string _procname) ",")
-  #'(_filename-string _procname))
-
-(define #'(filename _filename)
-  (inject-syntax ([#'filename-string (symbol->string (syntax->datum #'_filename))]
-                  [#'proc-name (string->symbol (cadr (regexp-match #rx"^(.*)\\.hdl$"(symbol->string (syntax->datum #'_filename)))))])
-                 #'(filename-string proc-name)))
-
-(define-inverting #'(table-expr "output-list" _column-id ...)
-  #'(_column-id ...))
-
-(define-cases #'column-id
-  [#'(_ _colid) #'_colid]
-  [#'(_ _colid ",") #'_colid])
 
 
-(define #'(display-header _sym ...)
+(define-macro (set-expr IN-BUS IN-VAL)
-  #'(begin
+  (with-pattern
-      (apply display-values (list _sym ...))
+   ([CHIP-IN-BUS-ID-WRITE (prefix-id chip-prefix "-" (suffix-id #'IN-BUS "-write"))])
-      (apply display-dashes (list _sym ...))))
+   #'(CHIP-IN-BUS-ID-WRITE IN-VAL)))
-
-(define (vals->text vals)
-  (string-join (map ~a vals) " | "))
-
-(define (display-values . vals)
-  (displayln (vals->text vals)))
-
-(define (display-dashes . vals)
-  (displayln (make-string (string-length (vals->text vals)) #\-)))
 
 
-(define-inverting #'(test-expr _step-expr ... ";")
+(define-macro (eval-expr)
-  #'(begin
+  (with-shared-id
-      _step-expr ...))
+   (eval-result eval-chip)
+   #'(set! eval-result (eval-chip))))
 
 
-(define-cases #'step-expr
+(define-macro (output-expr)
-  [#'(_ _step) #'_step]
+  (with-shared-id
-  [#'(_ _step ",") #'_step])
+   (output eval-result)
-
+   #'(apply output eval-result)))
-
-(define #'(set-expr "set" _id _val)
-  #'(_id _val))
-
-
-(define #'(eval-expr "eval")
-  #'(void))
-
-
-(define #'(output-expr "output")
-  (inject-syntax ([#'output (shared-syntax 'output)])
-  #'(output)))

beautiful-racket/br/demo/hdl-tst/hdlprint.rkt

@@ -1,19 +0,0 @@
-#lang racket
-
-
-(define (hdlprint val fmt)
-  (match-define (list _ radix-letter number-strings) (regexp-match #px"^%(.)(.*)$" fmt)) ; like %B1.16.1
-  (match-define (list left-margin width right-margin) (map string->number (string-split number-strings ".")))
-  (define radix (case radix-letter
-                  [("B") 2]))
-  (string-append (make-string left-margin #\space)
-                 (if (number? val)
-                     (~r val #:min-width width #:pad-string "0" #:base radix)
-                     (~a val #:min-width width #:pad-string " " #:align 'center))
-                 (make-string right-margin #\space)))
-
-(module+ test
-(require rackunit)
-(define a 123)
-(check-equal? (hdlprint a "%B1.16.1") " 0000000001111011 ")
-(check-equal? (hdlprint "out" "%B1.16.1") "       out        "))

beautiful-racket/br/demo/hdl-tst/parser.rkt

@@ -1,23 +1,23 @@
 #lang brag
 
-tst-program : header-expr test-expr*
+tst-program : load-expr output-file-expr compare-to-expr output-list-expr /";" test-expr*
 
-header-expr : load-expr table-expr ";"
+load-expr : /"load" ID /","
 
-load-expr : "load" filename ","
+output-file-expr : /"output-file" ID /","
 
-filename : ID
+compare-to-expr : /"compare-to" ID /","
 
-table-expr : "output-list" column-id+
+output-list-expr : /"output-list" column [column]+
 
-column-id :  ID [","]
+/column :  ID FORMAT-STRING
 
-test-expr : step-expr+ ";"
+@test-expr : step-expr+ /";"
 
-step-expr : (set-expr | eval-expr | output-expr) [","]
+@step-expr : (set-expr | eval-expr | output-expr) [/","]
 
-set-expr : "set" ID VAL
+set-expr : /"set" ID VAL
 
-eval-expr : "eval"
+eval-expr : /"eval"
 
-output-expr : "output"
+output-expr : /"output"

beautiful-racket/br/demo/hdl-tst/tokenizer.rkt

@@ -7,15 +7,16 @@
 (define (tokenize input-port)
   (define (next-token)
     (define get-token
-      (lexer
+      (lexer-src-pos
        [(eof) eof]
         [(union
          (seq "/*" (complement (seq any-string "*/" any-string)) "*/")
          (seq "//" (repetition 1 +inf.0 (char-complement #\newline)) #\newline))
         (token 'COMMENT lexeme #:skip? #t)]
        [(union #\tab #\space #\newline) (get-token input-port)]
-       [(union "load" "output-list" "set" "eval" "output" (char-set ",;")) lexeme]
+       [(union "load" "output-list" "output-file" "compare-to" "set" "eval" "output" (char-set ",;")) lexeme]
+       [(seq "%" (repetition 1 +inf.0 (union alphabetic numeric (char-set ".")))) (token 'FORMAT-STRING lexeme)]
        [(repetition 1 +inf.0 numeric) (token 'VAL (string->number lexeme))]
-       [(repetition 1 +inf.0 (union alphabetic numeric (char-set "-."))) (token 'ID (string->symbol lexeme))]))
+       [(repetition 1 +inf.0 (union alphabetic numeric (char-set "-."))) (token 'ID lexeme)]))
     (get-token input-port))  
   next-token)

beautiful-racket/br/demo/hdl/And.cmp

@@ -0,0 +1,5 @@
+|   a   |   b   |  out  |
+|   0   |   0   |   0   |
+|   0   |   1   |   0   |
+|   1   |   0   |   0   |
+|   1   |   1   |   1   |

beautiful-racket/br/demo/hdl/And.out

@@ -0,0 +1,5 @@
+|   a   |   b   |  out  |
+|   0   |   0   |   0   |
+|   0   |   1   |   0   |
+|   1   |   0   |   0   |
+|   1   |   1   |   1   |

beautiful-racket/br/demo/hdl/And.tst

@@ -1,14 +0,0 @@
-#lang br/demo/hdl-tst
-
-/* and */
-
-load And.hdl,
-output-list a, b, out;
-set a 0, set b 0,
-eval, output;
-set a 0, set b 1,
-eval, output;
-set a 1, set b 0,
-eval, output;
-set a 1, set b 1,
-eval, output;

beautiful-racket/br/demo/hdl/And.tst.rkt

@@ -0,0 +1,31 @@
+#lang br/demo/hdl-tst
+
+// This file is part of www.nand2tetris.org
+// and the book "The Elements of Computing Systems"
+// by Nisan and Schocken, MIT Press.
+// File name: projects/01/And.tst
+
+load And.hdl,
+output-file And.out,
+compare-to And.cmp,
+output-list a%B3.1.3 b%B3.1.3 out%B3.1.3;
+
+set a 0,
+set b 0,
+eval,
+output;
+
+set a 0,
+set b 1,
+eval,
+output;
+
+set a 1,
+set b 0,
+eval,
+output;
+
+set a 1,
+set b 1,
+eval,
+output;

beautiful-racket/br/demo/hdl/DMux.cmp

@@ -0,0 +1,5 @@
+|  in   |  sel  |   a   |   b   |
+|   0   |   0   |   0   |   0   |
+|   0   |   1   |   0   |   0   |
+|   1   |   0   |   1   |   0   |
+|   1   |   1   |   0   |   1   |

beautiful-racket/br/demo/hdl/DMux.hdl.rkt

@@ -16,5 +16,7 @@ CHIP DMux {
     OUT a, b;
 
     PARTS:
-    Not
+    Not(in=sel, out=not-sel);
+    And(a=in, b=not-sel, out=a);
+    And(a=in, b=sel, out=b);
 }

beautiful-racket/br/demo/hdl/DMux.out

@@ -0,0 +1,5 @@
+|  in   |  sel  |   a   |   b   |
+|   0   |   0   |   0   |   0   |
+|   0   |   1   |   0   |   0   |
+|   1   |   0   |   1   |   0   |
+|   1   |   1   |   0   |   1   |

beautiful-racket/br/demo/hdl/DMux.tst

@@ -0,0 +1,27 @@
+// This file is part of www.nand2tetris.org
+// and the book "The Elements of Computing Systems"
+// by Nisan and Schocken, MIT Press.
+// File name: projects/01/DMux.tst
+
+load DMux.hdl,
+output-file DMux.out,
+compare-to DMux.cmp,
+output-list in%B3.1.3 sel%B3.1.3 a%B3.1.3 b%B3.1.3;
+
+set in 0,
+set sel 0,
+eval,
+output;
+
+set sel 1,
+eval,
+output;
+
+set in 1,
+set sel 0,
+eval,
+output;
+
+set sel 1,
+eval,
+output;

beautiful-racket/br/demo/hdl/DMux4Way-test.rkt

@@ -0,0 +1,28 @@
+#lang racket
+(require "DMux4Way.hdl.rkt")
+(require rackunit)
+
+(DMux4Way-in (random 2))
+(DMux4Way-sel #b00)
+(check-equal? (DMux4Way-a) (DMux4Way-in))
+(check-equal? (DMux4Way-b) 0)
+(check-equal? (DMux4Way-c) 0)
+(check-equal? (DMux4Way-d) 0)
+
+(DMux4Way-sel #b01)
+(check-equal? (DMux4Way-a) 0)
+(check-equal? (DMux4Way-b) (DMux4Way-in))
+(check-equal? (DMux4Way-c) 0)
+(check-equal? (DMux4Way-d) 0)
+
+(DMux4Way-sel #b10)
+(check-equal? (DMux4Way-a) 0)
+(check-equal? (DMux4Way-b) 0)
+(check-equal? (DMux4Way-c) (DMux4Way-in))
+(check-equal? (DMux4Way-d) 0)
+
+(DMux4Way-sel #b11)
+(check-equal? (DMux4Way-a) 0)
+(check-equal? (DMux4Way-b) 0)
+(check-equal? (DMux4Way-c) 0)
+(check-equal? (DMux4Way-d) (DMux4Way-in))

beautiful-racket/br/demo/hdl/DMux4Way.cmp

@@ -0,0 +1,9 @@
+| in  | sel  |  a  |  b  |  c  |  d  |
+|  0  |  00  |  0  |  0  |  0  |  0  |
+|  0  |  01  |  0  |  0  |  0  |  0  |
+|  0  |  10  |  0  |  0  |  0  |  0  |
+|  0  |  11  |  0  |  0  |  0  |  0  |
+|  1  |  00  |  1  |  0  |  0  |  0  |
+|  1  |  01  |  0  |  1  |  0  |  0  |
+|  1  |  10  |  0  |  0  |  1  |  0  |
+|  1  |  11  |  0  |  0  |  0  |  1  |

beautiful-racket/br/demo/hdl/DMux4Way.tst

@@ -0,0 +1,43 @@
+// This file is part of www.nand2tetris.org
+// and the book "The Elements of Computing Systems"
+// by Nisan and Schocken, MIT Press.
+// File name: projects/01/DMux4Way.tst
+
+load DMux4Way.hdl,
+output-file DMux4Way.out,
+compare-to DMux4Way.cmp,
+output-list in%B2.1.2 sel%B2.2.2 a%B2.1.2 b%B2.1.2 c%B2.1.2 d%B2.1.2;
+
+set in 0,
+set sel %B00,
+eval,
+output;
+
+set sel %B01,
+eval,
+output;
+
+set sel %B10,
+eval,
+output;
+
+set sel %B11,
+eval,
+output;
+
+set in 1,
+set sel %B00,
+eval,
+output;
+
+set sel %B01,
+eval,
+output;
+
+set sel %B10,
+eval,
+output;
+
+set sel %B11,
+eval,
+output;

beautiful-racket/br/demo/hdl/DMux4Way.tst.rkt

@@ -0,0 +1,45 @@
+#lang br/demo/hdl-tst
+
+// This file is part of www.nand2tetris.org
+// and the book "The Elements of Computing Systems"
+// by Nisan and Schocken, MIT Press.
+// File name: projects/01/DMux4Way.tst
+
+load DMux4Way.hdl,
+output-file DMux4Way.out,
+compare-to DMux4Way.cmp,
+output-list in%B2.1.2 sel%B2.2.2 a%B2.1.2 b%B2.1.2 c%B2.1.2 d%B2.1.2;
+
+set in 0,
+set sel %B00,
+eval,
+output;
+
+set sel %B01,
+eval,
+output;
+
+set sel %B10,
+eval,
+output;
+
+set sel %B11,
+eval,
+output;
+
+set in 1,
+set sel %B00,
+eval,
+output;
+
+set sel %B01,
+eval,
+output;
+
+set sel %B10,
+eval,
+output;
+
+set sel %B11,
+eval,
+output;

beautiful-racket/br/demo/hdl/Dmux-test.rkt

@@ -0,0 +1,23 @@
+#lang racket
+(require "DMux.hdl.rkt")
+(require rackunit)
+
+(DMux-in-write 0)
+(DMux-sel-write 0)
+(check-equal? (DMux-a) 0)
+(check-equal? (DMux-b) 0)
+
+(DMux-in-write 0)
+(DMux-sel-write 1)
+(check-equal? (DMux-a) 0)
+(check-equal? (DMux-b) 0)
+
+(DMux-in-write 1)
+(DMux-sel-write 0)
+(check-equal? (DMux-a) 1)
+(check-equal? (DMux-b) 0)
+
+(DMux-in-write 1)
+(DMux-sel-write 1)
+(check-equal? (DMux-a) 0)
+(check-equal? (DMux-b) 1)

beautiful-racket/br/demo/hdl/Dmux.tst.rkt

@@ -1,4 +1,4 @@
-#lang br/demo/hdl/tst
+#lang br/demo/hdl-tst
 
 // This file is part of www.nand2tetris.org
 // and the book "The Elements of Computing Systems"
@@ -6,10 +6,9 @@
 // File name: projects/01/DMux.tst
 
 load DMux.hdl,
-// output-file DMux.out,
+output-file DMux.out,
-// compare-to DMux.cmp,
+compare-to DMux.cmp,
-// output-list in%B3.1.3 sel%B3.1.3 a%B3.1.3 b%B3.1.3;
+output-list in%B3.1.3 sel%B3.1.3 a%B3.1.3 b%B3.1.3;
-output-list in, sel, a, b;
 
 set in 0,
 set sel 0,

beautiful-racket/br/demo/hdl/Dmux4Way.hdl.rkt

@@ -0,0 +1,32 @@
+#lang br/demo/hdl
+
+// This file is part of www.nand2tetris.org
+// and the book "The Elements of Computing Systems"
+// by Nisan and Schocken, MIT Press.
+// File name: projects/01/DMux4Way.hdl
+
+/**
+ * 4-way demultiplexor:
+ * {a, b, c, d} = {in, 0, 0, 0} if sel == 00
+ *                {0, in, 0, 0} if sel == 01
+ *                {0, 0, in, 0} if sel == 10
+ *                {0, 0, 0, in} if sel == 11
+ */
+
+CHIP DMux4Way {
+    // todo: how should sel subscripting work?
+    IN in, sel[2];
+    OUT a, b, c, d;
+
+    PARTS:
+    DMux(in=in, sel=sel[0], a=a, b=b);
+    DMux(in=in, sel=sel[1], a=c, b=d);
+    /*
+    // the right answer: note that subscripting on right always means "read this bit";
+    // subscripting on left means "write this bit"
+    // build out assignment operator
+    DMux(in=in, sel=sel[0], a=s0a, b=s0b);
+    DMux(in=s0b, sel=sel[1], a=b, b=d);
+    DMux(in=s0a, sel=sel[1], a=a, b=c);
+    */
+}

beautiful-racket/br/demo/hdl/Fanout.hdl.rkt

@@ -0,0 +1,12 @@
+#lang br/demo/hdl
+
+CHIP Fanout {
+         IN in;
+            OUT outa, outb;
+            
+            PARTS:
+            And(a=in, b=in, out=outa);
+            And(a=in, b=in, out=outb);
+            
+            }
+

beautiful-racket/br/demo/hdl/HalfAdder.cmp

@@ -0,0 +1,5 @@
+|   a   |   b   |  sum  | carry |
+|   0   |   0   |   0   |   0   |
+|   0   |   1   |   1   |   0   |
+|   1   |   0   |   1   |   0   |
+|   1   |   1   |   0   |   1   |

beautiful-racket/br/demo/hdl/HalfAdder.hdl.rkt

@@ -0,0 +1,11 @@
+#lang br/demo/hdl
+
+CHIP HalfAdder {
+    IN a, b;    // 1-bit inputs
+    OUT sum,    // Right bit of a + b 
+        carry;  // Left bit of a + b
+
+    PARTS:
+    Xor(a=a, b=b, out=sum);
+    And(a=a, b=b, out=carry);
+}

beautiful-racket/br/demo/hdl/HalfAdder.out

@@ -0,0 +1,5 @@
+|   a   |   b   |  sum  | carry |
+|   0   |   0   |   0   |   0   |
+|   0   |   1   |   1   |   0   |
+|   1   |   0   |   1   |   0   |
+|   1   |   1   |   0   |   1   |

beautiful-racket/br/demo/hdl/HalfAdder.tst.rkt

@@ -0,0 +1,31 @@
+#lang br/demo/hdl-tst
+
+// This file is part of www.nand2tetris.org
+// and the book "The Elements of Computing Systems"
+// by Nisan and Schocken, MIT Press.
+// File name: projects/02/HalfAdder.tst
+
+load HalfAdder.hdl,
+output-file HalfAdder.out,
+compare-to HalfAdder.cmp,
+output-list a%B3.1.3 b%B3.1.3 sum%B3.1.3 carry%B3.1.3;
+
+set a 0,
+set b 0,
+eval,
+output;
+
+set a 0,
+set b 1,
+eval,
+output;
+
+set a 1,
+set b 0,
+eval,
+output;
+
+set a 1,
+set b 1,
+eval,
+output;

beautiful-racket/br/demo/hdl/Mux-test.rkt

@@ -0,0 +1,39 @@
+#lang racket
+(require "Mux.hdl.rkt")
+(require rackunit)
+
+(Mux-sel-write 0)
+
+(Mux-a-write 0)
+(Mux-b-write 0)
+(check-equal? (Mux-out) (Mux-a))
+
+(Mux-a-write 0)
+(Mux-b-write 1)
+(check-equal? (Mux-out) (Mux-a))
+
+(Mux-a-write 1)
+(Mux-b-write 0)
+(check-equal? (Mux-out) (Mux-a))
+
+(Mux-a-write 1)
+(Mux-b-write 1)
+(check-equal? (Mux-out) (Mux-a))
+
+(Mux-sel-write 1)
+
+(Mux-a-write 0)
+(Mux-b-write 0)
+(check-equal? (Mux-out) (Mux-b))
+
+(Mux-a-write 0)
+(Mux-b-write 1)
+(check-equal? (Mux-out) (Mux-b))
+
+(Mux-a-write 1)
+(Mux-b-write 0)
+(check-equal? (Mux-out) (Mux-b))
+
+(Mux-a-write 1)
+(Mux-b-write 1)
+(check-equal? (Mux-out) (Mux-b))

beautiful-racket/br/demo/hdl/Mux.cmp

@@ -0,0 +1,9 @@
+|   a   |   b   |  sel  |  out  |
+|   0   |   0   |   0   |   0   |
+|   0   |   0   |   1   |   0   |
+|   0   |   1   |   0   |   0   |
+|   0   |   1   |   1   |   1   |
+|   1   |   0   |   0   |   1   |
+|   1   |   0   |   1   |   0   |
+|   1   |   1   |   0   |   1   |
+|   1   |   1   |   1   |   1   |

beautiful-racket/br/demo/hdl/Mux.hdl.rkt

@@ -12,12 +12,12 @@
  */
 
 CHIP Mux {
-    IN a, b, sel;
+    IN a, b[15], sel[8];
     OUT out;
 
     PARTS:
-    // Put your code here:
+    Not(in=sel, out=not-sel);
-    Not(in=sel, out=sel-opposite);
+    And(a=a, b=not-sel, out=a-and-not-sel);
-    And(a=a, b=sel-opposite, out=maybe-a);
+	And(a=b, b=sel, out=b-and-sel);
-    Or(a=maybe-a, b=b, out=out);
+	Or(a=a-and-not-sel, b=b-and-sel, out=out);
 }

beautiful-racket/br/demo/hdl/Mux.out

@@ -0,0 +1,9 @@
+|   a   |   b   |  sel  |  out  |
+|   0   |   0   |   0   |   0   |
+|   0   |   0   |   1   |   0   |
+|   0   |   1   |   0   |   0   |
+|   0   |   1   |   1   |   1   |
+|   1   |   0   |   0   |   1   |
+|   1   |   0   |   1   |   0   |
+|   1   |   1   |   0   |   1   |
+|   1   |   1   |   1   |   1   |

beautiful-racket/br/demo/hdl/Mux.tst

@@ -0,0 +1,49 @@
+// This file is part of www.nand2tetris.org
+// and the book "The Elements of Computing Systems"
+// by Nisan and Schocken, MIT Press.
+// File name: projects/01/Mux.tst
+
+load Mux.hdl,
+output-file Mux.out,
+compare-to Mux.cmp,
+output-list a%B3.1.3 b%B3.1.3 sel%B3.1.3 out%B3.1.3;
+
+set a 0,
+set b 0,
+set sel 0,
+eval,
+output;
+
+set sel 1,
+eval,
+output;
+
+set a 0,
+set b 1,
+set sel 0,
+eval,
+output;
+
+set sel 1,
+eval,
+output;
+
+set a 1,
+set b 0,
+set sel 0,
+eval,
+output;
+
+set sel 1,
+eval,
+output;
+
+set a 1,
+set b 1,
+set sel 0,
+eval,
+output;
+
+set sel 1,
+eval,
+output;

beautiful-racket/br/demo/hdl/Mux.tst.rkt

@@ -1,14 +1,13 @@
-#lang br/demo/hdl/tst
+#lang br/demo/hdl-tst
 // This file is part of www.nand2tetris.org
 // and the book "The Elements of Computing Systems"
 // by Nisan and Schocken, MIT Press.
 // File name: projects/01/Mux.tst
 
 load Mux.hdl,
-// output-file Mux.out,
+output-file Mux.out,
-// compare-to Mux.cmp,
+compare-to Mux.cmp,
-// output-list a%B3.1.3 b%B3.1.3 sel%B3.1.3 out%B3.1.3;
+output-list a%B3.1.3 b%B3.1.3 sel%B3.1.3 out%B3.1.3;
-output-list a, b, sel, out;
 
 set a 0,
 set b 0,

beautiful-racket/br/demo/hdl/Nand.hdl

@@ -1,13 +0,0 @@
-#lang br
-
-(define+provide (Nand #:a a #:b b)
-  (if (< (+ a b) 2)
-      1
-      0))
-
-(module+ test
-  (require rackunit)
-  (check-equal? (Nand #:a 0 #:b 0) 1)
-  (check-equal? (Nand #:a 0 #:b 1) 1)
-  (check-equal? (Nand #:a 1 #:b 0) 1)
-  (check-equal? (Nand #:a 1 #:b 1) 0))

beautiful-racket/br/demo/hdl/Nand.hdl.rkt

@@ -0,0 +1,18 @@
+#lang br
+(provide (prefix-out Nand- (all-defined-out)))
+(require "bus.rkt")
+
+(define-input-bus a)
+(define-input-bus b)
+
+(define (out . etc)
+  (if (< (+ (a) (b)) 2)
+      1
+      0))
+
+(module+ test
+  (require rackunit)
+  (check-equal? (begin (a-write 0) (b-write 0) (out)) 1)
+  (check-equal? (begin (a-write 0) (b-write 1) (out)) 1)
+  (check-equal? (begin (a-write 1) (b-write 0) (out)) 1)
+  (check-equal? (begin (a-write 1) (b-write 1) (out)) 0))

beautiful-racket/br/demo/hdl/Nand.tst.rkt

@@ -1,4 +1,4 @@
-#lang br/demo/hdl/tst
+#lang br/demo/hdl-tst
 
 /* nand */
 

beautiful-racket/br/demo/hdl/Nand2.hdl.rkt

@@ -0,0 +1,20 @@
+#lang br
+(provide (prefix-out Nand2- (all-defined-out)))
+(require "helper.rkt")
+(define a (make-input))
+(define b (make-input))
+
+
+(define (out)
+  (if (< (+ (a) (b)) 2)
+      1
+      0))
+
+(module+ test
+  (require rackunit)
+  (check-equal? (begin (a 0) (b 0) (out)) 1)
+  (check-equal? (begin (a 0) (b 1) (out)) 1)
+  (check-equal? (begin (a 1) (b 0) (out)) 1)
+  (check-equal? (begin (a 1) (b 1) (out)) 0))
+
+#;(define n (make-Nand))

beautiful-racket/br/demo/hdl/Not-sexp.rkt

@@ -0,0 +1,17 @@
+#lang s-exp br/demo/hdl/expander
+
+#|
+CHIP Not {
+          IN in;
+          OUT out;
+             
+          PARTS:
+          Nand(a=in, b=in, out=out);
+}
+|#
+
+(chip-program Not
+              (in-spec (in))
+              (out-spec (out))
+              (part Nand (a in) (b in) (out out)))
+

beautiful-racket/br/demo/hdl/Not.cmp

@@ -0,0 +1,3 @@
+|  in   |  out  |
+|   0   |   1   |
+|   1   |   0   |

beautiful-racket/br/demo/hdl/Not.hdl

@@ -1,13 +0,0 @@
-#lang br/demo/hdl
-
-CHIP Not {
-          IN in;
-          OUT out;
-             
-             PARTS:
-             Nand(a=in, b=in, out=out);
-             
-             }
-
-
-

beautiful-racket/br/demo/hdl/Not.hdl.rkt

@@ -0,0 +1,12 @@
+#lang br/demo/hdl
+
+CHIP Not {
+          IN in;
+          OUT out;
+             
+          PARTS:
+          Nand(a=in, b=in, out=out);
+}
+
+
+

beautiful-racket/br/demo/hdl/Not.out

@@ -0,0 +1,3 @@
+|  in   |  out  |
+|   0   |   1   |
+|   1   |   0   |

beautiful-racket/br/demo/hdl/Not.tst

@@ -1,10 +0,0 @@
-#lang br/demo/hdl/tst
-
-/* Not */
-
-load Not.hdl,
-output-list in, out;
-set in 0,
-eval, output;
-set in 1,
-eval, output;

beautiful-racket/br/demo/hdl/Not.tst-sexp.rkt

@@ -0,0 +1,34 @@
+#lang s-exp br/demo/hdl-tst/expander
+
+
+#|
+load Not.hdl,
+output-file Not.out,
+compare-to Not.cmp,
+output-list in%B3.1.3 out%B3.1.3;
+set in 0,
+eval,
+output;
+set in 1,
+eval,
+output;
+
+|#
+
+(require br/demo/hdl-tst/hdlprint rackunit racket/file)
+(require "Not.hdl.rkt") ; load Not.hdl,
+(define of (open-output-file "Not.out" #:mode 'text #:exists 'replace)) ; output-file Not.out,
+(define (output in out) ; output-list in%B3.1.3 out%B3.1.3;
+(fprintf of (format "~a\n" (string-join (list (hdlprint in "%B3.1.3") (hdlprint out "%B3.1.3")) "|" #:before-first "|" #:after-last "|"))))  
+(define eval-result #f)
+(define eval-thunk (λ () (list (Not-in) (Not-out)))) ; output-list in%B3.1.3 out%B3.1.3;
+(output "in" "out") ; put names at top of output
+(Not-in-write 0) ; set in 0,
+(set! eval-result (eval-thunk)) ; eval,
+(apply output eval-result) ; output;
+(Not-in-write 1) ; set in 1,
+(set! eval-result (eval-thunk)) ; eval,
+(apply output eval-result) ; output;
+(close-output-port of)
+(display (file->string "Not.out"))
+(check-equal? (file->lines "Not.out") (file->lines "Not.cmp")) ; compare-to Not.cmp,

beautiful-racket/br/demo/hdl/Not.tst.rkt

@@ -0,0 +1,14 @@
+#lang br/demo/hdl-tst
+
+load Not.hdl,
+output-file Not.out,
+compare-to Not.cmp,
+output-list in%B3.1.3 out%B3.1.3;
+
+set in 0,
+eval,
+output;
+
+set in 1,
+eval,
+output;

beautiful-racket/br/demo/hdl/Or.cmp

@@ -0,0 +1,5 @@
+|   a   |   b   |  out  |
+|   0   |   0   |   0   |
+|   0   |   1   |   1   |
+|   1   |   0   |   1   |
+|   1   |   1   |   1   |

beautiful-racket/br/demo/hdl/Or.out

@@ -0,0 +1,5 @@
+|   a   |   b   |  out  |
+|   0   |   0   |   0   |
+|   0   |   1   |   1   |
+|   1   |   0   |   1   |
+|   1   |   1   |   1   |

beautiful-racket/br/demo/hdl/Or.tst

@@ -1,14 +1,29 @@
-#lang br/demo/hdl/tst
+// This file is part of www.nand2tetris.org
-
+// and the book "The Elements of Computing Systems"
-/* or */
+// by Nisan and Schocken, MIT Press.
+// File name: projects/01/Or.tst
 
 load Or.hdl,
-output-list a, b, out;
+output-file Or.out,
-set a 0, set b 0,
+compare-to Or.cmp,
-eval, output;
+output-list a%B3.1.3 b%B3.1.3 out%B3.1.3;
-set a 0, set b 1,
+
-eval, output;
+set a 0,
-set a 1, set b 0,
+set b 0,
-eval, output;
+eval,
-set a 1, set b 1,
+output;
-eval, output;
+
+set a 0,
+set b 1,
+eval,
+output;
+
+set a 1,
+set b 0,
+eval,
+output;
+
+set a 1,
+set b 1,
+eval,
+output;

beautiful-racket/br/demo/hdl/Or.tst.rkt

@@ -0,0 +1,30 @@
+#lang br/demo/hdl-tst
+// This file is part of www.nand2tetris.org
+// and the book "The Elements of Computing Systems"
+// by Nisan and Schocken, MIT Press.
+// File name: projects/01/Or.tst
+
+load Or.hdl,
+output-file Or.out,
+compare-to Or.cmp,
+output-list a%B3.1.3 b%B3.1.3 out%B3.1.3;
+
+set a 0,
+set b 0,
+eval,
+output;
+
+set a 0,
+set b 1,
+eval,
+output;
+
+set a 1,
+set b 0,
+eval,
+output;
+
+set a 1,
+set b 1,
+eval,
+output;

beautiful-racket/br/demo/hdl/Toffoli.hdl.rkt

@@ -0,0 +1,13 @@
+#lang br/demo/hdl
+
+CHIP And {
+          IN a, b;
+             OUT out;
+             
+             PARTS:
+             Nand(a=a, b=b, out=nandout);
+             Not(in=nandout, out=out);
+             }
+
+
+

beautiful-racket/br/demo/hdl/Xor.cmp

@@ -0,0 +1,5 @@
+|   a   |   b   |  out  |
+|   0   |   0   |   0   |
+|   0   |   1   |   1   |
+|   1   |   0   |   1   |
+|   1   |   1   |   0   |

beautiful-racket/br/demo/hdl/Xor.out

@@ -0,0 +1,5 @@
+|   a   |   b   |  out  |
+|   0   |   0   |   0   |
+|   0   |   1   |   1   |
+|   1   |   0   |   1   |
+|   1   |   1   |   0   |

beautiful-racket/br/demo/hdl/Xor.tst

@@ -1,12 +1,29 @@
-#lang br/demo/hdl/tst
+// This file is part of www.nand2tetris.org
+// and the book "The Elements of Computing Systems"
+// by Nisan and Schocken, MIT Press.
+// File name: projects/01/Xor.tst
 
 load Xor.hdl,
-output-list a, b, out;
+output-file Xor.out,
-set a 0, set b 0,
+compare-to Xor.cmp,
-eval, output;
+output-list a%B3.1.3 b%B3.1.3 out%B3.1.3;
-set a 0, set b 1,
+
-eval, output;
+set a 0,
-set a 1, set b 0,
+set b 0,
-eval, output;
+eval,
-set a 1, set b 1,
+output;
-eval, output;
+
+set a 0,
+set b 1,
+eval,
+output;
+
+set a 1,
+set b 0,
+eval,
+output;
+
+set a 1,
+set b 1,
+eval,
+output;

beautiful-racket/br/demo/hdl/Xor.tst.rkt

@@ -0,0 +1,31 @@
+#lang br/demo/hdl-tst
+
+// This file is part of www.nand2tetris.org
+// and the book "The Elements of Computing Systems"
+// by Nisan and Schocken, MIT Press.
+// File name: projects/01/Xor.tst
+
+load Xor.hdl,
+output-file Xor.out,
+compare-to Xor.cmp,
+output-list a%B3.1.3 b%B3.1.3 out%B3.1.3;
+
+set a 0,
+set b 0,
+eval,
+output;
+
+set a 0,
+set b 1,
+eval,
+output;
+
+set a 1,
+set b 0,
+eval,
+output;
+
+set a 1,
+set b 1,
+eval,
+output;

beautiful-racket/br/demo/hdl/bus-properties.rkt

@@ -0,0 +1,11 @@
+#lang br
+(provide (all-defined-out))
+
+(define-values (bus bus? bus-get)
+  (make-impersonator-property 'bus))
+
+(define-values (output-bus output-bus? output-bus-get)
+  (make-impersonator-property 'output-bus))
+
+(define-values (input-bus input-bus? input-bus-get)
+  (make-impersonator-property 'input-bus))

beautiful-racket/br/demo/hdl/bus.rkt

@@ -0,0 +1,257 @@
+#lang br
+(require racket/list (for-syntax br/syntax) racket/splicing "bus-properties.rkt")
+(provide (all-defined-out))
+
+(module+ test
+  (require rackunit))
+
+(define (bitwise-bit-set x bit)
+  (if (not (bitwise-bit-set? x bit))
+      (bitwise-ior x (expt 2 bit))
+      x))
+
+(define (bitwise-bit-unset x bit)
+  (if (bitwise-bit-set? x bit)
+      (bitwise-and x (bitwise-not (expt 2 bit)))
+      x))
+
+(module+ test
+  (define x-bitset (string->number "1011" 2)) ; decimal 11
+  (check-true (bitwise-bit-set? x-bitset 0))
+  (check-true (bitwise-bit-set? x-bitset 1))
+  (check-false (bitwise-bit-set? x-bitset 2))
+  (check-true (bitwise-bit-set? x-bitset 3))
+  (set! x-bitset (bitwise-bit-set x-bitset 2))
+  (check-true (bitwise-bit-set? x-bitset 2))
+  (set! x-bitset (bitwise-bit-unset x-bitset 2))
+  (check-false (bitwise-bit-set? x-bitset 2)))
+
+(define (bus-range start [finish start])
+  (range start (add1 finish)))
+
+(define (integer->bitvals int width)
+  (reverse (for/list ([i (in-range width)])
+                     (bitwise-bit-field int i (add1 i)))))
+
+(define max-bus-width 64)
+(define default-bus-width 1)
+
+
+(define (check-bit-against-width bus-name bit width)
+  (unless (< bit width)
+    (raise-argument-error bus-name (format "bit less than bus width ~a" width) bit)))
+
+(define (check-val-against-width bus-name val width)
+  (when (and val (> val (sub1 (expt 2 width))))
+    (raise-argument-error bus-name
+                          (format "~a-bit value (0 to ~a inclusive)" width (sub1 (expt 2 width))) val)))
+
+
+(define (make-bus-reader reader-name width)
+  (define-cases bus-reader-func
+    [(_ id-thunk-val) (bus-reader-func id-thunk-val 0 (sub1 width))]
+    [(_ id-thunk-val bit) (bus-reader-func id-thunk-val bit bit)]
+    [(_ id-thunk-val first-bit last-bit)
+     (unless (<= first-bit last-bit)
+       (raise-argument-error reader-name (format "last bit greater than or equal to first bit ~a" first-bit) last-bit))
+     (check-bit-against-width reader-name first-bit width)
+     (check-bit-against-width reader-name last-bit width)
+     (bitwise-bit-field id-thunk-val first-bit (add1 last-bit))])
+  (procedure-rename bus-reader-func reader-name))
+
+
+(define (make-bus-writer writer-name width)
+  (define-cases bus-writer-func
+    [(_ id-thunk-val) (raise-argument-error writer-name "new value" empty)]
+    [(_ id-thunk-val new-val-in)
+     (define new-val (cond
+                       [(boolean? new-val-in)
+                        (if new-val-in (sub1 (expt 2 width)) 0)]
+                       [(or (input-bus? new-val-in) (output-bus? new-val-in)) (new-val-in)]
+                       [else new-val-in]))
+     (check-val-against-width writer-name new-val width)
+     new-val]
+    [(_ id-thunk-val bit new-val) (bus-writer-func id-thunk-val bit bit new-val)]
+    [(_ id-thunk-val first-bit last-bit new-val-in)
+     (define bit-range-width (add1 (- last-bit first-bit)))
+     (define new-val (cond
+                       [(boolean? new-val-in)
+                        (if new-val-in (sub1 (expt 2 bit-range-width)) 0)]
+                       [(or (input-bus? new-val-in) (output-bus? new-val-in)) (new-val-in)]
+                       [else new-val-in]))
+     (unless (<= first-bit last-bit)
+       (raise-argument-error writer-name (format "last bit greater than or equal to first bit ~a" first-bit) last-bit))
+     (check-bit-against-width writer-name first-bit width)
+     (check-bit-against-width writer-name last-bit width)
+     (check-val-against-width writer-name new-val bit-range-width)
+     (define last-val
+       (for/fold ([val id-thunk-val])
+                 ([bit (in-range first-bit (add1 last-bit))]
+                  [new-bit-val (in-list (integer->bitvals new-val bit-range-width))])
+         ((if (= 1 new-bit-val) bitwise-bit-set bitwise-bit-unset) val bit)))
+     last-val])
+  bus-writer-func)
+
+
+#|
+
+base bus:
++ can read all, or bits
++ every read invokes a thunk
+|#
+
+
+
+(define-macro-cases define-base-bus
+  [(_ ID THUNK) #'(define-base-bus ID THUNK default-bus-width)]
+  [(_ ID THUNK BUS-WIDTH-IN)
+   (with-pattern
+    ([ID-THUNK (suffix-id #'ID "-val")]
+     [BUS-TYPE (or (syntax-property caller-stx 'impersonate) #'bus)])
+    #`(splicing-let ([ID-THUNK THUNK]
+                     [bus-width BUS-WIDTH-IN])
+        (define ID
+          (begin
+            (unless (<= bus-width max-bus-width)
+              (raise-argument-error 'id (format "bus width <= max width ~a" max-bus-width) bus-width))
+            (impersonate-procedure
+             (let ([reader (make-bus-reader 'id bus-width)])
+               (procedure-rename (λ args (apply reader (ID-THUNK) args)) (string->symbol (format "~a:~a-bit" 'ID bus-width))))
+             #f BUS-TYPE #t)))
+        #,(when (syntax-property caller-stx 'writer)
+            (with-pattern
+             ([_id-write (suffix-id #'ID "-write")])
+             #'(define _id-write
+                 (let ([writer (make-bus-writer 'id-write bus-width)])
+                   (λ args
+                     (define result (apply writer (ID-THUNK) args))
+                     (set! ID-THUNK (λ () result)))))))))])
+
+
+(module+ test
+  (define-base-bus bb (λ () #b0110) 4)
+  (check-true (bus? bb))
+  (check-false (input-bus? bb))
+  (check-false (output-bus? bb))
+  (check-exn exn:fail? (λ () (define-base-bus bb (λ () #b0110) 17) bb)) ; exceeds 16-bit width
+  (check-equal? (bb) #b0110)
+  (check-equal? (bb 0) #b0)
+  (check-equal? (bb 1) #b1)
+  (check-equal? (bb 2) #b1)
+  (check-equal? (bb 3) #b0)
+  (check-exn exn:fail? (λ () (bb 5))) ; exceeds bus width
+  (check-equal? (bb 0 1) #b10)
+  (check-equal? (bb 1 2) #b11)
+  (check-equal? (bb 2 3) #b01)
+  (check-exn exn:fail? (λ () (bb 3 2))) ; inverted bus spec
+  (check-exn exn:fail? (λ () (bb 5 10))) ; exceeds bus width
+  )
+
+
+#|
+output bus:
++ thunk is a runtime computation
++ cannot write
+|#
+
+
+
+
+(define-macro (define-output-bus . ARGS)
+  (syntax-property #'(define-base-bus . ARGS) 'impersonate #'output-bus))
+
+(module+ test
+  (define-output-bus ob (λ () #b0110) 4)
+  (check-false (bus? ob))
+  (check-false (input-bus? ob))
+  (check-true (output-bus? ob))
+  (check-exn exn:fail? (λ () (define-base-bus ob (λ () #b0110) 17) ob)) ; exceeds 16-bit width
+  (check-equal? (ob) #b0110)
+  (check-equal? (ob 0) #b0)
+  (check-equal? (ob 1) #b1)
+  (check-equal? (ob 2) #b1)
+  (check-equal? (ob 3) #b0)
+  (check-exn exn:fail? (λ () (ob 5))) ; exceeds bus width
+  (check-equal? (ob 0 1) #b10)
+  (check-equal? (ob 1 2) #b11)
+  (check-equal? (ob 2 3) #b01)
+  (check-exn exn:fail? (λ () (ob 3 2))) ; inverted bus spec
+  (check-exn exn:fail? (λ () (ob 5 10))) ; exceeds bus width
+  )
+
+#|
+input bus:
++ thunk returns a constant
++ identifies itself as input bus
++ can write all, or bits
+|#
+
+
+(define-macro-cases define-input-bus
+  [(MACRO-NAME ID)
+   #'(MACRO-NAME ID default-bus-width)]
+  [(MACRO-NAME ID BUS-WIDTH)
+   (syntax-property* #'(define-base-bus ID (λ () 0) BUS-WIDTH)
+                     ['impersonate #'input-bus]
+                     ['writer #t])])
+
+(module+ test
+  (define-input-bus ib 4)
+  (check-false (bus? ib))
+  (check-false (output-bus? ib))
+  (check-true (input-bus? ib))
+  (check-exn exn:fail? (λ () (define-input-bus ib 17) ib)) ; exceeds 16-bit width
+  (check-equal? (ib) 0)
+  (ib-write 11) ; set whole value
+  (check-equal? (ib) 11)
+  (check-exn exn:fail? (λ () (ib-write #b11111))) ; overflow
+  (ib-write 2 1) ; set bit
+  (check-equal? (ib) #b1111)  
+  (ib-write 0 #b0) ; set bit
+  (ib-write 1 #b0) ; set bit
+  (ib-write 2 #b0) ; set bit
+  (check-equal? (ib) #b1000)
+  (check-exn exn:fail? (λ () (ib-write 5 1 #b0))) ; last index smaller than first
+  (check-exn exn:fail? (λ () (ib-write 1 300 #b0))) ; overlarge bit index
+  (check-exn exn:fail? (λ () (ib-write 300 500 #b0))) ; overlarge bit index
+  (check-exn exn:fail? (λ () (ib-write 1 #b11111))) ; overflow value
+  (ib-write 0)
+  (ib-write 1 2 #b11) 
+  (check-equal? (ib) #b0110)
+  (ib-write 3 3 #b1)
+  (ib-write 0 0 #b1)
+  (check-equal? (ib) #b1111)
+  (check-exn exn:fail? (λ () (ib-write 0 300 #b0))) ; overlarge bit index
+  (check-exn exn:fail? (λ () (ib-write 1 1 #b11111))) ; overflow value
+  (ib-write 0)
+  (ib-write 1 2 #t) ; using #t to fill certain bits
+  (check-equal? (ib) #b0110)
+  (ib-write 2 2 #f) ; using #f to fill certain bits
+  (check-equal? (ib) #b0010)
+  (ib-write 0)
+  (ib-write #t) ; using #t to fill all bits
+  (check-equal? (ib) #b1111)
+  (ib-write #f) ; using #f to fill all bits
+  (check-equal? (ib) #b0000)
+  (ib-write 1 #t)
+  (check-equal? (ib) 2)
+  (ib-write 1 #f)
+  (check-equal? (ib) 0)
+  (ib-write 2 1)
+  (check-equal? (ib) 4)
+  (ib-write 2 0)
+  (check-equal? (ib) 0)
+  (ib-write 1 2 #t)
+  (check-equal? (ib) 6)
+  (ib-write 2 3 #t)
+  (check-equal? (ib) 14)
+  (ib-write 0 2 #f)
+  (check-equal? (ib) 8)
+  (ib-write #b1011)
+  (check-equal? (ib) 11)
+  (define-input-bus ib2 4)
+  (check-exn exn:fail? (λ () (ib2-write 16))) ; overflow value
+  (ib2-write #b1100)
+  (ib-write ib2) ; using bus as input value
+  (check-equal? (ib) (ib2))
+  )

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

@@ -1,40 +1,60 @@
-#lang br
+#lang br/quicklang
-(provide #%top-interaction #%module-begin #%app #%datum (all-defined-out))
+(require "bus.rkt" (for-syntax racket/syntax racket/require-transform br/syntax "bus-properties.rkt"))
+(provide #%module-begin (all-defined-out))
 
-(define-inverting #'(chip-program "CHIP" _chipname "{"
+(define-macro (chip-program CHIPNAME
-                                  (_input-pin ...)
+                            (in-spec (IN-BUS IN-WIDTH ...) ...)
-                                  (_output-pin ...)
+                            (out-spec (OUT-BUS OUT-WIDTH ...) ...)
-                                  _part-spec "}")
+                            PART ...)
-  #'(begin
+  (with-pattern
-      (define+provide _chipname
+   ([CHIP-PREFIX (suffix-id #'CHIPNAME "-")]
-        (procedure-rename
+    [(IN-BUS-WRITE ...) (suffix-id #'(IN-BUS ...) "-write")]
-         (make-keyword-procedure
+    [(PREFIX-OUT-BUS ...) (prefix-id #'CHIP-PREFIX #'(OUT-BUS ...))])
-          (λ (kws kw-args . rest)
+   #'(begin
-            (define kw-pairs (map cons kws kw-args))
+       (provide (prefix-out CHIP-PREFIX (combine-out IN-BUS ... IN-BUS-WRITE ...)))
-            (let ([_input-pin (cdr (assq (string->keyword (format "~a" '_input-pin)) kw-pairs))] ...)
+       (define-input-bus IN-BUS IN-WIDTH ...) ...
-              _part-spec
+       PART ...
-              (values _output-pin ...)))) '_chipname))))
+       (provide PREFIX-OUT-BUS ...)
+       (define-output-bus PREFIX-OUT-BUS OUT-BUS OUT-WIDTH ...) ...)))
 
-(define-inverting #'(pin-spec _label _pin ... ";")
-  #'(_pin ...))
 
-(define-cases #'pin
+(define-macro (part PARTNAME ((BUS-LEFT . BUS-LEFT-ARGS) BUS-RIGHT-EXPR) ...)
-  [#'(_ _pin ",") #'_pin]
+  (with-pattern
-  [#'(_ _pin) #'_pin])
+   ([(PARTNAME-BUS-LEFT ...) (prefix-id #'PARTNAME "-" #'(BUS-LEFT ...))]
+    [PARTNAME-MODULE-PATH (format-string "~a.hdl.rkt" #'PARTNAME)])
+   #'(begin
+       (require (import-chip PARTNAME-MODULE-PATH)
+                ;; need for-syntax to make phase 1 binding available
+                ;; so we can determine during expansion which buses are `input-bus?`
+                ;; because the pin-spec syntax is inherently ambiguous
+                (for-syntax (import-chip PARTNAME-MODULE-PATH))) 
+       (handle-buses ((PARTNAME-BUS-LEFT . BUS-LEFT-ARGS) BUS-RIGHT-EXPR) ...))))
 
-(define #'(part-spec "PARTS:" _part ...)
-  #'(begin _part ...))
 
-(define-inverting #'(part _partname "(" (_pin _val) ... (_lastpin _pinout) ")" ";")
+(define-syntax import-chip
-  #'(define _pinout (call-part _partname [_pin _val] ...)))
+  (make-require-transformer
+   (λ (stx)
+     (syntax-case stx ()
+       [(_ module-path)
+        (expand-import #'module-path)]))))
 
-(define-cases #'pin-val-pair
-  [#'(_ _pin "=" _val ",") #'(_pin _val)]
-  [#'(_ _pin "=" _val) #'(_pin _val)])
 
-(define #'(call-part _partname [_pin _val] ...)
+(define-macro (handle-buses BUS-ASSIGNMENTS ...)
-  (inject-syntax ([#'part-path (format "~a.hdl" (syntax->datum #'_partname))]
+  (let-values
-                  [#'(kw ...) (map (λ(pi) (string->keyword (format "~a" (syntax->datum pi)))) (syntax->list #'(_pin ...)))])
+      ([(in-bus-assignments out-bus-assignments)
-                 #'(let ()
+        (syntax-case-partition #'(BUS-ASSIGNMENTS ...) ()
-                     (local-require (rename-in part-path [_partname local-name]))
+                               [((PREFIXED-WIRE . _) _)
-                     (keyword-apply local-name '(kw ...) (list _val ...) null))))
+                                ;; we "pre-evaluate" #'PREFIXED-WIRE so we can set up the program correctly.
+                                ;; This is not ideal: usually we want evaluate runtime expressions only at runtime.
+                                ;; But in this case, it controls which identifiers we `define` as output buses
+                                ;; so there's no way around it. Runtime would be too late.
+                                (input-bus? (syntax-local-eval #'PREFIXED-WIRE))])])
+    (with-pattern
+     ([(((IN-BUS IN-BUS-ARG ...) IN-BUS-VALUE) ...) in-bus-assignments]
+      [(IN-BUS-WRITE ...) (suffix-id #'(IN-BUS ...) "-write")]
+      [((OUT-BUS-EXPR (NEW-OUT-BUS)) ...) out-bus-assignments])
+     #'(begin
+         (define-output-bus NEW-OUT-BUS
+           (λ ()
+             (IN-BUS-WRITE IN-BUS-ARG ... IN-BUS-VALUE) ...
+             OUT-BUS-EXPR)) ...))))

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

@@ -1,21 +1,32 @@
 #lang brag
 
-;; rule of thumb: use [optional] bits judiciously as they multiply the cases needed for a production rule
+chip-program : /"CHIP" chipname /"{" in-spec out-spec part-spec /"}"
-;; rule of thumb: for a set of related IDs, put each into the same grammar entity
-;; rule of thumb: avoid mushing unrelated IDs into one grammar entity
-;; whereas a * corresponds directly to an ... in the expander macro
-;; syntax patterns are good for
-;; + single case / nonrecursive structure
-;; + nonalternating pattern (no "this that this that ...")
 
-chip-program : "CHIP" ID "{" pin-spec pin-spec part-spec "}"
+@chipname : ID
 
-pin-spec : ("IN" | "OUT") pin+ ";"
+in-spec : pin-spec
 
-pin : ID [","]
+out-spec : pin-spec
 
-part-spec : "PARTS:" part+
+@pin-spec : (/"IN" | /"OUT") pin [/"," pin]* /";"
 
-part : ID "(" pin-val-pair+ ")" ";"
+/pin : ID  [/"[" NUMBER /"]"]
 
-pin-val-pair : ID "=" ID [","]
+@part-spec : /"PARTS:" part+
+
+part : partname /"(" wire-assign [/"," wire-assign]* /")" /";"
+
+@partname : ID
+
+/wire-assign : pin-range /"=" pin-val
+
+/pin-range : ID [/"[" bus-range /"]"]
+
+@bus-range : number [/"." /"." number]
+
+@pin-val : pin-range
+         | BINARY-NUMBER
+         | TRUE
+         | FALSE
+
+@number : BINARY-NUMBER | NUMBER

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

@@ -1,7 +1,6 @@
 #lang br
 (require br/reader-utils "parser.rkt" "tokenizer.rkt")
 
-(provide read-syntax)
+(define-read-and-read-syntax (source-path input-port)
-(define (read-syntax source-path input-port)
+  #`(module hdl-mod br/demo/hdl/expander
-  (strip-context #`(module hdl-mod br/demo/hdl/expander
+      #,(parse source-path (tokenize input-port))))
-                     #,(parse source-path (tokenize input-port)))))