From 25dd8727cb8aca54dc7c5cbf1814f2049234ad1d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 11 Dec 2011 17:14:14 -0700 Subject: [PATCH] add `datum-case', etc. as `syntax/datum' This library is used by Redex, which wants a `syntax'-like template language, but for datum values instead of syntax objects. Using `datum-case' and `datum' generates much less code. Redex uses only a small part of the general functionality, so adding `syntax/datum' could be overkill. It's implemented by generalizing the `syntax-case' and `syntax' pattern matching and template constructing code, though; it's not a lot of extra code, and it's easiest to generalize completely. We may find other uses for datum templates, too. --- collects/racket/private/base.rkt | 4 +- collects/racket/private/misc.rkt | 2 +- collects/racket/private/old-ds.rkt | 4 +- collects/racket/private/qqstx.rkt | 411 ++++++++++++--------- collects/racket/private/sc.rkt | 262 +++++++------ collects/racket/private/stxcase-scheme.rkt | 10 +- collects/racket/private/stxcase.rkt | 112 ++++-- collects/racket/private/stxloc.rkt | 23 +- collects/racket/private/with-stx.rkt | 96 ++--- collects/redex/private/term.rkt | 23 +- collects/scheme/mzscheme.rkt | 2 +- collects/syntax/datum.rkt | 5 + collects/syntax/scribblings/datum.scrbl | 84 +++++ collects/syntax/scribblings/syntax.scrbl | 9 +- collects/tests/syntax/datum.rkt | 57 +++ 15 files changed, 710 insertions(+), 394 deletions(-) create mode 100644 collects/syntax/datum.rkt create mode 100644 collects/syntax/scribblings/datum.scrbl create mode 100644 collects/tests/syntax/datum.rkt diff --git a/collects/racket/private/base.rkt b/collects/racket/private/base.rkt index dbbc48652a..793f680d7b 100644 --- a/collects/racket/private/base.rkt +++ b/collects/racket/private/base.rkt @@ -29,8 +29,8 @@ -regexp-replace*) (rename -regexp-replace* regexp-replace*) identifier? - (all-from "stxcase-scheme.rkt") - (all-from "qqstx.rkt") + (all-from-except "stxcase-scheme.rkt" datum datum-case with-datum) + (all-from-except "qqstx.rkt" quasidatum undatum undatum-splicing) (all-from "namespace.rkt") (all-from "cert.rkt") (for-syntax syntax-rules syntax-id-rules ... _) diff --git a/collects/racket/private/misc.rkt b/collects/racket/private/misc.rkt index c730f54125..4776164e6c 100644 --- a/collects/racket/private/misc.rkt +++ b/collects/racket/private/misc.rkt @@ -33,7 +33,7 @@ (syntax/loc stx (define-syntax name (lambda (user-stx) - (syntax-case** dr #t user-stx () free-identifier=? + (syntax-case** dr #t user-stx () free-identifier=? #f [(_ . pattern) (syntax-protect (syntax/loc user-stx template))] [_ (pattern-failure user-stx 'pattern)]))))] [(_ (name . ptrn) tmpl) (err "expected an identifier" #'name)] diff --git a/collects/racket/private/old-ds.rkt b/collects/racket/private/old-ds.rkt index 4a4e045ea3..e0b35a753b 100644 --- a/collects/racket/private/old-ds.rkt +++ b/collects/racket/private/old-ds.rkt @@ -4,7 +4,7 @@ (for-syntax '#%kernel "stxcase-scheme.rkt")) - (#%provide define-struct let-struct datum) + (#%provide define-struct let-struct old-datum) (define-syntaxes (define-struct) (lambda (stx) @@ -28,6 +28,6 @@ (define-struct base (field ...)) body1 body ...)])) - (define-syntaxes (datum) + (define-syntaxes (old-datum) (syntax-rules () [(_ . any) (quote any)]))) diff --git a/collects/racket/private/qqstx.rkt b/collects/racket/private/qqstx.rkt index d0bcb4dfe9..24bc7e67f0 100644 --- a/collects/racket/private/qqstx.rkt +++ b/collects/racket/private/qqstx.rkt @@ -8,7 +8,10 @@ (#%provide quasisyntax quasisyntax/loc unsyntax - unsyntax-splicing) + unsyntax-splicing + quasidatum + undatum + undatum-splicing) (define-syntaxes (unsyntax unsyntax-splicing) (let ([f (lambda (stx) @@ -18,6 +21,14 @@ stx))]) (values f f))) + (define-syntaxes (undatum undatum-splicing) + (let ([f (lambda (stx) + (raise-syntax-error + #f + "illegal outside of quasidatum" + stx))]) + (values f f))) + (-define (check-splicing-list l ctx) (unless (stx-list? l) (raise-type-error @@ -26,184 +37,212 @@ l)) (datum->syntax ctx l ctx)) - (define-syntaxes (quasisyntax quasisyntax/loc) - (let ([qq - (lambda (orig-stx body mk-final) - (let ([here-stx #'here]) - (let loop ([stx body] - [depth 0] - [same-k (lambda () - (datum->syntax - here-stx - (mk-final body) - orig-stx))] - [convert-k (lambda (body bindings) - (datum->syntax - here-stx - (list - (quote-syntax with-syntax) - bindings - (mk-final body)) - orig-stx))]) - (syntax-case stx (unsyntax unsyntax-splicing quasisyntax) - [(unsyntax x) - (if (zero? depth) - (let ([temp (car (generate-temporaries '(uq)))]) - (convert-k temp (list (list temp (syntax x))))) - (loop (syntax x) (sub1 depth) - same-k - (lambda (v bindings) - (convert-k (datum->syntax - here-stx - (list (stx-car stx) v) - stx) - bindings))))] - [unsyntax - (raise-syntax-error - #f - "misuse within quasisyntax" - orig-stx - stx)] - [((unsyntax-splicing x) . rest) - (if (zero? depth) - (if (stx-null? (syntax rest)) - (with-syntax ([temp (car (generate-temporaries '(uqs1)))]) - (convert-k (datum->syntax - stx - (syntax temp) - stx) - (list #'[temp x]))) - (let ([rest-done-k - (lambda (rest-v bindings) - (with-syntax ([temp (car (generate-temporaries '(uqs)))] - [ctx (datum->syntax #'x 'ctx #'x)]) - (convert-k (datum->syntax - stx - (list* (syntax temp) - (quote-syntax ...) - rest-v) - stx) - (cons #'[(temp (... ...)) (check-splicing-list x (quote-syntax ctx))] - bindings))))]) - (loop (syntax rest) depth - (lambda () - (rest-done-k (syntax rest) null)) - rest-done-k))) - (let ([mk-rest-done-k - (lambda (x-v x-bindings) - (lambda (rest-v rest-bindings) - (convert-k (datum->syntax - stx - (cons x-v rest-v) - stx) - (append x-bindings - rest-bindings))))]) - (loop (syntax x) (sub1 depth) - (lambda () - ;; x is unchanged. - (loop (syntax rest) depth - same-k - (mk-rest-done-k (stx-car stx) null))) - (lambda (x-v x-bindings) - ;; x is generated by x-v - (let ([rest-done-k (mk-rest-done-k - (datum->syntax - (stx-car stx) - (list (stx-car (stx-car stx)) x-v) - (stx-car stx)) - x-bindings)]) - (loop (syntax rest) depth - (lambda () - ;; rest is unchanged - (rest-done-k (syntax rest) null)) - rest-done-k))))))] - [unsyntax-splicing - (raise-syntax-error - #f - "misuse within quasisyntax" - orig-stx - stx)] - [(quasisyntax x) - (loop (syntax x) (add1 depth) - same-k - (lambda (v bindings) - (convert-k (datum->syntax - stx - (list (stx-car stx) v) - stx) - bindings)))] - [_ - (cond - ;; We treat pairs specially so that we don't generate a lot - ;; of syntax objects when the input syntax collapses a list - ;; into a single syntax object. - [(pair? (syntax-e stx)) - (let ploop ([l (syntax-e stx)] - [same-k same-k] - [convert-k (lambda (l bindings) - (convert-k (datum->syntax - stx - l - stx) - bindings))]) - (cond - [(pair? l) - (if (let ([a (car l)]) - (or (and (identifier? a) - (or (free-identifier=? a (quote-syntax unsyntax)) - (free-identifier=? a (quote-syntax quasisyntax)))) - (and (stx-pair? a) - (let ([a (stx-car a)]) - (and (identifier? a) - (free-identifier=? a (quote-syntax unsyntax-splicing))))))) - ;; Found something important, like `unsyntax'; stop the special - ;; handling for pairs - (loop (datum->syntax #f l #f) depth - same-k - convert-k) - ;; Normal special pair handling - (ploop (cdr l) - (lambda () - ;; rest is the same - (loop (car l) depth - same-k - (lambda (a a-bindings) - (convert-k (cons (datum->syntax - (car l) - a - (car l)) - (cdr l)) - a-bindings)))) - (lambda (rest rest-bindings) - (loop (car l) depth - (lambda () - (convert-k (cons (car l) rest) - rest-bindings)) - (lambda (a a-bindings) - (convert-k (cons (datum->syntax - (car l) - a - (car l)) - rest) - (append a-bindings - rest-bindings)))))))] - [(null? l) (same-k)] - [else (loop l depth same-k convert-k)]))] - [(vector? (syntax-e stx)) - (loop (datum->syntax - stx - (vector->list (syntax-e stx)) - stx) - depth - same-k - (lambda (v bindings) - (convert-k (datum->syntax - stx - (list->vector (syntax->list v)) - stx) - bindings)))] - [else - (same-k)])]))))]) + (-define (check-splicing-datum-list l ctx) + (unless (list? l) + (raise-type-error + 'undatum-splicing + "proper list" + l)) + l) + + (define-syntaxes (quasisyntax quasisyntax/loc quasidatum) + (let* ([gen-qq + (lambda (orig-stx body mk-final who unsyntax-id unsyntax-splicing-id quasisyntax-id + with-syntax-id check-splicing-list-id) + (let ([here-stx #'here]) + (let loop ([stx body] + [depth 0] + [same-k (lambda () + (datum->syntax + here-stx + (mk-final body) + orig-stx))] + [convert-k (lambda (body bindings) + (datum->syntax + here-stx + (list + with-syntax-id + bindings + (mk-final body)) + orig-stx))]) + (syntax-case stx () + [(us x) + (and (identifier? #'us) + (free-identifier=? #'us unsyntax-id)) + (if (zero? depth) + (let ([temp (car (generate-temporaries '(uq)))]) + (convert-k temp (list (list temp (syntax x))))) + (loop (syntax x) (sub1 depth) + same-k + (lambda (v bindings) + (convert-k (datum->syntax + here-stx + (list (stx-car stx) v) + stx) + bindings))))] + [us + (and (identifier? #'us) + (free-identifier=? #'us unsyntax-id)) + (raise-syntax-error + #f + (format "misuse within ~a" who) + orig-stx + stx)] + [((us-s x) . rest) + (and (identifier? #'us-s) + (free-identifier=? #'us-s unsyntax-splicing-id)) + (if (zero? depth) + (if (stx-null? (syntax rest)) + (with-syntax ([temp (car (generate-temporaries '(uqs1)))]) + (convert-k (datum->syntax + stx + (syntax temp) + stx) + (list #'[temp x]))) + (let ([rest-done-k + (lambda (rest-v bindings) + (with-syntax ([temp (car (generate-temporaries '(uqs)))] + [ctx (datum->syntax #'x 'ctx #'x)]) + (convert-k (datum->syntax + stx + (list* (syntax temp) + (quote-syntax ...) + rest-v) + stx) + (with-syntax ([check check-splicing-list-id]) + (cons #'[(temp (... ...)) (check x (quote-syntax ctx))] + bindings)))))]) + (loop (syntax rest) depth + (lambda () + (rest-done-k (syntax rest) null)) + rest-done-k))) + (let ([mk-rest-done-k + (lambda (x-v x-bindings) + (lambda (rest-v rest-bindings) + (convert-k (datum->syntax + stx + (cons x-v rest-v) + stx) + (append x-bindings + rest-bindings))))]) + (loop (syntax x) (sub1 depth) + (lambda () + ;; x is unchanged. + (loop (syntax rest) depth + same-k + (mk-rest-done-k (stx-car stx) null))) + (lambda (x-v x-bindings) + ;; x is generated by x-v + (let ([rest-done-k (mk-rest-done-k + (datum->syntax + (stx-car stx) + (list (stx-car (stx-car stx)) x-v) + (stx-car stx)) + x-bindings)]) + (loop (syntax rest) depth + (lambda () + ;; rest is unchanged + (rest-done-k (syntax rest) null)) + rest-done-k))))))] + [us-s + (and (identifier? #'us-s) + (free-identifier=? #'us-s unsyntax-splicing-id)) + (raise-syntax-error + #f + "misuse within quasisyntax" + orig-stx + stx)] + [(qs x) + (and (identifier? #'qs) + (free-identifier=? #'qs quasisyntax-id)) + (loop (syntax x) (add1 depth) + same-k + (lambda (v bindings) + (convert-k (datum->syntax + stx + (list (stx-car stx) v) + stx) + bindings)))] + [_ + (cond + ;; We treat pairs specially so that we don't generate a lot + ;; of syntax objects when the input syntax collapses a list + ;; into a single syntax object. + [(pair? (syntax-e stx)) + (let ploop ([l (syntax-e stx)] + [same-k same-k] + [convert-k (lambda (l bindings) + (convert-k (datum->syntax + stx + l + stx) + bindings))]) + (cond + [(pair? l) + (if (let ([a (car l)]) + (or (and (identifier? a) + (or (free-identifier=? a unsyntax-id) + (free-identifier=? a quasisyntax-id))) + (and (stx-pair? a) + (let ([a (stx-car a)]) + (and (identifier? a) + (free-identifier=? a unsyntax-splicing-id)))))) + ;; Found something important, like `unsyntax'; stop the special + ;; handling for pairs + (loop (datum->syntax #f l #f) depth + same-k + convert-k) + ;; Normal special pair handling + (ploop (cdr l) + (lambda () + ;; rest is the same + (loop (car l) depth + same-k + (lambda (a a-bindings) + (convert-k (cons (datum->syntax + (car l) + a + (car l)) + (cdr l)) + a-bindings)))) + (lambda (rest rest-bindings) + (loop (car l) depth + (lambda () + (convert-k (cons (car l) rest) + rest-bindings)) + (lambda (a a-bindings) + (convert-k (cons (datum->syntax + (car l) + a + (car l)) + rest) + (append a-bindings + rest-bindings)))))))] + [(null? l) (same-k)] + [else (loop l depth same-k convert-k)]))] + [(vector? (syntax-e stx)) + (loop (datum->syntax + stx + (vector->list (syntax-e stx)) + stx) + depth + same-k + (lambda (v bindings) + (convert-k (datum->syntax + stx + (list->vector (syntax->list v)) + stx) + bindings)))] + [else + (same-k)])]))))] + [qq (lambda (orig-stx body mk-final) + (gen-qq orig-stx body mk-final + 'quasisyntax + (quote-syntax unsyntax) + (quote-syntax unsyntax-splicing) + (quote-syntax quasisyntax) + (quote-syntax with-syntax) + (quote-syntax check-splicing-list)))]) (values (lambda (orig-stx) (syntax-case orig-stx () [(_ stx) (qq orig-stx @@ -217,4 +256,16 @@ (lambda (body) (list (quote-syntax syntax/loc) (syntax loc) - body)))])))))) + body)))])) + (lambda (orig-stx) + (syntax-case orig-stx () + [(_ stx) (gen-qq orig-stx + (syntax stx) + (lambda (body) + (list (quote-syntax datum) body)) + 'quasidatum + (quote-syntax undatum) + (quote-syntax undatum-splicing) + (quote-syntax quasidatum-splicing) + (quote-syntax with-datum) + (quote-syntax check-splicing-datum-list))])))))) diff --git a/collects/racket/private/sc.rkt b/collects/racket/private/sc.rkt index 9491adca1d..779a68d13e 100644 --- a/collects/racket/private/sc.rkt +++ b/collects/racket/private/sc.rkt @@ -83,7 +83,7 @@ ;; does not contain the pattern variables as "keys", since the positions ;; can also be determined by the prototype. ;; - (-define (make-match&env/extract-vars who top p k just-vars? phase-param? interp-box) + (-define (make-match&env/extract-vars who top p k just-vars? phase-param? interp-box s-exp?) ;; The m&e function returns three values. If just-vars? is true, ;; only the first result is used, and it is the variable list. ;; Otherwise, the first result is the code assuming an input bound to `e'. @@ -109,17 +109,19 @@ (length nest-vars) last?) `(lambda (e) - (if (stx-list? e) + (if (,(if s-exp? 'list? 'stx-list?) e) ,(let ([b (app-e match-head)]) (if (equal? b '(list e)) - (if last? - '(stx->list e) - '(list (stx->list e))) + (if s-exp? + (if last? 'e '(list e)) + (if last? + '(stx->list e) + '(list (stx->list e)))) (if (null? nest-vars) - `(andmap (lambda (e) ,b) (stx->list e)) + `(andmap (lambda (e) ,b) ,(if s-exp? 'e '(stx->list e))) `(let/ec esc (let ([l (map (lambda (e) (stx-check/esc ,b esc)) - (stx->list e))]) + ,(if s-exp? 'e '(stx->list e)))]) (if (null? l) (quote ,(let ([empties (map (lambda (v) '()) nest-vars)]) (if last? @@ -178,7 +180,7 @@ (if mh-did-var? (app-append apph appt) `(if ,apph ,appt #f)))]) - (if cap? + (if (and cap? (not s-exp?)) (if id-is-rest? `(let ([cap (if (syntax? e) e cap)]) ,s) `(let ([cap e]) ,s)) @@ -221,15 +223,15 @@ mh-did-var? mt-did-var?) `(lambda (e) - (if (stx-pair? e) - ,(let ([s (let ([apph (app match-head '(stx-car e))] - [appt (app match-tail '(stx-cdr e))]) + (if (,(if s-exp? 'pair? 'stx-pair?) e) + ,(let ([s (let ([apph (app match-head (if s-exp? '(car e) '(stx-car e)))] + [appt (app match-tail (if s-exp? '(cdr e) '(stx-cdr e)))]) (if mh-did-var? (if mt-did-var? (app-append apph appt) `(let ([mh ,apph]) (and mh ,appt mh))) `(if ,apph ,appt #f)))]) - (if cap? + (if (and cap? (not s-exp?)) (if id-is-rest? `(let ([cap (if (syntax? e) e cap)]) ,s) `(let ([cap e]) ,s)) @@ -242,7 +244,9 @@ (values null #f #f) (values (if interp-box '() - 'stx-null/#f) + (if s-exp? + '(lambda (e) (if (null? e) null #f)) + 'stx-null/#f)) #f #f))] [(identifier? p) @@ -264,11 +268,11 @@ (sub1 (length (unbox interp-box))))))]) pos) `(lambda (e) - (if (identifier? e) + (if (,(if s-exp? 'symbol? 'identifier?) e) ;; This free-identifier=? can be turned into ;; free-transformer-identifier=? by an ;; enclosing binding. - (if (free-identifier=? e (quote-syntax ,p)) + (if (free-identifier=? e (,(if s-exp? 'quote 'quote-syntax) ,p)) null #f) #f))) @@ -300,7 +304,7 @@ (let ([wrap (if last? (lambda (x) `(lambda (e) ,x)) (lambda (x) `(lambda (e) (list ,x))))]) - (if id-is-rest? + (if (and id-is-rest? (not s-exp?)) (wrap '(datum->syntax cap e cap)) (wrap 'e)))) #t @@ -320,7 +324,9 @@ (if interp-box (vector 'vector len body) `(lambda (e) - (if (stx-vector? e ,len) + (if ,(if s-exp? + `(and (vector? e) (= ,len (vector-length e))) + `(stx-vector? e ,len)) ,body #f))) did-var? @@ -332,7 +338,9 @@ (or did-var? elem-did-var?) (if interp-box (cons (cons match-elem elem-did-var?) body) - (let ([app-elem (app match-elem `(stx-vector-ref e ,(sub1 pos)))]) + (let ([app-elem (app match-elem `(,(if s-exp? 'vector-ref 'stx-vector-ref) + e + ,(sub1 pos)))]) (if (null? body) app-elem (if elem-did-var? @@ -346,8 +354,10 @@ (if interp-box (vector 'veclist match-content) `(lambda (e) - (if (stx-vector? e #f) - ,(app match-content '(vector->list (syntax-e e))) + (if ,(if s-exp? + '(vector? e) + '(stx-vector? e #f)) + ,(app match-content `(vector->list ,(if s-exp? 'e '(syntax-e e)))) #f))) did-var? #f)))))] @@ -364,7 +374,9 @@ (if interp-box (vector 'prefab key match-content) `(lambda (e) - (if (stx-prefab? ',key e) + (if ,(if s-exp? + `(equal? ',key (prefab-struct-key e)) + `(stx-prefab? ',key e)) ,(app match-content '(cdr (vector->list (struct->vector (syntax-e e))))) #f))) did-var? @@ -416,17 +428,17 @@ null)) ,(app-e r))))))) - (-define (make-match&env who top p k phase-param?) - (make-match&env/extract-vars who top p k #f phase-param? #f)) + (-define (make-match&env who top p k phase-param? s-exp?) + (make-match&env/extract-vars who top p k #f phase-param? #f s-exp?)) (-define (get-match-vars who top p k) - (make-match&env/extract-vars who top p k #t #f #f)) + (make-match&env/extract-vars who top p k #t #f #f #f)) - (-define (make-interp-match p keys interp-box) + (-define (make-interp-match p keys interp-box s-exp?) (make-match&env/extract-vars (quote-syntax interp) #f p keys - #f #f interp-box)) + #f #f interp-box s-exp?)) ;; Create an S-expression that applies ;; rest to `e'. Optimize ((lambda (e) E) e) to E. @@ -483,7 +495,7 @@ ;; An environment for an expander is a list*; see the note above, ;; under "Input Matcher", for details. ;; - (-define (make-pexpand p proto-r k dest) + (-define (make-pexpand p proto-r k dest s-exp?) (-define top p) ;; Helper function: avoid generating completely new symbols ;; for substitution. Instead, try to generate normal symbols @@ -616,7 +628,7 @@ (let ([v (if (eq? post 'null) pre `(append ,pre ,post))]) - (if (and (not need-list?) (syntax? p)) + (if (and (not need-list?) (syntax? p) (not s-exp?)) ;; Keep srcloc, properties, etc.: (let ([small-dest (datum->syntax p 'dest @@ -643,14 +655,14 @@ [etl (expander (stx-cdr p) proto-r local-top use-ellipses? use-tail-pos hash! need-list?)]) (if proto-r `(lambda (r) - ,(apply-cons p (apply-to-r ehd) (apply-to-r etl) p sub-gensym)) + ,(apply-cons p (apply-to-r ehd) (apply-to-r etl) p sub-gensym s-exp?)) ;; variables were hashed (void)))))] [(stx-vector? p #f) (let ([e (expander (vector->list (syntax-e p)) proto-r p use-ellipses? use-tail-pos hash! #t)]) (if proto-r `(lambda (r) - (list->vector (stx->list ,(apply-to-r e)))) + (list->vector (,(if s-exp? 'values 'stx->list) ,(apply-to-r e)))) ;; variables were hashed (void)))] [(and (syntax? p) @@ -659,13 +671,14 @@ (let ([e (expander (cdr (vector->list (struct->vector (syntax-e p)))) proto-r p use-ellipses? use-tail-pos hash! #t)]) (if proto-r `(lambda (r) - (apply make-prefab-struct ',(prefab-struct-key (syntax-e p)) (stx->list ,(apply-to-r e)))) + (apply make-prefab-struct ',(prefab-struct-key (syntax-e p)) + (,(if s-exp? 'values 'stx->list) ,(apply-to-r e)))) ;; variables were hashed (void)))] [(identifier? p) (if (stx-memq p k) (if proto-r - `(lambda (r) (quote-syntax ,p)) + `(lambda (r) (,(if s-exp? 'quote 'quote-syntax) ,p)) (void)) (if proto-r (let ((x (stx-memq p proto-r))) @@ -680,7 +693,7 @@ top p)) (check-not-pattern p proto-r) - `(lambda (r) (quote-syntax ,p))))) + `(lambda (r) (,(if s-exp? 'quote 'quote-syntax) ,p))))) (unless (and (...? p) use-ellipses?) (hash! p))))] @@ -690,7 +703,7 @@ `(lambda (r) null) (void))] [else (if proto-r - `(lambda (r) (quote-syntax ,p)) + `(lambda (r) (,(if s-exp? 'quote 'quote-syntax) ,p)) (void))])) (let* ([ht (if proto-r #f @@ -712,8 +725,9 @@ (if proto-r `(lambda (r) ,(let ([main (let ([build (apply-to-r l)]) - (if (and (pair? build) - (eq? (car build) 'pattern-substitute)) + (if (or s-exp? + (and (pair? build) + (eq? (car build) 'pattern-substitute))) build (let ([small-dest ;; In case dest has significant structure... (and dest (datum->syntax @@ -753,52 +767,58 @@ ;; a quoted as the "optimization" --- one that ;; is necessary to preserve the syntax wraps ;; associated with p. - (-define (apply-cons stx h t p sub-gensym) + (-define (apply-cons stx h t p sub-gensym s-exp?) (cond [(and (pair? h) - (eq? (car h) 'quote-syntax) + (if s-exp? + (eq? (car h) 'quote) + (eq? (car h) 'quote-syntax)) (eq? (cadr h) (stx-car p)) (or (eq? t 'null) (and (pair? t) - (eq? (car t) 'quote-syntax) + (eq? (car t) (car h)) (eq? (cadr t) (stx-cdr p))))) - `(quote-syntax ,p)] + `(,(if s-exp? 'quote 'quote-syntax) ,p)] [(and (pair? t) (eq? (car t) 'pattern-substitute)) ;; fold h into the existing pattern-substitute: (cond [(and (pair? h) - (eq? (car h) 'quote-syntax) + (or (eq? (car h) 'quote-syntax) + (eq? (car h) 'quote)) (eq? (cadr h) (stx-car p))) ;; Just extend constant part: `(pattern-substitute - (quote-syntax ,(let ([v (cons (cadr h) (cadadr t))]) - ;; We exploit the fact that we're - ;; building an S-expression to - ;; preserve the source's distinction - ;; between (x y) and (x . (y)). - (if (syntax? stx) - (datum->syntax stx - v - stx - stx - stx) - v))) + (,(if s-exp? 'quote 'quote-syntax) + ,(let ([v (cons (cadr h) (cadadr t))]) + ;; We exploit the fact that we're + ;; building an S-expression to + ;; preserve the source's distinction + ;; between (x y) and (x . (y)). + (if (syntax? stx) + (datum->syntax stx + v + stx + stx + stx) + v))) . ,(cddr t))] [(and (pair? h) - (eq? 'pattern-substitute (car h))) + (eq? (car t) #| = 'pattern-substitute |# (car h))) ;; Combine two pattern substitutions: - `(pattern-substitute (quote-syntax ,(let ([v (cons (cadadr h) (cadadr t))]) - (if (syntax? stx) - (datum->syntax stx - v - stx - stx - stx) - v))) - ,@(cddr h) ;; <-- WARNING: potential quadratic expansion - . ,(cddr t))] + `(pattern-substitute + (,(if s-exp? 'quote 'quote-syntax) + ,(let ([v (cons (cadadr h) (cadadr t))]) + (if (syntax? stx) + (datum->syntax stx + v + stx + stx + stx) + v))) + ,@(cddr h) ;; <-- WARNING: potential quadratic expansion + . ,(cddr t))] [else ;; General case: add a substitution: (let* ([id (sub-gensym)] @@ -811,34 +831,54 @@ stx) expr)]) `(pattern-substitute - (quote-syntax ,expr) + (,(if s-exp? 'quote 'quote-syntax) ,expr) ,id ,h . ,(cddr t)))])] - [(eq? t 'null) - (apply-cons stx h - `(pattern-substitute (quote-syntax ())) - p - sub-gensym)] - - [(and (pair? t) - (eq? (car t) 'quote-syntax) - (stx-smaller-than? (cdr t) 10)) - ;; Shift into `pattern-substitute' mode with an intitial constant. - ;; (Only do this for small constants, so we don't traverse - ;; big constants when looking for substitutions.) - (apply-cons stx h - `(pattern-substitute ,t) - p - sub-gensym)] + [(not s-exp?) + (cond + [(eq? t 'null) + (apply-cons stx h + `(pattern-substitute (quote-syntax ())) + p + sub-gensym + s-exp?)] + + [(and (pair? t) + (eq? (car t) 'quote-syntax) + (stx-smaller-than? (cdr t) 10)) + ;; Shift into `pattern-substitute' mode with an intitial constant. + ;; (Only do this for small constants, so we don't traverse + ;; big constants when looking for substitutions.) + (apply-cons stx h + `(pattern-substitute ,t) + p + sub-gensym + s-exp?)] + [else + ;; Shift into `pattern-substitute' with an initial substitution: + (apply-cons stx h + (let ([id (sub-gensym)]) + `(pattern-substitute (quote-syntax ,id) + ,id ,t)) + p + sub-gensym + s-exp?)])] [else - ;; Shift into `pattern-substitute' with an initial substitution: - (apply-cons stx h - (let ([id (sub-gensym)]) - `(pattern-substitute (quote-syntax ,id) - ,id ,t)) - p - sub-gensym)])) - + ;; In S-expression mode, `cons' on, but collapse to `list' + ;; or `list*' if possible: + (cond + [(eq? t 'null) + (list 'list h)] + [(and (pair? t) + (eq? (car t) 'list)) + (list* 'list h (cdr t))] + [(and (pair? t) + (or (eq? (car t) 'list*) + (eq? (car t) 'cons))) + (list* 'list* h (cdr t))] + [else + (list 'cons h t)])])) + (-define (stx-smaller-than? stx sz) (sz . > . (stx-size stx (add1 sz)))) @@ -1022,22 +1062,23 @@ (not (...? stx))] [else #t])) + (-define (raise-pattern-error self stx) + (if (identifier? stx) + (raise-syntax-error + #f + "pattern variable cannot be used outside of a template" + stx) + (raise-syntax-error + #f + "pattern variable cannot be used outside of a template" + stx + (if (free-identifier=? (quote-syntax set!) (stx-car stx)) + (stx-car (stx-cdr stx)) + (stx-car stx))))) + ;; Structure for communicating first-order pattern variable information: (define-values (struct:syntax-mapping -make-syntax-mapping -syntax-mapping? syntax-mapping-ref syntax-mapping-set!) - (make-struct-type 'syntax-mapping #f 2 0 #f null (current-inspector) - (lambda (self stx) - (if (identifier? stx) - (raise-syntax-error - #f - "pattern variable cannot be used outside of a template" - stx) - (raise-syntax-error - #f - "pattern variable cannot be used outside of a template" - stx - (if (free-identifier=? (quote-syntax set!) (stx-car stx)) - (stx-car (stx-cdr stx)) - (stx-car stx))))))) + (make-struct-type 'syntax-mapping #f 2 0 #f null (current-inspector) raise-pattern-error)) (-define (make-syntax-mapping depth valvar) (make-set!-transformer (-make-syntax-mapping depth valvar))) (-define (syntax-pattern-variable? v) @@ -1048,8 +1089,23 @@ (-define (syntax-mapping-valvar v) (syntax-mapping-ref (set!-transformer-procedure v) 1)) + ;; Ditto for S-expression patterns: + (define-values (struct:s-exp-mapping -make-s-exp-mapping -s-exp-mapping? s-exp-mapping-ref s-exp-mapping-set!) + (make-struct-type 's-exp-mapping #f 2 0 #f null (current-inspector) raise-pattern-error)) + (-define (make-s-exp-mapping depth valvar) + (make-set!-transformer (-make-s-exp-mapping depth valvar))) + (-define (s-exp-pattern-variable? v) + (and (set!-transformer? v) + (-s-exp-mapping? (set!-transformer-procedure v)))) + (-define (s-exp-mapping-depth v) + (s-exp-mapping-ref (set!-transformer-procedure v) 0)) + (-define (s-exp-mapping-valvar v) + (s-exp-mapping-ref (set!-transformer-procedure v) 1)) + (#%provide (protect make-match&env get-match-vars make-interp-match make-pexpand make-syntax-mapping syntax-pattern-variable? syntax-mapping-depth syntax-mapping-valvar + make-s-exp-mapping s-exp-pattern-variable? + s-exp-mapping-depth s-exp-mapping-valvar stx-memq-pos no-ellipses?))) diff --git a/collects/racket/private/stxcase-scheme.rkt b/collects/racket/private/stxcase-scheme.rkt index a3b707b91c..4cfef0d214 100644 --- a/collects/racket/private/stxcase-scheme.rkt +++ b/collects/racket/private/stxcase-scheme.rkt @@ -40,26 +40,26 @@ ;; From Dybvig, mostly: (-define-syntax syntax-rules (lambda (stx) - (syntax-case** syntax-rules #t stx () free-identifier=? + (syntax-case** syntax-rules #t stx () free-identifier=? #f ((sr (k ...) ((keyword . pattern) template) ...) (andmap identifier? (syntax->list (syntax (k ...)))) (begin (check-sr-rules stx (syntax (keyword ...))) (syntax/loc stx (lambda (x) - (syntax-case** sr #t x (k ...) free-identifier=? + (syntax-case** sr #t x (k ...) free-identifier=? #f ((_ . pattern) (syntax-protect (syntax/loc x template))) ...)))))))) (-define-syntax syntax-id-rules (lambda (x) - (syntax-case** syntax-id-rules #t x () free-identifier=? + (syntax-case** syntax-id-rules #t x () free-identifier=? #f ((sidr (k ...) (pattern template) ...) (andmap identifier? (syntax->list (syntax (k ...)))) (syntax/loc x (make-set!-transformer (lambda (x) - (syntax-case** sidr #t x (k ...) free-identifier=? + (syntax-case** sidr #t x (k ...) free-identifier=? #f (pattern (syntax-protect (syntax/loc x template))) ...)))))))) @@ -68,7 +68,7 @@ (syntax-arm stx #f #t) (raise-type-error 'syntax-protect "syntax-object" stx))) - (#%provide syntax (all-from "with-stx.rkt") (all-from "stxloc.rkt") + (#%provide syntax datum (all-from "with-stx.rkt") (all-from "stxloc.rkt") check-duplicate-identifier syntax-protect syntax-rules syntax-id-rules (for-syntax syntax-pattern-variable?))) diff --git a/collects/racket/private/stxcase.rkt b/collects/racket/private/stxcase.rkt index a28badd36c..21683e867e 100644 --- a/collects/racket/private/stxcase.rkt +++ b/collects/racket/private/stxcase.rkt @@ -134,22 +134,34 @@ (-define interp-match (lambda (pat e literals immediate=?) + (interp-gen-match pat e literals immediate=? #f))) + + (-define interp-s-match + (lambda (pat e literals immediate=?) + (interp-gen-match pat e literals immediate=? #t))) + + (-define interp-gen-match + (lambda (pat e literals immediate=? s-exp?) (let loop ([pat pat][e e][cap e]) (cond [(null? pat) - (stx-null? e)] + (if s-exp? + (null? e) + (stx-null? e))] [(number? pat) - (and (identifier? e) - (immediate=? e (vector-ref (syntax-e literals) pat)))] + (and (if s-exp? (symbol? e) (identifier? e)) + (immediate=? e (vector-ref (if s-exp? literals (syntax-e literals)) pat)))] [(not pat) #t] [else (let ([i (vector-ref pat 0)]) (cond [(eq? i 'bind) - (let ([e (if (vector-ref pat 2) - (datum->syntax cap e cap) - e)]) + (let ([e (if s-exp? + e + (if (vector-ref pat 2) + (datum->syntax cap e cap) + e))]) (if (vector-ref pat 1) e (list e)))] @@ -170,23 +182,29 @@ h) t))))))))] [(eq? i 'quote) - (and (syntax? e) - (equal? (vector-ref pat 1) (syntax-e e)) - null)] + (if s-exp? + (and (equal? (vector-ref pat 1) e) + null) + (and (syntax? e) + (equal? (vector-ref pat 1) (syntax-e e)) + null))] [(eq? i 'ellipses) (let ([match-head (vector-ref pat 1)] [nest-cnt (vector-ref pat 2)] [last? (vector-ref pat 3)]) - (and (stx-list? e) + (and (if s-exp? + (list? e) + (stx-list? e)) (if (zero? nest-cnt) - (andmap (lambda (e) (loop match-head e cap)) (stx->list e)) + (andmap (lambda (e) (loop match-head e cap)) + (if s-exp? e (stx->list e))) (let/ec esc (let ([l (map (lambda (e) (let ([m (loop match-head e cap)]) (if m m (esc #f)))) - (stx->list e))]) + (if s-exp? e (stx->list e)))]) (if (null? l) (let loop ([cnt nest-cnt]) (cond @@ -214,10 +232,14 @@ t) h))))))))] [(eq? i 'veclist) - (and (stx-vector? e #f) - (loop (vector-ref pat 1) (vector->list (syntax-e e)) cap))] + (and (if s-exp? + (vector? e) + (stx-vector? e #f)) + (loop (vector-ref pat 1) (vector->list (if s-exp? e (syntax-e e))) cap))] [(eq? i 'vector) - (and (stx-vector? e (vector-ref pat 1)) + (and (if s-exp? + (and (vector? e) (= (vector-length e) (vector-ref pat 1))) + (stx-vector? e (vector-ref pat 1))) (let vloop ([p (vector-ref pat 2)][pos 0]) (cond [(null? p) null] @@ -225,7 +247,7 @@ (let ([clause (car p)]) (let ([match-elem (car clause)] [elem-did-var? (cdr clause)]) - (let ([m (loop match-elem (stx-vector-ref e pos) cap)]) + (let ([m (loop match-elem (if s-exp? (vector-ref e pos) (stx-vector-ref e pos)) cap)]) (and m (let ([body (vloop (cdr p) (add1 pos))]) (and body @@ -235,8 +257,10 @@ (append m body)) body)))))))])))] [(eq? i 'prefab) - (and (stx-prefab? (vector-ref pat 1) e) - (loop (vector-ref pat 2) (cdr (vector->list (struct->vector (syntax-e e)))) cap))] + (and (if s-exp? + (equal? (vector-ref pat 1) (prefab-struct-key e)) + (stx-prefab? (vector-ref pat 1) e)) + (loop (vector-ref pat 2) (cdr (vector->list (struct->vector (if s-exp? e (syntax-e e))))) cap))] [else (error "yikes!" pat)]))])))) (-define-syntax syntax-case** @@ -253,7 +277,8 @@ [expr (caddr l)] [kws (cadddr l)] [lit-comp (cadddr (cdr l))] - [clauses (cddddr (cdr l))]) + [s-exp? (syntax-e (cadddr (cddr l)))] + [clauses (cddddr (cddr l))]) (unless (stx-list? kws) (raise-syntax-error (syntax-e who) @@ -300,7 +325,7 @@ (syntax-arm (datum->syntax (quote-syntax here) - (list (quote-syntax let) (list (list arg (if (syntax-e arg-is-stx?) + (list (quote-syntax let) (list (list arg (if (or s-exp? (syntax-e arg-is-stx?)) expr (list (quote-syntax datum->syntax) (list @@ -348,7 +373,8 @@ pattern pattern (stx->list kws) - (not lit-comp-is-mod?))] + (not lit-comp-is-mod?) + s-exp?)] [cant-fail? (if lit-comp-is-mod? (equal? mtch '(lambda (e) e)) (equal? mtch '(lambda (e free-identifier=?) e)))] @@ -366,15 +392,16 @@ [else (sub1 fuel)]))))] [mtch (if interp? (let ([interp-box (box null)]) - (let ([pat (make-interp-match pattern (syntax->list kws) interp-box)]) + (let ([pat (make-interp-match pattern (syntax->list kws) interp-box s-exp?)]) (list 'lambda '(e) - (list 'interp-match + (list (if s-exp? 'interp-s-match 'interp-match) (list 'quote pat) 'e (if (null? (unbox interp-box)) #f - (list 'quote-syntax (list->vector (reverse (unbox interp-box))))) + (list (if s-exp? 'quote 'quote-syntax) + (list->vector (reverse (unbox interp-box))))) lit-comp)))) mtch)] [m @@ -436,7 +463,9 @@ (map (lambda (pattern-var unflat-pattern-var temp-var) (list (list pattern-var) (list - (quote-syntax make-syntax-mapping) + (if s-exp? + (quote-syntax make-s-exp-mapping) + (quote-syntax make-syntax-mapping)) ;; Tell it the shape of the variable: (let loop ([var unflat-pattern-var][d 0]) (if (syntax? var) @@ -469,8 +498,9 @@ m))))]))) x))))))) - (-define-syntax syntax - (lambda (x) + (begin-for-syntax + (define-values (gen-template) + (lambda (x s-exp?) (-define here-stx (quote-syntax here)) (unless (and (stx-pair? x) (let ([rest (stx-cdr x)]) @@ -484,19 +514,24 @@ (datum->syntax here-stx (let ([pattern (stx-car (stx-cdr x))]) - (let-values ([(unique-vars all-varss) (make-pexpand pattern #f null #f)]) + (let-values ([(unique-vars all-varss) (make-pexpand pattern #f null #f s-exp?)]) (let ([var-bindings (map (lambda (var) (and (let ([v (syntax-local-value var (lambda () #f))]) - (and (syntax-pattern-variable? v) + (and (if s-exp? + (s-exp-pattern-variable? v) + (syntax-pattern-variable? v)) v)))) unique-vars)]) (if (and (or (null? var-bindings) (not (ormap (lambda (x) x) var-bindings))) (no-ellipses? pattern)) ;; Constant template: - (list (quote-syntax quote-syntax) pattern) + (list (if s-exp? + (quote-syntax quote) + (quote-syntax quote-syntax)) + pattern) ;; Non-constant: (let ([proto-r (let loop ([vars unique-vars][bindings var-bindings]) (if (null? bindings) @@ -505,7 +540,9 @@ (cdr bindings))]) (if (car bindings) (cons (let loop ([v (car vars)] - [d (syntax-mapping-depth (car bindings))]) + [d (if s-exp? + (s-exp-mapping-depth (car bindings)) + (syntax-mapping-depth (car bindings)))]) (if (zero? d) v (loop (list v) (sub1 d)))) @@ -522,14 +559,16 @@ (let ([build-from-template ;; Even if we don't use the builder, we need to check ;; for a well-formed pattern: - (make-pexpand pattern proto-r non-pattern-vars pattern)] + (make-pexpand pattern proto-r non-pattern-vars pattern s-exp?)] [r (let loop ([vars unique-vars][bindings var-bindings][all-varss all-varss]) (cond [(null? bindings) null] [(car bindings) (cons (syntax-property - (let ([id (syntax-mapping-valvar (car bindings))]) + (let ([id (if s-exp? + (s-exp-mapping-valvar (car bindings)) + (syntax-mapping-valvar (car bindings)))]) (datum->syntax id (syntax-e id) @@ -552,7 +591,10 @@ [(= len 1) (car r)] [else (cons (quote-syntax list*) r)])))))))))) - x)))) + x))))) - (#%provide (all-from "ellipses.rkt") syntax-case** syntax + (-define-syntax syntax (lambda (stx) (gen-template stx #f))) + (-define-syntax datum (lambda (stx) (gen-template stx #t))) + + (#%provide (all-from "ellipses.rkt") syntax-case** syntax datum (for-syntax syntax-pattern-variable?))) diff --git a/collects/racket/private/stxloc.rkt b/collects/racket/private/stxloc.rkt index 54ce3cdd6b..1356fbf00c 100644 --- a/collects/racket/private/stxloc.rkt +++ b/collects/racket/private/stxloc.rkt @@ -6,19 +6,26 @@ (#%require "qq-and-or.rkt" "stxcase.rkt" "define-et-al.rkt" (for-syntax '#%kernel "stxcase.rkt" "sc.rkt")) - ;; Regular syntax-case + ;; Like regular syntax-case, but with free-identifier=? replacement (-define-syntax syntax-case* (lambda (stx) - (syntax-case** #f #t stx () free-identifier=? + (syntax-case** #f #t stx () free-identifier=? #f [(sc stxe kl id=? clause ...) - (syntax (syntax-case** sc #f stxe kl id=? clause ...))]))) + (syntax (syntax-case** sc #f stxe kl id=? #f clause ...))]))) ;; Regular syntax-case (-define-syntax syntax-case (lambda (stx) - (syntax-case** #f #t stx () free-identifier=? + (syntax-case** #f #t stx () free-identifier=? #f [(sc stxe kl clause ...) - (syntax (syntax-case** sc #f stxe kl free-identifier=? clause ...))]))) + (syntax (syntax-case** sc #f stxe kl free-identifier=? #f clause ...))]))) + + ;; Like `syntax-case, but on plain datums + (-define-syntax datum-case + (lambda (stx) + (syntax-case** #f #t stx () free-identifier=? #f + [(sc stxe kl clause ...) + (syntax (syntax-case** sc #f stxe kl eq? #t clause ...))]))) (-define (relocate loc stx) (if (or (syntax-source loc) @@ -34,7 +41,7 @@ ;; resulting syntax object. (-define-syntax syntax/loc (lambda (stx) - (syntax-case** #f #t stx () free-identifier=? + (syntax-case** #f #t stx () free-identifier=? #f [(_ loc pattern) (if (if (symbol? (syntax-e #'pattern)) (syntax-pattern-variable? (syntax-local-value #'pattern (lambda () #f))) @@ -44,7 +51,7 @@ (-define-syntax quote-syntax/prune (lambda (stx) - (syntax-case** #f #t stx () free-identifier=? + (syntax-case** #f #t stx () free-identifier=? #f [(_ id) (if (symbol? (syntax-e #'id)) (datum->syntax #'here @@ -62,4 +69,4 @@ stx #'id))]))) - (#%provide syntax/loc quote-syntax/prune syntax-case* syntax-case ... _)) + (#%provide syntax/loc quote-syntax/prune syntax-case* syntax-case datum-case ... _)) diff --git a/collects/racket/private/with-stx.rkt b/collects/racket/private/with-stx.rkt index ff29e192cc..8b75c9dbe6 100644 --- a/collects/racket/private/with-stx.rkt +++ b/collects/racket/private/with-stx.rkt @@ -12,48 +12,60 @@ "binding match failed" stx)) + (-define (with-datum-fail stx) + (raise-syntax-error + 'with-datum + "binding match failed" + stx)) + ;; Partly from Dybvig - (-define-syntax with-syntax - (let ([here-stx (quote-syntax here)]) - (lambda (x) - (syntax-case x () - ((_ () e1 e2 ...) - (syntax/loc x (begin e1 e2 ...))) - ((_ ((out in) ...) e1 e2 ...) - (let ([ins (syntax->list (syntax (in ...)))]) - ;; Check for duplicates or other syntax errors: - (get-match-vars (syntax _) x (syntax (out ...)) null) - ;; Generate temps and contexts: - (let ([tmps (map (lambda (x) (gen-temp-id 'ws)) ins)] - [heres (map (lambda (x) - (datum->syntax - x - 'here - x)) - ins)] - [outs (syntax->list (syntax (out ...)))]) - ;; Let-bind RHSs, then build up nested syntax-cases: - (datum->syntax - here-stx - `(let ,(map (lambda (tmp here in) - `[,tmp (datum->syntax - (quote-syntax ,here) - ,in)]) - tmps heres ins) - ,(let loop ([tmps tmps][outs outs]) - (cond - [(null? tmps) - (syntax (begin e1 e2 ...))] - [else `(syntax-case** #f #t ,(car tmps) () free-identifier=? - [,(car outs) ,(loop (cdr tmps) - (cdr outs))] - [_ (with-syntax-fail - ;; Minimize the syntax structure we keep: - (quote-syntax ,(datum->syntax - #f - (syntax->datum (car outs)) - (car outs))))])]))) - x)))))))) + (begin-for-syntax + (define-values (gen-with-syntax) + (let ([here-stx (quote-syntax here)]) + (lambda (x s-exp?) + (syntax-case x () + ((_ () e1 e2 ...) + (syntax/loc x (begin e1 e2 ...))) + ((_ ((out in) ...) e1 e2 ...) + (let ([ins (syntax->list (syntax (in ...)))]) + ;; Check for duplicates or other syntax errors: + (get-match-vars (syntax _) x (syntax (out ...)) null) + ;; Generate temps and contexts: + (let ([tmps (map (lambda (x) (gen-temp-id 'ws)) ins)] + [heres (map (lambda (x) + (datum->syntax + x + 'here + x)) + ins)] + [outs (syntax->list (syntax (out ...)))]) + ;; Let-bind RHSs, then build up nested syntax-cases: + (datum->syntax + here-stx + `(let ,(map (lambda (tmp here in) + `[,tmp ,(if s-exp? + in + `(datum->syntax + (quote-syntax ,here) + ,in))]) + tmps heres ins) + ,(let loop ([tmps tmps][outs outs]) + (cond + [(null? tmps) + (syntax (begin e1 e2 ...))] + [else `(syntax-case** #f #t ,(car tmps) () ,(if s-exp? 'eq? 'free-identifier=?) ,s-exp? + [,(car outs) ,(loop (cdr tmps) + (cdr outs))] + [_ (,(if s-exp? 'with-datum-fail 'with-syntax-fail) + ;; Minimize the syntax structure we keep: + (quote-syntax ,(datum->syntax + #f + (syntax->datum (car outs)) + (car outs))))])]))) + x))))))))) + + (-define-syntax with-syntax (lambda (stx) (gen-with-syntax stx #f))) + (-define-syntax with-datum (lambda (stx) (gen-with-syntax stx #t))) (-define counter 0) (-define (append-number s) @@ -84,4 +96,4 @@ (datum->syntax #f (append-number 'temp))]))) l))) - (#%provide with-syntax generate-temporaries)) + (#%provide with-syntax with-datum generate-temporaries)) diff --git a/collects/redex/private/term.rkt b/collects/redex/private/term.rkt index b6e6f0602c..235377319a 100644 --- a/collects/redex/private/term.rkt +++ b/collects/redex/private/term.rkt @@ -5,6 +5,7 @@ syntax/boundmap syntax/parse racket/syntax) + syntax/datum "error.rkt" "matcher.rkt") @@ -36,7 +37,7 @@ (let-values ([(rewritten max-depth) (rewrite/max-depth args depth)]) (let ([result-id (car (generate-temporaries '(f-results)))]) (with-syntax ([fn fn]) - (let loop ([func (syntax (λ (x) (fn (syntax->datum x))))] + (let loop ([func (syntax (λ (x) (fn x)))] [args-stx rewritten] [res result-id] [args-depth (min depth max-depth)]) @@ -46,10 +47,10 @@ (if (zero? args-depth) (begin (set! outer-bindings - (cons (syntax [res (func (quasisyntax args))]) + (cons (syntax [res (func (quasidatum args))]) outer-bindings)) (values result-id (min depth max-depth))) - (loop (syntax (λ (l) (map func (syntax->list l)))) + (loop (syntax (λ (l) (map func l))) (syntax/loc args-stx (args (... ...))) (syntax (res (... ...))) (sub1 args-depth))))))))) @@ -82,18 +83,18 @@ #,ref)]) (values #'#,v 0)))] [(unquote x) - (values (syntax (unsyntax x)) 0)] + (values (syntax (undatum x)) 0)] [(unquote . x) (raise-syntax-error 'term "malformed unquote" orig-stx stx)] [(unquote-splicing x) - (values (syntax (unsyntax-splicing x)) 0)] + (values (syntax (undatum-splicing x)) 0)] [(unquote-splicing . x) (raise-syntax-error 'term "malformed unquote splicing" orig-stx stx)] [(in-hole id body) (rewrite-application (syntax (λ (x) (apply plug x))) (syntax/loc stx (id body)) depth)] [(in-hole . x) (raise-syntax-error 'term "malformed in-hole" orig-stx stx)] - [hole (values (syntax (unsyntax the-hole)) 0)] + [hole (values (syntax (undatum the-hole)) 0)] [() (values stx 0)] @@ -130,10 +131,10 @@ (λ (f _) (defined-check f "metafunction"))) #,(let loop ([bs (reverse outer-bindings)]) (cond - [(null? bs) (syntax (syntax->datum (quasisyntax rewritten)))] + [(null? bs) (syntax (quasidatum rewritten))] [else (with-syntax ([rec (loop (cdr bs))] [fst (car bs)]) - (syntax (with-syntax (fst) + (syntax (with-datum (fst) rec)))])))))])) (define-syntax (term-let-fn stx) @@ -200,9 +201,9 @@ [no-match (syntax/loc (syntax rhs1) (error 'error-name "term ~s does not match pattern ~s" rhs1 'x1))]) (syntax - (syntax-case rhs1 () + (datum-case rhs1 () [new-x1 - (let-syntax ([orig-names (make-term-id #'new-names (syntax-e #'depths))] ...) + (let-syntax ([orig-names (make-term-id #'new-names depths)] ...) (term-let/error-name error-name ((x rhs) ...) body1 body2 ...))] [_ no-match]))))] [(_ error-name () body1 body2 ...) @@ -227,4 +228,4 @@ (not-expression-context stx) #'(begin (define term-val (term t)) - (define-syntax x (defined-term #'term-val)))])) \ No newline at end of file + (define-syntax x (defined-term #'term-val)))])) diff --git a/collects/scheme/mzscheme.rkt b/collects/scheme/mzscheme.rkt index fe281c24d5..ab66de51d9 100644 --- a/collects/scheme/mzscheme.rkt +++ b/collects/scheme/mzscheme.rkt @@ -98,7 +98,7 @@ #%top-interaction map for-each andmap ormap assq assv assoc reverse memq memv member - (rename datum #%datum) + (rename old-datum #%datum) (rename mzscheme-in-stx-module-begin #%module-begin) (rename #%module-begin #%plain-module-begin) (rename lambda #%plain-lambda) diff --git a/collects/syntax/datum.rkt b/collects/syntax/datum.rkt new file mode 100644 index 0000000000..ce064f8b76 --- /dev/null +++ b/collects/syntax/datum.rkt @@ -0,0 +1,5 @@ +(module datum '#%kernel + (#%require racket/private/stxcase-scheme + racket/private/qqstx) + (#%provide datum datum-case with-datum + quasidatum undatum undatum-splicing)) diff --git a/collects/syntax/scribblings/datum.scrbl b/collects/syntax/scribblings/datum.scrbl new file mode 100644 index 0000000000..413beb3a48 --- /dev/null +++ b/collects/syntax/scribblings/datum.scrbl @@ -0,0 +1,84 @@ +#lang scribble/manual +@(require "common.rkt" + scribble/eval + (for-label racket/base + syntax/datum)) + +@(define datum-eval (make-base-eval)) +@interaction-eval[#:eval datum-eval (require syntax/datum)] + +@title{Datum Pattern Matching} + +@defmodule[syntax/datum]{The @racketmodname[syntax/datum] library +provides forms that implement the pattern and template language of +@racket[syntax-case], but for matching and constructing datum values +instead of syntax.} + +For most pattern-matching purposes, @racketmodname[racket/match] is a +better choice than @racketmodname[syntax/datum]. The +@racketmodname[syntax/datum] library is useful mainly for its template +support (i.e., @racket[datum]) and, to a lesser extent, its direct +correspondence to @racket[syntax-case] patterns. + + +@deftogether[( +@defform[(datum-case datum-expr (literal-id ...) + clause ...)] +@defform[(datum template)] +)]{ + +Like @racket[syntax-case] and @racket[syntax], but @racket[datum-expr] +in @racket[datum-case] should produce a @tech[#:doc refman]{datum} +(i.e., plain S-expression) instead of a @tech[#:doc refman]{syntax +object} to be matched in @racket[clause]s, and @racket[datum] +similarly produces a datum. Pattern variables bound in each +@racket[clause] of @racket[datum-case] are accessible via +@racket[datum] instead of @racket[syntax]. When a @racket[literal-id] +appears in a @racket[clause]'s pattern, it matches the corresponding +symbol (using @racket[eq?]). + + +Using @racket[datum-case] and @racket[datum] is essentially equivalent +to converting the input to @racket[syntax-case] using +@racket[datum->syntax] and then wrapping each use of @racket[syntax] +with @racket[syntax->datum], but @racket[datum-case] and +@racket[datum] to not create intermediate syntax objects. + +@examples[ +#:eval datum-eval +(datum-case '(1 "x" -> y) (->) + [(a ... -> b) (datum (b (+ a) ...))]) +]} + + +@defform[(with-datum ([pattern datum-expr] ...) + body ...+)]{ + +Analogous to @racket[with-syntax], but for @racket[datum-case] and +@racket[datum] instead of @racket[syntax-case] and @racket[syntax]. + +@examples[ +#:eval datum-eval +(with-datum ([(a ...) '(1 2 3)] + [(b ...) '("x" "y" "z")]) + (datum ((a b) ...))) +]} + + +@deftogether[( +@defform[(quasidatum template)] +@defform[(undatum expr)] +@defform[(undatum-splicing expr)] +)]{ + +Analogous to @racket[quasisyntax], @racket[unsyntax], and +@racket[unsyntax-splicing]. + +@examples[ +#:eval datum-eval +(with-datum ([(a ...) '(1 2 3)]) + (quasidatum ((undatum (- 1 1)) a ... (undatum (+ 2 2))))) +]} + + +@close-eval[datum-eval] diff --git a/collects/syntax/scribblings/syntax.scrbl b/collects/syntax/scribblings/syntax.scrbl index 1fbdee5c5f..61698b4f8d 100644 --- a/collects/syntax/scribblings/syntax.scrbl +++ b/collects/syntax/scribblings/syntax.scrbl @@ -5,14 +5,19 @@ @table-of-contents[] +@include-section["parse.scrbl"] + @include-section["syntax-object-helpers.scrbl"] +@include-section["datum.scrbl"] + @include-section["module-helpers.scrbl"] @include-section["transformer-helpers.scrbl"] @include-section["reader-helpers.scrbl"] +@include-section["srcloc.scrbl"] @include-section["toplevel.scrbl"] @@ -20,8 +25,4 @@ @include-section["docprovide.scrbl"] -@include-section["parse.scrbl"] - -@include-section["srcloc.scrbl"] - @index-section[] diff --git a/collects/tests/syntax/datum.rkt b/collects/tests/syntax/datum.rkt new file mode 100644 index 0000000000..4f4bfcba36 --- /dev/null +++ b/collects/tests/syntax/datum.rkt @@ -0,0 +1,57 @@ +#lang racket +(require syntax/datum) + +(define (do-test expect got expr) + (unless (equal? expect got) (error "failed\n" expr))) + + +(define-syntax test + (syntax-rules (datum-case datum) + [(_ expect (datum-case expr () [pat (datum tmpl)])) + (begin + (test expect (values (datum-case expr () [pat (datum tmpl)]))) + (test expect (with-datum ([pat expr]) (datum tmpl))))] + [(_ expect expr) + (do-test expect expr 'expr)])) + +(test '(3 2 1) + (datum-case '(1 2 3) () + [(a b c) (datum (c b a))])) + +(test '(3 1 2) + (datum-case '(1 2 3) () + [(a ... c) (datum (c a ...))])) + +(test '(3 1 2) + (datum-case '#(1 2 3) () + [#(a ... c) (datum (c a ...))])) + +(test '(3 2 1) + (datum-case '#(1 2 3) () + [#(a b c) (datum (c b a))])) + +(test '(3 2 1) + (datum-case '#s(q 1 2 3) () + [#s(q a b c) (datum (c b a))])) + +(test '(3 2 1) + (datum-case '(1 ! 2 % 3) (! %) + [(a ! b % c) (datum (c b a))])) + +(test '(3 2 1) + (datum-case '#(1 ! 2 % 3) (! %) + [#(a ! b % c) (datum (c b a))])) + +(test 'x + (datum x)) + +(test 'x + (quasidatum x)) +(test '(1 2 3) + (quasidatum (1 (undatum (+ 1 1)) 3))) +(test '#(1 2 3) + (quasidatum #(1 (undatum (+ 1 1)) 3))) +(test '(1 2 3) + (quasidatum (1 (undatum-splicing (list (+ 1 1) 3))))) +(test '(1 2 3 4) + (quasidatum (1 (undatum-splicing (list (+ 1 1) 3)) 4)))