code:
;;;; (sxml ssax input-parse) -- a simple lexer
;;;;
;;;; 	Copyright (C) 2009  Free Software Foundation, Inc.
;;;;    Modified 2004 by Andy Wingo <wingo at pobox dot com>.
;;;;    Written 2003 by Oleg Kiselyov <oleg at pobox dot com> as input-parse.scm.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;

;;; Commentary:
;;
;; A simple lexer.
;;
;; The procedures in this module surprisingly often suffice to parse an
;; input stream. They either skip, or build and return tokens, according
;; to inclusion or delimiting semantics. The list of characters to
;; expect, include, or to break at may vary from one invocation of a
;; function to another. This allows the functions to easily parse even
;; context-sensitive languages.
;;
;; EOF is generally frowned on, and thrown up upon if encountered.
;; Exceptions are mentioned specifically. The list of expected
;; characters (characters to skip until, or break-characters) may
;; include an EOF "character", which is to be coded as the symbol,
;; @code{*eof*}.
;;
;; The input stream to parse is specified as a @dfn{port}, which is
;; usually the last (and optional) argument. It defaults to the current
;; input port if omitted.
;;
;; If the parser encounters an error, it will throw an exception to the
;; key @code{parser-error}. The arguments will be of the form
;; @code{(@var{port} @var{message} @var{specialising-msg}*)}.
;;
;; The first argument is a port, which typically points to the offending
;; character or its neighborhood. You can then use @code{port-column}
;; and @code{port-line} to query the current position. @var{message} is
;; the description of the error. Other arguments supply more details
;; about the problem.
;;
;;; Code:

(define-module (sxml ssax input-parse)
  #:use-module (ice-9 rdelim)
  #:export (peek-next-char
            assert-curr-char
            skip-until
            skip-while
            next-token
            next-token-of
            read-text-line
            read-string
            find-string-from-port?))

(define ascii->char integer->char)
(define char->ascii char->integer)
(define char-newline #\newline)
(define char-return #\return)
(define inc 1+)
(define dec 1-)

;; rewrite oleg's define-opt into define* style
(define-macro (define-opt bindings body . body-rest)
  (let* ((rev-bindings (reverse bindings))
         (opt-bindings
          (and (pair? rev-bindings) (pair? (car rev-bindings))
               (eq? 'optional (caar rev-bindings))
               (cdar rev-bindings))))
    (if opt-bindings
	`(define* ,(append (reverse (cons #:optional (cdr rev-bindings)))
			  opt-bindings)
	   ,body ,@body-rest)
	`(define* ,bindings ,body ,@body-rest))))

(define (parser-error port message . rest)
  (apply throw 'parser-error port message rest))

(include-from-path "sxml/upstream/input-parse.scm")

;; This version for guile is quite speedy, due to read-delimited (which
;; is implemented in C).
(define-opt (next-token prefix-skipped-chars break-chars
			(optional (comment "") (port (current-input-port))) )
  (let ((delims (list->string (delete '*eof* break-chars))))
    (if (eof-object? (if (null? prefix-skipped-chars)
                         (peek-char port)
                         (skip-while prefix-skipped-chars port)))
        (if (memq '*eof* break-chars)
            ""
            (parser-error port "EOF while reading a token " comment))
        (let ((token (read-delimited delims port 'peek)))
          (if (and (eof-object? (peek-char port))
                   (not (memq '*eof* break-chars)))
              (parser-error port "EOF while reading a token " comment)
              token)))))

(define-opt (read-text-line (optional (port (current-input-port))) )
  (read-line port))

;; Written 1995, 1996 by Oleg Kiselyov (oleg@acm.org)
;; Modified 1996, 1997, 1998, 2001 by A. Jaffer (agj@alum.mit.edu)
;; Modified 2003 by Steve VanDevender (stevev@hexadecimal.uoregon.edu)
;; Modified 2004 Andy Wingo <wingo at pobox dot com>
;; This function is from SLIB's strsrch.scm, and is in the public domain.
(define (find-string-from-port? str <input-port> . max-no-char)
  "Looks for @var{str} in @var{<input-port>}, optionally within the
first @var{max-no-char} characters."
  (set! max-no-char (if (null? max-no-char) #f (car max-no-char)))
  (letrec
      ((no-chars-read 0)
       (peeked? #f)
       (my-peek-char			; Return a peeked char or #f
        (lambda () (and (or (not (number? max-no-char))
                            (< no-chars-read max-no-char))
                        (let ((c (peek-char <input-port>)))
                          (cond (peeked? c)
                                ((eof-object? c) #f)
                                ((procedure? max-no-char)
                                 (set! peeked? #t)
                                 (if (max-no-char c) #f c))
                                ((eqv? max-no-char c) #f)
                                (else c))))))
       (next-char (lambda () (set! peeked? #f) (read-char <input-port>)
                          (set! no-chars-read  (+ 1 no-chars-read))))
       (match-1st-char                  ; of the string str
        (lambda ()
          (let ((c (my-peek-char)))
            (and c
                 (begin (next-char)
                        (if (char=? c (string-ref str 0))
                            (match-other-chars 1)
                            (match-1st-char)))))))
       ;; There has been a partial match, up to the point pos-to-match
       ;; (for example, str[0] has been found in the stream)
       ;; Now look to see if str[pos-to-match] for would be found, too
       (match-other-chars
        (lambda (pos-to-match)
          (if (>= pos-to-match (string-length str))
              no-chars-read             ; the entire string has matched
              (let ((c (my-peek-char)))
                (and c
                     (if (not (char=? c (string-ref str pos-to-match)))
                         (backtrack 1 pos-to-match)
                         (begin (next-char)
                                (match-other-chars (+ 1 pos-to-match)))))))))

       ;; There had been a partial match, but then a wrong char showed up.
       ;; Before discarding previously read (and matched) characters, we check
       ;; to see if there was some smaller partial match. Note, characters read
       ;; so far (which matter) are those of str[0..matched-substr-len - 1]
       ;; In other words, we will check to see if there is such i>0 that
       ;; substr(str,0,j) = substr(str,i,matched-substr-len)
       ;; where j=matched-substr-len - i
       (backtrack
        (lambda (i matched-substr-len)
          (let ((j (- matched-substr-len i)))
            (if (<= j 0)
                ;; backed off completely to the begining of str
                (match-1st-char)
                (let loop ((k 0))
                  (if (>= k j)
                      (match-other-chars j) ; there was indeed a shorter match
                      (if (char=? (string-ref str k)
                                  (string-ref str (+ i k)))
                          (loop (+ 1 k))
                          (backtrack (+ 1 i) matched-substr-len))))))))
       )
    (match-1st-char)))


code:
;; Library: sxml-match
;; Author: Jim Bender
;; Version: 1.1, version for PLT Scheme
;;
;; Copyright 2005-9, Jim Bender
;; sxml-match is released under the MIT License
;;
(module sxml-match mzscheme

  (provide sxml-match
           sxml-match-let
           sxml-match-let*)

  (require (rename (lib "fold.ss" "srfi" "1") fold-right fold-right)
           (rename (lib "filter.ss" "srfi" "1") filter filter))

  (define (nodeset? x)
    (or (and (pair? x) (not (symbol? (car x)))) (null? x)))

  (define (xml-element-tag s)
    (if (and (pair? s) (symbol? (car s)))
        (car s)
        (error 'xml-element-tag "expected an xml-element, given" s)))

  (define (xml-element-attributes s)
    (if (and (pair? s) (symbol? (car s)))
        (fold-right (lambda (a b)
                      (if (and (pair? a) (eq? '@ (car a)))
                          (if (null? b)
                              (filter (lambda (i) (not (and (pair? i) (eq? '@ (car i))))) (cdr a))
                              (fold-right (lambda (c d)
                                            (if (and (pair? c) (eq? '@ (car c)))
                                                d
                                                (cons c d)))
                                          b (cdr a)))
                          b))
                    '()
                    (cdr s))
        (error 'xml-element-attributes "expected an xml-element, given" s)))

  (define (xml-element-contents s)
    (if (and (pair? s) (symbol? (car s)))
        (filter (lambda (i)
                  (not (and (pair? i) (eq? '@ (car i)))))
                (cdr s))
        (error 'xml-element-contents "expected an xml-element, given" s)))

  (define (match-xml-attribute key l)
    (if (not (pair? l))
        #f
        (if (eq? (car (car l)) key)
            (car l)
            (match-xml-attribute key (cdr l)))))

  (define (filter-attributes keys lst)
    (if (null? lst)
        '()
        (if (member (caar lst) keys)
            (filter-attributes keys (cdr lst))
            (cons (car lst) (filter-attributes keys (cdr lst))))))

  (define-syntax compile-clause
    (lambda (stx)
      (letrec
          ([sxml-match-syntax-error
            (lambda (msg exp sub)
              (raise-syntax-error #f msg (with-syntax ([s exp]) (syntax (sxml-match s))) sub))]
           [ellipsis?
            (lambda (stx)
              (and (identifier? stx) (eq? '... (syntax-object->datum stx))))]
           [literal?
            (lambda (stx)
              (let ([x (syntax-object->datum stx)])
                (or (string? x)
                    (char? x)
                    (number? x)
                    (boolean? x))))]
           [keyword?
            (lambda (stx)
              (and (identifier? stx)
                   (let ([str (symbol->string (syntax-object->datum stx))])
                     (char=? #\: (string-ref str (- (string-length str) 1))))))]
           [extract-cata-fun
            (lambda (cf)
              (syntax-case cf ()
                [#f #f]
                [other cf]))]
           [add-pat-var
            (lambda (pvar pvar-lst)
              (define (check-pvar lst)
                (if (null? lst)
                    (void)
                    (if (bound-identifier=? (car lst) pvar)
                        (sxml-match-syntax-error "duplicate pattern variable not allowed"
                                                 stx
                                                 pvar)
                        (check-pvar (cdr lst)))))
              (check-pvar pvar-lst)
              (cons pvar pvar-lst))]
           [add-cata-def
            (lambda (depth cvars cfun ctemp cdefs)
              (cons (list depth cvars cfun ctemp) cdefs))]
           [process-cata-exp
            (lambda (depth cfun ctemp)
              (if (= depth 0)
                  (with-syntax ([cf cfun]
                                [ct ctemp])
                    (syntax (cf ct)))
                  (let ([new-ctemp (car (generate-temporaries (list ctemp)))])
                    (with-syntax ([ct ctemp]
                                  [nct new-ctemp]
                                  [body (process-cata-exp (- depth 1) cfun new-ctemp)])
                      (syntax (map (lambda (nct) body) ct))))))]
           [process-cata-defs
            (lambda (cata-defs body)
              (if (null? cata-defs)
                  body
                  (with-syntax ([(cata-binding ...)
                                 (map (lambda (def)
                                        (with-syntax ([bvar (cadr def)]
                                                      [bval (process-cata-exp (car def)
                                                                              (caddr def)
                                                                              (cadddr def))])
                                          (syntax (bvar bval))))
                                      cata-defs)]
                                [body-stx body])
                    (syntax (let-values (cata-binding ...)
                              body-stx)))))]
           [cata-defs->pvar-lst
            (lambda (lst)
              (if (null? lst)
                  '()
                  (let iter ([items (cadr (car lst))])
                    (syntax-case items ()
                      [() (cata-defs->pvar-lst (cdr lst))]
                      [(fst . rst) (cons (syntax fst) (iter (syntax rst)))]))))]
           [process-output-action
            (lambda (action dotted-vars)
              (define (finite-lst? lst)
                (syntax-case lst ()
                  (item
                   (identifier? (syntax item))
                   #f)
                  (()
                   #t)
                  ((fst dots . rst)
                   (ellipsis? (syntax dots))
                   #f)
                  ((fst . rst)
                   (finite-lst? (syntax rst)))))
              (define (expand-lst lst)
                (syntax-case lst ()
                  [() (syntax '())]
                  [item
                   (identifier? (syntax item))
                   (syntax item)]
                  [(fst dots . rst)
                   (ellipsis? (syntax dots))
                   (with-syntax ([exp-lft (expand-dotted-item
                                           (process-output-action (syntax fst)
                                                                  dotted-vars))]
                                 [exp-rgt (expand-lst (syntax rst))])
                     (syntax (append exp-lft exp-rgt)))]
                  [(fst . rst)
                   (with-syntax ([exp-lft (process-output-action (syntax fst)
                                                                 dotted-vars)]
                                 [exp-rgt (expand-lst (syntax rst))])
                     (syntax (cons exp-lft exp-rgt)))]))
              (define (member-var? var lst)
                (let iter ([lst lst])
                  (if (null? lst)
                      #f
                      (if (or (bound-identifier=? var (car lst))
                              (free-identifier=? var (car lst)))
                          #t
                          (iter (cdr lst))))))
              (define (dotted-var? var)
                (member-var? var dotted-vars))
              (define (merge-pvars lst1 lst2)
                (if (null? lst1)
                    lst2
                    (if (member-var? (car lst1) lst2)
                        (merge-pvars (cdr lst1) lst2)
                        (cons (car lst1) (merge-pvars (cdr lst1) lst2)))))
              (define (select-dotted-vars x)
                (define (walk-quasi-body y)
                  (syntax-case y (unquote unquote-splicing)
                    [((unquote a) . rst)
                     (merge-pvars (select-dotted-vars (syntax a))
                                  (walk-quasi-body (syntax rst)))]
                    [((unquote-splicing a) . rst)
                     (merge-pvars (select-dotted-vars (syntax a))
                                  (walk-quasi-body (syntax rst)))]
                    [(fst . rst)
                     (merge-pvars (walk-quasi-body (syntax fst))
                                  (walk-quasi-body (syntax rst)))]
                    [other
                     '()]))
                (syntax-case x (quote quasiquote)
                  [(quote . rst) '()]
                  [(quasiquote . rst) (walk-quasi-body (syntax rst))]
                  [(fst . rst)
                   (merge-pvars (select-dotted-vars (syntax fst))
                                (select-dotted-vars (syntax rst)))]
                  [item
                   (and (identifier? (syntax item))
                        (dotted-var? (syntax item)))
                   (list (syntax item))]
                  [item '()]))
              (define (expand-dotted-item item)
                (let ([dvars (select-dotted-vars item)])
                  (syntax-case item ()
                    [x
                     (identifier? (syntax x))
                     (syntax x)]
                    [x (with-syntax ([(dv ...) dvars])
                         (syntax (map (lambda (dv ...) x) dv ...)))])))
              (define (expand-quasiquote-body x)
                (syntax-case x (unquote unquote-splicing quasiquote)
                  [(quasiquote . rst) (process-quasiquote x)]
                  [(unquote item)
                   (with-syntax ([expanded-item (process-output-action (syntax item)
                                                                       dotted-vars)])
                     (syntax (unquote expanded-item)))]
                  [(unquote-splicing item)
                   (with-syntax ([expanded-item (process-output-action (syntax item)
                                                                       dotted-vars)])
                     (syntax (unquote-splicing expanded-item)))]
                  [((unquote item) dots . rst)
                   (ellipsis? (syntax dots))
                   (with-syntax ([expanded-item (expand-dotted-item
                                                 (process-output-action (syntax item)
                                                                        dotted-vars))]
                                 [expanded-rst (expand-quasiquote-body (syntax rst))])
                     (syntax ((unquote-splicing expanded-item) . expanded-rst)))]
                  [(item dots . rst)
                   (ellipsis? (syntax dots))
                   (with-syntax ([expanded-item (expand-dotted-item
                                                 (process-output-action (syntax (quasiquote item))
                                                                        dotted-vars))]
                                 [expanded-rst (expand-quasiquote-body (syntax rst))])
                     (syntax ((unquote-splicing expanded-item) . expanded-rst)))]
                  [(fst . rst)
                   (with-syntax ([expanded-fst (expand-quasiquote-body (syntax fst))]
                                 [expanded-rst (expand-quasiquote-body (syntax rst))])
                     (syntax (expanded-fst . expanded-rst)))]
                  [other x]))
              (define (process-quasiquote x)
                (syntax-case x ()
                  [(quasiquote term) (with-syntax ([expanded-body (expand-quasiquote-body (syntax term))])
                                       (syntax (quasiquote expanded-body)))]
                  [else (sxml-match-syntax-error "bad quasiquote-form"
                                                 stx
                                                 x)]))
              (syntax-case action (quote quasiquote)
                [(quote . rst) action]
                [(quasiquote . rst) (process-quasiquote action)]
                [(fst . rst) (if (finite-lst? action)
                                 (with-syntax ([exp-lft (process-output-action (syntax fst) dotted-vars)]
                                               [exp-rgt (process-output-action (syntax rst) dotted-vars)])
                                   (syntax (exp-lft . exp-rgt)))
                                 (with-syntax ([exp-lft (process-output-action (syntax fst)
                                                                               dotted-vars)]
                                               [exp-rgt (expand-lst (syntax rst))])
                                   (syntax (apply exp-lft exp-rgt))))]
                [item action]))]
           [compile-element-pat
            (lambda (ele exp nextp fail-k pvar-lst depth cata-fun cata-defs dotted-vars)
              (syntax-case ele (@)
                [(tag (@ . attr-items) . items)
                 (identifier? (syntax tag))
                 (let ([attr-exp (car (generate-temporaries (list exp)))]
                       [body-exp (car (generate-temporaries (list exp)))])
                   (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
                                 (compile-attr-list (syntax attr-items)
                                                    (syntax items)
                                                    attr-exp
                                                    body-exp
                                                    '()
                                                    nextp
                                                    fail-k
                                                    pvar-lst
                                                    depth
                                                    cata-fun
                                                    cata-defs
                                                    dotted-vars)])
                     (values (with-syntax ([x exp]
                                           [ax attr-exp]
                                           [bx body-exp]
                                           [body tests]
                                           [fail-to fail-k])
                               (syntax (if (and (pair? x) (eq? 'tag (xml-element-tag x)))
                                           (let ([ax (xml-element-attributes x)]
                                                 [bx (xml-element-contents x)])
                                             body)
                                           (fail-to))))
                             new-pvar-lst
                             new-cata-defs
                             new-dotted-vars)))]
                [(tag . items)
                 (identifier? (syntax tag))
                 (let ([body-exp (car (generate-temporaries (list exp)))])
                   (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
                                 (compile-item-list (syntax items)
                                                    body-exp
                                                    nextp
                                                    fail-k
                                                    #t
                                                    pvar-lst
                                                    depth
                                                    cata-fun
                                                    cata-defs
                                                    dotted-vars)])
                     (values (with-syntax ([x exp]
                                           [bx body-exp]
                                           [body tests]
                                           [fail-to fail-k])
                               (syntax (if (and (pair? x) (eq? 'tag (xml-element-tag x)))
                                           (let ([bx (xml-element-contents x)])
                                             body)
                                           (fail-to))))
                             new-pvar-lst
                             new-cata-defs
                             new-dotted-vars)))]))]
           [compile-end-element
            (lambda (exp nextp fail-k pvar-lst cata-defs dotted-vars)
              (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars)
                            (nextp pvar-lst cata-defs dotted-vars)])
                (values (with-syntax ([x exp]
                                      [body next-tests]
                                      [fail-to fail-k])
                          (syntax (if (null? x) body (fail-to))))
                        new-pvar-lst
                        new-cata-defs
                        new-dotted-vars)))]
           [compile-attr-list
            (lambda (attr-lst body-lst attr-exp body-exp attr-key-lst nextp fail-k pvar-lst depth cata-fun cata-defs dotted-vars)
              (syntax-case attr-lst (unquote ->)
                [(unquote var)
                 (identifier? (syntax var))
                 (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
                               (compile-item-list body-lst
                                                  body-exp
                                                  nextp
                                                  fail-k
                                                  #t
                                                  (add-pat-var (syntax var) pvar-lst)
                                                  depth
                                                  cata-fun
                                                  cata-defs
                                                  dotted-vars)])
                   (values (with-syntax ([ax attr-exp]
                                         [matched-attrs attr-key-lst]
                                         [body tests])
                             (syntax (let ([var (filter-attributes 'matched-attrs ax)])
                                       body)))
                           new-pvar-lst
                           new-cata-defs
                           new-dotted-vars))]
                [((atag [(unquote [cata -> cvar ...]) default]) . rst)
                 (identifier? (syntax atag))
                 (let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))])
                   (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
                                 (compile-attr-list (syntax rst)
                                                    body-lst
                                                    attr-exp
                                                    body-exp
                                                    (cons (syntax atag) attr-key-lst)
                                                    nextp
                                                    fail-k
                                                    (add-pat-var ctemp pvar-lst)
                                                    depth
                                                    cata-fun
                                                    (add-cata-def depth
                                                                  (syntax [cvar ...])
                                                                  (syntax cata)
                                                                  ctemp
                                                                  cata-defs)
                                                    dotted-vars)])
                     (values (with-syntax ([ax attr-exp]
                                           [ct ctemp]
                                           [body tests])
                               (syntax (let ([binding (match-xml-attribute 'atag ax)])
                                         (let ([ct (if binding
                                                       (cadr binding)
                                                       default)])
                                           body))))
                             new-pvar-lst
                             new-cata-defs
                             new-dotted-vars)))]
                [((atag [(unquote [cvar ...]) default]) . rst)
                 (identifier? (syntax atag))
                 (let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))])
                   (if (not cata-fun)
                       (sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context"
                                                stx
                                                (syntax [cvar ...])))
                   (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
                                 (compile-attr-list (syntax rst)
                                                    body-lst
                                                    attr-exp
                                                    body-exp
                                                    (cons (syntax atag) attr-key-lst)
                                                    nextp
                                                    fail-k
                                                    (add-pat-var ctemp pvar-lst)
                                                    depth
                                                    cata-fun
                                                    (add-cata-def depth
                                                                  (syntax [cvar ...])
                                                                  cata-fun
                                                                  ctemp
                                                                  cata-defs)
                                                    dotted-vars)])
                     (values (with-syntax ([ax attr-exp]
                                           [ct ctemp]
                                           [body tests])
                               (syntax (let ([binding (match-xml-attribute 'atag ax)])
                                         (let ([ct (if binding
                                                       (cadr binding)
                                                       default)])
                                           body))))
                             new-pvar-lst
                             new-cata-defs
                             new-dotted-vars)))]
                [((atag [(unquote var) default]) . rst)
                 (and (identifier? (syntax atag)) (identifier? (syntax var)))
                 (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
                               (compile-attr-list (syntax rst)
                                                  body-lst
                                                  attr-exp
                                                  body-exp
                                                  (cons (syntax atag) attr-key-lst)
                                                  nextp
                                                  fail-k
                                                  (add-pat-var (syntax var) pvar-lst)
                                                  depth
                                                  cata-fun
                                                  cata-defs
                                                  dotted-vars)])
                   (values (with-syntax ([ax attr-exp]
                                         [body tests])
                             (syntax (let ([binding (match-xml-attribute 'atag ax)])
                                       (let ([var (if binding
                                                      (cadr binding)
                                                      default)])
                                         body))))
                           new-pvar-lst
                           new-cata-defs
                           new-dotted-vars))]
                [((atag (unquote [cata -> cvar ...])) . rst)
                 (identifier? (syntax atag))
                 (let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))])
                   (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
                                 (compile-attr-list (syntax rst)
                                                    body-lst
                                                    attr-exp
                                                    body-exp
                                                    (cons (syntax atag) attr-key-lst)
                                                    nextp
                                                    fail-k
                                                    (add-pat-var ctemp pvar-lst)
                                                    depth
                                                    cata-fun
                                                    (add-cata-def depth
                                                                  (syntax [cvar ...])
                                                                  (syntax cata)
                                                                  ctemp
                                                                  cata-defs)
                                                    dotted-vars)])
                     (values (with-syntax ([ax attr-exp]
                                           [ct ctemp]
                                           [body tests]
                                           [fail-to fail-k])
                               (syntax (let ([binding (match-xml-attribute 'atag ax)])
                                         (if binding
                                             (let ([ct (cadr binding)])
                                               body)
                                             (fail-to)))))
                             new-pvar-lst
                             new-cata-defs
                             new-dotted-vars)))]
                [((atag (unquote [cvar ...])) . rst)
                 (identifier? (syntax atag))
                 (let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))])
                   (if (not cata-fun)
                       (sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context"
                                                stx
                                                (syntax [cvar ...])))
                   (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
                                 (compile-attr-list (syntax rst)
                                                    body-lst
                                                    attr-exp
                                                    body-exp
                                                    (cons (syntax atag) attr-key-lst)
                                                    nextp
                                                    fail-k
                                                    (add-pat-var ctemp pvar-lst)
                                                    depth
                                                    cata-fun
                                                    (add-cata-def depth
                                                                  (syntax [cvar ...])
                                                                  cata-fun
                                                                  ctemp
                                                                  cata-defs)
                                                    dotted-vars)])
                     (values (with-syntax ([ax attr-exp]
                                           [ct ctemp]
                                           [body tests]
                                           [fail-to fail-k])
                               (syntax (let ([binding (match-xml-attribute 'atag ax)])
                                         (if binding
                                             (let ([ct (cadr binding)])
                                               body)
                                             (fail-to)))))
                             new-pvar-lst
                             new-cata-defs
                             new-dotted-vars)))]
                [((atag (unquote var)) . rst)
                 (and (identifier? (syntax atag)) (identifier? (syntax var)))
                 (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
                               (compile-attr-list (syntax rst)
                                                  body-lst
                                                  attr-exp
                                                  body-exp
                                                  (cons (syntax atag) attr-key-lst)
                                                  nextp
                                                  fail-k
                                                  (add-pat-var (syntax var) pvar-lst)
                                                  depth
                                                  cata-fun
                                                  cata-defs
                                                  dotted-vars)])
                   (values (with-syntax ([ax attr-exp]
                                         [body tests]
                                         [fail-to fail-k])
                             (syntax (let ([binding (match-xml-attribute 'atag ax)])
                                       (if binding
                                           (let ([var (cadr binding)])
                                             body)
                                           (fail-to)))))
                           new-pvar-lst
                           new-cata-defs
                           new-dotted-vars))]
                [((atag (i ...)) . rst)
                 (identifier? (syntax atag))
                 (sxml-match-syntax-error "bad attribute pattern"
                                          stx
                                          (syntax (kwd (i ...))))]
                [((atag i) . rst)
                 (and (identifier? (syntax atag)) (identifier? (syntax i)))
                 (sxml-match-syntax-error "bad attribute pattern"
                                          stx
                                          (syntax (kwd i)))]
                [((atag literal) . rst)
                 (and (identifier? (syntax atag)) (literal? (syntax literal)))
                 (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
                               (compile-attr-list (syntax rst)
                                                  body-lst
                                                  attr-exp
                                                  body-exp
                                                  (cons (syntax atag) attr-key-lst)
                                                  nextp
                                                  fail-k
                                                  pvar-lst
                                                  depth
                                                  cata-fun
                                                  cata-defs
                                                  dotted-vars)])
                   (values (with-syntax ([ax attr-exp]
                                         [body tests]
                                         [fail-to fail-k])
                             (syntax (let ([binding (match-xml-attribute 'atag ax)])
                                       (if binding
                                           (if (equal? (cadr binding) literal)
                                               body
                                               (fail-to))
                                           (fail-to)))))
                           new-pvar-lst
                           new-cata-defs
                           new-dotted-vars))]
                [()
                 (compile-item-list body-lst
                                    body-exp
                                    nextp
                                    fail-k
                                    #t
                                    pvar-lst
                                    depth
                                    cata-fun
                                    cata-defs
                                    dotted-vars)]))]
           [compile-item-list
            (lambda (lst exp nextp fail-k ellipsis-allowed? pvar-lst depth cata-fun cata-defs dotted-vars)
              (syntax-case lst (unquote ->)
                [() (compile-end-element exp nextp fail-k pvar-lst cata-defs dotted-vars)]
                [(unquote var)
                 (identifier? (syntax var))
                 (if (not ellipsis-allowed?)
                     (sxml-match-syntax-error "improper list pattern not allowed in this context"
                                              stx
                                              (syntax dots))
                     (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars)
                                   (nextp (add-pat-var (syntax var) pvar-lst) cata-defs dotted-vars)])
                       (values (with-syntax ([x exp]
                                             [body next-tests])
                                 (syntax (let ([var x]) body)))
                               new-pvar-lst
                               new-cata-defs
                               new-dotted-vars)))]
                [(unquote [cata -> cvar ...])
                 (if (not ellipsis-allowed?)
                     (sxml-match-syntax-error "improper list pattern not allowed in this context"
                                              stx
                                              (syntax dots))
                     (let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))])
                       (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars)
                                     (nextp (add-pat-var ctemp pvar-lst)
                                            (add-cata-def depth
                                                          (syntax [cvar ...])
                                                          (syntax cata)
                                                          ctemp
                                                          cata-defs)
                                            dotted-vars)])
                         (values (with-syntax ([ct ctemp]
                                               [x exp]
                                               [body next-tests])
                                   (syntax (let ([ct x]) body)))
                                 new-pvar-lst
                                 new-cata-defs
                                 new-dotted-vars))))]
                [(unquote [cvar ...])
                 (let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))])
                   (if (not cata-fun)
                       (sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context"
                                                stx
                                                (syntax [cvar ...])))
                   (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars)
                                 (nextp (add-pat-var ctemp pvar-lst)
                                        (add-cata-def depth
                                                      (syntax [cvar ...])
                                                      cata-fun
                                                      ctemp
                                                      cata-defs)
                                        dotted-vars)])
                     (values (with-syntax ([ct ctemp]
                                           [x exp]
                                           [body next-tests])
                               (syntax (let ([ct x]) body)))
                             new-pvar-lst
                             new-cata-defs
                             new-dotted-vars)))]
                [(item dots . rst)
                 (ellipsis? (syntax dots))
                 (if (not ellipsis-allowed?)
                     (sxml-match-syntax-error "ellipses not allowed in this context"
                                              stx
                                              (syntax dots))
                     (compile-dotted-pattern-list (syntax item)
                                                  (syntax rst)
                                                  exp
                                                  nextp
                                                  fail-k
                                                  pvar-lst
                                                  depth
                                                  cata-fun
                                                  cata-defs
                                                  dotted-vars))]
                [(item . rst)
                 (compile-item (syntax item)
                               exp
                               (lambda (new-exp new-pvar-lst new-cata-defs new-dotted-vars)
                                 (compile-item-list (syntax rst)
                                                    new-exp
                                                    nextp
                                                    fail-k
                                                    ellipsis-allowed?
                                                    new-pvar-lst
                                                    depth
                                                    cata-fun
                                                    new-cata-defs
                                                    new-dotted-vars))
                               fail-k
                               pvar-lst
                               depth
                               cata-fun
                               cata-defs
                               dotted-vars)]))]
           [compile-dotted-pattern-list
            (lambda (item
                     tail
                     exp
                     nextp
                     fail-k
                     pvar-lst
                     depth
                     cata-fun
                     cata-defs
                     dotted-vars)
              (let-values ([(tail-tests tail-pvar-lst tail-cata-defs tail-dotted-vars)
                            (compile-item-list tail
                                               (syntax lst)
                                               (lambda (new-pvar-lst new-cata-defs new-dotted-vars)
                                                 (values (with-syntax ([(npv ...) new-pvar-lst])
                                                           (syntax (values #t npv ...)))
                                                         new-pvar-lst
                                                         new-cata-defs
                                                         new-dotted-vars))
                                               (syntax fail)
                                               #f
                                               '()
                                               depth
                                               '()
                                               '()
                                               dotted-vars)]
                           [(item-tests item-pvar-lst item-cata-defs item-dotted-vars)
                            (compile-item item
                                          (syntax lst)
                                          (lambda (new-exp new-pvar-lst new-cata-defs new-dotted-vars)
                                            (values (with-syntax ([(npv ...) new-pvar-lst])
                                                      (syntax (values #t (cdr lst) npv ...)))
                                                    new-pvar-lst
                                                    new-cata-defs
                                                    new-dotted-vars))
                                          (syntax fail)
                                          '()
                                          (+ 1 depth)
                                          cata-fun
                                          '()
                                          dotted-vars)])
                ; more here: check for duplicate pat-vars, cata-defs
                (let-values ([(final-tests final-pvar-lst final-cata-defs final-dotted-vars)
                              (nextp (append tail-pvar-lst item-pvar-lst pvar-lst)
                                     (append tail-cata-defs item-cata-defs cata-defs)
                                     (append item-pvar-lst
                                             (cata-defs->pvar-lst item-cata-defs)
                                             tail-dotted-vars
                                             dotted-vars))])
                  (let ([temp-item-pvar-lst (generate-temporaries item-pvar-lst)])
                    (values
                     (with-syntax
                         ([x exp]
                          [fail-to fail-k]
                          [tail-body tail-tests]
                          [item-body item-tests]
                          [final-body final-tests]
                          [(ipv ...) item-pvar-lst]
                          [(gpv ...) temp-item-pvar-lst]
                          [(tpv ...) tail-pvar-lst]
                          [(item-void ...) (map (lambda (i) (syntax (void))) item-pvar-lst)]
                          [(tail-void ...) (map (lambda (i) (syntax (void))) tail-pvar-lst)]
                          [(item-null ...) (map (lambda (i) (syntax '())) item-pvar-lst)]
                          [(item-cons ...) (map (lambda (a b)
                                                  (with-syntax ([xa a]
                                                                [xb b])
                                                    (syntax (cons xa xb))))
                                                item-pvar-lst
                                                temp-item-pvar-lst)])
                       (syntax (letrec ([match-tail
                                         (lambda (lst fail)
                                           tail-body)]
                                        [match-item
                                         (lambda (lst)
                                           (let ([fail (lambda ()
                                                         (values #f
                                                                 lst
                                                                 item-void ...))])
                                             item-body))]
                                        [match-dotted
                                         (lambda (x)
                                           (let-values ([(tail-res tpv ...)
                                                         (match-tail x
                                                                     (lambda ()
                                                                       (values #f
                                                                               tail-void ...)))])
                                             (if tail-res
                                                 (values item-null ...
                                                         tpv ...)
                                                 (let-values ([(res new-x ipv ...) (match-item x)])
                                                   (if res
                                                       (let-values ([(gpv ... tpv ...)
                                                                     (match-dotted new-x)])
                                                         (values item-cons ... tpv ...))
                                                       (let-values ([(last-tail-res tpv ...)
                                                                     (match-tail x fail-to)])
                                                         (values item-null ... tpv ...)))))))])
                                 (let-values ([(ipv ... tpv ...)
                                               (match-dotted x)])
                                   final-body))))
                     final-pvar-lst
                     final-cata-defs
                     final-dotted-vars)))))]
           [compile-item
            (lambda (item exp nextp fail-k pvar-lst depth cata-fun cata-defs dotted-vars)
              (syntax-case item (unquote ->)
                ; normal pattern var
                [(unquote var)
                 (identifier? (syntax var))
                 (let ([new-exp (car (generate-temporaries (list exp)))])
                   (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars)
                                 (nextp new-exp (add-pat-var (syntax var) pvar-lst) cata-defs dotted-vars)])
                     (values (with-syntax ([x exp]
                                           [nx new-exp]
                                           [body next-tests]
                                           [fail-to fail-k])
                               (syntax (if (pair? x)
                                           (let ([nx (cdr x)]
                                                 [var (car x)])
                                             body)
                                           (fail-to))))
                             new-pvar-lst
                             new-cata-defs
                             new-dotted-vars)))]
                ; named catamorphism
                [(unquote [cata -> cvar ...])
                 (let ([new-exp (car (generate-temporaries (list exp)))]
                       [ctemp (car (generate-temporaries (syntax ([cvar ...]))))])
                   (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars)
                                 (nextp new-exp
                                        (add-pat-var ctemp pvar-lst)
                                        (add-cata-def depth
                                                      (syntax [cvar ...])
                                                      (syntax cata)
                                                      ctemp
                                                      cata-defs)
                                        dotted-vars)])
                     (values (with-syntax ([x exp]
                                           [nx new-exp]
                                           [ct ctemp]
                                           [body next-tests]
                                           [fail-to fail-k])
                               (syntax (if (pair? x)
                                           (let ([nx (cdr x)]
                                                 [ct (car x)])
                                             body)
                                           (fail-to))))
                             new-pvar-lst
                             new-cata-defs
                             new-dotted-vars)))]
                ; basic catamorphism
                [(unquote [cvar ...])
                 (let ([new-exp (car (generate-temporaries (list exp)))]
                       [ctemp (car (generate-temporaries (syntax ([cvar ...]))))])
                   (if (not cata-fun)
                       (sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context"
                                                stx
                                                (syntax [cvar ...])))
                   (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars)
                                 (nextp new-exp
                                        (add-pat-var ctemp pvar-lst)
                                        (add-cata-def depth
                                                      (syntax [cvar ...])
                                                      cata-fun
                                                      ctemp
                                                      cata-defs)
                                        dotted-vars)])
                     (values (with-syntax ([x exp]
                                           [nx new-exp]
                                           [ct ctemp]
                                           [body next-tests]
                                           [fail-to fail-k])
                               (syntax (if (pair? x)
                                           (let ([nx (cdr x)]
                                                 [ct (car x)])
                                             body)
                                           (fail-to))))
                             new-pvar-lst
                             new-cata-defs
                             new-dotted-vars)))]
                [(tag item ...)
                 (identifier? (syntax tag))
                 (let ([new-exp (car (generate-temporaries (list exp)))])
                   (let-values ([(after-tests after-pvar-lst after-cata-defs after-dotted-vars)
                                 (compile-element-pat (syntax (tag item ...))
                                                      (with-syntax ([x exp])
                                                        (syntax (car x)))
                                                      (lambda (more-pvar-lst more-cata-defs more-dotted-vars)
                                                        (let-values ([(next-tests new-pvar-lst
                                                                                new-cata-defs
                                                                                new-dotted-vars)
                                                                      (nextp new-exp
                                                                             more-pvar-lst
                                                                             more-cata-defs
                                                                             more-dotted-vars)])
                                                          (values (with-syntax ([x exp]
                                                                                [nx new-exp]
                                                                                [body next-tests])
                                                                    (syntax (let ([nx (cdr x)])
                                                                              body)))
                                                                  new-pvar-lst
                                                                  new-cata-defs
                                                                  new-dotted-vars)))
                                                      fail-k
                                                      pvar-lst
                                                      depth
                                                      cata-fun
                                                      cata-defs
                                                      dotted-vars)])
                     ; test that we are not at the end of an item-list, BEFORE
                     ; entering tests for the element pattern (against the 'car' of the item-list)
                     (values (with-syntax ([x exp]
                                           [body after-tests]
                                           [fail-to fail-k])
                               (syntax (if (pair? x)
                                           body
                                           (fail-to))))
                             after-pvar-lst
                             after-cata-defs
                             after-dotted-vars)))]
                [(i ...)
                 (sxml-match-syntax-error "bad pattern syntax (not an element pattern)"
                                          stx
                                          (syntax (i ...)))]
                [i
                 (identifier? (syntax i))
                 (sxml-match-syntax-error "bad pattern syntax (symbol not allowed in this context)"
                                          stx
                                          (syntax i))]
                [literal
                 (literal? (syntax literal))
                 (let ([new-exp (car (generate-temporaries (list exp)))])
                   (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars)
                                 (nextp new-exp pvar-lst cata-defs dotted-vars)])
                     (values (with-syntax ([x exp]
                                           [nx new-exp]
                                           [body next-tests]
                                           [fail-to fail-k])
                               (syntax (if (and (pair? x) (equal? literal (car x)))
                                           (let ([nx (cdr x)])
                                             body)
                                           (fail-to))))
                             new-pvar-lst
                             new-cata-defs
                             new-dotted-vars)))]))])
        (let ([fail-k (syntax failure)])
          (syntax-case stx (unquote guard ->)
            [(compile-clause ((unquote var) (guard gexp ...) action0 action ...)
                             exp
                             cata-fun
                             fail-exp)
             (identifier? (syntax var))
             (syntax (let ([var exp])
                       (if (and gexp ...)
                           (begin action0 action ...)
                           (fail-exp))))]
            [(compile-clause ((unquote [cata -> cvar ...]) (guard gexp ...) action0 action ...)
                             exp
                             cata-fun
                             fail-exp)
             (syntax (if (and gexp ...)
                         (let-values ([(cvar ...) (cata exp)])
                           (begin action0 action ...))
                         (fail-exp)))]
            [(compile-clause ((unquote [cvar ...]) (guard gexp ...) action0 action ...)
                             exp
                             cata-fun
                             fail-exp)
             (if (not (extract-cata-fun (syntax cata-fun)))
                 (sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context"
                                          stx
                                          (syntax [cvar ...]))
                 (syntax (if (and gexp ...)
                             (let-values ([(cvar ...) (cata-fun exp)])
                               (begin action0 action ...))
                             (fail-exp))))]
            [(compile-clause ((unquote var) action0 action ...) exp cata-fun fail-exp)
             (identifier? (syntax var))
             (syntax (let ([var exp])
                       action0 action ...))]
            [(compile-clause ((unquote [cata -> cvar ...]) action0 action ...) exp cata-fun fail-exp)
             (syntax (let-values ([(cvar ...) (cata exp)])
                       action0 action ...))]
            [(compile-clause ((unquote [cvar ...]) action0 action ...) exp cata-fun fail-exp)
             (if (not (extract-cata-fun (syntax cata-fun)))
                 (sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context"
                                          stx
                                          (syntax [cvar ...]))
                 (syntax (let-values ([(cvar ...) (cata-fun exp)])
                           action0 action ...)))]
            [(compile-clause ((lst . rst) (guard gexp ...) action0 action ...) exp cata-fun fail-exp)
             (and (identifier? (syntax lst)) (eq? 'list (syntax-object->datum (syntax lst))))
             (let-values ([(result pvar-lst cata-defs dotted-vars)
                           (compile-item-list (syntax rst)
                                              (syntax exp)
                                              (lambda (new-pvar-lst new-cata-defs new-dotted-vars)
                                                (values
                                                 (with-syntax
                                                     ([exp-body (process-cata-defs new-cata-defs
                                                                                (process-output-action
                                                                                (syntax (begin action0
                                                                                action ...))
                                                                                new-dotted-vars))]
                                                      [fail-to fail-k])
                                                   (syntax (if (and gexp ...) exp-body (fail-to))))
                                                 new-pvar-lst
                                                 new-cata-defs
                                                 new-dotted-vars))
                                              fail-k
                                              #t
                                              '()
                                              0
                                              (extract-cata-fun (syntax cata-fun))
                                              '()
                                              '())])
               (with-syntax ([fail-to fail-k]
                             [body result])
                 (syntax (let ([fail-to fail-exp])
                           (if (nodeset? exp)
                               body
                               (fail-to))))))]
            [(compile-clause ((lst . rst) action0 action ...) exp cata-fun fail-exp)
             (and (identifier? (syntax lst)) (eq? 'list (syntax-object->datum (syntax lst))))
             (let-values ([(result pvar-lst cata-defs dotted-vars)
                           (compile-item-list (syntax rst)
                                              (syntax exp)
                                              (lambda (new-pvar-lst new-cata-defs new-dotted-vars)
                                                (values (process-cata-defs new-cata-defs
                                                                           (process-output-action
                                                                            (syntax (begin action0
                                                                                action ...))
                                                                            new-dotted-vars))
                                                        new-pvar-lst
                                                        new-cata-defs
                                                        new-dotted-vars))
                                              fail-k
                                              #t
                                              '()
                                              0
                                              (extract-cata-fun (syntax cata-fun))
                                              '()
                                              '())])
               (with-syntax ([body result]
                             [fail-to fail-k])
                 (syntax (let ([fail-to fail-exp])
                           (if (nodeset? exp)
                               body
                               (fail-to))))))]
            [(compile-clause ((fst . rst) (guard gexp ...) action0 action ...) exp cata-fun fail-exp)
             (identifier? (syntax fst))
             (let-values ([(result pvar-lst cata-defs dotted-vars)
                           (compile-element-pat (syntax (fst . rst))
                                                (syntax exp)
                                                (lambda (new-pvar-lst new-cata-defs new-dotted-vars)
                                                  (values
                                                   (with-syntax
                                                       ([body (process-cata-defs new-cata-defs
                                                                                (process-output-action
                                                                                (syntax (begin action0
                                                                                action ...))
                                                                                new-dotted-vars))]
                                                        [fail-to fail-k])
                                                     (syntax (if (and gexp ...) body (fail-to))))
                                                   new-pvar-lst
                                                   new-cata-defs
                                                   new-dotted-vars))
                                                fail-k
                                                '()
                                                0
                                                (extract-cata-fun (syntax cata-fun))
                                                '()
                                                '())])
               (with-syntax ([fail-to fail-k]
                             [body result])
                 (syntax (let ([fail-to fail-exp])
                           body))))]
            [(compile-clause ((fst . rst) action0 action ...) exp cata-fun fail-exp)
             (identifier? (syntax fst))
             (let-values ([(result pvar-lst cata-defs dotted-vars)
                           (compile-element-pat (syntax (fst . rst))
                                                (syntax exp)
                                                (lambda (new-pvar-lst new-cata-defs new-dotted-vars)
                                                  (values (process-cata-defs new-cata-defs
                                                                             (process-output-action
                                                                              (syntax (begin action0
                                                                                action ...))
                                                                              new-dotted-vars))
                                                          new-pvar-lst
                                                          new-cata-defs
                                                          new-dotted-vars))
                                                fail-k
                                                '()
                                                0
                                                (extract-cata-fun (syntax cata-fun))
                                                '()
                                                '())])
               (with-syntax ([fail-to fail-k]
                             [body result])
                 (syntax (let ([fail-to fail-exp])
                           body))))]
            [(compile-clause ((i ...) (guard gexp ...) action0 action ...) exp cata-fun fail-exp)
             (sxml-match-syntax-error "bad pattern syntax (not an element pattern)"
                                      stx
                                      (syntax (i ...)))]
            [(compile-clause ((i ...) action0 action ...) exp cata-fun fail-exp)
             (sxml-match-syntax-error "bad pattern syntax (not an element pattern)"
                                      stx
                                      (syntax (i ...)))]
            [(compile-clause (pat (guard gexp ...) action0 action ...) exp cata-fun fail-exp)
             (identifier? (syntax pat))
             (sxml-match-syntax-error "bad pattern syntax (symbol not allowed in this context)"
                                      stx
                                      (syntax pat))]
            [(compile-clause (pat action0 action ...) exp cata-fun fail-exp)
             (identifier? (syntax pat))
             (sxml-match-syntax-error "bad pattern syntax (symbol not allowed in this context)"
                                      stx
                                      (syntax pat))]
            [(compile-clause (literal (guard gexp ...) action0 action ...) exp cata-fun fail-exp)
             (literal? (syntax literal))
             (syntax (if (and (equal? literal exp) (and gexp ...))
                         (begin action0 action ...)
                         (fail-exp)))]
            [(compile-clause (literal action0 action ...) exp cata-fun fail-exp)
             (literal? (syntax literal))
             (syntax (if (equal? literal exp)
                         (begin action0 action ...)
                         (fail-exp)))])))))

  (define-syntax sxml-match1
    (syntax-rules ()
      [(sxml-match1 exp cata-fun clause)
       (compile-clause clause exp cata-fun
                       (lambda () (error 'sxml-match "no matching clause found")))]
      [(sxml-match1 exp cata-fun clause0 clause ...)
       (let/ec escape
         (compile-clause clause0 exp cata-fun
                         (lambda () (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 ...))))])))

  )

license: mit


code:
;;;; (sxml transform) -- pre- and post-order sxml transformation
;;;;
;;;; 	Copyright (C) 2009  Free Software Foundation, Inc.
;;;;    Modified 2004 by Andy Wingo <wingo at pobox dot com>.
;;;;    Written 2003 by Oleg Kiselyov <oleg at pobox dot com> as SXML-tree-trans.scm.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;

;;; Commentary:
;;
;;@heading SXML expression tree transformers
;
;@subheading Pre-Post-order traversal of a tree and creation of a new tree
;@smallexample
;pre-post-order:: <tree> x <bindings> -> <new-tree>
;@end smallexample
; where
;@smallexample
; <bindings> ::= (<binding> ...)
; <binding> ::= (<trigger-symbol> *preorder* . <handler>) |
;               (<trigger-symbol> *macro* . <handler>) |
;		(<trigger-symbol> <new-bindings> . <handler>) |
;		(<trigger-symbol> . <handler>)
; <trigger-symbol> ::= XMLname | *text* | *default*
; <handler> :: <trigger-symbol> x [<tree>] -> <new-tree>
;@end smallexample
;
; The pre-post-order function visits the nodes and nodelists
; pre-post-order (depth-first). For each @code{<Node>} of the form
; @code{(@var{name} <Node> ...)}, it looks up an association with the
; given @var{name} among its @var{<bindings>}. If failed,
; @code{pre-post-order} tries to locate a @code{*default*} binding. It's
; an error if the latter attempt fails as well. Having found a binding,
; the @code{pre-post-order} function first checks to see if the binding
; is of the form
;@smallexample
;	(<trigger-symbol> *preorder* . <handler>)
;@end smallexample
;
; If it is, the handler is 'applied' to the current node. Otherwise, the
; pre-post-order function first calls itself recursively for each child
; of the current node, with @var{<new-bindings>} prepended to the
; @var{<bindings>} in effect. The result of these calls is passed to the
; @var{<handler>} (along with the head of the current @var{<Node>}). To
; be more precise, the handler is _applied_ to the head of the current
; node and its processed children. The result of the handler, which
; should also be a @code{<tree>}, replaces the current @var{<Node>}. If
; the current @var{<Node>} is a text string or other atom, a special
; binding with a symbol @code{*text*} is looked up.
;
; A binding can also be of a form
;@smallexample
;	(<trigger-symbol> *macro* . <handler>)
;@end smallexample
; This is equivalent to @code{*preorder*} described above. However, the
; result is re-processed again, with the current stylesheet.
;;
;;; Code:

(define-module (sxml transform)
  #:export (SRV:send-reply
            foldts
            post-order
            pre-post-order
            replace-range))

;; Upstream version:
; $Id: SXML-tree-trans.scm,v 1.8 2003/04/24 19:39:53 oleg Exp oleg $

; Like let* but allowing for multiple-value bindings
(define-macro (let*-values bindings . body)
  (if (null? bindings) (cons 'begin body)
      (apply
       (lambda (vars initializer)
	 (let ((cont
		(cons 'let*-values
		      (cons (cdr bindings) body))))
	   (cond
	    ((not (pair? vars))		; regular let case, a single var
	     `(let ((,vars ,initializer)) ,cont))
	    ((null? (cdr vars))		; single var, see the prev case
	     `(let ((,(car vars) ,initializer)) ,cont))
	   (else			; the most generic case
	    `(call-with-values (lambda () ,initializer)
	      (lambda ,vars ,cont))))))
       (car bindings))))

(define (SRV:send-reply . fragments)
  "Output the @var{fragments} to the current output port.

The fragments are a list of strings, characters, numbers, thunks,
@code{#f}, @code{#t} -- and other fragments. The function traverses the
tree depth-first, writes out strings and characters, executes thunks,
and ignores @code{#f} and @code{'()}. The function returns @code{#t} if
anything was written at all; otherwise the result is @code{#f} If
@code{#t} occurs among the fragments, it is not written out but causes
the result of @code{SRV:send-reply} to be @code{#t}."
  (let loop ((fragments fragments) (result #f))
    (cond
      ((null? fragments) result)
      ((not (car fragments)) (loop (cdr fragments) result))
      ((null? (car fragments)) (loop (cdr fragments) result))
      ((eq? #t (car fragments)) (loop (cdr fragments) #t))
      ((pair? (car fragments))
        (loop (cdr fragments) (loop (car fragments) result)))
      ((procedure? (car fragments))
        ((car fragments))
        (loop (cdr fragments) #t))
      (else
        (display (car fragments))
        (loop (cdr fragments) #t)))))

;------------------------------------------------------------------------
;	          Traversal of an SXML tree or a grove:
;			a <Node> or a <Nodelist>
;
; A <Node> and a <Nodelist> are mutually-recursive datatypes that
; underlie the SXML tree:
;	<Node> ::= (name . <Nodelist>) | "text string"
; An (ordered) set of nodes is just a list of the constituent nodes:
; 	<Nodelist> ::= (<Node> ...)
; Nodelists, and Nodes other than text strings are both lists. A
; <Nodelist> however is either an empty list, or a list whose head is
; not a symbol (an atom in general). A symbol at the head of a node is
; either an XML name (in which case it's a tag of an XML element), or
; an administrative name such as '@'.
; See SXPath.scm and SSAX.scm for more information on SXML.

;; see the commentary for docs
(define (pre-post-order tree bindings)
  (let* ((default-binding (assq '*default* bindings))
	 (text-binding (or (assq '*text* bindings) default-binding))
	 (text-handler			; Cache default and text bindings
	   (and text-binding
	     (if (procedure? (cdr text-binding))
	         (cdr text-binding) (cddr text-binding)))))
    (let loop ((tree tree))
      (cond
	((null? tree) '())
	((not (pair? tree))
	  (let ((trigger '*text*))
	    (if text-handler (text-handler trigger tree)
	      (error "Unknown binding for " trigger " and no default"))))
	((not (symbol? (car tree))) (map loop tree)) ; tree is a nodelist
	(else				; tree is an SXML node
	  (let* ((trigger (car tree))
		 (binding (or (assq trigger bindings) default-binding)))
	    (cond
	      ((not binding)
		(error "Unknown binding for " trigger " and no default"))
	      ((not (pair? (cdr binding)))  ; must be a procedure: handler
		(apply (cdr binding) trigger (map loop (cdr tree))))
	      ((eq? '*preorder* (cadr binding))
		(apply (cddr binding) tree))
	      ((eq? '*macro* (cadr binding))
		(loop (apply (cddr binding) tree)))
	      (else			    ; (cadr binding) is a local binding
		(apply (cddr binding) trigger
		  (pre-post-order (cdr tree) (append (cadr binding) bindings)))
		))))))))

; post-order is a strict subset of pre-post-order without *preorder*
; (let alone *macro*) traversals.
; Now pre-post-order is actually faster than the old post-order.
; The function post-order is deprecated and is aliased below for
; backward compatibility.
(define post-order pre-post-order)

;------------------------------------------------------------------------
;			Extended tree fold
; tree = atom | (node-name tree ...)
;
; foldts fdown fup fhere seed (Leaf str) = fhere seed str
; foldts fdown fup fhere seed (Nd kids) =
;         fup seed $ foldl (foldts fdown fup fhere) (fdown seed) kids

; procedure fhere: seed -> atom -> seed
; procedure fdown: seed -> node -> seed
; procedure fup: parent-seed -> last-kid-seed -> node -> seed
; foldts returns the final seed

(define (foldts fdown fup fhere seed tree)
  (cond
   ((null? tree) seed)
   ((not (pair? tree))		; An atom
    (fhere seed tree))
   (else
    (let loop ((kid-seed (fdown seed tree)) (kids (cdr tree)))
      (if (null? kids)
	  (fup seed kid-seed tree)
	  (loop (foldts fdown fup fhere kid-seed (car kids))
		(cdr kids)))))))

;------------------------------------------------------------------------
; Traverse a forest depth-first and cut/replace ranges of nodes.
;
; The nodes that define a range don't have to have the same immediate
; parent, don't have to be on the same level, and the end node of a
; range doesn't even have to exist. A replace-range procedure removes
; nodes from the beginning node of the range up to (but not including)
; the end node of the range.  In addition, the beginning node of the
; range can be replaced by a node or a list of nodes. The range of
; nodes is cut while depth-first traversing the forest. If all
; branches of the node are cut a node is cut as well.  The procedure
; can cut several non-overlapping ranges from a forest.

;	replace-range:: BEG-PRED x END-PRED x FOREST -> FOREST
; where
;	type FOREST = (NODE ...)
;	type NODE = Atom | (Name . FOREST) | FOREST
;
; The range of nodes is specified by two predicates, beg-pred and end-pred.
;	beg-pred:: NODE -> #f | FOREST
;	end-pred:: NODE -> #f | FOREST
; The beg-pred predicate decides on the beginning of the range. The node
; for which the predicate yields non-#f marks the beginning of the range
; The non-#f value of the predicate replaces the node. The value can be a
; list of nodes. The replace-range procedure then traverses the tree and skips
; all the nodes, until the end-pred yields non-#f. The value of the end-pred
; replaces the end-range node. The new end node and its brothers will be
; re-scanned.
; The predicates are evaluated pre-order. We do not descend into a node that
; is marked as the beginning of the range.

(define (replace-range beg-pred end-pred forest)

  ; loop forest keep? new-forest
  ; forest is the forest to traverse
  ; new-forest accumulates the nodes we will keep, in the reverse
  ; order
  ; If keep? is #t, keep the curr node if atomic. If the node is not atomic,
  ; traverse its children and keep those that are not in the skip range.
  ; If keep? is #f, skip the current node if atomic. Otherwise,
  ; traverse its children. If all children are skipped, skip the node
  ; as well.

  (define (loop forest keep? new-forest)
    (if (null? forest) (values (reverse new-forest) keep?)
	(let ((node (car forest)))
	  (if keep?
	      (cond			; accumulate mode
	       ((beg-pred node) =>	; see if the node starts the skip range
		(lambda (repl-branches)	; if so, skip/replace the node
		  (loop (cdr forest) #f
			(append (reverse repl-branches) new-forest))))
	       ((not (pair? node))	; it's an atom, keep it
		(loop (cdr forest) keep? (cons node new-forest)))
	       (else
		(let*-values
		 (((node?) (symbol? (car node))) ; or is it a nodelist?
		  ((new-kids keep?)		 ; traverse its children
		   (loop (if node? (cdr node) node) #t '())))
		 (loop (cdr forest) keep?
		       (cons
			(if node? (cons (car node) new-kids) new-kids)
			new-forest)))))
	      ; skip mode
	      (cond
	       ((end-pred node) =>	; end the skip range
		(lambda (repl-branches)	; repl-branches will be re-scanned
		  (loop (append repl-branches (cdr forest)) #t
			new-forest)))
	       ((not (pair? node))	; it's an atom, skip it
		(loop (cdr forest) keep? new-forest))
	       (else
		(let*-values
		 (((node?) (symbol? (car node)))  ; or is it a nodelist?
		  ((new-kids keep?)		  ; traverse its children
		   (loop (if node? (cdr node) node) #f '())))
		 (loop (cdr forest) keep?
		       (if (or keep? (pair? new-kids))
			   (cons
			    (if node? (cons (car node) new-kids) new-kids)
			    new-forest)
			   new-forest)		; if all kids are skipped
		       ))))))))			; skip the node too

  (let*-values (((new-forest keep?) (loop forest #t '())))
     new-forest))

;;; arch-tag: 6c814f4b-38f7-42c1-b8ef-ce3447edefc7
;;; transform.scm ends here


code:
The files in this directory are imported directly from upstream SSAX,
and are in the public domain.