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

improvements

Browse Source
This commit is contained in:
Matthew Butterick 2016-05-20 19:00:39 -07:00
parent 4e5c5247fa
commit c53414285f
4 changed files with 24 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -12,7 +12,7 @@
*/
CHIP Mux {
IN a, b, sel;
IN a, b[15], sel[8];
OUT out;
PARTS:

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

@ -18,12 +18,12 @@
(define-output-bus prefixed-output-pin _output-pin _output-width ...) ...)))
(define #'(part _prefix [_suffix . _args] ...)
(with-syntax ([(prefix-suffix ...) (map (λ(s) (format-id s "~a-~a" #'_prefix s)) (syntax->list #'(_suffix ...)))]
(define #'(part _prefix ((_wire . _wireargs) _wirevalue) ...)
(with-syntax ([(prefixed-wire ...) (map (λ(s) (format-id s "~a-~a" #'_prefix s)) (syntax->list #'(_wire ...)))]
[chip-module-path (datum->syntax #'_prefix (format "~a.hdl.rkt" (syntax->datum #'_prefix)))])
#'(begin
(require (import-chip chip-module-path) (for-syntax (import-chip chip-module-path)))
(handle-wires [prefix-suffix . _args] ...))))
(handle-wires ((prefixed-wire . _wireargs) _wirevalue) ...))))
(define-syntax import-chip
@ -34,17 +34,18 @@
(expand-import #'module-path)]))))
(define #'(handle-wires _wirearg-pair ...)
(define #'(handle-wires _wire-assignments ...)
(let-values ([(in-wire-stxs out-wire-stxs)
(partition (λ(wirearg-pair-stx)
(define wire-stx (car (syntax->list wirearg-pair-stx)))
(input-bus? (syntax-local-eval wire-stx)))
(syntax->list #'(_wirearg-pair ...)))])
(with-syntax* ([([in-wire in-arg ...] ...) in-wire-stxs]
(partition (λ(wa)
(syntax-case wa ()
[((prefixed-wire . _wireargs) _)
(input-bus? (syntax-local-eval #'prefixed-wire))]))
(syntax->list #'(_wire-assignments ...)))])
(with-syntax* ([(((in-wire in-arg ...) input-expr) ...) in-wire-stxs]
[(in-wire-write ...) (map (λ(iw) (format-id iw "~a-write" iw)) (syntax->list #'(in-wire ...)))]
[([out-wire out-arg ... out-bus] ...) out-wire-stxs])
[(((out-wire out-arg ...) (out-bus)) ...) out-wire-stxs])
#'(begin
(define-output-bus out-bus
(λ ()
(in-wire-write (in-arg ...)) ...
(in-wire-write in-arg ... input-expr) ...
(out-wire out-arg ...))) ...))))

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

@ -115,7 +115,8 @@ base bus:
[(macro-name id thunk)
#'(macro-name id thunk default-bus-width)]
[(macro-name id thunk bus-width-in)
(with-syntax ([id-thunk (format-id #'id "~a-val" #'id)])
(with-syntax ([id-thunk (format-id #'id "~a-val" #'id)]
[bus-type (or (syntax-property stx 'impersonate) #'bus)])
#`(splicing-let ([id-thunk thunk]
[bus-width bus-width-in])
(define id
@ -124,8 +125,8 @@ 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)])
(λ args (apply reader (id-thunk) args)))
#f #,(or (syntax-property stx 'impersonate) #'bus) #t)))
(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 stx 'writer)
(with-syntax ([id-write (format-id #'id "~a-write" #'id)])
#'(define id-write
@ -250,6 +251,7 @@ input bus:
(define-input-bus ib2 4)
(check-exn exn:fail? (λ () (ib2-write 16))) ; overflow value
(ib2-write #b1100)
(ib-write (ib2)) ; using bus as input value
(ib-write ib2) ; using bus as input value
(check-equal? (ib) (ib2))
)
)

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

@ -14,16 +14,16 @@ out-spec : pin-spec
@part-spec : /"PARTS:" part+
part : partname /"(" pin-val-pair [/"," pin-val-pair]* /")" /";"
part : partname /"(" wire-assign [/"," wire-assign]* /")" /";"
@partname : ID
/pin-val-pair : pin-range /"=" pin-val
/wire-assign : pin-range /"=" pin-val
/pin-range : ID [/"[" bus-range /"]"]
@bus-range : number [/"." /"." number]
@pin-range : ID [/"[" bus-range /"]"]
@pin-val : pin-range
| BINARY-NUMBER
| TRUE