mbutterick
/
beautiful-racket
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

renamings

Browse Source
pull/2/head
Matthew Butterick 9 years ago
parent a36fbc2df6
commit 4e0e306777
5 changed files with 74 additions and 61 deletions
Show Stats Download Patch File Download Diff File

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

@ -44,7 +44,7 @@
[remove-id (prefix-id "remove-" #'id)] [remove-id (prefix-id "remove-" #'id)]
[id? (suffix-id #'id "?")] [id? (suffix-id #'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 #'(begin
(define id-sis (define id-sis
(let ([sis-in (list scope-id-sis ...)]) (let ([sis-in (list scope-id-sis ...)])

49
beautiful-racket-lib/br/syntax.rkt
Unescape Escape View File

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

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

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

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

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

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

@ -104,28 +104,30 @@ base bus:
(define-values (bus bus? bus-get) (define-values (bus bus? bus-get)
(make-impersonator-property 'bus)) (make-impersonator-property 'bus))
(define-cases #'define-base-bus (define-macro-cases define-base-bus
[#'(_macro-name _id _thunk) #'(_macro-name _id _thunk default-bus-width)] [#'(_macro-name ID THUNK) #'(_macro-name ID THUNK default-bus-width)]
[#'(_macro-name _id _thunk _bus-width-in) [#'(_macro-name ID THUNK _bus-width-in)
(inject-syntax ([#'_id-thunk (suffix-id #'_id "-val")] (with-pattern
[#'_bus-type (or (syntax-property caller-stx 'impersonate) #'bus)]) ([_id-thunk (suffix-id #'ID "-val")]
#`(splicing-let ([_id-thunk _thunk] [_bus-type (or (syntax-property caller-stx 'impersonate) #'bus)])
[bus-width _bus-width-in]) #`(splicing-let ([_id-thunk THUNK]
(define _id [bus-width _bus-width-in])
(begin (define ID
(unless (<= bus-width max-bus-width) (begin
(raise-argument-error 'id (format "bus width <= max width ~a" max-bus-width) bus-width)) (unless (<= bus-width max-bus-width)
(impersonate-procedure (raise-argument-error 'id (format "bus width <= max width ~a" max-bus-width) bus-width))
(let ([reader (make-bus-reader 'id bus-width)]) (impersonate-procedure
(procedure-rename (λ args (apply reader (_id-thunk) args)) (string->symbol (format "~a, a bus of width ~a" '_id bus-width)))) (let ([reader (make-bus-reader 'id bus-width)])
#f _bus-type #t))) (procedure-rename (λ args (apply reader (_id-thunk) args)) (string->symbol (format "~a, a bus of width ~a" 'ID bus-width))))
#,(when (syntax-property caller-stx 'writer) #f _bus-type #t)))
(inject-syntax ([#'_id-write (suffix-id #'_id "-write")]) #,(when (syntax-property caller-stx 'writer)
#'(define _id-write (with-pattern
(let ([writer (make-bus-writer 'id-write bus-width)]) ([_id-write (suffix-id #'ID "-write")])
(λ args #'(define _id-write
(define result (apply writer (_id-thunk) args)) (let ([writer (make-bus-writer 'id-write bus-width)])
(set! _id-thunk (λ () result)))))))))]) (λ args
(define result (apply writer (_id-thunk) args))
(set! _id-thunk (λ () result)))))))))])
(module+ test (module+ test
@ -157,7 +159,7 @@ output bus:
(define-values (output-bus output-bus? output-bus-get) (define-values (output-bus output-bus? output-bus-get)
(make-impersonator-property 'output-bus)) (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)) (syntax-property #'(define-base-bus . _args) 'impersonate #'output-bus))
(module+ test (module+ test
@ -189,7 +191,7 @@ input bus:
(define-values (input-bus input-bus? input-bus-get) (define-values (input-bus input-bus? input-bus-get)
(make-impersonator-property 'input-bus)) (make-impersonator-property 'input-bus))
(define-cases #'define-input-bus (define-macro-cases define-input-bus
[#'(_macro-name _id) [#'(_macro-name _id)
#'(_macro-name _id default-bus-width)] #'(_macro-name _id default-bus-width)]
[#'(_macro-name _id _bus-width) [#'(_macro-name _id _bus-width)

Write Preview
Loading…
Cancel
Save