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

touchups

Browse Source
pull/2/head
Matthew Butterick 9 years ago
parent e85bf68fa7
commit 7dcce997d0
3 changed files with 57 additions and 43 deletions
Show Stats Download Patch File Download Diff File

17
beautiful-racket-lib/br/define.rkt
Unescape Escape View File

@ -146,7 +146,7 @@
;; syntax ;; syntax
[(_ (syntax (id . pat-args)) . body) ; (define #'(foo arg) #'(+ arg arg)) [(_ (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) [(_ sid:syntaxed-id sid2:syntaxed-id) ; (define #'f1 #'f2)
#'(define-syntax sid.name (make-rename-transformer sid2))] #'(define-syntax sid.name (make-rename-transformer sid2))]
@ -248,6 +248,11 @@
#'(datum->syntax caller-stx (if (syntax? form) #'(datum->syntax caller-stx (if (syntax? form)
(syntax-e form) (syntax-e form)
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) (define-syntax (br:define-cases-inverting stx)
(syntax-case stx (syntax) (syntax-case stx (syntax)
@ -293,6 +298,14 @@
[(_ pat . body) [(_ pat . body)
#'(br:define (syntax 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 (module+ test
(br:define-macro (add _x) #'(+ _x _x)) (br:define-macro (add _x) #'(+ _x _x))
(check-equal? (add 5) 10)) (check-equal? (add 5) 10)
(br:define-macro-cases add-again [#'(_ X) #'(+ X X)])
(check-equal? (add-again 5) 10))

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

@ -6,7 +6,7 @@
(all-from-out racket/list racket/string racket/format racket/match racket/port (all-from-out racket/list racket/string racket/format racket/match racket/port
br/syntax br/datum br/debug br/conditional) br/syntax br/datum br/debug br/conditional)
(for-syntax (all-from-out racket/base racket/syntax br/syntax br/debug)) (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 (filtered-out
(λ (name) (λ (name)
(let ([pat (regexp "^br:")]) (let ([pat (regexp "^br:")])

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

@ -1,62 +1,63 @@
#lang br #lang br
(require (for-syntax br/syntax br/scope)) (require (for-syntax br/syntax br/scope racket/string)
(provide #%top-interaction #%module-begin #%datum #;(rename-out [my-top #%top]) #%app "hdlprint.rkt" rackunit racket/file)
(all-defined-out) (all-from-out br)) (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-for-syntax chip-prefix #f)
(define-macro (tst-program ARG ...) (define-macro (tst-program ARG ...)
(let-syntax-pattern ([compare (shared-syntax #'compare)] (let-shared-id (compare output-file)
[of (shared-syntax #'of)]) #'(begin ARG ...
#'(begin ARG ... (close-output-port of) (compare) ))) (close-output-port output-file)
(compare))))
(define-macro (load-expr CHIPFILE-STRING) (define-macro (load-expr CHIPFILE-STRING)
(let () (set! chip-prefix (string-replace (syntax->datum #'CHIPFILE-STRING) ".hdl" ""))
(set! chip-prefix (string-replace (syntax->datum #'CHIPFILE-STRING) ".hdl" "")) (let-syntax-pattern ([CHIPFILE.RKT (format-string "~a.rkt" #'CHIPFILE-STRING)])
(let-syntax-pattern ([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)
(let-syntax-pattern ([ofname (shared-syntax #'ofname)] (let-shared-id (output-file output-filename)
[of (shared-syntax #'of)]) #'(begin
#'(begin (define output-filename OUTPUT-FILE-STRING)
(define ofname OUTPUT-FILE-STRING) (define output-file (open-output-file output-filename #:exists 'replace)))))
(define of (open-output-file ofname #:mode 'text #:exists 'replace)))))
(define-macro (compare-to-expr COMPARE-FILE-STRING) (define-macro (compare-to-expr COMPARE-FILE-STRING)
(let-syntax-pattern ([compare (shared-syntax 'compare)] (let-shared-id (compare output-filename)
[ofname (shared-syntax 'ofname)]) #'(define (compare)
#'(define (compare) (check-equal? (file->lines output-filename) (file->lines COMPARE-FILE-STRING)))))
(check-equal? (file->lines ofname) (file->lines COMPARE-FILE-STRING)))))
(define-macro (output-list-expr (COL-NAME FORMAT-SPEC) ...) (define-macro (output-list-expr (COL-NAME FORMAT-SPEC) ...)
(let-syntax-pattern ([(COL-ID ...) (prefix-ids "" #'(COL-NAME ...))] (let-shared-id (output output-file eval-result eval-thunk)
[(CHIP-COL-ID ...) (prefix-ids chip-prefix "-" #'(COL-NAME ...))] (let-syntax-pattern ([(COL-ID ...) (suffix-ids #'(COL-NAME ...))]
[output (shared-syntax 'output)] [(CHIP-COL-ID ...) (prefix-ids chip-prefix "-" #'(COL-NAME ...))])
[of (shared-syntax 'of)] #'(begin
[eval-result (shared-syntax 'eval-result)] (define (output COL-ID ...)
[eval-thunk (shared-syntax 'eval-thunk)]) (fprintf output-file
#'(begin (format "~a\n" (string-join (list (hdlprint COL-ID FORMAT-SPEC) ...) "|"
(define (output COL-ID ...) #:before-first "|"
(fprintf of (format "~a\n" (string-join (list (hdlprint COL-ID FORMAT-SPEC) ...) "|" #:after-last "|"))))
#:before-first "|" (define eval-result #f)
#:after-last "|")))) (define (eval-thunk) (list (CHIP-COL-ID) ...))
(define eval-result #f) (output COL-NAME ...)))))
(define eval-thunk (λ () (list (CHIP-COL-ID) ...)))
(output COL-NAME ...))))
(define-macro (set-expr IN-BUS IN-VAL) (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"))]) (let-syntax-pattern ([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)))
(define-macro (eval-expr) (define-macro (eval-expr)
(let-syntax-pattern ([eval-result (shared-syntax 'eval-result)] (let-shared-id (eval-result eval-thunk)
[eval-thunk (shared-syntax 'eval-thunk)]) #'(set! eval-result (eval-thunk))))
#'(set! eval-result (eval-thunk))))
(define-macro (output-expr) (define-macro (output-expr)
(let-syntax-pattern ([output (shared-syntax 'output)] (let-shared-id (output eval-result)
[eval-result (shared-syntax 'eval-result)]) #'(apply output eval-result)))
#'(apply output eval-result)))

Write Preview
Loading…
Cancel
Save