1 ;;; -*- show-trailing-whitespace: t; indent-tabs: nil -*-
3 ;;; Copyright (c) 2007 David Lichteblau. All rights reserved.
5 ;;; Redistribution and use in source and binary forms, with or without
6 ;;; modification, are permitted provided that the following conditions
9 ;;; * Redistributions of source code must retain the above copyright
10 ;;; notice, this list of conditions and the following disclaimer.
12 ;;; * Redistributions in binary form must reproduce the above
13 ;;; copyright notice, this list of conditions and the following
14 ;;; disclaimer in the documentation and/or other materials
15 ;;; provided with the distribution.
17 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
18 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
19 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
20 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
21 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
22 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
23 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
24 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
25 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
26 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
27 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29 (in-package :xuriella
)
31 (defun map-namespace-declarations (fn element
)
32 (let ((parent (stp:parent element
)))
33 (maphash (lambda (prefix uri
)
34 (unless (and (typep parent
'stp
:element
)
35 (equal (stp:find-namespace prefix parent
) uri
))
36 (funcall fn prefix uri
)))
37 (cxml-stp-impl::collect-local-namespaces element
))))
39 (defun maybe-wrap-namespaces (child exprs
)
40 (if (typep child
'stp
:element
)
43 (map-namespace-declarations (lambda (prefix uri
)
44 (push (list prefix uri
) bindings
))
46 (stp:with-attributes
((erp "exclude-result-prefixes" *xsl
*))
48 (dolist (prefix (words (or erp
"")))
49 (when (equal prefix
"#default")
51 (push (or (stp:find-namespace prefix child
)
52 (xslt-error "namespace not found: ~A" prefix
))
55 `((xsl:with-namespaces
,bindings
56 (xsl:with-excluded-namespaces
,excluded-uris
61 (defun parse-body (node &optional
(start 0))
62 (let ((n (stp:count-children-if
#'identity node
)))
65 (let ((child (stp:nth-child i node
)))
66 (maybe-wrap-namespaces
68 (if (namep child
"variable")
69 (stp:with-attributes
(name select
) child
70 (when (and select
(stp:list-children child
))
71 (xslt-error "variable with select and body"))
72 `((let ((,name
,(or select
73 `(progn ,@(parse-body child
)))))
75 (cons (parse-instruction child
)
76 (recurse (1+ i
)))))))))
79 (defun parse-instruction (node)
82 (if (equal (stp:namespace-uri node
) *xsl
*)
83 (parse-instruction/xsl-element
84 (or (find-symbol (stp:local-name node
) :xuriella
)
85 (xslt-error "undefined instruction: ~A" (stp:local-name node
)))
87 (parse-instruction/literal-element node
)))
89 `(xsl:text
,(stp:data node
)))))
91 (defun parse-instruction/literal-element
(node)
93 (,(stp:local-name node
)
94 ,(stp:namespace-uri node
)
95 ,(stp:namespace-prefix node
))
96 ,@(stp:map-attributes
'list
98 `(xsl:literal-attribute
100 ,(stp:namespace-uri a
)
101 ,(stp:namespace-prefix a
))
104 ,@(parse-body node
)))
106 (defmacro define-instruction-parser
(name (node-var) &body body
)
107 `(defmethod parse-instruction/xsl-element
108 ((.name.
(eql ',name
)) ,node-var
)
109 (declare (ignore .name.
))
112 (define-instruction-parser |apply-templates|
(node)
113 (stp:with-attributes
(select mode
) node
114 `(xsl:apply-templates
115 (:select
,select
:mode
,mode
))))
117 (define-instruction-parser |if|
(node)
118 (stp:with-attributes
(test) node
120 ,@(parse-body node
))))
122 (define-instruction-parser |choose|
(node)
124 ,@(stp:map-children
'list
127 ((namep clause
"when")
128 (stp:with-attributes
(test) clause
130 ,@(parse-body clause
))))
131 ((namep clause
"otherwise")
132 `(t ,@(parse-body clause
)))
134 (xslt-error "invalid <choose> clause: ~A"
135 (stp:local-name clause
)))))
138 (define-instruction-parser |element|
(node)
139 (stp:with-attributes
(name namespace use-attribute-sets
) node
140 `(xsl:element
(,name
:namespace namespace
141 :use-attribute-sets use-attribute-sets
)
142 ,@(parse-body node
))))
144 (define-instruction-parser |attribute|
(node)
145 (stp:with-attributes
(name namespace
) node
146 `(xsl:attribute
(,name
:namespace namespace
)
147 ,@(parse-body node
))))
149 (define-instruction-parser |text|
(node)
150 `(xsl:text
,(stp:string-value node
)))
152 (define-instruction-parser |comment|
(node)
153 `(xsl:comment
,@(stp:string-value node
)))
155 (define-instruction-parser |processing-instruction|
(node)
156 (stp:with-attributes
(name) node
157 `(xsl:processing-instruction
,name
158 ,@(parse-body node
))))
160 (define-instruction-parser |value-of|
(node)
161 (stp:with-attributes
(select disable-output-escaping
) node
162 (if disable-output-escaping
163 `(xsl:unescaped-value-of
,select
)
164 `(xsl:value-of
,select
))))
166 (define-instruction-parser |copy-of|
(node)
167 (stp:with-attributes
(select) node
168 `(xsl:copy-of
,select
)))
170 (define-instruction-parser |copy|
(node)
171 (stp:with-attributes
(use-attribute-sets) node
172 `(xsl:copy
(:use-attribute-sets
,use-attribute-sets
)
173 ,@(parse-body node
))))
175 (define-instruction-parser |variable|
(node)
176 (error "unhandled xsl:variable"))
178 (define-instruction-parser |for-each|
(node)
179 (stp:with-attributes
(select) node
180 (multiple-value-bind (decls body-position
)
183 for child in
(stp:list-children node
)
184 while
(namep node
"sort")
185 collect
(parse-sort node
) into decls
186 finally
(return (values decls i
)))
187 `(xsl:for-each
,select
189 ,@(parse-body node body-position
)))))
191 (defun parse-sort (node)
192 (stp:with-attributes
(select lang data-type order case-order
) node
193 `(sort :select
,select
195 :data-type
,data-type
197 :case-order
,case-order
)))
199 (define-instruction-parser |message|
(node)
200 `(xsl:message
,@(parse-body node
)))
202 (define-instruction-parser |terminate|
(node)
203 `(xsl:terminate
,@(parse-body node
)))