diff --git a/beautiful-racket/br/demo/hdl/DMux.hdl.rkt b/beautiful-racket/br/demo/hdl/DMux.hdl.rkt index 328c556..189558b 100644 --- a/beautiful-racket/br/demo/hdl/DMux.hdl.rkt +++ b/beautiful-racket/br/demo/hdl/DMux.hdl.rkt @@ -16,5 +16,6 @@ CHIP DMux { OUT a, b; PARTS: - Not + And(a=in, b=sel, out=a); + And(a=in, b=sel, out=b); } diff --git a/beautiful-racket/br/demo/hdl/Mux-test.rkt b/beautiful-racket/br/demo/hdl/Mux-test.rkt new file mode 100644 index 0000000..c456b4d --- /dev/null +++ b/beautiful-racket/br/demo/hdl/Mux-test.rkt @@ -0,0 +1,39 @@ +#lang racket +(require "Mux.hdl.rkt") +(require rackunit) + +(Mux-sel 0) + +(Mux-a 0) +(Mux-b 0) +(check-equal? (Mux-out) (Mux-a)) + +(Mux-a 0) +(Mux-b 1) +(check-equal? (Mux-out) (Mux-a)) + +(Mux-a 1) +(Mux-b 0) +(check-equal? (Mux-out) (Mux-a)) + +(Mux-a 1) +(Mux-b 1) +(check-equal? (Mux-out) (Mux-a)) + +(Mux-sel 1) + +(Mux-a 0) +(Mux-b 0) +(check-equal? (Mux-out) (Mux-b)) + +(Mux-a 0) +(Mux-b 1) +(check-equal? (Mux-out) (Mux-b)) + +(Mux-a 1) +(Mux-b 0) +(check-equal? (Mux-out) (Mux-b)) + +(Mux-a 1) +(Mux-b 1) +(check-equal? (Mux-out) (Mux-b)) diff --git a/beautiful-racket/br/demo/hdl/Mux.hdl.rkt b/beautiful-racket/br/demo/hdl/Mux.hdl.rkt index 57fe089..755d75f 100644 --- a/beautiful-racket/br/demo/hdl/Mux.hdl.rkt +++ b/beautiful-racket/br/demo/hdl/Mux.hdl.rkt @@ -16,8 +16,10 @@ CHIP Mux { OUT out; PARTS: - // Put your code here: Not(in=sel, out=sel-opposite); - And(a=a, b=sel-opposite, out=maybe-a); + Not(in=a, out=not-a); + Or(a=not-a, b=sel-opposite, out=maybe-a); + Not(in=b, out=not-b); + Or(a=not-b, b=sel, out=maybe-b); Or(a=maybe-a, b=b, out=out); } diff --git a/beautiful-racket/br/demo/hdl/Nand.hdl.rkt b/beautiful-racket/br/demo/hdl/Nand.hdl.rkt index e181804..8e98888 100644 --- a/beautiful-racket/br/demo/hdl/Nand.hdl.rkt +++ b/beautiful-racket/br/demo/hdl/Nand.hdl.rkt @@ -2,9 +2,8 @@ (provide (prefix-out Nand- (all-defined-out))) (require "helper.rkt") -(define a (make-bus)) -(define b (make-bus)) - +(define-input-bus a) +(define-input-bus b) (define (out . etc) (if (< (+ (a) (b)) 2) diff --git a/beautiful-racket/br/demo/hdl/Not-sexp.rkt b/beautiful-racket/br/demo/hdl/Not-sexp.rkt index 61c697b..4032432 100644 --- a/beautiful-racket/br/demo/hdl/Not-sexp.rkt +++ b/beautiful-racket/br/demo/hdl/Not-sexp.rkt @@ -13,4 +13,4 @@ CHIP Not { (chip-program Not (in-spec (in 8) (a)) (out-spec (out 8)) - (part-spec (part Nand ((a) (in)) ((b) (in)) ((out) (out))))) \ No newline at end of file + (part Nand (a in) (b in) (out out))) \ No newline at end of file diff --git a/beautiful-racket/br/demo/hdl/Not.hdl.rkt b/beautiful-racket/br/demo/hdl/Not.hdl.rkt index 4632613..e8034cd 100644 --- a/beautiful-racket/br/demo/hdl/Not.hdl.rkt +++ b/beautiful-racket/br/demo/hdl/Not.hdl.rkt @@ -1,11 +1,11 @@ #lang br/demo/hdl CHIP Not { - IN in[8]; + IN in; OUT out; PARTS: - Nand(a[2..4]=in, b=011, c=true, out[3]=v); + Nand(a=in, b=in, out=out); } diff --git a/beautiful-racket/br/demo/hdl/expander.rkt b/beautiful-racket/br/demo/hdl/expander.rkt index 091989f..a61d82d 100644 --- a/beautiful-racket/br/demo/hdl/expander.rkt +++ b/beautiful-racket/br/demo/hdl/expander.rkt @@ -9,31 +9,30 @@ (define #'(chip-program _chipname (in-spec (_input-pin _input-width ...) ...) (out-spec (_output-pin _output-width ...) ...) - . args) + _part ...) (with-syntax ([chip-prefix (format-id #'_chipname "~a-" #'_chipname)]) - #''(begin + #'(begin (provide (prefix-out chip-prefix (combine-out _input-pin ... _output-pin ...))) - (define _input-pin (make-bus '_input-pin _input-width ...)) ... - . args))) + (define-input-bus _input-pin _input-width ...) ... + _part ...))) #;(define #'(chip-program _chipname (in-spec (_input-pin _input-width ...) ...) (out-spec (_output-pin _output-width ...) ...) (part-spec (part _partname ((_pin _pinwhich ...) (_val _valwhich ...)) ... ) ...)) (with-syntax ([chip-prefix (format-id #'_chipname "~a-" #'_chipname)]) - #''(begin + #'(begin (provide (prefix-out chip-prefix (combine-out _input-pin ... _output-pin ...))) (define _input-pin (make-bus _input-width ...)) ... - #;(define _output-pin (make-bus _output-width ...)) #;... (handle-part _partname (_pin (or #f _pinwhich ...) (_val (or #f _valwhich ...))) ...) ...))) -(define #'(handle-part _prefix [_suffix _which _arg] ...) +(define #'(part _prefix [_suffix _arg ...] ...) (with-syntax ([(prefix-suffix ...) (map (λ(s) (format-id s "~a-~a" #'_prefix s)) (syntax->list #'(_suffix ...)))] [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 _which _arg] ...)))) + (handle-wires [prefix-suffix _arg ...] ...)))) (define-syntax import-chip @@ -48,11 +47,12 @@ (let-values ([(in-wire-stxs out-wire-stxs) (partition (λ(wirearg-pair-stx) (define wire-stx (car (syntax->list wirearg-pair-stx))) - (input-wire? (syntax-local-eval wire-stx))) + (input-bus? (syntax-local-eval wire-stx))) (syntax->list #'(_wirearg-pair ...)))]) (with-syntax ([([in-wire . in-args] ...) in-wire-stxs] - [([out-wire which (out-arg . args)] ...) out-wire-stxs]) + [([out-wire out-arg ... out-bus] ...) out-wire-stxs]) #'(begin - (define (out-arg) + (define-output-bus out-bus + (λ () (in-wire . in-args) ... - (out-wire which)) ...)))) \ No newline at end of file + (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 a7d929e..0cd69ef 100644 --- a/beautiful-racket/br/demo/hdl/helper.rkt +++ b/beautiful-racket/br/demo/hdl/helper.rkt @@ -2,46 +2,180 @@ (require racket/match racket/list) (provide (all-defined-out)) +(module+ test + (require rackunit)) + +(define (bitwise-bit-set x bit) + (if (not (bitwise-bit-set? x bit)) + (bitwise-ior x (expt 2 bit)) + x)) + +(define (bitwise-bit-unset x bit) + (if (bitwise-bit-set? x bit) + (bitwise-and x (bitwise-not (expt 2 bit))) + x)) + +(module+ test + (define x-bitset (string->number "1011" 2)) ; decimal 11 + + (check-true (bitwise-bit-set? x-bitset 0)) + (check-true (bitwise-bit-set? x-bitset 1)) + (check-false (bitwise-bit-set? x-bitset 2)) + (check-true (bitwise-bit-set? x-bitset 3)) + + (set! x-bitset (bitwise-bit-set x-bitset 2)) + (check-true (bitwise-bit-set? x-bitset 2)) + + (set! x-bitset (bitwise-bit-unset x-bitset 2)) + (check-false (bitwise-bit-set? x-bitset 2))) + (define (bus-range start [finish start]) (range start (add1 finish))) -(define-values (input-wire input-wire? input-wire-get) - (make-impersonator-property 'input-wire)) +(define-values (input-bus input-bus? input-bus-get) + (make-impersonator-property 'input-bus)) + +(define (integer->bitvals int width) + (reverse (for/list ([i (in-range width)]) + (bitwise-bit-field int i (add1 i))))) + +(define max-bus-width 16) -(define (make-bus bus-name [width 1]) - (impersonate-procedure +(define (check-bit-against-width bus-name bit width) + (unless (< bit width) + (raise-argument-error bus-name (format "bit less than bus width ~a" width) bit))) + +(require sugar/debug) +(define (make-input-bus bus-name [width 1]) + (impersonate-procedure (procedure-rename (let ([bus-width width] [bus-val 0]) - (define (do-arg-check arg) - (when (and arg (> arg (expt 2 bus-width))) - (raise-argument-error bus-name (format "value that fits into bus width ~a (= under ~a)" bus-width (expt 2 bus-width)) arg))) - (case-lambda - [() bus-val] - [(arg) - (do-arg-check arg) - (set! bus-val arg)] - [(bus-bits arg) - (unless (and (< (first bus-bits) bus-width) (< (last bus-bits) bus-width)) - (raise-argument-error bus-name (format "bus bit spec less than bus width ~a" bus-width) bus-bits)) - (do-arg-check arg) - (set! bus-val arg)])) bus-name) - #f input-wire #t)) + (unless (<= bus-width max-bus-width) + (raise-argument-error bus-name (format "bus width <= max width ~a" max-bus-width) bus-width)) + (define (check-val-against-width val width) + (when (and val (> val (sub1 (expt 2 width)))) + (raise-argument-error bus-name + (format "~a-bit value (0 to ~a inclusive)" width (sub1 (expt 2 width))) val))) + (define func + (case-lambda + [() bus-val] + [(new-val-in) + (define new-val (cond + [(boolean? new-val-in) + (if new-val-in (sub1 (expt 2 bus-width)) 0)] + [(or (input-bus? new-val-in) (output-bus? new-val-in)) (new-val-in)] + [else new-val-in])) + (check-val-against-width new-val bus-width) + (set! bus-val new-val)] + [(bit new-val) (func bit bit new-val)] + [(first-bit last-bit new-val-in) + (define bit-range-width (add1 (- last-bit first-bit))) + (define new-val (cond + [(boolean? new-val-in) + (if new-val-in (sub1 (expt 2 bit-range-width)) 0)] + [(or (input-bus? new-val-in) (output-bus? new-val-in)) (new-val-in)] + [else new-val-in])) + (unless (<= first-bit last-bit) + (raise-argument-error bus-name (format "last bit greater than or equal to first bit ~a" first-bit) last-bit)) + (check-bit-against-width bus-name first-bit bus-width) + (check-bit-against-width bus-name last-bit bus-width) + (check-val-against-width new-val bit-range-width) + (for ([bit (in-range first-bit (add1 last-bit))] + [new-bit-val (in-list (integer->bitvals new-val bit-range-width))]) + (set! bus-val ((if (= 1 new-bit-val) bitwise-bit-set bitwise-bit-unset) bus-val bit)))])) + func) + bus-name) + #f input-bus #t)) + +(define-syntax-rule (define-input-bus id arg ...) + (define id (make-input-bus 'id arg ...))) (module+ test - (require rackunit) - (define in-wire (make-bus 'in-wire)) + (define-input-bus in-bus) (define other (λ () (+ 2 2))) - (check-true (input-wire? in-wire)) - (check-false (input-wire? other)) + (check-true (input-bus? in-bus)) + (check-false (input-bus? other)) - (define x (make-bus 'x 4)) - (check-equal? (x) 0) - (x 12) - (check-equal? (x) 12) - (x 0) - (check-equal? (x) 0) - (x 12) - (check-equal? (x) 12) - (check-exn exn:fail? (λ () (x 32))) + (define-input-bus ib 4) + (check-exn exn:fail? (λ () (define-input-bus ib 17) ib)) ; exceeds 16-bit width + (check-equal? (ib) 0) + (ib 11) ; set whole value + (check-exn exn:fail? (λ () (ib #b11111))) ; overflow + (ib 2 1) ; set bit + (check-equal? (ib) #b1111) + (ib 0 #b0) ; set bit + (ib 1 #b0) ; set bit + (ib 2 #b0) ; set bit + (check-equal? (ib) #b1000) + (check-exn exn:fail? (λ () (ib 5 1 #b0))) ; last index smaller than first + (check-exn exn:fail? (λ () (ib 1 300 #b0))) ; overlarge bit index + (check-exn exn:fail? (λ () (ib 300 500 #b0))) ; overlarge bit index + (check-exn exn:fail? (λ () (ib 1 #b11111))) ; overflow value + (ib 0) + (ib 1 2 #b11) + (check-equal? (ib) #b0110) + (ib 3 3 #b1) + (ib 0 0 #b1) + (check-equal? (ib) #b1111) + (check-exn exn:fail? (λ () (ib 0 300 #b0))) ; overlarge bit index + (check-exn exn:fail? (λ () (ib 1 1 #b11111))) ; overflow value + (ib 0) + (ib 1 2 #t) ; using #t to fill certain bits + (check-equal? (ib) #b0110) + (ib 2 2 #f) ; using #f to fill certain bits + (check-equal? (ib) #b0010) + (ib 0) + (ib #t) ; using #t to fill all bits + (check-equal? (ib) #b1111) + (ib #f) ; using #f to fill all bits + (check-equal? (ib) #b0000) + (define-input-bus ib2 4) + (check-exn exn:fail? (λ () (ib2 16))) ; overflow value + (ib2 #b1100) + (ib ib2) ; using bus as input value + (check-equal? (ib) (ib2)) + ) + + +(define-values (output-bus output-bus? output-bus-get) + (make-impersonator-property 'output-bus)) + +(define (make-output-bus bus-name thunk [width 1]) + (impersonate-procedure + (procedure-rename + (let ([bus-width width]) + (unless (<= bus-width max-bus-width) + (raise-argument-error bus-name (format "bus width <= max width ~a" max-bus-width) bus-width)) + (define func + (case-lambda + [() (func 0 (sub1 bus-width))] + [(bit) (func bit bit)] + [(first-bit last-bit) + (unless (<= first-bit last-bit) + (raise-argument-error bus-name (format "last bit greater than or equal to first bit ~a" first-bit) last-bit)) + (check-bit-against-width bus-name first-bit bus-width) + (check-bit-against-width bus-name last-bit bus-width) + (bitwise-bit-field (thunk) first-bit (add1 last-bit))])) + func) + bus-name) + #f output-bus #t)) + +(define-syntax-rule (define-output-bus id thunk arg ...) + (define id (make-output-bus 'id thunk arg ...))) + +(module+ test + (define-output-bus ob (λ () #b0110) 4) + (check-exn exn:fail? (λ () (define-input-bus ob (λ () #b0110) 17) ob)) ; exceeds 16-bit width + (check-equal? (ob) #b0110) + (check-equal? (ob 0) #b0) + (check-equal? (ob 1) #b1) + (check-equal? (ob 2) #b1) + (check-equal? (ob 3) #b0) + (check-exn exn:fail? (λ () (ob 5))) ; exceeds bus width + (check-equal? (ob 0 1) #b10) + (check-equal? (ob 1 2) #b11) + (check-equal? (ob 2 3) #b01) + (check-exn exn:fail? (λ () (ob 3 2))) ; inverted bus spec + (check-exn exn:fail? (λ () (ob 5 10))) ; exceeds bus width ) diff --git a/beautiful-racket/br/demo/hdl/parser.rkt b/beautiful-racket/br/demo/hdl/parser.rkt index 975ece2..f560ebf 100644 --- a/beautiful-racket/br/demo/hdl/parser.rkt +++ b/beautiful-racket/br/demo/hdl/parser.rkt @@ -12,7 +12,7 @@ out-spec : pin-spec /pin : ID [/"[" NUMBER /"]"] -part-spec : /"PARTS:" part+ +@part-spec : /"PARTS:" part+ part : partname /"(" pin-val-pair [/"," pin-val-pair]* /")" /";" @@ -20,7 +20,7 @@ part : partname /"(" pin-val-pair [/"," pin-val-pair]* /")" /";" /pin-val-pair : ID [/"[" bus-range /"]"] /"=" pin-val -bus-range : NUMBER [/"." /"." NUMBER] +@bus-range : NUMBER [/"." /"." NUMBER] @pin-val : ID | BINARY-NUMBER diff --git a/beautiful-racket/br/demo/hdl/tokenizer.rkt b/beautiful-racket/br/demo/hdl/tokenizer.rkt index 6b5493d..6becdec 100644 --- a/beautiful-racket/br/demo/hdl/tokenizer.rkt +++ b/beautiful-racket/br/demo/hdl/tokenizer.rkt @@ -16,10 +16,10 @@ [(union #\tab #\space #\newline) (get-token input-port)] [(union "CHIP" "IN" "OUT" "PARTS:") lexeme] [(char-set "[]{}(),;=.") lexeme] - ["true" (token 'TRUE 1)] - ["false" (token 'FALSE 0)] + ["true" (token 'TRUE #t)] + ["false" (token 'FALSE #f)] [(repetition 1 +inf.0 (char-set "01")) (token 'BINARY-NUMBER (string->number lexeme 2))] [(repetition 1 +inf.0 numeric) (token 'NUMBER (string->number lexeme))] - [(seq (repetition 1 1 alphabetic) (repetition 0 +inf.0 (union alphabetic numeric))) (token 'ID (string->symbol lexeme))])) + [(seq (repetition 1 1 alphabetic) (repetition 0 +inf.0 (union alphabetic numeric "-"))) (token 'ID (string->symbol lexeme))])) (get-token input-port)) next-token)