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

syntaxing

Browse Source
This commit is contained in:
Matthew Butterick 2016-05-20 22:33:20 -07:00
parent 1f0e0eec61
commit 187230041e
2 changed files with 42 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base syntax/parse racket/syntax syntax/strip-context) (require (for-syntax racket/base syntax/parse racket/syntax syntax/strip-context)
syntax/strip-context racket/function racket/list) syntax/strip-context racket/function racket/list racket/syntax)
(provide (all-defined-out) (all-from-out syntax/strip-context)) (provide (all-defined-out) (all-from-out syntax/strip-context))
@ -33,29 +33,37 @@
(for/list ([arg (in-list (syntax->list args))]) (for/list ([arg (in-list (syntax->list args))])
(_proc arg)))])) (_proc arg)))]))
(define identity (λ(arg) arg))
(define-syntax (partition-syntax-case stx)
(syntax-case stx ()
[(_ (_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) (define identity (λ(arg) arg))
(define-syntax (syntax-case-partition stx)
(syntax-case stx () (syntax-case stx ()
[(_ _proc _args) [(_ _stx-list literals . _matchers)
#'(let ([args _args]) #'(partition (λ(stx-item)
(datum->syntax args (with-handlers ([exn:fail:syntax? (λ (exn) #f)])
(if (and (syntax? args) (list? (syntax-e args))) (syntax-case stx-item literals
(for*/list ([arg (in-list (syntax->list args))] . _matchers))) (if (syntax? _stx-list)
[result (in-value (_proc (syntax->datum arg)))] (syntax->list _stx-list)
#:when result) _stx-list))]))
arg)
(error 'not-syntax-list))))])) (define-syntax (syntax-case-filter stx)
(syntax-case stx ()
[(_ _stx-list literals . _matchers)
#'(let-values ([(matches others) (syntax-case-partition _stx-list literals . _matchers)])
matches)]))
(define-syntax (syntax-case-map stx)
(syntax-case stx ()
[(_ _stx-list literals . _matchers)
#'(map (λ(stx-item)
(syntax-case stx-item literals
. _matchers)) (if (syntax? _stx-list)
(syntax->list _stx-list)
_stx-list))]))
(define-syntax-rule (reformat-id fmt id0 id ...)
(format-id id0 fmt id0 id ...))
#;(define-syntax syntax-variable (make-rename-transformer #'format-id)) #;(define-syntax syntax-variable (make-rename-transformer #'format-id))

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

@ -7,9 +7,11 @@
(in-spec (_input-pin _input-width ...) ...) (in-spec (_input-pin _input-width ...) ...)
(out-spec (_output-pin _output-width ...) ...) (out-spec (_output-pin _output-width ...) ...)
_part ...) _part ...)
(with-syntax* ([chip-prefix (format-id #'_chipname "~a-" #'_chipname)] (with-syntax* ([chip-prefix (reformat-id "~a-" #'_chipname)]
[(in-pin-write ...) (map (λ(iw) (format-id iw "~a-write" iw)) (syntax->list #'(_input-pin ...)))] [(in-pin-write ...) (syntax-case-map #'(_input-pin ...) ()
[(prefixed-output-pin ...) (map (λ(op) (format-id op "~a~a" #'chip-prefix op)) (syntax->list #'(_output-pin ...)))]) [iw (reformat-id "~a-write" #'iw)])]
[(prefixed-output-pin ...) (syntax-case-map #'(_output-pin ...) ()
[op (format-id #'op "~a~a" #'chip-prefix #'op)])])
#'(begin #'(begin
(provide (prefix-out chip-prefix (combine-out _input-pin ... in-pin-write ...))) (provide (prefix-out chip-prefix (combine-out _input-pin ... in-pin-write ...)))
(define-input-bus _input-pin _input-width ...) ... (define-input-bus _input-pin _input-width ...) ...
@ -19,7 +21,8 @@
(define #'(part _prefix ((_wire . _wireargs) _wirevalue) ...) (define #'(part _prefix ((_wire . _wireargs) _wirevalue) ...)
(with-syntax ([(prefixed-wire ...) (map (λ(s) (format-id s "~a-~a" #'_prefix s)) (syntax->list #'(_wire ...)))] (with-syntax ([(prefixed-wire ...) (syntax-case-map #'(_wire ...) ()
[s (format-id #'s "~a-~a" #'_prefix #'s)])]
[chip-module-path (datum->syntax #'_prefix (format "~a.hdl.rkt" (syntax->datum #'_prefix)))]) [chip-module-path (datum->syntax #'_prefix (format "~a.hdl.rkt" (syntax->datum #'_prefix)))])
#'(begin #'(begin
(require (import-chip chip-module-path) (for-syntax (import-chip chip-module-path))) (require (import-chip chip-module-path) (for-syntax (import-chip chip-module-path)))
@ -36,12 +39,12 @@
(define #'(handle-wires _wire-assignments ...) (define #'(handle-wires _wire-assignments ...)
(let-values ([(in-wire-stxs out-wire-stxs) (let-values ([(in-wire-stxs out-wire-stxs)
(partition-syntax-case (syntax-case-partition #'(_wire-assignments ...) ()
([((prefixed-wire . _wireargs) _) [((prefixed-wire . _wireargs) _)
(syntax-local-eval (syntax-shift-phase-level #'(input-bus? prefixed-wire) 1))]) (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] (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 ...)))] [(in-wire-write ...) (syntax-case-map #'(in-wire ...) ()
[iw (reformat-id "~a-write" #'iw)])]
[(((out-wire out-arg ...) (out-bus)) ...) out-wire-stxs]) [(((out-wire out-arg ...) (out-bus)) ...) out-wire-stxs])
#'(begin #'(begin
(define-output-bus out-bus (define-output-bus out-bus