output bus experiment

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

@@ -19,8 +19,8 @@ CHIP DMux4Way {
     OUT a, b, c, d;
 
     PARTS:
-    DMux(in=in, sel[0]=sel, a=a, b=b);
+    DMux(in=in, sel=sel[0], a=a, b=b);
-    DMux(in=in, sel[1]=sel, a=c, b=d);
+    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"

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

@@ -1,10 +1,7 @@
 #lang br
 (require "helper.rkt" (for-syntax racket/base racket/syntax "helper.rkt" racket/list racket/require-transform))
-(provide #%top-interaction (rename-out [mb #%module-begin]) #%app #%datum and or (all-defined-out))
+(provide #%top-interaction #%module-begin #%app #%datum and or (all-defined-out))
 
-(define #'(mb _arg ...)
-  #'(#%module-begin
-     _arg ...))
 
 (define #'(chip-program _chipname
                         (in-spec (_input-pin _input-width ...) ...)

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

@@ -40,11 +40,18 @@
                      (bitwise-bit-field int i (add1 i)))))
 
 (define max-bus-width 16)
+(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)))
+
 (require sugar/debug)
 (define (make-input-bus bus-name [width 1])
   (impersonate-procedure
@@ -53,10 +60,7 @@
           [bus-val 0])
       (unless (<= bus-width max-bus-width)
         (raise-argument-error bus-name (format "bus width <= max width ~a" max-bus-width) bus-width))
-      (define (check-val-against-width 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 func
         (case-lambda
           [() bus-val]
@@ -88,10 +92,21 @@
     bus-name)
    #f input-bus #t))
 
-(define-syntax-rule (define-input-bus id arg ...)
-  (define id (make-input-bus 'id arg ...)))
 
-(module+ test
+(require (for-syntax racket/base racket/syntax))
+(define-syntax (define-input-bus stx)
+  (syntax-case stx ()
+    [(macro-name id)
+     #'(macro-name id void default-bus-width)]
+    [(macro-name id width)
+     #'(macro-name id void width)]
+    [(macro-name id thunk width)
+     (with-syntax ([id-write (format-id #'id "~a-write" #'id)])
+       #'(begin
+           (define-output-bus id thunk width)
+          ))]))
+
+#;(module+ test
     (define-input-bus in-bus)
     (define other (λ () (+ 2 2)))
     (check-true (input-bus? in-bus))
@@ -99,83 +114,124 @@
     
     (define-input-bus ib 4)
     (check-exn exn:fail? (λ () (define-input-bus ib 17) ib)) ; exceeds 16-bit width
-  (check-equal? (ib) 0)
+    (check-equal? (ib-read) 0)
-  (ib 11) ; set whole value
+    (ib-write 11) ; set whole value
-  (check-exn exn:fail? (λ () (ib #b11111))) ; overflow
+    (check-exn exn:fail? (λ () (ib-write #b11111))) ; overflow
-  (ib 2 1) ; set bit
+    (ib-write 2 1) ; set bit
     (check-equal? (ib) #b1111)  
-  (ib 0 #b0) ; set bit
+    (ib-write 0 #b0) ; set bit
-  (ib 1 #b0) ; set bit
+    (ib-write 1 #b0) ; set bit
-  (ib 2 #b0) ; set bit
+    (ib-write 2 #b0) ; set bit
-  (check-equal? (ib) #b1000)
+    (check-equal? (ib-read) #b1000)
-  (check-exn exn:fail? (λ () (ib 5 1 #b0))) ; last index smaller than first
+    (check-exn exn:fail? (λ () (ib-write 5 1 #b0))) ; last index smaller than first
-  (check-exn exn:fail? (λ () (ib 1 300 #b0))) ; overlarge bit index
+    (check-exn exn:fail? (λ () (ib-write 1 300 #b0))) ; overlarge bit index
-  (check-exn exn:fail? (λ () (ib 300 500 #b0))) ; overlarge bit index
+    (check-exn exn:fail? (λ () (ib-write 300 500 #b0))) ; overlarge bit index
-  (check-exn exn:fail? (λ () (ib 1 #b11111))) ; overflow value
+    (check-exn exn:fail? (λ () (ib-write 1 #b11111))) ; overflow value
-  (ib 0)
+    (ib-write 0)
-  (ib 1 2 #b11) 
+    (ib-write 1 2 #b11) 
-  (check-equal? (ib) #b0110)
+    (check-equal? (ib-read) #b0110)
-  (ib 3 3 #b1)
+    (ib-write 3 3 #b1)
-  (ib 0 0 #b1)
+    (ib-write 0 0 #b1)
-  (check-equal? (ib) #b1111)
+    (check-equal? (ib-read) #b1111)
-  (check-exn exn:fail? (λ () (ib 0 300 #b0))) ; overlarge bit index
+    (check-exn exn:fail? (λ () (ib-write 0 300 #b0))) ; overlarge bit index
-  (check-exn exn:fail? (λ () (ib 1 1 #b11111))) ; overflow value
+    (check-exn exn:fail? (λ () (ib-write 1 1 #b11111))) ; overflow value
-  (ib 0)
+    (ib-write 0)
-  (ib 1 2 #t) ; using #t to fill certain bits
+    (ib-write 1 2 #t) ; using #t to fill certain bits
-  (check-equal? (ib) #b0110)
+    (check-equal? (ib-read) #b0110)
-  (ib 2 2 #f) ; using #f to fill certain bits
+    (ib-write 2 2 #f) ; using #f to fill certain bits
-  (check-equal? (ib) #b0010)
+    (check-equal? (ib-read) #b0010)
-  (ib 0)
+    (ib-write 0)
-  (ib #t) ; using #t to fill all bits
+    (ib-write #t) ; using #t to fill all bits
-  (check-equal? (ib) #b1111)
+    (check-equal? (ib-read) #b1111)
-  (ib #f) ; using #f to fill all bits
+    (ib-write #f) ; using #f to fill all bits
-  (check-equal? (ib) #b0000)
+    (check-equal? (ib-read) #b0000)
     (define-input-bus ib2 4)
-  (check-exn exn:fail? (λ () (ib2 16))) ; overflow value
+    (check-exn exn:fail? (λ () (ib2-write 16))) ; overflow value
-  (ib2 #b1100)
+    (ib2-write #b1100)
-  (ib ib2) ; using bus as input value
+    (ib-write (ib2-read)) ; using bus as input value
-  (check-equal? (ib) (ib2))
+    (check-equal? (ib-read) (ib2))
     )
 
 
 (define-values (output-bus output-bus? output-bus-get)
   (make-impersonator-property 'output-bus))
 
-(define (make-output-bus bus-name thunk [width 1])
+(define (make-read-bus bus-name thunk bus-width)
-  (impersonate-procedure
-   (procedure-rename
-    (let ([bus-width width])
   (unless (<= bus-width max-bus-width)
     (raise-argument-error bus-name (format "bus width <= max width ~a" max-bus-width) bus-width))
-      (define func
+  (impersonate-procedure (procedure-rename thunk bus-name) #f output-bus #t))
+
+(define (make-bus-reader reader-name id-val thunk width)
+  (define bus-reader-func
     (case-lambda
-          [() (func 0 (sub1 bus-width))]
+      [() (bus-reader-func 0 (sub1 width))]
-          [(bit) (func bit bit)]
+      [(bit) (bus-reader-func bit bit)]
       [(first-bit last-bit)
        (unless (<= first-bit last-bit)
-             (raise-argument-error bus-name (format "last bit greater than or equal to first bit ~a" 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 bus-name first-bit bus-width)
+       (check-bit-against-width reader-name first-bit width)
-           (check-bit-against-width bus-name last-bit bus-width)
+       (check-bit-against-width reader-name last-bit width)
-           (bitwise-bit-field (thunk) first-bit (add1 last-bit))]))
+       (set! id-val (thunk))
-      func)
+       (bitwise-bit-field id-val first-bit (add1 last-bit))]))
-    bus-name)
+  bus-reader-func)
-   #f output-bus #t))
+
+(define (make-bus-writer writer-name id width)
+  (define bus-writer-func
+    (case-lambda
+      [() (raise-argument-error writer-name "new value" empty)]
+      [(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 'id new-val width)
+       (set! id new-val)]
+      [(bit new-val) (bus-writer-func bit bit new-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 new-val bit-range-width)
+       (for ([bit (in-range first-bit (add1 last-bit))]
+             [new-bit-val (in-list (integer->bitvals new-val bit-range-width))])
+            (set! id ((if (= 1 new-bit-val) bitwise-bit-set bitwise-bit-unset) id bit)))]))
+  bus-writer-func)
+
+(define-syntax (define-output-bus stx)
+  (syntax-case stx ()
+    [(macro-name id thunk)
+     #'(macro-name id thunk default-bus-width)]
+    [(macro-name id thunk width)
+     (with-syntax ([id-val (format-id #'id "~a-val" #'id)]
+                   [id-read (format-id #'id "~a-read" #'id)]
+                   [id-write (format-id #'id "~a-write" #'id)])
+       #'(begin
+           (define id-val 0)
+           (define id-read (make-bus-reader 'id-read id-val thunk width))
+           (define id (make-read-bus 'id id-read width))
+           (define id-write (make-bus-writer 'id-write id width))))]))
 
-(define-syntax-rule (define-output-bus id thunk arg ...)
-  (define id (make-output-bus 'id thunk arg ...)))
 
 (module+ test
   (define-output-bus ob (λ () #b0110) 4)
-  (check-exn exn:fail? (λ () (define-input-bus ob (λ () #b0110) 17) ob)) ; exceeds 16-bit width
+  (check-exn exn:fail? (λ () (define-output-bus ob (λ () #b0110) 17) ob)) ; exceeds 16-bit width
-  (check-equal? (ob) #b0110)
+  (check-equal? (ob-read) #b0110)
-  (check-equal? (ob 0) #b0)
+  (check-equal? (ob-read 0) #b0)
-  (check-equal? (ob 1) #b1)
+  (check-equal? (ob-read 1) #b1)
-  (check-equal? (ob 2) #b1)
+  (check-equal? (ob-read 2) #b1)
-  (check-equal? (ob 3) #b0)
+  (check-equal? (ob-read 3) #b0)
-  (check-exn exn:fail? (λ () (ob 5))) ; exceeds bus width
+  (check-exn exn:fail? (λ () (ob-read 5))) ; exceeds bus width
-  (check-equal? (ob 0 1) #b10)
+  (check-equal? (ob-read 0 1) #b10)
-  (check-equal? (ob 1 2) #b11)
+  (check-equal? (ob-read 1 2) #b11)
-  (check-equal? (ob 2 3) #b01)
+  (check-equal? (ob-read 2 3) #b01)
-  (check-exn exn:fail? (λ () (ob 3 2))) ; inverted bus spec
+  (check-exn exn:fail? (λ () (ob-read 3 2))) ; inverted bus spec
-  (check-exn exn:fail? (λ () (ob 5 10))) ; exceeds bus width
+  (check-exn exn:fail? (λ () (ob-read 5 10))) ; exceeds bus width
   )

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

@@ -18,11 +18,15 @@ part : partname /"(" pin-val-pair [/"," pin-val-pair]* /")" /";"
 
 @partname : ID
 
-/pin-val-pair : ID  [/"[" bus-range /"]"] /"=" pin-val
+/pin-val-pair : pin-range /"=" pin-val
 
-@bus-range : NUMBER [/"." /"." NUMBER]
+@bus-range : number [/"." /"." number]
 
-@pin-val : ID [/"[" bus-range /"]"]
+@pin-range : ID [/"[" bus-range /"]"]
+
+@pin-val : pin-range
          | BINARY-NUMBER
          | TRUE
          | FALSE
+
+@number : BINARY-NUMBER | NUMBER