suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Handle rename transformers better in match expanders.

Browse Source 
Closes PR 15223.

Merge to 6.4.
This commit is contained in:
Sam Tobin-Hochstadt 2016-01-16 12:58:21 -05:00
parent ea172ae459
commit e133d87765
2 changed files with 46 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
pkgs/racket-test/tests/match/examples.rkt
View File

@ -810,4 +810,21 @@
[_ 'no])
'yes))
(test-case "match-expander rename transformer"
(define-match-expander foo
(lambda (stx) (syntax-case stx () [(_ a) #'a]))
(make-rename-transformer #'values))
(check-equal? (foo 2) 2))
(test-case "match-expander rename transformer set!"
(define x 1)
(define-match-expander foo
(lambda (stx) (syntax-case stx () [(_ a) #'a]))
(make-rename-transformer #'x))
(set! foo 2)
(check-equal? x 2))
))

31
racket/collects/racket/match/match-expander.rkt
View File

@ -11,13 +11,30 @@
#:property prop:set!-transformer
(λ (me stx)
(define xf (match-expander-macro-xform me))
(if (set!-transformer? xf)
((set!-transformer-procedure xf) stx)
(syntax-case stx (set!)
[(set! . _)
(raise-syntax-error #f "cannot mutate syntax identifier" stx)]
[_ (xf stx)])))
#:property prop:match-expander (struct-field-index match-xform)
(define proc
(cond [(rename-transformer? xf)
(lambda (x)
(define target (rename-transformer-target xf))
(syntax-case stx (set!)
[(set! id args ...)
#`(set! #,target args ...)]
[(id args ...)
(datum->syntax stx
`(,target ,@(syntax->list #'(args ...)))
stx stx)]
[_ (rename-transformer-target xf)]))]
[(set!-transformer? xf) (set!-transformer-procedure xf)]
[(procedure? xf)
(lambda (stx)
(syntax-case stx (set!)
[(set! . _)
(raise-syntax-error #f "cannot mutate syntax identifier" stx)]
[_ (xf stx)]))]
[else (raise-syntax-error
#f
"not a procedure for match expander transformer" stx)]))
(proc stx))
#:property prop:match-expander (struct-field-index match-xform)
#:property prop:legacy-match-expander (struct-field-index legacy-xform))
(values make-match-expander))))