mbutterick
/
beautiful-racket
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

cleaner

Browse Source
pull/2/head
Matthew Butterick 9 years ago
parent 7dcce997d0
commit a36fbc2df6
5 changed files with 130 additions and 116 deletions
Show Stats Download Patch File Download Diff File

4
beautiful-racket-lib/br/syntax.rkt
Unescape Escape View File

@ -118,3 +118,7 @@
(check-true (syntax-property* x 'bar)) (check-true (syntax-property* x 'bar))
(check-equal? (syntax-property* x 'foo 'bar 'zam) '(#f #t boni))) (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))

81
beautiful-racket/br/demo/hdl-tst/expander.rkt
Unescape Escape View File

@ -1,63 +1,92 @@
#lang br #lang br
(require (for-syntax br/syntax br/scope racket/string) (require (for-syntax br/syntax br/scope racket/string) rackunit racket/file)
"hdlprint.rkt" rackunit racket/file)
(provide #%top-interaction #%module-begin #%datum #%app (all-defined-out)) (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-for-syntax chip-prefix #f)
(define-macro (tst-program ARG ...) (define-macro (tst-program EXPR ...)
(let-shared-id (compare output-file) #'(begin
#'(begin ARG ... EXPR ...
(close-output-port output-file) (compare-files)))
(compare))))
(define-macro (load-expr CHIPFILE-STRING) (define-macro (load-expr CHIPFILE-STRING)
(set! chip-prefix (string-replace (syntax->datum #'CHIPFILE-STRING) ".hdl" "")) (set! chip-prefix (string-replace (syntax->datum #'CHIPFILE-STRING) ".hdl" ""))
(let-syntax-pattern ([CHIPFILE.RKT (format-string "~a.rkt" #'CHIPFILE-STRING)]) (let-syntax-pattern
([CHIPFILE.RKT (format-string "~a.rkt" #'CHIPFILE-STRING)])
#'(require CHIPFILE.RKT))) #'(require CHIPFILE.RKT)))
(define-macro (output-file-expr OUTPUT-FILE-STRING) (define-macro (output-file-expr OUTPUT-FILE-STRING)
(let-shared-id (output-file output-filename) (introduce-id
(output-file output-filename)
#'(begin #'(begin
(define output-filename OUTPUT-FILE-STRING) (define output-filename OUTPUT-FILE-STRING)
(define output-file (open-output-file output-filename #:exists 'replace))))) (with-output-to-file output-filename
(λ () (printf ""))
#:mode 'text
#:exists 'replace))))
(define-macro (compare-to-expr COMPARE-FILE-STRING) (define-macro (compare-to-expr COMPARE-FILE-STRING)
(let-shared-id (compare output-filename) (introduce-id
#'(define (compare) (compare-files)
#'(define (compare-files)
(check-equal? (file->lines output-filename) (file->lines COMPARE-FILE-STRING))))) (check-equal? (file->lines output-filename) (file->lines COMPARE-FILE-STRING)))))
(define-macro (output-list-expr (COL-NAME FORMAT-SPEC) ...) (define-macro (output-list-expr (COL-NAME FORMAT-SPEC) ...)
(let-shared-id (output output-file eval-result eval-thunk) (introduce-id
(let-syntax-pattern ([(COL-ID ...) (suffix-ids #'(COL-NAME ...))] (eval-result eval-chip output)
(let-syntax-pattern
([(COL-ID ...) (suffix-ids #'(COL-NAME ...))]
[(CHIP-COL-ID ...) (prefix-ids chip-prefix "-" #'(COL-NAME ...))]) [(CHIP-COL-ID ...) (prefix-ids chip-prefix "-" #'(COL-NAME ...))])
#'(begin #'(begin
(define (output COL-ID ...) (define (output COL-ID ...)
(fprintf output-file (print-line output-filename (map print-cell (list COL-ID ...) (list FORMAT-SPEC ...))))
(format "~a\n" (string-join (list (hdlprint COL-ID FORMAT-SPEC) ...) "|"
#:before-first "|"
#:after-last "|"))))
(define eval-result #f) (define eval-result #f)
(define (eval-thunk) (list (CHIP-COL-ID) ...)) (define (eval-chip) (list (CHIP-COL-ID) ...))
(output COL-NAME ...))))) (output COL-NAME ...)))))
(define-macro (set-expr IN-BUS IN-VAL) (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"))]) (let-syntax-pattern
([CHIP-IN-BUS-ID-WRITE (prefix-id chip-prefix "-" (suffix-id #'IN-BUS "-write"))])
#'(CHIP-IN-BUS-ID-WRITE IN-VAL))) #'(CHIP-IN-BUS-ID-WRITE IN-VAL)))
(define-macro (eval-expr) (define-macro (eval-expr) #'(set! eval-result (eval-chip)))
(let-shared-id (eval-result eval-thunk)
#'(set! eval-result (eval-thunk))))
(define-macro (output-expr) (define-macro (output-expr) #'(apply output eval-result))
(let-shared-id (output eval-result)
#'(apply output eval-result)))

23
beautiful-racket/br/demo/hdl-tst/hdlprint.rkt
Unescape Escape View File

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

14
beautiful-racket/br/demo/hdl/expander.rkt
Unescape Escape View File

@ -6,7 +6,8 @@
(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 "-")] (let-syntax-pattern
([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 #'(begin
@ -18,7 +19,8 @@
(define-macro (part PARTNAME ((BUS-LEFT . BUS-LEFT-ARGS) BUS-RIGHT-EXPR) ...) (define-macro (part PARTNAME ((BUS-LEFT . BUS-LEFT-ARGS) BUS-RIGHT-EXPR) ...)
(let-syntax-pattern ([(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 #'(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)))
@ -34,15 +36,17 @@
(define-macro (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 . _) _) [((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))])])
(let-syntax-pattern ([(((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 #'(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)) ...))))
Write Preview
Loading…
Cancel
Save