diff --git a/beautiful-racket-lib/br/syntax.rkt b/beautiful-racket-lib/br/syntax.rkt index 91cf581..31850cc 100644 --- a/beautiful-racket-lib/br/syntax.rkt +++ b/beautiful-racket-lib/br/syntax.rkt @@ -1,6 +1,6 @@ #lang racket/base (require (for-syntax racket/base syntax/parse racket/syntax syntax/strip-context) - syntax/strip-context racket/function) + syntax/strip-context racket/function racket/list) (provide (all-defined-out) (all-from-out syntax/strip-context)) @@ -33,13 +33,17 @@ (for/list ([arg (in-list (syntax->list args))]) (_proc arg)))])) -(define-syntax (partition-syntax stx) +(define identity (λ(arg) arg)) +(define-syntax (partition-syntax-case stx) (syntax-case stx () - [(_ _proc _args) - #'(let ([args _args]) - (unless (and (syntax? args) (list? (syntax-e args))) - (raise-argument-error 'map-syntax "not a syntax list")) - (partition _proc (syntax->list args)))])) + [(_ (_matchers ...) _stx-list) + #'(let* ([stx-list _stx-list] + [stxs (cond + [(and (syntax? stx-list) (syntax->list stx-list)) => identity] + [(and (list? stx-list) (andmap syntax? list)) stx-list] + [else (raise-argument-error 'partition-syntax-case "syntaxed list or list of syntax objects" stx-list)])]) + (partition (λ(stx-item) (syntax-case stx-item () + _matchers ...)) stxs))])) (define-syntax (filter-syntax stx) (syntax-case stx () diff --git a/beautiful-racket/br/demo/hdl/expander.rkt b/beautiful-racket/br/demo/hdl/expander.rkt index 6ae21dd..0b21ab6 100644 --- a/beautiful-racket/br/demo/hdl/expander.rkt +++ b/beautiful-racket/br/demo/hdl/expander.rkt @@ -1,5 +1,5 @@ #lang br -(require "helper.rkt" (for-syntax racket/base racket/syntax "helper.rkt" racket/list racket/require-transform)) +(require "helper.rkt" (for-syntax racket/base racket/syntax racket/require-transform br/syntax)) (provide #%top-interaction #%module-begin #%app #%datum and or (all-defined-out)) @@ -36,11 +36,10 @@ (define #'(handle-wires _wire-assignments ...) (let-values ([(in-wire-stxs out-wire-stxs) - (partition (λ(wa) - (syntax-case wa () - [((prefixed-wire . _wireargs) _) - (input-bus? (syntax-local-eval #'prefixed-wire))])) - (syntax->list #'(_wire-assignments ...)))]) + (partition-syntax-case + ([((prefixed-wire . _wireargs) _) + (syntax-local-eval (syntax-shift-phase-level #'(input-bus? prefixed-wire) 1))]) + #'(_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])