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

resume in hdl-tst

Browse Source
pull/2/head
Matthew Butterick 8 years ago
parent f02e605a9c
commit c0a3020947
3 changed files with 70 additions and 73 deletions
Show Stats Download Patch File Download Diff File

38
beautiful-racket-lib/br/cond.rkt
Unescape Escape View File

@ -1,27 +1,27 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base)) (require (for-syntax racket/base br/syntax)
br/define)
(provide (all-defined-out)) (provide (all-defined-out))
(define-syntax-rule (until COND EXPR ...) (define-macro (until COND EXPR ...)
(let loop () #'(let loop ()
(unless COND (unless COND
EXPR ... EXPR ...
(loop)))) (loop))))
(define-syntax-rule (while COND EXPR ...) (define-macro (while COND EXPR ...)
(let loop () #'(let loop ()
(when COND (when COND
EXPR ... EXPR ...
(loop)))) (loop))))
(define-syntax (forever stx) (define-macro (forever . EXPRS)
(syntax-case stx () ;; todo: would be better with a syntax parameter
[(_ . EXPRS) (with-pattern
;; todo: would be better with a syntax parameter ([stop (datum->syntax #'EXPRS 'stop)])
(with-syntax ([stop (datum->syntax #'EXPRS 'stop)]) #'(let/ec stop
#'(let/ec stop (while #t
(while #t . EXPRS))))
. EXPRS)))]))
(module+ test (module+ test
(require rackunit) (require rackunit)

39
beautiful-racket-lib/br/debug.rkt
Unescape Escape View File

@ -1,27 +1,26 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base racket/syntax)) (require (for-syntax racket/base br/syntax)
br/define)
(provide (all-defined-out)) (provide (all-defined-out))
(define-syntax (report stx) (define-macro-cases report
(syntax-case stx () [(_ EXPR) #'(report EXPR EXPR)]
[(_ EXPR) #'(report EXPR EXPR)] [(_ EXPR NAME)
[(_ EXPR NAME) #'(let ([expr-result EXPR])
#'(let ([expr-result EXPR]) (eprintf "~a = ~v\n" 'NAME expr-result)
(eprintf "~a = ~v\n" 'NAME expr-result) expr-result)])
expr-result)]))
(define-syntax (report-datum stx) (define-macro-cases report-datum
(syntax-case stx () [(_ STX-EXPR)
[(_ STX-EXPR) (with-pattern ([datum (syntax->datum #'STX-EXPR)])
(with-syntax ([datum (syntax->datum #'STX-EXPR)]) #'(report-datum STX-EXPR datum))]
#'(report-datum STX-EXPR datum))] [(_ STX-EXPR NAME)
[(_ STX-EXPR NAME) #'(let ()
#'(let () (eprintf "~a = ~v\n" 'NAME (syntax->datum STX-EXPR))
(eprintf "~a = ~v\n" 'NAME (syntax->datum STX-EXPR)) STX-EXPR)])
STX-EXPR)]))
(define-syntax-rule (define-multi-version MULTI-NAME NAME) (define-macro (define-multi-version MULTI-NAME NAME)
(define-syntax-rule (MULTI-NAME x (... ...)) #'(define-macro (MULTI-NAME X (... ...))
(begin (NAME x) (... ...)))) #'(begin (NAME X) (... ...))))
(define-multi-version report* report) (define-multi-version report* report)

66
beautiful-racket-lib/br/reader-utils.rkt
Unescape Escape View File

@ -1,43 +1,41 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base racket/syntax) syntax/strip-context) (require (for-syntax racket/base racket/syntax br/syntax) br/define syntax/strip-context)
(provide define-read-and-read-syntax) (provide define-read-and-read-syntax)
;; `define-read-functions` simplifies support for the standard reading API, ;; `define-read-functions` simplifies support for the standard reading API,
;; which asks for `read` and `read-syntax`. ;; which asks for `read` and `read-syntax`.
;; in general, `read` is just the datum from the result of `read-syntax`. ;; in general, `read` is just the datum from the result of `read-syntax`.
(define-syntax (define-read-and-read-syntax calling-site-stx) (define-macro (define-read-and-read-syntax (PATH PORT) BODY ...)
(syntax-case calling-site-stx () (let ([internal-prefix (gensym)])
[(_ (PATH PORT) BODY ...) (with-syntax ([READ (datum->syntax caller-stx 'read)]
(let ([internal-prefix (gensym)]) [READ-SYNTAX (datum->syntax caller-stx 'read-syntax)]
(with-syntax ([READ (datum->syntax calling-site-stx 'read)] ;; use prefixed names to prevent namespace collisions with possibly existing `read` & `read-syntax`
[READ-SYNTAX (datum->syntax calling-site-stx 'read-syntax)] [INTERNAL-READ (format-id #'here "~a-~a" internal-prefix 'read)]
;; use prefixed names to prevent namespace collisions with possibly existing `read` & `read-syntax` [INTERNAL-READ-SYNTAX (format-id #'here "~a-~a" internal-prefix 'read-syntax)])
[INTERNAL-READ (format-id #'here "~a-~a" internal-prefix 'read)] #'(begin
[INTERNAL-READ-SYNTAX (format-id #'here "~a-~a" internal-prefix 'read-syntax)]) (provide (rename-out [INTERNAL-READ READ]
#'(begin [INTERNAL-READ-SYNTAX READ-SYNTAX]))
(provide (rename-out [INTERNAL-READ READ] (define (calling-site-function PATH PORT)
[INTERNAL-READ-SYNTAX READ-SYNTAX])) BODY ...) ; don't care whether this produces datum or syntax
(define (calling-site-function PATH PORT)
BODY ...) ; don't care whether this produces datum or syntax
(define INTERNAL-READ-SYNTAX (define INTERNAL-READ-SYNTAX
(procedure-rename (λ (path port) ; rename proc so it looks right in the REPL (otherwise retains internal prefix name) (procedure-rename (λ (path port) ; rename proc so it looks right in the REPL (otherwise retains internal prefix name)
;; because `read-syntax` must produce syntax ;; because `read-syntax` must produce syntax
;; coerce a datum result to syntax if needed (à la `with-syntax`) ;; coerce a datum result to syntax if needed (à la `with-syntax`)
(define result-syntax (let ([output (calling-site-function path port)]) (define result-syntax (let ([output (calling-site-function path port)])
(if (syntax? output) (if (syntax? output)
output output
(datum->syntax #f output)))) (datum->syntax #f output))))
;; because `read-syntax` must produce syntax without context ;; because `read-syntax` must produce syntax without context
;; see http://docs.racket-lang.org/guide/hash-lang_reader.html ;; see http://docs.racket-lang.org/guide/hash-lang_reader.html
;; "a `read-syntax` function should return a syntax object with no lexical context" ;; "a `read-syntax` function should return a syntax object with no lexical context"
(strip-context result-syntax)) 'READ-SYNTAX)) (strip-context result-syntax)) 'READ-SYNTAX))
(define INTERNAL-READ (define INTERNAL-READ
(procedure-rename (λ (port) (procedure-rename (λ (port)
; because `read` must produce a datum ; because `read` must produce a datum
(let ([output (calling-site-function #f port)]) (let ([output (calling-site-function #f port)])
(if (syntax? output) (if (syntax? output)
(syntax->datum output) (syntax->datum output)
output))) 'READ)))))])) output))) 'READ))))))
Write Preview
Loading…
Cancel
Save