From c53414285f488ddd088e7f9b054c4248aacbc7ed Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Fri, 20 May 2016 19:00:39 -0700
Subject: [PATCH] improvements

---
 beautiful-racket/br/demo/hdl/Mux.hdl.rkt  |  2 +-
 beautiful-racket/br/demo/hdl/expander.rkt | 23 ++++++++++++-----------
 beautiful-racket/br/demo/hdl/helper.rkt   | 12 +++++++-----
 beautiful-racket/br/demo/hdl/parser.rkt   |  8 ++++----
 4 files changed, 24 insertions(+), 21 deletions(-)

diff --git a/beautiful-racket/br/demo/hdl/Mux.hdl.rkt b/beautiful-racket/br/demo/hdl/Mux.hdl.rkt
index f94e6d9..28c72c1 100644
--- a/beautiful-racket/br/demo/hdl/Mux.hdl.rkt
+++ b/beautiful-racket/br/demo/hdl/Mux.hdl.rkt
@@ -12,7 +12,7 @@
  */
 
 CHIP Mux {
-    IN a, b, sel;
+    IN a, b[15], sel[8];
     OUT out;
 
     PARTS:
diff --git a/beautiful-racket/br/demo/hdl/expander.rkt b/beautiful-racket/br/demo/hdl/expander.rkt
index 056929a..6ae21dd 100644
--- a/beautiful-racket/br/demo/hdl/expander.rkt
+++ b/beautiful-racket/br/demo/hdl/expander.rkt
@@ -18,12 +18,12 @@
         (define-output-bus prefixed-output-pin _output-pin _output-width ...) ...)))
 
 
-(define #'(part _prefix [_suffix . _args] ...)
-  (with-syntax ([(prefix-suffix ...) (map (λ(s) (format-id s "~a-~a" #'_prefix s)) (syntax->list #'(_suffix ...)))]
+(define #'(part _prefix ((_wire . _wireargs) _wirevalue) ...)
+  (with-syntax ([(prefixed-wire ...) (map (λ(s) (format-id s "~a-~a" #'_prefix s)) (syntax->list #'(_wire ...)))]
                 [chip-module-path (datum->syntax #'_prefix (format "~a.hdl.rkt" (syntax->datum #'_prefix)))])
     #'(begin
         (require (import-chip chip-module-path) (for-syntax (import-chip chip-module-path)))
-        (handle-wires [prefix-suffix . _args] ...))))
+        (handle-wires ((prefixed-wire . _wireargs) _wirevalue) ...))))
 
 
 (define-syntax import-chip
@@ -34,17 +34,18 @@
         (expand-import #'module-path)]))))
 
 
-(define #'(handle-wires _wirearg-pair ...)
+(define #'(handle-wires _wire-assignments ...)
   (let-values ([(in-wire-stxs out-wire-stxs)
-                (partition (λ(wirearg-pair-stx)
-                             (define wire-stx (car (syntax->list wirearg-pair-stx)))
-                             (input-bus? (syntax-local-eval wire-stx)))
-                           (syntax->list #'(_wirearg-pair ...)))])
-    (with-syntax* ([([in-wire in-arg ...] ...) in-wire-stxs]
+                (partition (λ(wa)
+                             (syntax-case wa ()
+                               [((prefixed-wire . _wireargs) _)
+                                (input-bus? (syntax-local-eval #'prefixed-wire))]))
+                           (syntax->list #'(_wire-assignments ...)))])
+    (with-syntax* ([(((in-wire in-arg ...) input-expr) ...) in-wire-stxs]
                    [(in-wire-write ...) (map (λ(iw) (format-id iw "~a-write" iw)) (syntax->list #'(in-wire ...)))]
-                   [([out-wire out-arg ... out-bus] ...) out-wire-stxs])
+                   [(((out-wire out-arg ...) (out-bus)) ...) out-wire-stxs])
       #'(begin
           (define-output-bus out-bus
             (λ ()
-              (in-wire-write (in-arg ...)) ...
+              (in-wire-write in-arg ... input-expr) ...
               (out-wire out-arg ...))) ...))))
\ No newline at end of file
diff --git a/beautiful-racket/br/demo/hdl/helper.rkt b/beautiful-racket/br/demo/hdl/helper.rkt
index ca93190..91ab179 100644
--- a/beautiful-racket/br/demo/hdl/helper.rkt
+++ b/beautiful-racket/br/demo/hdl/helper.rkt
@@ -115,7 +115,8 @@ base bus:
     [(macro-name id thunk)
      #'(macro-name id thunk default-bus-width)]
     [(macro-name id thunk bus-width-in)
-     (with-syntax ([id-thunk (format-id #'id "~a-val" #'id)])
+     (with-syntax ([id-thunk (format-id #'id "~a-val" #'id)]
+                   [bus-type (or (syntax-property stx 'impersonate) #'bus)])
        #`(splicing-let ([id-thunk thunk]
                         [bus-width bus-width-in])
            (define id
@@ -124,8 +125,8 @@ base bus:
                  (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)])
-                  (λ args (apply reader (id-thunk) args)))
-                #f #,(or (syntax-property stx 'impersonate) #'bus) #t)))
+                  (procedure-rename (λ args (apply reader (id-thunk) args)) (string->symbol (format "~a, a bus of width ~a" 'id bus-width))))
+                #f bus-type #t)))
            #,(when (syntax-property stx 'writer)
                (with-syntax ([id-write (format-id #'id "~a-write" #'id)])
                  #'(define id-write
@@ -250,6 +251,7 @@ input bus:
   (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
+  (ib-write ib2) ; using bus as input value
   (check-equal? (ib) (ib2))
-  )
\ No newline at end of file
+  )
+  
\ No newline at end of file
diff --git a/beautiful-racket/br/demo/hdl/parser.rkt b/beautiful-racket/br/demo/hdl/parser.rkt
index 23b5fcd..8223cb1 100644
--- a/beautiful-racket/br/demo/hdl/parser.rkt
+++ b/beautiful-racket/br/demo/hdl/parser.rkt
@@ -14,15 +14,15 @@ out-spec : pin-spec
 
 @part-spec : /"PARTS:" part+
 
-part : partname /"(" pin-val-pair [/"," pin-val-pair]* /")" /";"
+part : partname /"(" wire-assign [/"," wire-assign]* /")" /";"
 
 @partname : ID
 
-/pin-val-pair : pin-range /"=" pin-val
+/wire-assign : pin-range /"=" pin-val
 
-@bus-range : number [/"." /"." number]
+/pin-range : ID [/"[" bus-range /"]"]
 
-@pin-range : ID [/"[" bus-range /"]"]
+@bus-range : number [/"." /"." number]
 
 @pin-val : pin-range
          | BINARY-NUMBER