rewrite hdl-test language

beautiful-racket-lib/br/define.rkt

@@ -12,6 +12,9 @@
          (map loop maybe-list)
          stx))))
 
+(define-for-syntax (upcased? str)
+  (equal? (string-upcase str) str))
+
 (define-for-syntax (generate-literals pats)
   ;; generate literals for any symbols that are not ... or _ or _underscore-prefixed
   (define pattern-arg-prefixer "_")
@@ -19,7 +22,8 @@
              #:when (let ([pat-datum (syntax->datum pat-arg)])
                       (and (symbol? pat-datum)
                            (not (member pat-datum '(... _ else))) ; exempted from literality
-                           (not (string-prefix? (symbol->string pat-datum) pattern-arg-prefixer)))))
+                           (not (string-prefix? (symbol->string pat-datum) pattern-arg-prefixer))
+                           (not (upcased? (symbol->string pat-datum))))))
             pat-arg))
 
 ;; expose the caller context within br:define macros with syntax parameter
@@ -282,3 +286,13 @@
   (define-syntax-rule (falsy id) (#f id))
   
   (check-equal? (tree (foo (falsy a) (falsy b) (falsy c)) (values 1 2 3)) '(1 2 3)))
+
+
+(define-syntax (br:define-macro stx)
+  (syntax-case stx (syntax)
+    [(_ pat . body)
+     #'(br:define (syntax pat) . body)]))
+
+(module+ test
+  (br:define-macro (add _x) #'(+ _x _x))
+  (check-equal? (add 5) 10))

beautiful-racket-lib/br/syntax.rkt

@@ -17,6 +17,8 @@
   ;; one-arg form allows you to inject an existing syntax object using its current name
   (syntax-case stx (syntax)
     [(_ ([(syntax sid) sid-stx] ...) body ...)
+     #'(inject-syntax ([sid sid-stx] ...) body ...)]
+    [(_ ([sid sid-stx] ...) body ...)
      #'(with-syntax ([sid sid-stx] ...) body ...)]
     ;; todo: limit `sid` to be an identifier
     [(_ ([sid] ...) body ...)
@@ -29,9 +31,13 @@
      #'(inject-syntax (stx-expr0)
                       (inject-syntax* (stx-expr ...) . body))]))
 
+(define-syntax let-syntax-pattern (make-rename-transformer #'inject-syntax*))
+(define-syntax let*-syntax-pattern (make-rename-transformer #'inject-syntax*))
 (define-syntax syntax-let (make-rename-transformer #'inject-syntax))
 (define-syntax add-syntax (make-rename-transformer #'inject-syntax))
 
+(define-syntax-rule (test-macro mac-expr)
+  (syntax->datum (expand-once #'mac-expr)))
 
 (define (check-syntax-list-argument caller-name arg)
   (cond
@@ -73,14 +79,14 @@
       x))
 
 (define-syntax-rule (prefix-id _prefix ... _base)
-  (format-id _base "~a~a" (string-append (format "~a" (->unsyntax _prefix)) ...) _base))
+  (format-id _base "~a~a" (string-append (format "~a" (->unsyntax _prefix)) ...) (syntax-e _base)))
 
 (define-syntax-rule (prefix-ids _prefix ... _bases)
   (syntax-case-map _bases ()
                    [_base (prefix-id _prefix ... #'_base)]))
 
 (define-syntax-rule (infix-id _prefix _base _suffix ...)
-  (format-id _base "~a~a~a" (->unsyntax _prefix) _base (string-append (format "~a" (->unsyntax _suffix)) ...)))
+  (format-id _base "~a~a~a" (->unsyntax _prefix) (syntax-e _base) (string-append (format "~a" (->unsyntax _suffix)) ...)))
 
 (define-syntax-rule (infix-ids _prefix _bases _suffix ...)
   (syntax-case-map _bases ()

beautiful-racket/br/demo/Or.cmp

@@ -0,0 +1,5 @@
+|   a   |   b   |  out  |
+|   0   |   0   |   0   |
+|   0   |   1   |   1   |
+|   1   |   0   |   1   |
+|   1   |   1   |   1   |

beautiful-racket/br/demo/Or.tst

@@ -0,0 +1,29 @@
+// 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/Or.tst
+
+load Or.hdl,
+output-file Or.out,
+compare-to Or.cmp,
+output-list a%B3.1.3 b%B3.1.3 out%B3.1.3;
+
+set a 0,
+set b 0,
+eval,
+output;
+
+set a 0,
+set b 1,
+eval,
+output;
+
+set a 1,
+set b 0,
+eval,
+output;
+
+set a 1,
+set b 1,
+eval,
+output;

beautiful-racket/br/demo/Xor.cmp

@@ -0,0 +1,5 @@
+|   a   |   b   |  out  |
+|   0   |   0   |   0   |
+|   0   |   1   |   1   |
+|   1   |   0   |   1   |
+|   1   |   1   |   0   |

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

@@ -1,54 +1,62 @@
 #lang br
-(require (for-syntax br/syntax))
+(require (for-syntax br/syntax br/scope))
-(provide #%top-interaction #%module-begin #%datum (rename-out [my-top #%top]) #%app
+(provide #%top-interaction #%module-begin #%datum #;(rename-out [my-top #%top]) #%app
-         (all-defined-out))
+         (all-defined-out) (all-from-out br))
 
-; #%app and #%datum have to be present to make #%top work
+(require br/demo/hdl-tst/hdlprint rackunit racket/file (for-syntax racket/string))
-(define #'(my-top . id)
+
-  #'(begin
+(define-for-syntax chip-prefix #f)
-      (displayln (format "got unbound identifier: ~a" 'id))
-      (procedure-rename (λ xs (cons 'id xs)) (string->symbol (format "undefined:~a" 'id)))))
 
-(define #'(tst-program _arg ...) #'(begin _arg ...))
+(define-macro (tst-program ARG ...)
+  (let-syntax-pattern ([compare (shared-syntax #'compare)]
+                       [of (shared-syntax #'of)])
+                      #'(begin ARG ... (close-output-port of) (compare) )))
 
-(begin-for-syntax
+(define-macro (load-expr CHIPFILE-STRING)
-  (define-scope blue))
+  (let ()
+    (set! chip-prefix (string-replace (syntax->datum #'CHIPFILE-STRING) ".hdl" ""))
+    (let-syntax-pattern ([CHIPFILE.RKT (format-string "~a.rkt" #'CHIPFILE-STRING)])
+                        #'(require CHIPFILE.RKT))))
 
-(define #'(header-expr _filename (_colid ... _outid))
+(define-macro (output-file-expr OUTPUT-FILE-STRING)
-  (with-syntax* ([filename-string (symbol->string (syntax->datum #'_filename))]
+  (let-syntax-pattern ([ofname (shared-syntax #'ofname)]
-                 [procname (string->symbol (cadr (regexp-match #rx"^(.*)\\.hdl$"(symbol->string (syntax->datum #'_filename)))))])
+                       [of (shared-syntax #'of)])
-    (with-blue-binding-form (output)
                       #'(begin
-                                (provide (all-defined-out))
+                          (define ofname OUTPUT-FILE-STRING)
-                                (define procname
+                          (define of (open-output-file ofname #:mode 'text #:exists 'replace)))))
-                                  (dynamic-require (findf file-exists?
+
-                                                          (list filename-string (format "~a.rkt" filename-string))) 'procname))
+(define-macro (compare-to-expr COMPARE-FILE-STRING)
-                                (display-header '_colid ... '_outid)
+  (let-syntax-pattern ([compare (shared-syntax 'compare)]
-                                (define _colid (make-parameter 0)) ...
+                       [ofname (shared-syntax 'ofname)])
-                                (define (_outid)
+                      #'(define (compare)
-                                  (keyword-apply procname
+                          (check-equal? (file->lines ofname) (file->lines COMPARE-FILE-STRING)))))
-                                                 (map (compose1 string->keyword symbol->string) (list '_colid ...))
+
-                                                 (list (_colid) ...) null))
+(define-macro (output-list-expr (COL-NAME FORMAT-SPEC) ...)
-                                
+  (let-syntax-pattern ([(COL-ID ...) (prefix-ids "" #'(COL-NAME ...))]
-                                (define (output)
+                       [(CHIP-COL-ID ...) (prefix-ids chip-prefix "-" #'(COL-NAME ...))]
-                                  (display-values (_colid) ... (_outid)))))))
+                       [output (shared-syntax 'output)]
-
+                       [of (shared-syntax 'of)]
-(define #'(display-header _sym ...)
+                       [eval-result (shared-syntax 'eval-result)]
+                       [eval-thunk (shared-syntax 'eval-thunk)])
                       #'(begin
-      (apply display-values (list _sym ...))
+                          (define (output COL-ID ...)
-      (apply display-dashes (list _sym ...))))
+                            (fprintf of (format "~a\n" (string-join (list (hdlprint COL-ID FORMAT-SPEC) ...) "|"
-
+                                                                    #:before-first "|"
-(define (vals->text vals) (string-join (map ~a vals) " | "))
+                                                                    #:after-last "|"))))
-
+                          (define eval-result #f)
-(define (display-values . vals) (displayln (vals->text vals)))
+                          (define eval-thunk (λ () (list (CHIP-COL-ID) ...)))
-
+                          (output COL-NAME ...))))
-(define (display-dashes . vals)
+
-  (displayln (make-string (string-length (vals->text vals)) #\-)))
+(define-macro (set-expr IN-BUS IN-VAL)
-
+  (let-syntax-pattern ([CHIP-IN-BUS-ID-WRITE (prefix-id chip-prefix "-" (suffix-id #'IN-BUS "-write"))])
-(define #'test-expr #'begin)
+                      #'(CHIP-IN-BUS-ID-WRITE IN-VAL)))
-
+
-(define #'eval-expr #'void)
+(define-macro (eval-expr)
-
+  (let-syntax-pattern ([eval-result (shared-syntax 'eval-result)]
-(define #'(output-expr)
+                       [eval-thunk (shared-syntax 'eval-thunk)])
-  (with-blue-identifiers (output)
+                      #'(set! eval-result (eval-thunk))))
-                        #'(output)))
+
+(define-macro (output-expr)
+  (let-syntax-pattern ([output (shared-syntax 'output)]
+                       [eval-result (shared-syntax 'eval-result)])
+                      #'(apply output eval-result)))

beautiful-racket/br/demo/hdl-tst/hdlprint.rkt

@@ -1,19 +1,23 @@
 #lang racket
-
+(provide hdlprint)
 
 (define (hdlprint val fmt)
   (match-define (list _ radix-letter number-strings) (regexp-match #px"^%(.)(.*)$" fmt)) ; like %B1.16.1
   (match-define (list left-margin width right-margin) (map string->number (string-split number-strings ".")))
+  (cond
+    [(number? val)
       (define radix (case radix-letter
                      [("B") 2]))
         (string-append (make-string left-margin #\space)
-                 (if (number? val)
                        (~r val #:min-width width #:pad-string "0" #:base radix)
-                     (~a val #:min-width width #:pad-string " " #:align 'center))
+                       (make-string right-margin #\space))]
-                 (make-string right-margin #\space)))
+    [(string? val) (~a val #:min-width (+ left-margin width right-margin) #:pad-string " " #:align 'center)]
+    [else (error 'unknown-value)]))
 
 (module+ test
-(require rackunit)
+  (require rackunit)
-(define a 123)
+  (define a 123)
-(check-equal? (hdlprint a "%B1.16.1") " 0000000001111011 ")
+  (check-equal? (hdlprint a "%B1.16.1") " 0000000001111011 ")
-(check-equal? (hdlprint "out" "%B1.16.1") "       out        "))
+  (check-equal? (hdlprint "out" "%B1.16.1") "       out        ")
+  (check-equal? (hdlprint "out" "%B3.1.3") "  out  ")
+  (check-equal? (hdlprint "in" "%B3.1.3") "  in   "))

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

@@ -1,20 +1,22 @@
 #lang brag
 
-tst-program : header-expr test-expr*
+tst-program : load-expr output-file-expr compare-to-expr output-list-expr /";" test-expr*
 
-header-expr : load-expr table-expr /";"
+load-expr : /"load" ID /","
 
-@load-expr : /"load" ID /","
+output-file-expr : /"output-file" ID /","
 
-/table-expr : /"output-list" columns
+compare-to-expr : /"compare-to" ID /","
 
-@columns :  ID [/"," columns]
+output-list-expr : /"output-list" column [column]+
 
-test-expr : step-expr+ /";"
+/column :  ID FORMAT-STRING
 
-@step-expr : (set-expr | @eval-expr | output-expr) [/","]
+@test-expr : step-expr+ /";"
 
-/set-expr : /"set" ID VAL
+@step-expr : (set-expr | eval-expr | output-expr) [/","]
+
+set-expr : /"set" ID VAL
 
 eval-expr : /"eval"
 

beautiful-racket/br/demo/hdl-tst/tokenizer.rkt

@@ -14,8 +14,9 @@
          (seq "//" (repetition 1 +inf.0 (char-complement #\newline)) #\newline))
         (token 'COMMENT lexeme #:skip? #t)]
        [(union #\tab #\space #\newline) (get-token input-port)]
-       [(union "load" "output-list" "set" "eval" "output" (char-set ",;")) lexeme]
+       [(union "load" "output-list" "output-file" "compare-to" "set" "eval" "output" (char-set ",;")) lexeme]
+       [(seq "%" (repetition 1 +inf.0 (union alphabetic numeric (char-set ".")))) (token 'FORMAT-STRING lexeme)]
        [(repetition 1 +inf.0 numeric) (token 'VAL (string->number lexeme))]
-       [(repetition 1 +inf.0 (union alphabetic numeric (char-set "-."))) (token 'ID (string->symbol lexeme))]))
+       [(repetition 1 +inf.0 (union alphabetic numeric (char-set "-."))) (token 'ID lexeme)]))
     (get-token input-port))  
   next-token)

beautiful-racket/br/demo/hdl/And.cmp

@@ -0,0 +1,5 @@
+|   a   |   b   |  out  |
+|   0   |   0   |   0   |
+|   0   |   1   |   0   |
+|   1   |   0   |   0   |
+|   1   |   1   |   1   |

beautiful-racket/br/demo/hdl/And.out

@@ -0,0 +1,5 @@
+|   a   |   b   |  out  |
+|   0   |   0   |   0   |
+|   0   |   1   |   0   |
+|   1   |   0   |   0   |
+|   1   |   1   |   1   |

beautiful-racket/br/demo/hdl/And.tst.rkt

@@ -1,14 +1,31 @@
 #lang br/demo/hdl-tst
 
-/* and */
+// 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/And.tst
 
 load And.hdl,
-output-list a, b, out;
+output-file And.out,
-set a 0, set b 0,
+compare-to And.cmp,
-eval, output;
+output-list a%B3.1.3 b%B3.1.3 out%B3.1.3;
-set a 0, set b 1,
+
-eval, output;
+set a 0,
-set a 1, set b 0,
+set b 0,
-eval, output;
+eval,
-set a 1, set b 1,
+output;
-eval, output;
+
+set a 0,
+set b 1,
+eval,
+output;
+
+set a 1,
+set b 0,
+eval,
+output;
+
+set a 1,
+set b 1,
+eval,
+output;

beautiful-racket/br/demo/hdl/DMux.cmp

@@ -0,0 +1,5 @@
+|  in   |  sel  |   a   |   b   |
+|   0   |   0   |   0   |   0   |
+|   0   |   1   |   0   |   0   |
+|   1   |   0   |   1   |   0   |
+|   1   |   1   |   0   |   1   |

beautiful-racket/br/demo/hdl/DMux.out

@@ -0,0 +1,5 @@
+|  in   |  sel  |   a   |   b   |
+|   0   |   0   |   0   |   0   |
+|   0   |   1   |   0   |   0   |
+|   1   |   0   |   1   |   0   |
+|   1   |   1   |   0   |   1   |

beautiful-racket/br/demo/hdl/DMux.tst

@@ -0,0 +1,27 @@
+// 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/DMux.tst
+
+load DMux.hdl,
+output-file DMux.out,
+compare-to DMux.cmp,
+output-list in%B3.1.3 sel%B3.1.3 a%B3.1.3 b%B3.1.3;
+
+set in 0,
+set sel 0,
+eval,
+output;
+
+set sel 1,
+eval,
+output;
+
+set in 1,
+set sel 0,
+eval,
+output;
+
+set sel 1,
+eval,
+output;

beautiful-racket/br/demo/hdl/DMux4Way.cmp

@@ -0,0 +1,9 @@
+| in  | sel  |  a  |  b  |  c  |  d  |
+|  0  |  00  |  0  |  0  |  0  |  0  |
+|  0  |  01  |  0  |  0  |  0  |  0  |
+|  0  |  10  |  0  |  0  |  0  |  0  |
+|  0  |  11  |  0  |  0  |  0  |  0  |
+|  1  |  00  |  1  |  0  |  0  |  0  |
+|  1  |  01  |  0  |  1  |  0  |  0  |
+|  1  |  10  |  0  |  0  |  1  |  0  |
+|  1  |  11  |  0  |  0  |  0  |  1  |

beautiful-racket/br/demo/hdl/DMux4Way.tst

@@ -0,0 +1,43 @@
+// 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.tst
+
+load DMux4Way.hdl,
+output-file DMux4Way.out,
+compare-to DMux4Way.cmp,
+output-list in%B2.1.2 sel%B2.2.2 a%B2.1.2 b%B2.1.2 c%B2.1.2 d%B2.1.2;
+
+set in 0,
+set sel %B00,
+eval,
+output;
+
+set sel %B01,
+eval,
+output;
+
+set sel %B10,
+eval,
+output;
+
+set sel %B11,
+eval,
+output;
+
+set in 1,
+set sel %B00,
+eval,
+output;
+
+set sel %B01,
+eval,
+output;
+
+set sel %B10,
+eval,
+output;
+
+set sel %B11,
+eval,
+output;

beautiful-racket/br/demo/hdl/DMux4Way.tst.rkt

@@ -0,0 +1,45 @@
+#lang br/demo/hdl-tst
+
+// 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.tst
+
+load DMux4Way.hdl,
+output-file DMux4Way.out,
+compare-to DMux4Way.cmp,
+output-list in%B2.1.2 sel%B2.2.2 a%B2.1.2 b%B2.1.2 c%B2.1.2 d%B2.1.2;
+
+set in 0,
+set sel %B00,
+eval,
+output;
+
+set sel %B01,
+eval,
+output;
+
+set sel %B10,
+eval,
+output;
+
+set sel %B11,
+eval,
+output;
+
+set in 1,
+set sel %B00,
+eval,
+output;
+
+set sel %B01,
+eval,
+output;
+
+set sel %B10,
+eval,
+output;
+
+set sel %B11,
+eval,
+output;

beautiful-racket/br/demo/hdl/Dmux.tst.rkt

@@ -6,10 +6,9 @@
 // File name: projects/01/DMux.tst
 
 load DMux.hdl,
-// output-file DMux.out,
+output-file DMux.out,
-// compare-to DMux.cmp,
+compare-to DMux.cmp,
-// output-list in%B3.1.3 sel%B3.1.3 a%B3.1.3 b%B3.1.3;
+output-list in%B3.1.3 sel%B3.1.3 a%B3.1.3 b%B3.1.3;
-output-list in, sel, a, b;
 
 set in 0,
 set sel 0,

beautiful-racket/br/demo/hdl/HalfAdder.cmp

@@ -0,0 +1,5 @@
+|   a   |   b   |  sum  | carry |
+|   0   |   0   |   0   |   0   |
+|   0   |   1   |   1   |   0   |
+|   1   |   0   |   1   |   0   |
+|   1   |   1   |   0   |   1   |

beautiful-racket/br/demo/hdl/HalfAdder.out

@@ -0,0 +1,5 @@
+|   a   |   b   |  sum  | carry |
+|   0   |   0   |   0   |   0   |
+|   0   |   1   |   1   |   0   |
+|   1   |   0   |   1   |   0   |
+|   1   |   1   |   0   |   1   |

beautiful-racket/br/demo/hdl/HalfAdder.tst.rkt

@@ -0,0 +1,31 @@
+#lang br/demo/hdl-tst
+
+// 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/02/HalfAdder.tst
+
+load HalfAdder.hdl,
+output-file HalfAdder.out,
+compare-to HalfAdder.cmp,
+output-list a%B3.1.3 b%B3.1.3 sum%B3.1.3 carry%B3.1.3;
+
+set a 0,
+set b 0,
+eval,
+output;
+
+set a 0,
+set b 1,
+eval,
+output;
+
+set a 1,
+set b 0,
+eval,
+output;
+
+set a 1,
+set b 1,
+eval,
+output;

beautiful-racket/br/demo/hdl/Mux.cmp

@@ -0,0 +1,9 @@
+|   a   |   b   |  sel  |  out  |
+|   0   |   0   |   0   |   0   |
+|   0   |   0   |   1   |   0   |
+|   0   |   1   |   0   |   0   |
+|   0   |   1   |   1   |   1   |
+|   1   |   0   |   0   |   1   |
+|   1   |   0   |   1   |   0   |
+|   1   |   1   |   0   |   1   |
+|   1   |   1   |   1   |   1   |

beautiful-racket/br/demo/hdl/Mux.out

@@ -0,0 +1,9 @@
+|   a   |   b   |  sel  |  out  |
+|   0   |   0   |   0   |   0   |
+|   0   |   0   |   1   |   0   |
+|   0   |   1   |   0   |   0   |
+|   0   |   1   |   1   |   1   |
+|   1   |   0   |   0   |   1   |
+|   1   |   0   |   1   |   0   |
+|   1   |   1   |   0   |   1   |
+|   1   |   1   |   1   |   1   |

beautiful-racket/br/demo/hdl/Mux.tst

@@ -0,0 +1,49 @@
+// 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/Mux.tst
+
+load Mux.hdl,
+output-file Mux.out,
+compare-to Mux.cmp,
+output-list a%B3.1.3 b%B3.1.3 sel%B3.1.3 out%B3.1.3;
+
+set a 0,
+set b 0,
+set sel 0,
+eval,
+output;
+
+set sel 1,
+eval,
+output;
+
+set a 0,
+set b 1,
+set sel 0,
+eval,
+output;
+
+set sel 1,
+eval,
+output;
+
+set a 1,
+set b 0,
+set sel 0,
+eval,
+output;
+
+set sel 1,
+eval,
+output;
+
+set a 1,
+set b 1,
+set sel 0,
+eval,
+output;
+
+set sel 1,
+eval,
+output;

beautiful-racket/br/demo/hdl/Mux.tst.rkt

@@ -5,10 +5,9 @@
 // File name: projects/01/Mux.tst
 
 load Mux.hdl,
-// output-file Mux.out,
+output-file Mux.out,
-// compare-to Mux.cmp,
+compare-to Mux.cmp,
-// output-list a%B3.1.3 b%B3.1.3 sel%B3.1.3 out%B3.1.3;
+output-list a%B3.1.3 b%B3.1.3 sel%B3.1.3 out%B3.1.3;
-output-list a, b, sel, out;
 
 set a 0,
 set b 0,

beautiful-racket/br/demo/hdl/Not.cmp

@@ -0,0 +1,3 @@
+|  in   |  out  |
+|   0   |   1   |
+|   1   |   0   |

beautiful-racket/br/demo/hdl/Not.out

@@ -0,0 +1,3 @@
+|  in   |  out  |
+|   0   |   1   |
+|   1   |   0   |

beautiful-racket/br/demo/hdl/Not.tst-sexp.rkt

@@ -0,0 +1,34 @@
+#lang s-exp br/demo/hdl-tst/expander
+
+
+#|
+load Not.hdl,
+output-file Not.out,
+compare-to Not.cmp,
+output-list in%B3.1.3 out%B3.1.3;
+set in 0,
+eval,
+output;
+set in 1,
+eval,
+output;
+
+|#
+
+(require br/demo/hdl-tst/hdlprint rackunit racket/file)
+(require "Not.hdl.rkt") ; load Not.hdl,
+(define of (open-output-file "Not.out" #:mode 'text #:exists 'replace)) ; output-file Not.out,
+(define (output in out) ; output-list in%B3.1.3 out%B3.1.3;
+(fprintf of (format "~a\n" (string-join (list (hdlprint in "%B3.1.3") (hdlprint out "%B3.1.3")) "|" #:before-first "|" #:after-last "|"))))  
+(define eval-result #f)
+(define eval-thunk (λ () (list (Not-in) (Not-out)))) ; output-list in%B3.1.3 out%B3.1.3;
+(output "in" "out") ; put names at top of output
+(Not-in-write 0) ; set in 0,
+(set! eval-result (eval-thunk)) ; eval,
+(apply output eval-result) ; output;
+(Not-in-write 1) ; set in 1,
+(set! eval-result (eval-thunk)) ; eval,
+(apply output eval-result) ; output;
+(close-output-port of)
+(display (file->string "Not.out"))
+(check-equal? (file->lines "Not.out") (file->lines "Not.cmp")) ; compare-to Not.cmp,

beautiful-racket/br/demo/hdl/Not.tst.rkt

@@ -1,10 +1,14 @@
 #lang br/demo/hdl-tst
 
-/* Not */
-
 load Not.hdl,
-output-list in, out;
+output-file Not.out,
+compare-to Not.cmp,
+output-list in%B3.1.3 out%B3.1.3;
+
 set in 0,
-eval, output;
+eval,
+output;
+
 set in 1,
-eval, output;
+eval,
+output;

beautiful-racket/br/demo/hdl/Or.cmp

@@ -0,0 +1,5 @@
+|   a   |   b   |  out  |
+|   0   |   0   |   0   |
+|   0   |   1   |   1   |
+|   1   |   0   |   1   |
+|   1   |   1   |   1   |

beautiful-racket/br/demo/hdl/Or.out

@@ -0,0 +1,5 @@
+|   a   |   b   |  out  |
+|   0   |   0   |   0   |
+|   0   |   1   |   1   |
+|   1   |   0   |   1   |
+|   1   |   1   |   1   |

beautiful-racket/br/demo/hdl/Or.tst

@@ -0,0 +1,29 @@
+// 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/Or.tst
+
+load Or.hdl,
+output-file Or.out,
+compare-to Or.cmp,
+output-list a%B3.1.3 b%B3.1.3 out%B3.1.3;
+
+set a 0,
+set b 0,
+eval,
+output;
+
+set a 0,
+set b 1,
+eval,
+output;
+
+set a 1,
+set b 0,
+eval,
+output;
+
+set a 1,
+set b 1,
+eval,
+output;

beautiful-racket/br/demo/hdl/Or.tst.rkt

@@ -1,14 +1,30 @@
 #lang br/demo/hdl-tst
-
+// This file is part of www.nand2tetris.org
-/* or */
+// and the book "The Elements of Computing Systems"
+// by Nisan and Schocken, MIT Press.
+// File name: projects/01/Or.tst
 
 load Or.hdl,
-output-list a, b, out;
+output-file Or.out,
-set a 0, set b 0,
+compare-to Or.cmp,
-eval, output;
+output-list a%B3.1.3 b%B3.1.3 out%B3.1.3;
-set a 0, set b 1,
+
-eval, output;
+set a 0,
-set a 1, set b 0,
+set b 0,
-eval, output;
+eval,
-set a 1, set b 1,
+output;
-eval, output;
+
+set a 0,
+set b 1,
+eval,
+output;
+
+set a 1,
+set b 0,
+eval,
+output;
+
+set a 1,
+set b 1,
+eval,
+output;

beautiful-racket/br/demo/hdl/Xor.cmp

@@ -0,0 +1,5 @@
+|   a   |   b   |  out  |
+|   0   |   0   |   0   |
+|   0   |   1   |   1   |
+|   1   |   0   |   1   |
+|   1   |   1   |   0   |

beautiful-racket/br/demo/hdl/Xor.out

@@ -0,0 +1,5 @@
+|   a   |   b   |  out  |
+|   0   |   0   |   0   |
+|   0   |   1   |   1   |
+|   1   |   0   |   1   |
+|   1   |   1   |   0   |

beautiful-racket/br/demo/hdl/Xor.tst

@@ -0,0 +1,29 @@
+// 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/Xor.tst
+
+load Xor.hdl,
+output-file Xor.out,
+compare-to Xor.cmp,
+output-list a%B3.1.3 b%B3.1.3 out%B3.1.3;
+
+set a 0,
+set b 0,
+eval,
+output;
+
+set a 0,
+set b 1,
+eval,
+output;
+
+set a 1,
+set b 0,
+eval,
+output;
+
+set a 1,
+set b 1,
+eval,
+output;

beautiful-racket/br/demo/hdl/Xor.tst.rkt

@@ -1,12 +1,31 @@
 #lang br/demo/hdl-tst
 
+// 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/Xor.tst
+
 load Xor.hdl,
-output-list a, b, out;
+output-file Xor.out,
-set a 0, set b 0,
+compare-to Xor.cmp,
-eval, output;
+output-list a%B3.1.3 b%B3.1.3 out%B3.1.3;
-set a 0, set b 1,
+
-eval, output;
+set a 0,
-set a 1, set b 0,
+set b 0,
-eval, output;
+eval,
-set a 1, set b 1,
+output;
-eval, output;
+
+set a 0,
+set b 1,
+eval,
+output;
+
+set a 1,
+set b 0,
+eval,
+output;
+
+set a 1,
+set b 1,
+eval,
+output;

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

@@ -1,29 +1,28 @@
 #lang br
-(require "helper.rkt" (for-syntax racket/base racket/syntax racket/require-transform br/syntax))
+(require "helper.rkt" (for-syntax racket/syntax racket/require-transform br/syntax))
-(provide #%top-interaction #%module-begin #%app #%datum and or (all-defined-out))
+(provide #%top-interaction #%module-begin #%app #%datum (all-defined-out))
-
+
-
+(define-macro (chip-program CHIPNAME
-(define #'(chip-program _chipname
+                            (in-spec (IN-BUS IN-WIDTH ...) ...)
-                        (in-spec (_in-bus _in-width ...) ...)
+                            (out-spec (OUT-BUS OUT-WIDTH ...) ...)
-                        (out-spec (_out-bus _out-width ...) ...)
+                            PART ...)
-                        _part ...)
+  (let-syntax-pattern ([CHIP-PREFIX (suffix-id #'CHIPNAME "-")]
-  (inject-syntax* ([#'_chip-prefix (suffix-id #'_chipname "-")]
+                       [(IN-BUS-WRITE ...) (suffix-ids #'(IN-BUS ...) "-write")]
-                   [#'(_in-bus-write ...) (suffix-ids #'(_in-bus ...) "-write")]
+                       [(PREFIX-OUT-BUS ...) (prefix-ids #'CHIP-PREFIX #'(OUT-BUS ...))])
-                   [#'(_prefix-out-bus ...) (prefix-ids #'_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 ...) ...
+                          (define-input-bus IN-BUS IN-WIDTH ...) ...
-                      _part ...
+                          PART ...
-                      (provide _prefix-out-bus ...)
+                          (provide PREFIX-OUT-BUS ...)
-                      (define-output-bus _prefix-out-bus _out-bus _out-width ...) ...)))
+                          (define-output-bus PREFIX-OUT-BUS OUT-BUS OUT-WIDTH ...) ...)))
 
 
-(define #'(part _partname ((_bus-left . _busargs) _bus-expr-right) ...)
+(define-macro (part PARTNAME ((BUS-LEFT . BUS-LEFT-ARGS) BUS-RIGHT-EXPR) ...)
-  (inject-syntax ([#'(_partname-bus-left ...) (prefix-ids #'_partname "-" #'(_bus-left ...))]
+  (let-syntax-pattern ([(PARTNAME-BUS-LEFT ...) (prefix-ids #'PARTNAME "-" #'(BUS-LEFT ...))]
-                  [#'_chip-module-path (format-string "~a.hdl.rkt" #'_partname)])
+                       [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) (for-syntax (import-chip CHIP-MODULE-PATH)))
-                     (handle-buses ((_partname-bus-left . _busargs) _bus-expr-right) ...))))
+                          (handle-buses ((PARTNAME-BUS-LEFT . BUS-LEFT-ARGS) BUS-RIGHT-EXPR) ...))))
 
 
 (define-syntax import-chip
@@ -34,16 +33,16 @@
         (expand-import #'module-path)]))))
 
 
-(define #'(handle-buses _bus-assignments ...)
+(define-macro (handle-buses BUS-ASSIGNMENTS ...)
-  (let-values ([(_in-bus-assignments _out-bus-assignments)
+  (let-values ([(in-bus-assignments out-bus-assignments)
-                (syntax-case-partition #'(_bus-assignments ...) ()
+                (syntax-case-partition #'(BUS-ASSIGNMENTS ...) ()
-                                       [((prefixed-wire . _wireargs) _)
+                                       [((PREFIXED-WIRE . _) _)
-                                        (syntax-local-eval (syntax-shift-phase-level #'(input-bus? prefixed-wire) 1))])])
+                                        (syntax-local-eval (syntax-shift-phase-level #'(input-bus? PREFIXED-WIRE) 1))])])
-    (inject-syntax* ([#'(((_in-bus _in-bus-arg ...) _in-bus-value) ...) _in-bus-assignments]
+    (let-syntax-pattern ([(((IN-BUS IN-BUS-ARG ...) _in-bus-value) ...) in-bus-assignments]
-                     [#'(_in-bus-write ...) (suffix-ids #'(_in-bus ...) "-write")]
+                         [(IN-BUS-WRITE ...) (suffix-ids #'(IN-BUS ...) "-write")]
-                     [#'((_out-bus-expr (_new-out-bus)) ...) _out-bus-assignments])
+                         [((OUT-BUS-EXPR (NEW-OUT-BUS)) ...) out-bus-assignments])
                         #'(begin
-                        (define-output-bus _new-out-bus
+                            (define-output-bus NEW-OUT-BUS
                               (λ ()
-                            (_in-bus-write _in-bus-arg ... _in-bus-value) ...
+                                (IN-BUS-WRITE IN-BUS-ARG ... _in-bus-value) ...
-                            _out-bus-expr)) ...))))
+                                OUT-BUS-EXPR)) ...))))

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

@@ -105,7 +105,7 @@ base bus:
   (make-impersonator-property 'bus))
 
 (define-cases #'define-base-bus
-  [#'(_macro-name _id _thunk) #'(_macro-name _id _thunk _default-bus-width)]
+  [#'(_macro-name _id _thunk) #'(_macro-name _id _thunk default-bus-width)]
   [#'(_macro-name _id _thunk _bus-width-in)
    (inject-syntax ([#'_id-thunk (suffix-id #'_id "-val")]
                    [#'_bus-type (or (syntax-property caller-stx 'impersonate) #'bus)])
@@ -117,7 +117,7 @@ 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)])
-                             (procedure-rename (λ args (apply reader (_id-thunk) args)) (string->symbol (format "~a, a bus of width ~a" 'id bus-width))))
+                             (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 caller-stx 'writer)
                           (inject-syntax ([#'_id-write (suffix-id #'_id "-write")])