summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/sxml/match.scm5
-rw-r--r--module/sxml/sxml-match.ss5
-rw-r--r--test-suite/tests/sxml-match-tests.ss9
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))