From fad5a4fce8a0172e573e3048924794d62e83a467 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sat, 21 May 2016 17:58:01 -0700 Subject: [PATCH] `syntax-property*` and other improvements --- beautiful-racket-lib/br/syntax.rkt | 25 +++- beautiful-racket/br/demo/hdl/helper.rkt | 174 ++++++++++++------------ 2 files changed, 111 insertions(+), 88 deletions(-) diff --git a/beautiful-racket-lib/br/syntax.rkt b/beautiful-racket-lib/br/syntax.rkt index d89c2b8..efa1a9d 100644 --- a/beautiful-racket-lib/br/syntax.rkt +++ b/beautiful-racket-lib/br/syntax.rkt @@ -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))) + diff --git a/beautiful-racket/br/demo/hdl/helper.rkt b/beautiful-racket/br/demo/hdl/helper.rkt index 91ab179..030d5ff 100644 --- a/beautiful-racket/br/demo/hdl/helper.rkt +++ b/beautiful-racket/br/demo/hdl/helper.rkt @@ -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)) ) - \ No newline at end of file