1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
3 ;;; Copyright (c) 2007,2008 David Lichteblau, Ivan Shvedunov.
4 ;;; All rights reserved.
6 ;;; Redistribution and use in source and binary forms, with or without
7 ;;; modification, are permitted provided that the following conditions
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
13 ;;; * Redistributions in binary form must reproduce the above
14 ;;; copyright notice, this list of conditions and the following
15 ;;; disclaimer in the documentation and/or other materials
16 ;;; provided with the distribution.
18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
21 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
30 (in-package :xuriella
)
33 (declaim (optimize (debug 2)))
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
))
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
))))
53 ((xpath:boolean-value
(funcall test-thunk ctx
))
54 (funcall then-thunk ctx
))
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
)
68 (destructuring-bind ((test &body body
) &rest clauses
) args
69 (compile-instruction (if (eq test t
)
77 (define-instruction progn
(args env
)
79 (let ((first-thunk (compile-instruction (first args
) env
))
80 (rest-thunk (compile-instruction `(progn ,@(rest args
)) env
)))
82 (funcall first-thunk ctx
)
83 (funcall rest-thunk ctx
)))
86 (defun decode-qname/runtime
(qname namespaces attributep
)
88 (multiple-value-bind (prefix local-name
)
91 (if (or prefix
(not attributep
))
92 (or (cdr (assoc prefix namespaces
:test
'equal
))
93 (xslt-error "namespace not found: ~A" 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
)
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
)
108 (compile-avt namespace env
)
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
)
120 (setf uri namespace
))
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
130 (xslt-error "namespace not found: ~A" prefix
)
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
*))
141 (let ((qname (funcall name-thunk ctx
)))
142 (multiple-value-bind (local-name uri prefix
)
143 (decode-qname/runtime qname namespaces nil
)
145 (setf uri
(funcall ns-thunk ctx
)))
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
)))
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
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
)
169 (compile-avt namespace env
)
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
)
181 (setf uri namespace
))
183 (write-attribute local-name
185 (with-toplevel-text-output-sink (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
*))
195 (let ((qname (funcall name-thunk ctx
)))
196 (multiple-value-bind (local-name uri prefix
)
197 (decode-qname/runtime qname namespaces t
)
199 (setf uri
(funcall ns-thunk ctx
)))
200 (write-attribute local-name
202 (with-toplevel-text-output-sink (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 '())
214 for cons in namespaces
215 for
(prefix* . uri
) = cons
216 for prefix
= (or prefix
* "")
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
))))
227 (define-instruction xsl
:literal-element
(args env
)
229 ((local-name &optional
(uri "") suggested-prefix
) &body body
)
231 (let ((body-thunk (compile-instruction `(progn ,@body
) env
))
232 (namespaces (remove-excluded-namespaces *namespaces
*)))
234 (with-element (local-name (or uri
"")
235 :suggested-prefix suggested-prefix
236 :extra-namespaces namespaces
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
)))
244 (write-attribute local-name
246 (funcall value-thunk ctx
)
248 :suggested-prefix suggested-prefix
)))))
250 (define-instruction xsl
:text
(args env
)
251 (destructuring-bind (str) args
253 (declare (ignore ctx
))
256 (define-instruction xsl
:unescaped-text
(args env
)
257 (destructuring-bind (str) args
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
)))
267 (write-processing-instruction
268 (funcall name-thunk ctx
)
269 (with-toplevel-text-output-sink (s)
271 (funcall value-thunk ctx
))))))))
273 (define-instruction xsl
:comment
(args env
)
274 (let ((value-thunk (compile-instruction `(progn ,@args
) env
)))
276 (write-comment (with-toplevel-text-output-sink (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
)))
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
)))
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" "")))
301 (let ((result (funcall thunk ctx
)))
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)
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
#\
{ #\|
#\
} #\~
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
#\
{ #\|
#\
} #\~
347 (defun collation-char (char table
)
348 (let ((code (char-code char
)))
350 (elt table
(- code
32))
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
))
363 ((xpath::compare-numbers
'< n-a n-b
) -
1)
364 ((xpath::compare-numbers
'> n-a n-b
) 1)
367 (defun mismatch* (a b
)
368 (let ((pos (mismatch a b
)))
369 (if (and pos
(< pos
(min (length a
) (length b
))))
373 (defun compare-strings (i j char-table
)
374 ;; zzz Unicode support!
376 (or (mismatch* (string-downcase i
) (string-downcase j
))
379 (let ((c (collation-char (elt i pos
) char-table
))
380 (d (collation-char (elt j pos
) char-table
)))
385 (signum (- (length i
) (length j
))))))
387 (defun make-sorter/lazy
(spec env
)
388 (destructuring-bind (&key select lang data-type order case-order
)
390 (let ((select-thunk (compile-xpath (or select
".") env
))
391 (lang-thunk (compile-avt (or lang
"") env
))
392 (data-type-thunk (compile-avt (or data-type
"") env
))
393 (order-thunk (compile-avt (or order
"") env
))
394 (case-order-thunk (compile-avt (or case-order
"") env
)))
397 (equal (funcall data-type-thunk ctx
) "number"))
399 (if (equal (funcall case-order-thunk ctx
) "lower-first")
401 *upper-first-order
*))
403 (if (equal (funcall order-thunk ctx
) "descending") -
1 1))
405 (funcall lang-thunk ctx
)))
406 (declare (ignore lang
))
408 (let ((i (xpath:string-value
(funcall select-thunk a
)))
409 (j (xpath:string-value
(funcall select-thunk b
))))
412 (compare-numbers (xpath:number-value i
)
413 (xpath:number-value j
))
414 (compare-strings i j char-table
))))))))))
416 (defun compose-sorters/lazy
(sorters)
418 (let ((this-thunk (car sorters
))
419 (next-thunk (compose-sorters/lazy
(rest sorters
))))
421 (let ((this (funcall this-thunk ctx
))
422 (next (funcall next-thunk ctx
)))
424 (let ((d (funcall this a b
)))
429 (declare (ignore ctx
))
432 (defun make-sort-predicate/lazy
(decls env
)
434 (compose-sorters/lazy
435 (mapcar (lambda (x) (make-sorter/lazy x env
)) decls
))))
437 (let ((sorter (funcall sorter-thunk ctx
)))
439 (minusp (funcall sorter a b
)))))))
441 (defun contextify-node-list (nodes)
442 (let ((size (length nodes
)))
447 (xpath:make-context node size position
))))
449 (define-instruction xsl
:for-each
(args env
)
450 (destructuring-bind (select &optional decls
&rest body
) args
451 (unless (and (consp decls
)
452 (eq (car decls
) 'declare
))
455 (let ((select-thunk (compile-xpath select env
))
456 (body-thunk (compile-instruction `(progn ,@body
) env
))
457 (sort-predicate-thunk
459 (make-sort-predicate/lazy
(cdr decls
) env
))))
461 (let ((selected (funcall select-thunk ctx
))
463 (lambda (&optional ignore
)
464 (declare (ignore ignore
))
465 (xslt-error "apply-imports used in for-each"))))
466 (unless (xpath:node-set-p selected
)
467 (xslt-error "for-each select expression should yield a node-set"))
468 (let ((nodes (xpath::force
(xpath::sorted-pipe-of selected
))))
469 (when sort-predicate-thunk
471 (mapcar #'xpath
:context-node
472 (stable-sort (contextify-node-list nodes
)
473 (funcall sort-predicate-thunk ctx
)))))
474 (dolist (ctx (contextify-node-list nodes
))
475 (funcall body-thunk ctx
))))))))
477 (define-instruction xsl
:with-namespaces
(args env
)
478 (destructuring-bind ((&rest forms
) &rest body
) args
479 (let ((*namespaces
* *namespaces
*))
481 (destructuring-bind (prefix uri
) form
482 (push (cons prefix uri
) *namespaces
*)))
483 (compile-instruction `(progn ,@body
) env
))))
485 (define-instruction xsl
:with-excluded-namespaces
(args env
)
486 (destructuring-bind ((&rest uris
) &rest body
) args
487 (let ((*excluded-namespaces
* (append uris
*excluded-namespaces
*)))
488 (compile-instruction `(progn ,@body
) env
))))
490 (define-instruction xsl
:with-extension-namespaces
(args env
)
491 (destructuring-bind ((&rest uris
) &rest body
) args
492 (let ((*extension-namespaces
* (append uris
*extension-namespaces
*)))
493 (compile-instruction `(progn ,@body
) env
))))
495 (define-instruction xsl
:with-version
(args env
)
496 (destructuring-bind (version &rest body
) args
497 (let ((*forwards-compatible-p
* (not (equal version
"1.0"))))
498 (compile-instruction `(progn ,@body
) env
))))
500 ;; XSLT disallows multiple definitions of the same variable within a
501 ;; template. Local variables can shadow global variables though.
502 ;; Since our LET syntax makes it natural to shadow local variables the
503 ;; Lisp way, we check for duplicate variables only where instructed to
504 ;; by the XML syntax parser using WITH-DUPLICATES-CHECK:
505 (defvar *template-variables
* nil
)
507 (define-instruction xsl
:with-duplicates-check
(args env
)
508 (let ((*template-variables
* *template-variables
*))
509 (destructuring-bind ((&rest qnames
) &rest body
) args
510 (dolist (qname qnames
)
511 (multiple-value-bind (local-name uri
)
512 (decode-qname qname env nil
)
513 (let ((key (cons local-name uri
)))
514 (when (find key
*template-variables
* :test
#'equal
)
515 (xslt-error "duplicate variable: ~A, ~A" local-name uri
))
516 (push key
*template-variables
*))))
517 (compile-instruction `(progn ,@body
) env
))))
519 (define-instruction xsl
:with-base-uri
(args env
)
520 (destructuring-bind (uri &rest body
) args
521 (let ((*instruction-base-uri
* uri
))
522 (compile-instruction `(progn ,@body
) env
))))
524 (defstruct (result-tree-fragment
525 (:constructor make-result-tree-fragment
(node)))
528 (define-default-method xpath-protocol
:node-p
529 ((node result-tree-fragment
))
532 (define-default-method xpath-protocol
:node-text
533 ((node result-tree-fragment
))
534 (xpath-protocol:node-text
(result-tree-fragment-node node
)))
536 (defun apply-to-result-tree-fragment (ctx thunk
)
538 (with-xml-output (make-stpx-builder)
539 (with-element ("fragment" "")
540 (funcall thunk ctx
)))))
541 (make-result-tree-fragment (stp:document-element document
))))
543 (defun compile-var-bindings/nointern
(forms env
)
545 for
(name value
) in forms
546 collect
(multiple-value-bind (local-name uri
)
547 (decode-qname name env nil
)
548 (list (cons local-name uri
)
550 (compile-value-thunk value env
)
551 "local variable ~s = ~s" name
:result
)))))
553 (define-instruction let
(args env
)
554 (destructuring-bind ((&rest forms
) &rest body
) args
555 (let* ((old-top (length *lexical-variable-declarations
*))
556 (vars-and-names (compile-var-bindings/nointern forms env
))
558 (loop for
((local-name . uri
) thunk
) in vars-and-names
560 (list (push-variable local-name
562 *lexical-variable-declarations
*)
564 (let ((thunk (compile-instruction `(progn ,@body
) env
)))
565 (fill *lexical-variable-declarations
* nil
:start old-top
)
567 (loop for
(index var-thunk
) in vars-and-positions
568 do
(setf (lexical-variable-value index
)
569 (funcall var-thunk ctx
)))
570 (funcall thunk ctx
))))))
572 (define-instruction let
* (args env
)
573 (destructuring-bind ((&rest forms
) &rest body
) args
575 (compile-instruction `(let (,(car forms
))
576 (let* (,@(cdr forms
))
579 (compile-instruction `(progn ,@body
) env
))))
581 (define-instruction xsl
:message
(args env
)
582 (compile-message #'warn args env
))
584 (define-instruction xsl
:terminate
(args env
)
585 (compile-message #'xslt-error args env
))
587 (defun namespaces-as-alist (element)
588 (let ((namespaces '()))
589 (do-pipe (ns (xpath-protocol:namespace-pipe element
))
590 (push (cons (xpath-protocol:local-name ns
)
591 (xpath-protocol:node-text ns
))
595 (define-instruction xsl
:copy
(args env
)
596 (let ((body (compile-instruction `(progn ,@args
) env
)))
598 (let ((node (xpath:context-node ctx
)))
600 ((xpath-protocol:node-type-p node
:element
)
602 ((xpath-protocol:local-name node
)
603 (xpath-protocol:namespace-uri node
)
604 :suggested-prefix
(xpath-protocol:namespace-prefix node
)
605 :extra-namespaces
(namespaces-as-alist node
))
607 ((xpath-protocol:node-type-p node
:document
)
610 (copy-leaf-node node
)))))))
612 (defun copy-leaf-node (node)
614 ((xpath-protocol:node-type-p node
:text
)
615 (etypecase (if (typep node
'stripping-node
)
616 (stripping-node-target node
)
618 (unescaped-text (write-unescaped (xpath-protocol:node-text node
)))
619 (stp:text
(write-text (xpath-protocol:node-text node
)))))
620 ((xpath-protocol:node-type-p node
:comment
)
621 (write-comment (xpath-protocol:node-text node
)))
622 ((xpath-protocol:node-type-p node
:processing-instruction
)
623 (write-processing-instruction
624 (xpath-protocol:processing-instruction-target node
)
625 (xpath-protocol:node-text node
)))
626 ((xpath-protocol:node-type-p node
:attribute
)
628 (xpath-protocol:local-name node
)
629 (xpath-protocol:namespace-uri node
)
630 (xpath-protocol:node-text node
)
631 :suggested-prefix
(xpath-protocol:namespace-prefix node
)))
632 ((xpath-protocol:node-type-p node
:namespace
)
633 (write-extra-namespace
634 (xpath-protocol:local-name node
)
635 (xpath-protocol:node-text node
)
638 (error "don't know how to copy node ~A" node
))))
640 (defun compile-message (fn args env
)
641 (let ((thunk (compile-instruction `(progn ,@args
) env
)))
644 (with-xml-output (cxml:make-string-sink
)
645 (funcall thunk ctx
))))))
647 (define-instruction xsl
:apply-templates
(args env
)
648 (destructuring-bind ((&key select mode
) &rest param-binding-specs
) args
650 (when (and (consp (car param-binding-specs
))
651 (eq (caar param-binding-specs
) 'declare
))
652 (cdr (pop param-binding-specs
))))
654 (compile-xpath (or select
"child::node()") env
))
656 (compile-var-bindings param-binding-specs env
))
657 (sort-predicate-thunk
659 (make-sort-predicate/lazy decls env
))))
660 (multiple-value-bind (mode-local-name mode-uri
)
661 (and mode
(decode-qname mode env nil
))
663 (apply-templates/list
665 (xpath::sorted-pipe-of
(funcall select-thunk ctx
)))
667 (loop for
(name nil value-thunk
) in param-bindings
668 collect
(list name
(funcall value-thunk ctx
)))
669 :sort-predicate
(when sort-predicate-thunk
670 (funcall sort-predicate-thunk ctx
))
672 (or (find-mode *stylesheet
*
677 (define-instruction xsl
:apply-imports
(args env
)
678 (declare (ignore args env
))
680 (declare (ignore ctx
))
681 (funcall *apply-imports
*)))
683 (define-instruction xsl
:call-template
(args env
)
684 (destructuring-bind (name &rest param-binding-specs
) args
685 (let ((param-bindings
686 (compile-var-bindings param-binding-specs env
)))
687 (multiple-value-bind (local-name uri
)
688 (decode-qname name env nil
)
689 (setf name
(cons local-name uri
)))
691 (call-template ctx name
692 (loop for
(name nil value-thunk
) in param-bindings
693 collect
(list name
(funcall value-thunk ctx
))))))))
695 ;; fixme: incompatible with XSLT 2.0
696 (define-instruction xsl
:document
(args env
)
697 (destructuring-bind ((href &key method indent doctype-public doctype-system
)
700 (declare (ignore doctype-public doctype-system
)) ;fixme
701 (let ((thunk (compile-instruction `(progn ,@body
) env
))
702 (href-thunk (compile-avt href env
)))
706 (puri:merge-uris
(funcall href-thunk ctx
)
707 (xpath-protocol:base-uri
708 (xpath:context-node ctx
))))))
709 (ensure-directories-exist pathname
) ;really?
710 (invoke-with-output-sink
713 (make-output-specification :method
(or method
"XML") :indent indent
)
716 (defun compile-instruction (form env
)
718 (funcall (or (get (car form
) 'xslt-instruction
)
719 (error "undefined instruction: ~A" (car form
)))
722 "instruction ~s" (car form
)))
724 ;;: WTF: "A right curly brace inside a Literal in an expression is not
725 ;;; recognized as terminating the expression."
727 ;;; Da hilft nur tagbody.
728 (defun parse-attribute-value-template (template-string)
729 (with-input-from-string (input template-string
)
730 (let ((ordinary (make-string-output-stream))
731 (xpath (make-string-output-stream))
733 (c (read-char input nil
:eof
)))
735 (let ((o (get-output-stream-string ordinary
)))
736 (when (plusp (length o
))
737 (push (list :data o
) tokens
)))
738 (let ((x (get-output-stream-string xpath
)))
739 (when (plusp (length x
))
740 (push (list :xpath x
) tokens
))))
742 (write-char c ordinary
))
744 (write-char c xpath
)))
745 (macrolet ((goto (target)
747 (setf c
(read-char input nil
:eof
))
768 (goto in-single-quote
))
770 (xslt-error "unexpected end of avt")))
779 (goto in-single-quote
))
782 (goto in-double-quote
))
784 (goto seen-closing-
}))
786 (xslt-error "unexpected end of avt")))
796 (xslt-error "unexpected end of avt")))
798 (goto in-single-quote
)
806 (xslt-error "unexpected end of avt")))
808 (goto in-double-quote
)
829 (xslt-error "unexpected closing brace in avt")
835 (defun compile-avt (template-string env
)
841 (constantly (second x
)))
844 (compile-xpath (second x
) env
))))
846 (parse-attribute-value-template template-string
)
847 (xslt-error "missing avt")))))
848 (values (lambda (ctx)
849 (with-output-to-string (s)
851 (write-string (xpath:string-value
(funcall fn ctx
)) s
))))
855 ;;;; Indentation for slime
857 (defmacro define-indentation
(name (&rest args
))
858 (labels ((collect-variables (list)
864 (collect-variables sub
))
866 (if (eql (mismatch "&" (symbol-name sub
)) 1)
869 `(defmacro ,name
(,@args
)
870 (declare (ignorable ,@(collect-variables args
)))
871 (error "XSL indentation helper ~A used literally in lisp code"
874 (define-indentation xsl
:element
875 ((name &key namespace use-attribute-sets
) &body body
))
876 (define-indentation xsl
:literal-element
((name &optional uri
) &body body
))
877 (define-indentation xsl
:attribute
((name &key namespace
) &body body
))
878 (define-indentation xsl
:literal-attribute
((name &optional uri
) &body body
))
879 (define-indentation xsl
:text
(str))
880 (define-indentation xsl
:processing-instruction
(name &body body
))
881 (define-indentation xsl
:comment
(&body body
))
882 (define-indentation xsl
:value-of
(xpath))
883 (define-indentation xsl
:unescaped-value-of
(xpath))
884 (define-indentation xsl
:for-each
(select &body decls-and-body
))
885 (define-indentation xsl
:message
(&body body
))
886 (define-indentation xsl
:terminate
(&body body
))
887 (define-indentation xsl
:apply-templates
((&key select mode
) &body decls-and-body
))
888 (define-indentation xsl
:call-template
(name &rest parameters
))
889 (define-indentation xsl
:copy-of
(xpath))
893 (defun test-instruction (form document
)
894 (let ((thunk (compile-instruction form
(make-instance 'lexical-environment
)))
895 (root (cxml:parse document
(stp:make-builder
))))
896 (with-xml-output (cxml:make-string-sink
)
897 (funcall thunk
(xpath:make-context root
)))))