From 0b045ba77b3095f53a7f4e1deb5c82b9232e17f1 Mon Sep 17 00:00:00 2001
From: AlexKnauth <alexander@knauth.org>
Date: Wed, 13 Aug 2014 16:10:16 -0400
Subject: [PATCH] Add syntax-local-match-introduce

---
 .../scribblings/reference/match.scrbl         |  4 ++++
 .../racket-test/tests/match/examples.rkt      | 11 ++++++++--
 pkgs/unstable-2d/unstable/2d/match.rkt        |  2 +-
 racket/collects/racket/match/match.rkt        |  4 +++-
 racket/collects/racket/match/parse-helper.rkt | 20 ++++++++++---------
 .../match/syntax-local-match-introduce.rkt    | 15 ++++++++++++++
 6 files changed, 43 insertions(+), 13 deletions(-)
 create mode 100644 racket/collects/racket/match/syntax-local-match-introduce.rkt

diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/match.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/match.scrbl
index 6e713f0b1c..7a950790e1 100644
--- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/match.scrbl
+++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/match.scrbl
@@ -661,6 +661,10 @@ Predicates for values which implement the appropriate match expander
 properties.
 }
 
+@defproc[(syntax-local-match-introduce [stx syntax?]) syntax?]{
+Like @racket[syntax-local-introduce], but for match expanders.
+}
+
 
 @defparam[match-equality-test comp-proc (any/c any/c . -> . any)]{
 
diff --git a/pkgs/racket-pkgs/racket-test/tests/match/examples.rkt b/pkgs/racket-pkgs/racket-test/tests/match/examples.rkt
index 662170eb69..0a5b182aa2 100644
--- a/pkgs/racket-pkgs/racket-test/tests/match/examples.rkt
+++ b/pkgs/racket-pkgs/racket-test/tests/match/examples.rkt
@@ -1,7 +1,7 @@
 #lang scheme/base
 
-(require scheme/match
-	 scheme/mpair
+(require racket/match
+         scheme/mpair
          scheme/control scheme/foreign
          (only-in racket/list split-at)
          (for-syntax scheme/base)
@@ -728,4 +728,11 @@
            [(cons a b) #:when (= a b) 1]
            [_ 0]))
    
+   (test-case "syntax-local-match-introduce"
+     (define-match-expander foo
+       (lambda (stx) (syntax-local-match-introduce #'x)))
+     (check-equal? (match 42
+                     [(foo) x])
+                   42))
+   
 ))
diff --git a/pkgs/unstable-2d/unstable/2d/match.rkt b/pkgs/unstable-2d/unstable/2d/match.rkt
index a555c6bd5f..164892a2b4 100644
--- a/pkgs/unstable-2d/unstable/2d/match.rkt
+++ b/pkgs/unstable-2d/unstable/2d/match.rkt
@@ -1,6 +1,6 @@
 #lang racket/base
 (require (for-syntax racket/base
-                     racket/match/parse
+                     (only-in racket/match/parse parse)
                      racket/match/patterns)
          racket/match)
 
diff --git a/racket/collects/racket/match/match.rkt b/racket/collects/racket/match/match.rkt
index fb82e2d2d4..9720b69ef2 100644
--- a/racket/collects/racket/match/match.rkt
+++ b/racket/collects/racket/match/match.rkt
@@ -8,6 +8,7 @@
          "define-forms.rkt"
          "struct.rkt"
          (for-syntax racket/lazy-require
+                     "syntax-local-match-introduce.rkt"
                      (only-in "stxtime.rkt"
                               match-...-nesting
                               match-expander?
@@ -19,7 +20,8 @@
   (lazy-require [racket/match/parse (parse)]))
 
 (provide (for-syntax match-...-nesting match-expander? legacy-match-expander?
-                     prop:match-expander prop:legacy-match-expander)
+                     prop:match-expander prop:legacy-match-expander
+                     syntax-local-match-introduce)
          match-equality-test
          define-match-expander
          struct* ==          
diff --git a/racket/collects/racket/match/parse-helper.rkt b/racket/collects/racket/match/parse-helper.rkt
index 0449d180db..252602d0dd 100644
--- a/racket/collects/racket/match/parse-helper.rkt
+++ b/racket/collects/racket/match/parse-helper.rkt
@@ -4,7 +4,8 @@
          syntax/boundmap
          racket/struct-info
          ;macro-debugger/emit
-         "patterns.rkt")
+         "patterns.rkt"
+         "syntax-local-match-introduce.rkt")
 
 (provide ddk? parse-literal all-vars pattern-var? match:syntax-err
          match-expander-transform trans-match parse-struct
@@ -153,14 +154,15 @@
                           (set!-transformer-procedure transformer)
                           transformer)])
     (unless transformer (raise-syntax-error #f error-msg expander*))
-    (let* ([introducer (make-syntax-introducer)]
-           [mstx (introducer (syntax-local-introduce stx))]
-           [mresult (if (procedure-arity-includes? transformer 2) 
-                        (transformer expander* mstx)
-                        (transformer mstx))]
-           [result (syntax-local-introduce (introducer mresult))])
-      ;(emit-local-step stx result #:id expander)
-      (parse result))))
+    (define introducer (make-syntax-introducer))
+    (parameterize ([current-match-introducer introducer])
+      (let* ([mstx (introducer (syntax-local-introduce stx))]
+             [mresult (if (procedure-arity-includes? transformer 2) 
+                          (transformer expander* mstx)
+                          (transformer mstx))]
+             [result (syntax-local-introduce (introducer mresult))])
+        ;(emit-local-step stx result #:id expander)
+        (parse result)))))
 
 ;; raise an error, blaming stx
 (define (match:syntax-err stx msg)
diff --git a/racket/collects/racket/match/syntax-local-match-introduce.rkt b/racket/collects/racket/match/syntax-local-match-introduce.rkt
new file mode 100644
index 0000000000..816eb37436
--- /dev/null
+++ b/racket/collects/racket/match/syntax-local-match-introduce.rkt
@@ -0,0 +1,15 @@
+#lang racket/base
+
+(provide syntax-local-match-introduce
+         current-match-introducer)
+
+(define current-match-introducer
+  (make-parameter
+   (lambda (x)
+     (error 'syntax-local-match-introduce "not expanding match expander form"))))
+
+(define (syntax-local-match-introduce x)
+  (unless (syntax? x)
+    (raise-argument-error 'syntax-local-match-introduce "syntax?" x))
+  ((current-match-introducer) x))
+