From e133d87765ecf5c77d700bec43f70777cbfe8f78 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@ccs.neu.edu>
Date: Sat, 16 Jan 2016 12:58:21 -0500
Subject: [PATCH] Handle rename transformers better in match expanders.

Closes PR 15223.

Merge to 6.4.
---
 pkgs/racket-test/tests/match/examples.rkt     | 27 +++++++++++++---
 .../collects/racket/match/match-expander.rkt  | 31 ++++++++++++++-----
 2 files changed, 46 insertions(+), 12 deletions(-)

diff --git a/pkgs/racket-test/tests/match/examples.rkt b/pkgs/racket-test/tests/match/examples.rkt
index 22cbee956e..d5eff15695 100644
--- a/pkgs/racket-test/tests/match/examples.rkt
+++ b/pkgs/racket-test/tests/match/examples.rkt
@@ -736,12 +736,12 @@
                 (failure-cont)
                 0)]
            [_ 1]))
-   
+
    (comp 0
          (match (cons 1 2)
            [(cons a b) #:when (= a b) 1]
            [_ 0]))
-   
+
    (comp 1
          (match (cons 1 1)
            [(cons a b) #:when (= a b) 1]
@@ -772,7 +772,7 @@
             [`(,(? L4e?) ...) #t]
             [(? L3v?) #t]
             [_ #f]))
-        
+
         (define (is-biop? sym) (or (is-aop? sym) (is-cmp? sym)))
         (define (is-aop? sym) (memq sym '(+ - *)))
         (define (is-cmp? sym) (memq sym '(< <= =)))
@@ -794,7 +794,7 @@
          (apply max (hash-values ht)))))
     (check-true (car v))
     (check < (cadr v) 50))
-   
+
    (test-case "syntax-local-match-introduce"
      (define-match-expander foo
        (lambda (stx) (syntax-local-match-introduce #'x)))
@@ -809,5 +809,22 @@
         [(and x (? (λ _ (set-box! b #f))) (app unbox #f)) 'yes]
         [_ '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))
+
+
 ))
diff --git a/racket/collects/racket/match/match-expander.rkt b/racket/collects/racket/match/match-expander.rkt
index c40632dd9a..60a9b8730d 100644
--- a/racket/collects/racket/match/match-expander.rkt
+++ b/racket/collects/racket/match/match-expander.rkt
@@ -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))))