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

touchups

Browse Source
This commit is contained in:
Matthew Butterick 2016-05-24 13:09:06 -07:00
parent e85bf68fa7
commit 7dcce997d0
3 changed files with 57 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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))
(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
View File

@ -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:")])

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

@ -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)))