diff --git a/beautiful-racket/br/demo/hdl/Mux.hdl.rkt b/beautiful-racket/br/demo/hdl/Mux.hdl.rkt index f94e6d9..28c72c1 100644 --- a/beautiful-racket/br/demo/hdl/Mux.hdl.rkt +++ b/beautiful-racket/br/demo/hdl/Mux.hdl.rkt @@ -12,7 +12,7 @@ */ CHIP Mux { - IN a, b, sel; + IN a, b[15], sel[8]; OUT out; PARTS: diff --git a/beautiful-racket/br/demo/hdl/expander.rkt b/beautiful-racket/br/demo/hdl/expander.rkt index 056929a..6ae21dd 100644 --- a/beautiful-racket/br/demo/hdl/expander.rkt +++ b/beautiful-racket/br/demo/hdl/expander.rkt @@ -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 ...))) ...)))) \ No newline at end of file diff --git a/beautiful-racket/br/demo/hdl/helper.rkt b/beautiful-racket/br/demo/hdl/helper.rkt index ca93190..91ab179 100644 --- a/beautiful-racket/br/demo/hdl/helper.rkt +++ b/beautiful-racket/br/demo/hdl/helper.rkt @@ -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)) - ) \ No newline at end of file + ) + \ No newline at end of file diff --git a/beautiful-racket/br/demo/hdl/parser.rkt b/beautiful-racket/br/demo/hdl/parser.rkt index 23b5fcd..8223cb1 100644 --- a/beautiful-racket/br/demo/hdl/parser.rkt +++ b/beautiful-racket/br/demo/hdl/parser.rkt @@ -14,15 +14,15 @@ 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 -@bus-range : number [/"." /"." number] +/pin-range : ID [/"[" bus-range /"]"] -@pin-range : ID [/"[" bus-range /"]"] +@bus-range : number [/"." /"." number] @pin-val : pin-range | BINARY-NUMBER