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

resume in mux

Browse Source
This commit is contained in:
Matthew Butterick 2016-05-19 13:00:55 -07:00
parent 2fc5f63185
commit 1e6407bd1a
10 changed files with 232 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
beautiful-racket/br/demo/hdl/DMux.hdl.rkt
View File

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

39
beautiful-racket/br/demo/hdl/Mux-test.rkt Normal file
View File

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

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

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

5
beautiful-racket/br/demo/hdl/Nand.hdl.rkt
View File

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

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

@ -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)))))
(part Nand (a in) (b in) (out out)))

4
beautiful-racket/br/demo/hdl/Not.hdl.rkt
View File

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

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

@ -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)) ...))))
(out-wire out-arg ...))) ...))))

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

@ -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 (make-bus bus-name [width 1])
(impersonate-procedure
(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 (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
)

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

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

6
beautiful-racket/br/demo/hdl/tokenizer.rkt
View File

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