Forwards compatible processing: Unknown instruction elements
[xuriella.git] / instructions.lisp
blob8d13b76901632381adc7af92cb1c221e44f6fddc
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 (define-instruction let (args env)
539 (destructuring-bind ((&rest forms) &rest body) args
540 (let* ((old-top (length *lexical-variable-declarations*))
541 (vars-and-names (compile-var-bindings/nointern forms env))
542 (vars-and-positions
543 (loop for ((local-name . uri) thunk) in vars-and-names
544 collect
545 (list (push-variable local-name
547 *lexical-variable-declarations*)
548 thunk))))
549 (let ((thunk (compile-instruction `(progn ,@body) env)))
550 (fill *lexical-variable-declarations* nil :start old-top)
551 (lambda (ctx)
552 (loop for (index var-thunk) in vars-and-positions
553 do (setf (lexical-variable-value index)
554 (funcall var-thunk ctx)))
555 (funcall thunk ctx))))))
557 (define-instruction let* (args env)
558 (destructuring-bind ((&rest forms) &rest body) args
559 (if forms
560 (compile-instruction `(let (,(car forms))
561 (let* (,@(cdr forms))
562 ,@body))
563 env)
564 (compile-instruction `(progn ,@body) env))))
566 (define-instruction xsl:message (args env)
567 (compile-message #'warn args env))
569 (define-instruction xsl:terminate (args env)
570 (compile-message #'xslt-error args env))
572 (defun namespaces-as-alist (element)
573 (let ((namespaces '()))
574 (do-pipe (ns (xpath-protocol:namespace-pipe element))
575 (push (cons (xpath-protocol:local-name ns)
576 (xpath-protocol:node-text ns))
577 namespaces))
578 namespaces))
580 (define-instruction xsl:copy (args env)
581 (let ((body (compile-instruction `(progn ,@args) env)))
582 (lambda (ctx)
583 (let ((node (xpath:context-node ctx)))
584 (cond
585 ((xpath-protocol:node-type-p node :element)
586 (with-element
587 ((xpath-protocol:local-name node)
588 (xpath-protocol:namespace-uri node)
589 :suggested-prefix (xpath-protocol:namespace-prefix node)
590 :extra-namespaces (namespaces-as-alist node))
591 (funcall body ctx)))
592 ((xpath-protocol:node-type-p node :document)
593 (funcall body ctx))
595 (copy-leaf-node node)))))))
597 (defun copy-leaf-node (node)
598 (cond
599 ((xpath-protocol:node-type-p node :text)
600 (etypecase (if (typep node 'stripping-node)
601 (stripping-node-target node)
602 node)
603 (unescaped-text (write-unescaped (xpath-protocol:node-text node)))
604 (stp:text (write-text (xpath-protocol:node-text node)))))
605 ((xpath-protocol:node-type-p node :comment)
606 (write-comment (xpath-protocol:node-text node)))
607 ((xpath-protocol:node-type-p node :processing-instruction)
608 (write-processing-instruction
609 (xpath-protocol:processing-instruction-target node)
610 (xpath-protocol:node-text node)))
611 ((xpath-protocol:node-type-p node :attribute)
612 (write-attribute
613 (xpath-protocol:local-name node)
614 (xpath-protocol:namespace-uri node)
615 (xpath-protocol:node-text node)
616 :suggested-prefix (xpath-protocol:namespace-prefix node)))
617 ((xpath-protocol:node-type-p node :namespace)
618 (write-extra-namespace
619 (xpath-protocol:local-name node)
620 (xpath-protocol:node-text node)
621 nil))
623 (error "don't know how to copy node ~A" node))))
625 (defun compile-message (fn args env)
626 (let ((thunk (compile-instruction `(progn ,@args) env)))
627 (lambda (ctx)
628 (funcall fn
629 (with-xml-output (cxml:make-string-sink)
630 (funcall thunk ctx))))))
632 (define-instruction xsl:apply-templates (args env)
633 (destructuring-bind ((&key select mode) &rest param-binding-specs) args
634 (let* ((decls
635 (when (and (consp (car param-binding-specs))
636 (eq (caar param-binding-specs) 'declare))
637 (cdr (pop param-binding-specs))))
638 (select-thunk
639 (compile-xpath (or select "child::node()") env))
640 (param-bindings
641 (compile-var-bindings param-binding-specs env))
642 (sort-predicate-thunk
643 (when decls
644 (make-sort-predicate/lazy decls env))))
645 (multiple-value-bind (mode-local-name mode-uri)
646 (and mode (decode-qname mode env nil))
647 (lambda (ctx)
648 (apply-templates/list
649 (xpath::force
650 (xpath::sorted-pipe-of (funcall select-thunk ctx)))
651 :param-bindings
652 (loop for (name nil value-thunk) in param-bindings
653 collect (list name (funcall value-thunk ctx)))
654 :sort-predicate (when sort-predicate-thunk
655 (funcall sort-predicate-thunk ctx))
656 :mode (when mode
657 (or (find-mode *stylesheet*
658 mode-local-name
659 mode-uri)
660 *empty-mode*))))))))
662 (define-instruction xsl:apply-imports (args env)
663 (declare (ignore args env))
664 (lambda (ctx)
665 (declare (ignore ctx))
666 (funcall *apply-imports*)))
668 (define-instruction xsl:call-template (args env)
669 (destructuring-bind (name &rest param-binding-specs) args
670 (let ((param-bindings
671 (compile-var-bindings param-binding-specs env)))
672 (multiple-value-bind (local-name uri)
673 (decode-qname name env nil)
674 (setf name (cons local-name uri)))
675 (lambda (ctx)
676 (call-template ctx name
677 (loop for (name nil value-thunk) in param-bindings
678 collect (list name (funcall value-thunk ctx))))))))
680 ;; fixme: incompatible with XSLT 2.0
681 (define-instruction xsl:document (args env)
682 (destructuring-bind ((href &key method indent doctype-public doctype-system)
683 &body body)
684 args
685 (declare (ignore doctype-public doctype-system)) ;fixme
686 (let ((thunk (compile-instruction `(progn ,@body) env))
687 (href-thunk (compile-avt href env)))
688 (lambda (ctx)
689 (let ((pathname
690 (uri-to-pathname
691 (puri:merge-uris (funcall href-thunk ctx)
692 (xpath-protocol:base-uri
693 (xpath:context-node ctx))))))
694 (ensure-directories-exist pathname) ;really?
695 (invoke-with-output-sink
696 (lambda ()
697 (funcall thunk ctx))
698 (make-output-specification :method (or method "XML") :indent indent)
699 pathname))))))
701 (defun compile-instruction (form env)
702 (xslt-trace-thunk
703 (funcall (or (get (car form) 'xslt-instruction)
704 (error "undefined instruction: ~A" (car form)))
705 (cdr form)
706 env)
707 "instruction ~s" (car form)))
709 ;;: WTF: "A right curly brace inside a Literal in an expression is not
710 ;;; recognized as terminating the expression."
712 ;;; Da hilft nur tagbody.
713 (defun parse-attribute-value-template (template-string)
714 (with-input-from-string (input template-string)
715 (let ((ordinary (make-string-output-stream))
716 (xpath (make-string-output-stream))
717 (tokens '())
718 (c (read-char input nil :eof)))
719 (flet ((emit ()
720 (let ((o (get-output-stream-string ordinary)))
721 (when (plusp (length o))
722 (push (list :data o) tokens)))
723 (let ((x (get-output-stream-string xpath)))
724 (when (plusp (length x))
725 (push (list :xpath x) tokens))))
726 (collect-ordinary ()
727 (write-char c ordinary))
728 (collect-xpath ()
729 (write-char c xpath)))
730 (macrolet ((goto (target)
731 `(progn
732 (setf c (read-char input nil :eof))
733 (go ,target))))
734 (tagbody
735 ordinary
736 (case c
737 (#\{
738 (goto seen{))
739 (#\}
740 (goto seen-stray-}))
741 (:eof
742 (go done)))
743 (collect-ordinary)
744 (goto ordinary)
746 seen{
747 (case c
748 (#\{
749 (collect-ordinary)
750 (goto ordinary))
751 (#\'
752 (collect-xpath)
753 (goto in-single-quote))
754 (:eof
755 (xslt-error "unexpected end of avt")))
756 (emit)
757 (collect-xpath)
758 (goto xpath)
760 xpath
761 (case c
762 (#\'
763 (collect-xpath)
764 (goto in-single-quote))
765 (#\"
766 (collect-xpath)
767 (goto in-double-quote))
768 (#\}
769 (goto seen-closing-}))
770 (:eof
771 (xslt-error "unexpected end of avt")))
772 (collect-xpath)
773 (goto xpath)
775 in-single-quote
776 (case c
777 (#\'
778 (collect-xpath)
779 (goto xpath))
780 (:eof
781 (xslt-error "unexpected end of avt")))
782 (collect-xpath)
783 (goto in-single-quote)
785 in-double-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-double-quote)
795 seen-closing-}
796 (case c
797 (#\}
798 (collect-xpath)
799 (goto xpath))
800 (#\{
801 (emit)
802 (goto xpath))
803 (:eof
804 (goto done)))
805 (emit)
806 (collect-ordinary)
807 (goto ordinary)
809 seen-stray-}
810 (case c
811 (#\}
812 (collect-ordinary)
813 (goto ordinary)))
814 (xslt-error "unexpected closing brace in avt")
816 done
817 (emit))))
818 (nreverse tokens))))
820 (defun compile-avt (template-string env)
821 (let* ((constantp t)
822 (fns
823 (mapcar (lambda (x)
824 (ecase (car x)
825 (:data
826 (constantly (second x)))
827 (:xpath
828 (setf constantp nil)
829 (compile-xpath (second x) env))))
830 (parse-attribute-value-template template-string))))
831 (values (lambda (ctx)
832 (with-output-to-string (s)
833 (dolist (fn fns)
834 (write-string (xpath:string-value (funcall fn ctx)) s))))
835 constantp)))
838 ;;;; Indentation for slime
840 (defmacro define-indentation (name (&rest args))
841 (labels ((collect-variables (list)
842 (loop
843 for sub in list
844 append
845 (etypecase sub
846 (list
847 (collect-variables sub))
848 (symbol
849 (if (eql (mismatch "&" (symbol-name sub)) 1)
851 (list sub)))))))
852 `(defmacro ,name (,@args)
853 (declare (ignorable ,@(collect-variables args)))
854 (error "XSL indentation helper ~A used literally in lisp code"
855 ',name))))
857 (define-indentation xsl:element
858 ((name &key namespace use-attribute-sets) &body body))
859 (define-indentation xsl:literal-element ((name &optional uri) &body body))
860 (define-indentation xsl:attribute ((name &key namespace) &body body))
861 (define-indentation xsl:literal-attribute ((name &optional uri) &body body))
862 (define-indentation xsl:text (str))
863 (define-indentation xsl:processing-instruction (name &body body))
864 (define-indentation xsl:comment (&body body))
865 (define-indentation xsl:value-of (xpath))
866 (define-indentation xsl:unescaped-value-of (xpath))
867 (define-indentation xsl:for-each (select &body decls-and-body))
868 (define-indentation xsl:message (&body body))
869 (define-indentation xsl:terminate (&body body))
870 (define-indentation xsl:apply-templates ((&key select mode) &body decls-and-body))
871 (define-indentation xsl:call-template (name &rest parameters))
872 (define-indentation xsl:copy-of (xpath))
874 ;;;;
876 (defun test-instruction (form document)
877 (let ((thunk (compile-instruction form (make-instance 'lexical-environment)))
878 (root (cxml:parse document (stp:make-builder))))
879 (with-xml-output (cxml:make-string-sink)
880 (funcall thunk (xpath:make-context root)))))