Add GNU package update script.

svn path=/nixpkgs/trunk/; revision=21040

3 files changed, 1951 insertions, 0 deletions

diff --git a/maintainers/scripts/gnu/gnupdate b/maintainers/scripts/gnu/gnupdate
new file mode 100755
index 000000000000..c0dcd0785532
--- /dev/null
+++ b/maintainers/scripts/gnu/gnupdate
@@ -0,0 +1,4 @@
+#!/bin/sh
+
+exec "${GUILE:-guile}" "$GUILE_FLAGS" -L . -l gnupdate.scm \
+  -e '(apply main (cdr (command-line)))' -- "$@"
diff --git a/maintainers/scripts/gnu/gnupdate.scm b/maintainers/scripts/gnu/gnupdate.scm
new file mode 100644
index 000000000000..e43e5baf32c3
--- /dev/null
+++ b/maintainers/scripts/gnu/gnupdate.scm
@@ -0,0 +1,720 @@
+;;; GNUpdate -- Update GNU packages in Nixpkgs.     -*- coding: utf-8; -*-
+;;; Copyright (C) 2010  Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This program is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+(cond-expand (guile-2 #t)
+             (else (error "GNU Guile 2.0 is required")))
+
+(use-modules (sxml simple)
+             (ice-9 popen)
+             (ice-9 match)
+             (ice-9 rdelim)
+             (ice-9 regex)
+             (ice-9 vlist)
+             (sxml-match)
+             (srfi srfi-1)
+             (srfi srfi-9)
+             (srfi srfi-11)
+             (srfi srfi-37)
+             (system foreign)
+             (rnrs bytevector))
+
+
+;;;
+;;; SNix.
+;;;
+
+(define-record-type <location>
+  (make-location file line column)
+  location?
+  (file          location-file)
+  (line          location-line)
+  (column        location-column))
+
+(define (->loc line column path)
+  (and line column path
+       (make-location path (string->number line) (string->number column))))
+
+;; Nix object types visible in the XML output of `nix-instantiate' and
+;; mapping to S-expressions (we map to sexps, not records, so that we
+;; can do pattern matching):
+;;
+;;   at               (at varpat attrspat)
+;;   attr             (attribute loc name value)
+;;   attrs            (attribute-set attributes)
+;;   attrspat         (attribute-set-pattern patterns)
+;;   bool             #f|#t
+;;   derivation       (derivation drv-path out-path attributes)
+;;   ellipsis         '...
+;;   expr             (expr loc body ...)
+;;   function         (function loc at|attrspat|varpat)
+;;   int              int
+;;   list             list
+;;   null             'null
+;;   path             string
+;;   string           string
+;;   unevaluated      'unevaluated
+;;   varpat           (varpat name)
+;;
+;; Initially ATTRIBUTES in `derivation' and `attribute-set' was a promise;
+;; however, handling `repeated' nodes makes it impossible to do anything
+;; lazily because the whole SXML tree has to be traversed to maintain the
+;; list of known derivations.
+
+(define (sxml->snix tree)
+  ;; Return the SNix represention of TREE, an SXML tree as returned by
+  ;; parsing the XML output of `nix-instantiate' on Nixpkgs.
+
+  ;; FIXME: We should use SSAX to avoid the SXML step otherwise we end up
+  ;; eating memory up to the point where fork(2) returns ENOMEM!
+
+  (define whitespace
+    ;; The whitespace marker.
+    (cons 'white 'space))
+
+  (let loop ((node        tree)
+             (derivations vlist-null))
+    (define (process-body body)
+      (let ((result+derivations
+             (fold (lambda (node result)
+                     (let-values (((out derivations)
+                                   (loop node (cdr result))))
+                       (if (eq? out whitespace)
+                           result
+                           (cons (cons out (car result))
+                                 derivations))))
+                   (cons '() derivations)
+                   body)))
+        (values (reverse (car result+derivations))
+                (cdr result+derivations))))
+
+    (sxml-match node
+      (,x
+       (guard (and (string? x) (string=? (string-trim-both x) "")))
+       (values whitespace derivations))
+      ((*TOP* (*PI* ,_ ...) (expr ,body ...))
+       ;; The entry/exit point.  Of the two values returned, the second one
+       ;; is likely to be discarded by the caller (thanks to multiple-value
+       ;; truncation).
+       (let-values (((body derivations) (process-body body)))
+         (values (cons* 'snix #f body)
+                 derivations)))
+      ((at ,body ...)
+       (let-values (((body derivations) (process-body body)))
+         (values (list 'at body) derivations)))
+      ((attr (@ (name ,name)
+                (line (,line #f)) (column (,column #f)) (path (,path #f)))
+             ,body ...)
+       (let-values (((body derivations) (process-body body)))
+         (values (cons* 'attribute
+                        (->loc line column path)
+                        name
+                        (if (or (null? body)
+                                (and (pair? body) (null? (cdr body))))
+                            body
+                            (error 'sxml->snix "invalid attribute body"
+                                   body)))
+                 derivations)))
+      ((attrs ,body ...)
+       (let-values (((body derivations) (process-body body)))
+         (values (list 'attribute-set body)
+                 derivations)))
+      ((attrspat ,body ...)
+       (let-values (((body derivations) (process-body body)))
+         (values (cons 'attribute-set-pattern body)
+                 derivations)))
+      ((bool (@ (value ,value)))
+       (values (string-ci=? value "true") derivations))
+      ((derivation (@ (drvPath ,drv-path) (outPath ,out-path)) ,body ...)
+       (let-values (((body derivations) (process-body body)))
+         (let ((repeated? (equal? body '(repeated))))
+           (values (list 'derivation drv-path out-path
+                         (if repeated?
+                             (let ((body (vhash-assoc drv-path derivations)))
+                               (if (pair? body)
+                                   (cdr body)
+                                   (error "no previous occurrence of derivation"
+                                          drv-path)))
+                             body))
+                   (if repeated?
+                       derivations
+                       (vhash-cons drv-path body derivations))))))
+      ((ellipsis)
+       (values '... derivations))
+      ((function (@ (line (,line #f)) (column (,column #f)) (path (,path #f)))
+                 ,body ...)
+       (let-values (((body derivations) (process-body body)))
+         (values (cons* 'function
+                        (->loc line column path)
+                        (if (and (pair? body) (null? (cdr body)))
+                            body
+                            (error 'sxml->snix "invalid function body"
+                                   body)))
+                 derivations)))
+      ((int (@ (value ,value)))
+       (values (string->number value) derivations))
+      (,x
+       ;; We can't use `(list ,body ...)', which has a different meaning,
+       ;; hence the guard hack.
+       (guard (and (pair? x) (eq? (car x) 'list)))
+       (process-body (cdr x)))
+      ((null)
+       (values 'null derivations))
+      ((path (@ (value ,value)))
+       (values value derivations))
+      ((repeated)
+       ;; This is then handled in `derivation' above.
+       (values 'repeated derivations))
+      ((string (@ (value ,value)))
+       (values value derivations))
+      ((unevaluated)
+       (values 'unevaluated derivations))
+      ((varpat (@ (name ,name)))
+       (values (list 'varpat name) derivations))
+      (,x
+       (error 'sxml->snix "unmatched sxml form" x)))))
+
+(define (call-with-package snix proc)
+  (match snix
+    (('attribute _ (and attribute-name (? string?))
+                 ('derivation _ _ body))
+     ;; Ugly pattern matching.
+     (let ((meta
+            (any (lambda (attr)
+                   (match attr
+                     (('attribute _ "meta" ('attribute-set metas)) metas)
+                     (_ #f)))
+                 body))
+           (package-name
+            (any (lambda (attr)
+                   (match attr
+                     (('attribute _ "name" (and name (? string?)))
+                      name)
+                     (_ #f)))
+                 body))
+           (location
+            (any (lambda (attr)
+                   (match attr
+                     (('attribute loc "name" (? string?))
+                      loc)
+                     (_ #f)))
+                 body))
+           (src
+            (any (lambda (attr)
+                   (match attr
+                     (('attribute _ "src" src)
+                      src)
+                     (_ #f)))
+                 body)))
+       (proc attribute-name package-name location meta src)))))
+
+(define (call-with-src snix proc)
+  ;; Assume SNIX contains the SNix expression for the value of an `src'
+  ;; attribute, as returned by `call-with-package', and call PROC with the
+  ;; relevant SRC information, or #f if SNIX doesn't match.
+  (match snix
+    (('derivation _ _ body)
+     (let ((name
+            (any (lambda (attr)
+                   (match attr
+                     (('attribute _ "name" (and name (? string?)))
+                      name)
+                     (_ #f)))
+                 body))
+           (output-hash
+            (any (lambda (attr)
+                   (match attr
+                     (('attribute _ "outputHash" (and hash (? string?)))
+                      hash)
+                     (_ #f)))
+                 body))
+           (urls
+            (any (lambda (attr)
+                   (match attr
+                     (('attribute _ "urls" (and urls (? pair?)))
+                      urls)
+                     (_ #f)))
+                 body)))
+       (proc name output-hash urls)))
+    (_ (proc #f #f #f))))
+
+(define (src->values snix)
+  (call-with-src snix values))
+
+(define (open-nixpkgs nixpkgs)
+  (let ((script  (string-append nixpkgs
+                                "/maintainers/scripts/eval-release.nix")))
+    (open-pipe* OPEN_READ "nix-instantiate"
+                "--strict" "--eval-only" "--xml"
+                script)))
+
+(define (nix-prefetch-url url)
+  ;; Download URL in the Nix store and return the base32-encoded SHA256 hash
+  ;; of the file at URL
+  (let* ((pipe (open-pipe* OPEN_READ "nix-prefetch-url" url))
+         (hash (read-line pipe)))
+    (close-pipe pipe)
+    (if (eof-object? hash)
+        (values #f #f)
+        (let* ((pipe (open-pipe* OPEN_READ "nix-store" "--print-fixed-path"
+                                 "sha256" hash (basename url)))
+               (path (read-line pipe)))
+          (if (eof-object? path)
+              (values #f #f)
+              (values (string-trim-both hash) (string-trim-both path)))))))
+
+(define (update-nix-expression file
+                               old-version old-hash
+                               new-version new-hash)
+  ;; Modify FILE in-place.  Ugly: we call out to sed(1).
+  (let ((cmd (format #f "sed -i \"~a\" -e 's/~A/~a/g ; s/~A/~A/g'"
+                     file
+                     (regexp-quote old-version) new-version
+                     old-hash
+                     (or new-hash "new hash not available, check the log"))))
+    (format #t "running `~A'...~%" cmd)
+    (system cmd)))
+
+
+;;;
+;;; FTP client.
+;;;
+
+(define-record-type <ftp-connection>
+  (%make-ftp-connection socket addrinfo)
+  ftp-connection?
+  (socket    ftp-connection-socket)
+  (addrinfo  ftp-connection-addrinfo))
+
+(define %ftp-ready-rx
+  (make-regexp "^([0-9]{3}) (.+)$"))
+
+(define (%ftp-listen port)
+  (let loop ((line (read-line port)))
+    (cond ((eof-object? line) (values line #f))
+          ((regexp-exec %ftp-ready-rx line)
+           =>
+           (lambda (match)
+             (values (string->number (match:substring match 1))
+                     (match:substring match 2))))
+          (else
+           (loop (read-line port))))))
+
+(define (%ftp-command command expected-code port)
+  (format port "~A~A~A" command (string #\return) (string #\newline))
+  (let-values (((code message) (%ftp-listen port)))
+    (if (eqv? code expected-code)
+        message
+        (throw 'ftp-error port command code message))))
+
+(define (ftp-open host)
+  (catch 'getaddrinfo-error
+    (lambda ()
+      (let* ((ai (car (getaddrinfo host "ftp")))
+             (s  (socket (addrinfo:fam ai) (addrinfo:socktype ai)
+                         (addrinfo:protocol ai))))
+        (connect s (addrinfo:addr ai))
+        (setvbuf s _IOLBF)
+        (let-values (((code message) (%ftp-listen s)))
+          (if (eqv? code 220)
+              (begin
+                ;(%ftp-command "OPTS UTF8 ON" 200 s)
+                ;; FIXME: When `USER' returns 331, we should do a `PASS email'.
+                (%ftp-command "USER anonymous" 230 s)
+                (%make-ftp-connection s ai))
+              (begin
+                (format (current-error-port) "FTP to `~a' failed: ~A: ~A~%"
+                        host code message)
+                (close s)
+                #f)))))
+    (lambda (key errcode)
+      (format (current-error-port) "failed to resolve `~a': ~a~%"
+              host (gai-strerror errcode))
+      #f)))
+
+(define (ftp-close conn)
+  (close (ftp-connection-socket conn)))
+
+(define (ftp-chdir conn dir)
+  (%ftp-command (string-append "CWD " dir) 250
+                (ftp-connection-socket conn)))
+
+(define (ftp-pasv conn)
+  (define %pasv-rx
+    (make-regexp "([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)"))
+
+  (let ((message (%ftp-command "PASV" 227 (ftp-connection-socket conn))))
+    (cond ((regexp-exec %pasv-rx message)
+           =>
+           (lambda (match)
+             (+ (* (string->number (match:substring match 5)) 256)
+                (string->number (match:substring match 6)))))
+          (else
+           (throw 'ftp-error conn "PASV" 227 message)))))
+
+
+(define (ftp-list conn)
+  (define (address-with-port sa port)
+    (let ((fam  (sockaddr:fam sa))
+          (addr (sockaddr:addr sa)))
+      (cond ((= fam AF_INET)
+             (make-socket-address fam addr port))
+            ((= fam AF_INET6)
+             (make-socket-address fam addr port
+                                  (sockaddr:flowinfo sa)
+                                  (sockaddr:scopeid sa)))
+            (else #f))))
+
+  (let* ((port (ftp-pasv conn))
+         (ai   (ftp-connection-addrinfo conn))
+         (s    (socket (addrinfo:fam ai) (addrinfo:socktype ai)
+                       (addrinfo:protocol ai))))
+    (connect s (address-with-port (addrinfo:addr ai) port))
+    (setvbuf s _IOLBF)
+
+    (dynamic-wind
+      (lambda () #t)
+      (lambda ()
+        (%ftp-command "LIST" 150 (ftp-connection-socket conn))
+
+        (let loop ((line   (read-line s))
+                   (result '()))
+          (cond ((eof-object? line) (reverse result))
+                ((regexp-exec %ftp-ready-rx line)
+                 =>
+                 (lambda (match)
+                   (let ((code (string->number (match:substring match 1))))
+                     (if (= 126 code)
+                         (reverse result)
+                         (throw 'ftp-error conn "LIST" code)))))
+                (else
+                 (loop (read-line s)
+                       (let ((file (car (reverse (string-tokenize line)))))
+                         (cons file result)))))))
+      (lambda ()
+        (close s)
+        (let-values (((code message) (%ftp-listen (ftp-connection-socket conn))))
+          (or (eqv? code 226)
+              (throw 'ftp-error conn "LIST" code message)))))))
+
+
+;;;
+;;; GNU.
+;;;
+
+(define %ignored-package-attributes
+  ;; Attribute name of packages to be ignored.
+  '("bash" "bashReal" "bashInteractive" ;; the full versioned name is incorrect
+    "autoconf213"
+    "automake17x"
+    "automake19x"
+    "automake110x"
+    "automake" ;; = 1.10.x
+    "bison1875"
+    "bison23"
+    "bison" ;; = 2.3
+    "emacs22"
+    "emacsSnapshot"
+    "gcc295"
+    "gcc33"
+    "gcc34"
+    "gcc40"
+    "gcc41"
+    "gcc42"
+    "gcc43"
+    "glibc25"
+    "glibc27"
+    "glibc29"
+    "guile_1_9"
+    ))
+
+(define (gnu? package)
+  ;; Return true if PACKAGE (a snix expression) is a GNU package (according
+  ;; to a simple heuristic.)  Otherwise return #f.
+  (match package
+    (('attribute _ attribute-name ('derivation _ _ body))
+     (any (lambda (attr)
+            (match attr
+              (('attribute _ "meta" ('attribute-set metas))
+               (any (lambda (attr)
+                      (match attr
+                        (('attribute _ "description" value)
+                         (string-prefix? "GNU" value))
+                        (('attribute "homepage" value)
+                         (string-contains value "www.gnu.org"))
+                        (_ #f)))
+                    metas))
+              (_ #f)))
+          body))
+    (_ #f)))
+
+(define (gnu-packages packages)
+  (fold (lambda (package gnu)
+          (match package
+            (('attribute _ "emacs23Packages" emacs-packages)
+             ;; XXX: Should prepend `emacs23Packages.' to attribute names.
+             (append (gnu-packages emacs-packages) gnu))
+            (('attribute _ attribute-name ('derivation _ _ body))
+             (if (member attribute-name %ignored-package-attributes)
+                 gnu
+                 (if (gnu? package)
+                     (cons package gnu)
+                     gnu)))
+            (_ gnu)))
+        '()
+        packages))
+
+(define (ftp-server/directory project)
+  (define quirks
+    '(("libgcrypt"    "ftp.gnupg.org" "/gcrypt" #t)
+      ("libgpg-error" "ftp.gnupg.org" "/gcrypt" #t)
+      ("gnupg"        "ftp.gnupg.org" "/gcrypt" #t)
+      ("gnu-ghostscript" "ftp.gnu.org"  "/ghostscript" #f)
+      ("GNUnet"       "ftp.gnu.org" "/gnu/gnunet" #f)
+      ("icecat"       "ftp.gnu.org" "/gnu/gnuzilla" #f)
+      ("TeXmacs"      "ftp.texmacs.org" "/TeXmacs/targz" #f)))
+
+  (let ((quirk (assoc project quirks)))
+    (match quirk
+      ((_ server directory subdir?)
+       (values server (if (not subdir?)
+                          directory
+                          (string-append directory "/" project))))
+      (else
+       (values "ftp.gnu.org" (string-append "/gnu/" project))))))
+
+(define (nixpkgs->gnu-name project)
+  (define quirks
+    '(("gcc-wrapper" . "gcc")
+      ("ghostscript" . "gnu-ghostscript") ;; ../ghostscript/gnu-ghoscript-X.Y.tar.gz
+      ("gnum4"       . "m4")
+      ("gnugrep"     . "grep")
+      ("gnused"      . "sed")
+      ("gnutar"      . "tar")
+      ("gnunet"      . "GNUnet") ;; ftp.gnu.org/gnu/gnunet/GNUnet-x.y.tar.gz
+      ("texmacs"     . "TeXmacs")))
+
+  (or (assoc-ref quirks project) project))
+
+(define (releases project)
+  ;; TODO: Handle project release trees like that of IceCat and MyServer.
+  (define release-rx
+    (make-regexp (string-append "^" project "-[0-9].*\\.tar\\.")))
+
+  (catch #t
+    (lambda ()
+      (let-values (((server directory) (ftp-server/directory project)))
+        (let ((conn (ftp-open server)))
+          (ftp-chdir conn directory)
+          (let ((files (ftp-list conn)))
+            (ftp-close conn)
+            (map (lambda (tarball)
+                   (let ((end (string-contains tarball ".tar")))
+                     (substring tarball 0 end)))
+
+                 ;; Filter out signatures, deltas, and files which are potentially
+                 ;; not releases of PROJECT (e.g., in /gnu/guile, filter out
+                 ;; guile-oops and guile-www).
+                 (filter (lambda (file)
+                           (and (not (string-suffix? ".sig" file))
+                                (regexp-exec release-rx file)))
+                         files))))))
+    (lambda (key subr message . args)
+      (format (current-error-port)
+              "failed to get release list for `~A': ~A ~A~%"
+              project message args)
+      '())))
+
+(define version-string>?
+  (let ((strverscmp
+         (let ((sym (or (dynamic-func "strverscmp" (dynamic-link))
+                        (error "could not find `strverscmp' (from GNU libc)"))))
+           (make-foreign-function int sym (list '* '*))))
+        (string->null-terminated-utf8
+         (lambda (s)
+           (let* ((utf8 (string->utf8 s))
+                  (len  (bytevector-length utf8))
+                  (nts  (make-bytevector (+ len 1))))
+             (bytevector-copy! utf8 0 nts 0 len)
+             (bytevector-u8-set! nts len 0)
+             nts))))
+    (lambda (a b)
+      (let ((a (bytevector->foreign (string->null-terminated-utf8 a)))
+            (b (bytevector->foreign (string->null-terminated-utf8 b))))
+        (> (strverscmp a b) 0)))))
+
+(define (latest-release project)
+  ;; Return "FOO-X.Y" or #f.
+  (let ((releases (releases project)))
+    (and (not (null? releases))
+         (fold (lambda (release latest)
+                 (if (version-string>? release latest)
+                     release
+                     latest))
+               ""
+               releases))))
+
+(define (package/version name+version)
+  (let ((hyphen (string-rindex name+version #\-)))
+    (if (not hyphen)
+        (values name+version #f)
+        (let ((name    (substring name+version 0 hyphen))
+              (version (substring name+version (+ hyphen 1)
+                                  (string-length name+version))))
+          (values name version)))))
+
+(define (file-extension file)
+  (let ((dot (string-rindex file #\.)))
+    (and dot (substring file (+ 1 dot) (string-length file)))))
+
+(define (packages-to-update gnu-packages)
+  (fold (lambda (pkg result)
+          (call-with-package pkg
+            (lambda (attribute name+version location meta src)
+              (let-values (((name old-version)
+                            (package/version name+version)))
+                (let ((latest (latest-release (nixpkgs->gnu-name name))))
+                  (cond ((not latest)
+                         (format #t "~A [unknown latest version]~%"
+                                 name+version)
+                         result)
+                        ((string=? name+version latest)
+                         (format #t "~A [up to date]~%" name+version)
+                         result)
+                        (else
+                         (let-values (((project new-version)
+                                       (package/version latest))
+                                      ((old-name old-hash old-urls)
+                                       (src->values src)))
+                           (format #t "~A -> ~A [~A]~%" name+version latest
+                                   (and (pair? old-urls) (car old-urls)))
+                           (let* ((url      (and (pair? old-urls)
+                                                 (car old-urls)))
+                                  (new-hash (fetch-gnu project new-version
+                                                       (if url
+                                                           (file-extension url)
+                                                           "gz"))))
+                             (cons (list name attribute
+                                         old-version old-hash
+                                         new-version new-hash
+                                         location)
+                                   result))))))))))
+        '()
+        gnu-packages))
+
+(define (fetch-gnu project version archive-type)
+  (let-values (((server directory)
+                (ftp-server/directory project)))
+    (let* ((base    (string-append project "-" version ".tar." archive-type))
+           (url     (string-append "ftp://" server "/" directory "/" base))
+           (sig     (string-append base ".sig"))
+           (sig-url (string-append url ".sig")))
+      (let-values (((hash path) (nix-prefetch-url url)))
+        (pk 'prefetch-url url hash path)
+        (and hash path
+             (begin
+               (false-if-exception (delete-file sig))
+               (system* "wget" sig-url)
+               (if (file-exists? sig)
+                   (let ((ret (system* "gpg" "--verify" sig path)))
+                     (false-if-exception (delete-file sig))
+                     (if (and ret (= 0 (status:exit-val ret)))
+                         hash
+                         (begin
+                           (format (current-error-port)
+                                   "signature verification failed for `~a'~%"
+                                   base)
+                           (format (current-error-port)
+                                   "(could be because the public key is not in your keyring)~%")
+                           #f)))
+                   (begin
+                     (format (current-error-port)
+                             "no signature for `~a'~%" base)
+                     hash))))))))
+
+
+;;;
+;;; Main program.
+;;;
+
+(define %options
+  ;; Specifications of the command-line options.
+  (list (option '(#\h "help") #f #f
+                (lambda (opt name arg result)
+                  (format #t "Usage: gnupdate [OPTIONS...]~%")
+                  (format #t "GNUpdate -- update Nix expressions of GNU packages in Nixpkgs~%")
+                  (format #t "~%")
+                  (format #t "  -x, --xml=FILE      Read XML output of `nix-instantiate'~%")
+                  (format #t "                      from FILE.~%")
+                  (format #t "  -s, --sxml=FILE     Read SXML output of `nix-instantiate'~%")
+                  (format #t "                      from FILE.~%")
+                  (format #t "  -h, --help          Give this help list.~%~%")
+                  (format #t "Report bugs to <ludo@gnu.org>~%")
+                  (exit 0)))
+
+        (option '(#\x "xml") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'xml-file arg result)))
+        (option '(#\s "sxml") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'sxml-file arg result)))))
+
+(define (main . args)
+  ;; Assume Nixpkgs is under $NIXPKGS or ~/src/nixpkgs.
+  (let* ((opts      (args-fold args %options
+                               (lambda (opt name arg result)
+                                 (error "unrecognized option `~A'" name))
+                               (lambda (operand result)
+                                 (error "extraneous argument `~A'" operand))
+                               '()))
+         (home      (getenv "HOME"))
+         (path      (or (getenv "NIXPKGS")
+                        (string-append home "/src/nixpkgs")))
+         (sxml      (or (and=> (assoc-ref opts 'sxml-file)
+                               (lambda (input)
+                                 (format (current-error-port)
+                                         "reading SXML...~%")
+                                 (read-disable 'positions) ;; reduce memory usage
+                                 (with-input-from-file input read)))
+                        (begin
+                          (format (current-error-port) "parsing XML...~%")
+                          (xml->sxml
+                           (or (and=> (assoc-ref opts 'xml-file)
+                                      open-input-file)
+                               (open-nixpkgs path))))))
+         (snix      (let ((s (begin
+                               (format (current-error-port)
+                                       "producing SNix tree...~%")
+                               (sxml->snix sxml))))
+                      (set! sxml #f) (gc)
+                      s))
+         (packages  (match snix
+                      (('snix _ ('attribute-set attributes))
+                       attributes)
+                      (else #f)))
+         (gnu       (gnu-packages packages))
+         (updates   (packages-to-update gnu)))
+    (format #t "~%~A packages to update...~%" (length updates))
+    (for-each (lambda (update)
+                (match update
+                  ((name attribute
+                    old-version old-hash
+                    new-version new-hash
+                    location)
+                   (update-nix-expression (location-file location)
+                                          old-version old-hash
+                                          new-version new-hash))
+                  (_ #f)))
+              updates)))
diff --git a/maintainers/scripts/gnu/sxml-match.scm b/maintainers/scripts/gnu/sxml-match.scm
new file mode 100644
index 000000000000..48d8c91b4b1f
--- /dev/null
+++ b/maintainers/scripts/gnu/sxml-match.scm
@@ -0,0 +1,1227 @@
+;; 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
+;;
+
+(define-module (sxml-match)
+  #:export (sxml-match
+            sxml-match-let
+            sxml-match-let*)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11))
+
+
+;;;
+;;; 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 (gensym)))
+       (call-with-prompt prompt
+                         (lambda ()
+                           (proc (lambda args
+                                   (apply abort-to-prompt
+                                          prompt args))))
+                         (lambda (k . 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))
+
+
+;;;
+;;; Body, unmodified from
+;;; http://planet.plt-scheme.org/package-source/jim/sxml-match.plt/1/1/sxml-match.ss
+;;; except for:
+;;;
+;;;   1. The PLT-specific `module' form.
+;;;
+;;;   2. In `sxml-match1', ESCAPE is called with `call-with-values' instead
+;;;      of being called "normally", such that the example below returns the
+;;;      values `x' and `y' instead of just `x':
+;;;
+;;;      (sxml-match '(foo) ((bar) (values 'p 'q)) ((foo) (values 'x 'y)))
+;;;
+
+(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->datum stx))))]
+         [literal?
+          (lambda (stx)
+            (let ([x (syntax->datum stx)])
+              (or (string? x)
+                  (char? x)
+                  (number? x)
+                  (boolean? x))))]
+         [keyword?
+          (lambda (stx)
+            (and (identifier? stx)
+                 (let ([str (symbol->string (syntax->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->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 () (call-with-values
+                                      (lambda () (sxml-match1 exp cata-fun
+                                                              clause ...))
+                                    escape))))]))
+
+(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 ...))))])))