Updated TEST for current Plexippus
[xuriella.git] / xslt.lisp
blob52f778948d8676b3a058b85c86d36135db0e45b4
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 (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"))
42 ;;;; XSLT-ERROR
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
58 :format-control fmt
59 :format-arguments args)))
61 (defvar *debug* nil)
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
67 ;; important.)
68 (let ((doit (gensym)))
69 `(flet ((,doit () ,form))
70 (if *debug*
71 (,doit)
72 (handler-case
73 (,doit)
74 ,@clauses)))))
76 (defun compile-xpath (xpath &optional env)
77 (handler-case*
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)
92 `(block nil
93 (map-pipe-eagerly #'(lambda (,var) ,@body) ,pipe)
94 ,result))
97 ;;;; XSLT-ENVIRONMENT and XSLT-CONTEXT
99 (defparameter *namespaces* *initial-namespaces*)
101 (defvar *global-variable-declarations*)
102 (defvar *lexical-variable-declarations*)
104 (defvar *global-variable-values*)
105 (defvar *lexical-variable-values*)
107 (defclass xslt-environment () ())
109 (defun split-qname (str)
110 (handler-case
111 (multiple-value-bind (prefix local-name)
112 (cxml::split-qname str)
113 (unless
114 ;; FIXME: cxml should really offer a function that does
115 ;; checks for NCName and QName in a sensible way for user code.
116 ;; cxml::split-qname is tailored to the needs of the parser.
118 ;; For now, let's just check the syntax explicitly.
119 (and (or (null prefix) (xpath::nc-name-p prefix))
120 (xpath::nc-name-p local-name))
121 (xslt-error "not a qname: ~A" str))
122 (values prefix local-name))
123 (cxml:well-formedness-violation ()
124 (xslt-error "not a qname: ~A" str))))
126 (defun decode-qname (qname env attributep)
127 (multiple-value-bind (prefix local-name)
128 (split-qname qname)
129 (values local-name
130 (if (or prefix (not attributep))
131 (xpath-sys:environment-find-namespace env prefix)
133 prefix)))
135 (defmethod xpath-sys:environment-find-namespace ((env xslt-environment) prefix)
136 (cdr (assoc prefix *namespaces* :test 'equal)))
138 (defun find-variable-index (local-name uri table)
139 (position (cons local-name uri) table :test 'equal))
141 (defun intern-global-variable (local-name uri)
142 (or (find-variable-index local-name uri *global-variable-declarations*)
143 (push-variable local-name uri *global-variable-declarations*)))
145 (defun push-variable (local-name uri table)
146 (prog1
147 (length table)
148 (vector-push-extend (cons local-name uri) table)))
150 (defun lexical-variable-value (index &optional (errorp t))
151 (let ((result (svref *lexical-variable-values* index)))
152 (when errorp
153 (assert (not (eq result 'unbound))))
154 result))
156 (defun (setf lexical-variable-value) (newval index)
157 (assert (not (eq newval 'unbound)))
158 (setf (svref *lexical-variable-values* index) newval))
160 (defun global-variable-value (index &optional (errorp t))
161 (let ((result (svref *global-variable-values* index)))
162 (when errorp
163 (assert (not (eq result 'unbound))))
164 result))
166 (defun (setf global-variable-value) (newval index)
167 (assert (not (eq newval 'unbound)))
168 (setf (svref *global-variable-values* index) newval))
170 (defmethod xpath-sys:environment-find-function
171 ((env xslt-environment) lname uri)
172 (if (string= uri "")
173 (or (xpath-sys:find-xpath-function lname *xsl*)
174 (xpath-sys:find-xpath-function lname uri))
175 (xpath-sys:find-xpath-function lname uri)))
177 (defmethod xpath-sys:environment-find-variable
178 ((env xslt-environment) lname uri)
179 (let ((index
180 (find-variable-index lname uri *lexical-variable-declarations*)))
181 (when index
182 (lambda (ctx)
183 (declare (ignore ctx))
184 (svref *lexical-variable-values* index)))))
186 (defclass lexical-xslt-environment (xslt-environment) ())
188 (defmethod xpath-sys:environment-find-variable
189 ((env lexical-xslt-environment) lname uri)
190 (or (call-next-method)
191 (let ((index
192 (find-variable-index lname uri *global-variable-declarations*)))
193 (when index
194 (xslt-trace-thunk
195 (lambda (ctx)
196 (declare (ignore ctx))
197 (svref *global-variable-values* index))
198 "global ~s (uri ~s) = ~s" lname uri :result)))))
200 (defclass global-variable-environment (xslt-environment)
201 ((initial-global-variable-thunks
202 :initarg :initial-global-variable-thunks
203 :accessor initial-global-variable-thunks)))
205 (defmethod xpath-sys:environment-find-variable
206 ((env global-variable-environment) lname uri)
207 (or (call-next-method)
208 (gethash (cons lname uri) (initial-global-variable-thunks env))))
211 ;;;; TOPLEVEL-TEXT-OUTPUT-SINK
212 ;;;;
213 ;;;; A sink that serializes only text not contained in any element.
215 (defmacro with-toplevel-text-output-sink ((var) &body body)
216 `(invoke-with-toplevel-text-output-sink (lambda (,var) ,@body)))
218 (defclass toplevel-text-output-sink (sax:default-handler)
219 ((target :initarg :target :accessor text-output-sink-target)
220 (depth :initform 0 :accessor textoutput-sink-depth)))
222 (defmethod sax:start-element ((sink toplevel-text-output-sink)
223 namespace-uri local-name qname attributes)
224 (declare (ignore namespace-uri local-name qname attributes))
225 (incf (textoutput-sink-depth sink)))
227 (defmethod sax:characters ((sink toplevel-text-output-sink) data)
228 (when (zerop (textoutput-sink-depth sink))
229 (write-string data (text-output-sink-target sink))))
231 (defmethod sax:end-element ((sink toplevel-text-output-sink)
232 namespace-uri local-name qname)
233 (declare (ignore namespace-uri local-name qname))
234 (decf (textoutput-sink-depth sink)))
236 (defun invoke-with-toplevel-text-output-sink (fn)
237 (with-output-to-string (s)
238 (funcall fn (make-instance 'toplevel-text-output-sink :target s))))
241 ;;;; TEXT-FILTER
242 ;;;;
243 ;;;; A sink that passes through only text (at any level).
245 (defclass text-filter (sax:default-handler)
246 ((target :initarg :target :accessor text-filter-target)))
248 (defmethod sax:characters ((sink text-filter) data)
249 (sax:characters (text-filter-target sink) data))
251 (defmethod sax:end-document ((sink text-filter))
252 (sax:end-document (text-filter-target sink)))
254 (defun make-text-filter (target)
255 (make-instance 'text-filter :target target))
258 ;;;; Names
260 (defun of-name (local-name)
261 (stp:of-name local-name *xsl*))
263 (defun namep (node local-name)
264 (and (typep node '(or stp:element stp:attribute))
265 (equal (stp:namespace-uri node) *xsl*)
266 (equal (stp:local-name node) local-name)))
269 ;;;; PARSE-STYLESHEET
271 (defstruct stylesheet
272 (modes (make-hash-table :test 'equal))
273 (global-variables (make-empty-declaration-array))
274 (output-specification (make-output-specification))
275 (strip-tests nil)
276 (named-templates (make-hash-table :test 'equal))
277 (attribute-sets (make-hash-table :test 'equal))
278 (keys (make-hash-table :test 'equal))
279 (namespace-aliases (make-hash-table :test 'equal)))
281 (defstruct mode (templates nil))
283 (defun find-mode (stylesheet local-name &optional uri)
284 (gethash (cons local-name uri) (stylesheet-modes stylesheet)))
286 (defun ensure-mode (stylesheet &optional local-name uri)
287 (or (find-mode stylesheet local-name uri)
288 (setf (gethash (cons local-name uri) (stylesheet-modes stylesheet))
289 (make-mode))))
291 (defun ensure-mode/qname (stylesheet qname env)
292 (if qname
293 (multiple-value-bind (local-name uri)
294 (decode-qname qname env nil)
295 (ensure-mode stylesheet local-name uri))
296 (find-mode stylesheet nil)))
298 (defun acons-namespaces (element &optional (bindings *namespaces*))
299 (map-namespace-declarations (lambda (prefix uri)
300 (push (cons prefix uri) bindings))
301 element)
302 bindings)
304 (defun find-key (name stylesheet)
305 (or (gethash name (stylesheet-keys stylesheet))
306 (xslt-error "unknown key: ~a" name)))
308 (defun make-key (match use) (cons match use))
310 (defun key-match (key) (car key))
312 (defun key-use (key) (cdr key))
314 (defun add-key (stylesheet name match use)
315 (if (gethash name (stylesheet-keys stylesheet))
316 (xslt-error "duplicate key: ~a" name)
317 (setf (gethash name (stylesheet-keys stylesheet))
318 (make-key match use))))
320 (defvar *excluded-namespaces* (list *xsl*))
321 (defvar *empty-mode*)
323 (defvar *xsl-include-stack* nil)
325 (defun uri-to-pathname (uri)
326 (cxml::uri-to-pathname (puri:parse-uri uri)))
328 (defun parse-stylesheet-to-stp (input uri-resolver)
329 (let* ((d (cxml:parse input (make-text-normalizer (cxml-stp:make-builder))))
330 (<transform> (stp:document-element d)))
331 (strip-stylesheet <transform>)
332 ;; FIXME: handle embedded stylesheets
333 (unless (and (equal (stp:namespace-uri <transform>) *xsl*)
334 (or (equal (stp:local-name <transform>) "transform")
335 (equal (stp:local-name <transform>) "stylesheet")))
336 (xslt-error "not a stylesheet"))
337 (dolist (include (stp:filter-children (of-name "include") <transform>))
338 (let* ((uri (puri:merge-uris (stp:attribute-value include "href")
339 (stp:base-uri include)))
340 (uri (if uri-resolver
341 (funcall uri-resolver (puri:render-uri uri nil))
342 uri))
343 (str (puri:render-uri uri nil))
344 (pathname
345 (handler-case
346 (uri-to-pathname uri)
347 (cxml:xml-parse-error (c)
348 (xslt-error "cannot find included stylesheet ~A: ~A"
349 uri c)))))
350 (with-open-file
351 (stream pathname
352 :element-type '(unsigned-byte 8)
353 :if-does-not-exist nil)
354 (unless stream
355 (xslt-error "cannot find included stylesheet ~A at ~A"
356 uri pathname))
357 (when (find str *xsl-include-stack* :test #'equal)
358 (xslt-error "recursive inclusion of ~A" uri))
359 (let* ((*xsl-include-stack* (cons str *xsl-include-stack*))
360 (<transform>2 (parse-stylesheet-to-stp stream uri-resolver)))
361 (stp:insert-child-after <transform>
362 (stp:copy <transform>2)
363 include)
364 (stp:detach include)))))
365 <transform>))
367 (defvar *instruction-base-uri*) ;misnamed, is also used in other attributes
368 (defvar *apply-imports-limit*)
369 (defvar *import-priority*)
370 (defvar *extension-namespaces*)
372 (defmacro do-toplevel ((var xpath <transform>) &body body)
373 `(map-toplevel (lambda (,var) ,@body) ,xpath ,<transform>))
375 (defun map-toplevel (fn xpath <transform>)
376 (dolist (node (list-toplevel xpath <transform>))
377 (let ((*namespaces* *namespaces*))
378 (xpath:do-node-set (ancestor (xpath:evaluate "ancestor::node()" node))
379 (when (xpath-protocol:node-type-p ancestor :element)
380 (setf *namespaces* (acons-namespaces ancestor))))
381 (funcall fn node))))
383 (defun list-toplevel (xpath <transform>)
384 (labels ((recurse (sub)
385 (let ((subsubs
386 (xpath-sys:pipe-of
387 (xpath:evaluate "transform|stylesheet" sub))))
388 (xpath::append-pipes
389 (xpath-sys:pipe-of (xpath:evaluate xpath sub))
390 (xpath::mappend-pipe #'recurse subsubs)))))
391 (xpath::sort-nodes (recurse <transform>))))
393 (defmacro with-parsed-prefixes ((node env) &body body)
394 `(invoke-with-parsed-prefixes (lambda () ,@body) ,node ,env))
396 (defun invoke-with-parsed-prefixes (fn node env)
397 (unless (or (namep node "stylesheet") (namep node "transform"))
398 (setf node (stp:parent node)))
399 (let ((*excluded-namespaces* (list *xsl*))
400 (*extension-namespaces* '()))
401 (parse-exclude-result-prefixes! node env)
402 (parse-extension-element-prefixes! node env)
403 (funcall fn)))
405 (defun parse-1-stylesheet (env stylesheet designator uri-resolver)
406 (let* ((<transform> (parse-stylesheet-to-stp designator uri-resolver))
407 (instruction-base-uri (stp:base-uri <transform>))
408 (namespaces (acons-namespaces <transform>))
409 (apply-imports-limit (1+ *import-priority*))
410 (continuations '()))
411 (let ((*namespaces* namespaces))
412 (invoke-with-parsed-prefixes (constantly t) <transform> env))
413 (macrolet ((with-specials ((&optional) &body body)
414 `(let ((*instruction-base-uri* instruction-base-uri)
415 (*namespaces* namespaces)
416 (*apply-imports-limit* apply-imports-limit))
417 ,@body)))
418 (with-specials ()
419 (do-toplevel (import "import" <transform>)
420 (let ((uri (puri:merge-uris (stp:attribute-value import "href")
421 (stp:base-uri import))))
422 (push (parse-imported-stylesheet env stylesheet uri uri-resolver)
423 continuations))))
424 (let ((import-priority
425 (incf *import-priority*))
426 (var-cont (prepare-global-variables stylesheet <transform>)))
427 ;; delay the rest of compilation until we've seen all global
428 ;; variables:
429 (lambda ()
430 (mapc #'funcall (nreverse continuations))
431 (with-specials ()
432 (let ((*import-priority* import-priority))
433 (funcall var-cont)
434 (parse-keys! stylesheet <transform> env)
435 (parse-templates! stylesheet <transform> env)
436 (parse-output! stylesheet <transform>)
437 (parse-strip/preserve-space! stylesheet <transform> env)
438 (parse-attribute-sets! stylesheet <transform> env)
439 (parse-namespace-aliases! stylesheet <transform> env))))))))
441 (defvar *xsl-import-stack* nil)
443 (defun parse-imported-stylesheet (env stylesheet uri uri-resolver)
444 (let* ((uri (if uri-resolver
445 (funcall uri-resolver (puri:render-uri uri nil))
446 uri))
447 (str (puri:render-uri uri nil))
448 (pathname
449 (handler-case
450 (uri-to-pathname uri)
451 (cxml:xml-parse-error (c)
452 (xslt-error "cannot find imported stylesheet ~A: ~A"
453 uri c)))))
454 (with-open-file
455 (stream pathname
456 :element-type '(unsigned-byte 8)
457 :if-does-not-exist nil)
458 (unless stream
459 (xslt-error "cannot find imported stylesheet ~A at ~A"
460 uri pathname))
461 (when (find str *xsl-import-stack* :test #'equal)
462 (xslt-error "recursive inclusion of ~A" uri))
463 (let ((*xsl-import-stack* (cons str *xsl-import-stack*)))
464 (parse-1-stylesheet env stylesheet stream uri-resolver)))))
466 (defun parse-stylesheet (designator &key uri-resolver)
467 (xpath:with-namespaces ((nil #.*xsl*))
468 (let* ((*import-priority* 0)
469 (puri:*strict-parse* nil)
470 (stylesheet (make-stylesheet))
471 (env (make-instance 'lexical-xslt-environment))
472 (*excluded-namespaces* *excluded-namespaces*)
473 (*global-variable-declarations* (make-empty-declaration-array)))
474 (ensure-mode stylesheet nil)
475 (funcall (parse-1-stylesheet env stylesheet designator uri-resolver))
476 ;; reverse attribute sets:
477 (let ((table (stylesheet-attribute-sets stylesheet)))
478 (maphash (lambda (k v)
479 (setf (gethash k table) (nreverse v)))
480 table))
481 stylesheet)))
483 (defun parse-attribute-sets! (stylesheet <transform> env)
484 (do-toplevel (elt "attribute-set" <transform>)
485 (with-parsed-prefixes (elt env)
486 (push (let* ((sets
487 (mapcar (lambda (qname)
488 (multiple-value-list (decode-qname qname env nil)))
489 (words
490 (stp:attribute-value elt "use-attribute-sets"))))
491 (instructions
492 (stp:map-children
493 'list
494 (lambda (child)
495 (unless (or (not (typep child 'stp:element))
496 (and (equal (stp:namespace-uri child) *xsl*)
497 (equal (stp:local-name child)
498 "attribute"))
499 (find (stp:namespace-uri child)
500 *extension-namespaces*
501 :test 'equal))
502 (xslt-error "non-attribute found in attribute set"))
503 (parse-instruction child))
504 elt))
505 (*lexical-variable-declarations*
506 (make-empty-declaration-array))
507 (thunk
508 (compile-instruction `(progn ,@instructions) env))
509 (n-variables (length *lexical-variable-declarations*)))
510 (lambda (ctx)
511 (with-stack-limit ()
512 (loop for (local-name uri nil) in sets do
513 (dolist (thunk (find-attribute-set local-name uri))
514 (funcall thunk ctx)))
515 (let ((*lexical-variable-values*
516 (make-variable-value-array n-variables)))
517 (funcall thunk ctx)))))
518 (gethash (multiple-value-bind (local-name uri)
519 (decode-qname (stp:attribute-value elt "name") env nil)
520 (cons local-name uri))
521 (stylesheet-attribute-sets stylesheet))))))
523 (defun parse-namespace-aliases! (stylesheet <transform> env)
524 (do-toplevel (elt "namespace-alias" <transform>)
525 (stp:with-attributes (stylesheet-prefix result-prefix) elt
526 (setf (gethash
527 (xpath-sys:environment-find-namespace env stylesheet-prefix)
528 (stylesheet-namespace-aliases stylesheet))
529 (xpath-sys:environment-find-namespace env result-prefix)))))
531 (defun parse-exclude-result-prefixes! (node env)
532 (stp:with-attributes (exclude-result-prefixes)
533 node
534 (dolist (prefix (words (or exclude-result-prefixes "")))
535 (if (equal prefix "#default")
536 (setf prefix nil)
537 (unless (cxml-stp-impl::nc-name-p prefix)
538 (xslt-error "invalid prefix: ~A" prefix)))
539 (push (or (xpath-sys:environment-find-namespace env prefix)
540 (xslt-error "namespace not found: ~A" prefix))
541 *excluded-namespaces*))))
543 (defun parse-extension-element-prefixes! (node env)
544 (stp:with-attributes (extension-element-prefixes)
545 node
546 (dolist (prefix (words (or extension-element-prefixes "")))
547 (if (equal prefix "#default")
548 (setf prefix nil)
549 (unless (cxml-stp-impl::nc-name-p prefix)
550 (xslt-error "invalid prefix: ~A" prefix)))
551 (let ((uri
552 (or (xpath-sys:environment-find-namespace env prefix)
553 (xslt-error "namespace not found: ~A" prefix))))
554 (unless (equal uri *xsl*)
555 (push uri *extension-namespaces*)
556 (push uri *excluded-namespaces*))))))
558 (defun parse-strip/preserve-space! (stylesheet <transform> env)
559 (xpath:with-namespaces ((nil #.*xsl*))
560 (do-toplevel (elt "strip-space|preserve-space" <transform>)
561 (let ((*namespaces* (acons-namespaces elt))
562 (mode
563 (if (equal (stp:local-name elt) "strip-space")
564 :strip
565 :preserve)))
566 (dolist (name-test (words (stp:attribute-value elt "elements")))
567 (let* ((pos (search ":*" name-test))
568 (test-function
569 (cond
570 ((eql pos (- (length name-test) 2))
571 (let* ((prefix (subseq name-test 0 pos))
572 (name-test-uri
573 (xpath-sys:environment-find-namespace env prefix)))
574 (unless (xpath::nc-name-p prefix)
575 (xslt-error "not an NCName: ~A" prefix))
576 (lambda (local-name uri)
577 (declare (ignore local-name))
578 (if (equal uri name-test-uri)
579 mode
580 nil))))
581 ((equal name-test "*")
582 (lambda (local-name uri)
583 (declare (ignore local-name uri))
584 mode))
586 (multiple-value-bind (name-test-local-name name-test-uri)
587 (decode-qname name-test env nil)
588 (lambda (local-name uri)
589 (if (and (equal local-name name-test-local-name)
590 (equal uri name-test-uri))
591 mode
592 nil)))))))
593 (push test-function (stylesheet-strip-tests stylesheet))))))))
595 (defstruct (output-specification
596 (:conc-name "OUTPUT-"))
597 method
598 indent
599 omit-xml-declaration
600 encoding)
602 (defun parse-output! (stylesheet <transform>)
603 (let ((outputs (list-toplevel "output" <transform>)))
604 (when outputs
605 (when (cdr outputs)
606 ;; FIXME:
607 ;; - concatenate cdata-section-elements
608 ;; - the others must not conflict
609 (error "oops, merging of output elements not supported yet"))
610 (let ((<output> (car outputs))
611 (spec (stylesheet-output-specification stylesheet)))
612 (stp:with-attributes (;; version
613 method
614 indent
615 encoding
616 ;;; media-type
617 ;;; doctype-system
618 ;;; doctype-public
619 omit-xml-declaration
620 ;;; standalone
621 ;;; cdata-section-elements
623 <output>
624 (setf (output-method spec) method)
625 (setf (output-indent spec) indent)
626 (setf (output-encoding spec) encoding)
627 (setf (output-omit-xml-declaration spec) omit-xml-declaration))))))
629 (defun make-empty-declaration-array ()
630 (make-array 1 :fill-pointer 0 :adjustable t))
632 (defun make-variable-value-array (n-lexical-variables)
633 (make-array n-lexical-variables :initial-element 'unbound))
635 (defun compile-global-variable (<variable> env) ;; also for <param>
636 (stp:with-attributes (name select) <variable>
637 (when (and select (stp:list-children <variable>))
638 (xslt-error "variable with select and body"))
639 (let* ((*lexical-variable-declarations* (make-empty-declaration-array))
640 (inner (cond
641 (select
642 (compile-xpath select env))
643 ((stp:list-children <variable>)
644 (let* ((inner-sexpr `(progn ,@(parse-body <variable>)))
645 (inner-thunk (compile-instruction inner-sexpr env)))
646 (lambda (ctx)
647 (apply-to-result-tree-fragment ctx inner-thunk))))
649 (lambda (ctx)
650 (declare (ignore ctx))
651 ""))))
652 (n-lexical-variables (length *lexical-variable-declarations*)))
653 (xslt-trace-thunk
654 (lambda (ctx)
655 (let* ((*lexical-variable-values*
656 (make-variable-value-array n-lexical-variables)))
657 (funcall inner ctx)))
658 "global ~s (~s) = ~s" name select :result))))
660 (defstruct (variable-information
661 (:constructor make-variable)
662 (:conc-name "VARIABLE-"))
663 index
664 thunk
665 local-name
667 param-p
668 thunk-setter)
670 (defun parse-global-variable! (<variable> global-env) ;; also for <param>
671 (let* ((*namespaces* (acons-namespaces <variable>))
672 (instruction-base-uri (stp:base-uri <variable>))
673 (*instruction-base-uri* instruction-base-uri)
674 (*excluded-namespaces* (list *xsl*))
675 (*extension-namespaces* '())
676 (qname (stp:attribute-value <variable> "name")))
677 (with-parsed-prefixes (<variable> global-env)
678 (unless qname
679 (xslt-error "name missing in ~A" (stp:local-name <variable>)))
680 (multiple-value-bind (local-name uri)
681 (decode-qname qname global-env nil)
682 ;; For the normal compilation environment of templates, install it
683 ;; into *GLOBAL-VARIABLE-DECLARATIONS*:
684 (let ((index (intern-global-variable local-name uri)))
685 ;; For the evaluation of a global variable itself, build a thunk
686 ;; that lazily resolves other variables, stored into
687 ;; INITIAL-GLOBAL-VARIABLE-THUNKS:
688 (let* ((value-thunk :unknown)
689 (global-variable-thunk
690 (lambda (ctx)
691 (let ((v (global-variable-value index nil)))
692 (when (eq v 'seen)
693 (xslt-error "recursive variable definition"))
694 (cond
695 ((eq v 'unbound)
696 (setf (global-variable-value index) 'seen)
697 (setf (global-variable-value index)
698 (funcall value-thunk ctx)))
700 v)))))
701 (excluded-namespaces *excluded-namespaces*)
702 (extension-namespaces *extension-namespaces*)
703 (thunk-setter
704 (lambda ()
705 (let ((*instruction-base-uri* instruction-base-uri)
706 (*excluded-namespaces* excluded-namespaces)
707 (*extension-namespaces* extension-namespaces))
708 (setf value-thunk
709 (compile-global-variable <variable> global-env))))))
710 (setf (gethash (cons local-name uri)
711 (initial-global-variable-thunks global-env))
712 global-variable-thunk)
713 (make-variable :index index
714 :local-name local-name
715 :uri uri
716 :thunk global-variable-thunk
717 :param-p (namep <variable> "param")
718 :thunk-setter thunk-setter)))))))
720 (defun parse-keys! (stylesheet <transform> env)
721 (xpath:with-namespaces ((nil #.*xsl*))
722 (do-toplevel (<key> "key" <transform>)
723 (let ((*instruction-base-uri* (stp:base-uri <key>)))
724 (stp:with-attributes (name match use) <key>
725 (unless name (xslt-error "key name attribute not specified"))
726 (unless match (xslt-error "key match attribute not specified"))
727 (unless use (xslt-error "key use attribute not specified"))
728 (multiple-value-bind (local-name uri)
729 (decode-qname name env nil)
730 (add-key stylesheet
731 (cons local-name uri)
732 (compile-xpath `(xpath:xpath ,(parse-key-pattern match)) env)
733 (compile-xpath use env))))))))
735 (defun prepare-global-variables (stylesheet <transform>)
736 (xpath:with-namespaces ((nil #.*xsl*))
737 (let* ((table (make-hash-table :test 'equal))
738 (global-env (make-instance 'global-variable-environment
739 :initial-global-variable-thunks table))
740 (specs '()))
741 (do-toplevel (<variable> "variable|param" <transform>)
742 (let ((var (parse-global-variable! <variable> global-env)))
743 (xslt-trace "parsing global variable ~s (uri ~s)"
744 (variable-local-name var)
745 (variable-uri var))
746 (when (find var
747 specs
748 :test (lambda (a b)
749 (and (equal (variable-local-name a)
750 (variable-local-name b))
751 (equal (variable-uri a)
752 (variable-uri b)))))
753 (xslt-error "duplicate definition for global variable ~A"
754 (variable-local-name var)))
755 (push var specs)))
756 (setf specs (nreverse specs))
757 (lambda ()
758 ;; now that the global environment knows about all variables, run the
759 ;; thunk setters to perform their compilation
760 (mapc (lambda (spec) (funcall (variable-thunk-setter spec))) specs)
761 (let ((table (stylesheet-global-variables stylesheet))
762 (newlen (length *global-variable-declarations*)))
763 (adjust-array table newlen :fill-pointer newlen)
764 (dolist (spec specs)
765 (setf (elt table (variable-index spec)) spec)))))))
767 (defun parse-templates! (stylesheet <transform> env)
768 (let ((i 0))
769 (do-toplevel (<template> "template" <transform>)
770 (let ((*namespaces* (acons-namespaces <template>))
771 (*instruction-base-uri* (stp:base-uri <template>)))
772 (with-parsed-prefixes (<template> env)
773 (dolist (template (compile-template <template> env i))
774 (let ((name (template-name template)))
775 (if name
776 (let* ((table (stylesheet-named-templates stylesheet))
777 (head (car (gethash name table))))
778 (when (and head (eql (template-import-priority head)
779 (template-import-priority template)))
780 ;; fixme: is this supposed to be a run-time error?
781 (xslt-error "conflicting templates for ~A" name))
782 (push template (gethash name table)))
783 (let ((mode (ensure-mode/qname stylesheet
784 (template-mode-qname template)
785 env)))
786 (setf (template-mode template) mode)
787 (push template (mode-templates mode))))))))
788 (incf i))))
791 ;;;; APPLY-STYLESHEET
793 (defvar *stylesheet*)
794 (defvar *mode*)
796 (deftype xml-designator () '(or runes:xstream runes:rod array stream pathname))
798 (defun unalias-uri (uri)
799 (gethash uri (stylesheet-namespace-aliases *stylesheet*)
800 uri))
802 (defstruct (parameter
803 (:constructor make-parameter (value local-name &optional uri)))
804 (uri "")
805 local-name
806 value)
808 (defun find-parameter-value (local-name uri parameters)
809 (dolist (p parameters)
810 (when (and (equal (parameter-local-name p) local-name)
811 (equal (parameter-uri p) uri))
812 (return (parameter-value p)))))
814 (defvar *uri-resolver*)
816 (defun parse-allowing-microsoft-bom (pathname handler)
817 (with-open-file (s pathname :element-type '(unsigned-byte 8))
818 (unless (and (eql (read-byte s nil) #xef)
819 (eql (read-byte s nil) #xbb)
820 (eql (read-byte s nil) #xbf))
821 (file-position s 0))
822 (cxml:parse s handler)))
824 (defun %document (uri-string base-uri)
825 (let* ((absolute-uri
826 (puri:merge-uris uri-string (or base-uri "")))
827 (resolved-uri
828 (if *uri-resolver*
829 (funcall *uri-resolver* (puri:render-uri absolute-uri nil))
830 absolute-uri))
831 (pathname
832 (handler-case
833 (uri-to-pathname resolved-uri)
834 (cxml:xml-parse-error (c)
835 (xslt-error "cannot find referenced document ~A: ~A"
836 resolved-uri c))))
837 (document
838 (handler-case
839 (parse-allowing-microsoft-bom pathname (stp:make-builder))
840 ((or file-error cxml:xml-parse-error) (c)
841 (xslt-error "cannot parse referenced document ~A: ~A"
842 pathname c))))
843 (xpath-root-node
844 (make-whitespace-stripper document
845 (stylesheet-strip-tests *stylesheet*))))
846 (when (puri:uri-fragment absolute-uri)
847 (xslt-error "use of fragment identifiers in document() not supported"))
848 xpath-root-node))
850 (xpath-sys:define-extension xslt *xsl*)
852 (xpath-sys:define-xpath-function/lazy
853 xslt :document
854 (object &optional node-set)
855 (let ((instruction-base-uri *instruction-base-uri*))
856 (lambda (ctx)
857 (let* ((object (funcall object ctx))
858 (node-set (and node-set (funcall node-set ctx)))
859 (uri
860 (when node-set
861 ;; FIXME: should use first node of the node set
862 ;; _in document order_
863 (xpath-protocol:base-uri (xpath:first-node node-set)))))
864 (xpath-sys:make-node-set
865 (if (xpath:node-set-p object)
866 (xpath:map-node-set->list
867 (lambda (node)
868 (%document (xpath:string-value node)
869 (if (plusp (length uri))
871 (xpath-protocol:base-uri node))))
872 object)
873 (list (%document (xpath:string-value object)
874 (if (plusp (length uri))
876 instruction-base-uri)))))))))
878 (xpath-sys:define-xpath-function/lazy xslt :key (name object)
879 (let ((namespaces *namespaces*))
880 (lambda (ctx)
881 (let* ((qname (xpath:string-value (funcall name ctx)))
882 (object (funcall object ctx))
883 (expanded-name
884 (multiple-value-bind (local-name uri)
885 (decode-qname/runtime qname namespaces nil)
886 (cons local-name uri)))
887 (key (find-key expanded-name *stylesheet*)))
888 (labels ((get-by-key (value)
889 (let ((value (xpath:string-value value)))
890 (xpath::filter-pipe
891 #'(lambda (node)
892 (let ((uses
893 (xpath:evaluate-compiled (key-use key) node)))
894 (if (xpath:node-set-p uses)
895 (xpath::find-in-pipe
896 value
897 (xpath-sys:pipe-of uses)
898 :key #'xpath:string-value
899 :test #'equal)
900 (equal value (xpath:string-value uses)))))
901 (xpath-sys:pipe-of
902 (xpath:node-set-value
903 (xpath:evaluate-compiled (key-match key) ctx)))))))
904 (xpath-sys:make-node-set
905 (xpath::sort-pipe
906 (if (xpath:node-set-p object)
907 (xpath::mappend-pipe #'get-by-key (xpath-sys:pipe-of object))
908 (get-by-key object)))))))))
910 ;; FIXME: add alias mechanism for XPath extensions in order to avoid duplication
912 (xpath-sys:define-xpath-function/lazy xslt :current ()
913 #'(lambda (ctx)
914 (xpath-sys:make-node-set
915 (xpath-sys:make-pipe
916 (xpath:context-starting-node ctx)
917 nil))))
919 (xpath-sys:define-xpath-function/lazy xslt :unparsed-entity-uri (name)
920 #'(lambda (ctx)
921 (or (xpath-protocol:unparsed-entity-uri (xpath:context-node ctx)
922 (funcall name ctx))
923 "")))
925 (defun %get-node-id (node)
926 (when (xpath:node-set-p node)
927 (setf node (xpath::textually-first-node node)))
928 (when node
929 (let ((id (xpath-sys:get-node-id node))
930 (highest-base-uri
931 (loop
932 for parent = node then next
933 for next = (xpath-protocol:parent-node parent)
934 for this-base-uri = (xpath-protocol:base-uri parent)
935 for highest-base-uri = (if (plusp (length this-base-uri))
936 this-base-uri
937 highest-base-uri)
938 while next
939 finally (return highest-base-uri))))
940 ;; Heuristic: Reverse it so that the /home/david/alwaysthesame prefix is
941 ;; checked only if everything else matches.
943 ;; This might be pointless premature optimization, but I like the idea :-)
944 (nreverse (concatenate 'string highest-base-uri "//" id)))))
946 (xpath-sys:define-xpath-function/lazy xslt :generate-id (&optional node-set-thunk)
947 (if node-set-thunk
948 #'(lambda (ctx)
949 (%get-node-id (xpath:node-set-value (funcall node-set-thunk ctx))))
950 #'(lambda (ctx)
951 (%get-node-id (xpath:context-node ctx)))))
953 (defparameter *available-instructions* (make-hash-table :test 'equal))
955 (xpath-sys:define-xpath-function/lazy xslt :element-available (qname)
956 (let ((namespaces *namespaces*))
957 #'(lambda (ctx)
958 (let ((qname (funcall qname ctx)))
959 (multiple-value-bind (local-name uri)
960 (decode-qname/runtime qname namespaces nil)
961 (and (equal uri *xsl*)
962 (gethash local-name *available-instructions*)
963 t))))))
965 (xpath-sys:define-xpath-function/lazy xslt :function-available (qname)
966 (let ((namespaces *namespaces*))
967 #'(lambda (ctx)
968 (let ((qname (funcall qname ctx)))
969 (multiple-value-bind (local-name uri)
970 (decode-qname/runtime qname namespaces nil)
971 (and (zerop (length uri))
972 (or (xpath-sys:find-xpath-function local-name *xsl*)
973 (xpath-sys:find-xpath-function local-name uri))
974 t))))))
976 (defun apply-stylesheet
977 (stylesheet source-document
978 &key output parameters uri-resolver navigator)
979 (when (typep stylesheet 'xml-designator)
980 (setf stylesheet (parse-stylesheet stylesheet)))
981 (when (typep source-document 'xml-designator)
982 (setf source-document (cxml:parse source-document (stp:make-builder))))
983 (invoke-with-output-sink
984 (lambda ()
985 (handler-case*
986 (let* ((xpath:*navigator* (or navigator :default-navigator))
987 (puri:*strict-parse* nil)
988 (*stylesheet* stylesheet)
989 (*mode* (find-mode stylesheet nil))
990 (*empty-mode* (make-mode))
991 (global-variable-specs
992 (stylesheet-global-variables stylesheet))
993 (*global-variable-values*
994 (make-variable-value-array (length global-variable-specs)))
995 (*uri-resolver* uri-resolver)
996 (xpath-root-node
997 (make-whitespace-stripper
998 source-document
999 (stylesheet-strip-tests stylesheet)))
1000 (ctx (xpath:make-context xpath-root-node)))
1001 (map nil
1002 (lambda (spec)
1003 (when (variable-param-p spec)
1004 (let ((value
1005 (find-parameter-value (variable-local-name spec)
1006 (variable-uri spec)
1007 parameters)))
1008 (when value
1009 (setf (global-variable-value (variable-index spec))
1010 value)))))
1011 global-variable-specs)
1012 (map nil
1013 (lambda (spec)
1014 (funcall (variable-thunk spec) ctx))
1015 global-variable-specs)
1016 ;; zzz we wouldn't have to mask float traps here if we used the
1017 ;; XPath API properly. Unfortunately I've been using FUNCALL
1018 ;; everywhere instead of EVALUATE, so let's paper over that
1019 ;; at a central place to be sure:
1020 (xpath::with-float-traps-masked ()
1021 (apply-templates ctx)))
1022 (xpath:xpath-error (c)
1023 (xslt-error "~A" c))))
1024 (stylesheet-output-specification stylesheet)
1025 output))
1027 (defun find-attribute-set (local-name uri)
1028 (or (gethash (cons local-name uri) (stylesheet-attribute-sets *stylesheet*))
1029 (xslt-error "no such attribute set: ~A/~A" local-name uri)))
1031 (defun apply-templates/list (list &optional param-bindings sort-predicate)
1032 (when sort-predicate
1033 (setf list (sort list sort-predicate)))
1034 (let* ((n (length list))
1035 (s/d (lambda () n)))
1036 (loop
1037 for i from 1
1038 for child in list
1040 (apply-templates (xpath:make-context child s/d i)
1041 param-bindings))))
1043 (defvar *stack-limit* 200)
1045 (defun invoke-with-stack-limit (fn)
1046 (let ((*stack-limit* (1- *stack-limit*)))
1047 (unless (plusp *stack-limit*)
1048 (xslt-error "*stack-limit* reached; stack overflow"))
1049 (funcall fn)))
1051 (defun invoke-template (ctx template param-bindings)
1052 (let ((*lexical-variable-values*
1053 (make-variable-value-array (template-n-variables template))))
1054 (with-stack-limit ()
1055 (loop
1056 for (name-cons value) in param-bindings
1057 for (nil index nil) = (find name-cons
1058 (template-params template)
1059 :test #'equal
1060 :key #'car)
1062 (when index
1063 (setf (lexical-variable-value index) value)))
1064 (funcall (template-body template) ctx))))
1066 (defun apply-default-templates (ctx)
1067 (let ((node (xpath:context-node ctx)))
1068 (cond
1069 ((or (xpath-protocol:node-type-p node :processing-instruction)
1070 (xpath-protocol:node-type-p node :comment)))
1071 ((or (xpath-protocol:node-type-p node :text)
1072 (xpath-protocol:node-type-p node :attribute))
1073 (write-text (xpath-protocol:node-text node)))
1075 (apply-templates/list
1076 (xpath::force
1077 (xpath-protocol:child-pipe node)))))))
1079 (defvar *apply-imports*)
1081 (defun apply-applicable-templates (ctx templates param-bindings finally)
1082 (labels ((apply-imports (&optional actual-param-bindings)
1083 (if templates
1084 (let* ((this (pop templates))
1085 (low (template-apply-imports-limit this))
1086 (high (template-import-priority this)))
1087 (setf templates
1088 (remove-if-not
1089 (lambda (x)
1090 (<= low (template-import-priority x) high))
1091 templates))
1092 (invoke-template ctx this actual-param-bindings))
1093 (funcall finally))))
1094 (let ((*apply-imports* #'apply-imports))
1095 (apply-imports param-bindings))))
1097 (defun apply-templates (ctx &optional param-bindings)
1098 (apply-applicable-templates ctx
1099 (find-templates ctx)
1100 param-bindings
1101 (lambda ()
1102 (apply-default-templates ctx))))
1104 (defun call-template (ctx name &optional param-bindings)
1105 (apply-applicable-templates ctx
1106 (find-named-templates name)
1107 param-bindings
1108 (lambda ()
1109 (error "cannot find named template: ~s"
1110 name))))
1112 (defun find-templates (ctx)
1113 (let* ((matching-candidates
1114 (remove-if-not (lambda (template)
1115 (template-matches-p template ctx))
1116 (mode-templates *mode*)))
1117 (npriorities
1118 (if matching-candidates
1119 (1+ (reduce #'max
1120 matching-candidates
1121 :key #'template-import-priority))
1123 (priority-groups (make-array npriorities :initial-element nil)))
1124 (dolist (template matching-candidates)
1125 (push template
1126 (elt priority-groups (template-import-priority template))))
1127 (loop
1128 for i from (1- npriorities) downto 0
1129 for group = (elt priority-groups i)
1130 for template = (maximize #'template< group)
1131 when template
1132 collect template)))
1134 (defun find-named-templates (name)
1135 (gethash name (stylesheet-named-templates *stylesheet*)))
1137 (defun template< (a b) ;assuming same import priority
1138 (let ((p (template-priority a))
1139 (q (template-priority b)))
1140 (cond
1141 ((< p q) t)
1142 ((> p q) nil)
1144 (xslt-cerror "conflicting templates:~_~A,~_~A"
1145 (template-match-expression a)
1146 (template-match-expression b))
1147 (< (template-position a) (template-position b))))))
1149 (defun maximize (< things)
1150 (when things
1151 (let ((max (car things)))
1152 (dolist (other (cdr things))
1153 (when (funcall < max other)
1154 (setf max other)))
1155 max)))
1157 (defun template-matches-p (template ctx)
1158 (find (xpath:context-node ctx)
1159 (xpath:all-nodes (funcall (template-match-thunk template) ctx))))
1161 (defun invoke-with-output-sink (fn output-spec output)
1162 (etypecase output
1163 (pathname
1164 (with-open-file (s output
1165 :direction :output
1166 :element-type '(unsigned-byte 8)
1167 :if-exists :rename-and-delete)
1168 (invoke-with-output-sink fn output-spec s)))
1169 ((or stream null)
1170 (invoke-with-output-sink fn
1171 output-spec
1172 (make-output-sink output-spec output)))
1173 ((or hax:abstract-handler sax:abstract-handler)
1174 (with-xml-output output
1175 (funcall fn)))))
1177 (defun make-output-sink (output-spec stream)
1178 (let* ((ystream
1179 (if stream
1180 (let ((et (stream-element-type stream)))
1181 (cond
1182 ((or (null et) (subtypep et '(unsigned-byte 8)))
1183 (runes:make-octet-stream-ystream stream))
1184 ((subtypep et 'character)
1185 (runes:make-character-stream-ystream stream))))
1186 (runes:make-rod-ystream)))
1187 (omit-xml-declaration-p
1188 (equal (output-omit-xml-declaration output-spec) "yes"))
1189 (sax-target
1190 (make-instance 'cxml::sink
1191 :ystream ystream
1192 :omit-xml-declaration-p omit-xml-declaration-p)))
1193 (cond
1194 ((equalp (output-method output-spec) "HTML")
1195 (make-instance 'combi-sink
1196 :hax-target (make-instance 'chtml::sink
1197 :ystream ystream)
1198 :sax-target sax-target
1199 :encoding (output-encoding output-spec)))
1200 ((equalp (output-method output-spec) "TEXT")
1201 (make-text-filter sax-target))
1203 sax-target))))
1205 (defstruct template
1206 match-expression
1207 match-thunk
1208 name
1209 import-priority
1210 apply-imports-limit
1211 priority
1212 position
1213 mode
1214 mode-qname
1215 params
1216 body
1217 n-variables)
1219 (defun expression-priority (form)
1220 (let ((step (second form)))
1221 (if (and (null (cddr form))
1222 (listp step)
1223 (member (car step) '(:child :attribute))
1224 (null (cddr step)))
1225 (let ((name (second step)))
1226 (cond
1227 ((or (stringp name)
1228 (and (consp name)
1229 (or (eq (car name) :qname)
1230 (eq (car name) :processing-instruction))))
1231 0.0)
1232 ((and (consp name)
1233 (or (eq (car name) :namespace)
1234 (eq (car name) '*)))
1235 -0.25)
1237 -0.5)))
1238 0.5)))
1240 (defun valid-expression-p (expr)
1241 (cond
1242 ((atom expr) t)
1243 ((eq (first expr) :path)
1244 (every (lambda (x)
1245 (let ((filter (third x)))
1246 (or (null filter) (valid-expression-p filter))))
1247 (cdr expr)))
1248 ((eq (first expr) :variable) ;(!)
1249 nil)
1251 (every #'valid-expression-p (cdr expr)))))
1253 (defun parse-xpath (str)
1254 (handler-case
1255 (xpath:parse-xpath str)
1256 (xpath:xpath-error (c)
1257 (xslt-error "~A" c))))
1259 ;; zzz also use naive-pattern-expression here?
1260 (defun parse-key-pattern (str)
1261 (let ((parsed
1262 (mapcar #'(lambda (item)
1263 `(:path (:root :node)
1264 (:descendant-or-self *)
1265 ,@(cdr item)))
1266 (parse-pattern str))))
1267 (if (null (rest parsed))
1268 (first parsed)
1269 `(:union ,@parsed))))
1271 (defun parse-pattern (str)
1272 ;; zzz check here for anything not allowed as an XSLT pattern
1273 ;; zzz can we hack id() and key() here?
1274 (let ((form (parse-xpath str)))
1275 (unless (consp form)
1276 (xslt-error "not a valid pattern: ~A" str))
1277 (labels ((process-form (form)
1278 (cond ((eq (car form) :union)
1279 (alexandria:mappend #'process-form (rest form)))
1280 ((not (or (eq (car form) :path)
1281 (and (eq (car form) :filter)
1282 (let ((filter (second form)))
1283 (and (consp filter)
1284 (member (car filter)
1285 '(:key :id))))
1286 (equal (third form) '(:true)))
1287 (member (car form) '(:key :id))))
1288 (xslt-error "not a valid pattern: ~A ~A" str form))
1289 ((not (valid-expression-p form))
1290 (xslt-error "invalid filter"))
1291 (t (list form)))))
1292 (process-form form))))
1294 (defun naive-pattern-expression (x)
1295 (ecase (car x)
1296 (:path `(:path (:ancestor-or-self :node) ,@(cdr x)))
1297 ((:filter :key :id) x)))
1299 (defun compile-value-thunk (value env)
1300 (if (and (listp value) (eq (car value) 'progn))
1301 (let ((inner-thunk (compile-instruction value env)))
1302 (lambda (ctx)
1303 (apply-to-result-tree-fragment ctx inner-thunk)))
1304 (compile-xpath value env)))
1306 (defun compile-var-bindings/nointern (forms env)
1307 (loop
1308 for (name value) in forms
1309 collect (multiple-value-bind (local-name uri)
1310 (decode-qname name env nil)
1311 (list (cons local-name uri)
1312 (xslt-trace-thunk
1313 (compile-value-thunk value env)
1314 "local variable ~s = ~s" name :result)))))
1316 (defun compile-var-bindings (forms env)
1317 (loop
1318 for (cons thunk) in (compile-var-bindings/nointern forms env)
1319 for (local-name . uri) = cons
1320 collect (list cons
1321 (push-variable local-name
1323 *lexical-variable-declarations*)
1324 thunk)))
1326 (defun compile-template (<template> env position)
1327 (stp:with-attributes (match name priority mode) <template>
1328 (unless (or name match)
1329 (xslt-error "missing match in template"))
1330 (multiple-value-bind (params body-pos)
1331 (loop
1332 for i from 0
1333 for child in (stp:list-children <template>)
1334 while (namep child "param")
1335 collect (parse-param child) into params
1336 finally (return (values params i)))
1337 (let* ((*lexical-variable-declarations* (make-empty-declaration-array))
1338 (param-bindings (compile-var-bindings params env))
1339 (body (parse-body <template> body-pos (mapcar #'car params)))
1340 (body-thunk (compile-instruction `(progn ,@body) env))
1341 (outer-body-thunk
1342 (xslt-trace-thunk
1343 #'(lambda (ctx)
1344 (unwind-protect
1345 (progn
1346 ;; set params that weren't initialized by apply-templates
1347 (loop for (name index param-thunk) in param-bindings
1348 when (eq (lexical-variable-value index nil) 'unbound)
1349 do (setf (lexical-variable-value index)
1350 (funcall param-thunk ctx)))
1351 (funcall body-thunk ctx))))
1352 "template: match = ~s name = ~s" match name))
1353 (n-variables (length *lexical-variable-declarations*)))
1354 (append
1355 (when name
1356 (multiple-value-bind (local-name uri)
1357 (decode-qname name env nil)
1358 (list
1359 (make-template :name (cons local-name uri)
1360 :import-priority *import-priority*
1361 :apply-imports-limit *apply-imports-limit*
1362 :params param-bindings
1363 :body outer-body-thunk
1364 :n-variables n-variables))))
1365 (when match
1366 (mapcar (lambda (expression)
1367 (let ((match-thunk
1368 (xslt-trace-thunk
1369 (compile-xpath
1370 `(xpath:xpath
1371 ,(naive-pattern-expression expression))
1372 env)
1373 "match-thunk for template (match ~s): ~s --> ~s"
1374 match expression :result))
1375 (p (if priority
1376 (parse-number:parse-number priority)
1377 (expression-priority expression))))
1378 (make-template :match-expression expression
1379 :match-thunk match-thunk
1380 :import-priority *import-priority*
1381 :apply-imports-limit *apply-imports-limit*
1382 :priority p
1383 :position position
1384 :mode-qname mode
1385 :params param-bindings
1386 :body outer-body-thunk
1387 :n-variables n-variables)))
1388 (parse-pattern match))))))))
1389 #+(or)
1390 (xuriella::parse-stylesheet #p"/home/david/src/lisp/xuriella/test.xsl")