.travis.yml

@@ -14,8 +14,6 @@ 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

@@ -1,36 +0,0 @@
-#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

@@ -0,0 +1,15 @@
+#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,29 +1,31 @@
 #lang racket/base
 (require (for-syntax racket/base br/syntax) br/define)
-(provide (except-out (all-defined-out) string->datum))
+(provide (all-defined-out))
 
 ;; read "foo bar" the same way as "(foo bar)" 
-;; otherwise "bar" is dropped, which is too astonishing
+;; other "bar" is dropped, which is too astonishing
 (define (string->datum str)
-  (if (positive? (string-length str))
   (let ([result (read (open-input-string (format "(~a)" str)))])
     (if (= (length result) 1)
         (car result)
-            result))
+        result)))
-      (void)))
 
-(define (datum? x)
+#;(define-syntax format-datum
-  (or (list? x) (symbol? x)))
+    (λ(stx)
+      (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)
@@ -34,5 +36,4 @@
   (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,26 +1,17 @@
 #lang racket/base
-(require (for-syntax racket/base br/syntax)
+(require (for-syntax racket/base racket/syntax))
-         br/define)
 (provide (all-defined-out))
 
-(define-macro-cases report
+(define-syntax (report stx)
-  [(_ EXPR) #'(report EXPR EXPR)]
+  (syntax-case stx ()
-  [(_ EXPR NAME)
+    [(_ expr) #'(report expr expr)]
-   #'(let ([expr-result EXPR]) 
+    [(_ expr name)
-       (eprintf "~a = ~v\n" 'NAME expr-result)
+     #'(let ([expr-result expr]) 
-       expr-result)])
+         (eprintf "~a = ~v\n" 'name expr-result)
+         expr-result)]))
 
-(define-macro-cases report-datum
+(define-syntax-rule (define-multi-version multi-name name)
-  [(_ STX-EXPR)
+  (define-syntax-rule (multi-name x (... ...))
-   (with-pattern ([datum (syntax->datum #'STX-EXPR)])
+    (begin (name x) (... ...))))
-     #'(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,262 +1,284 @@
 #lang racket/base
-(require
+(require (for-syntax racket/list racket/base syntax/parse racket/syntax syntax/datum syntax/strip-context racket/string) sugar/define)
-  racket/function
+(provide (all-defined-out))
-  (for-syntax racket/base
-              syntax/parse
-              br/private/syntax-flatten
-              syntax/define))
-(provide (all-defined-out)
-         (for-syntax with-shared-id))
 
-(module+ test
+;; everything is prefixed br: whether it needs it or not so it can be stripped by #lang br
-  (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-syntax (define+provide stx)
+(define-for-syntax (generate-literals pats)
-  (with-syntax ([(id lambda-exp)
+  ;; generate literals for any symbols that are not ... or _ or _underscore-prefixed
-                 (let-values ([(id-stx body-exp-stx)
-                               (normalize-definition stx (datum->syntax stx 'λ) #t #t)])
-                   (list id-stx body-exp-stx))])
-    #'(begin
-        (provide id)
-        (define id lambda-exp))))
-
-
-(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))]
+  (for/list ([pat-arg (in-list (syntax-flatten pats))]
-                [pat-datum (in-value (syntax->datum pat-arg))]
+             #:when (let ([pat-datum (syntax->datum pat-arg)])
-                #:when (and (symbol? pat-datum)
+                      (and (symbol? pat-datum)
-                            (not (member pat-datum '(... _))) ; exempted from literality
+                           (not (member pat-datum '(... _ else))) ; exempted from literality
-                            (not (upcased-and-capitalized? (symbol->string pat-datum)))))
+                           (not (string-prefix? (symbol->string pat-datum) pattern-arg-prefixer)))))
-               pat-arg)))
+            pat-arg))
 
+;; expose the caller context within br:define macros with syntax parameter
 (begin-for-syntax
-  ;; expose the caller context within br:define macros with syntax parameter
   (require (for-syntax racket/base) racket/stxparam)
-  (provide caller-stx)
+  (provide caller-stx shared-syntax)
-  (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 (define-cases stx)
+(define-syntax (br:define-cases stx)
-  (syntax-parse stx
-    #:literals (syntax)
-    [(_ id:id)
-     (raise-syntax-error 'define-cases "no cases given" (syntax->datum #'id))]
-    [(_ id:id [(_ . pat-args:expr) . body:expr] ...)
-     #'(define id
-         (case-lambda
-           [pat-args . body] ...
-           [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
-  (define-cases f
-    [(_ arg) (add1 arg)]
-    [(_ arg1 arg2) (+ arg1 arg2)]
-    [(_ . any) 'boing])
-  (check-equal? (f 42) 43)
-  (check-equal? (f 42 5) 47)
-  (check-equal? (f 42 5 'zonk) 'boing)
-
-  (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)
-    #`(begin
-        (for-each displayln
-                  (list
-                   (format "input pattern = #'~a" '#,'(ID . PAT-ARGS))
-                   (format "output pattern = #'~a" (cadr '#,'BODY))
-                   (format "invoked as = ~a" (syntax->datum #'(ID . PAT-ARGS)))
-                   (format "expanded as = ~a" '#,(syntax->datum BODY))
-                   (format "evaluated as = ~a" #,BODY)))
-        #,BODY)))
-
-
-(module+ test
-  (require rackunit racket/port)
-  (parameterize ([current-output-port (open-output-nowhere)])
-    (check-equal? (let ()
-                    (debug-define-macro (foo X Y Z)
-                                        #'(apply + (list X Y Z)))
-                    (foo 1 2 3)) 6)  
-    (check-equal? (let ()
-                    (debug-define-macro (foo X ...) #'(apply * (list X ...)))
-                    (foo 10 11 12)) 1320)))
-
-
-(begin-for-syntax
-  (begin-for-syntax
-    (require (for-syntax racket/base))
-    (define-syntax-rule (make-shared-syntax-macro caller-stx)
-      #'(syntax-rules stx
-          [(_ form)
-           #'(datum->syntax caller-stx (if (syntax? form)
-                                           (syntax-e form)
-                                           form))]))))
-
-(module+ test
-  (define-macro (dirty-maker ARG)
-    (with-syntax ([dirty-bar (datum->syntax caller-stx 'dirty-bar)])
-      #'(define dirty-bar (* ARG 2))))
-  (dirty-maker 42)
-  (check-equal? dirty-bar 84))
-
-
-(begin-for-syntax
-  (define-syntax-rule (with-shared-id (id ...) . body)
-    (with-syntax ([id (datum->syntax caller-stx 'id)] ...)
-      . body)))
-
-
-;; `syntax-parse` classes shared by `define-macro` and `define-macro-cases`
-(begin-for-syntax
-  (require syntax/parse)
   (define-syntax-class syntaxed-id
-    #:literals (syntax quasisyntax)
+    #:literals (syntax)
     #:description "id in syntaxed form"
-    (pattern ([~or syntax quasisyntax] name:id)))
+    (pattern (syntax name:id)))
   
   (define-syntax-class syntaxed-thing
-    #:literals (syntax quasisyntax)
+    #:literals (syntax)
     #:description "some datum in syntaxed form"
-    (pattern ([~or syntax quasisyntax] thing:expr)))
+    (pattern (syntax 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)
+    #:literals (syntax)
-     #'(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))]))
     
+    ;; defective for syntax or function
+    [(_ top-id)
+     (raise-syntax-error 'define-cases "no cases given" (syntax->datum #'top-id))]
     
-(define-syntax (define-macro-cases stx)  
+    ;; defective for syntax
-  (syntax-parse stx
+    [(_ (sid:syntaxed-id . _) . _)  ; (define (#'f1 stx) expr ...)
-    [(_ id:id)
+     (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))]
-     (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 ...)
+    ;; syntax matcher
-     (raise-syntax-error 'define-macro-cases "`else` clause must be last" (syntax->datum #'id))]
+    [(_ top-id:syntaxed-id . patexprs)
-    [(_ id:id (pat:expr . result-exprs:expr) ... else-clause:else-clause)
+     ;; todo: rephrase this check as a syntax-parse pattern above
-     (with-syntax ([LITERALS (generate-literals #'(pat ...))])
+     (let ([all-but-last-pat-datums (map syntax->datum (syntax->list (syntax-case #'patexprs ()
-       #'(define-macro id
+                                                                       [((pat result) ... last-one) #'(pat ...)])))])
-           (λ (stx)
+       (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-parameterize ([caller-stx (make-rename-transformer #'stx)])
                                         (syntax-case stx LITERALS
-                   [pat . result-exprs] ...
+                                          [pat (syntax-parameterize ([caller-stx (make-rename-transformer #'stx)])
-                   else-clause)))
+                                                 (syntax-parameterize ([shared-syntax (make-shared-syntax-macro caller-stx)])
+                                                   . result-exprs))] ...
+                                          [else . else-result-exprs]))
                                       (if (syntax? result)
                                           result
-                 (datum->syntax #'id result)))))]
+                                          (datum->syntax #'top-id.name result)))))]
-    [(_ id:id pat-clause:expr ...) ; macro without `else` clause will reach this branch
+    
-     #'(define-macro-cases id
+    ;; function matcher
-         pat-clause ...
+    [(_ top-id:id [(_ . pat-args) . body] ...)
-         [else (raise-syntax-error
+     #'(define top-id
-                'id
+         (case-lambda
-                "no matching case for calling pattern"
+           [pat-args . body] ...
-                (syntax->datum caller-stx))])]
+           [else (raise-syntax-error 'define-cases "no matching case for argument pattern" (object-name top-id))]))]))
-    [else (raise-syntax-error
-           'define-macro-cases
-           "no matching case for calling pattern"
-           (syntax->datum stx))]))
 
 
 (module+ test
-  (define-macro plus (λ(stx) #'+))
+  (require rackunit)
-  (check-equal? (plus 42) +)
-  (define-macro plusser #'plus)
-  (check-equal? (plusser 42) +)
-  (check-equal? plusser +)
-  (define-macro (times [nested ARG]) #`(* ARG ARG))
-  (check-equal? (times [nested 10]) 100)
-  (define-macro timeser #'times)
-  (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))
-  
-  ;; use caller-stx parameter to introduce identifier unhygienically
-  (define-macro (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-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
+  (br:define-cases #'op
-    [(_ "+") #''got-plus]
+                   [#'(_ "+") #''got-plus]
-    [(_ ARG) #''got-something-else]
+                   [#'(_ _ARG) #''got-something-else]
-    [(_) #'(foo-func)]
+                   [#'(_) #'(foo-func)]
-    [_ #'foo-val])
+                   [#'_ #'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
+  (br:define-cases #'elseop
-    [(_ ARG) #''got-arg]
+                   [#'(_ _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 #'(br:define-cases #'badelseop
-
-  (check-exn exn:fail:syntax? (λ _ (expand-once #'(define-macro-cases badelseop
                                                [else #''got-else]
-                                                    [(_ _arg) #''got-arg]))))
+                                               [#'(_ _arg) #''got-arg]))))
   
-  (define-macro-cases no-else-macro
+  (br:define-cases f
-    [(_ ARG) #''got-arg])
+                   [(_ arg) (add1 arg)]
-  (check-exn exn:fail:syntax? (λ _ (expand-once #'(no-else-macro 'arg1 'arg2)))))
+                   [(_ arg1 arg2) (+ arg1 arg2)])
+  
+  (check-equal? (f 42) 43)
+  (check-equal? (f 42 5) 47)
+  
+  (check-exn exn:fail:syntax? (λ _ (expand-once #'(br:define-cases (#'times stx stx2) #'*)))))
+
+
+
+
+(define-syntax (br:define stx)
+  
+  ;;todo: share syntax classes
+  
+  (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)
+    
+    ;; 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)
+                                     #'(apply + (list _X _Y _Z)))
+                    (foo 1 2 3)) 6)  
+    (check-equal? (let ()
+                    (br:debug-define #'(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)
+      (syntax-case stx ()
+        [(_ caller-stx)
+         #'(λ(stx) (syntax-case stx ()
+                     [(_ form)
+                      #'(datum->syntax caller-stx (if (syntax? form)
+                                                      (syntax-e form)
+                                                      form))]))]))))
+
+(define-syntax (br:define-cases-inverting stx)
+  (syntax-case stx (syntax)
+    [(_ (syntax _id) [(syntax _patarg) . _bodyexprs] ...)
+     (with-syntax ([LITERALS (generate-literals #'(_patarg ...))])
+       #'(define-syntax (_id stx)
+           (syntax-case stx ()
+             [(_id . rest)
+              (let ([expanded-stx (with-syntax ([expanded-macros (map expand-macro (syntax->list #'rest))])
+                                  #'(_id . expanded-macros))])
+                (define result
+                  (syntax-case expanded-stx LITERALS
+                    [_patarg (syntax-parameterize ([caller-stx (make-rename-transformer #'stx)])
+                            (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))]))
+                (if (syntax? result)
+                    result
+                    (datum->syntax #'_id result)))])))]))
+
+
+(module+ test
+  ;; an inverting macro expands its arguments.
+  ;; so `foo` does not get `(falsy a) (falsy b) (falsy c)` as arguments,
+  ;; but rather the result of their expansion, namely `((#f a) (#f b) (#f c))`
+  ;; and `tree` does not get `(foo (#f a) (#f b) (#f c))` as its first argument,
+  ;; but rather the result of its expansion, namely (a b c).
+  (br:define-inverting #'(tree (_id ...) _vals)
+                       #'(let ()
+                           (define-values (_id ...) _vals)
+                           (list _id ...)))
+  
+  (br:define-cases-inverting #'foo
+                             [#'(_ (#f _id) ...) #'(_id ...)])
+  
+  (define-syntax-rule (falsy id) (#f id))
+  
+  (check-equal? (tree (foo (falsy a) (falsy b) (falsy c)) (values 1 2 3)) '(1 2 3)))

beautiful-racket-lib/br/eopl.rkt

@@ -0,0 +1,97 @@
+#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

@@ -1,73 +0,0 @@
-#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

@@ -1,127 +0,0 @@
-#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

@@ -1,19 +0,0 @@
-#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,22 +1,26 @@
 #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/cond racket/function
+         br/define br/syntax br/datum br/debug br/conditional
          (for-syntax racket/base racket/syntax br/syntax br/debug br/define))
-(provide (all-from-out racket/base)
+(provide (except-out (all-from-out racket/base) define)
          (all-from-out racket/list racket/string racket/format racket/match racket/port
-                       br/syntax br/datum br/debug br/cond racket/function br/define)
+                       br/syntax br/datum br/debug br/conditional)
          (for-syntax (all-from-out racket/base racket/syntax br/syntax br/debug))
-         (for-syntax caller-stx with-shared-id)) ; from br/define
+         (for-syntax caller-stx shared-syntax) ; 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
 
-(provide evaluate)
+(define (remove-blank-lines strs)
-(define-macro (evaluate DATUM)
+  (filter (λ(str) (regexp-match #px"\\S" str)) strs))
-  #'(begin
+
-      (define-namespace-anchor nsa)
+(provide remove-blank-lines)
-      (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

@@ -1,12 +0,0 @@
-#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

@@ -1,31 +0,0 @@
-#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,15 +1,17 @@
 #lang racket/base
-(require (for-syntax racket/base racket/syntax br/syntax) br/define syntax/strip-context)
+(require (for-syntax racket/base racket/syntax) 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-macro (define-read-and-read-syntax (PATH PORT) BODY ...)
+(define-syntax (define-read-and-read-syntax calling-site-stx)
+  (syntax-case calling-site-stx ()
+    [(_ (PATH PORT) BODY ...)
      (let ([internal-prefix (gensym)])
-    (with-syntax ([READ (datum->syntax caller-stx 'read)]
+       (with-syntax ([READ (datum->syntax calling-site-stx 'read)]
-                  [READ-SYNTAX (datum->syntax caller-stx 'read-syntax)]
+                     [READ-SYNTAX (datum->syntax calling-site-stx 'read-syntax)]
                      ;; use prefixed names to prevent namespace collisions with possibly existing `read` & `read-syntax`
                      [INTERNAL-READ (format-id #'here "~a-~a" internal-prefix 'read)]
                      [INTERNAL-READ-SYNTAX (format-id #'here "~a-~a" internal-prefix 'read-syntax)])
@@ -38,4 +40,4 @@
                                    (let ([output (calling-site-function #f port)])
                                      (if (syntax? output)
                                          (syntax->datum output)
-                                      output))) 'READ))))))
+                                         output))) 'READ)))))]))

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

@@ -1,417 +1,65 @@
 #lang scribble/manual
-@(require (for-label racket/base racket/contract br))
+@(require (for-label br/conditional))
-
-@(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)}
 
-@defmodulelang[br]
+@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/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/cond]
+@defmodule[br/conditional]
 
-@defform[(while cond body ...)]{
+@defform[(while cond body ...)]
-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.
+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.
 
-@examples[#:eval my-eval
+@defform[(until cond body ...)]
-(let ([x 42])
+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.
-  (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-form (or/c list? symbol?)]
+[datum-template symbol?]
-[val any/c?] ...)
+[arg any/c?] ...)
-(or/c list? symbol?)]{
+datum?]
-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]).
+tk
-
-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]
 
-@defform[
+TK
-(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]
 
-@defform[
+TK
-(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,115 +1,34 @@
 #lang racket/base
-(require (for-syntax racket/base racket/syntax)
+(require (for-syntax racket/base syntax/parse) syntax/strip-context)
-         racket/list
+(provide (all-defined-out) (all-from-out syntax/strip-context))
-         racket/syntax
-         br/define
-         br/private/syntax-flatten)
-(provide (all-defined-out)
-         syntax-flatten)
-
-(module+ test
-  (require rackunit))
 
 
-(define-macro (syntax-match STX-ARG [(syntax PATTERN) BODY ...] ...)
+(define-syntax (syntax-match stx)
-  #'(syntax-case STX-ARG ()
+  (syntax-case stx (syntax)
-      [PATTERN BODY ...] ...))
+    [(_ stx-arg [(syntax 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-macro-cases with-pattern
+#;(define-syntax syntax-variable (make-rename-transformer #'format-id))
-  [(_ () . 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

@@ -1,10 +0,0 @@
-#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,7 +2,5 @@
 (define collection 'multi)
 
 (define version "0.01")
-(define deps '("base"
+(define deps '("base" "sugar"))
-               "sugar"
-               "gui-lib"))
 (define build-deps '("racket-doc" "rackunit-lib" "scribble-lib"))

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

@@ -1,19 +0,0 @@
-#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

@@ -1,140 +0,0 @@
-#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

@@ -1,55 +0,0 @@
-#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,30 +1,29 @@
 #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 chemical kryptocyanic acid can only be"
+10 PRINT "THE FICTITIOUS CHECMICAL 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(50))
+100 A=INT(RND(1)*50)
 110 W=7*A/3
-115 if A=1 then P="liter" else P="liters"
+120 PRINT A;"LITERS OF KRYPTOCYANIC ACID.  HOW MUCH WATER";
-120 print A; " "; P ; " of kryptocyanic acid. How much water?";
+130 INPUT R
-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=3 then 260
+230 IF T=9 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 3 lives are used, but you will be long remembered for"
+260 PRINT " YOUR 9 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

@@ -1,7 +0,0 @@
-#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,271 +1,162 @@
 #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
 
-(begin-for-syntax
+(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$ ""])
-  (require racket/list)
-  (define (gather-unique-ids stx)
-    (remove-duplicates (map syntax->datum (filter (λ(s) (syntax-property s 'id)) (syntax-flatten stx))) eq?)))
 
-(define-macro (basic-module-begin (basic-program PROGRAM-LINE ...))
+(define #'(basic-module-begin _parse-tree ...)
-  (with-pattern ([(UNIQUE-ID ...)
-                  (map (compose1 syntax-local-introduce (λ(id) (datum->syntax #f id)))
-                       (gather-unique-ids #'(PROGRAM-LINE ...)))])
   #'(#%module-begin
-       (define UNIQUE-ID 0) ...
+     (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$)
-       (provide UNIQUE-ID ...)
+                                (println (quote _parse-tree ...))
-       (run PROGRAM-LINE ... (line #f (statement "end"))))))
+                                _parse-tree ...)))
 
 ; #%app and #%datum have to be present to make #%top work
-(define-macro (basic-top . ID)
+(define #'(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)
+
+
+(define (run lines)
+  (define program-lines (list->vector (filter (λ(ln) (not (equal? ln "cr"))) lines)))
+  (define (line-number->index ln)
+    (or
+     (for/or ([idx (in-range (vector-length program-lines))])
+             (and (= (car (vector-ref program-lines idx)) ln)
+                  idx))
      (raise
       (exn:line-not-found
        (format "line number ~a not found in program" ln)
-    (current-continuation-marks))))
+       (current-continuation-marks)))))
-
-(struct end-program-signal exn:fail ())
-(define (raise-end-program-signal)
-  (raise (end-program-signal "" (current-continuation-marks))))
-
-(struct end-line-signal exn:fail ())
-(define (raise-end-line-signal)
-  (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 lines))])
-             (and (= ($line-number (vector-ref lines idx)) ln)
-                  idx))
-     (raise-line-not-found-error ln)))
-  (void
-   (with-handlers ([end-program-signal? void])
   (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 return-stack empty)
+(define #'(cr-line _arg ...) #'(begin _arg ...))
 
-(define (basic:gosub where)
-  (let/cc return-k
-    (set! return-stack (cons return-k return-stack))
-    (basic:goto where)))
 
-(define current-line (make-parameter #f))
+(define current-return-stack (make-parameter empty))
-(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-macro-cases statement
+(define-cases #'line
-  [(statement ID "=" EXPR) #'(basic:let ID EXPR)]
+  [#'(_ _NUMBER (statement-list (statement "GOSUB" _WHERE)))
-  [(statement PROC-NAME . ARGS)
+   #'(cons _NUMBER
-   (with-pattern
+           (λ _
-       ([PROC-ID (prefix-id "basic:" #'PROC-NAME)])
+             (let ([return-stack (current-return-stack)])
-     #'(PROC-ID . ARGS))])
+               (cond
+                 [(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-macro-cases basic:let
+(define-cases #'statement-list
-  [(_ (id-expr ID) EXPR)
+  [#'(_ _STATEMENT) #'(begin _STATEMENT)]
-   #'(begin
+  [#'(_ _STATEMENT ":" _STATEMENT-LIST) #'(begin _STATEMENT _STATEMENT-LIST)])
-       #;(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-macro-cases basic:if
+(define-cases #'statement
-  [(_ COND-EXPR TRUE-EXPR FALSE-EXPR)
+  [#'(statement _ID "=" _EXPR) #'(set! _ID _EXPR)]
-   #'(if (true? COND-EXPR)
+  ;[#'(statement "PRINT" ARG ...) #'(print ARG ...)]
-         TRUE-EXPR
+  ;[#'(statement "RETURN" ARG ...) #'(return ARG ...)]
-         FALSE-EXPR)]
+  ;[#'(statement "END" ARG ...) #'(end ARG ...)]
-  [(_ COND-EXPR TRUE-EXPR)
+  [#'(statement _proc-string _arg ...)
-   #'(if (true? COND-EXPR)
+   (inject-syntax ([#'PROC-ID (format-datum "basic:~a" #'_proc-string)])
-         TRUE-EXPR
+                  #'(PROC-ID _arg ...))])
-         (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-macro-cases id-expr
+(define-cases #'expr-list
-  [(_ ID) #'(cond
+  [#'(_ _EXPR) #'_EXPR]
-              [(procedure? ID) (ID)]
+  [#'(_ _EXPR "," _EXPR-LIST) #'(_EXPR _EXPR-LIST)])
-              [(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-macro-cases expr
+(define-cases #'expr
-  [(_ COMP-EXPR) #'COMP-EXPR]
+  [#'(_ _COMP-EXPR "AND" _SUBEXPR) #'(basic:and _COMP-EXPR _SUBEXPR)]
-  [(_ COMP-EXPR "and" SUBEXPR) #'(basic:and COMP-EXPR SUBEXPR)]
+  [#'(_ _COMP-EXPR "OR" _SUBEXPR) #'(basic:or _COMP-EXPR _SUBEXPR)]
-  [(_ COMP-EXPR "or" SUBEXPR) #'(basic:or COMP-EXPR SUBEXPR)])
+  [#'(_ _COMP-EXPR) #'_COMP-EXPR])
-
-(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-macro-cases sum
+(define-cases #'sum
-  [(_ SUM) #'SUM]
+  [#'(_ _TERM "+" _SUM) #'(+ _TERM _SUM)]
-  [(_ SUM "+" PRODUCT) #'(+ SUM PRODUCT)]
+  [#'(_ _TERM "-" _SUM) #'(- _TERM _SUM)]
-  [(_ SUM "-" PRODUCT) #'(- SUM PRODUCT)])
+  [#'(_ _TERM) #'_TERM])
 
-(define-macro-cases product
+(define-cases #'product
-  [(_ "-" VALUE) #'(- VALUE)]
+  [#'(_ _value "*" _product) #'(* _value _product)]
-  [(_ VALUE) #'VALUE]
+  [#'(_ _value "/" _product) #'(/ _value _product)]
-  [(_ PRODUCT "*" VALUE) #'(* PRODUCT VALUE)]
+  [#'(_ _value) #'_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 #f])
+(define (basic:PRINT args)
-  (define (println [x ""])
-    (define xstr (format "~a" x))
-    (displayln xstr)
-    (set! current-print-position 0))
-  (define (print x)
-    (define xstr (format "~a" x))
-    (display xstr)
-    (set! current-print-position (+ current-print-position (string-length xstr))))
-  
   (match args
-    [#f (println)]
+    [(list) (displayln "")]
-    [(list print-list-items ... ";" pl)
+    [(list print-list-item ... ";" pl) (begin (for-each display print-list-item)
-     (begin
+                                              (basic:PRINT pl))]
-       (for-each
+    [(list print-list-item ... ";") (for-each display print-list-item)]
-        (λ(pli)
+    [(list print-list-item ...) (for-each displayln print-list-item)]))
-          (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 num #\space))
-(define (TAB num) (make-string (max 0 (INT (- num current-print-position))) #\space))
+(define #'(INT _ARG ...) #'(inexact->exact (truncate (expr _ARG ...))))
-(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-macro-cases basic:input
+(define-cases #'basic:INPUT
-  [(_ (print-list . PL-ITEMS) ID ...)
+  [#'(_ _PRINT-LIST ";" _ID)
    #'(begin
-       (basic:print (append (print-list . PL-ITEMS) (list ";")))
+       (basic:PRINT (append _PRINT-LIST (list ";")))
-       (basic:input ID) ...)]
+       (basic:INPUT _ID))]
-  [(_ ID ...) #'(begin
+  [#'(_ _ID) #'(set! _ID (let* ([str (read-line)]
-                  (set! ID (let* ([str (read-line)]
+                                [num (string->number str)])
-                                  [num (string->number (string-trim str))])
+                           (if num num str)))])
-                             (or num str))) ...)])
 
-(define (basic:goto where) where)
+(define (basic:GOTO where) where)
 
-(define-macro-cases basic:on
+(define (basic:RETURN) (car (current-return-stack)))
-  [(_ 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)
-(define (basic:return)
+  'end)
-  (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

@@ -1,8 +0,0 @@
-#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 "2 of 3"
+15 PRINT "BOOM"
 17 GOSUB 30
 20 END
-30 PRINT "3 of 3"
+30 PRINT "YAY"
 40 RETURN
-50 PRINT "1 of 3"
+50 PRINT "50"
 55 RETURN

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

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

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

@@ -1,11 +0,0 @@
-#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,45 +1,35 @@
 #lang brag
 
-basic-program : line*
+;; recursive rules destucture easily in the expander
+program : [CR]* [line [CR line]*] [CR]*
 
-line: NUMBER statement [/":" statement]*
+line: NUMBER statement-list
 
-statement : "def" id /"(" id /")" /"=" expr
+statement-list : statement [":" statement-list]
-| "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]
 
-print-list : expr [[";"] [print-list]]
+statement : "END"
+| "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"
 
-expr : comp-expr [("and" | "or") expr]
+print-list : [expr [";" [print-list]]]
+
+expr : comp-expr [("AND" | "OR") expr]
 
 comp-expr : sum [("=" | ">" | ">=" | "<" | "<=" | "<>") comp-expr]
 
-sum : [sum ("+" | "-")] product
+sum : product [("+" | "-") sum]
 
-product : [product ("*" | "/")] power
+product : value [("*" | "/") product]
 
-power : value [/"^" value]
+expr-list : expr ["," expr-list]*
 
-@value : id-val
+value : ID ["(" expr-list ")"]
-| id-expr
+| "(" 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,19 +1,6 @@
 #lang br/demo/basic
 
-10 PRINT TAB(30);"SINE WAVE"
+1 A = 2
-20 PRINT TAB(15);"CREATIVE COMPUTING  MORRISTOWN, NEW JERSEY"
+10 PRINT A < 2
-30 PRINT: PRINT: PRINT: PRINT: PRINT
+12 C$ = "string thing"
-40 REMARKABLE PROGRAM BY DAVID AHL
+15 PRINT A;: PRINT C$
-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

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

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

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

@@ -1,39 +0,0 @@
-#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,60 +1,36 @@
-#lang br/quicklang
+#lang br
 
-(define-macro (bf-module-begin PARSE-TREE)
+(define #'(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 (fold-funcs apl bf-funcs)
+(define #'(bf-program _OP-OR-LOOP ...)
-  (for/fold ([current-apl apl])
+  #'(begin _OP-OR-LOOP ...))
-            ([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-macro (loop "[" OP-OR-LOOP-ARG ... "]")
+(define-cases #'op
-  #'(lambda (arr ptr)
+  [#'(op ">") #'(move-pointer 1)]
-      (for/fold ([current-apl (list arr ptr)])
+  [#'(op "<") #'(move-pointer -1)]
-                ([i (in-naturals)]
+  [#'(op "+") #'(set-current-byte! (add1 (get-current-byte)))]
-                 #:break (zero? (apply current-byte
+  [#'(op "-") #'(set-current-byte! (sub1 (get-current-byte)))]
-                                       current-apl)))
+  [#'(op ".") #'(write-byte (get-current-byte))]
-        (fold-funcs current-apl (list OP-OR-LOOP-ARG ...)))))
+  [#'(op ",") #'(set-current-byte! (read-byte))])
-(provide loop)
-
-(define-macro-cases op
-  [(op ">") #'gt]
-  [(op "<") #'lt]
-  [(op "+") #'plus]
-  [(op "-") #'minus]
-  [(op ".") #'period]
-  [(op ",") #'comma])
 (provide op)
 
-(define (current-byte arr ptr) (vector-ref arr ptr))
+(define bf-vector (make-vector 30000 0))
+(define bf-pointer 0)
 
-(define (set-current-byte arr ptr val)
+(define (move-pointer how-far)
-  (vector-set! arr ptr val)
+  (set! bf-pointer (+ bf-pointer how-far)))
-  arr)
 
-(define (gt arr ptr) (list arr (add1 ptr)))
+(define (get-current-byte)
-(define (lt arr ptr) (list arr (sub1 ptr)))
+  (vector-ref bf-vector bf-pointer))
-
+(define (set-current-byte! val)
-(define (plus arr ptr)
+  (vector-set! bf-vector bf-pointer val))
-  (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,20 +1,21 @@
-#lang br/quicklang
+#lang br
-(require "bf-parser.rkt")
-
-(define (read-syntax path port)
-  (define parse-tree (parse path (tokenize port)))
-  (define module-datum `(module bf-mod br/demo/bf/bf-expander
-                          ,parse-tree))
-  (datum->syntax #f module-datum))
-(provide read-syntax)
-
 (require parser-tools/lex brag/support)
-(define (tokenize port)
+(define (tokenize input-port)
   (define (next-token)
-    (define our-lexer
+    (define get-token
       (lexer
-       [(eof) eof]
        [(char-set "><-.,+[]") lexeme]
-       [any-char (next-token)]))
+       [(char-complement (char-set "><-.,+[]")) 
-    (our-lexer port))  
+         (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)))
+  (strip-context
+    (inject-syntax ([#'PARSE-TREE parse-tree])
+                  #'(module bf-mod br/demo/bf/bf-expander
+                      PARSE-TREE))))
+(provide read-syntax)

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 (split-bytes val)
+(define (explode-bytes val)
   (cond
     [(zero? val) (list 0)]
     [else
@@ -17,95 +17,60 @@
 
 (module+ test
   (require rackunit)
-  (check-equal? (split-bytes #x2B45) (list #x2 #xB #x4 #x5))
+  (check-equal? (explode-bytes #x2B45) (list #x2 #xB #x4 #x5))
-  (check-equal? (split-bytes #xCD) (list #xC #xD))
+  (check-equal? (explode-bytes #xCD) (list #xC #xD))
-  (check-equal? (split-bytes #xA) (list #xA))
+  (check-equal? (explode-bytes #xA) (list #xA))
-  (check-equal? (split-bytes #x0) (list #x0)))
+  (check-equal? (explode-bytes #x0) (list #x0)))
 
-(define (join-bytes bytes)
+(define (glue-bytes bytes)
   (for/sum ([b (in-list (reverse bytes))]
             [i (in-naturals)])
            (* b (expt 16 i))))
 
 (module+ test
-  (check-equal? #x2B45 (join-bytes (list #x2 #xB #x4 #x5)))
+  (check-equal? #x2B45 (glue-bytes (list #x2 #xB #x4 #x5)))
-  (check-equal? #xCD (join-bytes (list #xC #xD)))
+  (check-equal? #xCD (glue-bytes (list #xC #xD)))
-  (check-equal? #xA (join-bytes (list #xA)))
+  (check-equal? #xA (glue-bytes (list #xA)))
-  (check-equal? #x0 (join-bytes (list #x0))))
+  (check-equal? #x0 (glue-bytes (list #x0))))
 
-(define-macro (define-memory-vector ID [FIELD LENGTH SIZE] ...)
+(define-syntax (define-memory-vector stx)
-  (with-pattern
+  (syntax-case stx ()
-   ([(PREFIXED-ID ...)  (prefix-id #'ID "-" #'(FIELD ...))]
+    [(_ ID [FIELD LENGTH SIZE] ...)
-    [(PREFIXED-ID-REF ...) (suffix-id #'(PREFIXED-ID ...) "-ref")]
+     (with-syntax ([(ID-FIELD-REF ...) (map (λ(field) (format-id stx "~a-~a-ref" #'ID field)) (syntax->list #'(FIELD ...)))]
-    [(PREFIXED-ID-SET! ...) (suffix-id #'(PREFIXED-ID ...) "-set!")]
+                   [(ID-FIELD-SET! ...) (map (λ(field) (format-id stx "~a-~a-set!" #'ID field)) (syntax->list #'(FIELD ...)))]
                    [(FIELD-OFFSET ...) (reverse (cdr
-                                  (for/fold ([accum-stxs (list #'0)])
+                                                 (for/fold ([offsets '(0)])
-                                            ([len-size-stx (in-list (syntax->list #'((LENGTH SIZE) ...)))])
+                                                           ([len (in-list (syntax->list #'(LENGTH ...)))]
-                                    (cons (with-pattern
+                                                            [size (in-list  (syntax->list #'(SIZE ...)))])
-                                           ([accum (car accum-stxs)]
+                                                   (cons (+ (syntax-local-eval #`(* #,len #,size)) (car offsets)) offsets))))])
-                                            [(len size) len-size-stx])
-                                           #'(+ (* len size) accum)) accum-stxs))))])
        #'(begin
            (define ID (make-vector (+ (* LENGTH SIZE) ...)))
-       (define (PREFIXED-ID-REF idx)
+           (define (ID-FIELD-REF idx)
              (unless (< idx LENGTH)
-           (raise-argument-error 'PREFIXED-ID-REF (format "index less than field length ~a" LENGTH) idx))
+               (raise-argument-error 'ID-FIELD-REF (format "index less than field length ~a" LENGTH) idx))
-         (join-bytes
+             (glue-bytes
               (for/list ([i (in-range SIZE)])
                         (vector-ref ID (+ FIELD-OFFSET i idx)))))
            ...
-       (define (PREFIXED-ID-SET! idx val)
+           (define (ID-FIELD-SET! idx val)
              (unless (< idx LENGTH)
-           (raise-argument-error 'PREFIXED-ID-SET! (format "index less than field length ~a" LENGTH) idx))
+               (raise-argument-error 'ID-FIELD-SET! (format "index less than field length ~a" LENGTH) idx))
              (unless (< val (expt 16 SIZE))
-           (raise-argument-error 'PREFIXED-ID-SET! (format "value less than field size ~a" (expt 16 SIZE)) val))
+               (raise-argument-error 'ID-FIELD-SET! (format "value less than field size ~a" (expt 16 SIZE)) val))
              (for ([i (in-range SIZE)]
-               [b (in-list (split-bytes val))])
+                   [b (in-list (explode-bytes val))])
-              (vector-set! ID (+ FIELD-OFFSET i idx) b))) ...)))
+                  (vector-set! ID (+ FIELD-OFFSET i idx) b))) ...))]))
 
-(define-memory-vector chip8 
+(define-memory-vector chip 
   [opcode 1 2] ; two bytes
   [memory 4096 1] ; one byte per
   [V 16 1] ; one byte per
-  [I 2 1] ; index register, 0x000 to 0xFFF (1.5 bytes)
+  [I 3 1] ; index register, 0x000 to 0xFFF
-  [pc 2 1] ; program counter, 0x000 to 0xFFF (1.5 bytes)
+  [pc 3 1] ; program counter, 0x000 to 0xFFF
   [gfx (* 64 32) 1] ; pixels
   [delay_timer 1 1]
   [sound_timer 1 1]
   [stack 16 2] ; 2 bytes each
-  [sp 1 2] ; stack pointer
+  [sp 1 1] ; 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

@@ -1,33 +0,0 @@
-#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

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

beautiful-racket/br/demo/funstacker.rkt

@@ -1,31 +0,0 @@
-#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,100 +1,84 @@
-#lang br/quicklang
+#lang br
-(require (for-syntax br/syntax racket/string) rackunit racket/file)
+(provide #%top-interaction #%module-begin #%datum (rename-out [my-top #%top]) #%app
-(provide #%module-begin (all-defined-out))
+         (all-defined-out))
 
-
+; #%app and #%datum have to be present to make #%top work
-(define (print-cell val fmt)
+(define #'(my-top . id)
-  (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 ".")))
-  (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 (print-line output-filename cells)
-  (with-output-to-file output-filename
-    (λ () (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 ...
+      (displayln (format "got unbound identifier: ~a" 'id))
-       (compare-files))))
+      (procedure-rename (λ xs (cons 'id xs)) (string->symbol (format "undefined:~a" 'id)))))
 
-
+(define-inverting #'(tst-program _arg ...)
-(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)
+      _arg ...))
-       (with-output-to-file output-filename
-         (λ () (printf ""))
-         #:mode 'text
-         #:exists 'replace))))
 
+(define-for-syntax output-here #'output-here)
 
-(define-macro (compare-to-expr COMPARE-FILE-STRING)
+(define-inverting #'(header-expr (_filename-string _procname) (_colid ... _outid) ";")
-  (with-shared-id
+  (inject-syntax ([#'shared-procname (shared-syntax #'_procname)]
-   (compare-files output-filename)
+                  [#'output (shared-syntax 'output)])
-   #'(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
-        (define (output COL-ID ...)
+        (provide (all-defined-out))
-          (print-line output-filename (map print-cell (list COL-ID ...) (list FORMAT-SPEC ...))))
+        (define shared-procname (dynamic-require (findf file-exists? (list _filename-string (format "~a.rkt" _filename-string))) 'shared-procname))
-        (define eval-result #f)
+        (display-header '_colid ... '_outid)
-        (define (eval-chip) (list (CHIP-COL-ID) ...))
+        (define _colid (make-parameter 0)) ...
-        (output COL-NAME ...)))))
+        (define (_outid)
+          (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-macro (set-expr IN-BUS IN-VAL)
+(define #'(display-header _sym ...)
-  (with-pattern
+  #'(begin
-   ([CHIP-IN-BUS-ID-WRITE (prefix-id chip-prefix "-" (suffix-id #'IN-BUS "-write"))])
+      (apply display-values (list _sym ...))
-   #'(CHIP-IN-BUS-ID-WRITE IN-VAL)))
+      (apply display-dashes (list _sym ...))))
+
+(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-macro (eval-expr)
+(define-inverting #'(test-expr _step-expr ... ";")
-  (with-shared-id
+  #'(begin
-   (eval-result eval-chip)
+      _step-expr ...))
-   #'(set! eval-result (eval-chip))))
 
 
-(define-macro (output-expr)
+(define-cases #'step-expr
-  (with-shared-id
+  [#'(_ _step) #'_step]
-   (output eval-result)
+  [#'(_ _step ",") #'_step])
-   #'(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

@@ -0,0 +1,19 @@
+#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 : load-expr output-file-expr compare-to-expr output-list-expr /";" test-expr*
+tst-program : header-expr test-expr*
 
-load-expr : /"load" ID /","
+header-expr : load-expr table-expr ";"
 
-output-file-expr : /"output-file" ID /","
+load-expr : "load" filename ","
 
-compare-to-expr : /"compare-to" ID /","
+filename : ID
 
-output-list-expr : /"output-list" column [column]+
+table-expr : "output-list" column-id+
 
-/column :  ID FORMAT-STRING
+column-id :  ID [","]
 
-@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,16 +7,15 @@
 (define (tokenize input-port)
   (define (next-token)
     (define get-token
-      (lexer-src-pos
+      (lexer
        [(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" "output-file" "compare-to" "set" "eval" "output" (char-set ",;")) lexeme]
+       [(union "load" "output-list" "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 lexeme)]))
+       [(repetition 1 +inf.0 (union alphabetic numeric (char-set "-."))) (token 'ID (string->symbol lexeme))]))
     (get-token input-port))  
   next-token)

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

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

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

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

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

@@ -0,0 +1,14 @@
+#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

@@ -1,31 +0,0 @@
-#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

@@ -1,5 +0,0 @@
-|  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

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

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

@@ -1,5 +0,0 @@
-|  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

@@ -1,27 +0,0 @@
-// 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

@@ -1,28 +0,0 @@
-#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

@@ -1,9 +0,0 @@
-| 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

@@ -1,43 +0,0 @@
-// 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

@@ -1,45 +0,0 @@
-#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

@@ -1,23 +0,0 @@
-#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,9 +6,10 @@
 // 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

@@ -1,32 +0,0 @@
-#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

@@ -1,12 +0,0 @@
-#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

@@ -1,5 +0,0 @@
-|   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

@@ -1,11 +0,0 @@
-#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

@@ -1,5 +0,0 @@
-|   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

@@ -1,31 +0,0 @@
-#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

@@ -1,39 +0,0 @@
-#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

@@ -1,9 +0,0 @@
-|   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

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

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

@@ -1,9 +0,0 @@
-|   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

@@ -1,49 +0,0 @@
-// 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,13 +1,14 @@
-#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

@@ -0,0 +1,13 @@
+#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

@@ -1,18 +0,0 @@
-#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

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

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

@@ -1,20 +0,0 @@
-#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

@@ -1,17 +0,0 @@
-#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

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

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

@@ -0,0 +1,13 @@
+#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

@@ -1,12 +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.out

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

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

@@ -0,0 +1,10 @@
+#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

@@ -1,34 +0,0 @@
-#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

@@ -1,14 +0,0 @@
-#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

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

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

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

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

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

@@ -1,30 +0,0 @@
-#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

@@ -1,13 +0,0 @@
-#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

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

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

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

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

@@ -1,29 +1,12 @@
-// This file is part of www.nand2tetris.org
+#lang br/demo/hdl/tst
-// 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,
+output-list a, b, out;
-compare-to Xor.cmp,
+set a 0, set b 0,
-output-list a%B3.1.3 b%B3.1.3 out%B3.1.3;
+eval, output;
-
+set a 0, set b 1,
-set a 0,
+eval, output;
-set b 0,
+set a 1, set b 0,
-eval,
+eval, output;
-output;
+set a 1, set b 1,
-
+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

@@ -1,31 +0,0 @@
-#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

@@ -1,11 +0,0 @@
-#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

@@ -1,257 +0,0 @@
-#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,60 +1,40 @@
-#lang br/quicklang
+#lang br
-(require "bus.rkt" (for-syntax racket/syntax racket/require-transform br/syntax "bus-properties.rkt"))
+(provide #%top-interaction #%module-begin #%app #%datum (all-defined-out))
-(provide #%module-begin (all-defined-out))
 
-(define-macro (chip-program CHIPNAME
+(define-inverting #'(chip-program "CHIP" _chipname "{"
-                            (in-spec (IN-BUS IN-WIDTH ...) ...)
+                                  (_input-pin ...)
-                            (out-spec (OUT-BUS OUT-WIDTH ...) ...)
+                                  (_output-pin ...)
-                            PART ...)
+                                  _part-spec "}")
-  (with-pattern
-   ([CHIP-PREFIX (suffix-id #'CHIPNAME "-")]
-    [(IN-BUS-WRITE ...) (suffix-id #'(IN-BUS ...) "-write")]
-    [(PREFIX-OUT-BUS ...) (prefix-id #'CHIP-PREFIX #'(OUT-BUS ...))])
   #'(begin
-       (provide (prefix-out CHIP-PREFIX (combine-out IN-BUS ... IN-BUS-WRITE ...)))
+      (define+provide _chipname
-       (define-input-bus IN-BUS IN-WIDTH ...) ...
+        (procedure-rename
-       PART ...
+         (make-keyword-procedure
-       (provide PREFIX-OUT-BUS ...)
+          (λ (kws kw-args . rest)
-       (define-output-bus PREFIX-OUT-BUS OUT-BUS OUT-WIDTH ...) ...)))
+            (define kw-pairs (map cons kws kw-args))
+            (let ([_input-pin (cdr (assq (string->keyword (format "~a" '_input-pin)) kw-pairs))] ...)
+              _part-spec
+              (values _output-pin ...)))) '_chipname))))
 
+(define-inverting #'(pin-spec _label _pin ... ";")
+  #'(_pin ...))
 
-(define-macro (part PARTNAME ((BUS-LEFT . BUS-LEFT-ARGS) BUS-RIGHT-EXPR) ...)
+(define-cases #'pin
-  (with-pattern
+  [#'(_ _pin ",") #'_pin]
-   ([(PARTNAME-BUS-LEFT ...) (prefix-id #'PARTNAME "-" #'(BUS-LEFT ...))]
+  [#'(_ _pin) #'_pin])
-    [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-syntax import-chip
+(define-inverting #'(part _partname "(" (_pin _val) ... (_lastpin _pinout) ")" ";")
-  (make-require-transformer
+  #'(define _pinout (call-part _partname [_pin _val] ...)))
-   (λ (stx)
-     (syntax-case stx ()
-       [(_ module-path)
-        (expand-import #'module-path)]))))
 
+(define-cases #'pin-val-pair
+  [#'(_ _pin "=" _val ",") #'(_pin _val)]
+  [#'(_ _pin "=" _val) #'(_pin _val)])
 
-(define-macro (handle-buses BUS-ASSIGNMENTS ...)
+(define #'(call-part _partname [_pin _val] ...)
-  (let-values
+  (inject-syntax ([#'part-path (format "~a.hdl" (syntax->datum #'_partname))]
-      ([(in-bus-assignments out-bus-assignments)
+                  [#'(kw ...) (map (λ(pi) (string->keyword (format "~a" (syntax->datum pi)))) (syntax->list #'(_pin ...)))])
-        (syntax-case-partition #'(BUS-ASSIGNMENTS ...) ()
+                 #'(let ()
-                               [((PREFIXED-WIRE . _) _)
+                     (local-require (rename-in part-path [_partname local-name]))
-                                ;; we "pre-evaluate" #'PREFIXED-WIRE so we can set up the program correctly.
+                     (keyword-apply local-name '(kw ...) (list _val ...) null))))
-                                ;; 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,32 +1,21 @@
 #lang brag
 
-chip-program : /"CHIP" chipname /"{" in-spec out-spec part-spec /"}"
+;; rule of thumb: use [optional] bits judiciously as they multiply the cases needed for a production rule
+;; 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 ...")
 
-@chipname : ID
+chip-program : "CHIP" ID "{" pin-spec pin-spec part-spec "}"
 
-in-spec : pin-spec
+pin-spec : ("IN" | "OUT") pin+ ";"
 
-out-spec : pin-spec
+pin : ID [","]
 
-@pin-spec : (/"IN" | /"OUT") pin [/"," pin]* /";"
+part-spec : "PARTS:" part+
 
-/pin : ID  [/"[" NUMBER /"]"]
+part : ID "(" pin-val-pair+ ")" ";"
 
-@part-spec : /"PARTS:" part+
+pin-val-pair : ID "=" ID [","]
-
-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,6 +1,7 @@
 #lang br
 (require br/reader-utils "parser.rkt" "tokenizer.rkt")
 
-(define-read-and-read-syntax (source-path input-port)
+(provide read-syntax)
-  #`(module hdl-mod br/demo/hdl/expander
+(define (read-syntax source-path input-port)
-      #,(parse source-path (tokenize input-port))))
+  (strip-context #`(module hdl-mod br/demo/hdl/expander
+                     #,(parse source-path (tokenize input-port)))))