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

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

@ -736,12 +736,12 @@
(failure-cont) (failure-cont)
0)] 0)]
[_ 1])) [_ 1]))
(comp 0 (comp 0
(match (cons 1 2) (match (cons 1 2)
[(cons a b) #:when (= a b) 1] [(cons a b) #:when (= a b) 1]
[_ 0])) [_ 0]))
(comp 1 (comp 1
(match (cons 1 1) (match (cons 1 1)
[(cons a b) #:when (= a b) 1] [(cons a b) #:when (= a b) 1]
@ -772,7 +772,7 @@
[`(,(? L4e?) ...) #t] [`(,(? L4e?) ...) #t]
[(? L3v?) #t] [(? L3v?) #t]
[_ #f])) [_ #f]))
(define (is-biop? sym) (or (is-aop? sym) (is-cmp? sym))) (define (is-biop? sym) (or (is-aop? sym) (is-cmp? sym)))
(define (is-aop? sym) (memq sym '(+ - *))) (define (is-aop? sym) (memq sym '(+ - *)))
(define (is-cmp? sym) (memq sym '(< <= =))) (define (is-cmp? sym) (memq sym '(< <= =)))
@ -794,7 +794,7 @@
(apply max (hash-values ht))))) (apply max (hash-values ht)))))
(check-true (car v)) (check-true (car v))
(check < (cadr v) 50)) (check < (cadr v) 50))
(test-case "syntax-local-match-introduce" (test-case "syntax-local-match-introduce"
(define-match-expander foo (define-match-expander foo
(lambda (stx) (syntax-local-match-introduce #'x))) (lambda (stx) (syntax-local-match-introduce #'x)))
@ -809,5 +809,22 @@
[(and x (? (λ _ (set-box! b #f))) (app unbox #f)) 'yes] [(and x (? (λ _ (set-box! b #f))) (app unbox #f)) 'yes]
[_ 'no]) [_ 'no])
'yes)) '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 #:property prop:set!-transformer
(λ (me stx) (λ (me stx)
(define xf (match-expander-macro-xform me)) (define xf (match-expander-macro-xform me))
(if (set!-transformer? xf) (define proc
((set!-transformer-procedure xf) stx) (cond [(rename-transformer? xf)
(syntax-case stx (set!) (lambda (x)
[(set! . _) (define target (rename-transformer-target xf))
(raise-syntax-error #f "cannot mutate syntax identifier" stx)] (syntax-case stx (set!)
[_ (xf stx)]))) [(set! id args ...)
#:property prop:match-expander (struct-field-index match-xform) #`(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)) #:property prop:legacy-match-expander (struct-field-index legacy-xform))
(values make-match-expander)))) (values make-match-expander))))