xsl:number: Don't print zero
[xuriella.git] / instructions.lisp
blob61a1a6bc9995526fddf7222a245083a34fa5a170
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
8 ;;; are met:
9 ;;;
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
12 ;;;
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.
17 ;;;
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 #+sbcl
33 (declaim (optimize (debug 2)))
36 ;;;; Instructions
38 (defparameter *available-instructions* (make-hash-table :test 'equal))
40 (defmacro define-instruction (name (args-var env-var) &body body)
41 `(setf (get ',name 'xslt-instruction)
42 (lambda (,args-var ,env-var)
43 (declare (ignorable ,env-var))
44 ,@body)))
46 (define-instruction if (args env)
47 (destructuring-bind (test then &optional else) args
48 (let ((test-thunk (compile-xpath test env))
49 (then-thunk (compile-instruction then env))
50 (else-thunk (when else (compile-instruction else env))))
51 (lambda (ctx)
52 (cond
53 ((xpath:boolean-value (funcall test-thunk ctx))
54 (funcall then-thunk ctx))
55 (else-thunk
56 (funcall else-thunk ctx)))))))
58 (define-instruction when (args env)
59 (destructuring-bind (test &rest body) args
60 (compile-instruction `(if ,test (progn ,@body)) env)))
62 (define-instruction unless (args env)
63 (destructuring-bind (test &rest body) args
64 (compile-instruction `(if (:not ,test) (progn ,@body)) env)))
66 (define-instruction cond (args env)
67 (if args
68 (destructuring-bind ((test &body body) &rest clauses) args
69 (compile-instruction (if (eq test t)
70 `(progn ,@body)
71 `(if ,test
72 (progn ,@body)
73 (cond ,@clauses)))
74 env))
75 (constantly nil)))
77 (define-instruction progn (args env)
78 (if args
79 (let ((first-thunk (compile-instruction (first args) env))
80 (rest-thunk (compile-instruction `(progn ,@(rest args)) env)))
81 (lambda (ctx)
82 (funcall first-thunk ctx)
83 (funcall rest-thunk ctx)))
84 (constantly nil)))
86 (defun decode-qname/runtime (qname namespaces attributep)
87 (handler-case
88 (multiple-value-bind (prefix local-name)
89 (split-qname qname)
90 (values local-name
91 (if (or prefix (not attributep))
92 (cdr (assoc prefix namespaces :test 'equal))
93 "")
94 prefix))
95 (cxml:well-formedness-violation ()
96 (xslt-error "not a qname: ~A" qname))))
98 (define-instruction xsl:element (args env)
99 (destructuring-bind ((name &key namespace use-attribute-sets)
100 &body body)
101 args
102 (declare (ignore use-attribute-sets)) ;fixme
103 (multiple-value-bind (name-thunk constant-name-p)
104 (compile-avt name env)
105 (multiple-value-bind (ns-thunk constant-ns-p)
106 (if namespace
107 (compile-avt namespace env)
108 (values nil t))
109 (let ((body-thunk (compile-instruction `(progn ,@body) env)))
110 (if (and constant-name-p constant-ns-p)
111 (compile-element/constant-name name namespace env body-thunk)
112 (compile-element/runtime name-thunk ns-thunk body-thunk)))))))
114 (defun compile-element/constant-name (qname namespace env body-thunk)
115 ;; the simple case: compile-time decoding of the QName
116 (multiple-value-bind (local-name uri prefix)
117 (decode-qname qname env nil)
118 (when namespace
119 (setf uri namespace))
120 (lambda (ctx)
121 (cond
122 (uri
123 (with-element (local-name uri :suggested-prefix prefix)
124 (funcall body-thunk ctx)))
126 ;; ERROR rather than CERROR because saxon doesn't do the recovery,
127 ;; and the official output illustrates recovery but is useless as
128 ;; always.
129 (xslt-error "namespace not found: ~A" prefix)
130 #+(or)
131 (let ((*start-tag-written-p* t))
132 (declare (special *start-tag-written-p*))
133 (funcall body-thunk ctx)))))))
135 (defun compile-element/runtime (name-thunk ns-thunk body-thunk)
136 ;; run-time decoding of the QName, but using the same namespaces
137 ;; that would have been known at compilation time.
138 (let ((namespaces *namespaces*))
139 (lambda (ctx)
140 (let ((qname (funcall name-thunk ctx)))
141 (multiple-value-bind (local-name uri prefix)
142 (decode-qname/runtime qname namespaces nil)
143 (when ns-thunk
144 (setf uri (funcall ns-thunk ctx)))
145 (unless uri
146 (setf uri ""))
147 (with-element (local-name uri :suggested-prefix prefix)
148 (funcall body-thunk ctx)))))))
150 (define-instruction xsl:use-attribute-sets (args env)
151 (destructuring-bind (str) args
152 (let ((sets (mapcar (lambda (qname)
153 (multiple-value-list (decode-qname qname env nil)))
154 (words str))))
155 (lambda (ctx)
156 (loop for (local-name uri nil) in sets do
157 (dolist (thunk (find-attribute-set local-name uri))
158 (funcall thunk ctx)))))))
160 (define-instruction xsl:attribute (args env)
161 (destructuring-bind ((name &key namespace) &body body) args
162 (when (null name)
163 (xslt-error "xsl:attribute: name not specified"))
164 (multiple-value-bind (name-thunk constant-name-p)
165 (compile-avt name env)
166 (multiple-value-bind (ns-thunk constant-ns-p)
167 (if namespace
168 (compile-avt namespace env)
169 (values nil t))
170 (let ((value-thunk (compile-instruction `(progn ,@body) env)))
171 (if (and constant-name-p constant-ns-p)
172 (compile-attribute/constant-name name namespace env value-thunk)
173 (compile-attribute/runtime name-thunk ns-thunk value-thunk)))))))
175 (defun compile-attribute/constant-name (qname namespace env value-thunk)
176 ;; the simple case: compile-time decoding of the QName
177 (multiple-value-bind (local-name uri prefix)
178 (decode-qname qname env t)
179 (when namespace
180 (setf uri namespace))
181 (lambda (ctx)
182 (write-attribute local-name
183 (or uri "")
184 (with-toplevel-text-output-sink (s)
185 (with-xml-output s
186 (funcall value-thunk ctx)))
187 :suggested-prefix prefix))))
189 (defun compile-attribute/runtime (name-thunk ns-thunk value-thunk)
190 ;; run-time decoding of the QName, but using the same namespaces
191 ;; that would have been known at compilation time.
192 (let ((namespaces *namespaces*))
193 (lambda (ctx)
194 (let ((qname (funcall name-thunk ctx)))
195 (multiple-value-bind (local-name uri prefix)
196 (decode-qname/runtime qname namespaces t)
197 (when ns-thunk
198 (setf uri (funcall ns-thunk ctx)))
199 (write-attribute local-name
200 (or uri "")
201 (with-toplevel-text-output-sink (s)
202 (with-xml-output s
203 (funcall value-thunk ctx)))
204 :suggested-prefix prefix))))))
206 ;; zzz Also elides (later) namespaces hidden by (earlier) ones.
207 ;; zzz Reverses order.
208 (defun remove-excluded-namespaces
209 (namespaces &optional (excluded-uris *excluded-namespaces*))
210 (let ((koerbchen '())
211 (kroepfchen '()))
212 (loop
213 for cons in namespaces
214 for (prefix* . uri) = cons
215 for prefix = (or prefix* "")
217 (cond
218 ((find prefix kroepfchen :test #'equal))
219 ((find prefix koerbchen :test #'equal :key #'car))
220 ((find uri excluded-uris :test #'equal)
221 (push prefix kroepfchen))
223 (push cons koerbchen))))
224 koerbchen))
226 (define-instruction xsl:literal-element (args env)
227 (destructuring-bind
228 ((local-name &optional (uri "") suggested-prefix) &body body)
229 args
230 (let ((body-thunk (compile-instruction `(progn ,@body) env))
231 (namespaces (remove-excluded-namespaces *namespaces*)))
232 (lambda (ctx)
233 (with-element (local-name (or uri "")
234 :suggested-prefix suggested-prefix
235 :extra-namespaces namespaces
236 :process-aliases t)
237 (funcall body-thunk ctx))))))
239 (define-instruction xsl:literal-attribute (args env)
240 (destructuring-bind ((local-name &optional uri suggested-prefix) value) args
241 (let ((value-thunk (compile-avt value env)))
242 (lambda (ctx)
243 (write-attribute local-name
245 (funcall value-thunk ctx)
246 :process-aliases t
247 :suggested-prefix suggested-prefix)))))
249 (define-instruction xsl:text (args env)
250 (destructuring-bind (str) args
251 (lambda (ctx)
252 (declare (ignore ctx))
253 (write-text str))))
255 (define-instruction xsl:unescaped-text (args env)
256 (destructuring-bind (str) args
257 (lambda (ctx)
258 (declare (ignore ctx))
259 (write-unescaped str))))
261 (define-instruction xsl:processing-instruction (args env)
262 (destructuring-bind (name &rest body) args
263 (let ((name-thunk (compile-avt name env))
264 (value-thunk (compile-instruction `(progn ,@body) env)))
265 (lambda (ctx)
266 (write-processing-instruction
267 (funcall name-thunk ctx)
268 (with-toplevel-text-output-sink (s)
269 (with-xml-output s
270 (funcall value-thunk ctx))))))))
272 (define-instruction xsl:comment (args env)
273 (let ((value-thunk (compile-instruction `(progn ,@args) env)))
274 (lambda (ctx)
275 (write-comment (with-toplevel-text-output-sink (s)
276 (with-xml-output s
277 (funcall value-thunk ctx)))))))
279 (define-instruction xsl:value-of (args env)
280 (destructuring-bind (xpath) args
281 (let ((thunk (compile-xpath xpath env)))
282 (xslt-trace-thunk
283 (lambda (ctx)
284 (write-text (xpath:string-value (funcall thunk ctx))))
285 "value-of ~s = ~s" xpath :result))))
287 (define-instruction xsl:unescaped-value-of (args env)
288 (destructuring-bind (xpath) args
289 (let ((thunk (compile-xpath xpath env)))
290 (lambda (ctx)
291 (write-unescaped (xpath:string-value (funcall thunk ctx)))))))
293 (define-instruction xsl:copy-of (args env)
294 (destructuring-bind (xpath) args
295 (let ((thunk (compile-xpath xpath env))
296 ;; FIXME: what was this for? --david
297 #+(or) (v (intern-variable "varName" "")))
298 (xslt-trace-thunk
299 (lambda (ctx)
300 (let ((result (funcall thunk ctx)))
301 (typecase result
302 (xpath:node-set ;; FIXME: variables can contain node sets w/fragments inside. Maybe just fragments would do?
303 (xpath:map-node-set #'copy-into-result (xpath:sort-node-set result)))
304 (result-tree-fragment
305 (copy-into-result result))
307 (write-text (xpath:string-value result))))))
308 "copy-of ~s" xpath))))
310 (defun copy-into-result (node)
311 (cond
312 ((result-tree-fragment-p node)
313 (stp:do-children (child (result-tree-fragment-node node))
314 (copy-into-result child)))
315 ((xpath-protocol:node-type-p node :element)
316 (with-element ((xpath-protocol:local-name node)
317 (xpath-protocol:namespace-uri node)
318 :suggested-prefix (xpath-protocol:namespace-prefix node)
319 :extra-namespaces (namespaces-as-alist node))
320 (map-pipe-eagerly #'copy-into-result
321 (xpath-protocol:attribute-pipe node))
322 (map-pipe-eagerly #'copy-into-result
323 (xpath-protocol:child-pipe node))))
324 ((xpath-protocol:node-type-p node :document)
325 (map-pipe-eagerly #'copy-into-result
326 (xpath-protocol:child-pipe node)))
328 (copy-leaf-node node))))
330 (defparameter *lower-first-order*
331 #(#\ #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\0 #\1 #\2
332 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\: #\; #\< #\= #\> #\? #\@ #\H #\J #\L #\N #\P
333 #\R #\T #\V #\X #\Z #\\ #\^ #\` #\b #\d #\f #\h #\j #\l #\n #\p #\r #\t #\v
334 #\x #\z #\A #\B #\C #\D #\E #\F #\G #\I #\K #\M #\O #\Q #\S #\U #\W #\Y #\[
335 #\] #\_ #\a #\c #\e #\g #\i #\k #\m #\o #\q #\s #\u #\w #\y #\{ #\| #\} #\~
336 #\Rubout))
338 (defparameter *upper-first-order*
339 #(#\ #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\0 #\1 #\2
340 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\: #\; #\< #\= #\> #\? #\@ #\G #\I #\K #\M #\O
341 #\Q #\S #\U #\W #\Y #\[ #\] #\_ #\a #\c #\e #\g #\i #\k #\m #\o #\q #\s #\u
342 #\w #\y #\A #\B #\C #\D #\E #\F #\H #\J #\L #\N #\P #\R #\T #\V #\X #\Z #\\
343 #\^ #\` #\b #\d #\f #\h #\j #\l #\n #\p #\r #\t #\v #\x #\z #\{ #\| #\} #\~
344 #\Rubout))
346 (defun collation-char (char table)
347 (let ((code (char-code char)))
348 (if (<= 32 code 127)
349 (elt table (- code 32))
350 char)))
352 (defun make-collation-key (str table)
353 (map 'string (lambda (char) (collation-char char table)) str))
355 (defun compare-numbers (n-a n-b)
356 (cond ((and (xpath::nan-p n-a)
357 (not (xpath::nan-p n-b)))
359 ((and (not (xpath::nan-p n-a))
360 (xpath::nan-p n-b))
362 ((xpath::compare-numbers '< n-a n-b) -1)
363 ((xpath::compare-numbers '> n-a n-b) 1)
364 (t 0)))
366 (defun mismatch* (a b)
367 (let ((pos (mismatch a b)))
368 (if (and pos (< pos (min (length a) (length b))))
370 nil)))
372 (defun compare-strings (i j char-table)
373 ;; zzz Unicode support!
374 (let ((pos
375 (or (mismatch* (string-downcase i) (string-downcase j))
376 (mismatch* i j))))
377 (if pos
378 (let ((c (collation-char (elt i pos) char-table))
379 (d (collation-char (elt j pos) char-table)))
380 (cond
381 ((char< c d) -1)
382 ((char= c d) 0)
383 (t 1)))
384 (signum (- (length i) (length j))))))
386 (defun make-sorter/lazy (spec env)
387 (destructuring-bind (&key select lang data-type order case-order)
388 (cdr spec)
389 (let ((select-thunk (compile-xpath (or select ".") env))
390 (lang-thunk (compile-avt (or lang "") env))
391 (data-type-thunk (compile-avt (or data-type "") env))
392 (order-thunk (compile-avt (or order "") env))
393 (case-order-thunk (compile-avt (or case-order "") env)))
394 (lambda (ctx)
395 (let ((numberp
396 (equal (funcall data-type-thunk ctx) "number"))
397 (char-table
398 (if (equal (funcall case-order-thunk ctx) "lower-first")
399 *lower-first-order*
400 *upper-first-order*))
402 (if (equal (funcall order-thunk ctx) "descending") -1 1))
403 (lang
404 (funcall lang-thunk ctx)))
405 (declare (ignore lang))
406 (lambda (a b)
407 (let ((i (xpath:string-value (funcall select-thunk a)))
408 (j (xpath:string-value (funcall select-thunk b))))
409 (* f
410 (if numberp
411 (compare-numbers (xpath:number-value i)
412 (xpath:number-value j))
413 (compare-strings i j char-table))))))))))
415 (defun compose-sorters/lazy (sorters)
416 (if sorters
417 (let ((this-thunk (car sorters))
418 (next-thunk (compose-sorters/lazy (rest sorters))))
419 (lambda (ctx)
420 (let ((this (funcall this-thunk ctx))
421 (next (funcall next-thunk ctx)))
422 (lambda (a b)
423 (let ((d (funcall this a b)))
424 (if (zerop d)
425 (funcall next a b)
426 d))))))
427 (lambda (ctx)
428 (declare (ignore ctx))
429 (constantly 0))))
431 (defun make-sort-predicate/lazy (decls env)
432 (let ((sorter-thunk
433 (compose-sorters/lazy
434 (mapcar (lambda (x) (make-sorter/lazy x env)) decls))))
435 (lambda (ctx)
436 (let ((sorter (funcall sorter-thunk ctx)))
437 (lambda (a b)
438 (minusp (funcall sorter a b)))))))
440 (defun contextify-node-list (nodes)
441 (let ((size (length nodes)))
442 (loop
443 for position from 1
444 for node in nodes
445 collect
446 (xpath:make-context node size position))))
448 (define-instruction xsl:for-each (args env)
449 (destructuring-bind (select &optional decls &rest body) args
450 (unless (and (consp decls)
451 (eq (car decls) 'declare))
452 (push decls body)
453 (setf decls nil))
454 (let ((select-thunk (compile-xpath select env))
455 (body-thunk (compile-instruction `(progn ,@body) env))
456 (sort-predicate-thunk
457 (when (cdr decls)
458 (make-sort-predicate/lazy (cdr decls) env))))
459 (lambda (ctx)
460 (let ((selected (funcall select-thunk ctx)))
461 (unless (xpath:node-set-p selected)
462 (xslt-error "for-each select expression should yield a node-set"))
463 (let ((nodes (xpath::force (xpath::sorted-pipe-of selected))))
464 (when sort-predicate-thunk
465 (setf nodes
466 (mapcar #'xpath:context-node
467 (stable-sort (contextify-node-list nodes)
468 (funcall sort-predicate-thunk ctx)))))
469 (dolist (ctx (contextify-node-list nodes))
470 (funcall body-thunk ctx))))))))
472 (define-instruction xsl:with-namespaces (args env)
473 (destructuring-bind ((&rest forms) &rest body) args
474 (let ((*namespaces* *namespaces*))
475 (dolist (form forms)
476 (destructuring-bind (prefix uri) form
477 (push (cons prefix uri) *namespaces*)))
478 (compile-instruction `(progn ,@body) env))))
480 (define-instruction xsl:with-excluded-namespaces (args env)
481 (destructuring-bind ((&rest uris) &rest body) args
482 (let ((*excluded-namespaces* (append uris *excluded-namespaces*)))
483 (compile-instruction `(progn ,@body) env))))
485 (define-instruction xsl:with-extension-namespaces (args env)
486 (destructuring-bind ((&rest uris) &rest body) args
487 (let ((*extension-namespaces* (append uris *extension-namespaces*)))
488 (compile-instruction `(progn ,@body) env))))
490 (define-instruction xsl:with-version (args env)
491 (destructuring-bind (version &rest body) args
492 (let ((*forwards-compatible-p* (not (equal version "1.0"))))
493 (compile-instruction `(progn ,@body) env))))
495 ;; XSLT disallows multiple definitions of the same variable within a
496 ;; template. Local variables can shadow global variables though.
497 ;; Since our LET syntax makes it natural to shadow local variables the
498 ;; Lisp way, we check for duplicate variables only where instructed to
499 ;; by the XML syntax parser using WITH-DUPLICATES-CHECK:
500 (defvar *template-variables* nil)
502 (define-instruction xsl:with-duplicates-check (args env)
503 (let ((*template-variables* *template-variables*))
504 (destructuring-bind ((&rest qnames) &rest body) args
505 (dolist (qname qnames)
506 (multiple-value-bind (local-name uri)
507 (decode-qname qname env nil)
508 (let ((key (cons local-name uri)))
509 (when (find key *template-variables* :test #'equal)
510 (xslt-error "duplicate variable: ~A, ~A" local-name uri))
511 (push key *template-variables*))))
512 (compile-instruction `(progn ,@body) env))))
514 (define-instruction xsl:with-base-uri (args env)
515 (destructuring-bind (uri &rest body) args
516 (let ((*instruction-base-uri* uri))
517 (compile-instruction `(progn ,@body) env))))
519 (defstruct (result-tree-fragment
520 (:constructor make-result-tree-fragment (node)))
521 node)
523 (define-default-method xpath-protocol:node-p
524 ((node result-tree-fragment))
527 (define-default-method xpath-protocol:node-text
528 ((node result-tree-fragment))
529 (xpath-protocol:node-text (result-tree-fragment-node node)))
531 (defun apply-to-result-tree-fragment (ctx thunk)
532 (let ((document
533 (with-xml-output (make-stpx-builder)
534 (with-element ("fragment" "")
535 (funcall thunk ctx)))))
536 (make-result-tree-fragment (stp:document-element document))))
538 (defun compile-var-bindings/nointern (forms env)
539 (loop
540 for (name value) in forms
541 collect (multiple-value-bind (local-name uri)
542 (decode-qname name env nil)
543 (list (cons local-name uri)
544 (xslt-trace-thunk
545 (compile-value-thunk value env)
546 "local variable ~s = ~s" name :result)))))
548 (define-instruction let (args env)
549 (destructuring-bind ((&rest forms) &rest body) args
550 (let* ((old-top (length *lexical-variable-declarations*))
551 (vars-and-names (compile-var-bindings/nointern forms env))
552 (vars-and-positions
553 (loop for ((local-name . uri) thunk) in vars-and-names
554 collect
555 (list (push-variable local-name
557 *lexical-variable-declarations*)
558 thunk))))
559 (let ((thunk (compile-instruction `(progn ,@body) env)))
560 (fill *lexical-variable-declarations* nil :start old-top)
561 (lambda (ctx)
562 (loop for (index var-thunk) in vars-and-positions
563 do (setf (lexical-variable-value index)
564 (funcall var-thunk ctx)))
565 (funcall thunk ctx))))))
567 (define-instruction let* (args env)
568 (destructuring-bind ((&rest forms) &rest body) args
569 (if forms
570 (compile-instruction `(let (,(car forms))
571 (let* (,@(cdr forms))
572 ,@body))
573 env)
574 (compile-instruction `(progn ,@body) env))))
576 (define-instruction xsl:message (args env)
577 (compile-message #'warn args env))
579 (define-instruction xsl:terminate (args env)
580 (compile-message #'xslt-error args env))
582 (defun namespaces-as-alist (element)
583 (let ((namespaces '()))
584 (do-pipe (ns (xpath-protocol:namespace-pipe element))
585 (push (cons (xpath-protocol:local-name ns)
586 (xpath-protocol:node-text ns))
587 namespaces))
588 namespaces))
590 (define-instruction xsl:copy (args env)
591 (let ((body (compile-instruction `(progn ,@args) env)))
592 (lambda (ctx)
593 (let ((node (xpath:context-node ctx)))
594 (cond
595 ((xpath-protocol:node-type-p node :element)
596 (with-element
597 ((xpath-protocol:local-name node)
598 (xpath-protocol:namespace-uri node)
599 :suggested-prefix (xpath-protocol:namespace-prefix node)
600 :extra-namespaces (namespaces-as-alist node))
601 (funcall body ctx)))
602 ((xpath-protocol:node-type-p node :document)
603 (funcall body ctx))
605 (copy-leaf-node node)))))))
607 (defun copy-leaf-node (node)
608 (cond
609 ((xpath-protocol:node-type-p node :text)
610 (etypecase (if (typep node 'stripping-node)
611 (stripping-node-target node)
612 node)
613 (unescaped-text (write-unescaped (xpath-protocol:node-text node)))
614 (stp:text (write-text (xpath-protocol:node-text node)))))
615 ((xpath-protocol:node-type-p node :comment)
616 (write-comment (xpath-protocol:node-text node)))
617 ((xpath-protocol:node-type-p node :processing-instruction)
618 (write-processing-instruction
619 (xpath-protocol:processing-instruction-target node)
620 (xpath-protocol:node-text node)))
621 ((xpath-protocol:node-type-p node :attribute)
622 (write-attribute
623 (xpath-protocol:local-name node)
624 (xpath-protocol:namespace-uri node)
625 (xpath-protocol:node-text node)
626 :suggested-prefix (xpath-protocol:namespace-prefix node)))
627 ((xpath-protocol:node-type-p node :namespace)
628 (write-extra-namespace
629 (xpath-protocol:local-name node)
630 (xpath-protocol:node-text node)
631 nil))
633 (error "don't know how to copy node ~A" node))))
635 (defun compile-message (fn args env)
636 (let ((thunk (compile-instruction `(progn ,@args) env)))
637 (lambda (ctx)
638 (funcall fn
639 (with-xml-output (cxml:make-string-sink)
640 (funcall thunk ctx))))))
642 (define-instruction xsl:apply-templates (args env)
643 (destructuring-bind ((&key select mode) &rest param-binding-specs) args
644 (let* ((decls
645 (when (and (consp (car param-binding-specs))
646 (eq (caar param-binding-specs) 'declare))
647 (cdr (pop param-binding-specs))))
648 (select-thunk
649 (compile-xpath (or select "child::node()") env))
650 (param-bindings
651 (compile-var-bindings param-binding-specs env))
652 (sort-predicate-thunk
653 (when decls
654 (make-sort-predicate/lazy decls env))))
655 (multiple-value-bind (mode-local-name mode-uri)
656 (and mode (decode-qname mode env nil))
657 (lambda (ctx)
658 (apply-templates/list
659 (xpath::force
660 (xpath::sorted-pipe-of (funcall select-thunk ctx)))
661 :param-bindings
662 (loop for (name nil value-thunk) in param-bindings
663 collect (list name (funcall value-thunk ctx)))
664 :sort-predicate (when sort-predicate-thunk
665 (funcall sort-predicate-thunk ctx))
666 :mode (when mode
667 (or (find-mode *stylesheet*
668 mode-local-name
669 mode-uri)
670 *empty-mode*))))))))
672 (define-instruction xsl:apply-imports (args env)
673 (declare (ignore args env))
674 (lambda (ctx)
675 (declare (ignore ctx))
676 (funcall *apply-imports*)))
678 (define-instruction xsl:call-template (args env)
679 (destructuring-bind (name &rest param-binding-specs) args
680 (let ((param-bindings
681 (compile-var-bindings param-binding-specs env)))
682 (multiple-value-bind (local-name uri)
683 (decode-qname name env nil)
684 (setf name (cons local-name uri)))
685 (lambda (ctx)
686 (call-template ctx name
687 (loop for (name nil value-thunk) in param-bindings
688 collect (list name (funcall value-thunk ctx))))))))
690 ;; fixme: incompatible with XSLT 2.0
691 (define-instruction xsl:document (args env)
692 (destructuring-bind ((href &key method indent doctype-public doctype-system)
693 &body body)
694 args
695 (declare (ignore doctype-public doctype-system)) ;fixme
696 (let ((thunk (compile-instruction `(progn ,@body) env))
697 (href-thunk (compile-avt href env)))
698 (lambda (ctx)
699 (let ((pathname
700 (uri-to-pathname
701 (puri:merge-uris (funcall href-thunk ctx)
702 (xpath-protocol:base-uri
703 (xpath:context-node ctx))))))
704 (ensure-directories-exist pathname) ;really?
705 (invoke-with-output-sink
706 (lambda ()
707 (funcall thunk ctx))
708 (make-output-specification :method (or method "XML") :indent indent)
709 pathname))))))
711 (defun compile-instruction (form env)
712 (xslt-trace-thunk
713 (funcall (or (get (car form) 'xslt-instruction)
714 (error "undefined instruction: ~A" (car form)))
715 (cdr form)
716 env)
717 "instruction ~s" (car form)))
719 ;;: WTF: "A right curly brace inside a Literal in an expression is not
720 ;;; recognized as terminating the expression."
722 ;;; Da hilft nur tagbody.
723 (defun parse-attribute-value-template (template-string)
724 (with-input-from-string (input template-string)
725 (let ((ordinary (make-string-output-stream))
726 (xpath (make-string-output-stream))
727 (tokens '())
728 (c (read-char input nil :eof)))
729 (flet ((emit ()
730 (let ((o (get-output-stream-string ordinary)))
731 (when (plusp (length o))
732 (push (list :data o) tokens)))
733 (let ((x (get-output-stream-string xpath)))
734 (when (plusp (length x))
735 (push (list :xpath x) tokens))))
736 (collect-ordinary ()
737 (write-char c ordinary))
738 (collect-xpath ()
739 (write-char c xpath)))
740 (macrolet ((goto (target)
741 `(progn
742 (setf c (read-char input nil :eof))
743 (go ,target))))
744 (tagbody
745 ordinary
746 (case c
747 (#\{
748 (goto seen{))
749 (#\}
750 (goto seen-stray-}))
751 (:eof
752 (go done)))
753 (collect-ordinary)
754 (goto ordinary)
756 seen{
757 (case c
758 (#\{
759 (collect-ordinary)
760 (goto ordinary))
761 (#\'
762 (collect-xpath)
763 (goto in-single-quote))
764 (:eof
765 (xslt-error "unexpected end of avt")))
766 (emit)
767 (collect-xpath)
768 (goto xpath)
770 xpath
771 (case c
772 (#\'
773 (collect-xpath)
774 (goto in-single-quote))
775 (#\"
776 (collect-xpath)
777 (goto in-double-quote))
778 (#\}
779 (goto seen-closing-}))
780 (:eof
781 (xslt-error "unexpected end of avt")))
782 (collect-xpath)
783 (goto xpath)
785 in-single-quote
786 (case c
787 (#\'
788 (collect-xpath)
789 (goto xpath))
790 (:eof
791 (xslt-error "unexpected end of avt")))
792 (collect-xpath)
793 (goto in-single-quote)
795 in-double-quote
796 (case c
797 (#\"
798 (collect-xpath)
799 (goto xpath))
800 (:eof
801 (xslt-error "unexpected end of avt")))
802 (collect-xpath)
803 (goto in-double-quote)
805 seen-closing-}
806 (case c
807 (#\}
808 (emit)
809 (goto seen-stray-}))
810 (#\{
811 (emit)
812 (goto xpath))
813 (:eof
814 (goto done)))
815 (emit)
816 (collect-ordinary)
817 (goto ordinary)
819 seen-stray-}
820 (case c
821 (#\}
822 (collect-ordinary)
823 (goto ordinary)))
824 (xslt-error "unexpected closing brace in avt")
826 done
827 (emit))))
828 (nreverse tokens))))
830 (defun compile-avt (template-string env)
831 (let* ((constantp t)
832 (fns
833 (mapcar (lambda (x)
834 (ecase (car x)
835 (:data
836 (constantly (second x)))
837 (:xpath
838 (setf constantp nil)
839 (compile-xpath (second x) env))))
840 (if template-string
841 (parse-attribute-value-template template-string)
842 (xslt-error "missing avt")))))
843 (values (lambda (ctx)
844 (with-output-to-string (s)
845 (dolist (fn fns)
846 (write-string (xpath:string-value (funcall fn ctx)) s))))
847 constantp)))
850 ;;;; Indentation for slime
852 (defmacro define-indentation (name (&rest args))
853 (labels ((collect-variables (list)
854 (loop
855 for sub in list
856 append
857 (etypecase sub
858 (list
859 (collect-variables sub))
860 (symbol
861 (if (eql (mismatch "&" (symbol-name sub)) 1)
863 (list sub)))))))
864 `(defmacro ,name (,@args)
865 (declare (ignorable ,@(collect-variables args)))
866 (error "XSL indentation helper ~A used literally in lisp code"
867 ',name))))
869 (define-indentation xsl:element
870 ((name &key namespace use-attribute-sets) &body body))
871 (define-indentation xsl:literal-element ((name &optional uri) &body body))
872 (define-indentation xsl:attribute ((name &key namespace) &body body))
873 (define-indentation xsl:literal-attribute ((name &optional uri) &body body))
874 (define-indentation xsl:text (str))
875 (define-indentation xsl:processing-instruction (name &body body))
876 (define-indentation xsl:comment (&body body))
877 (define-indentation xsl:value-of (xpath))
878 (define-indentation xsl:unescaped-value-of (xpath))
879 (define-indentation xsl:for-each (select &body decls-and-body))
880 (define-indentation xsl:message (&body body))
881 (define-indentation xsl:terminate (&body body))
882 (define-indentation xsl:apply-templates ((&key select mode) &body decls-and-body))
883 (define-indentation xsl:call-template (name &rest parameters))
884 (define-indentation xsl:copy-of (xpath))
886 ;;;;
888 (defun test-instruction (form document)
889 (let ((thunk (compile-instruction form (make-instance 'lexical-environment)))
890 (root (cxml:parse document (stp:make-builder))))
891 (with-xml-output (cxml:make-string-sink)
892 (funcall thunk (xpath:make-context root)))))