1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
3 ;;; Copyright (c) 2007,2008 David Lichteblau, Ivan Shvedunov.
4 ;;; All rights reserved.
6 ;;; Redistribution and use in source and binary forms, with or without
7 ;;; modification, are permitted provided that the following conditions
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
13 ;;; * Redistributions in binary form must reproduce the above
14 ;;; copyright notice, this list of conditions and the following
15 ;;; disclaimer in the documentation and/or other materials
16 ;;; provided with the distribution.
18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
21 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
30 (in-package :xuriella
)
32 (defun map-namespace-declarations (fn element
)
33 (let ((parent (stp:parent element
)))
34 (maphash (lambda (prefix uri
)
35 (unless (and (typep parent
'stp
:element
)
36 (equal (stp:find-namespace prefix parent
) uri
))
37 (funcall fn prefix uri
)))
38 (cxml-stp-impl::collect-local-namespaces element
))))
40 (defun maybe-wrap-namespaces (child exprs
)
41 (if (typep child
'stp
:element
)
44 (map-namespace-declarations (lambda (prefix uri
)
45 (push (list prefix uri
) bindings
))
47 (stp:with-attributes
((erp "exclude-result-prefixes" *xsl
*))
49 (dolist (prefix (words (or erp
"")))
50 (when (equal prefix
"#default")
52 (push (or (stp:find-namespace prefix child
)
53 (xslt-error "namespace not found: ~A" prefix
))
56 `((xsl:with-namespaces
,bindings
57 (xsl:with-excluded-namespaces
,excluded-uris
62 (defun parse-body (node &optional
(start 0) (param-names '()))
63 (let ((n (stp:count-children-if
#'identity node
)))
66 (let ((child (stp:nth-child i node
)))
67 (maybe-wrap-namespaces
69 (if (namep child
"variable")
70 (stp:with-attributes
(name select
) child
71 (when (and select
(stp:list-children child
))
72 (xslt-error "variable with select and body"))
73 `((let ((,name
,(or select
74 `(progn ,@(parse-body child
)))))
75 (xsl:with-duplicates-check
(,name
)
76 ,@(recurse (1+ i
))))))
77 (cons (parse-instruction child
)
78 (recurse (1+ i
)))))))))
79 (let ((result (recurse start
)))
81 `((xsl:with-duplicates-check
(,@param-names
)
85 (defun parse-param (node)
87 (stp:with-attributes
(name select
) node
89 (xslt-error "name not specified for parameter"))
90 (when (and select
(stp:list-children node
))
91 (xslt-error "param with select and body"))
94 `(progn ,@(parse-body node
))))))
96 (defun parse-instruction (node)
101 ((equal (stp:namespace-uri node
) *xsl
*)
102 (parse-instruction/xsl-element
103 (or (find-symbol (stp:local-name node
) :xuriella
)
104 (xslt-error "undefined instruction: ~A"
105 (stp:local-name node
)))
107 ((find (stp:namespace-uri node
)
108 *extension-namespaces
*
110 (parse-fallback-children node
))
112 (parse-instruction/literal-element node
))))
113 (parent (stp:parent node
)))
114 (if (and (equal (stp:base-uri node
) (stp:base-uri parent
))
115 (equal (stp:namespace-uri parent
) *xsl
*)
116 (find-symbol (stp:local-name parent
) :xuriella
))
118 `(xsl:with-base-uri
,(stp:base-uri node
)
121 `(xsl:text
,(stp:data node
)))))
123 (defun parse-instruction/literal-element
(node)
124 `(xsl:literal-element
125 (,(stp:local-name node
)
126 ,(stp:namespace-uri node
)
127 ,(stp:namespace-prefix node
))
128 (xsl:use-attribute-sets
129 ,(stp:attribute-value node
"use-attribute-sets" *xsl
*))
130 ,@(loop for a in
(stp:list-attributes node
)
131 unless
(equal (stp:namespace-uri a
) *xsl
*)
132 collect
`(xsl:literal-attribute
134 ,(stp:namespace-uri a
)
135 ,(stp:namespace-prefix a
))
137 ,@(parse-body node
)))
139 (defun parse-fallback-children (node)
142 for fallback in
(stp:filter-children
(of-name "fallback") node
)
143 append
(parse-body fallback
))))
145 (defparameter *available-instructions
* (make-hash-table :test
'equal
))
147 (defmacro define-instruction-parser
(name (node-var) &body body
)
149 (setf (gethash ,(symbol-name name
) *available-instructions
*) t
)
150 (defmethod parse-instruction/xsl-element
151 ((.name.
(eql ',name
)) ,node-var
)
152 (declare (ignore .name.
))
155 (define-instruction-parser |fallback|
(node)
158 (define-instruction-parser |apply-templates|
(node)
159 (stp:with-attributes
(select mode
) node
160 (multiple-value-bind (decls rest
)
163 for cons on
(stp:list-children node
)
164 for
(child . nil
) = cons
165 while
(namep child
"sort")
166 collect
(parse-sort child
) into decls
167 finally
(return (values decls cons
)))
168 `(xsl:apply-templates
169 (:select
,select
:mode
,mode
)
171 ,@(mapcar (lambda (clause)
172 (unless (namep clause
"with-param")
173 (xslt-error "undefined instruction: ~A"
174 (stp:local-name clause
)))
175 (parse-param clause
))
178 (define-instruction-parser |apply-imports|
(node)
179 `(xsl:apply-imports
))
181 (define-instruction-parser |call-template|
(node)
182 (stp:with-attributes
(name) node
184 ,name
,@(stp:map-children
'list
186 (if (namep clause
"with-param")
188 (xslt-error "undefined instruction: ~A"
189 (stp:local-name clause
))))
192 (define-instruction-parser |if|
(node)
193 (stp:with-attributes
(test) node
195 ,@(parse-body node
))))
197 (define-instruction-parser |choose|
(node)
199 ,@(stp:map-children
'list
202 ((namep clause
"when")
203 (stp:with-attributes
(test) clause
205 ,@(parse-body clause
))))
206 ((namep clause
"otherwise")
207 `(t ,@(parse-body clause
)))
209 (xslt-error "invalid <choose> clause: ~A"
210 (stp:local-name clause
)))))
213 (define-instruction-parser |element|
(node)
214 (stp:with-attributes
(name namespace use-attribute-sets
) node
215 `(xsl:element
(,name
:namespace
,namespace
)
216 (xsl:use-attribute-sets
,use-attribute-sets
)
217 ,@(parse-body node
))))
219 (define-instruction-parser |attribute|
(node)
220 (stp:with-attributes
(name namespace
) node
221 `(xsl:attribute
(,name
:namespace
,namespace
)
222 ,@(parse-body node
))))
224 (define-instruction-parser |text|
(node)
225 `(xsl:text
,(stp:string-value node
)))
227 (define-instruction-parser |comment|
(node)
228 `(xsl:comment
,@(parse-body node
)))
230 (define-instruction-parser |processing-instruction|
(node)
231 (stp:with-attributes
(name) node
232 `(xsl:processing-instruction
,name
233 ,@(parse-body node
))))
235 (define-instruction-parser |value-of|
(node)
236 (stp:with-attributes
(select disable-output-escaping
) node
237 (if disable-output-escaping
238 `(xsl:unescaped-value-of
,select
)
239 `(xsl:value-of
,select
))))
241 (define-instruction-parser |copy-of|
(node)
242 (stp:with-attributes
(select) node
243 `(xsl:copy-of
,select
)))
245 (define-instruction-parser |copy|
(node)
246 (stp:with-attributes
(use-attribute-sets) node
248 (xsl:use-attribute-sets
,use-attribute-sets
)
249 ,@(parse-body node
))))
251 (define-instruction-parser |variable|
(node)
252 (xslt-error "unhandled xsl:variable"))
254 (define-instruction-parser |for-each|
(node)
255 (stp:with-attributes
(select) node
256 (multiple-value-bind (decls body-position
)
259 for child in
(stp:list-children node
)
260 while
(namep child
"sort")
261 collect
(parse-sort child
) into decls
262 finally
(return (values decls i
)))
263 `(xsl:for-each
,select
265 ,@(parse-body node body-position
)))))
267 (defun parse-sort (node)
268 (stp:with-attributes
(select lang data-type order case-order
) node
269 `(sort :select
,select
271 :data-type
,data-type
273 :case-order
,case-order
)))
275 (define-instruction-parser |message|
(node)
276 `(xsl:message
,@(parse-body node
)))
278 (define-instruction-parser |terminate|
(node)
279 `(xsl:terminate
,@(parse-body node
)))
281 (define-instruction-parser |number|
(node)
282 (stp:with-attributes
(level count from value format lang letter-value
283 grouping-separator grouping-size
)
285 `(xsl:number
:level
,level
291 :letter-value
,letter-value
292 :grouping-separator
,grouping-separator
293 :grouping-size
,grouping-size
)))
295 (define-instruction-parser |document|
(node)
296 (stp:with-attributes
(href method indent doctype-public doctype-system
) node
297 `(xsl:document
(,href
:method
,method
299 :doctype-public
,doctype-public
300 :doctype-system
,doctype-system
)
301 ,@(parse-body node
))))