suzanne.soy/beautiful-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

rewrite hdl-test language

Browse Source
This commit is contained in:
Matthew Butterick 2016-05-24 12:19:24 -07:00
parent f9f79d63f6
commit 5a78b92d92
40 changed files with 658 additions and 161 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
beautiful-racket-lib/br/define.rkt
View File

@ -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)))
(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))

10
beautiful-racket-lib/br/syntax.rkt
View File

@ -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 ()

5
beautiful-racket/br/demo/Or.cmp Executable file
View File

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

29
beautiful-racket/br/demo/Or.tst Executable file
View File

@ -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;

5
beautiful-racket/br/demo/Xor.cmp Executable file
View File

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

94
beautiful-racket/br/demo/hdl-tst/expander.rkt
View File

@ -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))
(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))
; #%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)))))
(require br/demo/hdl-tst/hdlprint rackunit racket/file (for-syntax racket/string))
(define #'(tst-program _arg ...) #'(begin _arg ...))
(define-for-syntax chip-prefix #f)
(begin-for-syntax
(define-scope blue))
(define-macro (tst-program ARG ...)
(let-syntax-pattern ([compare (shared-syntax #'compare)]
[of (shared-syntax #'of)])
#'(begin ARG ... (close-output-port of) (compare) )))
(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-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 #'(display-header _sym ...)
#'(begin
(apply display-values (list _sym ...))
(apply display-dashes (list _sym ...))))
(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 (vals->text vals) (string-join (map ~a vals) " | "))
(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 (display-values . vals) (displayln (vals->text vals)))
(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 (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"))])
#'(CHIP-IN-BUS-ID-WRITE IN-VAL)))
(define #'test-expr #'begin)
(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 #'eval-expr #'void)
(define #'(output-expr)
(with-blue-identifiers (output)
#'(output)))
(define-macro (output-expr)
(let-syntax-pattern ([output (shared-syntax 'output)]
[eval-result (shared-syntax 'eval-result)])
#'(apply output eval-result)))

28
beautiful-racket/br/demo/hdl-tst/hdlprint.rkt
View File

@ -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 "))

18
beautiful-racket/br/demo/hdl-tst/parser.rkt
View File

@ -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"

5
beautiful-racket/br/demo/hdl-tst/tokenizer.rkt
View File

@ -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)

5
beautiful-racket/br/demo/hdl/And.cmp Executable file
View File

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

5
beautiful-racket/br/demo/hdl/And.out Normal file
View File

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

45
beautiful-racket/br/demo/hdl/And.tst.rkt Normal file → Executable file
View File

@ -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;

5
beautiful-racket/br/demo/hdl/DMux.cmp Executable file
View File

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

5
beautiful-racket/br/demo/hdl/DMux.out Normal file
View File

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

27
beautiful-racket/br/demo/hdl/DMux.tst Executable file
View File

@ -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;

9
beautiful-racket/br/demo/hdl/DMux4Way.cmp Executable file
View File

@ -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 |

43
beautiful-racket/br/demo/hdl/DMux4Way.tst Executable file
View File

@ -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;

45
beautiful-racket/br/demo/hdl/DMux4Way.tst.rkt Normal file
View File

@ -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;

7
beautiful-racket/br/demo/hdl/Dmux.tst.rkt
View File

@ -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,

5
beautiful-racket/br/demo/hdl/HalfAdder.cmp Executable file
View File

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

5
beautiful-racket/br/demo/hdl/HalfAdder.out Normal file
View File

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

31
beautiful-racket/br/demo/hdl/HalfAdder.tst.rkt Executable file
View File

@ -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;

9
beautiful-racket/br/demo/hdl/Mux.cmp Executable file
View File

@ -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 |

9
beautiful-racket/br/demo/hdl/Mux.out Normal file
View File

@ -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 |

49
beautiful-racket/br/demo/hdl/Mux.tst Executable file
View File

@ -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;

7
beautiful-racket/br/demo/hdl/Mux.tst.rkt
View File

@ -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,

3
beautiful-racket/br/demo/hdl/Not.cmp Executable file
View File

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

3
beautiful-racket/br/demo/hdl/Not.out Normal file
View File

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

34
beautiful-racket/br/demo/hdl/Not.tst-sexp.rkt Normal file
View File

@ -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,

14
beautiful-racket/br/demo/hdl/Not.tst.rkt
View File

@ -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;

5
beautiful-racket/br/demo/hdl/Or.cmp Executable file
View File

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

5
beautiful-racket/br/demo/hdl/Or.out Normal file
View File

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

29
beautiful-racket/br/demo/hdl/Or.tst Executable file
View File

@ -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;

38
beautiful-racket/br/demo/hdl/Or.tst.rkt
View File

@ -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;

5
beautiful-racket/br/demo/hdl/Xor.cmp Executable file
View File

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

5
beautiful-racket/br/demo/hdl/Xor.out Normal file
View File

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

29
beautiful-racket/br/demo/hdl/Xor.tst Executable file
View File

@ -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;

37
beautiful-racket/br/demo/hdl/Xor.tst.rkt
View File

@ -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;

71
beautiful-racket/br/demo/hdl/expander.rkt
View File

@ -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))
(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 #'(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) ...))))
(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)) ...))))
(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)) ...))))

4
beautiful-racket/br/demo/hdl/helper.rkt
View File

@ -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")])