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

renamings

Browse Source
This commit is contained in:
Matthew Butterick 2016-05-25 08:52:46 -07:00
parent a36fbc2df6
commit 4e0e306777
5 changed files with 72 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
beautiful-racket-lib/br/scope.rkt
View File

@ -44,7 +44,7 @@
[remove-id (prefix-id "remove-" #'id)]
[id? (suffix-id #'id "?")]
[id* (suffix-id #'id "*")]
[(scope-id-sis ...) (suffix-ids #'scope-ids "-sis")])
[(scope-id-sis ...) (suffix-id #'scope-ids "-sis")])
#'(begin
(define id-sis
(let ([sis-in (list scope-id-sis ...)])

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

@ -31,6 +31,7 @@
#'(inject-syntax (stx-expr0)
(inject-syntax* (stx-expr ...) . body))]))
(define-syntax with-pattern (make-rename-transformer #'inject-syntax*))
(define-syntax let-syntax-pattern (make-rename-transformer #'inject-syntax*))
(define-syntax let*-syntax-pattern (make-rename-transformer #'inject-syntax*))
(define-syntax syntax-let (make-rename-transformer #'inject-syntax))
@ -78,25 +79,33 @@
(syntax->datum x)
x))
(define-syntax-rule (prefix-id _prefix ... _base)
(format-id _base "~a~a" (string-append (format "~a" (->unsyntax _prefix)) ...) (syntax-e _base)))
(define-syntax-rule (prefix-id _prefix ... _base-or-bases)
(let* ([bob _base-or-bases]
[got-single? (and (not (list? bob)) (not (syntax->list bob)))]
[bases (if got-single?
(list bob)
bob)]
[result (syntax-case-map
bases ()
[base (format-id #'base "~a~a"
(string-append (format "~a" (->unsyntax _prefix)) ...)
(syntax-e #'base))])])
(if got-single? (car result) result)))
(define-syntax-rule (prefix-ids _prefix ... _bases)
(syntax-case-map _bases ()
[_base (prefix-id _prefix ... #'_base)]))
(define-syntax-rule (infix-id _prefix _base-or-bases _suffix ...)
(let* ([bob _base-or-bases]
[got-single? (and (not (list? bob)) (not (syntax->list bob)))]
[bases (if got-single?
(list bob)
bob)]
[result (syntax-case-map
bases ()
[base (format-id #'base "~a~a~a" (->unsyntax _prefix) (syntax-e #'base)
(string-append (format "~a" (->unsyntax _suffix)) ...))])])
(if got-single? (car result) result)))
(define-syntax-rule (infix-id _prefix _base _suffix ...)
(format-id _base "~a~a~a" (->unsyntax _prefix) (syntax-e _base) (string-append (format "~a" (->unsyntax _suffix)) ...)))
(define-syntax-rule (infix-ids _prefix _bases _suffix ...)
(syntax-case-map _bases ()
[_base (infix-id _prefix #'_base _suffix ...)]))
(define-syntax-rule (suffix-id _base _suffix ...)
(infix-id "" _base _suffix ...))
(define-syntax-rule (suffix-ids _bases _suffix ...)
(infix-ids "" _bases _suffix ...))
(define-syntax-rule (suffix-id _base-or-bases _suffix ...)
(infix-id "" _base-or-bases _suffix ...))
(define-syntax (syntax-property* stx)
(syntax-case stx (quote)
@ -121,4 +130,6 @@
(define-syntax-rule (introduce-id (id ...) . body)
(with-syntax ([id (syntax-local-introduce (datum->syntax #f 'id))] ...)
. body))
(define-syntax with-shared-id (make-rename-transformer #'introduce-id))

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

@ -1,5 +1,5 @@
#lang br
(require (for-syntax br/syntax br/scope racket/string) rackunit racket/file)
(require (for-syntax br/syntax racket/string) rackunit racket/file)
(provide #%top-interaction #%module-begin #%datum #%app (all-defined-out))
@ -43,13 +43,13 @@
(define-macro (load-expr CHIPFILE-STRING)
(set! chip-prefix (string-replace (syntax->datum #'CHIPFILE-STRING) ".hdl" ""))
(let-syntax-pattern
(with-pattern
([CHIPFILE.RKT (format-string "~a.rkt" #'CHIPFILE-STRING)])
#'(require CHIPFILE.RKT)))
(define-macro (output-file-expr OUTPUT-FILE-STRING)
(introduce-id
(with-shared-id
(output-file output-filename)
#'(begin
(define output-filename OUTPUT-FILE-STRING)
@ -60,18 +60,18 @@
(define-macro (compare-to-expr COMPARE-FILE-STRING)
(introduce-id
(with-shared-id
(compare-files)
#'(define (compare-files)
(check-equal? (file->lines output-filename) (file->lines COMPARE-FILE-STRING)))))
(define-macro (output-list-expr (COL-NAME FORMAT-SPEC) ...)
(introduce-id
(with-shared-id
(eval-result eval-chip output)
(let-syntax-pattern
([(COL-ID ...) (suffix-ids #'(COL-NAME ...))]
[(CHIP-COL-ID ...) (prefix-ids chip-prefix "-" #'(COL-NAME ...))])
(with-pattern
([(COL-ID ...) (suffix-id #'(COL-NAME ...))]
[(CHIP-COL-ID ...) (prefix-id chip-prefix "-" #'(COL-NAME ...))])
#'(begin
(define (output COL-ID ...)
(print-line output-filename (map print-cell (list COL-ID ...) (list FORMAT-SPEC ...))))
@ -81,7 +81,7 @@
(define-macro (set-expr IN-BUS IN-VAL)
(let-syntax-pattern
(with-pattern
([CHIP-IN-BUS-ID-WRITE (prefix-id chip-prefix "-" (suffix-id #'IN-BUS "-write"))])
#'(CHIP-IN-BUS-ID-WRITE IN-VAL)))

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

@ -6,10 +6,10 @@
(in-spec (IN-BUS IN-WIDTH ...) ...)
(out-spec (OUT-BUS OUT-WIDTH ...) ...)
PART ...)
(let-syntax-pattern
(with-pattern
([CHIP-PREFIX (suffix-id #'CHIPNAME "-")]
[(IN-BUS-WRITE ...) (suffix-ids #'(IN-BUS ...) "-write")]
[(PREFIX-OUT-BUS ...) (prefix-ids #'CHIP-PREFIX #'(OUT-BUS ...))])
[(IN-BUS-WRITE ...) (suffix-id #'(IN-BUS ...) "-write")]
[(PREFIX-OUT-BUS ...) (prefix-id #'CHIP-PREFIX #'(OUT-BUS ...))])
#'(begin
(provide (prefix-out CHIP-PREFIX (combine-out IN-BUS ... IN-BUS-WRITE ...)))
(define-input-bus IN-BUS IN-WIDTH ...) ...
@ -19,8 +19,8 @@
(define-macro (part PARTNAME ((BUS-LEFT . BUS-LEFT-ARGS) BUS-RIGHT-EXPR) ...)
(let-syntax-pattern
([(PARTNAME-BUS-LEFT ...) (prefix-ids #'PARTNAME "-" #'(BUS-LEFT ...))]
(with-pattern
([(PARTNAME-BUS-LEFT ...) (prefix-id #'PARTNAME "-" #'(BUS-LEFT ...))]
[CHIP-MODULE-PATH (format-string "~a.hdl.rkt" #'PARTNAME)])
#'(begin
(require (import-chip CHIP-MODULE-PATH) (for-syntax (import-chip CHIP-MODULE-PATH)))
@ -41,9 +41,9 @@
(syntax-case-partition #'(BUS-ASSIGNMENTS ...) ()
[((PREFIXED-WIRE . _) _)
(syntax-local-eval (syntax-shift-phase-level #'(input-bus? PREFIXED-WIRE) 1))])])
(let-syntax-pattern
(with-pattern
([(((IN-BUS IN-BUS-ARG ...) IN-BUS-VALUE) ...) in-bus-assignments]
[(IN-BUS-WRITE ...) (suffix-ids #'(IN-BUS ...) "-write")]
[(IN-BUS-WRITE ...) (suffix-id #'(IN-BUS ...) "-write")]
[((OUT-BUS-EXPR (NEW-OUT-BUS)) ...) out-bus-assignments])
#'(begin
(define-output-bus NEW-OUT-BUS

50
beautiful-racket/br/demo/hdl/helper.rkt
View File

@ -104,28 +104,30 @@ base bus:
(define-values (bus bus? bus-get)
(make-impersonator-property 'bus))
(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)))))))))])
(define-macro-cases define-base-bus
[#'(_macro-name ID THUNK) #'(_macro-name ID THUNK default-bus-width)]
[#'(_macro-name ID THUNK _bus-width-in)
(with-pattern
([_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)
(with-pattern
([_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
@ -157,7 +159,7 @@ output bus:
(define-values (output-bus output-bus? output-bus-get)
(make-impersonator-property 'output-bus))
(define #'(define-output-bus . _args)
(define-macro (define-output-bus . _args)
(syntax-property #'(define-base-bus . _args) 'impersonate #'output-bus))
(module+ test
@ -189,7 +191,7 @@ input bus:
(define-values (input-bus input-bus? input-bus-get)
(make-impersonator-property 'input-bus))
(define-cases #'define-input-bus
(define-macro-cases define-input-bus
[#'(_macro-name _id)
#'(_macro-name _id default-bus-width)]
[#'(_macro-name _id _bus-width)