From c0a302094726a2aab93d471fb50edfe1a24a5d61 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sun, 14 Aug 2016 23:12:06 -0400 Subject: [PATCH] resume in hdl-tst --- beautiful-racket-lib/br/cond.rkt | 38 +++++++------- beautiful-racket-lib/br/debug.rkt | 39 +++++++------- beautiful-racket-lib/br/reader-utils.rkt | 66 ++++++++++++------------ 3 files changed, 70 insertions(+), 73 deletions(-) diff --git a/beautiful-racket-lib/br/cond.rkt b/beautiful-racket-lib/br/cond.rkt index dd1de32..6043fb7 100644 --- a/beautiful-racket-lib/br/cond.rkt +++ b/beautiful-racket-lib/br/cond.rkt @@ -1,27 +1,27 @@ #lang racket/base -(require (for-syntax racket/base)) +(require (for-syntax racket/base br/syntax) + br/define) (provide (all-defined-out)) -(define-syntax-rule (until COND EXPR ...) - (let loop () - (unless COND - EXPR ... - (loop)))) +(define-macro (until COND EXPR ...) + #'(let loop () + (unless COND + EXPR ... + (loop)))) -(define-syntax-rule (while COND EXPR ...) - (let loop () - (when COND - EXPR ... - (loop)))) +(define-macro (while COND EXPR ...) + #'(let loop () + (when COND + EXPR ... + (loop)))) -(define-syntax (forever stx) - (syntax-case stx () - [(_ . EXPRS) - ;; todo: would be better with a syntax parameter - (with-syntax ([stop (datum->syntax #'EXPRS 'stop)]) - #'(let/ec stop - (while #t - . EXPRS)))])) +(define-macro (forever . EXPRS) + ;; todo: would be better with a syntax parameter + (with-pattern + ([stop (datum->syntax #'EXPRS 'stop)]) + #'(let/ec stop + (while #t + . EXPRS)))) (module+ test (require rackunit) diff --git a/beautiful-racket-lib/br/debug.rkt b/beautiful-racket-lib/br/debug.rkt index fb4dbc3..9618a95 100644 --- a/beautiful-racket-lib/br/debug.rkt +++ b/beautiful-racket-lib/br/debug.rkt @@ -1,27 +1,26 @@ #lang racket/base -(require (for-syntax racket/base racket/syntax)) +(require (for-syntax racket/base br/syntax) + br/define) (provide (all-defined-out)) -(define-syntax (report stx) - (syntax-case stx () - [(_ EXPR) #'(report EXPR EXPR)] - [(_ EXPR NAME) - #'(let ([expr-result EXPR]) - (eprintf "~a = ~v\n" 'NAME expr-result) - expr-result)])) +(define-macro-cases report + [(_ EXPR) #'(report EXPR EXPR)] + [(_ EXPR NAME) + #'(let ([expr-result EXPR]) + (eprintf "~a = ~v\n" 'NAME expr-result) + expr-result)]) -(define-syntax (report-datum stx) - (syntax-case stx () - [(_ STX-EXPR) - (with-syntax ([datum (syntax->datum #'STX-EXPR)]) - #'(report-datum STX-EXPR datum))] - [(_ STX-EXPR NAME) - #'(let () - (eprintf "~a = ~v\n" 'NAME (syntax->datum STX-EXPR)) - STX-EXPR)])) +(define-macro-cases report-datum + [(_ STX-EXPR) + (with-pattern ([datum (syntax->datum #'STX-EXPR)]) + #'(report-datum STX-EXPR datum))] + [(_ STX-EXPR NAME) + #'(let () + (eprintf "~a = ~v\n" 'NAME (syntax->datum STX-EXPR)) + STX-EXPR)]) -(define-syntax-rule (define-multi-version MULTI-NAME NAME) - (define-syntax-rule (MULTI-NAME x (... ...)) - (begin (NAME x) (... ...)))) +(define-macro (define-multi-version MULTI-NAME NAME) + #'(define-macro (MULTI-NAME X (... ...)) + #'(begin (NAME X) (... ...)))) (define-multi-version report* report) \ No newline at end of file diff --git a/beautiful-racket-lib/br/reader-utils.rkt b/beautiful-racket-lib/br/reader-utils.rkt index 8b31f1b..57e3623 100644 --- a/beautiful-racket-lib/br/reader-utils.rkt +++ b/beautiful-racket-lib/br/reader-utils.rkt @@ -1,43 +1,41 @@ #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) ;; `define-read-functions` simplifies support for the standard reading API, ;; which asks for `read` and `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) - (syntax-case calling-site-stx () - [(_ (PATH PORT) BODY ...) - (let ([internal-prefix (gensym)]) - (with-syntax ([READ (datum->syntax calling-site-stx 'read)] - [READ-SYNTAX (datum->syntax calling-site-stx 'read-syntax)] - ;; use prefixed names to prevent namespace collisions with possibly existing `read` & `read-syntax` - [INTERNAL-READ (format-id #'here "~a-~a" internal-prefix 'read)] - [INTERNAL-READ-SYNTAX (format-id #'here "~a-~a" internal-prefix 'read-syntax)]) - #'(begin - (provide (rename-out [INTERNAL-READ READ] - [INTERNAL-READ-SYNTAX READ-SYNTAX])) - (define (calling-site-function PATH PORT) - BODY ...) ; don't care whether this produces datum or syntax +(define-macro (define-read-and-read-syntax (PATH PORT) BODY ...) + (let ([internal-prefix (gensym)]) + (with-syntax ([READ (datum->syntax caller-stx 'read)] + [READ-SYNTAX (datum->syntax caller-stx 'read-syntax)] + ;; use prefixed names to prevent namespace collisions with possibly existing `read` & `read-syntax` + [INTERNAL-READ (format-id #'here "~a-~a" internal-prefix 'read)] + [INTERNAL-READ-SYNTAX (format-id #'here "~a-~a" internal-prefix 'read-syntax)]) + #'(begin + (provide (rename-out [INTERNAL-READ READ] + [INTERNAL-READ-SYNTAX READ-SYNTAX])) + (define (calling-site-function PATH PORT) + BODY ...) ; don't care whether this produces datum or syntax - (define INTERNAL-READ-SYNTAX - (procedure-rename (λ (path port) ; rename proc so it looks right in the REPL (otherwise retains internal prefix name) - ;; because `read-syntax` must produce syntax - ;; coerce a datum result to syntax if needed (à la `with-syntax`) - (define result-syntax (let ([output (calling-site-function path port)]) - (if (syntax? output) - output - (datum->syntax #f output)))) - ;; because `read-syntax` must produce syntax without context - ;; see http://docs.racket-lang.org/guide/hash-lang_reader.html - ;; "a `read-syntax` function should return a syntax object with no lexical context" - (strip-context result-syntax)) 'READ-SYNTAX)) + (define INTERNAL-READ-SYNTAX + (procedure-rename (λ (path port) ; rename proc so it looks right in the REPL (otherwise retains internal prefix name) + ;; because `read-syntax` must produce syntax + ;; coerce a datum result to syntax if needed (à la `with-syntax`) + (define result-syntax (let ([output (calling-site-function path port)]) + (if (syntax? output) + output + (datum->syntax #f output)))) + ;; because `read-syntax` must produce syntax without context + ;; see http://docs.racket-lang.org/guide/hash-lang_reader.html + ;; "a `read-syntax` function should return a syntax object with no lexical context" + (strip-context result-syntax)) 'READ-SYNTAX)) - (define INTERNAL-READ - (procedure-rename (λ (port) - ; because `read` must produce a datum - (let ([output (calling-site-function #f port)]) - (if (syntax? output) - (syntax->datum output) - output))) 'READ)))))])) \ No newline at end of file + (define INTERNAL-READ + (procedure-rename (λ (port) + ; because `read` must produce a datum + (let ([output (calling-site-function #f port)]) + (if (syntax? output) + (syntax->datum output) + output))) 'READ)))))) \ No newline at end of file