improvements

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:

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] ...)
+(define #'(part _prefix ((_wire . _wireargs) _wirevalue) ...)
-  (with-syntax ([(prefix-suffix ...) (map (λ(s) (format-id s "~a-~a" #'_prefix s)) (syntax->list #'(_suffix ...)))]
+  (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)
+                (partition (λ(wa)
-                             (define wire-stx (car (syntax->list wirearg-pair-stx)))
+                             (syntax-case wa ()
-                             (input-bus? (syntax-local-eval wire-stx)))
+                               [((prefixed-wire . _wireargs) _)
-                           (syntax->list #'(_wirearg-pair ...)))])
+                                (input-bus? (syntax-local-eval #'prefixed-wire))]))
-    (with-syntax* ([([in-wire in-arg ...] ...) in-wire-stxs]
+                           (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 ...))) ...))))

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)))
+                  (procedure-rename (λ args (apply reader (id-thunk) args)) (string->symbol (format "~a, a bus of width ~a" 'id bus-width))))
-                #f #,(or (syntax-property stx 'impersonate) #'bus) #t)))
+                #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))
-  )
+  )
+  

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