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)))
36 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
37 (defvar *xsl
* "http://www.w3.org/1999/XSL/Transform")
38 (defvar *xml
* "http://www.w3.org/XML/1998/namespace")
39 (defvar *html
* "http://www.w3.org/1999/xhtml"))
44 (define-condition xslt-error
(simple-error)
46 (:documentation
"The class of all XSLT errors."))
48 (define-condition recoverable-xslt-error
(xslt-error)
50 (:documentation
"The class of recoverable XSLT errors."))
52 (defun xslt-error (fmt &rest args
)
53 (error 'xslt-error
:format-control fmt
:format-arguments args
))
55 (defun xslt-cerror (fmt &rest args
)
56 (with-simple-restart (recover "recover")
57 (error 'recoverable-xslt-error
59 :format-arguments args
)))
63 (defmacro handler-case
* (form &rest clauses
)
64 ;; like HANDLER-CASE if *DEBUG* is off. If it's on, don't establish
65 ;; a handler at all so that we see the real stack traces. (We could use
66 ;; HANDLER-BIND here and check at signalling time, but doesn't seem
68 (let ((doit (gensym)))
69 `(flet ((,doit
() ,form
))
76 (defun compile-xpath (xpath &optional env
)
78 (xpath:compile-xpath xpath env
)
79 (xpath:xpath-error
(c)
80 (xslt-error "~A" c
))))
82 (defmacro with-stack-limit
((&optional
) &body body
)
83 `(invoke-with-stack-limit (lambda () ,@body
)))
86 ;;;; Helper function and macro
88 (defun map-pipe-eagerly (fn pipe
)
89 (xpath::enumerate pipe
:key fn
:result nil
))
91 (defmacro do-pipe
((var pipe
&optional result
) &body body
)
93 (map-pipe-eagerly #'(lambda (,var
) ,@body
) ,pipe
)
97 ;;;; XSLT-ENVIRONMENT and XSLT-CONTEXT
99 (defparameter *namespaces
*
101 ("xmlns" .
#"http://www.w3.org/2000/xmlns/")
102 ("xml" .
#"http://www.w3.org/XML/1998/namespace")))
104 (defvar *global-variable-declarations
*)
105 (defvar *lexical-variable-declarations
*)
107 (defvar *global-variable-values
*)
108 (defvar *lexical-variable-values
*)
110 (defclass xslt-environment
() ())
112 (defun split-qname (str)
114 (multiple-value-bind (prefix local-name
)
115 (cxml::split-qname str
)
117 ;; FIXME: cxml should really offer a function that does
118 ;; checks for NCName and QName in a sensible way for user code.
119 ;; cxml::split-qname is tailored to the needs of the parser.
121 ;; For now, let's just check the syntax explicitly.
122 (and (or (null prefix
) (xpath::nc-name-p prefix
))
123 (xpath::nc-name-p local-name
))
124 (xslt-error "not a qname: ~A" str
))
125 (values prefix local-name
))
126 (cxml:well-formedness-violation
()
127 (xslt-error "not a qname: ~A" str
))))
129 (defun decode-qname (qname env attributep
)
130 (multiple-value-bind (prefix local-name
)
133 (if (or prefix
(not attributep
))
134 (xpath-sys:environment-find-namespace env
(or prefix
""))
138 (defmethod xpath-sys:environment-find-namespace
((env xslt-environment
) prefix
)
139 (or (cdr (assoc prefix
*namespaces
* :test
'equal
))
141 ;; Change the entire code base to represent "no prefix" as the
142 ;; empty string consistently. unparse.lisp has already been changed.
143 (and (equal prefix
"")
144 (cdr (assoc nil
*namespaces
* :test
'equal
)))
145 (and (eql prefix nil
)
146 (cdr (assoc "" *namespaces
* :test
'equal
)))))
148 (defun find-variable-index (local-name uri table
)
149 (position (cons local-name uri
) table
:test
'equal
))
151 (defun intern-global-variable (local-name uri
)
152 (or (find-variable-index local-name uri
*global-variable-declarations
*)
153 (push-variable local-name uri
*global-variable-declarations
*)))
155 (defun push-variable (local-name uri table
)
158 (vector-push-extend (cons local-name uri
) table
)))
160 (defun lexical-variable-value (index &optional
(errorp t
))
161 (let ((result (svref *lexical-variable-values
* index
)))
163 (assert (not (eq result
'unbound
))))
166 (defun (setf lexical-variable-value
) (newval index
)
167 (assert (not (eq newval
'unbound
)))
168 (setf (svref *lexical-variable-values
* index
) newval
))
170 (defun global-variable-value (index &optional
(errorp t
))
171 (let ((result (svref *global-variable-values
* index
)))
173 (assert (not (eq result
'unbound
))))
176 (defun (setf global-variable-value
) (newval index
)
177 (assert (not (eq newval
'unbound
)))
178 (setf (svref *global-variable-values
* index
) newval
))
180 (defmethod xpath-sys:environment-find-function
181 ((env xslt-environment
) lname uri
)
183 (or (xpath-sys:find-xpath-function lname
*xsl
*)
184 (xpath-sys:find-xpath-function lname uri
))
185 (xpath-sys:find-xpath-function lname uri
)))
187 (defmethod xpath-sys:environment-find-variable
188 ((env xslt-environment
) lname uri
)
190 (find-variable-index lname uri
*lexical-variable-declarations
*)))
193 (declare (ignore ctx
))
194 (svref *lexical-variable-values
* index
)))))
196 (defclass lexical-xslt-environment
(xslt-environment) ())
198 (defmethod xpath-sys:environment-find-variable
199 ((env lexical-xslt-environment
) lname uri
)
200 (or (call-next-method)
202 (find-variable-index lname uri
*global-variable-declarations
*)))
206 (declare (ignore ctx
))
207 (svref *global-variable-values
* index
))
208 "global ~s (uri ~s) = ~s" lname uri
:result
)))))
210 (defclass global-variable-environment
(xslt-environment)
211 ((initial-global-variable-thunks
212 :initarg
:initial-global-variable-thunks
213 :accessor initial-global-variable-thunks
)))
215 (defmethod xpath-sys:environment-find-variable
216 ((env global-variable-environment
) lname uri
)
217 (or (call-next-method)
218 (gethash (cons lname uri
) (initial-global-variable-thunks env
))))
221 ;;;; TOPLEVEL-TEXT-OUTPUT-SINK
223 ;;;; A sink that serializes only text not contained in any element.
225 (defmacro with-toplevel-text-output-sink
((var) &body body
)
226 `(invoke-with-toplevel-text-output-sink (lambda (,var
) ,@body
)))
228 (defclass toplevel-text-output-sink
(sax:default-handler
)
229 ((target :initarg
:target
:accessor text-output-sink-target
)
230 (depth :initform
0 :accessor textoutput-sink-depth
)))
232 (defmethod sax:start-element
((sink toplevel-text-output-sink
)
233 namespace-uri local-name qname attributes
)
234 (declare (ignore namespace-uri local-name qname attributes
))
235 (incf (textoutput-sink-depth sink
)))
237 (defmethod sax:characters
((sink toplevel-text-output-sink
) data
)
238 (when (zerop (textoutput-sink-depth sink
))
239 (write-string data
(text-output-sink-target sink
))))
241 (defmethod sax:unescaped
((sink toplevel-text-output-sink
) data
)
242 (sax:characters sink data
))
244 (defmethod sax:end-element
((sink toplevel-text-output-sink
)
245 namespace-uri local-name qname
)
246 (declare (ignore namespace-uri local-name qname
))
247 (decf (textoutput-sink-depth sink
)))
249 (defun invoke-with-toplevel-text-output-sink (fn)
250 (with-output-to-string (s)
251 (funcall fn
(make-instance 'toplevel-text-output-sink
:target s
))))
256 ;;;; A sink that passes through only text (at any level).
258 (defclass text-filter
(sax:default-handler
)
259 ((target :initarg
:target
:accessor text-filter-target
)))
261 (defmethod sax:characters
((sink text-filter
) data
)
262 (sax:characters
(text-filter-target sink
) data
))
264 (defmethod sax:unescaped
((sink text-filter
) data
)
265 (sax:unescaped
(text-filter-target sink
) data
))
267 (defmethod sax:end-document
((sink text-filter
))
268 (sax:end-document
(text-filter-target sink
)))
270 (defun make-text-filter (target)
271 (make-instance 'text-filter
:target target
))
276 ;;;; A sink that recovers from sax:unescaped using sax:characters, as per
279 (defclass escaper
(cxml:broadcast-handler
)
282 (defmethod sax:unescaped
((sink escaper
) data
)
283 (sax:characters sink data
))
285 (defun make-escaper (target)
286 (make-instance 'escaper
:handlers
(list target
)))
291 (defun of-name (local-name)
292 (stp:of-name local-name
*xsl
*))
294 (defun namep (node local-name
)
295 (and (typep node
'(or stp
:element stp
:attribute
))
296 (equal (stp:namespace-uri node
) *xsl
*)
297 (equal (stp:local-name node
) local-name
)))
300 ;;;; PARSE-STYLESHEET
302 (defstruct stylesheet
303 (modes (make-hash-table :test
'equal
))
304 (global-variables (make-empty-declaration-array))
305 (output-specification (make-output-specification))
307 (named-templates (make-hash-table :test
'equal
))
308 (attribute-sets (make-hash-table :test
'equal
))
309 (keys (make-hash-table :test
'equal
))
310 (namespace-aliases (make-hash-table :test
'equal
))
311 (decimal-formats (make-hash-table :test
'equal
)))
313 (defstruct mode
(templates nil
))
315 (defun find-mode (stylesheet local-name
&optional uri
)
316 (gethash (cons local-name uri
) (stylesheet-modes stylesheet
)))
318 (defun ensure-mode (stylesheet &optional local-name uri
)
319 (or (find-mode stylesheet local-name uri
)
320 (setf (gethash (cons local-name uri
) (stylesheet-modes stylesheet
))
323 (defun ensure-mode/qname
(stylesheet qname env
)
325 (multiple-value-bind (local-name uri
)
326 (decode-qname qname env nil
)
327 (ensure-mode stylesheet local-name uri
))
328 (find-mode stylesheet nil
)))
330 (defun acons-namespaces (element &optional
(bindings *namespaces
*))
331 (map-namespace-declarations (lambda (prefix uri
)
332 (push (cons prefix uri
) bindings
))
336 (defun find-key (name stylesheet
)
337 (or (gethash name
(stylesheet-keys stylesheet
))
338 (xslt-error "unknown key: ~a" name
)))
340 (defun make-key (match use
) (cons match use
))
342 (defun key-match (key) (car key
))
344 (defun key-use (key) (cdr key
))
346 (defun add-key (stylesheet name match use
)
347 (if (gethash name
(stylesheet-keys stylesheet
))
348 (xslt-error "duplicate key: ~a" name
)
349 (setf (gethash name
(stylesheet-keys stylesheet
))
350 (make-key match use
))))
352 (defvar *excluded-namespaces
* (list *xsl
*))
353 (defvar *empty-mode
*)
354 (defvar *default-mode
*)
356 (defvar *xsl-include-stack
* nil
)
358 (defun uri-to-pathname (uri)
359 (cxml::uri-to-pathname
(puri:parse-uri uri
)))
361 (defun parse-stylesheet-to-stp (input uri-resolver
)
362 (let* ((d (cxml:parse input
(make-text-normalizer (cxml-stp:make-builder
))))
363 (<transform
> (stp:document-element d
)))
364 (strip-stylesheet <transform
>)
365 ;; FIXME: handle embedded stylesheets
366 (unless (and (equal (stp:namespace-uri
<transform
>) *xsl
*)
367 (or (equal (stp:local-name
<transform
>) "transform")
368 (equal (stp:local-name
<transform
>) "stylesheet")))
369 (xslt-error "not a stylesheet"))
370 (dolist (include (stp:filter-children
(of-name "include") <transform
>))
371 (let* ((uri (puri:merge-uris
(stp:attribute-value include
"href")
372 (stp:base-uri include
)))
373 (uri (if uri-resolver
374 (funcall uri-resolver
(puri:render-uri uri nil
))
376 (str (puri:render-uri uri nil
))
379 (uri-to-pathname uri
)
380 (cxml:xml-parse-error
(c)
381 (xslt-error "cannot find included stylesheet ~A: ~A"
385 :element-type
'(unsigned-byte 8)
386 :if-does-not-exist nil
)
388 (xslt-error "cannot find included stylesheet ~A at ~A"
390 (when (find str
*xsl-include-stack
* :test
#'equal
)
391 (xslt-error "recursive inclusion of ~A" uri
))
392 (let* ((*xsl-include-stack
* (cons str
*xsl-include-stack
*))
393 (<transform
>2 (parse-stylesheet-to-stp stream uri-resolver
)))
394 (stp:insert-child-after
<transform
>
395 (stp:copy
<transform
>2)
397 (stp:detach include
)))))
400 (defvar *instruction-base-uri
*) ;misnamed, is also used in other attributes
401 (defvar *apply-imports-limit
*)
402 (defvar *import-priority
*)
403 (defvar *extension-namespaces
*)
405 (defmacro do-toplevel
((var xpath
<transform
>) &body body
)
406 `(map-toplevel (lambda (,var
) ,@body
) ,xpath
,<transform
>))
408 (defun map-toplevel (fn xpath
<transform
>)
409 (dolist (node (list-toplevel xpath
<transform
>))
410 (let ((*namespaces
* *namespaces
*))
411 (xpath:do-node-set
(ancestor (xpath:evaluate
"ancestor::node()" node
))
412 (when (xpath-protocol:node-type-p ancestor
:element
)
413 (setf *namespaces
* (acons-namespaces ancestor
))))
416 (defun list-toplevel (xpath <transform
>)
417 (labels ((recurse (sub)
420 (xpath:evaluate
"transform|stylesheet" sub
))))
422 (xpath-sys:pipe-of
(xpath:evaluate xpath sub
))
423 (xpath::mappend-pipe
#'recurse subsubs
)))))
424 (xpath::sort-nodes
(recurse <transform
>))))
426 (defmacro with-parsed-prefixes
((node env
) &body body
)
427 `(invoke-with-parsed-prefixes (lambda () ,@body
) ,node
,env
))
429 (defun invoke-with-parsed-prefixes (fn node env
)
430 (unless (or (namep node
"stylesheet") (namep node
"transform"))
431 (setf node
(stp:parent node
)))
432 (let ((*excluded-namespaces
* (list *xsl
*))
433 (*extension-namespaces
* '()))
434 (parse-exclude-result-prefixes! node env
)
435 (parse-extension-element-prefixes! node env
)
438 (defun parse-1-stylesheet (env stylesheet designator uri-resolver
)
439 (let* ((<transform
> (parse-stylesheet-to-stp designator uri-resolver
))
440 (instruction-base-uri (stp:base-uri
<transform
>))
441 (namespaces (acons-namespaces <transform
>))
442 (apply-imports-limit (1+ *import-priority
*))
444 (let ((*namespaces
* namespaces
))
445 (invoke-with-parsed-prefixes (constantly t
) <transform
> env
))
446 (macrolet ((with-specials ((&optional
) &body body
)
447 `(let ((*instruction-base-uri
* instruction-base-uri
)
448 (*namespaces
* namespaces
)
449 (*apply-imports-limit
* apply-imports-limit
))
452 (do-toplevel (import "import" <transform
>)
453 (let ((uri (puri:merge-uris
(stp:attribute-value import
"href")
454 (stp:base-uri import
))))
455 (push (parse-imported-stylesheet env stylesheet uri uri-resolver
)
457 (let ((import-priority
458 (incf *import-priority
*))
459 (var-cont (prepare-global-variables stylesheet
<transform
>)))
460 ;; delay the rest of compilation until we've seen all global
463 (mapc #'funcall
(nreverse continuations
))
465 (let ((*import-priority
* import-priority
))
467 (parse-keys! stylesheet
<transform
> env
)
468 (parse-templates! stylesheet
<transform
> env
)
469 (parse-output! stylesheet
<transform
>)
470 (parse-strip/preserve-space
! stylesheet
<transform
> env
)
471 (parse-attribute-sets! stylesheet
<transform
> env
)
472 (parse-namespace-aliases! stylesheet
<transform
> env
)
473 (parse-decimal-formats! stylesheet
<transform
> env
))))))))
475 (defvar *xsl-import-stack
* nil
)
477 (defun parse-imported-stylesheet (env stylesheet uri uri-resolver
)
478 (let* ((uri (if uri-resolver
479 (funcall uri-resolver
(puri:render-uri uri nil
))
481 (str (puri:render-uri uri nil
))
484 (uri-to-pathname uri
)
485 (cxml:xml-parse-error
(c)
486 (xslt-error "cannot find imported stylesheet ~A: ~A"
490 :element-type
'(unsigned-byte 8)
491 :if-does-not-exist nil
)
493 (xslt-error "cannot find imported stylesheet ~A at ~A"
495 (when (find str
*xsl-import-stack
* :test
#'equal
)
496 (xslt-error "recursive inclusion of ~A" uri
))
497 (let ((*xsl-import-stack
* (cons str
*xsl-import-stack
*)))
498 (parse-1-stylesheet env stylesheet stream uri-resolver
)))))
500 (defun parse-stylesheet (designator &key uri-resolver
)
501 (xpath:with-namespaces
((nil #.
*xsl
*))
502 (let* ((*import-priority
* 0)
503 (puri:*strict-parse
* nil
)
504 (stylesheet (make-stylesheet))
505 (env (make-instance 'lexical-xslt-environment
))
506 (*excluded-namespaces
* *excluded-namespaces
*)
507 (*global-variable-declarations
* (make-empty-declaration-array)))
508 (ensure-mode stylesheet nil
)
509 (funcall (parse-1-stylesheet env stylesheet designator uri-resolver
))
510 ;; reverse attribute sets:
511 (let ((table (stylesheet-attribute-sets stylesheet
)))
512 (maphash (lambda (k v
)
513 (setf (gethash k table
) (nreverse v
)))
516 (unless (find-decimal-format "" "" stylesheet nil
)
517 (setf (find-decimal-format "" "" stylesheet
)
518 (make-decimal-format)))
521 (defun parse-attribute-sets! (stylesheet <transform
> env
)
522 (do-toplevel (elt "attribute-set" <transform
>)
523 (with-parsed-prefixes (elt env
)
525 (mapcar (lambda (qname)
526 (multiple-value-list (decode-qname qname env nil
)))
528 (stp:attribute-value elt
"use-attribute-sets"))))
533 (unless (or (not (typep child
'stp
:element
))
534 (and (equal (stp:namespace-uri child
) *xsl
*)
535 (equal (stp:local-name child
)
537 (find (stp:namespace-uri child
)
538 *extension-namespaces
*
540 (xslt-error "non-attribute found in attribute set"))
541 (parse-instruction child
))
543 (*lexical-variable-declarations
*
544 (make-empty-declaration-array))
546 (compile-instruction `(progn ,@instructions
) env
))
547 (n-variables (length *lexical-variable-declarations
*)))
550 (loop for
(local-name uri nil
) in sets do
551 (dolist (thunk (find-attribute-set local-name uri
))
552 (funcall thunk ctx
)))
553 (let ((*lexical-variable-values
*
554 (make-variable-value-array n-variables
)))
555 (funcall thunk ctx
)))))
556 (gethash (multiple-value-bind (local-name uri
)
557 (decode-qname (stp:attribute-value elt
"name") env nil
)
558 (cons local-name uri
))
559 (stylesheet-attribute-sets stylesheet
))))))
561 (defun parse-namespace-aliases! (stylesheet <transform
> env
)
562 (do-toplevel (elt "namespace-alias" <transform
>)
563 (stp:with-attributes
(stylesheet-prefix result-prefix
) elt
565 (xpath-sys:environment-find-namespace env stylesheet-prefix
)
566 (stylesheet-namespace-aliases stylesheet
))
567 (xpath-sys:environment-find-namespace
569 (if (equal result-prefix
"#default")
573 (defun parse-decimal-formats! (stylesheet <transform
> env
)
574 (do-toplevel (elt "decimal-format" <transform
>)
575 (stp:with-attributes
(name
589 (multiple-value-bind (local-name uri
)
591 (decode-qname name env nil
)
593 (unless (find-decimal-format local-name uri stylesheet nil
)
594 (setf (find-decimal-format local-name uri stylesheet
)
598 (unless (eql (length x
) 1)
599 (xslt-error "not a single character: ~A" x
))
600 (let ((chr (elt x
0)))
601 (when (find chr seen
)
603 "conflicting decimal format characters: ~A"
610 (apply #'make-decimal-format
611 (append (str :infinity infinity
)
613 (chr :decimal-separator decimal-separator
)
614 (chr :grouping-separator grouping-separator
)
615 (chr :zero-digit zero-digit
)
616 (chr :percent percent
)
617 (chr :per-mille per-mille
)
619 (chr :pattern-separator pattern-separator
)
620 (chr :minus-sign minus-sign
)))))))))))
622 (defun parse-exclude-result-prefixes! (node env
)
623 (stp:with-attributes
(exclude-result-prefixes)
625 (dolist (prefix (words (or exclude-result-prefixes
"")))
626 (if (equal prefix
"#default")
628 (unless (cxml-stp-impl::nc-name-p prefix
)
629 (xslt-error "invalid prefix: ~A" prefix
)))
630 (push (or (xpath-sys:environment-find-namespace env prefix
)
631 (xslt-error "namespace not found: ~A" prefix
))
632 *excluded-namespaces
*))))
634 (defun parse-extension-element-prefixes! (node env
)
635 (stp:with-attributes
(extension-element-prefixes)
637 (dolist (prefix (words (or extension-element-prefixes
"")))
638 (if (equal prefix
"#default")
640 (unless (cxml-stp-impl::nc-name-p prefix
)
641 (xslt-error "invalid prefix: ~A" prefix
)))
643 (or (xpath-sys:environment-find-namespace env prefix
)
644 (xslt-error "namespace not found: ~A" prefix
))))
645 (unless (equal uri
*xsl
*)
646 (push uri
*extension-namespaces
*)
647 (push uri
*excluded-namespaces
*))))))
649 (defun parse-strip/preserve-space
! (stylesheet <transform
> env
)
650 (xpath:with-namespaces
((nil #.
*xsl
*))
651 (do-toplevel (elt "strip-space|preserve-space" <transform
>)
652 (let ((*namespaces
* (acons-namespaces elt
))
654 (if (equal (stp:local-name elt
) "strip-space")
657 (dolist (name-test (words (stp:attribute-value elt
"elements")))
658 (let* ((pos (search ":*" name-test
))
661 ((eql pos
(- (length name-test
) 2))
662 (let* ((prefix (subseq name-test
0 pos
))
664 (xpath-sys:environment-find-namespace env prefix
)))
665 (unless (xpath::nc-name-p prefix
)
666 (xslt-error "not an NCName: ~A" prefix
))
667 (lambda (local-name uri
)
668 (declare (ignore local-name
))
669 (if (equal uri name-test-uri
)
672 ((equal name-test
"*")
673 (lambda (local-name uri
)
674 (declare (ignore local-name uri
))
677 (multiple-value-bind (name-test-local-name name-test-uri
)
678 (decode-qname name-test env nil
)
679 (lambda (local-name uri
)
680 (if (and (equal local-name name-test-local-name
)
681 (equal uri name-test-uri
))
684 (push test-function
(stylesheet-strip-tests stylesheet
))))))))
686 (defstruct (output-specification
687 (:conc-name
"OUTPUT-"))
693 (defun parse-output! (stylesheet <transform
>)
694 (let ((outputs (list-toplevel "output" <transform
>)))
698 ;; - concatenate cdata-section-elements
699 ;; - the others must not conflict
700 (error "oops, merging of output elements not supported yet"))
701 (let ((<output
> (car outputs
))
702 (spec (stylesheet-output-specification stylesheet
)))
703 (stp:with-attributes
(;; version
712 ;;; cdata-section-elements
715 (setf (output-method spec
) method
)
716 (setf (output-indent spec
) indent
)
717 (setf (output-encoding spec
) encoding
)
718 (setf (output-omit-xml-declaration spec
) omit-xml-declaration
))))))
720 (defun make-empty-declaration-array ()
721 (make-array 1 :fill-pointer
0 :adjustable t
))
723 (defun make-variable-value-array (n-lexical-variables)
724 (make-array n-lexical-variables
:initial-element
'unbound
))
726 (defun compile-global-variable (<variable
> env
) ;; also for <param>
727 (stp:with-attributes
(name select
) <variable
>
728 (when (and select
(stp:list-children
<variable
>))
729 (xslt-error "variable with select and body"))
730 (let* ((*lexical-variable-declarations
* (make-empty-declaration-array))
733 (compile-xpath select env
))
734 ((stp:list-children
<variable
>)
735 (let* ((inner-sexpr `(progn ,@(parse-body <variable
>)))
736 (inner-thunk (compile-instruction inner-sexpr env
)))
738 (apply-to-result-tree-fragment ctx inner-thunk
))))
741 (declare (ignore ctx
))
743 (n-lexical-variables (length *lexical-variable-declarations
*)))
746 (let* ((*lexical-variable-values
*
747 (make-variable-value-array n-lexical-variables
)))
748 (funcall inner ctx
)))
749 "global ~s (~s) = ~s" name select
:result
))))
751 (defstruct (variable-information
752 (:constructor make-variable
)
753 (:conc-name
"VARIABLE-"))
761 (defun parse-global-variable! (<variable
> global-env
) ;; also for <param>
762 (let* ((*namespaces
* (acons-namespaces <variable
>))
763 (instruction-base-uri (stp:base-uri
<variable
>))
764 (*instruction-base-uri
* instruction-base-uri
)
765 (*excluded-namespaces
* (list *xsl
*))
766 (*extension-namespaces
* '())
767 (qname (stp:attribute-value
<variable
> "name")))
768 (with-parsed-prefixes (<variable
> global-env
)
770 (xslt-error "name missing in ~A" (stp:local-name
<variable
>)))
771 (multiple-value-bind (local-name uri
)
772 (decode-qname qname global-env nil
)
773 ;; For the normal compilation environment of templates, install it
774 ;; into *GLOBAL-VARIABLE-DECLARATIONS*:
775 (let ((index (intern-global-variable local-name uri
)))
776 ;; For the evaluation of a global variable itself, build a thunk
777 ;; that lazily resolves other variables, stored into
778 ;; INITIAL-GLOBAL-VARIABLE-THUNKS:
779 (let* ((value-thunk :unknown
)
780 (global-variable-thunk
782 (let ((v (global-variable-value index nil
)))
784 (xslt-error "recursive variable definition"))
787 (setf (global-variable-value index
) 'seen
)
788 (setf (global-variable-value index
)
789 (funcall value-thunk ctx
)))
792 (excluded-namespaces *excluded-namespaces
*)
793 (extension-namespaces *extension-namespaces
*)
796 (let ((*instruction-base-uri
* instruction-base-uri
)
797 (*excluded-namespaces
* excluded-namespaces
)
798 (*extension-namespaces
* extension-namespaces
))
800 (compile-global-variable <variable
> global-env
))))))
801 (setf (gethash (cons local-name uri
)
802 (initial-global-variable-thunks global-env
))
803 global-variable-thunk
)
804 (make-variable :index index
805 :local-name local-name
807 :thunk global-variable-thunk
808 :param-p
(namep <variable
> "param")
809 :thunk-setter thunk-setter
)))))))
811 (defun parse-keys! (stylesheet <transform
> env
)
812 (xpath:with-namespaces
((nil #.
*xsl
*))
813 (do-toplevel (<key
> "key" <transform
>)
814 (let ((*instruction-base-uri
* (stp:base-uri
<key
>)))
815 (stp:with-attributes
(name match use
) <key
>
816 (unless name
(xslt-error "key name attribute not specified"))
817 (unless match
(xslt-error "key match attribute not specified"))
818 (unless use
(xslt-error "key use attribute not specified"))
819 (multiple-value-bind (local-name uri
)
820 (decode-qname name env nil
)
822 (cons local-name uri
)
823 (compile-xpath `(xpath:xpath
,(parse-key-pattern match
)) env
)
824 (compile-xpath use env
))))))))
826 (defun prepare-global-variables (stylesheet <transform
>)
827 (xpath:with-namespaces
((nil #.
*xsl
*))
828 (let* ((table (make-hash-table :test
'equal
))
829 (global-env (make-instance 'global-variable-environment
830 :initial-global-variable-thunks table
))
832 (do-toplevel (<variable
> "variable|param" <transform
>)
833 (let ((var (parse-global-variable! <variable
> global-env
)))
834 (xslt-trace "parsing global variable ~s (uri ~s)"
835 (variable-local-name var
)
840 (and (equal (variable-local-name a
)
841 (variable-local-name b
))
842 (equal (variable-uri a
)
844 (xslt-error "duplicate definition for global variable ~A"
845 (variable-local-name var
)))
847 (setf specs
(nreverse specs
))
849 ;; now that the global environment knows about all variables, run the
850 ;; thunk setters to perform their compilation
851 (mapc (lambda (spec) (funcall (variable-thunk-setter spec
))) specs
)
852 (let ((table (stylesheet-global-variables stylesheet
))
853 (newlen (length *global-variable-declarations
*)))
854 (adjust-array table newlen
:fill-pointer newlen
)
856 (setf (elt table
(variable-index spec
)) spec
)))))))
858 (defun parse-templates! (stylesheet <transform
> env
)
860 (do-toplevel (<template
> "template" <transform
>)
861 (let ((*namespaces
* (acons-namespaces <template
>))
862 (*instruction-base-uri
* (stp:base-uri
<template
>)))
863 (with-parsed-prefixes (<template
> env
)
864 (dolist (template (compile-template <template
> env i
))
865 (let ((name (template-name template
)))
867 (let* ((table (stylesheet-named-templates stylesheet
))
868 (head (car (gethash name table
))))
869 (when (and head
(eql (template-import-priority head
)
870 (template-import-priority template
)))
871 ;; fixme: is this supposed to be a run-time error?
872 (xslt-error "conflicting templates for ~A" name
))
873 (push template
(gethash name table
)))
874 (let ((mode (ensure-mode/qname stylesheet
875 (template-mode-qname template
)
877 (setf (template-mode template
) mode
)
878 (push template
(mode-templates mode
))))))))
882 ;;;; APPLY-STYLESHEET
884 (defvar *stylesheet
*)
886 (deftype xml-designator
() '(or runes
:xstream runes
:rod array stream pathname
))
888 (defun unalias-uri (uri)
890 (gethash uri
(stylesheet-namespace-aliases *stylesheet
*)
892 (check-type result string
)
895 (defstruct (parameter
896 (:constructor make-parameter
(value local-name
&optional uri
)))
901 (defun find-parameter-value (local-name uri parameters
)
902 (dolist (p parameters
)
903 (when (and (equal (parameter-local-name p
) local-name
)
904 (equal (parameter-uri p
) uri
))
905 (return (parameter-value p
)))))
907 (defvar *uri-resolver
*)
909 (defun parse-allowing-microsoft-bom (pathname handler
)
910 (with-open-file (s pathname
:element-type
'(unsigned-byte 8))
911 (unless (and (eql (read-byte s nil
) #xef
)
912 (eql (read-byte s nil
) #xbb
)
913 (eql (read-byte s nil
) #xbf
))
915 (cxml:parse s handler
)))
919 (defun %document
(uri-string base-uri
)
921 (puri:merge-uris uri-string
(or base-uri
"")))
924 (funcall *uri-resolver
* (puri:render-uri absolute-uri nil
))
928 (uri-to-pathname resolved-uri
)
929 (cxml:xml-parse-error
(c)
930 (xslt-error "cannot find referenced document ~A: ~A"
933 (or (gethash pathname
*documents
*)
934 (setf (gethash pathname
*documents
*)
935 (make-whitespace-stripper
937 (parse-allowing-microsoft-bom pathname
939 ((or file-error cxml
:xml-parse-error
) (c)
940 (xslt-error "cannot parse referenced document ~A: ~A"
942 (stylesheet-strip-tests *stylesheet
*))))))
943 (when (puri:uri-fragment absolute-uri
)
944 (xslt-error "use of fragment identifiers in document() not supported"))
947 (xpath-sys:define-extension xslt
*xsl
*)
949 (defun document-base-uri (node)
950 (xpath-protocol:base-uri
952 ((xpath-protocol:node-type-p node
:document
)
953 (xpath::find-in-pipe-if
955 (xpath-protocol:node-type-p x
:element
))
956 (xpath-protocol:child-pipe node
)))
957 ((xpath-protocol:node-type-p node
:element
)
960 (xpath-protocol:parent-node node
)))))
962 (xpath-sys:define-xpath-function
/lazy
964 (object &optional node-set
)
965 (let ((instruction-base-uri *instruction-base-uri
*))
967 (let* ((object (funcall object ctx
))
968 (node-set (and node-set
(funcall node-set ctx
)))
971 (document-base-uri (xpath::textually-first-node node-set
))
972 instruction-base-uri
)))
973 (xpath-sys:make-node-set
974 (if (xpath:node-set-p object
)
975 (xpath:map-node-set-
>list
977 (%document
(xpath:string-value node
)
980 (document-base-uri node
))))
982 (list (%document
(xpath:string-value object
) base-uri
))))))))
984 (xpath-sys:define-xpath-function
/lazy xslt
:key
(name object
)
985 (let ((namespaces *namespaces
*))
987 (let* ((qname (xpath:string-value
(funcall name ctx
)))
988 (object (funcall object ctx
))
990 (multiple-value-bind (local-name uri
)
991 (decode-qname/runtime qname namespaces nil
)
992 (cons local-name uri
)))
993 (key (find-key expanded-name
*stylesheet
*)))
994 (labels ((get-by-key (value)
995 (let ((value (xpath:string-value value
)))
999 (xpath:evaluate-compiled
(key-use key
) node
)))
1000 (if (xpath:node-set-p uses
)
1001 (xpath::find-in-pipe
1003 (xpath-sys:pipe-of uses
)
1004 :key
#'xpath
:string-value
1006 (equal value
(xpath:string-value uses
)))))
1008 (xpath:node-set-value
1009 (xpath:evaluate-compiled
(key-match key
) ctx
)))))))
1010 (xpath-sys:make-node-set
1012 (if (xpath:node-set-p object
)
1013 (xpath::mappend-pipe
#'get-by-key
(xpath-sys:pipe-of object
))
1014 (get-by-key object
)))))))))
1016 ;; FIXME: add alias mechanism for XPath extensions in order to avoid duplication
1018 (xpath-sys:define-xpath-function
/lazy xslt
:current
()
1020 (xpath-sys:make-node-set
1021 (xpath-sys:make-pipe
1022 (xpath:context-starting-node ctx
)
1025 (xpath-sys:define-xpath-function
/lazy xslt
:unparsed-entity-uri
(name)
1027 (or (xpath-protocol:unparsed-entity-uri
(xpath:context-node ctx
)
1031 (defun %get-node-id
(node)
1032 (when (xpath:node-set-p node
)
1033 (setf node
(xpath::textually-first-node node
)))
1035 (let ((id (xpath-sys:get-node-id node
))
1038 for parent
= node then next
1039 for next
= (xpath-protocol:parent-node parent
)
1040 for this-base-uri
= (xpath-protocol:base-uri parent
)
1041 for highest-base-uri
= (if (plusp (length this-base-uri
))
1045 finally
(return highest-base-uri
))))
1046 ;; Heuristic: Reverse it so that the /home/david/alwaysthesame prefix is
1047 ;; checked only if everything else matches.
1049 ;; This might be pointless premature optimization, but I like the idea :-)
1050 (nreverse (concatenate 'string highest-base-uri
"//" id
)))))
1052 (xpath-sys:define-xpath-function
/lazy xslt
:generate-id
(&optional node-set-thunk
)
1055 (%get-node-id
(xpath:node-set-value
(funcall node-set-thunk ctx
))))
1057 (%get-node-id
(xpath:context-node ctx
)))))
1059 (declaim (special *available-instructions
*))
1061 (xpath-sys:define-xpath-function
/lazy xslt
:element-available
(qname)
1062 (let ((namespaces *namespaces
*))
1064 (let ((qname (funcall qname ctx
)))
1065 (multiple-value-bind (local-name uri
)
1066 (decode-qname/runtime qname namespaces nil
)
1067 (and (equal uri
*xsl
*)
1068 (gethash local-name
*available-instructions
*)
1071 (xpath-sys:define-xpath-function
/lazy xslt
:function-available
(qname)
1072 (let ((namespaces *namespaces
*))
1074 (let ((qname (funcall qname ctx
)))
1075 (multiple-value-bind (local-name uri
)
1076 (decode-qname/runtime qname namespaces nil
)
1077 (and (zerop (length uri
))
1078 (or (xpath-sys:find-xpath-function local-name
*xsl
*)
1079 (xpath-sys:find-xpath-function local-name uri
))
1082 (defun apply-stylesheet
1083 (stylesheet source-designator
1084 &key output parameters uri-resolver navigator
)
1085 (when (typep stylesheet
'xml-designator
)
1086 (setf stylesheet
(parse-stylesheet stylesheet
)))
1087 (invoke-with-output-sink
1090 (let* ((*documents
* (make-hash-table :test
'equal
))
1091 (xpath:*navigator
* (or navigator
:default-navigator
))
1092 (puri:*strict-parse
* nil
)
1093 (*stylesheet
* stylesheet
)
1094 (*empty-mode
* (make-mode))
1095 (*default-mode
* (find-mode stylesheet nil
))
1096 (global-variable-specs
1097 (stylesheet-global-variables stylesheet
))
1098 (*global-variable-values
*
1099 (make-variable-value-array (length global-variable-specs
)))
1100 (*uri-resolver
* uri-resolver
)
1102 (if (typep source-designator
'xml-designator
)
1103 (cxml:parse source-designator
(stp:make-builder
))
1106 (make-whitespace-stripper
1108 (stylesheet-strip-tests stylesheet
)))
1109 (ctx (xpath:make-context xpath-root-node
)))
1110 (when (pathnamep source-designator
)
1111 (setf (gethash source-designator
*documents
*) xpath-root-node
))
1114 (when (variable-param-p spec
)
1116 (find-parameter-value (variable-local-name spec
)
1120 (setf (global-variable-value (variable-index spec
))
1122 global-variable-specs
)
1125 (funcall (variable-thunk spec
) ctx
))
1126 global-variable-specs
)
1127 ;; zzz we wouldn't have to mask float traps here if we used the
1128 ;; XPath API properly. Unfortunately I've been using FUNCALL
1129 ;; everywhere instead of EVALUATE, so let's paper over that
1130 ;; at a central place to be sure:
1131 (xpath::with-float-traps-masked
()
1132 (apply-templates ctx
:mode
*default-mode
*)))
1133 (xpath:xpath-error
(c)
1134 (xslt-error "~A" c
))))
1135 (stylesheet-output-specification stylesheet
)
1138 (defun find-attribute-set (local-name uri
)
1139 (or (gethash (cons local-name uri
) (stylesheet-attribute-sets *stylesheet
*))
1140 (xslt-error "no such attribute set: ~A/~A" local-name uri
)))
1142 (defun apply-templates/list
(list &key param-bindings sort-predicate mode
)
1143 (when sort-predicate
1144 (setf list
(sort list sort-predicate
)))
1145 (let* ((n (length list
))
1146 (s/d
(lambda () n
)))
1151 (apply-templates (xpath:make-context child s
/d i
)
1152 :param-bindings param-bindings
1155 (defvar *stack-limit
* 200)
1157 (defun invoke-with-stack-limit (fn)
1158 (let ((*stack-limit
* (1- *stack-limit
*)))
1159 (unless (plusp *stack-limit
*)
1160 (xslt-error "*stack-limit* reached; stack overflow"))
1163 (defun invoke-template (ctx template param-bindings
)
1164 (let ((*lexical-variable-values
*
1165 (make-variable-value-array (template-n-variables template
))))
1166 (with-stack-limit ()
1168 for
(name-cons value
) in param-bindings
1169 for
(nil index nil
) = (find name-cons
1170 (template-params template
)
1175 (setf (lexical-variable-value index
) value
)))
1176 (funcall (template-body template
) ctx
))))
1178 (defun apply-default-templates (ctx mode
)
1179 (let ((node (xpath:context-node ctx
)))
1181 ((or (xpath-protocol:node-type-p node
:processing-instruction
)
1182 (xpath-protocol:node-type-p node
:comment
)))
1183 ((or (xpath-protocol:node-type-p node
:text
)
1184 (xpath-protocol:node-type-p node
:attribute
))
1185 (write-text (xpath-protocol:node-text node
)))
1187 (apply-templates/list
1189 (xpath-protocol:child-pipe node
))
1192 (defvar *apply-imports
*)
1194 (defun apply-applicable-templates (ctx templates param-bindings finally
)
1195 (labels ((apply-imports (&optional actual-param-bindings
)
1197 (let* ((this (pop templates
))
1198 (low (template-apply-imports-limit this
))
1199 (high (template-import-priority this
)))
1203 (<= low
(template-import-priority x
) high
))
1205 (invoke-template ctx this actual-param-bindings
))
1206 (funcall finally
))))
1207 (let ((*apply-imports
* #'apply-imports
))
1208 (apply-imports param-bindings
))))
1210 (defun apply-templates (ctx &key param-bindings mode
)
1211 (apply-applicable-templates ctx
1212 (find-templates ctx
(or mode
*default-mode
*))
1215 (apply-default-templates ctx mode
))))
1217 (defun call-template (ctx name
&optional param-bindings
)
1218 (apply-applicable-templates ctx
1219 (find-named-templates name
)
1222 (error "cannot find named template: ~s"
1225 (defun find-templates (ctx mode
)
1226 (let* ((matching-candidates
1227 (remove-if-not (lambda (template)
1228 (template-matches-p template ctx
))
1229 (mode-templates mode
)))
1231 (if matching-candidates
1234 :key
#'template-import-priority
))
1236 (priority-groups (make-array npriorities
:initial-element nil
)))
1237 (dolist (template matching-candidates
)
1239 (elt priority-groups
(template-import-priority template
))))
1241 for i from
(1- npriorities
) downto
0
1242 for group
= (elt priority-groups i
)
1243 for template
= (maximize #'template
< group
)
1247 (defun find-named-templates (name)
1248 (gethash name
(stylesheet-named-templates *stylesheet
*)))
1250 (defun template< (a b
) ;assuming same import priority
1251 (let ((p (template-priority a
))
1252 (q (template-priority b
)))
1257 (xslt-cerror "conflicting templates:~_~A,~_~A"
1258 (template-match-expression a
)
1259 (template-match-expression b
))
1260 (< (template-position a
) (template-position b
))))))
1262 (defun maximize (< things
)
1264 (let ((max (car things
)))
1265 (dolist (other (cdr things
))
1266 (when (funcall < max other
)
1270 (defun template-matches-p (template ctx
)
1271 (find (xpath:context-node ctx
)
1272 (xpath:all-nodes
(funcall (template-match-thunk template
) ctx
))))
1274 (defun invoke-with-output-sink (fn output-spec output
)
1277 (with-open-file (s output
1279 :element-type
'(unsigned-byte 8)
1280 :if-exists
:rename-and-delete
)
1281 (invoke-with-output-sink fn output-spec s
)))
1283 (invoke-with-output-sink fn
1285 (make-output-sink output-spec output
)))
1286 ((or hax
:abstract-handler sax
:abstract-handler
)
1287 (with-xml-output output
1290 (defun make-output-sink (output-spec stream
)
1293 (let ((et (stream-element-type stream
)))
1295 ((or (null et
) (subtypep et
'(unsigned-byte 8)))
1296 (runes:make-octet-stream-ystream stream
))
1297 ((subtypep et
'character
)
1298 (runes:make-character-stream-ystream stream
))))
1299 (runes:make-rod-ystream
)))
1300 (omit-xml-declaration-p
1301 (equal (output-omit-xml-declaration output-spec
) "yes"))
1303 (make-instance 'cxml
::sink
1305 :omit-xml-declaration-p omit-xml-declaration-p
)))
1306 (flet ((make-combi-sink ()
1307 (make-instance 'combi-sink
1308 :hax-target
(make-instance 'chtml
::sink
1310 :sax-target sax-target
1311 :encoding
(output-encoding output-spec
))))
1313 ((equalp (output-method output-spec
) "HTML")
1315 ((equalp (output-method output-spec
) "TEXT")
1316 (make-text-filter sax-target
))
1317 ((equalp (output-method output-spec
) "XML")
1320 (make-auto-detect-sink (make-combi-sink)))))))
1336 (defun expression-priority (form)
1337 (let ((step (second form
)))
1338 (if (and (null (cddr form
))
1340 (member (car step
) '(:child
:attribute
))
1342 (let ((name (second step
)))
1346 (or (eq (car name
) :qname
)
1347 (eq (car name
) :processing-instruction
))))
1350 (or (eq (car name
) :namespace
)
1351 (eq (car name
) '*)))
1357 (defun valid-expression-p (expr)
1360 ((eq (first expr
) :path
)
1362 (let ((filter (third x
)))
1363 (or (null filter
) (valid-expression-p filter
))))
1365 ((eq (first expr
) :variable
) ;(!)
1368 (every #'valid-expression-p
(cdr expr
)))))
1370 (defun parse-xpath (str)
1372 (xpath:parse-xpath str
)
1373 (xpath:xpath-error
(c)
1374 (xslt-error "~A" c
))))
1376 ;; zzz also use naive-pattern-expression here?
1377 (defun parse-key-pattern (str)
1379 (mapcar #'(lambda (item)
1380 `(:path
(:root
:node
)
1381 (:descendant-or-self
*)
1383 (parse-pattern str
))))
1384 (if (null (rest parsed
))
1386 `(:union
,@parsed
))))
1388 (defun parse-pattern (str)
1389 ;; zzz check here for anything not allowed as an XSLT pattern
1390 ;; zzz can we hack id() and key() here?
1391 (let ((form (parse-xpath str
)))
1392 (unless (consp form
)
1393 (xslt-error "not a valid pattern: ~A" str
))
1394 (labels ((process-form (form)
1395 (cond ((eq (car form
) :union
)
1396 (alexandria:mappend
#'process-form
(rest form
)))
1397 ((not (or (eq (car form
) :path
)
1398 (and (eq (car form
) :filter
)
1399 (let ((filter (second form
)))
1401 (member (car filter
)
1403 (equal (third form
) '(:true
)))
1404 (member (car form
) '(:key
:id
))))
1405 (xslt-error "not a valid pattern: ~A ~A" str form
))
1406 ((not (valid-expression-p form
))
1407 (xslt-error "invalid filter"))
1409 (process-form form
))))
1411 (defun naive-pattern-expression (x)
1413 (:path
`(:path
(:ancestor-or-self
:node
) ,@(cdr x
)))
1414 ((:filter
:key
:id
) x
)))
1416 (defun compile-value-thunk (value env
)
1417 (if (and (listp value
) (eq (car value
) 'progn
))
1418 (let ((inner-thunk (compile-instruction value env
)))
1420 (apply-to-result-tree-fragment ctx inner-thunk
)))
1421 (compile-xpath value env
)))
1423 (defun compile-var-bindings/nointern
(forms env
)
1425 for
(name value
) in forms
1426 collect
(multiple-value-bind (local-name uri
)
1427 (decode-qname name env nil
)
1428 (list (cons local-name uri
)
1430 (compile-value-thunk value env
)
1431 "local variable ~s = ~s" name
:result
)))))
1433 (defun compile-var-bindings (forms env
)
1435 for
(cons thunk
) in
(compile-var-bindings/nointern forms env
)
1436 for
(local-name . uri
) = cons
1438 (push-variable local-name
1440 *lexical-variable-declarations
*)
1443 (defun compile-template (<template
> env position
)
1444 (stp:with-attributes
(match name priority mode
) <template
>
1445 (unless (or name match
)
1446 (xslt-error "missing match in template"))
1447 (multiple-value-bind (params body-pos
)
1450 for child in
(stp:list-children
<template
>)
1451 while
(namep child
"param")
1452 collect
(parse-param child
) into params
1453 finally
(return (values params i
)))
1454 (let* ((*lexical-variable-declarations
* (make-empty-declaration-array))
1455 (param-bindings (compile-var-bindings params env
))
1456 (body (parse-body <template
> body-pos
(mapcar #'car params
)))
1457 (body-thunk (compile-instruction `(progn ,@body
) env
))
1463 ;; set params that weren't initialized by apply-templates
1464 (loop for
(name index param-thunk
) in param-bindings
1465 when
(eq (lexical-variable-value index nil
) 'unbound
)
1466 do
(setf (lexical-variable-value index
)
1467 (funcall param-thunk ctx
)))
1468 (funcall body-thunk ctx
))))
1469 "template: match = ~s name = ~s" match name
))
1470 (n-variables (length *lexical-variable-declarations
*)))
1473 (multiple-value-bind (local-name uri
)
1474 (decode-qname name env nil
)
1476 (make-template :name
(cons local-name uri
)
1477 :import-priority
*import-priority
*
1478 :apply-imports-limit
*apply-imports-limit
*
1479 :params param-bindings
1480 :body outer-body-thunk
1481 :n-variables n-variables
))))
1483 (mapcar (lambda (expression)
1488 ,(naive-pattern-expression expression
))
1490 "match-thunk for template (match ~s): ~s --> ~s"
1491 match expression
:result
))
1493 (parse-number:parse-number priority
)
1494 (expression-priority expression
))))
1495 (make-template :match-expression expression
1496 :match-thunk match-thunk
1497 :import-priority
*import-priority
*
1498 :apply-imports-limit
*apply-imports-limit
*
1502 :params param-bindings
1503 :body outer-body-thunk
1504 :n-variables n-variables
)))
1505 (parse-pattern match
))))))))
1507 (xuriella::parse-stylesheet
#p
"/home/david/src/lisp/xuriella/test.xsl")