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.

diff --git a/module/sxml/match.scm b/module/sxml/match.scm
index 5b21dee..d9d0285 100644 (file)
--- 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 b139718..40d1179 100644 (file)
--- 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 39772b4..824d017 100644 (file)
--- 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))