From 01fded8c776feba9cb721996414dd98cd687e917 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 26 May 2010 22:49:09 +0200
Subject: [PATCH] sxml-match: Handle multiple-value returns.

* module/sxml/sxml-match.ss (sxml-match1): Invoke ESCAPE via
  `call-with-values'.

* test-suite/tests/sxml-match-tests.ss ("test multiple value returns"):
  New test.

* module/sxml/match.scm: Mention the modification.
---
 module/sxml/match.scm                | 5 ++++-
 module/sxml/sxml-match.ss            | 5 ++++-
 test-suite/tests/sxml-match-tests.ss | 9 +++++++++
 3 files changed, 17 insertions(+), 2 deletions(-)

diff --git a/module/sxml/match.scm b/module/sxml/match.scm
index 5b21deee8..d9d0285cf 100644
--- a/module/sxml/match.scm
+++ b/module/sxml/match.scm
@@ -81,11 +81,14 @@
 ;;; Include upstream source file.
 ;;;
 
-;; This file was taken unmodified from
+;; This file was taken from
 ;; <http://planet.plt-scheme.org/package-source/jim/sxml-match.plt/1/1/> on
 ;; 2010-05-24.  It was written by Jim Bender <benderjg2@aol.com> and released
 ;; under the MIT/X11 license
 ;; <http://www.gnu.org/licenses/license-list.html#X11License>.
+;;
+;; Modified the `sxml-match1' macro to allow multiple-value returns (upstream
+;; was notified.)
 
 (include-from-path "sxml/sxml-match.ss")
 
diff --git a/module/sxml/sxml-match.ss b/module/sxml/sxml-match.ss
index b13971858..40d117944 100644
--- a/module/sxml/sxml-match.ss
+++ b/module/sxml/sxml-match.ss
@@ -1124,7 +1124,10 @@
       [(sxml-match1 exp cata-fun clause0 clause ...)
        (let/ec escape
          (compile-clause clause0 exp cata-fun
-                         (lambda () (escape (sxml-match1 exp cata-fun clause ...)))))]))
+                         (lambda () (call-with-values
+                                        (lambda () (sxml-match1 exp cata-fun
+                                                                clause ...))
+                                      escape))))]))
   
   (define-syntax sxml-match
     (syntax-rules ()
diff --git a/test-suite/tests/sxml-match-tests.ss b/test-suite/tests/sxml-match-tests.ss
index 39772b451..824d017ee 100644
--- a/test-suite/tests/sxml-match-tests.ss
+++ b/test-suite/tests/sxml-match-tests.ss
@@ -299,3 +299,12 @@
                       [(a (@ . ,qqq) ,t ...)
                        (list qqq t ...)])
           '(((z 1) (y 2) (x 3)) 4 5 6))
+
+(run-test "test multiple value returns"
+           (call-with-values
+               (lambda ()
+                 (sxml-match '(foo)
+                   ((foo) (values 'x 'y))))
+             (lambda (x y)
+               (cons x y)))
+           '(x . y))