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