mbutterick
/
beautiful-racket
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

`syntax-property*` and other improvements

Browse Source
pull/2/head
Matthew Butterick 8 years ago
parent 51ff735f7d
commit fad5a4fce8
2 changed files with 111 additions and 88 deletions
Show Stats Download Patch File Download Diff File

25
beautiful-racket-lib/br/syntax.rkt
Unescape Escape View File

@ -3,6 +3,8 @@
syntax/strip-context racket/function racket/list racket/syntax)
(provide (all-defined-out) (all-from-out syntax/strip-context))
(module+ test
(require rackunit))
(define-syntax (syntax-match stx)
(syntax-case stx (syntax)
@ -25,7 +27,7 @@
[(_ () . body) #'(begin . body)]
[(_ (stx-expr0 stx-expr ...) . body)
#'(inject-syntax (stx-expr0)
(inject-syntax* (stx-expr ...) . body))]))
(inject-syntax* (stx-expr ...) . body))]))
(define-syntax syntax-let (make-rename-transformer #'inject-syntax))
(define-syntax add-syntax (make-rename-transformer #'inject-syntax))
@ -90,4 +92,23 @@
(define-syntax-rule (suffix-ids _bases _suffix ...)
(infix-ids "" _bases _suffix ...))
(define-syntax (syntax-property* stx)
(syntax-case stx (quote)
[(_ stx-object 'prop0)
#'(syntax-property stx-object 'prop0)]
[(_ stx-object 'prop0 'prop ...)
#'(cons (syntax-property stx-object 'prop0) (let ([result (syntax-property* stx-object 'prop ...)])
(if (pair? result)
result
(list result))))]
[(_ stx-object ['prop0 val0 . preserved0])
#'(syntax-property stx-object 'prop0 val0 . preserved0)]
[(_ stx-object ['prop0 val0 . preserved0] ['prop val . preserved] ...)
#'(syntax-property* (syntax-property stx-object 'prop0 val0 . preserved0) ['prop val . preserved] ...)]))
(module+ test
(define x (syntax-property* #'foo ['bar #t] ['zam 'boni]))
(check-false (syntax-property* x 'foo))
(check-true (syntax-property* x 'bar))
(check-equal? (syntax-property* x 'foo 'bar 'zam) '(#f #t boni)))

174
beautiful-racket/br/demo/hdl/helper.rkt
Unescape Escape View File

@ -1,6 +1,5 @@
#lang racket/base
(require (for-syntax racket/base racket/syntax) racket/splicing)
(require racket/match racket/list)
#lang br
(require racket/list (for-syntax br/syntax) racket/splicing)
(provide (all-defined-out))
(module+ test
@ -18,22 +17,18 @@
(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 (integer->bitvals int width)
(reverse (for/list ([i (in-range width)])
(bitwise-bit-field int i (add1 i)))))
@ -53,49 +48,48 @@
(define (make-bus-reader reader-name width)
(define bus-reader-func
(case-lambda
[(id-thunk-val) (bus-reader-func id-thunk-val 0 (sub1 width))]
[(id-thunk-val bit) (bus-reader-func id-thunk-val bit bit)]
[(id-thunk-val first-bit last-bit)
(unless (<= first-bit last-bit)
(raise-argument-error reader-name (format "last bit greater than or equal to first bit ~a" first-bit) last-bit))
(check-bit-against-width reader-name first-bit width)
(check-bit-against-width reader-name last-bit width)
(bitwise-bit-field id-thunk-val first-bit (add1 last-bit))]))
(define-cases bus-reader-func
[(_ id-thunk-val) (bus-reader-func id-thunk-val 0 (sub1 width))]
[(_ id-thunk-val bit) (bus-reader-func id-thunk-val bit bit)]
[(_ id-thunk-val first-bit last-bit)
(unless (<= first-bit last-bit)
(raise-argument-error reader-name (format "last bit greater than or equal to first bit ~a" first-bit) last-bit))
(check-bit-against-width reader-name first-bit width)
(check-bit-against-width reader-name last-bit width)
(bitwise-bit-field id-thunk-val first-bit (add1 last-bit))])
(procedure-rename bus-reader-func reader-name))
(define (make-bus-writer writer-name width)
(define bus-writer-func
(case-lambda
[(id-thunk-val) (raise-argument-error writer-name "new value" empty)]
[(id-thunk-val new-val-in)
(define new-val (cond
[(boolean? new-val-in)
(if new-val-in (sub1 (expt 2 width)) 0)]
[(or (input-bus? new-val-in) (output-bus? new-val-in)) (new-val-in)]
[else new-val-in]))
(check-val-against-width writer-name new-val width)
new-val]
[(id-thunk-val bit new-val) (bus-writer-func id-thunk-val bit bit new-val)]
[(id-thunk-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 writer-name (format "last bit greater than or equal to first bit ~a" first-bit) last-bit))
(check-bit-against-width writer-name first-bit width)
(check-bit-against-width writer-name last-bit width)
(check-val-against-width writer-name new-val bit-range-width)
(define last-val
(for/fold ([val id-thunk-val])
([bit (in-range first-bit (add1 last-bit))]
[new-bit-val (in-list (integer->bitvals new-val bit-range-width))])
((if (= 1 new-bit-val) bitwise-bit-set bitwise-bit-unset) val bit)))
last-val]))
(define-cases bus-writer-func
[(_ id-thunk-val) (raise-argument-error writer-name "new value" empty)]
[(_ id-thunk-val new-val-in)
(define new-val (cond
[(boolean? new-val-in)
(if new-val-in (sub1 (expt 2 width)) 0)]
[(or (input-bus? new-val-in) (output-bus? new-val-in)) (new-val-in)]
[else new-val-in]))
(check-val-against-width writer-name new-val width)
new-val]
[(_ id-thunk-val bit new-val) (bus-writer-func id-thunk-val bit bit new-val)]
[(_ id-thunk-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 writer-name (format "last bit greater than or equal to first bit ~a" first-bit) last-bit))
(check-bit-against-width writer-name first-bit width)
(check-bit-against-width writer-name last-bit width)
(check-val-against-width writer-name new-val bit-range-width)
(define last-val
(for/fold ([val id-thunk-val])
([bit (in-range first-bit (add1 last-bit))]
[new-bit-val (in-list (integer->bitvals new-val bit-range-width))])
((if (= 1 new-bit-val) bitwise-bit-set bitwise-bit-unset) val bit)))
last-val])
bus-writer-func)
@ -110,30 +104,28 @@ base bus:
(define-values (bus bus? bus-get)
(make-impersonator-property 'bus))
(define-syntax (define-base-bus stx)
(syntax-case stx ()
[(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)]
[bus-type (or (syntax-property stx 'impersonate) #'bus)])
#`(splicing-let ([id-thunk thunk]
[bus-width bus-width-in])
(define id
(begin
(unless (<= bus-width max-bus-width)
(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)])
(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
(let ([writer (make-bus-writer 'id-write bus-width)])
(λ args
(define result (apply writer (id-thunk) args))
(set! id-thunk (λ () result)))))))))]))
(define-cases #'define-base-bus
[#'(_macro-name _id _thunk) #'(_macro-name _id _thunk _default-bus-width)]
[#'(_macro-name _id _thunk _bus-width-in)
(inject-syntax ([#'_id-thunk (suffix-id #'_id "-val")]
[#'_bus-type (or (syntax-property caller-stx 'impersonate) #'bus)])
#`(splicing-let ([_id-thunk _thunk]
[bus-width _bus-width-in])
(define _id
(begin
(unless (<= bus-width max-bus-width)
(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)])
(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 caller-stx 'writer)
(inject-syntax ([#'_id-write (suffix-id #'_id "-write")])
#'(define _id-write
(let ([writer (make-bus-writer 'id-write bus-width)])
(λ args
(define result (apply writer (_id-thunk) args))
(set! _id-thunk (λ () result)))))))))])
(module+ test
@ -165,10 +157,8 @@ output bus:
(define-values (output-bus output-bus? output-bus-get)
(make-impersonator-property 'output-bus))
(define-syntax (define-output-bus stx)
(syntax-case stx ()
[(_ . args)
(syntax-property #'(define-base-bus . args) 'impersonate #'output-bus)]))
(define #'(define-output-bus . _args)
(syntax-property #'(define-base-bus . _args) 'impersonate #'output-bus))
(module+ test
(define-output-bus ob (λ () #b0110) 4)
@ -199,16 +189,13 @@ input bus:
(define-values (input-bus input-bus? input-bus-get)
(make-impersonator-property 'input-bus))
(define-syntax (define-input-bus stx)
(syntax-case stx ()
[(macro-name id)
#'(macro-name id default-bus-width)]
[(macro-name id bus-width)
(syntax-property
(syntax-property
#'(define-base-bus id (λ () 0) bus-width)
'impersonate #'input-bus)
'writer #t)]))
(define-cases #'define-input-bus
[#'(_macro-name _id)
#'(_macro-name _id default-bus-width)]
[#'(_macro-name _id _bus-width)
(syntax-property* #'(define-base-bus _id (λ () 0) _bus-width)
['impersonate #'input-bus]
['writer #t])])
(module+ test
(define-input-bus ib 4)
@ -248,10 +235,25 @@ input bus:
(check-equal? (ib) #b1111)
(ib-write #f) ; using #f to fill all bits
(check-equal? (ib) #b0000)
(ib-write 1 #t)
(check-equal? (ib) 2)
(ib-write 1 #f)
(check-equal? (ib) 0)
(ib-write 2 1)
(check-equal? (ib) 4)
(ib-write 2 0)
(check-equal? (ib) 0)
(ib-write 1 2 #t)
(check-equal? (ib) 6)
(ib-write 2 3 #t)
(check-equal? (ib) 14)
(ib-write 0 2 #f)
(check-equal? (ib) 8)
(ib-write #b1011)
(check-equal? (ib) 11)
(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
(check-equal? (ib) (ib2))
)
Write Preview
Loading…
Cancel
Save