Add syntax-local-match-introduce

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)]{
 

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))
+   
 ))

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)
 

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* ==          

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)

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))
+