D7net
Home
Console
Upload
information
Create File
Create Folder
About
Tools
:
/
usr
/
share
/
guile
/
2.2
/
sxml
/
Filename :
sxml-match.ss
back
Copy
;; 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 ...))))]))) )