From e3334e64984ca1c7037efcc2c6e0fc650748776b Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Tue, 17 May 2016 19:11:26 -0700
Subject: [PATCH] resume in bit subscripts

---
 beautiful-racket/br/demo/hdl/Dmux4Way.hdl.rkt | 22 ++++++++++
 beautiful-racket/br/demo/hdl/Nand.hdl.rkt     |  2 +-
 beautiful-racket/br/demo/hdl/Not-sexp.rkt     |  2 +-
 beautiful-racket/br/demo/hdl/expander.rkt     | 22 +++++-----
 beautiful-racket/br/demo/hdl/helper.rkt       | 44 ++++++++++++++++---
 beautiful-racket/br/demo/hdl/parser.rkt       |  6 ++-
 beautiful-racket/br/demo/hdl/tokenizer.rkt    |  3 +-
 7 files changed, 78 insertions(+), 23 deletions(-)
 create mode 100644 beautiful-racket/br/demo/hdl/Dmux4Way.hdl.rkt

diff --git a/beautiful-racket/br/demo/hdl/Dmux4Way.hdl.rkt b/beautiful-racket/br/demo/hdl/Dmux4Way.hdl.rkt
new file mode 100644
index 0000000..dd941c8
--- /dev/null
+++ b/beautiful-racket/br/demo/hdl/Dmux4Way.hdl.rkt
@@ -0,0 +1,22 @@
+#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 {
+    IN in, sel[2];
+    OUT out;
+
+    PARTS:
+    Not(in=sel[0], out=out);
+}
\ No newline at end of file
diff --git a/beautiful-racket/br/demo/hdl/Nand.hdl.rkt b/beautiful-racket/br/demo/hdl/Nand.hdl.rkt
index 3139518..97b1a86 100644
--- a/beautiful-racket/br/demo/hdl/Nand.hdl.rkt
+++ b/beautiful-racket/br/demo/hdl/Nand.hdl.rkt
@@ -6,7 +6,7 @@
 (define b (make-input))
 
 
-(define (out)
+(define (out . etc)
   (if (< (+ (a) (b)) 2)
       1
       0))
diff --git a/beautiful-racket/br/demo/hdl/Not-sexp.rkt b/beautiful-racket/br/demo/hdl/Not-sexp.rkt
index 861101d..d428113 100644
--- a/beautiful-racket/br/demo/hdl/Not-sexp.rkt
+++ b/beautiful-racket/br/demo/hdl/Not-sexp.rkt
@@ -10,7 +10,7 @@ CHIP Not {
 }
 |#
 
-(chip-program Not
+#;(chip-program Not
               (in-spec in)
               (out-spec out)
               (part-spec (part Nand (a in) (b in) (out out))))
\ No newline at end of file
diff --git a/beautiful-racket/br/demo/hdl/expander.rkt b/beautiful-racket/br/demo/hdl/expander.rkt
index 5362584..50f89cb 100644
--- a/beautiful-racket/br/demo/hdl/expander.rkt
+++ b/beautiful-racket/br/demo/hdl/expander.rkt
@@ -4,22 +4,22 @@
 
 
 (define #'(chip-program _chipname
-                        (in-spec _input-pin ...)
-                        (out-spec _output-pin ...)
-                        (part-spec (part _partname (_pin _val) ... ) ...))
+                        (in-spec (_input-pin _inlen ...) ...)
+                        (out-spec (_output-pin _outlen ...) ...)
+                        (part-spec (part _partname ((_pin _pinwhich ...) (_val _valwhich ...)) ... ) ...))
   (with-syntax ([chip-prefix (format-id #'_chipname "~a-" #'_chipname)])
     #'(begin
         (provide (prefix-out chip-prefix (combine-out _input-pin ... _output-pin ...))) 
-        (define _input-pin (make-input)) ...
-        (handle-part _partname (_pin _val) ...) ...)))
+        (define _input-pin (make-input _inlen ...)) ...
+        (handle-part _partname (_pin (or #f _pinwhich ...) (_val (or #f _valwhich ...))) ...) ...)))
 
 
-(define #'(handle-part _prefix [_suffix _arg] ...)
+(define #'(handle-part _prefix [_suffix _which _arg] ...)
   (with-syntax ([(prefix-suffix ...) (map (λ(s) (format-id s "~a-~a" #'_prefix s)) (syntax->list #'(_suffix ...)))]
                 [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 _arg] ...))))
+        (handle-wires [prefix-suffix _which _arg] ...))))
 
 
 (define-syntax import-chip
@@ -36,9 +36,9 @@
                              (define wire-stx (car (syntax->list wirearg-pair-stx)))
                              (input-wire? (syntax-local-eval wire-stx)))
                            (syntax->list #'(_wirearg-pair ...)))])
-    (with-syntax ([([in-wire in-arg] ...) in-wire-stxs]
-                  [([out-wire out-arg] ...) out-wire-stxs])
+    (with-syntax ([([in-wire . in-args] ...) in-wire-stxs]
+                  [([out-wire which (out-arg . args)] ...) out-wire-stxs])
       #'(begin
           (define (out-arg)
-            (in-wire (in-arg)) ...
-            (out-wire)) ...))))
\ No newline at end of file
+            (in-wire . in-args) ...
+            (out-wire which)) ...))))
\ 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 ffb1c36..65e158f 100644
--- a/beautiful-racket/br/demo/hdl/helper.rkt
+++ b/beautiful-racket/br/demo/hdl/helper.rkt
@@ -4,13 +4,24 @@
 (define-values (input-wire input-wire? input-wire-get)
   (make-impersonator-property 'input-wire))
 
-(define (make-input)
+(define (make-input [max-length 16])
   (impersonate-procedure 
-   (let ([val 0])
-     (λ ([arg #f])
-       (if arg
-           (set! val arg)
-           val)))
+   (let ([max-length max-length]
+         [val 0])
+     (case-lambda
+       [() val]
+       [(bit)
+        (when (and bit (>= bit max-length))
+          (raise-argument-error 'make-input (format "bit index too large for bit length ~a" max-length) bit))
+        (if (bitwise-bit-set? val (or bit 0)) 1 0)]
+       [(bit arg)
+        (when (and bit (>= bit max-length))
+          (raise-argument-error 'make-input (format "bit index too large for bit length ~a" max-length) bit))
+        (when (and arg (> arg (expt 2 max-length)))
+          (raise-argument-error 'make-input (format "value too large for bit length ~a" max-length) arg))
+        (cond
+          [(and bit arg) (set! val (bitwise-ior val (expt 2 bit)))]
+          [else (set! val arg)])])) ;; aka (and arg (not bit))
    #f input-wire #t))
 
 (module+ test
@@ -18,4 +29,23 @@
   (define in-wire (make-input))
   (define other (λ () (+ 2 2)))
   (check-true (input-wire? in-wire))
-  (check-false (input-wire? other)))
\ No newline at end of file
+  (check-false (input-wire? other))
+  
+  (define x (make-input 4))
+  (check-equal? (x) 0)
+  (x #f 12)
+  (check-equal? (x) 12)
+  (x #f 0)
+  (check-equal? (x) 0)
+  (x 3 1)
+  (check-equal? (x) 8)
+  (x 2 1)
+  (check-equal? (x) 12)
+  (check-equal? (x 3) 1)
+  (check-equal? (x 2) 1)
+  (check-equal? (x 1) 0)
+  (check-equal? (x 0) 0)
+  
+  (check-exn exn:fail? (λ () (x #f 32)))
+  (check-exn exn:fail? (λ () (x 22 1)))
+  )
diff --git a/beautiful-racket/br/demo/hdl/parser.rkt b/beautiful-racket/br/demo/hdl/parser.rkt
index f9c3a8a..6012e6d 100644
--- a/beautiful-racket/br/demo/hdl/parser.rkt
+++ b/beautiful-racket/br/demo/hdl/parser.rkt
@@ -10,7 +10,7 @@ out-spec : pin-spec
 
 @pin-spec : (/"IN" | /"OUT") pin [/"," pin]* /";"
 
-@pin : ID
+/pin : ID  [/"[" NUMBER /"]"]
 
 part-spec : /"PARTS:" part+
 
@@ -18,4 +18,6 @@ part : partname /"(" pin-val-pair [/"," pin-val-pair]* /")" /";"
 
 @partname : ID
 
-/pin-val-pair : pin /"=" ID
\ No newline at end of file
+/pin-val-pair : pin /"=" pin-val
+
+/pin-val : ID  [/"[" NUMBER /"]"]
\ No newline at end of file
diff --git a/beautiful-racket/br/demo/hdl/tokenizer.rkt b/beautiful-racket/br/demo/hdl/tokenizer.rkt
index 1a1bc31..4ffdc08 100644
--- a/beautiful-racket/br/demo/hdl/tokenizer.rkt
+++ b/beautiful-racket/br/demo/hdl/tokenizer.rkt
@@ -15,7 +15,8 @@
         (token 'COMMENT lexeme #:skip? #t)]
        [(union #\tab #\space #\newline) (get-token input-port)]
        [(union "CHIP" "IN" "OUT" "PARTS:") lexeme]
-       [(char-set "{}(),;=") lexeme]
+       [(char-set "[]{}(),;=") lexeme]
+       [(repetition 1 +inf.0 numeric) (token 'NUMBER (string->number lexeme))]
        [(repetition 1 +inf.0 (union alphabetic numeric "-")) (token 'ID (string->symbol lexeme))]))
     (get-token input-port))  
   next-token)