diff --git a/beautiful-racket-lib/br/define.rkt b/beautiful-racket-lib/br/define.rkt index fb229d0..892c119 100644 --- a/beautiful-racket-lib/br/define.rkt +++ b/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 @@ -107,9 +111,9 @@ (check-equal? (elseop "+") 'got-arg) (check-equal? (elseop "+" 42) 'got-else) - (check-exn exn:fail:syntax? (λ _ (expand-once #'(br:define-cases #'badelseop - [else #''got-else] - [#'(_ _arg) #''got-arg])))) + (check-exn exn:fail:syntax? (λ _ (expand-once #'(br:define-cases #'badelseop + [else #''got-else] + [#'(_ _arg) #''got-arg])))) (br:define-cases f [(_ arg) (add1 arg)] @@ -157,7 +161,7 @@ #:fail-when (not (= (length (syntax->datum #'(stx-arg ...))) 1)) (raise-syntax-error 'define "did not get exactly one argument for macro" (syntax->datum #'(stx-arg ...))) (with-syntax ([(first-stx-arg other ...) #'(stx-arg ...)]) - #'(define-syntax (sid.name first-stx-arg) . exprs))] + #'(define-syntax (sid.name first-stx-arg) . exprs))] [(_ . args) #'(define . args)])) @@ -253,12 +257,12 @@ (syntax-case stx () [(_id . rest) (let ([expanded-stx (with-syntax ([expanded-macros (map expand-macro (syntax->list #'rest))]) - #'(_id . expanded-macros))]) + #'(_id . expanded-macros))]) (define result (syntax-case expanded-stx LITERALS [_patarg (syntax-parameterize ([caller-stx (make-rename-transformer #'stx)]) - (syntax-parameterize ([shared-syntax (make-shared-syntax-macro caller-stx)]) - . _bodyexprs))] ... + (syntax-parameterize ([shared-syntax (make-shared-syntax-macro caller-stx)]) + . _bodyexprs))] ... [else (raise-syntax-error 'define-cases-inverting (format "no matching case for syntax pattern ~v" (syntax->datum stx)) (syntax->datum #'_id))])) (if (syntax? result) result @@ -281,4 +285,14 @@ (define-syntax-rule (falsy id) (#f id)) - (check-equal? (tree (foo (falsy a) (falsy b) (falsy c)) (values 1 2 3)) '(1 2 3))) \ No newline at end of file + (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)) \ No newline at end of file diff --git a/beautiful-racket-lib/br/syntax.rkt b/beautiful-racket-lib/br/syntax.rkt index efa1a9d..3223584 100644 --- a/beautiful-racket-lib/br/syntax.rkt +++ b/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 () diff --git a/beautiful-racket/br/demo/Or.cmp b/beautiful-racket/br/demo/Or.cmp new file mode 100755 index 0000000..dab924c --- /dev/null +++ b/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 | diff --git a/beautiful-racket/br/demo/Or.tst b/beautiful-racket/br/demo/Or.tst new file mode 100755 index 0000000..948b6b3 --- /dev/null +++ b/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; diff --git a/beautiful-racket/br/demo/Xor.cmp b/beautiful-racket/br/demo/Xor.cmp new file mode 100755 index 0000000..a1e07b2 --- /dev/null +++ b/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 | diff --git a/beautiful-racket/br/demo/hdl-tst/expander.rkt b/beautiful-racket/br/demo/hdl-tst/expander.rkt index b6cc053..ee9692a 100644 --- a/beautiful-racket/br/demo/hdl-tst/expander.rkt +++ b/beautiful-racket/br/demo/hdl-tst/expander.rkt @@ -1,54 +1,62 @@ #lang br -(require (for-syntax br/syntax)) -(provide #%top-interaction #%module-begin #%datum (rename-out [my-top #%top]) #%app - (all-defined-out)) - -; #%app and #%datum have to be present to make #%top work -(define #'(my-top . id) - #'(begin - (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 ...)) - -(begin-for-syntax - (define-scope blue)) - -(define #'(header-expr _filename (_colid ... _outid)) - (with-syntax* ([filename-string (symbol->string (syntax->datum #'_filename))] - [procname (string->symbol (cadr (regexp-match #rx"^(.*)\\.hdl$"(symbol->string (syntax->datum #'_filename)))))]) - (with-blue-binding-form (output) - #'(begin - (provide (all-defined-out)) - (define procname - (dynamic-require (findf file-exists? - (list filename-string (format "~a.rkt" filename-string))) 'procname)) - (display-header '_colid ... '_outid) - (define _colid (make-parameter 0)) ... - (define (_outid) - (keyword-apply procname - (map (compose1 string->keyword symbol->string) (list '_colid ...)) - (list (_colid) ...) null)) - - (define (output) - (display-values (_colid) ... (_outid))))))) - -(define #'(display-header _sym ...) - #'(begin - (apply display-values (list _sym ...)) - (apply display-dashes (list _sym ...)))) - -(define (vals->text vals) (string-join (map ~a vals) " | ")) - -(define (display-values . vals) (displayln (vals->text vals))) - -(define (display-dashes . vals) - (displayln (make-string (string-length (vals->text vals)) #\-))) - -(define #'test-expr #'begin) - -(define #'eval-expr #'void) - -(define #'(output-expr) - (with-blue-identifiers (output) - #'(output))) +(require (for-syntax br/syntax br/scope)) +(provide #%top-interaction #%module-begin #%datum #;(rename-out [my-top #%top]) #%app + (all-defined-out) (all-from-out br)) + +(require br/demo/hdl-tst/hdlprint rackunit racket/file (for-syntax racket/string)) + +(define-for-syntax chip-prefix #f) + +(define-macro (tst-program ARG ...) + (let-syntax-pattern ([compare (shared-syntax #'compare)] + [of (shared-syntax #'of)]) + #'(begin ARG ... (close-output-port of) (compare) ))) + +(define-macro (load-expr CHIPFILE-STRING) + (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-macro (output-file-expr OUTPUT-FILE-STRING) + (let-syntax-pattern ([ofname (shared-syntax #'ofname)] + [of (shared-syntax #'of)]) + #'(begin + (define ofname OUTPUT-FILE-STRING) + (define of (open-output-file ofname #:mode 'text #:exists 'replace))))) + +(define-macro (compare-to-expr COMPARE-FILE-STRING) + (let-syntax-pattern ([compare (shared-syntax 'compare)] + [ofname (shared-syntax 'ofname)]) + #'(define (compare) + (check-equal? (file->lines ofname) (file->lines COMPARE-FILE-STRING))))) + +(define-macro (output-list-expr (COL-NAME FORMAT-SPEC) ...) + (let-syntax-pattern ([(COL-ID ...) (prefix-ids "" #'(COL-NAME ...))] + [(CHIP-COL-ID ...) (prefix-ids chip-prefix "-" #'(COL-NAME ...))] + [output (shared-syntax 'output)] + [of (shared-syntax 'of)] + [eval-result (shared-syntax 'eval-result)] + [eval-thunk (shared-syntax 'eval-thunk)]) + #'(begin + (define (output COL-ID ...) + (fprintf of (format "~a\n" (string-join (list (hdlprint COL-ID FORMAT-SPEC) ...) "|" + #:before-first "|" + #:after-last "|")))) + (define eval-result #f) + (define eval-thunk (λ () (list (CHIP-COL-ID) ...))) + (output COL-NAME ...)))) + +(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"))]) + #'(CHIP-IN-BUS-ID-WRITE IN-VAL))) + +(define-macro (eval-expr) + (let-syntax-pattern ([eval-result (shared-syntax 'eval-result)] + [eval-thunk (shared-syntax 'eval-thunk)]) + #'(set! eval-result (eval-thunk)))) + +(define-macro (output-expr) + (let-syntax-pattern ([output (shared-syntax 'output)] + [eval-result (shared-syntax 'eval-result)]) + #'(apply output eval-result))) diff --git a/beautiful-racket/br/demo/hdl-tst/hdlprint.rkt b/beautiful-racket/br/demo/hdl-tst/hdlprint.rkt index cf1c527..d10ac4e 100644 --- a/beautiful-racket/br/demo/hdl-tst/hdlprint.rkt +++ b/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 "."))) - (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))) + (cond + [(number? val) + (define radix (case radix-letter + [("B") 2])) + (string-append (make-string left-margin #\space) + (~r val #:min-width width #:pad-string "0" #:base radix) + (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) -(define a 123) -(check-equal? (hdlprint a "%B1.16.1") " 0000000001111011 ") -(check-equal? (hdlprint "out" "%B1.16.1") " out ")) + (require rackunit) + (define a 123) + (check-equal? (hdlprint a "%B1.16.1") " 0000000001111011 ") + (check-equal? (hdlprint "out" "%B1.16.1") " out ") + (check-equal? (hdlprint "out" "%B3.1.3") " out ") + (check-equal? (hdlprint "in" "%B3.1.3") " in ")) diff --git a/beautiful-racket/br/demo/hdl-tst/parser.rkt b/beautiful-racket/br/demo/hdl-tst/parser.rkt index cfd7637..0e69ca8 100644 --- a/beautiful-racket/br/demo/hdl-tst/parser.rkt +++ b/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" diff --git a/beautiful-racket/br/demo/hdl-tst/tokenizer.rkt b/beautiful-racket/br/demo/hdl-tst/tokenizer.rkt index 79a47c4..d4b0a32 100644 --- a/beautiful-racket/br/demo/hdl-tst/tokenizer.rkt +++ b/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) diff --git a/beautiful-racket/br/demo/hdl/And.cmp b/beautiful-racket/br/demo/hdl/And.cmp new file mode 100755 index 0000000..75e709a --- /dev/null +++ b/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 | diff --git a/beautiful-racket/br/demo/hdl/And.out b/beautiful-racket/br/demo/hdl/And.out new file mode 100644 index 0000000..8199ca5 --- /dev/null +++ b/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 | diff --git a/beautiful-racket/br/demo/hdl/And.tst.rkt b/beautiful-racket/br/demo/hdl/And.tst.rkt old mode 100644 new mode 100755 index 0eed34b..424f178 --- a/beautiful-racket/br/demo/hdl/And.tst.rkt +++ b/beautiful-racket/br/demo/hdl/And.tst.rkt @@ -1,14 +1,31 @@ -#lang br/demo/hdl-tst - -/* and */ - -load And.hdl, -output-list a, b, out; -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; +#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/And.tst + +load And.hdl, +output-file And.out, +compare-to And.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; diff --git a/beautiful-racket/br/demo/hdl/DMux.cmp b/beautiful-racket/br/demo/hdl/DMux.cmp new file mode 100755 index 0000000..6982094 --- /dev/null +++ b/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 | diff --git a/beautiful-racket/br/demo/hdl/DMux.out b/beautiful-racket/br/demo/hdl/DMux.out new file mode 100644 index 0000000..9a92ec0 --- /dev/null +++ b/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 | diff --git a/beautiful-racket/br/demo/hdl/DMux.tst b/beautiful-racket/br/demo/hdl/DMux.tst new file mode 100755 index 0000000..4adbc43 --- /dev/null +++ b/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; diff --git a/beautiful-racket/br/demo/hdl/DMux4Way.cmp b/beautiful-racket/br/demo/hdl/DMux4Way.cmp new file mode 100755 index 0000000..eac35c4 --- /dev/null +++ b/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 | diff --git a/beautiful-racket/br/demo/hdl/DMux4Way.tst b/beautiful-racket/br/demo/hdl/DMux4Way.tst new file mode 100755 index 0000000..6fbbb56 --- /dev/null +++ b/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; diff --git a/beautiful-racket/br/demo/hdl/DMux4Way.tst.rkt b/beautiful-racket/br/demo/hdl/DMux4Way.tst.rkt new file mode 100644 index 0000000..848eb79 --- /dev/null +++ b/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; diff --git a/beautiful-racket/br/demo/hdl/Dmux.tst.rkt b/beautiful-racket/br/demo/hdl/Dmux.tst.rkt index 261390f..5017ecb 100644 --- a/beautiful-racket/br/demo/hdl/Dmux.tst.rkt +++ b/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, -// 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, sel, a, b; +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, diff --git a/beautiful-racket/br/demo/hdl/HalfAdder.cmp b/beautiful-racket/br/demo/hdl/HalfAdder.cmp new file mode 100755 index 0000000..911c770 --- /dev/null +++ b/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 | diff --git a/beautiful-racket/br/demo/hdl/HalfAdder.out b/beautiful-racket/br/demo/hdl/HalfAdder.out new file mode 100644 index 0000000..612c8e3 --- /dev/null +++ b/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 | diff --git a/beautiful-racket/br/demo/hdl/HalfAdder.tst.rkt b/beautiful-racket/br/demo/hdl/HalfAdder.tst.rkt new file mode 100755 index 0000000..62ac533 --- /dev/null +++ b/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; diff --git a/beautiful-racket/br/demo/hdl/Mux.cmp b/beautiful-racket/br/demo/hdl/Mux.cmp new file mode 100755 index 0000000..7a5cc5b --- /dev/null +++ b/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 | diff --git a/beautiful-racket/br/demo/hdl/Mux.out b/beautiful-racket/br/demo/hdl/Mux.out new file mode 100644 index 0000000..e4b51c6 --- /dev/null +++ b/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 | diff --git a/beautiful-racket/br/demo/hdl/Mux.tst b/beautiful-racket/br/demo/hdl/Mux.tst new file mode 100755 index 0000000..9b7afd9 --- /dev/null +++ b/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; diff --git a/beautiful-racket/br/demo/hdl/Mux.tst.rkt b/beautiful-racket/br/demo/hdl/Mux.tst.rkt index 66e1129..c1b9058 100644 --- a/beautiful-racket/br/demo/hdl/Mux.tst.rkt +++ b/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, -// 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, b, sel, out; +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, diff --git a/beautiful-racket/br/demo/hdl/Not.cmp b/beautiful-racket/br/demo/hdl/Not.cmp new file mode 100755 index 0000000..e8c1191 --- /dev/null +++ b/beautiful-racket/br/demo/hdl/Not.cmp @@ -0,0 +1,3 @@ +| in | out | +| 0 | 1 | +| 1 | 0 | diff --git a/beautiful-racket/br/demo/hdl/Not.out b/beautiful-racket/br/demo/hdl/Not.out new file mode 100644 index 0000000..7b64092 --- /dev/null +++ b/beautiful-racket/br/demo/hdl/Not.out @@ -0,0 +1,3 @@ +| in | out | +| 0 | 1 | +| 1 | 0 | diff --git a/beautiful-racket/br/demo/hdl/Not.tst-sexp.rkt b/beautiful-racket/br/demo/hdl/Not.tst-sexp.rkt new file mode 100644 index 0000000..a65dcd4 --- /dev/null +++ b/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, \ No newline at end of file diff --git a/beautiful-racket/br/demo/hdl/Not.tst.rkt b/beautiful-racket/br/demo/hdl/Not.tst.rkt index 3aa9734..d35bf3b 100644 --- a/beautiful-racket/br/demo/hdl/Not.tst.rkt +++ b/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; \ No newline at end of file +eval, +output; diff --git a/beautiful-racket/br/demo/hdl/Or.cmp b/beautiful-racket/br/demo/hdl/Or.cmp new file mode 100755 index 0000000..dab924c --- /dev/null +++ b/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 | diff --git a/beautiful-racket/br/demo/hdl/Or.out b/beautiful-racket/br/demo/hdl/Or.out new file mode 100644 index 0000000..8010688 --- /dev/null +++ b/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 | diff --git a/beautiful-racket/br/demo/hdl/Or.tst b/beautiful-racket/br/demo/hdl/Or.tst new file mode 100755 index 0000000..948b6b3 --- /dev/null +++ b/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; diff --git a/beautiful-racket/br/demo/hdl/Or.tst.rkt b/beautiful-racket/br/demo/hdl/Or.tst.rkt index 4dd873e..29ae921 100644 --- a/beautiful-racket/br/demo/hdl/Or.tst.rkt +++ b/beautiful-racket/br/demo/hdl/Or.tst.rkt @@ -1,14 +1,30 @@ #lang br/demo/hdl-tst - -/* or */ +// 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-list a, b, out; -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; +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; diff --git a/beautiful-racket/br/demo/hdl/Xor.cmp b/beautiful-racket/br/demo/hdl/Xor.cmp new file mode 100755 index 0000000..a1e07b2 --- /dev/null +++ b/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 | diff --git a/beautiful-racket/br/demo/hdl/Xor.out b/beautiful-racket/br/demo/hdl/Xor.out new file mode 100644 index 0000000..73a8d0c --- /dev/null +++ b/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 | diff --git a/beautiful-racket/br/demo/hdl/Xor.tst b/beautiful-racket/br/demo/hdl/Xor.tst new file mode 100755 index 0000000..658cbe5 --- /dev/null +++ b/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; diff --git a/beautiful-racket/br/demo/hdl/Xor.tst.rkt b/beautiful-racket/br/demo/hdl/Xor.tst.rkt index b4cc445..2c57c46 100644 --- a/beautiful-racket/br/demo/hdl/Xor.tst.rkt +++ b/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; -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; +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; diff --git a/beautiful-racket/br/demo/hdl/expander.rkt b/beautiful-racket/br/demo/hdl/expander.rkt index 3e290e7..e36cf50 100644 --- a/beautiful-racket/br/demo/hdl/expander.rkt +++ b/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)) -(provide #%top-interaction #%module-begin #%app #%datum and or (all-defined-out)) - - -(define #'(chip-program _chipname - (in-spec (_in-bus _in-width ...) ...) - (out-spec (_out-bus _out-width ...) ...) - _part ...) - (inject-syntax* ([#'_chip-prefix (suffix-id #'_chipname "-")] - [#'(_in-bus-write ...) (suffix-ids #'(_in-bus ...) "-write")] - [#'(_prefix-out-bus ...) (prefix-ids #'_chip-prefix #'(_out-bus ...))]) - #'(begin - (provide (prefix-out _chip-prefix (combine-out _in-bus ... _in-bus-write ...))) - (define-input-bus _in-bus _in-width ...) ... - _part ... - (provide _prefix-out-bus ...) - (define-output-bus _prefix-out-bus _out-bus _out-width ...) ...))) - - -(define #'(part _partname ((_bus-left . _busargs) _bus-expr-right) ...) - (inject-syntax ([#'(_partname-bus-left ...) (prefix-ids #'_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))) - (handle-buses ((_partname-bus-left . _busargs) _bus-expr-right) ...)))) +(require "helper.rkt" (for-syntax racket/syntax racket/require-transform br/syntax)) +(provide #%top-interaction #%module-begin #%app #%datum (all-defined-out)) + +(define-macro (chip-program CHIPNAME + (in-spec (IN-BUS IN-WIDTH ...) ...) + (out-spec (OUT-BUS OUT-WIDTH ...) ...) + PART ...) + (let-syntax-pattern ([CHIP-PREFIX (suffix-id #'CHIPNAME "-")] + [(IN-BUS-WRITE ...) (suffix-ids #'(IN-BUS ...) "-write")] + [(PREFIX-OUT-BUS ...) (prefix-ids #'CHIP-PREFIX #'(OUT-BUS ...))]) + #'(begin + (provide (prefix-out CHIP-PREFIX (combine-out IN-BUS ... IN-BUS-WRITE ...))) + (define-input-bus IN-BUS IN-WIDTH ...) ... + PART ... + (provide PREFIX-OUT-BUS ...) + (define-output-bus PREFIX-OUT-BUS OUT-BUS OUT-WIDTH ...) ...))) + + +(define-macro (part PARTNAME ((BUS-LEFT . BUS-LEFT-ARGS) BUS-RIGHT-EXPR) ...) + (let-syntax-pattern ([(PARTNAME-BUS-LEFT ...) (prefix-ids #'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))) + (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 ...) - (let-values ([(_in-bus-assignments _out-bus-assignments) - (syntax-case-partition #'(_bus-assignments ...) () - [((prefixed-wire . _wireargs) _) - (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] - [#'(_in-bus-write ...) (suffix-ids #'(_in-bus ...) "-write")] - [#'((_out-bus-expr (_new-out-bus)) ...) _out-bus-assignments]) - #'(begin - (define-output-bus _new-out-bus - (λ () - (_in-bus-write _in-bus-arg ... _in-bus-value) ... - _out-bus-expr)) ...)))) \ No newline at end of file +(define-macro (handle-buses BUS-ASSIGNMENTS ...) + (let-values ([(in-bus-assignments out-bus-assignments) + (syntax-case-partition #'(BUS-ASSIGNMENTS ...) () + [((PREFIXED-WIRE . _) _) + (syntax-local-eval (syntax-shift-phase-level #'(input-bus? PREFIXED-WIRE) 1))])]) + (let-syntax-pattern ([(((IN-BUS IN-BUS-ARG ...) _in-bus-value) ...) in-bus-assignments] + [(IN-BUS-WRITE ...) (suffix-ids #'(IN-BUS ...) "-write")] + [((OUT-BUS-EXPR (NEW-OUT-BUS)) ...) out-bus-assignments]) + #'(begin + (define-output-bus NEW-OUT-BUS + (λ () + (IN-BUS-WRITE IN-BUS-ARG ... _in-bus-value) ... + OUT-BUS-EXPR)) ...)))) \ 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 030d5ff..9980778 100644 --- a/beautiful-racket/br/demo/hdl/helper.rkt +++ b/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")])