123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182 |
- (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)])
-
- (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 ->)
-
- [(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)))]
-
- [(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)))]
-
- [(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)])
-
-
- (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 ...))))])))
-
- )
|