notes

beautiful-racket/br/demo/chip8.rkt

@@ -33,33 +33,35 @@
   (check-equal? #xA (glue-bytes (list #xA)))
   (check-equal? #x0 (glue-bytes (list #x0))))
 
-(define-syntax (define-memory-vector stx)
+(define-macro (define-memory-vector ID [FIELD LENGTH SIZE] ...)
-  (syntax-case stx ()
+  (with-pattern
-    [(_ ID [FIELD LENGTH SIZE] ...)
+   ([(PREFIXED-ID ...)  (prefix-id #'ID "-" #'(FIELD ...))]
-     (with-syntax ([(ID-FIELD-REF ...) (map (λ(field) (format-id stx "~a-~a-ref" #'ID field)) (syntax->list #'(FIELD ...)))]
+    [(PREFIXED-ID-REF ...) (suffix-id #'(PREFIXED-ID ...) "-ref")]
-                   [(ID-FIELD-SET! ...) (map (λ(field) (format-id stx "~a-~a-set!" #'ID field)) (syntax->list #'(FIELD ...)))]
+    [(PREFIXED-ID-SET! ...) (suffix-id #'(PREFIXED-ID ...) "-set!")]
-                   [(FIELD-OFFSET ...) (reverse (cdr
+    [(FIELD-OFFSET ...) (reverse (cdr
-                                                 (for/fold ([offsets '(0)])
+                                  (for/fold ([accum-stxs (list #'0)])
-                                                           ([len (in-list (syntax->list #'(LENGTH ...)))]
+                                            ([len-size-stx (in-list (syntax->list #'((LENGTH SIZE) ...)))])
-                                                            [size (in-list  (syntax->list #'(SIZE ...)))])
+                                    (cons (with-pattern
-                                                   (cons (+ (syntax-local-eval #`(* #,len #,size)) (car offsets)) offsets))))])
+                                           ([accum (car accum-stxs)]
-       #'(begin
+                                            [(len size) len-size-stx])
-           (define ID (make-vector (+ (* LENGTH SIZE) ...)))
+                                           #'(+ (* len size) accum)) accum-stxs))))])
-           (define (ID-FIELD-REF idx)
+   #'(begin
-             (unless (< idx LENGTH)
+       (define ID (make-vector (+ (* LENGTH SIZE) ...)))
-               (raise-argument-error 'ID-FIELD-REF (format "index less than field length ~a" LENGTH) idx))
+       (define (PREFIXED-ID-REF idx)
-             (glue-bytes
+         (unless (< idx LENGTH)
-              (for/list ([i (in-range SIZE)])
+           (raise-argument-error 'PREFIXED-ID-REF (format "index less than field length ~a" LENGTH) idx))
-                        (vector-ref ID (+ FIELD-OFFSET i idx)))))
+         (glue-bytes
-           ...
+          (for/list ([i (in-range SIZE)])
-           (define (ID-FIELD-SET! idx val)
+                    (vector-ref ID (+ FIELD-OFFSET i idx)))))
-             (unless (< idx LENGTH)
+       ...
-               (raise-argument-error 'ID-FIELD-SET! (format "index less than field length ~a" LENGTH) idx))
+       (define (PREFIXED-ID-SET! idx val)
-             (unless (< val (expt 16 SIZE))
+         (unless (< idx LENGTH)
-               (raise-argument-error 'ID-FIELD-SET! (format "value less than field size ~a" (expt 16 SIZE)) val))
+           (raise-argument-error 'PREFIXED-ID-SET! (format "index less than field length ~a" LENGTH) idx))
-             (for ([i (in-range SIZE)]
+         (unless (< val (expt 16 SIZE))
-                   [b (in-list (explode-bytes val))])
+           (raise-argument-error 'PREFIXED-ID-SET! (format "value less than field size ~a" (expt 16 SIZE)) val))
-                  (vector-set! ID (+ FIELD-OFFSET i idx) b))) ...))]))
+         (for ([i (in-range SIZE)]
+               [b (in-list (explode-bytes val))])
+              (vector-set! ID (+ FIELD-OFFSET i idx) b))) ...)))
 
 (define-memory-vector chip 
   [opcode 1 2] ; two bytes

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

@@ -12,7 +12,7 @@
 
 (module+ test
   (require rackunit)
-  (check-equal? (begin (a 0) (b 0) (out)) 1)
+  (check-equal? (begin (a-write 0) (b-write 0) (out)) 1)
-  (check-equal? (begin (a 0) (b 1) (out)) 1)
+  (check-equal? (begin (a-write 0) (b-write 1) (out)) 1)
-  (check-equal? (begin (a 1) (b 0) (out)) 1)
+  (check-equal? (begin (a-write 1) (b-write 0) (out)) 1)
-  (check-equal? (begin (a 1) (b 1) (out)) 0))
+  (check-equal? (begin (a-write 1) (b-write 1) (out)) 0))

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

@@ -11,7 +11,7 @@
     [(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 ...))) 
+       (provide (prefix-out CHIP-PREFIX (combine-out IN-BUS ... IN-BUS-WRITE ...)))
        (define-input-bus IN-BUS IN-WIDTH ...) ...
        PART ...
        (provide PREFIX-OUT-BUS ...)
@@ -23,7 +23,11 @@
    ([(PARTNAME-BUS-LEFT ...) (prefix-id #'PARTNAME "-" #'(BUS-LEFT ...))]
     [CHIP-MODULE-PATH (format-string "~a.hdl.rkt" #'PARTNAME)])
    #'(begin
-       (require (import-chip CHIP-MODULE-PATH) (for-syntax (import-chip CHIP-MODULE-PATH)))
+       (require (import-chip CHIP-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 CHIP-MODULE-PATH))) 
        (handle-buses ((PARTNAME-BUS-LEFT . BUS-LEFT-ARGS) BUS-RIGHT-EXPR) ...))))
 
 
@@ -40,6 +44,10 @@
       ([(in-bus-assignments out-bus-assignments)
         (syntax-case-partition #'(BUS-ASSIGNMENTS ...) ()
                                [((PREFIXED-WIRE . _) _)
+                                ;; we "pre-evaluate" #'PREFIXED-WIRE so we can set up the program correctly.
+                                ;; This is not ideal: usually we want evaluate runtime expressions only at runtime.
+                                ;; But in this case, it controls which identifiers we `define`
+                                ;; 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]