3 ;; Version: 1.1, version for PLT Scheme
5 ;; Copyright 2005-9, Jim Bender
6 ;; sxml-match is released under the MIT License
8 (module sxml-match mzscheme
14 (require (rename (lib "fold.ss" "srfi" "1") fold-right fold-right)
15 (rename (lib "filter.ss" "srfi" "1") filter filter))
18 (or (and (pair? x) (not (symbol? (car x)))) (null? x)))
20 (define (xml-element-tag s)
21 (if (and (pair? s) (symbol? (car s)))
23 (error 'xml-element-tag "expected an xml-element, given" s)))
25 (define (xml-element-attributes s)
26 (if (and (pair? s) (symbol? (car s)))
27 (fold-right (lambda (a b)
28 (if (and (pair? a) (eq? '@ (car a)))
30 (filter (lambda (i) (not (and (pair? i) (eq? '@ (car i))))) (cdr a))
31 (fold-right (lambda (c d)
32 (if (and (pair? c) (eq? '@ (car c)))
39 (error 'xml-element-attributes "expected an xml-element, given" s)))
41 (define (xml-element-contents s)
42 (if (and (pair? s) (symbol? (car s)))
44 (not (and (pair? i) (eq? '@ (car i)))))
46 (error 'xml-element-contents "expected an xml-element, given" s)))
48 (define (match-xml-attribute key l)
51 (if (eq? (car (car l)) key)
53 (match-xml-attribute key (cdr l)))))
55 (define (filter-attributes keys lst)
58 (if (member (caar lst) keys)
59 (filter-attributes keys (cdr lst))
60 (cons (car lst) (filter-attributes keys (cdr lst))))))
62 (define-syntax compile-clause
65 ([sxml-match-syntax-error
67 (raise-syntax-error #f msg (with-syntax ([s exp]) (syntax (sxml-match s))) sub))]
70 (and (identifier? stx) (eq? '... (syntax-object->datum stx))))]
73 (let ([x (syntax-object->datum stx)])
80 (and (identifier? stx)
81 (let ([str (symbol->string (syntax-object->datum stx))])
82 (char=? #\: (string-ref str (- (string-length str) 1))))))]
89 (lambda (pvar pvar-lst)
90 (define (check-pvar lst)
93 (if (bound-identifier=? (car lst) pvar)
94 (sxml-match-syntax-error "duplicate pattern variable not allowed"
97 (check-pvar (cdr lst)))))
99 (cons pvar pvar-lst))]
101 (lambda (depth cvars cfun ctemp cdefs)
102 (cons (list depth cvars cfun ctemp) cdefs))]
104 (lambda (depth cfun ctemp)
106 (with-syntax ([cf cfun]
109 (let ([new-ctemp (car (generate-temporaries (list ctemp)))])
110 (with-syntax ([ct ctemp]
112 [body (process-cata-exp (- depth 1) cfun new-ctemp)])
113 (syntax (map (lambda (nct) body) ct))))))]
115 (lambda (cata-defs body)
116 (if (null? cata-defs)
118 (with-syntax ([(cata-binding ...)
120 (with-syntax ([bvar (cadr def)]
121 [bval (process-cata-exp (car def)
124 (syntax (bvar bval))))
127 (syntax (let-values (cata-binding ...)
133 (let iter ([items (cadr (car lst))])
134 (syntax-case items ()
135 [() (cata-defs->pvar-lst (cdr lst))]
136 [(fst . rst) (cons (syntax fst) (iter (syntax rst)))]))))]
137 [process-output-action
138 (lambda (action dotted-vars)
139 (define (finite-lst? lst)
142 (identifier? (syntax item))
147 (ellipsis? (syntax dots))
150 (finite-lst? (syntax rst)))))
151 (define (expand-lst lst)
155 (identifier? (syntax item))
158 (ellipsis? (syntax dots))
159 (with-syntax ([exp-lft (expand-dotted-item
160 (process-output-action (syntax fst)
162 [exp-rgt (expand-lst (syntax rst))])
163 (syntax (append exp-lft exp-rgt)))]
165 (with-syntax ([exp-lft (process-output-action (syntax fst)
167 [exp-rgt (expand-lst (syntax rst))])
168 (syntax (cons exp-lft exp-rgt)))]))
169 (define (member-var? var lst)
170 (let iter ([lst lst])
173 (if (or (bound-identifier=? var (car lst))
174 (free-identifier=? var (car lst)))
177 (define (dotted-var? var)
178 (member-var? var dotted-vars))
179 (define (merge-pvars lst1 lst2)
182 (if (member-var? (car lst1) lst2)
183 (merge-pvars (cdr lst1) lst2)
184 (cons (car lst1) (merge-pvars (cdr lst1) lst2)))))
185 (define (select-dotted-vars x)
186 (define (walk-quasi-body y)
187 (syntax-case y (unquote unquote-splicing)
189 (merge-pvars (select-dotted-vars (syntax a))
190 (walk-quasi-body (syntax rst)))]
191 [((unquote-splicing a) . rst)
192 (merge-pvars (select-dotted-vars (syntax a))
193 (walk-quasi-body (syntax rst)))]
195 (merge-pvars (walk-quasi-body (syntax fst))
196 (walk-quasi-body (syntax rst)))]
199 (syntax-case x (quote quasiquote)
201 [(quasiquote . rst) (walk-quasi-body (syntax rst))]
203 (merge-pvars (select-dotted-vars (syntax fst))
204 (select-dotted-vars (syntax rst)))]
206 (and (identifier? (syntax item))
207 (dotted-var? (syntax item)))
208 (list (syntax item))]
210 (define (expand-dotted-item item)
211 (let ([dvars (select-dotted-vars item)])
214 (identifier? (syntax x))
216 [x (with-syntax ([(dv ...) dvars])
217 (syntax (map (lambda (dv ...) x) dv ...)))])))
218 (define (expand-quasiquote-body x)
219 (syntax-case x (unquote unquote-splicing quasiquote)
220 [(quasiquote . rst) (process-quasiquote x)]
222 (with-syntax ([expanded-item (process-output-action (syntax item)
224 (syntax (unquote expanded-item)))]
225 [(unquote-splicing item)
226 (with-syntax ([expanded-item (process-output-action (syntax item)
228 (syntax (unquote-splicing expanded-item)))]
229 [((unquote item) dots . rst)
230 (ellipsis? (syntax dots))
231 (with-syntax ([expanded-item (expand-dotted-item
232 (process-output-action (syntax item)
234 [expanded-rst (expand-quasiquote-body (syntax rst))])
235 (syntax ((unquote-splicing expanded-item) . expanded-rst)))]
237 (ellipsis? (syntax dots))
238 (with-syntax ([expanded-item (expand-dotted-item
239 (process-output-action (syntax (quasiquote item))
241 [expanded-rst (expand-quasiquote-body (syntax rst))])
242 (syntax ((unquote-splicing expanded-item) . expanded-rst)))]
244 (with-syntax ([expanded-fst (expand-quasiquote-body (syntax fst))]
245 [expanded-rst (expand-quasiquote-body (syntax rst))])
246 (syntax (expanded-fst . expanded-rst)))]
248 (define (process-quasiquote x)
250 [(quasiquote term) (with-syntax ([expanded-body (expand-quasiquote-body (syntax term))])
251 (syntax (quasiquote expanded-body)))]
252 [else (sxml-match-syntax-error "bad quasiquote-form"
255 (syntax-case action (quote quasiquote)
256 [(quote . rst) action]
257 [(quasiquote . rst) (process-quasiquote action)]
258 [(fst . rst) (if (finite-lst? action)
259 (with-syntax ([exp-lft (process-output-action (syntax fst) dotted-vars)]
260 [exp-rgt (process-output-action (syntax rst) dotted-vars)])
261 (syntax (exp-lft . exp-rgt)))
262 (with-syntax ([exp-lft (process-output-action (syntax fst)
264 [exp-rgt (expand-lst (syntax rst))])
265 (syntax (apply exp-lft exp-rgt))))]
268 (lambda (ele exp nextp fail-k pvar-lst depth cata-fun cata-defs dotted-vars)
270 [(tag (@ . attr-items) . items)
271 (identifier? (syntax tag))
272 (let ([attr-exp (car (generate-temporaries (list exp)))]
273 [body-exp (car (generate-temporaries (list exp)))])
274 (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
275 (compile-attr-list (syntax attr-items)
287 (values (with-syntax ([x exp]
292 (syntax (if (and (pair? x) (eq? 'tag (xml-element-tag x)))
293 (let ([ax (xml-element-attributes x)]
294 [bx (xml-element-contents x)])
301 (identifier? (syntax tag))
302 (let ([body-exp (car (generate-temporaries (list exp)))])
303 (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
304 (compile-item-list (syntax items)
314 (values (with-syntax ([x exp]
318 (syntax (if (and (pair? x) (eq? 'tag (xml-element-tag x)))
319 (let ([bx (xml-element-contents x)])
324 new-dotted-vars)))]))]
326 (lambda (exp nextp fail-k pvar-lst cata-defs dotted-vars)
327 (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars)
328 (nextp pvar-lst cata-defs dotted-vars)])
329 (values (with-syntax ([x exp]
332 (syntax (if (null? x) body (fail-to))))
337 (lambda (attr-lst body-lst attr-exp body-exp attr-key-lst nextp fail-k pvar-lst depth cata-fun cata-defs dotted-vars)
338 (syntax-case attr-lst (unquote ->)
340 (identifier? (syntax var))
341 (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
342 (compile-item-list body-lst
347 (add-pat-var (syntax var) pvar-lst)
352 (values (with-syntax ([ax attr-exp]
353 [matched-attrs attr-key-lst]
355 (syntax (let ([var (filter-attributes 'matched-attrs ax)])
360 [((atag [(unquote [cata -> cvar ...]) default]) . rst)
361 (identifier? (syntax atag))
362 (let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))])
363 (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
364 (compile-attr-list (syntax rst)
368 (cons (syntax atag) attr-key-lst)
371 (add-pat-var ctemp pvar-lst)
380 (values (with-syntax ([ax attr-exp]
383 (syntax (let ([binding (match-xml-attribute 'atag ax)])
384 (let ([ct (if binding
391 [((atag [(unquote [cvar ...]) default]) . rst)
392 (identifier? (syntax atag))
393 (let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))])
395 (sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context"
397 (syntax [cvar ...])))
398 (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
399 (compile-attr-list (syntax rst)
403 (cons (syntax atag) attr-key-lst)
406 (add-pat-var ctemp pvar-lst)
415 (values (with-syntax ([ax attr-exp]
418 (syntax (let ([binding (match-xml-attribute 'atag ax)])
419 (let ([ct (if binding
426 [((atag [(unquote var) default]) . rst)
427 (and (identifier? (syntax atag)) (identifier? (syntax var)))
428 (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
429 (compile-attr-list (syntax rst)
433 (cons (syntax atag) attr-key-lst)
436 (add-pat-var (syntax var) pvar-lst)
441 (values (with-syntax ([ax attr-exp]
443 (syntax (let ([binding (match-xml-attribute 'atag ax)])
444 (let ([var (if binding
451 [((atag (unquote [cata -> cvar ...])) . rst)
452 (identifier? (syntax atag))
453 (let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))])
454 (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
455 (compile-attr-list (syntax rst)
459 (cons (syntax atag) attr-key-lst)
462 (add-pat-var ctemp pvar-lst)
471 (values (with-syntax ([ax attr-exp]
475 (syntax (let ([binding (match-xml-attribute 'atag ax)])
477 (let ([ct (cadr binding)])
483 [((atag (unquote [cvar ...])) . rst)
484 (identifier? (syntax atag))
485 (let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))])
487 (sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context"
489 (syntax [cvar ...])))
490 (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
491 (compile-attr-list (syntax rst)
495 (cons (syntax atag) attr-key-lst)
498 (add-pat-var ctemp pvar-lst)
507 (values (with-syntax ([ax attr-exp]
511 (syntax (let ([binding (match-xml-attribute 'atag ax)])
513 (let ([ct (cadr binding)])
519 [((atag (unquote var)) . rst)
520 (and (identifier? (syntax atag)) (identifier? (syntax var)))
521 (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
522 (compile-attr-list (syntax rst)
526 (cons (syntax atag) attr-key-lst)
529 (add-pat-var (syntax var) pvar-lst)
534 (values (with-syntax ([ax attr-exp]
537 (syntax (let ([binding (match-xml-attribute 'atag ax)])
539 (let ([var (cadr binding)])
545 [((atag (i ...)) . rst)
546 (identifier? (syntax atag))
547 (sxml-match-syntax-error "bad attribute pattern"
549 (syntax (kwd (i ...))))]
551 (and (identifier? (syntax atag)) (identifier? (syntax i)))
552 (sxml-match-syntax-error "bad attribute pattern"
555 [((atag literal) . rst)
556 (and (identifier? (syntax atag)) (literal? (syntax literal)))
557 (let-values ([(tests new-pvar-lst new-cata-defs new-dotted-vars)
558 (compile-attr-list (syntax rst)
562 (cons (syntax atag) attr-key-lst)
570 (values (with-syntax ([ax attr-exp]
573 (syntax (let ([binding (match-xml-attribute 'atag ax)])
575 (if (equal? (cadr binding) literal)
583 (compile-item-list body-lst
594 (lambda (lst exp nextp fail-k ellipsis-allowed? pvar-lst depth cata-fun cata-defs dotted-vars)
595 (syntax-case lst (unquote ->)
596 [() (compile-end-element exp nextp fail-k pvar-lst cata-defs dotted-vars)]
598 (identifier? (syntax var))
599 (if (not ellipsis-allowed?)
600 (sxml-match-syntax-error "improper list pattern not allowed in this context"
603 (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars)
604 (nextp (add-pat-var (syntax var) pvar-lst) cata-defs dotted-vars)])
605 (values (with-syntax ([x exp]
607 (syntax (let ([var x]) body)))
611 [(unquote [cata -> cvar ...])
612 (if (not ellipsis-allowed?)
613 (sxml-match-syntax-error "improper list pattern not allowed in this context"
616 (let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))])
617 (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars)
618 (nextp (add-pat-var ctemp pvar-lst)
625 (values (with-syntax ([ct ctemp]
628 (syntax (let ([ct x]) body)))
632 [(unquote [cvar ...])
633 (let ([ctemp (car (generate-temporaries (syntax ([cvar ...]))))])
635 (sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context"
637 (syntax [cvar ...])))
638 (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars)
639 (nextp (add-pat-var ctemp pvar-lst)
646 (values (with-syntax ([ct ctemp]
649 (syntax (let ([ct x]) body)))
654 (ellipsis? (syntax dots))
655 (if (not ellipsis-allowed?)
656 (sxml-match-syntax-error "ellipses not allowed in this context"
659 (compile-dotted-pattern-list (syntax item)
670 (compile-item (syntax item)
672 (lambda (new-exp new-pvar-lst new-cata-defs new-dotted-vars)
673 (compile-item-list (syntax rst)
689 [compile-dotted-pattern-list
700 (let-values ([(tail-tests tail-pvar-lst tail-cata-defs tail-dotted-vars)
701 (compile-item-list tail
703 (lambda (new-pvar-lst new-cata-defs new-dotted-vars)
704 (values (with-syntax ([(npv ...) new-pvar-lst])
705 (syntax (values #t npv ...)))
716 [(item-tests item-pvar-lst item-cata-defs item-dotted-vars)
719 (lambda (new-exp new-pvar-lst new-cata-defs new-dotted-vars)
720 (values (with-syntax ([(npv ...) new-pvar-lst])
721 (syntax (values #t (cdr lst) npv ...)))
731 ; more here: check for duplicate pat-vars, cata-defs
732 (let-values ([(final-tests final-pvar-lst final-cata-defs final-dotted-vars)
733 (nextp (append tail-pvar-lst item-pvar-lst pvar-lst)
734 (append tail-cata-defs item-cata-defs cata-defs)
735 (append item-pvar-lst
736 (cata-defs->pvar-lst item-cata-defs)
739 (let ([temp-item-pvar-lst (generate-temporaries item-pvar-lst)])
744 [tail-body tail-tests]
745 [item-body item-tests]
746 [final-body final-tests]
747 [(ipv ...) item-pvar-lst]
748 [(gpv ...) temp-item-pvar-lst]
749 [(tpv ...) tail-pvar-lst]
750 [(item-void ...) (map (lambda (i) (syntax (void))) item-pvar-lst)]
751 [(tail-void ...) (map (lambda (i) (syntax (void))) tail-pvar-lst)]
752 [(item-null ...) (map (lambda (i) (syntax '())) item-pvar-lst)]
753 [(item-cons ...) (map (lambda (a b)
756 (syntax (cons xa xb))))
758 temp-item-pvar-lst)])
759 (syntax (letrec ([match-tail
764 (let ([fail (lambda ()
771 (let-values ([(tail-res tpv ...)
777 (values item-null ...
779 (let-values ([(res new-x ipv ...) (match-item x)])
781 (let-values ([(gpv ... tpv ...)
782 (match-dotted new-x)])
783 (values item-cons ... tpv ...))
784 (let-values ([(last-tail-res tpv ...)
785 (match-tail x fail-to)])
786 (values item-null ... tpv ...)))))))])
787 (let-values ([(ipv ... tpv ...)
792 final-dotted-vars)))))]
794 (lambda (item exp nextp fail-k pvar-lst depth cata-fun cata-defs dotted-vars)
795 (syntax-case item (unquote ->)
798 (identifier? (syntax var))
799 (let ([new-exp (car (generate-temporaries (list exp)))])
800 (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars)
801 (nextp new-exp (add-pat-var (syntax var) pvar-lst) cata-defs dotted-vars)])
802 (values (with-syntax ([x exp]
806 (syntax (if (pair? x)
815 [(unquote [cata -> cvar ...])
816 (let ([new-exp (car (generate-temporaries (list exp)))]
817 [ctemp (car (generate-temporaries (syntax ([cvar ...]))))])
818 (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars)
820 (add-pat-var ctemp pvar-lst)
827 (values (with-syntax ([x exp]
832 (syntax (if (pair? x)
841 [(unquote [cvar ...])
842 (let ([new-exp (car (generate-temporaries (list exp)))]
843 [ctemp (car (generate-temporaries (syntax ([cvar ...]))))])
845 (sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context"
847 (syntax [cvar ...])))
848 (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars)
850 (add-pat-var ctemp pvar-lst)
857 (values (with-syntax ([x exp]
862 (syntax (if (pair? x)
871 (identifier? (syntax tag))
872 (let ([new-exp (car (generate-temporaries (list exp)))])
873 (let-values ([(after-tests after-pvar-lst after-cata-defs after-dotted-vars)
874 (compile-element-pat (syntax (tag item ...))
875 (with-syntax ([x exp])
877 (lambda (more-pvar-lst more-cata-defs more-dotted-vars)
878 (let-values ([(next-tests new-pvar-lst
885 (values (with-syntax ([x exp]
888 (syntax (let ([nx (cdr x)])
899 ; test that we are not at the end of an item-list, BEFORE
900 ; entering tests for the element pattern (against the 'car' of the item-list)
901 (values (with-syntax ([x exp]
904 (syntax (if (pair? x)
909 after-dotted-vars)))]
911 (sxml-match-syntax-error "bad pattern syntax (not an element pattern)"
915 (identifier? (syntax i))
916 (sxml-match-syntax-error "bad pattern syntax (symbol not allowed in this context)"
920 (literal? (syntax literal))
921 (let ([new-exp (car (generate-temporaries (list exp)))])
922 (let-values ([(next-tests new-pvar-lst new-cata-defs new-dotted-vars)
923 (nextp new-exp pvar-lst cata-defs dotted-vars)])
924 (values (with-syntax ([x exp]
928 (syntax (if (and (pair? x) (equal? literal (car x)))
934 new-dotted-vars)))]))])
935 (let ([fail-k (syntax failure)])
936 (syntax-case stx (unquote guard ->)
937 [(compile-clause ((unquote var) (guard gexp ...) action0 action ...)
941 (identifier? (syntax var))
942 (syntax (let ([var exp])
944 (begin action0 action ...)
946 [(compile-clause ((unquote [cata -> cvar ...]) (guard gexp ...) action0 action ...)
950 (syntax (if (and gexp ...)
951 (let-values ([(cvar ...) (cata exp)])
952 (begin action0 action ...))
954 [(compile-clause ((unquote [cvar ...]) (guard gexp ...) action0 action ...)
958 (if (not (extract-cata-fun (syntax cata-fun)))
959 (sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context"
962 (syntax (if (and gexp ...)
963 (let-values ([(cvar ...) (cata-fun exp)])
964 (begin action0 action ...))
966 [(compile-clause ((unquote var) action0 action ...) exp cata-fun fail-exp)
967 (identifier? (syntax var))
968 (syntax (let ([var exp])
969 action0 action ...))]
970 [(compile-clause ((unquote [cata -> cvar ...]) action0 action ...) exp cata-fun fail-exp)
971 (syntax (let-values ([(cvar ...) (cata exp)])
972 action0 action ...))]
973 [(compile-clause ((unquote [cvar ...]) action0 action ...) exp cata-fun fail-exp)
974 (if (not (extract-cata-fun (syntax cata-fun)))
975 (sxml-match-syntax-error "sxml-match pattern: catamorphism not allowed in this context"
978 (syntax (let-values ([(cvar ...) (cata-fun exp)])
979 action0 action ...)))]
980 [(compile-clause ((lst . rst) (guard gexp ...) action0 action ...) exp cata-fun fail-exp)
981 (and (identifier? (syntax lst)) (eq? 'list (syntax-object->datum (syntax lst))))
982 (let-values ([(result pvar-lst cata-defs dotted-vars)
983 (compile-item-list (syntax rst)
985 (lambda (new-pvar-lst new-cata-defs new-dotted-vars)
988 ([exp-body (process-cata-defs new-cata-defs
989 (process-output-action
990 (syntax (begin action0
994 (syntax (if (and gexp ...) exp-body (fail-to))))
1002 (extract-cata-fun (syntax cata-fun))
1005 (with-syntax ([fail-to fail-k]
1007 (syntax (let ([fail-to fail-exp])
1011 [(compile-clause ((lst . rst) action0 action ...) exp cata-fun fail-exp)
1012 (and (identifier? (syntax lst)) (eq? 'list (syntax-object->datum (syntax lst))))
1013 (let-values ([(result pvar-lst cata-defs dotted-vars)
1014 (compile-item-list (syntax rst)
1016 (lambda (new-pvar-lst new-cata-defs new-dotted-vars)
1017 (values (process-cata-defs new-cata-defs
1018 (process-output-action
1019 (syntax (begin action0
1029 (extract-cata-fun (syntax cata-fun))
1032 (with-syntax ([body result]
1034 (syntax (let ([fail-to fail-exp])
1038 [(compile-clause ((fst . rst) (guard gexp ...) action0 action ...) exp cata-fun fail-exp)
1039 (identifier? (syntax fst))
1040 (let-values ([(result pvar-lst cata-defs dotted-vars)
1041 (compile-element-pat (syntax (fst . rst))
1043 (lambda (new-pvar-lst new-cata-defs new-dotted-vars)
1046 ([body (process-cata-defs new-cata-defs
1047 (process-output-action
1048 (syntax (begin action0
1052 (syntax (if (and gexp ...) body (fail-to))))
1059 (extract-cata-fun (syntax cata-fun))
1062 (with-syntax ([fail-to fail-k]
1064 (syntax (let ([fail-to fail-exp])
1066 [(compile-clause ((fst . rst) action0 action ...) exp cata-fun fail-exp)
1067 (identifier? (syntax fst))
1068 (let-values ([(result pvar-lst cata-defs dotted-vars)
1069 (compile-element-pat (syntax (fst . rst))
1071 (lambda (new-pvar-lst new-cata-defs new-dotted-vars)
1072 (values (process-cata-defs new-cata-defs
1073 (process-output-action
1074 (syntax (begin action0
1083 (extract-cata-fun (syntax cata-fun))
1086 (with-syntax ([fail-to fail-k]
1088 (syntax (let ([fail-to fail-exp])
1090 [(compile-clause ((i ...) (guard gexp ...) action0 action ...) exp cata-fun fail-exp)
1091 (sxml-match-syntax-error "bad pattern syntax (not an element pattern)"
1094 [(compile-clause ((i ...) action0 action ...) exp cata-fun fail-exp)
1095 (sxml-match-syntax-error "bad pattern syntax (not an element pattern)"
1098 [(compile-clause (pat (guard gexp ...) action0 action ...) exp cata-fun fail-exp)
1099 (identifier? (syntax pat))
1100 (sxml-match-syntax-error "bad pattern syntax (symbol not allowed in this context)"
1103 [(compile-clause (pat action0 action ...) exp cata-fun fail-exp)
1104 (identifier? (syntax pat))
1105 (sxml-match-syntax-error "bad pattern syntax (symbol not allowed in this context)"
1108 [(compile-clause (literal (guard gexp ...) action0 action ...) exp cata-fun fail-exp)
1109 (literal? (syntax literal))
1110 (syntax (if (and (equal? literal exp) (and gexp ...))
1111 (begin action0 action ...)
1113 [(compile-clause (literal action0 action ...) exp cata-fun fail-exp)
1114 (literal? (syntax literal))
1115 (syntax (if (equal? literal exp)
1116 (begin action0 action ...)
1119 (define-syntax sxml-match1
1121 [(sxml-match1 exp cata-fun clause)
1122 (compile-clause clause exp cata-fun
1123 (lambda () (error 'sxml-match "no matching clause found")))]
1124 [(sxml-match1 exp cata-fun clause0 clause ...)
1126 (compile-clause clause0 exp cata-fun
1127 (lambda () (call-with-values
1128 (lambda () (sxml-match1 exp cata-fun
1132 (define-syntax sxml-match
1134 ((sxml-match val clause0 clause ...)
1135 (letrec ([cfun (lambda (exp)
1136 (sxml-match1 exp cfun clause0 clause ...))])
1139 (define-syntax sxml-match-let1
1141 [(sxml-match-let1 syntag synform () body0 body ...)
1142 (let () body0 body ...)]
1143 [(sxml-match-let1 syntag synform ([pat exp]) body0 body ...)
1144 (compile-clause (pat (let () body0 body ...))
1147 (lambda () (error 'syntag "could not match pattern ~s" 'pat)))]
1148 [(sxml-match-let1 syntag synform ([pat0 exp0] [pat exp] ...) body0 body ...)
1149 (compile-clause (pat0 (sxml-match-let1 syntag synform ([pat exp] ...) body0 body ...))
1152 (lambda () (error 'syntag "could not match pattern ~s" 'pat0)))]))
1154 (define-syntax sxml-match-let-help
1157 [(sxml-match-let-help syntag synform ([pat exp] ...) body0 body ...)
1158 (with-syntax ([(temp-name ...) (generate-temporaries (syntax (exp ...)))])
1159 (syntax (let ([temp-name exp] ...)
1160 (sxml-match-let1 syntag synform ([pat temp-name] ...) body0 body ...))))])))
1162 (define-syntax sxml-match-let
1165 [(sxml-match-let ([pat exp] ...) body0 body ...)
1166 (with-syntax ([synform stx])
1167 (syntax (sxml-match-let-help sxml-match-let synform ([pat exp] ...) body0 body ...)))])))
1169 (define-syntax sxml-match-let*
1172 [(sxml-match-let* () body0 body ...)
1173 (syntax (let () body0 body ...))]
1174 [(sxml-match-let* ([pat0 exp0] [pat exp] ...) body0 body ...)
1175 (with-syntax ([synform stx])
1176 (syntax (sxml-match-let-help sxml-match-let* synform ([pat0 exp0])
1177 (sxml-match-let* ([pat exp] ...)
1178 body0 body ...))))])))