guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, lua, updated. release_1-9-10-203-g3046


From: No Itisnt
Subject: [Guile-commits] GNU Guile branch, lua, updated. release_1-9-10-203-g304680b
Date: Wed, 26 May 2010 21:04:07 +0000

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=304680b5b6bfd085cc15491d22cc29cc4b8e3c1b

The branch, lua has been updated
       via  304680b5b6bfd085cc15491d22cc29cc4b8e3c1b (commit)
       via  713c50c5c606ce4c1e8d0794f35a7e4d70411220 (commit)
       via  40b19fda5c92e5acbb13351ebbe8c70c3337c82d (commit)
       via  400a5dcb8b3bb042d8106f0aca69aecc6fd0628c (commit)
       via  adb8f30600cdb146d6dd10684d9d9c6bcdd2cb76 (commit)
      from  fe959e02a1f042c435c08518b1498d22fa94bf98 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 304680b5b6bfd085cc15491d22cc29cc4b8e3c1b
Author: No Itisnt <address@hidden>
Date:   Wed May 26 16:02:51 2010 -0500

    Lua identifier support, as well as true, false, and nil
    
    * module/language/lua/lexer.scm:
    * test-suite/tests/lua-lexer.test: Identifier support

commit 713c50c5c606ce4c1e8d0794f35a7e4d70411220
Merge: fe959e02a1f042c435c08518b1498d22fa94bf98 
40b19fda5c92e5acbb13351ebbe8c70c3337c82d
Author: No Itisnt <address@hidden>
Date:   Wed May 26 15:28:25 2010 -0500

    Merge branch 'master' into lua

-----------------------------------------------------------------------

Summary of changes:
 doc/ref/Makefile.am                  |    1 +
 doc/ref/guile.texi                   |    5 +
 doc/ref/sxml-match.texi              |  377 +++++++++++
 module/Makefile.am                   |    2 +
 module/ice-9/compile-psyntax.scm     |   22 +-
 module/language/lua/lexer.scm        |   60 ++-
 module/sxml/match.scm                |   92 +++
 module/sxml/sxml-match.ss            | 1178 ++++++++++++++++++++++++++++++++++
 test-suite/Makefile.am               |    3 +-
 test-suite/tests/lua-lexer.test      |   22 +-
 test-suite/tests/sxml-match-tests.ss |  301 +++++++++
 test-suite/tests/sxml.match.test     |   45 ++
 12 files changed, 2086 insertions(+), 22 deletions(-)
 create mode 100644 doc/ref/sxml-match.texi
 create mode 100644 module/sxml/match.scm
 create mode 100644 module/sxml/sxml-match.ss
 create mode 100644 test-suite/tests/sxml-match-tests.ss
 create mode 100644 test-suite/tests/sxml.match.test

diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am
index 60146a3..feadec6 100644
--- a/doc/ref/Makefile.am
+++ b/doc/ref/Makefile.am
@@ -58,6 +58,7 @@ guile_TEXINFOS = preface.texi                 \
                 posix.texi                     \
                 expect.texi                    \
                 scsh.texi                      \
+                sxml-match.texi                \
                 scheme-scripts.texi            \
                 api-overview.texi              \
                 api-discdepr.texi              \
diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi
index 27d6c7b..32cf1d6 100644
--- a/doc/ref/guile.texi
+++ b/doc/ref/guile.texi
@@ -359,6 +359,7 @@ available through both Scheme and C interfaces.
 * Streams::                     Sequences of values.
 * Buffered Input::              Ports made from a reader function.
 * Expect::                     Controlling interactive programs with Guile.
+* sxml-match::                  Pattern matching of SXML.
 * The Scheme shell (scsh)::     Using scsh interfaces in Guile.
 * Tracing::                     Tracing program execution.
 @end menu
@@ -370,6 +371,10 @@ available through both Scheme and C interfaces.
 @include repl-modules.texi
 @include misc-modules.texi
 @include expect.texi
+
address@hidden XXX: Would be nicer if it were close to the (sxml simple) 
documentation.
address@hidden sxml-match.texi
+
 @include scsh.texi
 @include scheme-debugging.texi
 
diff --git a/doc/ref/sxml-match.texi b/doc/ref/sxml-match.texi
new file mode 100644
index 0000000..58c2d8c
--- /dev/null
+++ b/doc/ref/sxml-match.texi
@@ -0,0 +1,377 @@
address@hidden -*-texinfo-*-
address@hidden This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 2010  Free Software Foundation, Inc.
address@hidden See the file guile.texi for copying conditions.
address@hidden
address@hidden Based on the documentation at
address@hidden 
<http://planet.plt-scheme.org/package-source/jim/sxml-match.plt/1/1/doc.txt>,
address@hidden copyright 2005 Jim Bender, and released under the MIT/X11 
license (like the
address@hidden rest of `sxml-match'.)
address@hidden
address@hidden Converted to Texinfo and modified by Ludovic Courtès, 2010.
+
address@hidden sxml-match
address@hidden @code{sxml-match}: Pattern Matching of SXML
+
address@hidden pattern matching (SXML)
address@hidden SXML pattern matching
+
+The @code{(sxml match)} module provides syntactic forms for pattern matching of
+SXML trees, in a ``by example'' style reminiscent of the pattern matching of 
the
address@hidden and @code{syntax-case} macro systems.  @xref{sxml simple,
+the @code{(sxml simple)} module}, for more information on SXML.
+
+The following address@hidden example is taken from a paper by
+Krishnamurthi et al.  Their paper was the first to show the usefulness of the
address@hidden style of pattern matching for transformation of XML, though
+the language described, XT3D, is an XML language.} provides a brief
+illustration, transforming a music album catalog language into HTML.
+
address@hidden
+(define (album->html x)
+  (sxml-match x
+    [(album (@ (title ,t)) (catalog (num ,n) (fmt ,f)) ...)
+     `(ul (li ,t)
+          (li (b ,n) (i ,f)) ...)]))
address@hidden lisp
+
+Three macros are provided: @code{sxml-match}, @code{sxml-match-let}, and
address@hidden
+
+Compared to a standard s-expression pattern matcher, @code{sxml-match} provides
+the following benefits:
+
address@hidden
address@hidden
+matching of SXML elements does not depend on any degree of normalization of the
+SXML;
address@hidden
+matching of SXML attributes (within an element) is under-ordered; the order of
+the attributes specified within the pattern need not match the ordering with 
the
+element being matched;
address@hidden
+all attributes specified in the pattern must be present in the element being
+matched; in the spirit that XML is 'extensible', the element being matched may
+include additional attributes not specified in the pattern.
address@hidden itemize
+
+The present module is a descendant of WebIt!, and was inspired by an
+s-expression pattern matcher developed by Erik Hilsdale, Dan Friedman, and Kent
+Dybvig at Indiana University.
+
address@hidden Syntax
+
address@hidden provides @code{case}-like form for pattern matching of XML
+nodes.
+
address@hidden {Scheme Syntax} sxml-match input-expression clause ...
+Match @var{input-expression}, an SXML tree, according to the given 
@var{clause}s
+(one or more), each consisting of a pattern and one or more expressions to be
+evaluated if the pattern match succeeds.  Optionally, each @var{clause} within
address@hidden may include a @dfn{guard expression}.
address@hidden deffn
+
+The pattern notation is based on that of Scheme's @code{syntax-rules} and
address@hidden macro systems.  The grammar for the @code{sxml-match} syntax
+is given below:
+
address@hidden
+match-form ::= (sxml-match input-expression
+                 clause+)
+
+clause ::= [node-pattern action-expression+]
+         | [node-pattern (guard expression*) action-expression+]
+
+node-pattern ::= literal-pattern
+               | pat-var-or-cata
+               | element-pattern
+               | list-pattern
+
+literal-pattern ::= string
+                  | character
+                  | number
+                  | #t
+                  | #f
+
+attr-list-pattern ::= (@ attribute-pattern*)
+                    | (@ attribute-pattern* . pat-var-or-cata)
+
+attribute-pattern ::= (tag-symbol attr-val-pattern)
+
+attr-val-pattern ::= literal-pattern
+                   | pat-var-or-cata
+                   | (pat-var-or-cata default-value-expr)
+
+element-pattern ::= (tag-symbol attr-list-pattern?)
+                  | (tag-symbol attr-list-pattern? nodeset-pattern)
+                  | (tag-symbol attr-list-pattern?
+                                nodeset-pattern? . pat-var-or-cata)
+
+list-pattern ::= (list nodeset-pattern)
+               | (list nodeset-pattern? . pat-var-or-cata)
+               | (list)
+
+nodeset-pattern ::= node-pattern
+                  | node-pattern ...
+                  | node-pattern nodeset-pattern
+                  | node-pattern ... nodeset-pattern
+
+pat-var-or-cata ::= (unquote var-symbol)
+                  | (unquote [var-symbol*])
+                  | (unquote [cata-expression -> var-symbol*])
address@hidden verbatim
+
+Within a list or element body pattern, ellipses may appear only once, but may 
be
+followed by zero or more node patterns.
+
+Guard expressions cannot refer to the return values of catamorphisms.
+
+Ellipses in the output expressions must appear only in an expression context;
+ellipses are not allowed in a syntactic form.
+
+The sections below illustrate specific aspects of the @code{sxml-match} pattern
+matcher.
+
address@hidden Matching XML Elements
+
+The example below illustrates the pattern matching of an XML element:
+
address@hidden
+(sxml-match '(e (@ (i 1)) 3 4 5)
+  [(e (@ (i ,d)) ,a ,b ,c) (list d a b c)]
+  [,otherwise #f])
address@hidden lisp
+
+Each clause in @code{sxml-match} contains two parts: a pattern and one or more
+expressions which are evaluated if the pattern is successfully match.  The
+example above matches an element @code{e} with an attribute @code{i} and three
+children.
+
+Pattern variables are must be ``unquoted'' in the pattern.  The above 
expression
+binds @var{d} to @code{1}, @var{a} to @code{3}, @var{b} to @code{4}, and 
@var{c}
+to @code{5}.
+
address@hidden Ellipses in Patterns
+
+As in @code{syntax-rules}, ellipses may be used to specify a repeated pattern.
+Note that the pattern @code{item ...} specifies zero-or-more matches of the
+pattern @code{item}.
+
+The use of ellipses in a pattern is illustrated in the code fragment below,
+where nested ellipses are used to match the children of repeated instances of 
an
address@hidden element, within an element @code{d}.
+
address@hidden
+(define x '(d (a 1 2 3) (a 4 5) (a 6 7 8) (a 9 10)))
+
+(sxml-match x
+  [(d (a ,b ...) ...)
+   (list (list b ...) ...)])
address@hidden lisp
+
+The above expression returns a value of @code{((1 2 3) (4 5) (6 7 8) (9 10))}.
+
address@hidden Ellipses in Quasiquote'd Output
+
+Within the body of an @code{sxml-match} form, a slightly extended version of
+quasiquote is provided, which allows the use of ellipses.  This is illustrated
+in the example below.
+
address@hidden
+(sxml-match '(e 3 4 5 6 7)
+  [(e ,i ... 6 7) `("start" ,(list 'wrap i) ... "end")]
+  [,otherwise #f])
address@hidden lisp
+
+The general pattern is that @code{`(something ,i ...)} is rewritten as
address@hidden(something ,@@i)}.
+
address@hidden Matching Nodesets
+
+A nodeset pattern is designated by a list in the pattern, beginning the
+identifier list.  The example below illustrates matching a nodeset.
+
address@hidden
+(sxml-match '("i" "j" "k" "l" "m")
+  [(list ,a ,b ,c ,d ,e)
+   `((p ,a) (p ,b) (p ,c) (p ,d) (p ,e))])
address@hidden lisp
+
+This example wraps each nodeset item in an HTML paragraph element.  This 
example
+can be rewritten and simplified through using ellipsis:
+
address@hidden
+(sxml-match '("i" "j" "k" "l" "m")
+  [(list ,i ...)
+   `((p ,i) ...)])
address@hidden lisp
+
+This version will match nodesets of any length, and wrap each item in the
+nodeset in an HTML paragraph element.
+
address@hidden Matching the ``Rest'' of a Nodeset
+
+Matching the ``rest'' of a nodeset is achieved by using a @code{. rest)} 
pattern
+at the end of an element or nodeset pattern.
+
+This is illustrated in the example below:
+
address@hidden
+(sxml-match '(e 3 (f 4 5 6) 7)
+  [(e ,a (f . ,y) ,d)
+   (list a y d)])
address@hidden lisp
+
+The above expression returns @code{(3 (4 5 6) 7)}.
+
address@hidden Matching the Unmatched Attributes
+
+Sometimes it is useful to bind a list of attributes present in the element 
being
+matched, but which do not appear in the pattern.  This is achieved by using a
address@hidden rest)} pattern at the end of the attribute list pattern.  This is
+illustrated in the example below:
+
address@hidden
+(sxml-match '(a (@ (z 1) (y 2) (x 3)) 4 5 6)
+  [(a (@ (y ,www) . ,qqq) ,t ,u ,v)
+   (list www qqq t u v)])
address@hidden lisp
+
+The above expression matches the attribute @code{y} and binds a list of the
+remaining attributes to the variable @var{qqq}.  The result of the above
+expression is @code{(2 ((z 1) (x 3)) 4 5 6)}.
+
+This type of pattern also allows the binding of all attributes:
+
address@hidden
+(sxml-match '(a (@ (z 1) (y 2) (x 3)))
+  [(a (@ . ,qqq))
+   qqq])
address@hidden lisp
+
address@hidden Default Values in Attribute Patterns
+
+It is possible to specify a default value for an attribute which is used if the
+attribute is not present in the element being matched.  This is illustrated in
+the following example:
+
address@hidden
+(sxml-match '(e 3 4 5)
+  [(e (@ (z (,d 1))) ,a ,b ,c) (list d a b c)])
address@hidden lisp
+
+The value @code{1} is used when the attribute @code{z} is absent from the
+element @code{e}.
+
address@hidden Guards in Patterns
+
+Guards may be added to a pattern clause via the @code{guard} keyword.  A guard
+expression may include zero or more expressions which are evaluated only if the
+pattern is matched.  The body of the clause is only evaluated if the guard
+expressions evaluate to @code{#t}.
+
+The use of guard expressions is illustrated below:
+
address@hidden
+(sxml-match '(a 2 3)
+  ((a ,n) (guard (number? n)) n)
+  ((a ,m ,n) (guard (number? m) (number? n)) (+ m n)))
address@hidden lisp
+
address@hidden Catamorphisms
+
+The example below illustrates the use of explicit recursion within an
address@hidden form.  This example implements a simple calculator for the
+basic arithmetic operations, which are represented by the XML elements
address@hidden, @code{minus}, @code{times}, and @code{div}.
+
address@hidden
+(define simple-eval
+  (lambda (x)
+    (sxml-match x
+      [,i (guard (integer? i)) i]
+      [(plus ,x ,y) (+ (simple-eval x) (simple-eval y))]
+      [(times ,x ,y) (* (simple-eval x) (simple-eval y))]
+      [(minus ,x ,y) (- (simple-eval x) (simple-eval y))]
+      [(div ,x ,y) (/ (simple-eval x) (simple-eval y))]
+      [,otherwise (error "simple-eval: invalid expression" x)])))
address@hidden lisp
+
+Using the catamorphism feature of @code{sxml-match}, a more concise version of
address@hidden can be written.  The pattern @code{,[x]} recusively invokes
+the pattern matcher on the value bound in this position.
+
address@hidden
+(define simple-eval
+  (lambda (x)
+    (sxml-match x
+      [,i (guard (integer? i)) i]
+      [(plus ,[x] ,[y]) (+ x y)]
+      [(times ,[x] ,[y]) (* x y)]
+      [(minus ,[x] ,[y]) (- x y)]
+      [(div ,[x] ,[y]) (/ x y)]
+      [,otherwise (error "simple-eval: invalid expression" x)])))
address@hidden lisp
+
address@hidden Named-Catamorphisms
+
+It is also possible to explicitly name the operator in the ``cata'' position.
+Where @code{,[id*]} recurs to the top of the current @code{sxml-match},
address@hidden,[cata -> id*]} recurs to @code{cata}.  @code{cata} must evaluate 
to a
+procedure which takes one argument, and returns as many values as there are
+identifiers following @code{->}.
+
+Named catamorphism patterns allow processing to be split into multiple, 
mutually
+recursive procedures.  This is illustrated in the example below: a
+transformation that formats a "TV Guide" into HTML.
+
address@hidden
+(define (tv-guide->html g)
+  (define (cast-list cl)
+    (sxml-match cl
+      [(CastList (CastMember (Character (Name ,ch)) (Actor (Name ,a))) ...)
+       `(div (ul (li ,ch ": " ,a) ...))]))
+  (define (prog p)
+    (sxml-match p
+      [(Program (Start ,start-time) (Duration ,dur) (Series ,series-title)
+                (Description ,desc ...))
+       `(div (p ,start-time
+                (br) ,series-title
+                (br) ,desc ...))]
+      [(Program (Start ,start-time) (Duration ,dur) (Series ,series-title)
+                (Description ,desc ...)
+                ,[cast-list -> cl])
+       `(div (p ,start-time
+                (br) ,series-title
+                (br) ,desc ...)
+             ,cl)]))
+  (sxml-match g
+    [(TVGuide (@ (start ,start-date)
+                 (end ,end-date))
+              (Channel (Name ,nm) ,[prog -> p] ...) ...)
+     `(html (head (title "TV Guide"))
+            (body (h1 "TV Guide")
+                  (div (h2 ,nm) ,p ...) ...))]))
address@hidden lisp
+
address@hidden @code{sxml-match-let} and @code{sxml-match-let*}
+
address@hidden {Scheme Syntax} sxml-match-let ((pat expr) ...) expression0 
expression ...)
address@hidden {Scheme Syntax} sxml-match-let* ((pat expr) ...) expression0 
expression ...)
+These forms generalize the @code{let} and @code{let*} forms of Scheme to allow
+an XML pattern in the binding position, rather than a simple variable.
address@hidden deffn
+
+For example, the expression below:
+
address@hidden
+(sxml-match-let ([(a ,i ,j) '(a 1 2)])
+  (+ i j))
address@hidden lisp
+
+binds the variables @var{i} and @var{j} to @code{1} and @code{2} in the XML
+value given.
+
address@hidden Local Variables:
address@hidden coding: utf-8
address@hidden End:
diff --git a/module/Makefile.am b/module/Makefile.am
index 92c0e58..4ea8997 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -321,6 +321,7 @@ LIB_SOURCES =                                       \
   statprof.scm                                 \
   sxml/apply-templates.scm                     \
   sxml/fold.scm                                        \
+  sxml/match.scm                               \
   sxml/simple.scm                              \
   sxml/ssax/input-parse.scm                    \
   sxml/ssax.scm                                        \
@@ -354,6 +355,7 @@ NOCOMP_SOURCES =                            \
   ice-9/debugging/trace.scm                    \
   ice-9/debugging/traps.scm                    \
   ice-9/debugging/trc.scm                      \
+  sxml/sxml-match.ss                           \
   sxml/upstream/SSAX.scm                       \
   sxml/upstream/SXML-tree-trans.scm            \
   sxml/upstream/SXPath-old.scm                 \
diff --git a/module/ice-9/compile-psyntax.scm b/module/ice-9/compile-psyntax.scm
index 5529e69..e83a5be 100644
--- a/module/ice-9/compile-psyntax.scm
+++ b/module/ice-9/compile-psyntax.scm
@@ -1,4 +1,24 @@
-(use-modules (language tree-il) (ice-9 pretty-print))
+;;; -*- mode: scheme; coding: utf-8; -*-
+;;;
+;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;;;
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 
USA
+
+(use-modules (language tree-il)
+             (ice-9 pretty-print))
+
 (let ((source (list-ref (command-line) 1))
       (target (list-ref (command-line) 2)))
   (let ((in (open-input-file source))
diff --git a/module/language/lua/lexer.scm b/module/language/lua/lexer.scm
index 3bb0292..75171d7 100644
--- a/module/language/lua/lexer.scm
+++ b/module/language/lua/lexer.scm
@@ -8,23 +8,25 @@
 ;;;;; TOKENS
 
 (define-record-type token
-  (%make-token type location value)
+  (make-token type location value)
   token?
   (type token/type)
   (location token/location)
   (value token/value))
 
+(define (port-location port) 
+  (make-location (port-filename port) (port-line port) (port-column port)))
+
 ;; This is a macro to make sure the location is retrieved before the token is
 ;; consumed
-(define-syntax make-token
+(define-syntax make-token-simple
   (syntax-rules ()
-    ;; auxilliary pattern to make the location, used below
-    ((_ (port))
-     (make-location (port-filename port) (port-line port) (port-column port)))
-    ;; actual pattern
     ((_ port type value)
-     (let* ((location (make-token (port))))
-       (%make-token type location value)))))
+     (let* ((location (port-location port)))
+       (make-token type location value)))))
+
+(define (make-atomic-token type location)
+  (make-token type location *unspecified*))
 
 ;;;;; UTILITIES
 
@@ -32,37 +34,63 @@
   (when (eof-object? (peek-char port))
     (throw 'lua-unexpected-eof (string-append "unexpected end-of-file " 
desc))))
 
-(define (eat-char port) (read-char port) (if #f #f))
+(define (eat-char port) (read-char port) *unspecified*)
 
 (define (newline? c) (or (eq? c #\newline) (eq? c #\cr)))
 
 ;;;;; LEXER
 
 ;; Strings
-(define (lex-string port quote-character allow-newlines?)
-  (make-token port 'string
+(define (string port quote-character allow-newlines?)
+  (make-token-simple port 'string
   (with-output-to-string
    (lambda ()
      (eat-char port)
      (let loop ((c (peek-char port)))
        (assert-no-eof port "in string")
-       (cond ((eq? c quote-character) (get-output-string 
(current-output-port)))
+       (cond ((eq? c quote-character) *unspecified*)
              (else (write-char (read-char port)) (loop (peek-char port)))))))))
 
-(define (lex-comment port)
+;; Comments
+(define (comment port)
   (while (not (or (eof-object? (peek-char port)) (newline? (peek-char port))))
     (eat-char port))
   #f)
 
+;; Identifiers
+
+(define (char-identifier-first? c)
+  (and (not (eof-object? c)) (or (char-alphabetic? c) (char=? c #\_))))
+
+(define (char-identifier? c)
+  (and (not (eof-object? c)) (or (char-identifier-first? c) (char-numeric? 
c))))
+
+(define (identifier port)
+  (define location (port-location port))
+  (define return 
+   (string->symbol
+    (with-output-to-string
+     (lambda ()
+       (let loop ((c (peek-char port)))
+         (if (char-identifier? c)
+             (begin (write-char (read-char port)) (loop (peek-char port)))
+             *unspecified*))))))
+  (case return
+    ((true) (make-atomic-token 'true location))
+    ((false) (make-atomic-token 'false location))
+    ((nil) (make-atomic-token 'nil location))
+    (else (make-token 'identifier location return))))
+
 ;; Main loop
 (define (lex port)
   (define c (peek-char port))
   (cond ((eof-object? c) c)
+        ((char-identifier-first? c) (identifier port))
         ((eq? c #\-)
          (read-char port)
          (if (eq? (peek-char port) #\-)
-             (lex-comment port)
+             (comment port)
              (error)))
-        ((eq? c #\") (lex-string port #\" #f))
-        ((eq? c #\') (lex-string port #\' #f))
+        ((eq? c #\") (string port #\" #f))
+        ((eq? c #\') (string port #\' #f))
         (else (error))))
diff --git a/module/sxml/match.scm b/module/sxml/match.scm
new file mode 100644
index 0000000..5b21dee
--- /dev/null
+++ b/module/sxml/match.scm
@@ -0,0 +1,92 @@
+;;; -*- mode: scheme; coding: utf-8; -*-
+;;;
+;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;
+;;; This library is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU Lesser General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public License
+;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (sxml match)
+  #:export (sxml-match
+            sxml-match-let
+            sxml-match-let*)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11))
+
+
+;;; Commentary:
+;;;
+;;; This module provides an SXML pattern matcher, written by Jim Bender.  This
+;;; allows application code to match on SXML nodes and attributes without 
having
+;;; to deal with the details of s-expression matching, without worrying about
+;;; the order of attributes, etc.
+;;;
+;;; It is fully documented in the Guile Reference Manual.
+;;;
+;;; Code:
+
+
+
+;;;
+;;; PLT compatibility layer.
+;;;
+
+(define-syntax syntax-object->datum
+  (syntax-rules ()
+    ((_ stx)
+     (syntax->datum stx))))
+
+(define-syntax void
+  (syntax-rules ()
+    ((_) *unspecified*)))
+
+(define-syntax call/ec
+  ;; aka. `call-with-escape-continuation'
+  (syntax-rules ()
+    ((_ proc)
+     (let ((prompt (make-prompt-tag)))
+       (call-with-prompt prompt
+                         (lambda ()
+                           (proc (lambda args
+                                   (apply abort-to-prompt
+                                          prompt args))))
+                         (lambda (_ . args)
+                           (apply values args)))))))
+
+(define-syntax let/ec
+  (syntax-rules ()
+    ((_ cont body ...)
+     (call/ec (lambda (cont) body ...)))))
+
+(define (raise-syntax-error x msg obj sub)
+  (throw 'sxml-match-error x msg obj sub))
+
+(define-syntax module
+  (syntax-rules (provide require)
+    ((_ name lang (provide p_ ...) (require r_ ...)
+        body ...)
+     (begin body ...))))
+
+
+;;;
+;;; Include upstream source file.
+;;;
+
+;; This file was taken unmodified from
+;; <http://planet.plt-scheme.org/package-source/jim/sxml-match.plt/1/1/> on
+;; 2010-05-24.  It was written by Jim Bender <address@hidden> and released
+;; under the MIT/X11 license
+;; <http://www.gnu.org/licenses/license-list.html#X11License>.
+
+(include-from-path "sxml/sxml-match.ss")
+
+;;; match.scm ends here
diff --git a/module/sxml/sxml-match.ss b/module/sxml/sxml-match.ss
new file mode 100644
index 0000000..b139718
--- /dev/null
+++ b/module/sxml/sxml-match.ss
@@ -0,0 +1,1178 @@
+;; Library: sxml-match
+;; Author: Jim Bender
+;; Version: 1.1, version for PLT Scheme
+;;
+;; Copyright 2005-9, Jim Bender
+;; sxml-match is released under the MIT License
+;;
+(module sxml-match mzscheme
+  
+  (provide sxml-match
+           sxml-match-let
+           sxml-match-let*)
+  
+  (require (rename (lib "fold.ss" "srfi" "1") fold-right fold-right)
+           (rename (lib "filter.ss" "srfi" "1") filter filter))
+  
+  (define (nodeset? x)
+    (or (and (pair? x) (not (symbol? (car x)))) (null? x)))
+  
+  (define (xml-element-tag s)
+    (if (and (pair? s) (symbol? (car s)))
+        (car s)
+        (error 'xml-element-tag "expected an xml-element, given" s)))
+  
+  (define (xml-element-attributes s)
+    (if (and (pair? s) (symbol? (car s)))
+        (fold-right (lambda (a b)
+                      (if (and (pair? a) (eq? '@ (car a)))
+                          (if (null? b)
+                              (filter (lambda (i) (not (and (pair? i) (eq? '@ 
(car i))))) (cdr a))
+                              (fold-right (lambda (c d)
+                                            (if (and (pair? c) (eq? '@ (car 
c)))
+                                                d
+                                                (cons c d)))
+                                          b (cdr a)))
+                          b))
+                    '()
+                    (cdr s))
+        (error 'xml-element-attributes "expected an xml-element, given" s)))
+  
+  (define (xml-element-contents s)
+    (if (and (pair? s) (symbol? (car s)))
+        (filter (lambda (i)
+                  (not (and (pair? i) (eq? '@ (car i)))))
+                (cdr s))
+        (error 'xml-element-contents "expected an xml-element, given" s)))
+  
+  (define (match-xml-attribute key l)
+    (if (not (pair? l))
+        #f
+        (if (eq? (car (car l)) key)
+            (car l)
+            (match-xml-attribute key (cdr l)))))
+  
+  (define (filter-attributes keys lst)
+    (if (null? lst)
+        '()
+        (if (member (caar lst) keys)
+            (filter-attributes keys (cdr lst))
+            (cons (car lst) (filter-attributes keys (cdr lst))))))
+  
+  (define-syntax compile-clause
+    (lambda (stx)
+      (letrec
+          ([sxml-match-syntax-error
+            (lambda (msg exp sub)
+              (raise-syntax-error #f msg (with-syntax ([s exp]) (syntax 
(sxml-match s))) sub))]
+           [ellipsis?
+            (lambda (stx)
+              (and (identifier? stx) (eq? '... (syntax-object->datum stx))))]
+           [literal?
+            (lambda (stx)
+              (let ([x (syntax-object->datum stx)])
+                (or (string? x)
+                    (char? x)
+                    (number? x)
+                    (boolean? x))))]
+           [keyword?
+            (lambda (stx)
+              (and (identifier? stx)
+                   (let ([str (symbol->string (syntax-object->datum stx))])
+                     (char=? #\: (string-ref str (- (string-length str) 
1))))))]
+           [extract-cata-fun
+            (lambda (cf)
+              (syntax-case cf ()
+                [#f #f]
+                [other cf]))]
+           [add-pat-var
+            (lambda (pvar pvar-lst)
+              (define (check-pvar lst)
+                (if (null? lst)
+                    (void)
+                    (if (bound-identifier=? (car lst) pvar)
+                        (sxml-match-syntax-error "duplicate pattern variable 
not allowed"
+                                                 stx
+                                                 pvar)
+                        (check-pvar (cdr lst)))))
+              (check-pvar pvar-lst)
+              (cons pvar pvar-lst))]
+           [add-cata-def
+            (lambda (depth cvars cfun ctemp cdefs)
+              (cons (list depth cvars cfun ctemp) cdefs))]
+           [process-cata-exp
+            (lambda (depth cfun ctemp)
+              (if (= depth 0)
+                  (with-syntax ([cf cfun]
+                                [ct ctemp])
+                    (syntax (cf ct)))
+                  (let ([new-ctemp (car (generate-temporaries (list ctemp)))])
+                    (with-syntax ([ct ctemp]
+                                  [nct new-ctemp]
+                                  [body (process-cata-exp (- depth 1) cfun 
new-ctemp)])
+                      (syntax (map (lambda (nct) body) ct))))))]
+           [process-cata-defs
+            (lambda (cata-defs body)
+              (if (null? cata-defs)
+                  body
+                  (with-syntax ([(cata-binding ...)
+                                 (map (lambda (def)
+                                        (with-syntax ([bvar (cadr def)]
+                                                      [bval (process-cata-exp 
(car def)
+                                                                              
(caddr def)
+                                                                              
(cadddr def))])
+                                          (syntax (bvar bval))))
+                                      cata-defs)]
+                                [body-stx body])
+                    (syntax (let-values (cata-binding ...)
+                              body-stx)))))]
+           [cata-defs->pvar-lst
+            (lambda (lst)
+              (if (null? lst)
+                  '()
+                  (let iter ([items (cadr (car lst))])
+                    (syntax-case items ()
+                      [() (cata-defs->pvar-lst (cdr lst))]
+                      [(fst . rst) (cons (syntax fst) (iter (syntax 
rst)))]))))]
+           [process-output-action
+            (lambda (action dotted-vars)
+              (define (finite-lst? lst)
+                (syntax-case lst ()
+                  (item
+                   (identifier? (syntax item))
+                   #f)
+                  (()
+                   #t)
+                  ((fst dots . rst)
+                   (ellipsis? (syntax dots))
+                   #f)
+                  ((fst . rst)
+                   (finite-lst? (syntax rst)))))
+              (define (expand-lst lst)
+                (syntax-case lst ()
+                  [() (syntax '())]
+                  [item
+                   (identifier? (syntax item))
+                   (syntax item)]
+                  [(fst dots . rst)
+                   (ellipsis? (syntax dots))
+                   (with-syntax ([exp-lft (expand-dotted-item
+                                           (process-output-action (syntax fst)
+                                                                  
dotted-vars))]
+                                 [exp-rgt (expand-lst (syntax rst))])
+                     (syntax (append exp-lft exp-rgt)))]
+                  [(fst . rst)
+                   (with-syntax ([exp-lft (process-output-action (syntax fst)
+                                                                 dotted-vars)]
+                                 [exp-rgt (expand-lst (syntax rst))])
+                     (syntax (cons exp-lft exp-rgt)))]))
+              (define (member-var? var lst)
+                (let iter ([lst lst])
+                  (if (null? lst)
+                      #f
+                      (if (or (bound-identifier=? var (car lst))
+                              (free-identifier=? var (car lst)))
+                          #t
+                          (iter (cdr lst))))))
+              (define (dotted-var? var)
+                (member-var? var dotted-vars))
+              (define (merge-pvars lst1 lst2)
+                (if (null? lst1)
+                    lst2
+                    (if (member-var? (car lst1) lst2)
+                        (merge-pvars (cdr lst1) lst2)
+                        (cons (car lst1) (merge-pvars (cdr lst1) lst2)))))
+              (define (select-dotted-vars x)
+                (define (walk-quasi-body y)
+                  (syntax-case y (unquote unquote-splicing)
+                    [((unquote a) . rst)
+                     (merge-pvars (select-dotted-vars (syntax a))
+                                  (walk-quasi-body (syntax rst)))]
+                    [((unquote-splicing a) . rst)
+                     (merge-pvars (select-dotted-vars (syntax a))
+                                  (walk-quasi-body (syntax rst)))]
+                    [(fst . rst)
+                     (merge-pvars (walk-quasi-body (syntax fst))
+                                  (walk-quasi-body (syntax rst)))]
+                    [other
+                     '()]))
+                (syntax-case x (quote quasiquote)
+                  [(quote . rst) '()]
+                  [(quasiquote . rst) (walk-quasi-body (syntax rst))]
+                  [(fst . rst)
+                   (merge-pvars (select-dotted-vars (syntax fst))
+                                (select-dotted-vars (syntax rst)))]
+                  [item
+                   (and (identifier? (syntax item))
+                        (dotted-var? (syntax item)))
+                   (list (syntax item))]
+                  [item '()]))
+              (define (expand-dotted-item item)
+                (let ([dvars (select-dotted-vars item)])
+                  (syntax-case item ()
+                    [x
+                     (identifier? (syntax x))
+                     (syntax x)]
+                    [x (with-syntax ([(dv ...) dvars])
+                         (syntax (map (lambda (dv ...) x) dv ...)))])))
+              (define (expand-quasiquote-body x)
+                (syntax-case x (unquote unquote-splicing quasiquote)
+                  [(quasiquote . rst) (process-quasiquote x)]
+                  [(unquote item)
+                   (with-syntax ([expanded-item (process-output-action (syntax 
item)
+                                                                       
dotted-vars)])
+                     (syntax (unquote expanded-item)))]
+                  [(unquote-splicing item)
+                   (with-syntax ([expanded-item (process-output-action (syntax 
item)
+                                                                       
dotted-vars)])
+                     (syntax (unquote-splicing expanded-item)))]
+                  [((unquote item) dots . rst)
+                   (ellipsis? (syntax dots))
+                   (with-syntax ([expanded-item (expand-dotted-item 
+                                                 (process-output-action 
(syntax item)
+                                                                        
dotted-vars))]
+                                 [expanded-rst (expand-quasiquote-body (syntax 
rst))])
+                     (syntax ((unquote-splicing expanded-item) . 
expanded-rst)))]
+                  [(item dots . rst)
+                   (ellipsis? (syntax dots))
+                   (with-syntax ([expanded-item (expand-dotted-item 
+                                                 (process-output-action 
(syntax (quasiquote item))
+                                                                        
dotted-vars))]
+                                 [expanded-rst (expand-quasiquote-body (syntax 
rst))])
+                     (syntax ((unquote-splicing expanded-item) . 
expanded-rst)))]
+                  [(fst . rst)
+                   (with-syntax ([expanded-fst (expand-quasiquote-body (syntax 
fst))]
+                                 [expanded-rst (expand-quasiquote-body (syntax 
rst))])
+                     (syntax (expanded-fst . expanded-rst)))]
+                  [other x]))
+              (define (process-quasiquote x)
+                (syntax-case x ()
+                  [(quasiquote term) (with-syntax ([expanded-body 
(expand-quasiquote-body (syntax term))])
+                                       (syntax (quasiquote expanded-body)))]
+                  [else (sxml-match-syntax-error "bad quasiquote-form"
+                                                 stx
+                                                 x)]))
+              (syntax-case action (quote quasiquote)
+                [(quote . rst) action]
+                [(quasiquote . rst) (process-quasiquote action)]
+                [(fst . rst) (if (finite-lst? action)
+                                 (with-syntax ([exp-lft (process-output-action 
(syntax fst) dotted-vars)]
+                                               [exp-rgt (process-output-action 
(syntax rst) dotted-vars)])
+                                   (syntax (exp-lft . exp-rgt)))
+                                 (with-syntax ([exp-lft (process-output-action 
(syntax fst)
+                                                                               
dotted-vars)]
+                                               [exp-rgt (expand-lst (syntax 
rst))])
+                                   (syntax (apply exp-lft exp-rgt))))]
+                [item action]))]
+           [compile-element-pat
+            (lambda (ele exp nextp fail-k pvar-lst depth cata-fun cata-defs 
dotted-vars)
+              (syntax-case ele (@)
+                [(tag (@ . attr-items) . items)
+                 (identifier? (syntax tag))
+                 (let ([attr-exp (car (generate-temporaries (list exp)))]
+                       [body-exp (car (generate-temporaries (list exp)))])
+                   (let-values ([(tests new-pvar-lst new-cata-defs 
new-dotted-vars)
+                                 (compile-attr-list (syntax attr-items)
+                                                    (syntax items)
+                                                    attr-exp
+                                                    body-exp
+                                                    '()
+                                                    nextp
+                                                    fail-k
+                                                    pvar-lst
+                                                    depth
+                                                    cata-fun
+                                                    cata-defs
+                                                    dotted-vars)])
+                     (values (with-syntax ([x exp]
+                                           [ax attr-exp]
+                                           [bx body-exp]
+                                           [body tests]
+                                           [fail-to fail-k])
+                               (syntax (if (and (pair? x) (eq? 'tag 
(xml-element-tag x)))
+                                           (let ([ax (xml-element-attributes 
x)]
+                                                 [bx (xml-element-contents x)])
+                                             body)
+                                           (fail-to))))
+                             new-pvar-lst
+                             new-cata-defs
+                             new-dotted-vars)))]
+                [(tag . items)
+                 (identifier? (syntax tag))
+                 (let ([body-exp (car (generate-temporaries (list exp)))])
+                   (let-values ([(tests new-pvar-lst new-cata-defs 
new-dotted-vars)
+                                 (compile-item-list (syntax items)
+                                                    body-exp
+                                                    nextp
+                                                    fail-k
+                                                    #t
+                                                    pvar-lst
+                                                    depth
+                                                    cata-fun
+                                                    cata-defs
+                                                    dotted-vars)])
+                     (values (with-syntax ([x exp]
+                                           [bx body-exp]
+                                           [body tests]
+                                           [fail-to fail-k])
+                               (syntax (if (and (pair? x) (eq? 'tag 
(xml-element-tag x)))
+                                           (let ([bx (xml-element-contents x)])
+                                             body)
+                                           (fail-to))))
+                             new-pvar-lst
+                             new-cata-defs
+                             new-dotted-vars)))]))]
+           [compile-end-element
+            (lambda (exp nextp fail-k pvar-lst cata-defs dotted-vars)
+              (let-values ([(next-tests new-pvar-lst new-cata-defs 
new-dotted-vars)
+                            (nextp pvar-lst cata-defs dotted-vars)])
+                (values (with-syntax ([x exp]
+                                      [body next-tests]
+                                      [fail-to fail-k])
+                          (syntax (if (null? x) body (fail-to))))
+                        new-pvar-lst
+                        new-cata-defs
+                        new-dotted-vars)))]
+           [compile-attr-list
+            (lambda (attr-lst body-lst attr-exp body-exp attr-key-lst nextp 
fail-k pvar-lst depth cata-fun cata-defs dotted-vars)
+              (syntax-case attr-lst (unquote ->)
+                [(unquote var)
+                 (identifier? (syntax var))
+                 (let-values ([(tests new-pvar-lst new-cata-defs 
new-dotted-vars)
+                               (compile-item-list body-lst
+                                                  body-exp
+                                                  nextp
+                                                  fail-k
+                                                  #t
+                                                  (add-pat-var (syntax var) 
pvar-lst)
+                                                  depth
+                                                  cata-fun
+                                                  cata-defs
+                                                  dotted-vars)])
+                   (values (with-syntax ([ax attr-exp]
+                                         [matched-attrs attr-key-lst]
+                                         [body tests])
+                             (syntax (let ([var (filter-attributes 
'matched-attrs ax)])
+                                       body)))
+                           new-pvar-lst
+                           new-cata-defs
+                           new-dotted-vars))]
+                [((atag [(unquote [cata -> cvar ...]) default]) . rst)
+                 (identifier? (syntax atag))
+                 (let ([ctemp (car (generate-temporaries (syntax ([cvar 
...]))))])
+                   (let-values ([(tests new-pvar-lst new-cata-defs 
new-dotted-vars)
+                                 (compile-attr-list (syntax rst)
+                                                    body-lst
+                                                    attr-exp
+                                                    body-exp
+                                                    (cons (syntax atag) 
attr-key-lst)
+                                                    nextp
+                                                    fail-k
+                                                    (add-pat-var ctemp 
pvar-lst)
+                                                    depth
+                                                    cata-fun
+                                                    (add-cata-def depth
+                                                                  (syntax 
[cvar ...])
+                                                                  (syntax cata)
+                                                                  ctemp
+                                                                  cata-defs)
+                                                    dotted-vars)])
+                     (values (with-syntax ([ax attr-exp]
+                                           [ct ctemp]
+                                           [body tests])
+                               (syntax (let ([binding (match-xml-attribute 
'atag ax)])
+                                         (let ([ct (if binding
+                                                       (cadr binding)
+                                                       default)])
+                                           body))))
+                             new-pvar-lst
+                             new-cata-defs
+                             new-dotted-vars)))]
+                [((atag [(unquote [cvar ...]) default]) . rst)
+                 (identifier? (syntax atag))
+                 (let ([ctemp (car (generate-temporaries (syntax ([cvar 
...]))))])
+                   (if (not cata-fun)
+                       (sxml-match-syntax-error "sxml-match pattern: 
catamorphism not allowed in this context"
+                                                stx
+                                                (syntax [cvar ...])))
+                   (let-values ([(tests new-pvar-lst new-cata-defs 
new-dotted-vars)
+                                 (compile-attr-list (syntax rst)
+                                                    body-lst
+                                                    attr-exp
+                                                    body-exp
+                                                    (cons (syntax atag) 
attr-key-lst)
+                                                    nextp
+                                                    fail-k
+                                                    (add-pat-var ctemp 
pvar-lst)
+                                                    depth
+                                                    cata-fun
+                                                    (add-cata-def depth
+                                                                  (syntax 
[cvar ...])
+                                                                  cata-fun
+                                                                  ctemp
+                                                                  cata-defs)
+                                                    dotted-vars)])
+                     (values (with-syntax ([ax attr-exp]
+                                           [ct ctemp]
+                                           [body tests])
+                               (syntax (let ([binding (match-xml-attribute 
'atag ax)])
+                                         (let ([ct (if binding
+                                                       (cadr binding)
+                                                       default)])
+                                           body))))
+                             new-pvar-lst
+                             new-cata-defs
+                             new-dotted-vars)))]
+                [((atag [(unquote var) default]) . rst)
+                 (and (identifier? (syntax atag)) (identifier? (syntax var)))
+                 (let-values ([(tests new-pvar-lst new-cata-defs 
new-dotted-vars)
+                               (compile-attr-list (syntax rst)
+                                                  body-lst
+                                                  attr-exp
+                                                  body-exp
+                                                  (cons (syntax atag) 
attr-key-lst)
+                                                  nextp
+                                                  fail-k
+                                                  (add-pat-var (syntax var) 
pvar-lst)
+                                                  depth
+                                                  cata-fun
+                                                  cata-defs
+                                                  dotted-vars)])
+                   (values (with-syntax ([ax attr-exp]
+                                         [body tests])
+                             (syntax (let ([binding (match-xml-attribute 'atag 
ax)])
+                                       (let ([var (if binding
+                                                      (cadr binding)
+                                                      default)])
+                                         body))))
+                           new-pvar-lst
+                           new-cata-defs
+                           new-dotted-vars))]
+                [((atag (unquote [cata -> cvar ...])) . rst)
+                 (identifier? (syntax atag))
+                 (let ([ctemp (car (generate-temporaries (syntax ([cvar 
...]))))])
+                   (let-values ([(tests new-pvar-lst new-cata-defs 
new-dotted-vars)
+                                 (compile-attr-list (syntax rst)
+                                                    body-lst
+                                                    attr-exp
+                                                    body-exp
+                                                    (cons (syntax atag) 
attr-key-lst)
+                                                    nextp
+                                                    fail-k
+                                                    (add-pat-var ctemp 
pvar-lst)
+                                                    depth
+                                                    cata-fun
+                                                    (add-cata-def depth
+                                                                  (syntax 
[cvar ...])
+                                                                  (syntax cata)
+                                                                  ctemp
+                                                                  cata-defs)
+                                                    dotted-vars)])
+                     (values (with-syntax ([ax attr-exp]
+                                           [ct ctemp]
+                                           [body tests]
+                                           [fail-to fail-k])
+                               (syntax (let ([binding (match-xml-attribute 
'atag ax)])
+                                         (if binding
+                                             (let ([ct (cadr binding)])
+                                               body)
+                                             (fail-to)))))
+                             new-pvar-lst
+                             new-cata-defs
+                             new-dotted-vars)))]
+                [((atag (unquote [cvar ...])) . rst)
+                 (identifier? (syntax atag))
+                 (let ([ctemp (car (generate-temporaries (syntax ([cvar 
...]))))])
+                   (if (not cata-fun)
+                       (sxml-match-syntax-error "sxml-match pattern: 
catamorphism not allowed in this context"
+                                                stx
+                                                (syntax [cvar ...])))
+                   (let-values ([(tests new-pvar-lst new-cata-defs 
new-dotted-vars)
+                                 (compile-attr-list (syntax rst)
+                                                    body-lst
+                                                    attr-exp
+                                                    body-exp
+                                                    (cons (syntax atag) 
attr-key-lst)
+                                                    nextp
+                                                    fail-k
+                                                    (add-pat-var ctemp 
pvar-lst)
+                                                    depth
+                                                    cata-fun
+                                                    (add-cata-def depth
+                                                                  (syntax 
[cvar ...])
+                                                                  cata-fun
+                                                                  ctemp
+                                                                  cata-defs)
+                                                    dotted-vars)])
+                     (values (with-syntax ([ax attr-exp]
+                                           [ct ctemp]
+                                           [body tests]
+                                           [fail-to fail-k])
+                               (syntax (let ([binding (match-xml-attribute 
'atag ax)])
+                                         (if binding
+                                             (let ([ct (cadr binding)])
+                                               body)
+                                             (fail-to)))))
+                             new-pvar-lst
+                             new-cata-defs
+                             new-dotted-vars)))]
+                [((atag (unquote var)) . rst)
+                 (and (identifier? (syntax atag)) (identifier? (syntax var)))
+                 (let-values ([(tests new-pvar-lst new-cata-defs 
new-dotted-vars)
+                               (compile-attr-list (syntax rst)
+                                                  body-lst
+                                                  attr-exp
+                                                  body-exp
+                                                  (cons (syntax atag) 
attr-key-lst)
+                                                  nextp
+                                                  fail-k
+                                                  (add-pat-var (syntax var) 
pvar-lst)
+                                                  depth
+                                                  cata-fun
+                                                  cata-defs
+                                                  dotted-vars)])
+                   (values (with-syntax ([ax attr-exp]
+                                         [body tests]
+                                         [fail-to fail-k])
+                             (syntax (let ([binding (match-xml-attribute 'atag 
ax)])
+                                       (if binding
+                                           (let ([var (cadr binding)])
+                                             body)
+                                           (fail-to)))))
+                           new-pvar-lst
+                           new-cata-defs
+                           new-dotted-vars))]
+                [((atag (i ...)) . rst)
+                 (identifier? (syntax atag))
+                 (sxml-match-syntax-error "bad attribute pattern"
+                                          stx
+                                          (syntax (kwd (i ...))))]
+                [((atag i) . rst)
+                 (and (identifier? (syntax atag)) (identifier? (syntax i)))
+                 (sxml-match-syntax-error "bad attribute pattern"
+                                          stx
+                                          (syntax (kwd i)))]
+                [((atag literal) . rst)
+                 (and (identifier? (syntax atag)) (literal? (syntax literal)))
+                 (let-values ([(tests new-pvar-lst new-cata-defs 
new-dotted-vars)
+                               (compile-attr-list (syntax rst)
+                                                  body-lst
+                                                  attr-exp
+                                                  body-exp
+                                                  (cons (syntax atag) 
attr-key-lst)
+                                                  nextp
+                                                  fail-k
+                                                  pvar-lst
+                                                  depth
+                                                  cata-fun
+                                                  cata-defs
+                                                  dotted-vars)])
+                   (values (with-syntax ([ax attr-exp]
+                                         [body tests]
+                                         [fail-to fail-k])
+                             (syntax (let ([binding (match-xml-attribute 'atag 
ax)])
+                                       (if binding
+                                           (if (equal? (cadr binding) literal)
+                                               body
+                                               (fail-to))
+                                           (fail-to)))))
+                           new-pvar-lst
+                           new-cata-defs
+                           new-dotted-vars))]
+                [()
+                 (compile-item-list body-lst
+                                    body-exp
+                                    nextp
+                                    fail-k
+                                    #t
+                                    pvar-lst
+                                    depth
+                                    cata-fun
+                                    cata-defs
+                                    dotted-vars)]))]
+           [compile-item-list
+            (lambda (lst exp nextp fail-k ellipsis-allowed? pvar-lst depth 
cata-fun cata-defs dotted-vars)
+              (syntax-case lst (unquote ->)
+                [() (compile-end-element exp nextp fail-k pvar-lst cata-defs 
dotted-vars)]
+                [(unquote var)
+                 (identifier? (syntax var))
+                 (if (not ellipsis-allowed?)
+                     (sxml-match-syntax-error "improper list pattern not 
allowed in this context"
+                                              stx
+                                              (syntax dots))
+                     (let-values ([(next-tests new-pvar-lst new-cata-defs 
new-dotted-vars)
+                                   (nextp (add-pat-var (syntax var) pvar-lst) 
cata-defs dotted-vars)])
+                       (values (with-syntax ([x exp]
+                                             [body next-tests])
+                                 (syntax (let ([var x]) body)))
+                               new-pvar-lst
+                               new-cata-defs
+                               new-dotted-vars)))]
+                [(unquote [cata -> cvar ...])
+                 (if (not ellipsis-allowed?)
+                     (sxml-match-syntax-error "improper list pattern not 
allowed in this context"
+                                              stx
+                                              (syntax dots))
+                     (let ([ctemp (car (generate-temporaries (syntax ([cvar 
...]))))])
+                       (let-values ([(next-tests new-pvar-lst new-cata-defs 
new-dotted-vars)
+                                     (nextp (add-pat-var ctemp pvar-lst)
+                                            (add-cata-def depth
+                                                          (syntax [cvar ...])
+                                                          (syntax cata)
+                                                          ctemp
+                                                          cata-defs)
+                                            dotted-vars)])
+                         (values (with-syntax ([ct ctemp]
+                                               [x exp]
+                                               [body next-tests])
+                                   (syntax (let ([ct x]) body)))
+                                 new-pvar-lst
+                                 new-cata-defs
+                                 new-dotted-vars))))]
+                [(unquote [cvar ...])
+                 (let ([ctemp (car (generate-temporaries (syntax ([cvar 
...]))))])
+                   (if (not cata-fun)
+                       (sxml-match-syntax-error "sxml-match pattern: 
catamorphism not allowed in this context"
+                                                stx
+                                                (syntax [cvar ...])))
+                   (let-values ([(next-tests new-pvar-lst new-cata-defs 
new-dotted-vars)
+                                 (nextp (add-pat-var ctemp pvar-lst)
+                                        (add-cata-def depth
+                                                      (syntax [cvar ...])
+                                                      cata-fun
+                                                      ctemp
+                                                      cata-defs)
+                                        dotted-vars)])
+                     (values (with-syntax ([ct ctemp]
+                                           [x exp]
+                                           [body next-tests])
+                               (syntax (let ([ct x]) body)))
+                             new-pvar-lst
+                             new-cata-defs
+                             new-dotted-vars)))]
+                [(item dots . rst)
+                 (ellipsis? (syntax dots))
+                 (if (not ellipsis-allowed?)
+                     (sxml-match-syntax-error "ellipses not allowed in this 
context"
+                                              stx
+                                              (syntax dots))
+                     (compile-dotted-pattern-list (syntax item)
+                                                  (syntax rst)
+                                                  exp
+                                                  nextp
+                                                  fail-k
+                                                  pvar-lst
+                                                  depth
+                                                  cata-fun
+                                                  cata-defs
+                                                  dotted-vars))]
+                [(item . rst)
+                 (compile-item (syntax item)
+                               exp
+                               (lambda (new-exp new-pvar-lst new-cata-defs 
new-dotted-vars)
+                                 (compile-item-list (syntax rst)
+                                                    new-exp
+                                                    nextp
+                                                    fail-k
+                                                    ellipsis-allowed?
+                                                    new-pvar-lst
+                                                    depth
+                                                    cata-fun
+                                                    new-cata-defs
+                                                    new-dotted-vars))
+                               fail-k
+                               pvar-lst
+                               depth
+                               cata-fun
+                               cata-defs
+                               dotted-vars)]))]
+           [compile-dotted-pattern-list
+            (lambda (item
+                     tail
+                     exp
+                     nextp
+                     fail-k
+                     pvar-lst
+                     depth
+                     cata-fun
+                     cata-defs
+                     dotted-vars)
+              (let-values ([(tail-tests tail-pvar-lst tail-cata-defs 
tail-dotted-vars)
+                            (compile-item-list tail
+                                               (syntax lst)
+                                               (lambda (new-pvar-lst 
new-cata-defs new-dotted-vars)
+                                                 (values (with-syntax ([(npv 
...) new-pvar-lst])
+                                                           (syntax (values #t 
npv ...)))
+                                                         new-pvar-lst
+                                                         new-cata-defs
+                                                         new-dotted-vars))
+                                               (syntax fail)
+                                               #f
+                                               '()
+                                               depth
+                                               '()
+                                               '()
+                                               dotted-vars)]
+                           [(item-tests item-pvar-lst item-cata-defs 
item-dotted-vars)
+                            (compile-item item
+                                          (syntax lst)
+                                          (lambda (new-exp new-pvar-lst 
new-cata-defs new-dotted-vars)
+                                            (values (with-syntax ([(npv ...) 
new-pvar-lst])
+                                                      (syntax (values #t (cdr 
lst) npv ...)))
+                                                    new-pvar-lst
+                                                    new-cata-defs
+                                                    new-dotted-vars))
+                                          (syntax fail)
+                                          '()
+                                          (+ 1 depth)
+                                          cata-fun
+                                          '()
+                                          dotted-vars)])
+                ; more here: check for duplicate pat-vars, cata-defs
+                (let-values ([(final-tests final-pvar-lst final-cata-defs 
final-dotted-vars)
+                              (nextp (append tail-pvar-lst item-pvar-lst 
pvar-lst)
+                                     (append tail-cata-defs item-cata-defs 
cata-defs)
+                                     (append item-pvar-lst
+                                             (cata-defs->pvar-lst 
item-cata-defs)
+                                             tail-dotted-vars
+                                             dotted-vars))])
+                  (let ([temp-item-pvar-lst (generate-temporaries 
item-pvar-lst)])
+                    (values
+                     (with-syntax
+                         ([x exp]
+                          [fail-to fail-k]
+                          [tail-body tail-tests]
+                          [item-body item-tests]
+                          [final-body final-tests]
+                          [(ipv ...) item-pvar-lst]
+                          [(gpv ...) temp-item-pvar-lst]
+                          [(tpv ...) tail-pvar-lst]
+                          [(item-void ...) (map (lambda (i) (syntax (void))) 
item-pvar-lst)]
+                          [(tail-void ...) (map (lambda (i) (syntax (void))) 
tail-pvar-lst)]
+                          [(item-null ...) (map (lambda (i) (syntax '())) 
item-pvar-lst)]
+                          [(item-cons ...) (map (lambda (a b)
+                                                  (with-syntax ([xa a]
+                                                                [xb b])
+                                                    (syntax (cons xa xb))))
+                                                item-pvar-lst
+                                                temp-item-pvar-lst)])
+                       (syntax (letrec ([match-tail
+                                         (lambda (lst fail)
+                                           tail-body)]
+                                        [match-item
+                                         (lambda (lst)
+                                           (let ([fail (lambda ()
+                                                         (values #f
+                                                                 lst
+                                                                 item-void 
...))])
+                                             item-body))]
+                                        [match-dotted
+                                         (lambda (x)
+                                           (let-values ([(tail-res tpv ...)
+                                                         (match-tail x
+                                                                     (lambda ()
+                                                                       (values 
#f
+                                                                               
tail-void ...)))])
+                                             (if tail-res
+                                                 (values item-null ...
+                                                         tpv ...)
+                                                 (let-values ([(res new-x ipv 
...) (match-item x)])
+                                                   (if res
+                                                       (let-values ([(gpv ... 
tpv ...)
+                                                                     
(match-dotted new-x)])
+                                                         (values item-cons ... 
tpv ...))
+                                                       (let-values 
([(last-tail-res tpv ...)
+                                                                     
(match-tail x fail-to)])
+                                                         (values item-null ... 
tpv ...)))))))])
+                                 (let-values ([(ipv ... tpv ...)
+                                               (match-dotted x)])
+                                   final-body))))
+                     final-pvar-lst
+                     final-cata-defs
+                     final-dotted-vars)))))]
+           [compile-item
+            (lambda (item exp nextp fail-k pvar-lst depth cata-fun cata-defs 
dotted-vars)
+              (syntax-case item (unquote ->)
+                ; normal pattern var
+                [(unquote var)
+                 (identifier? (syntax var))
+                 (let ([new-exp (car (generate-temporaries (list exp)))])
+                   (let-values ([(next-tests new-pvar-lst new-cata-defs 
new-dotted-vars)
+                                 (nextp new-exp (add-pat-var (syntax var) 
pvar-lst) cata-defs dotted-vars)])
+                     (values (with-syntax ([x exp]
+                                           [nx new-exp]
+                                           [body next-tests]
+                                           [fail-to fail-k])
+                               (syntax (if (pair? x)
+                                           (let ([nx (cdr x)]
+                                                 [var (car x)])
+                                             body)
+                                           (fail-to))))
+                             new-pvar-lst
+                             new-cata-defs
+                             new-dotted-vars)))]
+                ; named catamorphism
+                [(unquote [cata -> cvar ...])
+                 (let ([new-exp (car (generate-temporaries (list exp)))]
+                       [ctemp (car (generate-temporaries (syntax ([cvar 
...]))))])
+                   (let-values ([(next-tests new-pvar-lst new-cata-defs 
new-dotted-vars)
+                                 (nextp new-exp
+                                        (add-pat-var ctemp pvar-lst)
+                                        (add-cata-def depth
+                                                      (syntax [cvar ...])
+                                                      (syntax cata)
+                                                      ctemp
+                                                      cata-defs)
+                                        dotted-vars)])
+                     (values (with-syntax ([x exp]
+                                           [nx new-exp]
+                                           [ct ctemp]
+                                           [body next-tests]
+                                           [fail-to fail-k])
+                               (syntax (if (pair? x)
+                                           (let ([nx (cdr x)]
+                                                 [ct (car x)])
+                                             body)
+                                           (fail-to))))
+                             new-pvar-lst
+                             new-cata-defs
+                             new-dotted-vars)))]
+                ; basic catamorphism
+                [(unquote [cvar ...])
+                 (let ([new-exp (car (generate-temporaries (list exp)))]
+                       [ctemp (car (generate-temporaries (syntax ([cvar 
...]))))])
+                   (if (not cata-fun)
+                       (sxml-match-syntax-error "sxml-match pattern: 
catamorphism not allowed in this context"
+                                                stx
+                                                (syntax [cvar ...])))
+                   (let-values ([(next-tests new-pvar-lst new-cata-defs 
new-dotted-vars)
+                                 (nextp new-exp
+                                        (add-pat-var ctemp pvar-lst)
+                                        (add-cata-def depth
+                                                      (syntax [cvar ...])
+                                                      cata-fun
+                                                      ctemp
+                                                      cata-defs)
+                                        dotted-vars)])
+                     (values (with-syntax ([x exp]
+                                           [nx new-exp]
+                                           [ct ctemp]
+                                           [body next-tests]
+                                           [fail-to fail-k])
+                               (syntax (if (pair? x)
+                                           (let ([nx (cdr x)]
+                                                 [ct (car x)])
+                                             body)
+                                           (fail-to))))
+                             new-pvar-lst
+                             new-cata-defs
+                             new-dotted-vars)))]
+                [(tag item ...)
+                 (identifier? (syntax tag))
+                 (let ([new-exp (car (generate-temporaries (list exp)))])
+                   (let-values ([(after-tests after-pvar-lst after-cata-defs 
after-dotted-vars)
+                                 (compile-element-pat (syntax (tag item ...))
+                                                      (with-syntax ([x exp])
+                                                        (syntax (car x)))
+                                                      (lambda (more-pvar-lst 
more-cata-defs more-dotted-vars)
+                                                        (let-values 
([(next-tests new-pvar-lst
+                                                                               
   new-cata-defs
+                                                                               
   new-dotted-vars)
+                                                                      (nextp 
new-exp
+                                                                             
more-pvar-lst
+                                                                             
more-cata-defs
+                                                                             
more-dotted-vars)])
+                                                          (values (with-syntax 
([x exp]
+                                                                               
 [nx new-exp]
+                                                                               
 [body next-tests])
+                                                                    (syntax 
(let ([nx (cdr x)])
+                                                                              
body)))
+                                                                  new-pvar-lst
+                                                                  new-cata-defs
+                                                                  
new-dotted-vars)))
+                                                      fail-k
+                                                      pvar-lst
+                                                      depth
+                                                      cata-fun
+                                                      cata-defs
+                                                      dotted-vars)])
+                     ; test that we are not at the end of an item-list, BEFORE
+                     ; entering tests for the element pattern (against the 
'car' of the item-list)
+                     (values (with-syntax ([x exp]
+                                           [body after-tests]
+                                           [fail-to fail-k])
+                               (syntax (if (pair? x)
+                                           body
+                                           (fail-to))))
+                             after-pvar-lst
+                             after-cata-defs
+                             after-dotted-vars)))]
+                [(i ...)
+                 (sxml-match-syntax-error "bad pattern syntax (not an element 
pattern)"
+                                          stx
+                                          (syntax (i ...)))]
+                [i
+                 (identifier? (syntax i))
+                 (sxml-match-syntax-error "bad pattern syntax (symbol not 
allowed in this context)"
+                                          stx
+                                          (syntax i))]
+                [literal
+                 (literal? (syntax literal))
+                 (let ([new-exp (car (generate-temporaries (list exp)))])
+                   (let-values ([(next-tests new-pvar-lst new-cata-defs 
new-dotted-vars)
+                                 (nextp new-exp pvar-lst cata-defs 
dotted-vars)])
+                     (values (with-syntax ([x exp]
+                                           [nx new-exp]
+                                           [body next-tests]
+                                           [fail-to fail-k])
+                               (syntax (if (and (pair? x) (equal? literal (car 
x)))
+                                           (let ([nx (cdr x)])
+                                             body)
+                                           (fail-to))))
+                             new-pvar-lst
+                             new-cata-defs
+                             new-dotted-vars)))]))])
+        (let ([fail-k (syntax failure)])
+          (syntax-case stx (unquote guard ->)
+            [(compile-clause ((unquote var) (guard gexp ...) action0 action 
...)
+                             exp
+                             cata-fun
+                             fail-exp)
+             (identifier? (syntax var))
+             (syntax (let ([var exp])
+                       (if (and gexp ...)
+                           (begin action0 action ...)
+                           (fail-exp))))]
+            [(compile-clause ((unquote [cata -> cvar ...]) (guard gexp ...) 
action0 action ...)
+                             exp
+                             cata-fun
+                             fail-exp)
+             (syntax (if (and gexp ...)
+                         (let-values ([(cvar ...) (cata exp)])
+                           (begin action0 action ...))
+                         (fail-exp)))]
+            [(compile-clause ((unquote [cvar ...]) (guard gexp ...) action0 
action ...)
+                             exp
+                             cata-fun
+                             fail-exp)
+             (if (not (extract-cata-fun (syntax cata-fun)))
+                 (sxml-match-syntax-error "sxml-match pattern: catamorphism 
not allowed in this context"
+                                          stx
+                                          (syntax [cvar ...]))
+                 (syntax (if (and gexp ...)
+                             (let-values ([(cvar ...) (cata-fun exp)])
+                               (begin action0 action ...))
+                             (fail-exp))))]
+            [(compile-clause ((unquote var) action0 action ...) exp cata-fun 
fail-exp)
+             (identifier? (syntax var))
+             (syntax (let ([var exp])
+                       action0 action ...))]
+            [(compile-clause ((unquote [cata -> cvar ...]) action0 action ...) 
exp cata-fun fail-exp)
+             (syntax (let-values ([(cvar ...) (cata exp)])
+                       action0 action ...))]
+            [(compile-clause ((unquote [cvar ...]) action0 action ...) exp 
cata-fun fail-exp)
+             (if (not (extract-cata-fun (syntax cata-fun)))
+                 (sxml-match-syntax-error "sxml-match pattern: catamorphism 
not allowed in this context"
+                                          stx
+                                          (syntax [cvar ...]))
+                 (syntax (let-values ([(cvar ...) (cata-fun exp)])
+                           action0 action ...)))]
+            [(compile-clause ((lst . rst) (guard gexp ...) action0 action ...) 
exp cata-fun fail-exp)
+             (and (identifier? (syntax lst)) (eq? 'list (syntax-object->datum 
(syntax lst))))
+             (let-values ([(result pvar-lst cata-defs dotted-vars)
+                           (compile-item-list (syntax rst)
+                                              (syntax exp)
+                                              (lambda (new-pvar-lst 
new-cata-defs new-dotted-vars)
+                                                (values
+                                                 (with-syntax
+                                                     ([exp-body 
(process-cata-defs new-cata-defs
+                                                                               
    (process-output-action
+                                                                               
     (syntax (begin action0
+                                                                               
                    action ...))
+                                                                               
     new-dotted-vars))]
+                                                      [fail-to fail-k])
+                                                   (syntax (if (and gexp ...) 
exp-body (fail-to))))
+                                                 new-pvar-lst
+                                                 new-cata-defs
+                                                 new-dotted-vars))
+                                              fail-k
+                                              #t
+                                              '()
+                                              0
+                                              (extract-cata-fun (syntax 
cata-fun))
+                                              '()
+                                              '())])
+               (with-syntax ([fail-to fail-k]
+                             [body result])
+                 (syntax (let ([fail-to fail-exp])
+                           (if (nodeset? exp)
+                               body
+                               (fail-to))))))]
+            [(compile-clause ((lst . rst) action0 action ...) exp cata-fun 
fail-exp)
+             (and (identifier? (syntax lst)) (eq? 'list (syntax-object->datum 
(syntax lst))))
+             (let-values ([(result pvar-lst cata-defs dotted-vars)
+                           (compile-item-list (syntax rst)
+                                              (syntax exp)
+                                              (lambda (new-pvar-lst 
new-cata-defs new-dotted-vars)
+                                                (values (process-cata-defs 
new-cata-defs
+                                                                           
(process-output-action
+                                                                            
(syntax (begin action0
+                                                                               
            action ...))
+                                                                            
new-dotted-vars))
+                                                        new-pvar-lst
+                                                        new-cata-defs
+                                                        new-dotted-vars))
+                                              fail-k
+                                              #t
+                                              '()
+                                              0
+                                              (extract-cata-fun (syntax 
cata-fun))
+                                              '()
+                                              '())])
+               (with-syntax ([body result]
+                             [fail-to fail-k])
+                 (syntax (let ([fail-to fail-exp])
+                           (if (nodeset? exp)
+                               body
+                               (fail-to))))))]
+            [(compile-clause ((fst . rst) (guard gexp ...) action0 action ...) 
exp cata-fun fail-exp)
+             (identifier? (syntax fst))
+             (let-values ([(result pvar-lst cata-defs dotted-vars)
+                           (compile-element-pat (syntax (fst . rst))
+                                                (syntax exp)
+                                                (lambda (new-pvar-lst 
new-cata-defs new-dotted-vars)
+                                                  (values
+                                                   (with-syntax
+                                                       ([body 
(process-cata-defs new-cata-defs
+                                                                               
  (process-output-action
+                                                                               
   (syntax (begin action0
+                                                                               
                  action ...))
+                                                                               
   new-dotted-vars))]
+                                                        [fail-to fail-k])
+                                                     (syntax (if (and gexp 
...) body (fail-to))))
+                                                   new-pvar-lst
+                                                   new-cata-defs
+                                                   new-dotted-vars))
+                                                fail-k
+                                                '()
+                                                0
+                                                (extract-cata-fun (syntax 
cata-fun))
+                                                '()
+                                                '())])
+               (with-syntax ([fail-to fail-k]
+                             [body result])
+                 (syntax (let ([fail-to fail-exp])
+                           body))))]
+            [(compile-clause ((fst . rst) action0 action ...) exp cata-fun 
fail-exp)
+             (identifier? (syntax fst))
+             (let-values ([(result pvar-lst cata-defs dotted-vars)
+                           (compile-element-pat (syntax (fst . rst))
+                                                (syntax exp)
+                                                (lambda (new-pvar-lst 
new-cata-defs new-dotted-vars)
+                                                  (values (process-cata-defs 
new-cata-defs
+                                                                             
(process-output-action
+                                                                              
(syntax (begin action0
+                                                                               
              action ...))
+                                                                              
new-dotted-vars))
+                                                          new-pvar-lst
+                                                          new-cata-defs
+                                                          new-dotted-vars))
+                                                fail-k
+                                                '()
+                                                0
+                                                (extract-cata-fun (syntax 
cata-fun))
+                                                '()
+                                                '())])
+               (with-syntax ([fail-to fail-k]
+                             [body result])
+                 (syntax (let ([fail-to fail-exp])
+                           body))))]
+            [(compile-clause ((i ...) (guard gexp ...) action0 action ...) exp 
cata-fun fail-exp)
+             (sxml-match-syntax-error "bad pattern syntax (not an element 
pattern)"
+                                      stx
+                                      (syntax (i ...)))]
+            [(compile-clause ((i ...) action0 action ...) exp cata-fun 
fail-exp)
+             (sxml-match-syntax-error "bad pattern syntax (not an element 
pattern)"
+                                      stx
+                                      (syntax (i ...)))]
+            [(compile-clause (pat (guard gexp ...) action0 action ...) exp 
cata-fun fail-exp)
+             (identifier? (syntax pat))
+             (sxml-match-syntax-error "bad pattern syntax (symbol not allowed 
in this context)"
+                                      stx
+                                      (syntax pat))]
+            [(compile-clause (pat action0 action ...) exp cata-fun fail-exp)
+             (identifier? (syntax pat))
+             (sxml-match-syntax-error "bad pattern syntax (symbol not allowed 
in this context)"
+                                      stx
+                                      (syntax pat))]
+            [(compile-clause (literal (guard gexp ...) action0 action ...) exp 
cata-fun fail-exp)
+             (literal? (syntax literal))
+             (syntax (if (and (equal? literal exp) (and gexp ...))
+                         (begin action0 action ...)
+                         (fail-exp)))]
+            [(compile-clause (literal action0 action ...) exp cata-fun 
fail-exp)
+             (literal? (syntax literal))
+             (syntax (if (equal? literal exp)
+                         (begin action0 action ...)
+                         (fail-exp)))])))))
+  
+  (define-syntax sxml-match1
+    (syntax-rules ()
+      [(sxml-match1 exp cata-fun clause)
+       (compile-clause clause exp cata-fun
+                       (lambda () (error 'sxml-match "no matching clause 
found")))]
+      [(sxml-match1 exp cata-fun clause0 clause ...)
+       (let/ec escape
+         (compile-clause clause0 exp cata-fun
+                         (lambda () (escape (sxml-match1 exp cata-fun clause 
...)))))]))
+  
+  (define-syntax sxml-match
+    (syntax-rules ()
+      ((sxml-match val clause0 clause ...)
+       (letrec ([cfun (lambda (exp)
+                        (sxml-match1 exp cfun clause0 clause ...))])
+         (cfun val)))))
+  
+  (define-syntax sxml-match-let1
+    (syntax-rules ()
+      [(sxml-match-let1 syntag synform () body0 body ...)
+       (let () body0 body ...)]
+      [(sxml-match-let1 syntag synform ([pat exp]) body0 body ...)
+       (compile-clause (pat (let () body0 body ...))
+                       exp
+                       #f
+                       (lambda () (error 'syntag "could not match pattern ~s" 
'pat)))]
+      [(sxml-match-let1 syntag synform ([pat0 exp0] [pat exp] ...) body0 body 
...)
+       (compile-clause (pat0 (sxml-match-let1 syntag synform ([pat exp] ...) 
body0 body ...))
+                       exp0
+                       #f
+                       (lambda () (error 'syntag "could not match pattern ~s" 
'pat0)))]))
+  
+  (define-syntax sxml-match-let-help
+    (lambda (stx)
+      (syntax-case stx ()
+        [(sxml-match-let-help syntag synform ([pat exp] ...) body0 body ...)
+         (with-syntax ([(temp-name ...) (generate-temporaries (syntax (exp 
...)))])
+           (syntax (let ([temp-name exp] ...)
+                     (sxml-match-let1 syntag synform ([pat temp-name] ...) 
body0 body ...))))])))
+  
+  (define-syntax sxml-match-let
+    (lambda (stx)
+      (syntax-case stx ()
+        [(sxml-match-let ([pat exp] ...) body0 body ...)
+         (with-syntax ([synform stx])
+           (syntax (sxml-match-let-help sxml-match-let synform ([pat exp] ...) 
body0 body ...)))])))
+  
+  (define-syntax sxml-match-let*
+    (lambda (stx)
+      (syntax-case stx ()
+        [(sxml-match-let* () body0 body ...)
+         (syntax (let () body0 body ...))]
+        [(sxml-match-let* ([pat0 exp0] [pat exp] ...) body0 body ...)
+         (with-syntax ([synform stx])
+           (syntax (sxml-match-let-help sxml-match-let* synform ([pat0 exp0])
+                                        (sxml-match-let* ([pat exp] ...)
+                                                         body0 body ...))))])))
+  
+  )
+
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 51870e6..2c1f229 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -121,6 +121,7 @@ SCM_TESTS = tests/00-initial-env.test               \
            tests/strings.test                  \
            tests/structs.test                  \
            tests/sxml.fold.test                \
+           tests/sxml.match.test               \
            tests/sxml.simple.test              \
            tests/sxml.ssax.test                \
            tests/sxml.transform.test           \
@@ -187,4 +188,4 @@ LALR_EXTRA +=                                       \
 TESTS = $(LALR_TESTS)
 TESTS_ENVIRONMENT = $(top_builddir)/meta/guile --no-autocompile
 
-EXTRA_DIST += $(LALR_EXTRA) $(LALR_TESTS)
+EXTRA_DIST += $(LALR_EXTRA) $(LALR_TESTS) tests/sxml-match-tests.ss
diff --git a/test-suite/tests/lua-lexer.test b/test-suite/tests/lua-lexer.test
index 400af94..3371d83 100644
--- a/test-suite/tests/lua-lexer.test
+++ b/test-suite/tests/lua-lexer.test
@@ -30,27 +30,41 @@
 ;; Test return value of lexer against a token
 (define-syntax token
   (syntax-rules ()
+    ((_ name)
+     (let ((str (symbol->string name)))
+       (token str str name *unspecified*)))
     ((_ name string result-type result-value)
      (pass-if name
        (token-equal=?
         result-type result-value
         (read-token-from-string string))))))
 
-;; Assert that no token is returned (such as if a comment is consumed)
+;; Test that no token is returned (such as if a comment is consumed)
 (define-syntax no-token
   (syntax-rules ()
     ((_ name string)
      (pass-if name
        (equal? #f (read-token-from-string string))))))
 
+(define-syntax atom
+  (syntax-rules ()
+    ((_ name)
+     (let ((str (symbol->string name)))
+       (token str str name)))))
+
 (with-test-prefix "lua"
   ;; Strings
-  (display (read-token-from-string "\"hello world\""))
-  (newline)
-  
   (token "string" "\"hello world\"" 'string "hello world")
   (eof "string without end quote" "\"hell")
 
+  ;; True, false, nil
+  (token 'nil)
+  (token 'true)
+  (token 'false)
+  
+  ;; Identifiers
+  (token "identifier" "my_identifier" 'identifier 'my_identifier)
+  
   ;; Comments
   (no-token "comment" "-- comment")
   
diff --git a/test-suite/tests/sxml-match-tests.ss 
b/test-suite/tests/sxml-match-tests.ss
new file mode 100644
index 0000000..39772b4
--- /dev/null
+++ b/test-suite/tests/sxml-match-tests.ss
@@ -0,0 +1,301 @@
+(define-syntax compile-match
+  (syntax-rules ()
+    [(compile-match pat action0 action ...)
+     (lambda (x)
+       (sxml-match x [pat action0 action ...]))]))
+
+(run-test "basic match of a top-level pattern var"
+          (sxml-match '(e 3 4 5)
+                      [,y (list "matched" y)])
+          '("matched" (e 3 4 5)))
+(run-test "match of simple element contents with pattern vars"
+          ((compile-match (e ,a ,b ,c) (list a b c)) '(e 3 4 5))
+          '(3 4 5))
+(run-test "match a literal pattern within a element pattern"
+          ((compile-match (e ,a "abc" ,c) (list a c)) '(e 3 "abc" 5))
+          '(3 5))
+(run-test "match an empty element"
+          ((compile-match (e) "match") '(e))
+          "match")
+(run-test "match a nested element"
+          ((compile-match (e ,a (f ,b ,c) ,d) (list a b c d)) '(e 3 (f 4 5) 6))
+          '(3 4 5 6))
+(run-test "match a dot-rest pattern within a nested element"
+          ((compile-match (e ,a (f . ,y) ,d) (list a y d)) '(e 3 (f 4 5) 6))
+          '(3 (4 5) 6))
+(run-test "match a basic list pattern"
+          ((compile-match (list ,a ,b ,c ,d ,e) (list a b c d e)) '("i" "j" 
"k" "l" "m"))
+          '("i" "j" "k" "l" "m"))
+(run-test "match a list pattern with a dot-rest pattern"
+          ((compile-match (list ,a ,b ,c . ,y) (list a b c y)) '("i" "j" "k" 
"l" "m"))
+          '("i" "j" "k" ("l" "m")))
+(run-test "basic test of a multi-clause sxml-match"
+          (sxml-match '(a 1 2 3)
+                      ((a ,n) n)
+                      ((a ,m ,n) (+ m n))
+                      ((a ,m ,n ,o) (list "matched" (list m n o))))
+          '("matched" (1 2 3)))
+(run-test "basic test of a sxml-match-let"
+          (sxml-match-let ([(a ,i ,j) '(a 1 2)])
+                          (+ i j))
+          3)
+(run-test "basic test of a sxml-match-let*"
+          (sxml-match-let* ([(a ,k) '(a (b 1 2))]
+                            [(b ,i ,j) k])
+                           (list i j))
+          '(1 2))
+(run-test "match of top-level literal string pattern"
+          ((compile-match "abc" "match") "abc")
+          "match")
+(run-test "match of top-level literal number pattern"
+          ((compile-match 77 "match") 77)
+          "match")
+(run-test "test of multi-expression guard in pattern"
+          (sxml-match '(a 1 2 3)
+                      ((a ,n) n)
+                      ((a ,m ,n) (+ m n))
+                      ((a ,m ,n ,o) (guard (number? m) (number? n) (number? 
o)) (list "guarded-matched" (list m n o))))
+          '("guarded-matched" (1 2 3)))
+(run-test "basic test of multiple action items in match clause"
+          ((compile-match 77 (display "") "match") 77)
+          "match")
+
+(define simple-eval
+  (lambda (x)
+    (sxml-match x
+                [,i (guard (integer? i)) i]
+                [(+ ,x ,y) (+ (simple-eval x) (simple-eval y))]
+                [(* ,x ,y) (* (simple-eval x) (simple-eval y))]
+                [(- ,x ,y) (- (simple-eval x) (simple-eval y))]
+                [(/ ,x ,y) (/ (simple-eval x) (simple-eval y))]
+                [,otherwise (error "simple-eval: invalid expression" x)])))
+
+(run-test "basic test of explicit recursion in match clauses"
+          (simple-eval '(* (+ 7 3) (- 7 3)))
+          40)
+
+(define simple-eval2
+  (lambda (x)
+    (sxml-match x
+                [,i (guard (integer? i)) i]
+                [(+ ,[x] ,[y]) (+ x y)]
+                [(* ,[x] ,[y]) (* x y)]
+                [(- ,[x] ,[y]) (- x y)]
+                [(/ ,[x] ,[y]) (/ x y)]
+                [,otherwise (error "simple-eval: invalid expression" x)])))
+
+(run-test "basic test of anonymous catas"
+          (simple-eval2 '(* (+ 7 3) (- 7 3)))
+          40)
+
+(define simple-eval3
+  (lambda (x)
+    (sxml-match x
+                [,i (guard (integer? i)) i]
+                [(+ ,[simple-eval3 -> x] ,[simple-eval3 -> y]) (+ x y)]
+                [(* ,[simple-eval3 -> x] ,[simple-eval3 -> y]) (* x y)]
+                [(- ,[simple-eval3 -> x] ,[simple-eval3 -> y]) (- x y)]
+                [(/ ,[simple-eval3 -> x] ,[simple-eval3 -> y]) (/ x y)]
+                [,otherwise (error "simple-eval: invalid expression" x)])))
+
+(run-test "test of named catas"
+          (simple-eval3 '(* (+ 7 3) (- 7 3)))
+          40)
+
+; need a test case for cata on a ". rest)" pattern
+
+(run-test "successful test of attribute matching: pat-var in value position"
+          (sxml-match '(e (@ (z 1)) 3 4 5)
+                      [(e (@ (z ,d)) ,a ,b ,c) (list d a b c)]
+                      [,otherwise #f])
+          '(1 3 4 5))
+
+(run-test "failing test of attribute matching: pat-var in value position"
+          (sxml-match '(e (@ (a 1)) 3 4 5)
+                      [(e (@ (z ,d)) ,a ,b ,c) (list d a b c)]
+                      [,otherwise #f])
+          #f)
+
+(run-test "test of attribute matching: literal in value position"
+          ((compile-match (e (@ (z 1)) ,a ,b ,c) (list a b c)) '(e (@ (z 1)) 3 
4 5))
+          '(3 4 5))
+
+(run-test "test of attribute matching: default-value spec in value position"
+          ((compile-match (e (@ (z (,d 1))) ,a ,b ,c) (list d a b c)) '(e 3 4 
5))
+          '(1 3 4 5))
+
+(run-test "test of attribute matching: multiple attributes in pattern"
+          ((compile-match (e (@ (y ,e) (z ,d)) ,a ,b ,c) (list e d a b c)) '(e 
(@ (z 1) (y 2)) 3 4 5))
+          '(2 1 3 4 5))
+
+(run-test "basic test of ellipses in pattern; no ellipses in output"
+          ((compile-match (e ,i ...) i) '(e 3 4 5))
+          '(3 4 5))
+
+(run-test "test of non-null tail pattern following ellipses"
+          ((compile-match (e ,i ... ,a ,b) i) '(e 3 4 5 6 7))
+          '(3 4 5 ))
+
+(define simple-eval4
+  (lambda (x)
+    (sxml-match x
+                [,i (guard (integer? i)) i]
+                [(+ ,[x*] ...) (apply + x*)]
+                [(* ,[x*] ...) (apply * x*)]
+                [(- ,[x] ,[y]) (- x y)]
+                [(/ ,[x] ,[y]) (/ x y)]
+                [,otherwise (error "simple-eval: invalid expression" x)])))
+
+(run-test "test of catas with ellipses in pattern"
+          (simple-eval4 '(* (+ 7 3) (- 7 3)))
+          40)
+
+(run-test "simple test of ellipses in pattern and output"
+          ((compile-match (e ,i ...) ((lambda rst (cons 'f rst)) i ...)) '(e 3 
4 5))
+          '(f 3 4 5))
+
+(define simple-eval5
+  (lambda (x)
+    (sxml-match x
+                [,i (guard (integer? i)) i]
+                [(+ ,[x*] ...) (+ x* ...)]
+                [(* ,[x*] ...) (* x* ...)]
+                [(- ,[x] ,[y]) (- x y)]
+                [(/ ,[x] ,[y]) (/ x y)]
+                [,otherwise (error "simple-eval: invalid expression" x)])))
+
+(run-test "test of catas with ellipses in pattern and output"
+          (simple-eval5 '(* (+ 7 3) (- 7 3)))
+          40)
+
+(run-test "test of nested dots in pattern and output"
+          ((lambda (x)
+             (sxml-match x
+                         [(d (a ,b ...) ...)
+                          (list (list b ...) ...)]))
+           '(d (a 1 2 3) (a 4 5) (a 6 7 8) (a 9 10)))
+          '((1 2 3) (4 5) (6 7 8) (9 10)))
+
+(run-test "test successful tail pattern match (after ellipses)"
+          (sxml-match '(e 3 4 5 6 7) ((e ,i ... 6 7) #t) (,otherwise #f))
+          #t)
+
+(run-test "test failing tail pattern match (after ellipses), too few items"
+          (sxml-match '(e 3 4 5 6) ((e ,i ... 6 7) #t) (,otherwise #f))
+          #f)
+
+(run-test "test failing tail pattern match (after ellipses), too many items"
+          (sxml-match '(e 3 4 5 6 7 8) ((e ,i ... 6 7) #t) (,otherwise #f))
+          #f)
+
+(run-test "test failing tail pattern match (after ellipses), wrong items"
+          (sxml-match '(e 3 4 5 7 8) ((e ,i ... 6 7) #t) (,otherwise #f))
+          #f)
+
+(run-test "test of ellipses in output quasiquote"
+          (sxml-match '(e 3 4 5 6 7)
+                      [(e ,i ... 6 7) `("start" ,i ... "end")]
+                      [,otherwise #f])
+          '("start" 3 4 5 "end"))
+
+(run-test "test of ellipses in output quasiquote, with more complex unquote 
expression"
+          (sxml-match '(e 3 4 5 6 7)
+                      [(e ,i ... 6 7) `("start" ,(list 'wrap i) ... "end")]
+                      [,otherwise #f])
+          '("start" (wrap 3) (wrap 4) (wrap 5) "end"))
+
+(run-test "test of a quasiquote expr within the dotted unquote expression"
+          (sxml-match '(e 3 4 5 6 7)
+                      [(e ,i ... 6 7) `("start" ,`(wrap ,i) ... "end")]
+                      [,otherwise #f])
+          '("start" (wrap 3) (wrap 4) (wrap 5) "end"))
+
+(define xyzpq '(d (a 1 2 3) (a 4 5) (a 6 7 8) (a 9 10)))
+
+(run-test "quasiquote tests"
+          (sxml-match xyzpq
+                      [(d (a ,b ...) ...)
+                       `(,`(,b ...) ...)])
+          '((1 2 3) (4 5) (6 7 8) (9 10)))
+
+(run-test "quasiquote tests"
+          (sxml-match xyzpq
+                      [(d (a ,b ...) ...)
+                       (list (list b ...) ...)])
+          '((1 2 3) (4 5) (6 7 8) (9 10)))
+
+(run-test "quasiquote tests"
+          (sxml-match xyzpq
+                      [(d (a ,b ...) ...)
+                       `(xx ,`(y ,b ...) ...)])
+          '(xx (y 1 2 3) (y 4 5) (y 6 7 8) (y 9 10)))
+
+(run-test "quasiquote tests"
+          (sxml-match xyzpq
+                      [(d (a ,b ...) ...)
+                       `(xx ,@(map (lambda (i) `(y ,@i)) b))])
+          '(xx (y 1 2 3) (y 4 5) (y 6 7 8) (y 9 10)))
+
+(run-test "quasiquote tests"
+          (sxml-match xyzpq
+                      [(d (a ,b ...) ...)
+                       `(xx ,(cons 'y b) ...)])
+          '(xx (y 1 2 3) (y 4 5) (y 6 7 8) (y 9 10)))
+
+(run-test "quasiquote tests"
+          (sxml-match xyzpq
+                      [(d (a ,b ...) ...)
+                       `(xx ,`(y ,b ...) ...)])
+          '(xx (y 1 2 3) (y 4 5) (y 6 7 8) (y 9 10)))
+
+(run-test "quasiquote tests"
+          (sxml-match xyzpq
+                      [(d (a ,b ...) ...)
+                       `(xx ,`(y ,@b) ...)])
+          '(xx (y 1 2 3) (y 4 5) (y 6 7 8) (y 9 10)))
+
+(run-test "quasiquote tests"
+          (sxml-match xyzpq
+                      [(d (a ,b ...) ...)
+                       `((,b ...) ...)])
+          '((1 2 3) (4 5) (6 7 8) (9 10)))
+
+(run-test "quasiquote tests"
+          (sxml-match xyzpq
+                      [(d (a ,b ...) ...)
+                       `(xx (y ,b ...) ...)])
+          '(xx (y 1 2 3) (y 4 5) (y 6 7 8) (y 9 10)))
+
+(define (prog-trans p)
+  (sxml-match p
+              [(Program (Start ,start-time) (Duration ,dur) (Series 
,series-title)
+                        (Description . ,desc)
+                        ,cl)
+               `(div (p ,start-time
+                        (br) ,series-title
+                        (br) ,desc)
+                     ,cl)]
+              [(Program (Start ,start-time) (Duration ,dur) (Series 
,series-title)
+                        (Description . ,desc))
+               `(div (p ,start-time
+                        (br) ,series-title
+                        (br) ,desc))]
+              [(Program (Start ,start-time) (Duration ,dur) (Series 
,series-title))
+               `(div (p ,start-time
+                        (br) ,series-title))]))
+
+(run-test "test for shrinking-order list of pattern clauses"
+          (prog-trans '(Program (Start "2001-07-05T20:00:00") (Duration 
"PT1H") (Series "HomeFront")))
+          '(div (p "2001-07-05T20:00:00" (br) "HomeFront")))
+
+(run-test "test binding of unmatched attributes"
+          (sxml-match '(a (@ (z 1) (y 2) (x 3)) 4 5 6)
+                      [(a (@ (y ,www) . ,qqq) ,t ...)
+                       (list www qqq t ...)])
+          '(2 ((z 1) (x 3)) 4 5 6))
+
+(run-test "test binding all attributes"
+          (sxml-match '(a (@ (z 1) (y 2) (x 3)) 4 5 6)
+                      [(a (@ . ,qqq) ,t ...)
+                       (list qqq t ...)])
+          '(((z 1) (y 2) (x 3)) 4 5 6))
diff --git a/test-suite/tests/sxml.match.test b/test-suite/tests/sxml.match.test
new file mode 100644
index 0000000..b3dbbe7
--- /dev/null
+++ b/test-suite/tests/sxml.match.test
@@ -0,0 +1,45 @@
+;;;; sxml.simple.test --- (sxml simple)  -*- mode: scheme; coding: utf-8; -*-
+;;;;
+;;;;   Copyright (C) 2010 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 
USA
+
+(define-module (test-sxml-match)
+  #:use-module (test-suite lib)
+  #:use-module (sxml match))
+
+(define-syntax run-test
+  (syntax-rules ()
+    ((_ desc test expected-result)
+     (pass-if desc (equal? test expected-result)))))
+
+
+;;;
+;;; Include upstream source file.
+;;;
+
+;; This file was taken unmodified from
+;; <http://planet.plt-scheme.org/package-source/jim/sxml-match.plt/1/1/> on
+;; 2010-05-24.  It was written by Jim Bender <address@hidden> and released
+;; under the MIT/X11 license
+;; <http://www.gnu.org/licenses/license-list.html#X11License>.
+;;
+;; It was modified to remove the `#lang' and `require' forms as well as the
+;; `run-test' macro, replaced by the one above.
+;;
+;; FIXME: The `xyzpq' variable in there is originally named `x' but using that
+;; name triggers a psyntax "identifier out of context" error.
+
+(include-from-path "test-suite/tests/sxml-match-tests.ss")


hooks/post-receive
-- 
GNU Guile



reply via email to

[Prev in Thread] Current Thread [Next in Thread]