FM / sxml

/usr/share/guile/3.0/sxml

Name	Size	Mode	Actions
ssax/	-	0755	rm
upstream/	-	0755	rm
apply-templates.scm	3951	0644	edit dl rm
fold.scm	8644	0644	edit dl rm
match.scm	2240	0644	edit dl rm
simple.scm	14218	0644	edit dl rm
ssax.scm	11011	0644	edit dl rm
sxml-match.ss	68295	0644	edit dl rm
transform.scm	12117	0644	edit dl rm
xpath.scm	19834	0644	edit dl rm

Edit: /usr/share/guile/3.0/sxml/sxml-match.ss (68295B)

;; 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 ...))))])))
  
  )

cmd: