From 4c0c3c0ff8c71c9b37680c35c196585e4d96565d Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Tue, 18 Nov 2008 21:17:36 +0000
Subject: [PATCH] Fix dynamic context of use of match failure continuations.

svn: r12497
---
 collects/scheme/match/compiler.ss | 10 ++++++----
 collects/scheme/match/runtime.ss  |  5 ++++-
 collects/tests/match/examples.ss  | 14 ++++++++++++++
 3 files changed, 24 insertions(+), 5 deletions(-)

diff --git a/collects/scheme/match/compiler.ss b/collects/scheme/match/compiler.ss
index 5c43ec57c6..0d0efd74fb 100644
--- a/collects/scheme/match/compiler.ss
+++ b/collects/scheme/match/compiler.ss
@@ -429,10 +429,12 @@
                                                     (quote-syntax #,esc))])
                                             #,(Row-rhs (car blocks)))])
                                    (if (Row-unmatch (car blocks))
-                                       #`(let/ec k
-                                                 (let ([#,(Row-unmatch (car blocks))
-                                                        (lambda () (call-with-values #,esc k))])
-                                                   rhs))
+                                       #`(call-with-continuation-prompt
+                                          (lambda () (let ([#,(Row-unmatch (car blocks))
+                                                        (lambda () (abort-current-continuation match-prompt-tag))])
+                                                       rhs))
+                                          match-prompt-tag
+                                          (lambda () (#,esc)))
                                        #'rhs))])
                   ;; then compile the rest, with our name as the esc
                   (loop (cdr blocks) #'f (cons #'[f (lambda () c)] acc)))))])
diff --git a/collects/scheme/match/runtime.ss b/collects/scheme/match/runtime.ss
index 8bd598543f..6b38c07fbb 100644
--- a/collects/scheme/match/runtime.ss
+++ b/collects/scheme/match/runtime.ss
@@ -7,7 +7,10 @@
          exn:misc:match?
          match:error
          fail
-         matchable?)
+         matchable?
+         match-prompt-tag)
+
+(define match-prompt-tag (make-continuation-prompt-tag 'match))
 
 (define match-equality-test (make-parameter equal?))
 
diff --git a/collects/tests/match/examples.ss b/collects/tests/match/examples.ss
index 2e66a284b6..679f6c09e5 100644
--- a/collects/tests/match/examples.ss
+++ b/collects/tests/match/examples.ss
@@ -2,6 +2,7 @@
 
 (require scheme/match 
 	 scheme/mpair
+         scheme/control
          (for-syntax scheme/base)
          (prefix-in m: mzlib/match)
          (only-in srfi/13 string-contains))
@@ -582,6 +583,19 @@
           (lambda () 
             (match 'foo [_ (=> skip) (skip)] [_ (values 1 2)]))
           list))
+   (comp 0
+         (let ([z (make-parameter 0)])
+           (match 1
+             [(? number?) (=> f) (parameterize ([z 1]) (f))] 
+             [(? number?) (z)])))
    
+   ;; make sure the prompts don't interfere
+   (comp 12
+         (%
+          (let ([z (make-parameter 0)])
+            (match 1
+              [(? number?) (=> f) (parameterize ([z 1]) (fcontrol 5))] 
+              [(? number?) (z)]))
+          (lambda _ 12)))
 
    ))