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 ;; on ;; 2010-05-24. It was written by Jim Bender and released ;; under the MIT/X11 license ;; . +;; +;; 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))