From acd6764019b24b09477fa84f79487a00f769d955 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 21 Mar 2013 08:50:03 -0600 Subject: [PATCH] support boxes in syntax patterns and templates Also, `datum-case' and `datum' from `syntax/datum'. --- collects/racket/private/sc.rkt | 24 +++++++++++++++++++ collects/racket/private/stx.rkt | 10 ++++++++ collects/racket/private/stxcase.rkt | 6 +++++ .../scribblings/reference/stx-patterns.scrbl | 13 ++++++++++ collects/tests/racket/stx.rktl | 6 +++++ collects/tests/syntax/datum.rkt | 12 ++++++++++ doc/release-notes/racket/HISTORY.txt | 2 ++ 7 files changed, 73 insertions(+) diff --git a/collects/racket/private/sc.rkt b/collects/racket/private/sc.rkt index 0312419b3a..578293e751 100644 --- a/collects/racket/private/sc.rkt +++ b/collects/racket/private/sc.rkt @@ -361,6 +361,20 @@ #f))) did-var? #f)))))] + [(stx-box? p) + (let*-values ([(content) (unbox (syntax-e p))] + [(match-content did-var? ) (m&e content content use-ellipses? last? #f)]) + (if just-vars? + (values match-content #f #f) + (values + (if interp-box + (vector 'box match-content) + `(lambda (e) + (if ,(if s-exp? '(box? e) '(stx-box? e)) + ,(app match-content `(unbox ,(if s-exp? 'e '(syntax-e e)))) + #f))) + did-var? + #f)))] [(and (syntax? p) (prefab-struct-key (syntax-e p))) => @@ -511,6 +525,7 @@ [(syntax? p) (loop (syntax-e p))] [(pair? p) (or (loop (car p)) (loop (cdr p)))] [(vector? p) (loop (vector->list p))] + [(box? p) (loop (unbox p))] [(struct? p) (loop (struct->vector p))] [else #f])) (pfx-loop (string-append "_" pfx)) @@ -665,6 +680,13 @@ (list->vector (,(if s-exp? 'values 'stx->list) ,(apply-to-r e)))) ;; variables were hashed (void)))] + [(stx-box? p) + (let ([e (expander (unbox (syntax-e p)) proto-r p use-ellipses? use-tail-pos hash! #t)]) + (if proto-r + `(lambda (r) + (box (,(if s-exp? 'values 'syntax-e) ,(apply-to-r e)))) + ;; variables were hashed + (void)))] [(and (syntax? p) (struct? (syntax-e p)) (prefab-struct-key (syntax-e p))) @@ -946,6 +968,8 @@ (list p))] [(stx-vector? p #f) (sub (vector->list (syntax-e p)) use-ellipses?)] + [(stx-box? p) + (sub (unbox (syntax-e p)) use-ellipses?)] [(and (syntax? p) (prefab-struct-key (syntax-e p))) (sub (cdr (vector->list (struct->vector (syntax-e p)))) use-ellipses?)] diff --git a/collects/racket/private/stx.rkt b/collects/racket/private/stx.rkt index 2835562c66..e0d4d694ee 100644 --- a/collects/racket/private/stx.rkt +++ b/collects/racket/private/stx.rkt @@ -122,6 +122,15 @@ (lambda (p pos) (vector-ref (syntax-e p) pos))) + ;; a syntax box? + (define-values (stx-box?) + (lambda (p) + (if (syntax? p) + (if (box? (syntax-e p)) + #t + #f) + #f))) + (define-values (stx-prefab?) (lambda (key v) (if (syntax? v) @@ -203,6 +212,7 @@ (#%provide identifier? stx-null? stx-null/#f stx-pair? stx-list? stx-car stx-cdr stx->list stx-vector? stx-vector-ref + stx-box? stx-prefab? stx-check/esc cons/#f append/#f stx-rotate stx-rotate* diff --git a/collects/racket/private/stxcase.rkt b/collects/racket/private/stxcase.rkt index 6b494e3e54..bb09893170 100644 --- a/collects/racket/private/stxcase.rkt +++ b/collects/racket/private/stxcase.rkt @@ -256,6 +256,12 @@ m (append m body)) body)))))))])))] + [(eq? i 'box) + (let ([match-content (vector-ref pat 1)]) + (and (if s-exp? + (box? e) + (stx-box? e)) + (loop match-content (unbox (if s-exp? e (syntax-e e))) cap)))] [(eq? i 'prefab) (and (if s-exp? (equal? (vector-ref pat 1) (prefab-struct-key e)) diff --git a/collects/scribblings/reference/stx-patterns.scrbl b/collects/scribblings/reference/stx-patterns.scrbl index 209961b7f1..3cff610b59 100644 --- a/collects/scribblings/reference/stx-patterns.scrbl +++ b/collects/scribblings/reference/stx-patterns.scrbl @@ -23,6 +23,7 @@ (pattern ... pattern ellipsis pattern ... . pattern) (code:line #,(tt "#")(pattern ...)) (code:line #,(tt "#")(pattern ... pattern ellipsis pattern ...)) + (code:line #,(tt "#&")pattern) (code:line #,(tt "#s")(key-datum pattern ...)) (code:line #,(tt "#s")(key-datum pattern ... pattern ellipsis pattern ...)) (ellipsis stat-pattern) @@ -128,6 +129,11 @@ A syntax object matches a @racket[pattern] as follows: but matching a vector syntax object whose elements match the corresponding sub-@racket[pattern]s.} + @specsubform[(code:line #,(tt "#&")pattern)]{ + + Matches a box syntax object whose content matches the + @racket[pattern].} + @specsubform[(code:line #,(tt "#s")(key-datum pattern ...))]{ Like a @racket[(pattern ...)] pattern, but matching a @tech{prefab} @@ -265,6 +271,7 @@ the individual @racket[stx-expr]. (template-elem ...) (template-elem ...+ . template) (code:line #,(tt "#")(template-elem ...)) + (code:line #,(tt "#&")template) (code:line #,(tt "#s")(key-datum template-elem ...)) (ellipsis stat-template) const] @@ -273,6 +280,7 @@ the individual @racket[stx-expr]. (stat-template ...) (stat-template ... . stat-template) (code:line #,(tt "#")(stat-template ...)) + (code:line #,(tt "#&")stat-template) (code:line #,(tt "#s")(key-datum stat-template ...)) const] [ellipsis #,lit-ellipsis])]{ @@ -352,6 +360,11 @@ Template forms produce a syntax object as follows: Like the @racket[(template-elem ...)] form, but producing a syntax object whose datum is a vector instead of a list.} + @specsubform[(code:line #,(tt "#&")template)]{ + + Produces a syntax object whose datum is a box holding the + syntax object produced by @racket[template].} + @specsubform[(code:line #,(tt "#s")(key-datum template-elem ...))]{ Like the @racket[(template-elem ...)] form, but producing a syntax diff --git a/collects/tests/racket/stx.rktl b/collects/tests/racket/stx.rktl index 918a65436c..d093f4f669 100644 --- a/collects/tests/racket/stx.rktl +++ b/collects/tests/racket/stx.rktl @@ -136,6 +136,12 @@ ((ull (+ nn mm) ((- n m) (- p q))) (ull (+ pp qq) ((- nn mm) (- pp qq)))))) +(test 5 syntax-e (syntax-case #'#&5 () + [#&x #'x])) +(test '(0 1 2 3 4) syntax->datum + (syntax-case #'#&(1 2 3) () + [#&(x ...) #'(0 x ... 4)])) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Test basic expansion and property propagation ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/collects/tests/syntax/datum.rkt b/collects/tests/syntax/datum.rkt index 4f4bfcba36..1f21a6aa16 100644 --- a/collects/tests/syntax/datum.rkt +++ b/collects/tests/syntax/datum.rkt @@ -30,6 +30,18 @@ (datum-case '#(1 2 3) () [#(a b c) (datum (c b a))])) +(test 5 + (datum-case '#&5 () + [#&x (datum x)])) + +(test '(3 2 1) + (datum-case '#&(1 2 3) () + [#&(a b c) (datum (c b a))])) + +(test '(5) + (datum-case '#&((((5)))) () + [#&((((x)))) (datum (x))])) + (test '(3 2 1) (datum-case '#s(q 1 2 3) () [#s(q a b c) (datum (c b a))])) diff --git a/doc/release-notes/racket/HISTORY.txt b/doc/release-notes/racket/HISTORY.txt index 567263a86c..55b99a2252 100644 --- a/doc/release-notes/racket/HISTORY.txt +++ b/doc/release-notes/racket/HISTORY.txt @@ -1,11 +1,13 @@ Version 5.3.3.7 Added module-compiled-cross-phase-persistent? Added 'so-mode mode for system-type +Changed syntax-case, etc. to support box patterns ffi/unsafe: changed ffi-lib to use (system-type 'so-mode) slideshow/balloon: added balloon-enable-3d slideshow: added interactive scribble/manual: added #:id option to defthing scribble/srcdoc: added begin-for-doc +syntax/datum: Changed datum-case to support box patterns syntax-color: added special support for dont-stop values; this change is backwards incompatible for code that calls lexers and may call unknown lexers