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
(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))
@ -33,29 +33,37 @@
(for/list ([arg (in-list (syntax->list args))])
(_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 ()
[(_ _proc _args)
#'(let ([args _args])
(datum->syntax args
(if (and (syntax? args) (list? (syntax-e args)))
(for*/list ([arg (in-list (syntax->list args))]
[result (in-value (_proc (syntax->datum arg)))]
#:when result)
arg)
(error 'not-syntax-list))))]))
[(_ _stx-list literals . _matchers)
#'(partition (λ(stx-item)
(with-handlers ([exn:fail:syntax? (λ (exn) #f)])
(syntax-case stx-item literals
. _matchers))) (if (syntax? _stx-list)
(syntax->list _stx-list)
_stx-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))

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

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