cleaner
This commit is contained in:
parent
7dcce997d0
commit
a36fbc2df6
|
@ -117,4 +117,8 @@
|
|||
(check-false (syntax-property* x 'foo))
|
||||
(check-true (syntax-property* x 'bar))
|
||||
(check-equal? (syntax-property* x 'foo 'bar 'zam) '(#f #t boni)))
|
||||
|
||||
(define-syntax-rule (introduce-id (id ...) . body)
|
||||
(with-syntax ([id (syntax-local-introduce (datum->syntax #f 'id))] ...)
|
||||
. body))
|
||||
|
||||
|
|
|
@ -1,63 +1,92 @@
|
|||
#lang br
|
||||
(require (for-syntax br/syntax br/scope racket/string)
|
||||
"hdlprint.rkt" rackunit racket/file)
|
||||
(require (for-syntax br/syntax br/scope racket/string) rackunit racket/file)
|
||||
(provide #%top-interaction #%module-begin #%datum #%app (all-defined-out))
|
||||
|
||||
|
||||
(define (print-cell 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)
|
||||
(~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)]))
|
||||
|
||||
|
||||
(define (print-line output-filename cells)
|
||||
(with-output-to-file output-filename
|
||||
(λ () (printf (format "~a\n" (string-join cells "|" #:before-first "|" #:after-last "|"))))
|
||||
#:mode 'text
|
||||
#:exists 'append))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(define a 123)
|
||||
(check-equal? (print-cell a "%B1.16.1") " 0000000001111011 ")
|
||||
(check-equal? (print-cell "out" "%B1.16.1") " out ")
|
||||
(check-equal? (print-cell "out" "%B3.1.3") " out ")
|
||||
(check-equal? (print-cell "in" "%B3.1.3") " in "))
|
||||
|
||||
|
||||
(define-for-syntax chip-prefix #f)
|
||||
|
||||
|
||||
(define-macro (tst-program ARG ...)
|
||||
(let-shared-id (compare output-file)
|
||||
#'(begin ARG ...
|
||||
(close-output-port output-file)
|
||||
(compare))))
|
||||
(define-macro (tst-program EXPR ...)
|
||||
#'(begin
|
||||
EXPR ...
|
||||
(compare-files)))
|
||||
|
||||
|
||||
(define-macro (load-expr CHIPFILE-STRING)
|
||||
(set! chip-prefix (string-replace (syntax->datum #'CHIPFILE-STRING) ".hdl" ""))
|
||||
(let-syntax-pattern ([CHIPFILE.RKT (format-string "~a.rkt" #'CHIPFILE-STRING)])
|
||||
#'(require CHIPFILE.RKT)))
|
||||
(let-syntax-pattern
|
||||
([CHIPFILE.RKT (format-string "~a.rkt" #'CHIPFILE-STRING)])
|
||||
#'(require CHIPFILE.RKT)))
|
||||
|
||||
|
||||
(define-macro (output-file-expr OUTPUT-FILE-STRING)
|
||||
(let-shared-id (output-file output-filename)
|
||||
#'(begin
|
||||
(define output-filename OUTPUT-FILE-STRING)
|
||||
(define output-file (open-output-file output-filename #:exists 'replace)))))
|
||||
(introduce-id
|
||||
(output-file output-filename)
|
||||
#'(begin
|
||||
(define output-filename OUTPUT-FILE-STRING)
|
||||
(with-output-to-file output-filename
|
||||
(λ () (printf ""))
|
||||
#:mode 'text
|
||||
#:exists 'replace))))
|
||||
|
||||
|
||||
(define-macro (compare-to-expr COMPARE-FILE-STRING)
|
||||
(let-shared-id (compare output-filename)
|
||||
#'(define (compare)
|
||||
(check-equal? (file->lines output-filename) (file->lines COMPARE-FILE-STRING)))))
|
||||
(introduce-id
|
||||
(compare-files)
|
||||
#'(define (compare-files)
|
||||
(check-equal? (file->lines output-filename) (file->lines COMPARE-FILE-STRING)))))
|
||||
|
||||
|
||||
(define-macro (output-list-expr (COL-NAME FORMAT-SPEC) ...)
|
||||
(let-shared-id (output output-file eval-result eval-thunk)
|
||||
(let-syntax-pattern ([(COL-ID ...) (suffix-ids #'(COL-NAME ...))]
|
||||
[(CHIP-COL-ID ...) (prefix-ids chip-prefix "-" #'(COL-NAME ...))])
|
||||
#'(begin
|
||||
(define (output COL-ID ...)
|
||||
(fprintf output-file
|
||||
(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 ...)))))
|
||||
(introduce-id
|
||||
(eval-result eval-chip output)
|
||||
(let-syntax-pattern
|
||||
([(COL-ID ...) (suffix-ids #'(COL-NAME ...))]
|
||||
[(CHIP-COL-ID ...) (prefix-ids chip-prefix "-" #'(COL-NAME ...))])
|
||||
#'(begin
|
||||
(define (output COL-ID ...)
|
||||
(print-line output-filename (map print-cell (list COL-ID ...) (list FORMAT-SPEC ...))))
|
||||
(define eval-result #f)
|
||||
(define (eval-chip) (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)))
|
||||
(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-shared-id (eval-result eval-thunk)
|
||||
#'(set! eval-result (eval-thunk))))
|
||||
(define-macro (eval-expr) #'(set! eval-result (eval-chip)))
|
||||
|
||||
|
||||
(define-macro (output-expr)
|
||||
(let-shared-id (output eval-result)
|
||||
#'(apply output eval-result)))
|
||||
(define-macro (output-expr) #'(apply output eval-result))
|
||||
|
|
|
@ -1,23 +0,0 @@
|
|||
#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)
|
||||
(~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 ")
|
||||
(check-equal? (hdlprint "out" "%B3.1.3") " out ")
|
||||
(check-equal? (hdlprint "in" "%B3.1.3") " in "))
|
|
@ -1,31 +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/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;
|
||||
#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;
|
||||
|
|
|
@ -6,23 +6,25 @@
|
|||
(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 ...) ...)))
|
||||
(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) ...))))
|
||||
(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,15 +36,17 @@
|
|||
|
||||
|
||||
(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)) ...))))
|
||||
(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)) ...))))
|
Loading…
Reference in New Issue
Block a user