From 7dcce997d0f1a322e9dd01e5f890d876bf2b82fa Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Tue, 24 May 2016 13:09:06 -0700 Subject: [PATCH] touchups --- beautiful-racket-lib/br/define.rkt | 17 +++- beautiful-racket-lib/br/main.rkt | 2 +- beautiful-racket/br/demo/hdl-tst/expander.rkt | 81 ++++++++++--------- 3 files changed, 57 insertions(+), 43 deletions(-) diff --git a/beautiful-racket-lib/br/define.rkt b/beautiful-racket-lib/br/define.rkt index 892c119..d50763c 100644 --- a/beautiful-racket-lib/br/define.rkt +++ b/beautiful-racket-lib/br/define.rkt @@ -146,7 +146,7 @@ ;; syntax [(_ (syntax (id . pat-args)) . body) ; (define #'(foo arg) #'(+ arg arg)) - #'(br:define-cases (syntax id) [(syntax (_ . pat-args)) . body])] + #'(br:define-cases (syntax id) [(syntax (_ . pat-args)) (begin . body)])] [(_ sid:syntaxed-id sid2:syntaxed-id) ; (define #'f1 #'f2) #'(define-syntax sid.name (make-rename-transformer sid2))] @@ -248,6 +248,11 @@ #'(datum->syntax caller-stx (if (syntax? form) (syntax-e form) form))]))])))) +(provide (for-syntax let-shared-id)) +(begin-for-syntax + (define-syntax-rule (let-shared-id (id ...) . body) + (with-syntax ([id (shared-syntax 'id)] ...) + . body))) (define-syntax (br:define-cases-inverting stx) (syntax-case stx (syntax) @@ -293,6 +298,14 @@ [(_ pat . body) #'(br:define (syntax pat) . body)])) +(define-syntax (br:define-macro-cases stx) + (syntax-case stx (syntax) + [(_ pat . body) + #'(br:define-cases (syntax pat) . body)])) + + (module+ test (br:define-macro (add _x) #'(+ _x _x)) - (check-equal? (add 5) 10)) \ No newline at end of file + (check-equal? (add 5) 10) + (br:define-macro-cases add-again [#'(_ X) #'(+ X X)]) + (check-equal? (add-again 5) 10)) \ No newline at end of file diff --git a/beautiful-racket-lib/br/main.rkt b/beautiful-racket-lib/br/main.rkt index f00e437..17bf42d 100644 --- a/beautiful-racket-lib/br/main.rkt +++ b/beautiful-racket-lib/br/main.rkt @@ -6,7 +6,7 @@ (all-from-out racket/list racket/string racket/format racket/match racket/port br/syntax br/datum br/debug br/conditional) (for-syntax (all-from-out racket/base racket/syntax br/syntax br/debug)) - (for-syntax caller-stx shared-syntax) ; from br/define + (for-syntax caller-stx shared-syntax let-shared-id) ; from br/define (filtered-out (λ (name) (let ([pat (regexp "^br:")]) diff --git a/beautiful-racket/br/demo/hdl-tst/expander.rkt b/beautiful-racket/br/demo/hdl-tst/expander.rkt index ee9692a..e78fddf 100644 --- a/beautiful-racket/br/demo/hdl-tst/expander.rkt +++ b/beautiful-racket/br/demo/hdl-tst/expander.rkt @@ -1,62 +1,63 @@ #lang br -(require (for-syntax br/syntax br/scope)) -(provide #%top-interaction #%module-begin #%datum #;(rename-out [my-top #%top]) #%app - (all-defined-out) (all-from-out br)) +(require (for-syntax br/syntax br/scope racket/string) + "hdlprint.rkt" rackunit racket/file) +(provide #%top-interaction #%module-begin #%datum #%app (all-defined-out)) -(require br/demo/hdl-tst/hdlprint rackunit racket/file (for-syntax racket/string)) (define-for-syntax chip-prefix #f) + (define-macro (tst-program ARG ...) - (let-syntax-pattern ([compare (shared-syntax #'compare)] - [of (shared-syntax #'of)]) - #'(begin ARG ... (close-output-port of) (compare) ))) + (let-shared-id (compare output-file) + #'(begin ARG ... + (close-output-port output-file) + (compare)))) + (define-macro (load-expr CHIPFILE-STRING) - (let () - (set! chip-prefix (string-replace (syntax->datum #'CHIPFILE-STRING) ".hdl" "")) - (let-syntax-pattern ([CHIPFILE.RKT (format-string "~a.rkt" #'CHIPFILE-STRING)]) - #'(require CHIPFILE.RKT)))) + (set! chip-prefix (string-replace (syntax->datum #'CHIPFILE-STRING) ".hdl" "")) + (let-syntax-pattern ([CHIPFILE.RKT (format-string "~a.rkt" #'CHIPFILE-STRING)]) + #'(require CHIPFILE.RKT))) + (define-macro (output-file-expr OUTPUT-FILE-STRING) - (let-syntax-pattern ([ofname (shared-syntax #'ofname)] - [of (shared-syntax #'of)]) - #'(begin - (define ofname OUTPUT-FILE-STRING) - (define of (open-output-file ofname #:mode 'text #:exists 'replace))))) + (let-shared-id (output-file output-filename) + #'(begin + (define output-filename OUTPUT-FILE-STRING) + (define output-file (open-output-file output-filename #:exists 'replace))))) + (define-macro (compare-to-expr COMPARE-FILE-STRING) - (let-syntax-pattern ([compare (shared-syntax 'compare)] - [ofname (shared-syntax 'ofname)]) - #'(define (compare) - (check-equal? (file->lines ofname) (file->lines COMPARE-FILE-STRING))))) + (let-shared-id (compare output-filename) + #'(define (compare) + (check-equal? (file->lines output-filename) (file->lines COMPARE-FILE-STRING))))) + (define-macro (output-list-expr (COL-NAME FORMAT-SPEC) ...) - (let-syntax-pattern ([(COL-ID ...) (prefix-ids "" #'(COL-NAME ...))] - [(CHIP-COL-ID ...) (prefix-ids chip-prefix "-" #'(COL-NAME ...))] - [output (shared-syntax 'output)] - [of (shared-syntax 'of)] - [eval-result (shared-syntax 'eval-result)] - [eval-thunk (shared-syntax 'eval-thunk)]) - #'(begin - (define (output COL-ID ...) - (fprintf of (format "~a\n" (string-join (list (hdlprint COL-ID FORMAT-SPEC) ...) "|" - #:before-first "|" - #:after-last "|")))) - (define eval-result #f) - (define eval-thunk (λ () (list (CHIP-COL-ID) ...))) - (output COL-NAME ...)))) + (let-shared-id (output output-file eval-result eval-thunk) + (let-syntax-pattern ([(COL-ID ...) (suffix-ids #'(COL-NAME ...))] + [(CHIP-COL-ID ...) (prefix-ids chip-prefix "-" #'(COL-NAME ...))]) + #'(begin + (define (output COL-ID ...) + (fprintf output-file + (format "~a\n" (string-join (list (hdlprint COL-ID FORMAT-SPEC) ...) "|" + #:before-first "|" + #:after-last "|")))) + (define eval-result #f) + (define (eval-thunk) (list (CHIP-COL-ID) ...)) + (output COL-NAME ...))))) + (define-macro (set-expr IN-BUS IN-VAL) (let-syntax-pattern ([CHIP-IN-BUS-ID-WRITE (prefix-id chip-prefix "-" (suffix-id #'IN-BUS "-write"))]) #'(CHIP-IN-BUS-ID-WRITE IN-VAL))) + (define-macro (eval-expr) - (let-syntax-pattern ([eval-result (shared-syntax 'eval-result)] - [eval-thunk (shared-syntax 'eval-thunk)]) - #'(set! eval-result (eval-thunk)))) + (let-shared-id (eval-result eval-thunk) + #'(set! eval-result (eval-thunk)))) + (define-macro (output-expr) - (let-syntax-pattern ([output (shared-syntax 'output)] - [eval-result (shared-syntax 'eval-result)]) - #'(apply output eval-result))) + (let-shared-id (output eval-result) + #'(apply output eval-result)))