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

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

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

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

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

@ -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)) ...))))
Write Preview
Loading…
Cancel
Save