From f02e605a9c4ac19d9b80e9e3863fa306283e3980 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sun, 14 Aug 2016 23:01:19 -0400 Subject: [PATCH] refactory --- beautiful-racket-lib/br/define.rkt | 29 +-- beautiful-racket-lib/br/experimental/eopl.rkt | 3 +- .../br/private/syntax-flatten.rkt | 12 + beautiful-racket-lib/br/private/to-string.rkt | 92 ------- beautiful-racket-lib/br/quicklang.rkt | 6 +- beautiful-racket-lib/br/syntax.rkt | 238 +++++++----------- beautiful-racket/br/demo/basic/expander.rkt | 1 + beautiful-racket/br/demo/hdl-tst/expander.rkt | 4 +- beautiful-racket/br/demo/hdl/bus.rkt | 32 +-- beautiful-racket/br/demo/hdl/expander.rkt | 4 +- beautiful-racket/br/demo/hdl/reader.rkt | 7 +- 11 files changed, 148 insertions(+), 280 deletions(-) create mode 100644 beautiful-racket-lib/br/private/syntax-flatten.rkt delete mode 100644 beautiful-racket-lib/br/private/to-string.rkt diff --git a/beautiful-racket-lib/br/define.rkt b/beautiful-racket-lib/br/define.rkt index a83f208..9bbc61f 100644 --- a/beautiful-racket-lib/br/define.rkt +++ b/beautiful-racket-lib/br/define.rkt @@ -3,11 +3,8 @@ racket/function (for-syntax racket/base syntax/parse - br/syntax - racket/syntax - syntax/datum - syntax/define - racket/string)) + br/private/syntax-flatten + syntax/define)) (provide (all-defined-out) (for-syntax with-shared-id)) @@ -26,18 +23,18 @@ (begin-for-syntax - (define (upcased? str) - (equal? (string-upcase str) str)) + (define (upcased-and-capitalized? str) + (and (equal? (string-upcase str) str) + (not (equal? (string-downcase (substring str 0 1)) (substring str 0 1))))) (define (generate-literals pats) - ;; generate literals for any symbols that are not ... or _ or _underscore-prefixed + ;; generate literals for any symbols that are not ... or _ (define pattern-arg-prefixer "_") (for*/list ([pat-arg (in-list (syntax-flatten pats))] [pat-datum (in-value (syntax->datum pat-arg))] #:when (and (symbol? pat-datum) (not (member pat-datum '(... _))) ; exempted from literality - (not (string-prefix? (symbol->string pat-datum) pattern-arg-prefixer)) - (not (upcased? (symbol->string pat-datum))))) + (not (upcased-and-capitalized? (symbol->string pat-datum))))) pat-arg))) (begin-for-syntax @@ -94,11 +91,11 @@ (require rackunit racket/port) (parameterize ([current-output-port (open-output-nowhere)]) (check-equal? (let () - (debug-define-macro (foo _X _Y _Z) - #'(apply + (list _X _Y _Z))) + (debug-define-macro (foo X Y Z) + #'(apply + (list X Y Z))) (foo 1 2 3)) 6) (check-equal? (let () - (debug-define-macro (foo _X ...) #'(apply * (list _X ...))) + (debug-define-macro (foo X ...) #'(apply * (list X ...))) (foo 10 11 12)) 1320))) @@ -228,7 +225,7 @@ (zam 'this 'that 42) (check-equal? dirty-zam 'got-dirty-zam) - (define-macro (add _x) #'(+ _x _x)) + (define-macro (add X) #'(+ X X)) (check-equal? (add 5) 10) (define-macro-cases add-again [(_ X) #'(+ X X)]) (check-equal? (add-again 5) 10) @@ -240,7 +237,7 @@ (define (foo-func) 'got-foo-func) (define-macro-cases op [(_ "+") #''got-plus] - [(_ _ARG) #''got-something-else] + [(_ ARG) #''got-something-else] [(_) #'(foo-func)] [_ #'foo-val]) @@ -250,7 +247,7 @@ (check-equal? op 'got-foo-val) (define-macro-cases elseop - [(_ _arg) #''got-arg] + [(_ ARG) #''got-arg] [else #''got-else]) (check-equal? (elseop "+") 'got-arg) diff --git a/beautiful-racket-lib/br/experimental/eopl.rkt b/beautiful-racket-lib/br/experimental/eopl.rkt index 90a167b..5f0ac09 100644 --- a/beautiful-racket-lib/br/experimental/eopl.rkt +++ b/beautiful-racket-lib/br/experimental/eopl.rkt @@ -2,7 +2,7 @@ (require racket/struct (for-syntax br/datum)) (provide define-datatype cases occurs-free?) -(define-macro (define-datatype BASE-TYPE _base-type-predicate? +(define-macro (define-datatype BASE-TYPE BASE-TYPE-PREDICATE? (SUBTYPE [FIELD FIELD-PREDICATE?] ...) ...) #'(begin (struct BASE-TYPE () #:transparent #:mutable) @@ -35,6 +35,7 @@ SUBTYPE-CASE ... [else (void)])])) + (define-macro-cases cases [(_ BASE-TYPE INPUT-VAR [SUBTYPE (POSITIONAL-VAR ...) . BODY] ... diff --git a/beautiful-racket-lib/br/private/syntax-flatten.rkt b/beautiful-racket-lib/br/private/syntax-flatten.rkt new file mode 100644 index 0000000..5e44af0 --- /dev/null +++ b/beautiful-racket-lib/br/private/syntax-flatten.rkt @@ -0,0 +1,12 @@ +#lang racket/base +(require racket/list) +(provide (all-defined-out)) + +(define (syntax-flatten stx) + (flatten + (let loop ([stx stx]) + (let* ([stx-unwrapped (syntax-e stx)] + [maybe-pair (and (pair? stx-unwrapped) (flatten stx-unwrapped))]) + (if maybe-pair + (map loop maybe-pair) + stx))))) \ No newline at end of file diff --git a/beautiful-racket-lib/br/private/to-string.rkt b/beautiful-racket-lib/br/private/to-string.rkt deleted file mode 100644 index ec3e840..0000000 --- a/beautiful-racket-lib/br/private/to-string.rkt +++ /dev/null @@ -1,92 +0,0 @@ -#lang racket/base -(require racket/contract/base - syntax/stx) - -(require racket/list) - -(define (syntax->string c) - (let* ([s (open-output-string)] - [l (syntax->list c)] - [init-col (or (syntax-column (first l)) 0)] - [col init-col] - [line (or (syntax-line (first l)) 0)]) - (define (advance c init-line!) - (let ([c (syntax-column c)] - [l (syntax-line c)]) - (when (and l (l . > . line)) - (for-each (λ (_) (newline)) (range (- l line))) - (set! line l) - (init-line!)) - (when c - (display (make-string (max 0 (- c col)) #\space)) - (set! col c)))) - (parameterize ([current-output-port s] - [read-case-sensitive #t]) - (define (loop init-line!) - (lambda (c) - (cond - [(eq? 'code:blank (syntax-e c)) - (advance c init-line!)] - [(eq? '_ (syntax-e c)) (void)] - [(eq? '... (syntax-e c)) - (void)] - [(and (pair? (syntax-e c)) - (eq? (syntax-e (car (syntax-e c))) 'code:comment)) - (advance c init-line!) - (printf "; ") - (display (syntax-e (cadr (syntax->list c))))] - [(and (pair? (syntax-e c)) - (eq? (syntax-e (car (syntax-e c))) 'code:contract)) - (advance c init-line!) - (printf "; ") - (let* ([l (cdr (syntax->list c))] - [s-col (or (syntax-column (first l)) col)]) - (set! col s-col) - (for-each (loop (lambda () - (set! col s-col) - (printf "; "))) - l))] - [(and (pair? (syntax-e c)) - (eq? (syntax-e (car (syntax-e c))) 'quote)) - (advance c init-line!) - (printf "'") - (let ([i (cadr (syntax->list c))]) - (set! col (or (syntax-column i) col)) - ((loop init-line!) i))] - [(pair? (syntax-e c)) - (advance c init-line!) - (define c-paren-shape (syntax-property c 'paren-shape)) - (printf (format "~a" (or c-paren-shape #\())) - (set! col (+ col 1)) - (map (loop init-line!) (syntax->list c)) - (printf (case c-paren-shape - [(#\[) "]"] - [(#\{) "}"] - [else ")"])) - (set! col (+ col 1))] - [(vector? (syntax-e c)) - (advance c init-line!) - (printf "#(") - (set! col (+ col 2)) - (map (loop init-line!) (vector->list (syntax-e c))) - (printf ")") - (set! col (+ col 1))] - [else - (advance c init-line!) - (let ([s (format "~s" (syntax-e c))]) - (set! col (+ col (string-length s))) - (display s))]))) - (for-each (loop (lambda () (set! col init-col))) l)) - (get-output-string s))) - -(provide/contract [syntax->string (-> (and/c syntax? stx-list?) - string?)]) - -(module+ test - (require rackunit) - (check-equal? (syntax->string - #'((define (f x) - [+ x x]) - - (define (g x) - (* x x)))) "(define (f x)\n [+ x x])\n\n(define (g x)\n (* x x))")) diff --git a/beautiful-racket-lib/br/quicklang.rkt b/beautiful-racket-lib/br/quicklang.rkt index a12ff6a..11ec310 100644 --- a/beautiful-racket-lib/br/quicklang.rkt +++ b/beautiful-racket-lib/br/quicklang.rkt @@ -3,10 +3,10 @@ (provide (except-out (all-from-out br) #%module-begin) (rename-out [quicklang-mb #%module-begin])) -(define-macro (quicklang-mb . exprs) +(define-macro (quicklang-mb . EXPRS) (define-values (kw-pairs other-exprs) - (let loop ([kw-pairs null][exprs (syntax->list #'exprs)]) + (let loop ([kw-pairs null][exprs (syntax->list #'EXPRS)]) (if (and (pair? exprs) (keyword? (syntax-e (car exprs)))) (loop (cons (cons (string->symbol (keyword->string (syntax-e (car exprs)))) (cadr exprs)) ; leave val in stx form so local binding is preserved @@ -22,7 +22,7 @@ (provide PROVIDED-ID ...) (provide (rename-out [VAL KW]) ...) (provide #%top #%app #%datum #%top-interaction) - . #,(datum->syntax #'exprs other-exprs #'exprs)))) + . #,(datum->syntax #'EXPRS other-exprs #'EXPRS)))) (module reader syntax/module-reader diff --git a/beautiful-racket-lib/br/syntax.rkt b/beautiful-racket-lib/br/syntax.rkt index 1e947bc..1fadc82 100644 --- a/beautiful-racket-lib/br/syntax.rkt +++ b/beautiful-racket-lib/br/syntax.rkt @@ -1,45 +1,29 @@ #lang racket/base -(require (for-syntax racket/base syntax/parse racket/syntax syntax/strip-context) - syntax/strip-context racket/function racket/list racket/syntax "private/to-string.rkt") -(provide (all-defined-out) (all-from-out syntax/strip-context) - (rename-out [strip-context strip-identifier-bindings])) +(require (for-syntax racket/base racket/syntax) + racket/list + racket/syntax + br/define + br/private/syntax-flatten) +(provide (all-defined-out) + syntax-flatten) (module+ test (require rackunit)) -(define-syntax (syntax-match stx) - (syntax-case stx (syntax) - [(_ stx-arg [(syntax pattern) body ...] ...) - #'(syntax-case stx-arg () - [pattern body ...] ...)])) - -(define-syntax (inject-syntax stx) - ;; todo: permit mixing of two-arg and one-arg binding forms - ;; one-arg form allows you to inject an existing syntax object using its current name - (syntax-case stx (syntax) - [(_ ([(syntax sid) sid-stx] ...) body ...) - #'(inject-syntax ([sid sid-stx] ...) body ...)] - [(_ ([sid sid-stx] ...) body ...) - #'(with-syntax ([sid sid-stx] ...) body ...)] - ;; todo: limit `sid` to be an identifier - [(_ ([sid] ...) body ...) - #'(with-syntax ([sid sid] ...) body ...)])) - -(define-syntax (inject-syntax* stx) - (syntax-case stx () - [(_ () . body) #'(begin . body)] - [(_ (stx-expr0 stx-expr ...) . body) - #'(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)) -(define-syntax add-syntax (make-rename-transformer #'inject-syntax)) - -(define-syntax-rule (test-macro mac-expr) - (syntax->datum (expand-once #'mac-expr))) + +(define-macro (syntax-match STX-ARG [(syntax PATTERN) BODY ...] ...) + #'(syntax-case STX-ARG () + [PATTERN BODY ...] ...)) + + +(define-macro-cases with-pattern + [(_ () . BODY) #'(begin . BODY)] + [(_ ([SID SID-STX] STX ...) . BODY) + #'(with-syntax ([SID SID-STX]) + (with-pattern (STX ...) . BODY))] + [(_ ([SID] STX ...) . BODY) ; standalone id + #'(with-pattern ([SID SID] STX ...) . BODY)]) ; convert to previous case + (define (check-syntax-list-argument caller-name arg) (cond @@ -48,118 +32,84 @@ [else (raise-argument-error caller-name "list of syntax, or syntaxed list" arg)])) -(define-syntax-rule (syntax-case-partition _stx-list _literals . _matchers) - (partition (λ(stx-item) - (with-handlers ([exn:fail:syntax? (λ (exn) #f)]) - (syntax-case stx-item _literals - . _matchers))) (check-syntax-list-argument 'syntax-case-partition _stx-list))) - - -(define-syntax-rule (syntax-case-filter _stx-list _literals . _matchers) - (filter (λ(stx-item) - (with-handlers ([exn:fail:syntax? (λ (exn) #f)]) - (syntax-case stx-item _literals - . _matchers))) (check-syntax-list-argument 'syntax-case-filter _stx-list))) - - -(define-syntax-rule (syntax-case-map _stx-list _literals . _matchers) - (map (λ(stx-item) - (syntax-case stx-item _literals - . _matchers)) (check-syntax-list-argument 'syntax-case-map _stx-list))) - - -(define-syntax-rule (reformat-id fmt id0 id ...) - (format-id id0 fmt id0 id ...)) - -(define-syntax-rule (format-string fmt id0 id ...) - (datum->syntax id0 (format fmt (syntax->datum id0) (syntax->datum id) ...))) - - -(define-syntax-rule (->unsyntax x) - (if (syntax? x) - (syntax->datum x) - x)) - -(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 (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 (suffix-id _base-or-bases _suffix ...) - (infix-id "" _base-or-bases _suffix ...)) - -(define-syntax (syntax-property* stx) - (syntax-case stx (quote) - [(_ stx-object 'prop0) - #'(syntax-property stx-object 'prop0)] - [(_ stx-object 'prop0 'prop ...) - #'(cons (syntax-property stx-object 'prop0) (let ([result (syntax-property* stx-object 'prop ...)]) - (if (pair? result) - result - (list result))))] - [(_ stx-object ['prop0 val0 . preserved0]) - #'(syntax-property stx-object 'prop0 val0 . preserved0)] - [(_ stx-object ['prop0 val0 . preserved0] ['prop val . preserved] ...) - #'(syntax-property* (syntax-property stx-object 'prop0 val0 . preserved0) ['prop val . preserved] ...)])) +(define-macro (define-listy-macro MACRO-ID LIST-FUNC) + #'(define-macro (MACRO-ID STX-LIST LITERALS . MATCHERS) + #'(LIST-FUNC + (λ(stx-item) + (with-handlers ([exn:fail:syntax? (λ (exn) #f)]) + (syntax-case stx-item LITERALS + . MATCHERS))) + (check-syntax-list-argument 'MACRO-ID STX-LIST)))) + +(define-listy-macro syntax-case-partition partition) +(define-listy-macro syntax-case-filter filter) +(define-listy-macro syntax-case-map map) + + +(define-macro (reformat-id FMT ID0 ID ...) + #'(format-id ID0 FMT ID0 ID ...)) -(module+ test - (define x (syntax-property* #'foo ['bar #t] ['zam 'boni])) - (check-false (syntax-property* x 'foo)) - (check-true (syntax-property* x 'bar)) - (check-equal? (syntax-property* x 'foo 'bar 'zam) '(#f #t boni))) +(define-macro (format-string FMT ID0 ID ...) + #'(datum->syntax ID0 (format FMT (syntax->datum ID0) (syntax->datum ID) ...))) -;; the Søgaard technique -;; http://blog.scheme.dk/2006/05/how-to-write-unhygienic-macro.html -(define-syntax-rule (introduce-id (id ...) . body) - (with-syntax ([id (syntax-local-introduce (syntax-local-get-shadower #'id))] ...) - . body)) +(define-macro (->unsyntax X) + #'(if (syntax? X) + (syntax->datum X) + X)) -(define (syntax-flatten stx) - (flatten - (let loop ([stx stx]) - (define maybe-pair (let ([e-stx (syntax-e stx)]) - (and (pair? e-stx) (flatten e-stx)))) - (if maybe-pair - (map loop maybe-pair) - stx)))) -(define-syntax-rule (begin-label LABEL . EXPRS) - (begin - (define LABEL (syntax->string #'EXPRS)) - (provide LABEL) - (begin . EXPRS))) +(define-macro (prefix-id PREFIX ... BASE-OR-BASES) + #'(let* ([bobs BASE-OR-BASES] + [got-single? (and (not (list? bobs)) (not (syntax->list bobs)))] + [bases (if got-single? + (list bobs) + bobs)] + [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-macro (infix-id PREFIX BASE-OR-BASES SUFFIX ...) + #'(let* ([bobs BASE-OR-BASES] + [got-single? (and (not (list? bobs)) (not (syntax->list bobs)))] + [bases (if got-single? + (list bobs) + bobs)] + [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-macro (suffix-id BASE-OR-BASES SUFFIX ...) + #'(infix-id "" BASE-OR-BASES SUFFIX ...)) + + +(define-macro-cases syntax-property* + [(_ STX 'PROP0) ; read one + #'(syntax-property STX 'PROP0)] + [(_ STX 'PROP0 'PROP ...) ; read multiple + #'(cons (syntax-property* STX 'PROP0) + (let ([result (syntax-property* STX 'PROP ...)]) + (if (pair? result) + result + (list result))))] + [(_ STX ['PROP0 VAL0 . PRESERVED0]) ; write one + #'(syntax-property STX 'PROP0 VAL0 . PRESERVED0)] + [(_ STX ['PROP0 VAL0 . PRESERVED0] ['PROP VAL . PRESERVED] ...) ; write multiple + #'(syntax-property* (syntax-property STX 'PROP0 VAL0 . PRESERVED0) ['PROP VAL . PRESERVED] ...)]) + (module+ test - (begin-label - zing - (define (f x) - [+ x x]) - - (define (g x) - (* x x))) - - (check-equal? zing "(define (f x)\n [+ x x])\n\n(define (g x)\n (* x x))") - (check-equal? (f 5) 10) - (check-equal? (g 5) 25)) \ No newline at end of file + (define x (syntax-property* #'foo ['bar #t] ['zam 'boni])) + (check-false (syntax-property* x 'foo)) + (check-true (syntax-property* x 'bar)) + (check-equal? (syntax-property* x 'foo 'bar 'zam) '(#f #t boni))) \ No newline at end of file diff --git a/beautiful-racket/br/demo/basic/expander.rkt b/beautiful-racket/br/demo/basic/expander.rkt index 0846838..892992b 100644 --- a/beautiful-racket/br/demo/basic/expander.rkt +++ b/beautiful-racket/br/demo/basic/expander.rkt @@ -1,4 +1,5 @@ #lang br +(require (for-syntax syntax/strip-context)) (provide #%top-interaction #%app #%datum (rename-out [basic-module-begin #%module-begin]) (rename-out [basic-top #%top]) diff --git a/beautiful-racket/br/demo/hdl-tst/expander.rkt b/beautiful-racket/br/demo/hdl-tst/expander.rkt index 0246304..c1f9e1e 100644 --- a/beautiful-racket/br/demo/hdl-tst/expander.rkt +++ b/beautiful-racket/br/demo/hdl-tst/expander.rkt @@ -1,6 +1,6 @@ -#lang br +#lang br/quicklang (require (for-syntax br/syntax racket/string) rackunit racket/file) -(provide #%top-interaction #%module-begin #%datum #%app (all-defined-out)) +(provide #%module-begin (all-defined-out)) (define (print-cell val fmt) diff --git a/beautiful-racket/br/demo/hdl/bus.rkt b/beautiful-racket/br/demo/hdl/bus.rkt index 3c02126..4858a96 100644 --- a/beautiful-racket/br/demo/hdl/bus.rkt +++ b/beautiful-racket/br/demo/hdl/bus.rkt @@ -103,29 +103,29 @@ base bus: (define-macro-cases define-base-bus - [(_macro-name ID THUNK) #'(_macro-name ID THUNK default-bus-width)] - [(_macro-name ID THUNK _bus-width-in) + [(_ ID THUNK) #'(define-base-bus ID THUNK default-bus-width)] + [(_ 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]) + ([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))) + (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)))))))))]) + (define result (apply writer (ID-THUNK) args)) + (set! ID-THUNK (λ () result)))))))))]) (module+ test @@ -157,8 +157,8 @@ output bus: -(define-macro (define-output-bus . _args) - (syntax-property #'(define-base-bus . _args) 'impersonate #'output-bus)) +(define-macro (define-output-bus . ARGS) + (syntax-property #'(define-base-bus . ARGS) 'impersonate #'output-bus)) (module+ test (define-output-bus ob (λ () #b0110) 4) @@ -188,10 +188,10 @@ input bus: (define-macro-cases define-input-bus - [(_macro-name _id) - #'(_macro-name _id default-bus-width)] - [(_macro-name _id _bus-width) - (syntax-property* #'(define-base-bus _id (λ () 0) _bus-width) + [(MACRO-NAME ID) + #'(MACRO-NAME ID default-bus-width)] + [(MACRO-NAME ID BUS-WIDTH) + (syntax-property* #'(define-base-bus ID (λ () 0) BUS-WIDTH) ['impersonate #'input-bus] ['writer #t])]) diff --git a/beautiful-racket/br/demo/hdl/expander.rkt b/beautiful-racket/br/demo/hdl/expander.rkt index f8edb24..3258704 100644 --- a/beautiful-racket/br/demo/hdl/expander.rkt +++ b/beautiful-racket/br/demo/hdl/expander.rkt @@ -1,6 +1,6 @@ -#lang br +#lang br/quicklang (require "bus.rkt" (for-syntax racket/syntax racket/require-transform br/syntax "bus-properties.rkt")) -(provide #%top-interaction #%module-begin #%app #%datum (all-defined-out)) +(provide #%module-begin (all-defined-out)) (define-macro (chip-program CHIPNAME (in-spec (IN-BUS IN-WIDTH ...) ...) diff --git a/beautiful-racket/br/demo/hdl/reader.rkt b/beautiful-racket/br/demo/hdl/reader.rkt index fd8264c..a6bf51f 100644 --- a/beautiful-racket/br/demo/hdl/reader.rkt +++ b/beautiful-racket/br/demo/hdl/reader.rkt @@ -1,7 +1,6 @@ #lang br (require br/reader-utils "parser.rkt" "tokenizer.rkt") -(provide read-syntax) -(define (read-syntax source-path input-port) - (strip-context #`(module hdl-mod br/demo/hdl/expander - #,(parse source-path (tokenize input-port))))) +(define-read-and-read-syntax (source-path input-port) + #`(module hdl-mod br/demo/hdl/expander + #,(parse source-path (tokenize input-port))))