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

partition-syntax-case

Browse Source
This commit is contained in:
Matthew Butterick 2016-05-20 20:59:24 -07:00
parent c53414285f
commit 1f0e0eec61
2 changed files with 16 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
beautiful-racket-lib/br/syntax.rkt
View File

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

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

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