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) (param-names '()))
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
)))))
74 (xsl:with-duplicates-check
(,name
)
75 ,@(recurse (1+ i
))))))
76 (cons (parse-instruction child
)
77 (recurse (1+ i
)))))))))
78 (let ((result (recurse start
)))
80 `((xsl:with-duplicates-check
(,@param-names
)
84 (defun parse-param (node)
86 (stp:with-attributes
(name select
) node
88 (xslt-error "name not specified for parameter"))
89 (when (and select
(stp:list-children node
))
90 (xslt-error "param with select and body"))
93 `(progn ,@(parse-body node
))))))
95 (defun parse-instruction (node)
98 (if (equal (stp:namespace-uri node
) *xsl
*)
99 (parse-instruction/xsl-element
100 (or (find-symbol (stp:local-name node
) :xuriella
)
101 (xslt-error "undefined instruction: ~A" (stp:local-name node
)))
103 (parse-instruction/literal-element node
)))
105 `(xsl:text
,(stp:data node
)))))
107 (defun parse-instruction/literal-element
(node)
108 `(xsl:literal-element
109 (,(stp:local-name node
)
110 ,(stp:namespace-uri node
)
111 ,(stp:namespace-prefix node
))
112 ,@(stp:map-attributes
'list
114 `(xsl:literal-attribute
116 ,(stp:namespace-uri a
)
117 ,(stp:namespace-prefix a
))
120 ,@(parse-body node
)))
122 (defmacro define-instruction-parser
(name (node-var) &body body
)
123 `(defmethod parse-instruction/xsl-element
124 ((.name.
(eql ',name
)) ,node-var
)
125 (declare (ignore .name.
))
128 (define-instruction-parser |apply-templates|
(node)
129 (stp:with-attributes
(select mode
) node
130 `(xsl:apply-templates
131 (:select
,select
:mode
,mode
)
132 ,@(remove nil
;; FIXME: this will be no longer needed when xsl:sort is implemented
133 (stp:map-children
'list
136 ((namep clause
"with-param")
137 (parse-param clause
))
138 ((namep clause
"sort")
142 (xslt-error "undefined instruction: ~A"
143 (stp:local-name clause
)))))
146 (define-instruction-parser |call-template|
(node)
147 (stp:with-attributes
(name) node
149 ,name
,@(stp:map-children
'list
151 (if (namep clause
"with-param")
153 (xslt-error "undefined instruction: ~A"
154 (stp:local-name clause
))))
157 (define-instruction-parser |if|
(node)
158 (stp:with-attributes
(test) node
160 ,@(parse-body node
))))
162 (define-instruction-parser |choose|
(node)
164 ,@(stp:map-children
'list
167 ((namep clause
"when")
168 (stp:with-attributes
(test) clause
170 ,@(parse-body clause
))))
171 ((namep clause
"otherwise")
172 `(t ,@(parse-body clause
)))
174 (xslt-error "invalid <choose> clause: ~A"
175 (stp:local-name clause
)))))
178 (define-instruction-parser |element|
(node)
179 (stp:with-attributes
(name namespace use-attribute-sets
) node
180 `(xsl:element
(,name
:namespace
,namespace
181 :use-attribute-sets
,use-attribute-sets
)
182 ,@(parse-body node
))))
184 (define-instruction-parser |attribute|
(node)
185 (stp:with-attributes
(name namespace
) node
186 `(xsl:attribute
(,name
:namespace
,namespace
)
187 ,@(parse-body node
))))
189 (define-instruction-parser |text|
(node)
190 `(xsl:text
,(stp:string-value node
)))
192 (define-instruction-parser |comment|
(node)
193 `(xsl:comment
,@(stp:string-value node
)))
195 (define-instruction-parser |processing-instruction|
(node)
196 (stp:with-attributes
(name) node
197 `(xsl:processing-instruction
,name
198 ,@(parse-body node
))))
200 (define-instruction-parser |value-of|
(node)
201 (stp:with-attributes
(select disable-output-escaping
) node
202 (if disable-output-escaping
203 `(xsl:unescaped-value-of
,select
)
204 `(xsl:value-of
,select
))))
206 (define-instruction-parser |copy-of|
(node)
207 (stp:with-attributes
(select) node
208 `(xsl:copy-of
,select
)))
210 (define-instruction-parser |copy|
(node)
211 (stp:with-attributes
(use-attribute-sets) node
212 `(xsl:copy
(:use-attribute-sets
,use-attribute-sets
)
213 ,@(parse-body node
))))
215 (define-instruction-parser |variable|
(node)
216 (xslt-error "unhandled xsl:variable"))
218 (define-instruction-parser |for-each|
(node)
219 (stp:with-attributes
(select) node
220 (multiple-value-bind (decls body-position
)
223 for child in
(stp:list-children node
)
224 while
(namep node
"sort")
225 collect
(parse-sort node
) into decls
226 finally
(return (values decls i
)))
227 `(xsl:for-each
,select
229 ,@(parse-body node body-position
)))))
231 (defun parse-sort (node)
232 (stp:with-attributes
(select lang data-type order case-order
) node
233 `(sort :select
,select
235 :data-type
,data-type
237 :case-order
,case-order
)))
239 (define-instruction-parser |message|
(node)
240 `(xsl:message
,@(parse-body node
)))
242 (define-instruction-parser |terminate|
(node)
243 `(xsl:terminate
,@(parse-body node
)))