Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

support boxes in syntax patterns and templates

Also, `datum-case' and `datum' from `syntax/datum'.
  • Loading branch information...
commit acd6764019b24b09477fa84f79487a00f769d955 1 parent 899c742
@mflatt mflatt authored
View
24 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? <false>) (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?)]
View
10 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*
View
6 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))
View
13 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
View
6 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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
View
12 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))]))
View
2  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

0 comments on commit acd6764

Please sign in to comment.
Something went wrong with that request. Please try again.