xslt.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
   2
   3 ;;; Copyright (c) 2007,2008 David Lichteblau, Ivan Shvedunov.
   4 ;;; All rights reserved.
   5
   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.
  29
  30 (in-package :xuriella)
  31
  32 #+sbcl
  33 (declaim (optimize (debug 2)))
  34
  35
  36 ;;;; XSLT-ERROR
  37
  38 (define-condition xslt-error (simple-error)
  39   ()
  40   (:documentation "The class of all XSLT errors."))
  41
  42 (define-condition recoverable-xslt-error (xslt-error)
  43   ()
  44   (:documentation "The class of recoverable XSLT errors."))
  45
  46 (defun xslt-error (fmt &rest args)
  47   (error 'xslt-error :format-control fmt :format-arguments args))
  48
  49 (defun xslt-cerror (fmt &rest args)
  50   (with-simple-restart (recover "recover")
  51     (error 'recoverable-xslt-error
  52            :format-control fmt
  53            :format-arguments args)))
  54
  55 (defvar *debug* nil)
  56
  57 (defmacro handler-case* (form &rest clauses)
  58   ;; like HANDLER-CASE if *DEBUG* is off.  If it's on, don't establish
  59   ;; a handler at all so that we see the real stack traces.  (We could use
  60   ;; HANDLER-BIND here and check at signalling time, but doesn't seem
  61   ;; important.)
  62   (let ((doit (gensym)))
  63     `(flet ((,doit () ,form))
  64        (if *debug*
  65            (,doit)
  66            (handler-case
  67                (,doit)
  68              ,@clauses)))))
  69
  70 (defun compile-xpath (xpath &optional env)
  71   (handler-case*
  72       (xpath:compile-xpath xpath env)
  73     (xpath:xpath-error (c)
  74       (xslt-error "~A" c))))
  75
  76 (defmacro with-stack-limit ((&optional) &body body)
  77   `(invoke-with-stack-limit (lambda () ,@body)))
  78
  79
  80 ;;;; Helper function and macro
  81
  82 (defun map-pipe-eagerly (fn pipe)
  83   (xpath::enumerate pipe :key fn :result nil))
  84
  85 (defmacro do-pipe ((var pipe &optional result) &body body)
  86   `(block nil
  87      (map-pipe-eagerly #'(lambda (,var) ,@body) ,pipe)
  88      ,result))
  89
  90
  91 ;;;; XSLT-ENVIRONMENT and XSLT-CONTEXT
  92
  93 (defparameter *initial-namespaces*
  94   '((nil . "")
  95     ("xmlns" . #"http://www.w3.org/2000/xmlns/")
  96     ("xml" . #"http://www.w3.org/XML/1998/namespace")))
  97
  98 (defparameter *namespaces* *initial-namespaces*)
  99
 100 (defvar *global-variable-declarations*)
 101 (defvar *lexical-variable-declarations*)
 102
 103 (defvar *global-variable-values*)
 104 (defvar *lexical-variable-values*)
 105
 106 (defclass xslt-environment () ())
 107
 108 (defun split-qname (str)
 109   (handler-case
 110       (multiple-value-bind (prefix local-name)
 111           (cxml::split-qname str)
 112         (unless
 113             ;; FIXME: cxml should really offer a function that does
 114             ;; checks for NCName and QName in a sensible way for user code.
 115             ;; cxml::split-qname is tailored to the needs of the parser.
 116             ;;
 117             ;; For now, let's just check the syntax explicitly.
 118             (and (or (null prefix) (xpath::nc-name-p prefix))
 119                  (xpath::nc-name-p local-name))
 120           (xslt-error "not a qname: ~A" str))
 121         (values prefix local-name))
 122     (cxml:well-formedness-violation ()
 123       (xslt-error "not a qname: ~A" str))))
 124
 125 (defun decode-qname (qname env attributep)
 126   (multiple-value-bind (prefix local-name)
 127       (split-qname qname)
 128     (values local-name
 129             (if (or prefix (not attributep))
 130                 (xpath-sys:environment-find-namespace env prefix)
 131                 "")
 132             prefix)))
 133
 134 (defmethod xpath-sys:environment-find-namespace ((env xslt-environment) prefix)
 135   (cdr (assoc prefix *namespaces* :test 'equal)))
 136
 137 (defun find-variable-index (local-name uri table)
 138   (position (cons local-name uri) table :test 'equal))
 139
 140 (defun intern-global-variable (local-name uri)
 141   (or (find-variable-index local-name uri *global-variable-declarations*)
 142       (push-variable local-name uri *global-variable-declarations*)))
 143
 144 (defun push-variable (local-name uri table)
 145   (prog1
 146       (length table)
 147     (vector-push-extend (cons local-name uri) table)))
 148
 149 (defun lexical-variable-value (index &optional (errorp t))
 150   (let ((result (svref *lexical-variable-values* index)))
 151     (when errorp
 152       (assert (not (eq result 'unbound))))
 153     result))
 154
 155 (defun (setf lexical-variable-value) (newval index)
 156   (assert (not (eq newval 'unbound)))
 157   (setf (svref *lexical-variable-values* index) newval))
 158
 159 (defun global-variable-value (index &optional (errorp t))
 160   (let ((result (svref *global-variable-values* index)))
 161     (when errorp
 162       (assert (not (eq result 'unbound))))
 163     result))
 164
 165 (defun (setf global-variable-value) (newval index)
 166   (assert (not (eq newval 'unbound)))
 167   (setf (svref *global-variable-values* index) newval))
 168
 169 (defmethod xpath-sys:environment-find-function
 170     ((env xslt-environment) lname uri)
 171   (if (string= uri "")
 172       (or (xpath-sys:find-xpath-function lname *xsl*)
 173           (xpath-sys:find-xpath-function lname uri))
 174       (xpath-sys:find-xpath-function lname uri)))
 175
 176 (defmethod xpath-sys:environment-find-variable
 177     ((env xslt-environment) lname uri)
 178   (let ((index
 179          (find-variable-index lname uri *lexical-variable-declarations*)))
 180     (when index
 181       (lambda (ctx)
 182         (declare (ignore ctx))
 183         (svref *lexical-variable-values* index)))))
 184
 185 (defclass lexical-xslt-environment (xslt-environment) ())
 186
 187 (defmethod xpath-sys:environment-find-variable
 188     ((env lexical-xslt-environment) lname uri)
 189   (or (call-next-method)
 190       (let ((index
 191              (find-variable-index lname uri *global-variable-declarations*)))
 192         (when index
 193           (xslt-trace-thunk
 194            (lambda (ctx)
 195              (declare (ignore ctx))
 196              (svref *global-variable-values* index))
 197            "global ~s (uri ~s) = ~s" lname uri :result)))))
 198
 199 (defclass global-variable-environment (xslt-environment)
 200   ((initial-global-variable-thunks
 201     :initarg :initial-global-variable-thunks
 202     :accessor initial-global-variable-thunks)))
 203
 204 (defmethod xpath-sys:environment-find-variable
 205     ((env global-variable-environment) lname uri)
 206   (or (call-next-method)
 207       (gethash (cons lname uri) (initial-global-variable-thunks env))))
 208
 209
 210 ;;;; TEXT-OUTPUT-SINK
 211 ;;;;
 212 ;;;; A sink that serializes only text and will error out on any other
 213 ;;;; SAX event.
 214
 215 (defmacro with-text-output-sink ((var) &body body)
 216   `(invoke-with-text-output-sink (lambda (,var) ,@body)))
 217
 218 (defclass text-output-sink (sax:default-handler)
 219   ((target :initarg :target :accessor text-output-sink-target)
 220    (depth :initform 0 :accessor textoutput-sink-depth)))
 221
 222 (defmethod sax:start-element ((sink 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)))
 226
 227 (defmethod sax:characters ((sink text-output-sink) data)
 228   (when (zerop (textoutput-sink-depth sink))
 229     (write-string data (text-output-sink-target sink))))
 230
 231 (defmethod sax:end-element ((sink text-output-sink)
 232                               namespace-uri local-name qname)
 233   (declare (ignore namespace-uri local-name qname))
 234   (decf (textoutput-sink-depth sink)))
 235
 236 (defun invoke-with-text-output-sink (fn)
 237   (with-output-to-string (s)
 238     (funcall fn (make-instance 'text-output-sink :target s))))
 239
 240 ;;;; Names
 241
 242 (eval-when (:compile-toplevel :load-toplevel :execute)
 243   (defvar *xsl* "http://www.w3.org/1999/XSL/Transform")
 244   (defvar *xml* "http://www.w3.org/XML/1998/namespace")
 245   (defvar *html* "http://www.w3.org/1999/xhtml"))
 246
 247 (defun of-name (local-name)
 248   (stp:of-name local-name *xsl*))
 249
 250 (defun namep (node local-name)
 251   (and (typep node '(or stp:element stp:attribute))
 252        (equal (stp:namespace-uri node) *xsl*)
 253        (equal (stp:local-name node) local-name)))
 254
 255
 256 ;;;; PARSE-STYLESHEET
 257
 258 (defstruct stylesheet
 259   (modes (make-hash-table :test 'equal))
 260   (global-variables ())
 261   (output-specification (make-output-specification))
 262   (strip-tests nil)
 263   (named-templates (make-hash-table :test 'equal))
 264   (attribute-sets (make-hash-table :test 'equal))
 265   (keys (make-hash-table :test 'equal))
 266   (namespace-aliases (make-hash-table :test 'equal)))
 267
 268 (defstruct mode (templates nil))
 269
 270 (defun find-mode (stylesheet local-name &optional uri)
 271   (gethash (cons local-name uri) (stylesheet-modes stylesheet)))
 272
 273 (defun ensure-mode (stylesheet &optional local-name uri)
 274   (or (find-mode stylesheet local-name uri)
 275       (setf (gethash (cons local-name uri) (stylesheet-modes stylesheet))
 276             (make-mode))))
 277
 278 (defun ensure-mode/qname (stylesheet qname env)
 279   (if qname
 280       (multiple-value-bind (local-name uri)
 281           (decode-qname qname env nil)
 282         (ensure-mode stylesheet local-name uri))
 283       (find-mode stylesheet nil)))
 284
 285 (defun acons-namespaces (element &optional (bindings *namespaces*))
 286   (map-namespace-declarations (lambda (prefix uri)
 287                                 (push (cons prefix uri) bindings))
 288                               element)
 289   bindings)
 290
 291 (defun find-key (name stylesheet)
 292   (or (gethash name (stylesheet-keys stylesheet))
 293       (xslt-error "unknown key: ~a" name)))
 294
 295 (defun make-key (match use) (cons match use))
 296
 297 (defun key-match (key) (car key))
 298
 299 (defun key-use (key) (cdr key))
 300
 301 (defun add-key (stylesheet name match use)
 302   (if (gethash name (stylesheet-keys stylesheet))
 303       (xslt-error "duplicate key: ~a" name)
 304       (setf (gethash name (stylesheet-keys stylesheet))
 305             (make-key match use))))
 306
 307 (defvar *excluded-namespaces* (list *xsl*))
 308 (defvar *empty-mode*)
 309
 310 (defvar *xsl-include-stack* nil)
 311
 312 (defun uri-to-pathname (uri)
 313   (cxml::uri-to-pathname (puri:parse-uri uri)))
 314
 315 (defun parse-stylesheet-to-stp (input uri-resolver)
 316   (let* ((d (cxml:parse input (make-text-normalizer (cxml-stp:make-builder))))
 317          (<transform> (stp:document-element d)))
 318     (strip-stylesheet <transform>)
 319     ;; FIXME: handle embedded stylesheets
 320     (unless (and (equal (stp:namespace-uri <transform>) *xsl*)
 321                  (or (equal (stp:local-name <transform>) "transform")
 322                      (equal (stp:local-name <transform>) "stylesheet")))
 323       (xslt-error "not a stylesheet"))
 324     (dolist (include (stp:filter-children (of-name "include") <transform>))
 325       (let* ((uri (puri:merge-uris (stp:attribute-value include "href")
 326                                    (stp:base-uri include)))
 327              (uri (if uri-resolver
 328                       (funcall uri-resolver (puri:render-uri uri nil))
 329                       uri))
 330              (str (puri:render-uri uri nil))
 331              (pathname
 332               (handler-case
 333                   (uri-to-pathname uri)
 334                 (cxml:xml-parse-error (c)
 335                   (xslt-error "cannot find included stylesheet ~A: ~A"
 336                               uri c)))))
 337         (with-open-file
 338             (stream pathname
 339                     :element-type '(unsigned-byte 8)
 340                     :if-does-not-exist nil)
 341           (unless stream
 342             (xslt-error "cannot find included stylesheet ~A at ~A"
 343                         uri pathname))
 344           (when (find str *xsl-include-stack* :test #'equal)
 345             (xslt-error "recursive inclusion of ~A" uri))
 346           (let* ((*xsl-include-stack* (cons str *xsl-include-stack*))
 347                  (<transform>2 (parse-stylesheet-to-stp stream uri-resolver)))
 348             (stp:do-children (child <transform>2)
 349               (stp:insert-child-after <transform>
 350                                       (stp:copy child)
 351                                       include))
 352             (stp:detach include)))))
 353     <transform>))
 354
 355 (defvar *instruction-base-uri*)
 356 (defvar *apply-imports-limit*)
 357 (defvar *import-priority*)
 358 (defvar *extension-namespaces*)
 359
 360 (defun parse-1-stylesheet (env stylesheet designator uri-resolver)
 361   (let* ((<transform> (parse-stylesheet-to-stp designator uri-resolver))
 362          (*instruction-base-uri* (stp:base-uri <transform>))
 363          (*namespaces* (acons-namespaces <transform>))
 364          (*apply-imports-limit* (1+ *import-priority*))
 365          (*extension-namespaces* nil))
 366     (dolist (import (stp:filter-children (of-name "import") <transform>))
 367       (let ((uri (puri:merge-uris (stp:attribute-value import "href")
 368                                   (stp:base-uri import))))
 369         (parse-imported-stylesheet env stylesheet uri uri-resolver)))
 370     (incf *import-priority*)
 371     (parse-exclude-result-prefixes! <transform> env)
 372     (parse-extension-element-prefixes <transform> env)
 373     (parse-global-variables! stylesheet <transform>)
 374     (parse-keys! stylesheet <transform> env)
 375     (parse-templates! stylesheet <transform> env)
 376     (parse-output! stylesheet <transform>)
 377     (parse-strip/preserve-space! stylesheet <transform> env)
 378     (parse-attribute-sets! stylesheet <transform> env)
 379     (parse-namespace-aliases! stylesheet <transform> env)))
 380
 381 (defvar *xsl-import-stack* nil)
 382
 383 (defun parse-imported-stylesheet (env stylesheet uri uri-resolver)
 384   (let* ((uri (if uri-resolver
 385                   (funcall uri-resolver (puri:render-uri uri nil))
 386                   uri))
 387          (str (puri:render-uri uri nil))
 388          (pathname
 389           (handler-case
 390               (uri-to-pathname uri)
 391             (cxml:xml-parse-error (c)
 392               (xslt-error "cannot find imported stylesheet ~A: ~A"
 393                           uri c)))))
 394     (with-open-file
 395         (stream pathname
 396                 :element-type '(unsigned-byte 8)
 397                 :if-does-not-exist nil)
 398       (unless stream
 399         (xslt-error "cannot find imported stylesheet ~A at ~A"
 400                     uri pathname))
 401       (when (find str *xsl-import-stack* :test #'equal)
 402         (xslt-error "recursive inclusion of ~A" uri))
 403       (let ((*xsl-import-stack* (cons str *xsl-import-stack*)))
 404         (parse-1-stylesheet env stylesheet stream uri-resolver)))))
 405
 406 (defun parse-stylesheet (designator &key uri-resolver)
 407   (let* ((*import-priority* 0)
 408          (puri:*strict-parse* nil)
 409          (stylesheet (make-stylesheet))
 410          (env (make-instance 'lexical-xslt-environment))
 411          (*excluded-namespaces* *excluded-namespaces*)
 412          (*global-variable-declarations* (make-empty-declaration-array)))
 413     (ensure-mode stylesheet nil)
 414     (parse-1-stylesheet env stylesheet designator uri-resolver)
 415     ;; reverse attribute sets:
 416     (let ((table (stylesheet-attribute-sets stylesheet)))
 417       (maphash (lambda (k v)
 418                  (setf (gethash k table) (nreverse v)))
 419                table))
 420     stylesheet))
 421
 422 (defun parse-attribute-sets! (stylesheet <transform> env)
 423   (dolist (elt (stp:filter-children (of-name "attribute-set") <transform>))
 424     (push (let* ((sets
 425                   (mapcar (lambda (qname)
 426                             (multiple-value-list (decode-qname qname env nil)))
 427                           (words
 428                            (stp:attribute-value elt "use-attribute-sets"))))
 429                  (instructions
 430                   (stp:map-children 'list #'parse-instruction elt))
 431                  (*lexical-variable-declarations*
 432                   (make-empty-declaration-array))
 433                  (thunk
 434                   (compile-instruction `(progn ,@instructions) env))
 435                  (n-variables (length *lexical-variable-declarations*)))
 436             (lambda (ctx)
 437               (with-stack-limit ()
 438                 (loop for (local-name uri nil) in sets do
 439                      (dolist (thunk (find-attribute-set local-name uri))
 440                        (funcall thunk ctx)))
 441                 (let ((*lexical-variable-values*
 442                        (make-variable-value-array n-variables)))
 443                   (funcall thunk ctx)))))
 444           (gethash (multiple-value-bind (local-name uri)
 445                        (decode-qname (stp:attribute-value elt "name") env nil)
 446                      (cons local-name uri))
 447                    (stylesheet-attribute-sets stylesheet)))))
 448
 449 (defun parse-namespace-aliases! (stylesheet <transform> env)
 450   (dolist (elt (stp:filter-children (of-name "namespace-alias") <transform>))
 451     (stp:with-attributes (stylesheet-prefix result-prefix) elt
 452       (setf (gethash
 453              (xpath-sys:environment-find-namespace env stylesheet-prefix)
 454              (stylesheet-namespace-aliases stylesheet))
 455             (xpath-sys:environment-find-namespace env result-prefix)))))
 456
 457 (defun parse-exclude-result-prefixes! (<transform> env)
 458   (stp:with-attributes (exclude-result-prefixes) <transform>
 459     (dolist (prefix (words (or exclude-result-prefixes "")))
 460       (when (equal prefix "#default")
 461         (setf prefix nil))
 462       (push (or (xpath-sys:environment-find-namespace env prefix)
 463                 (xslt-error "namespace not found: ~A" prefix))
 464             *excluded-namespaces*))))
 465
 466 (defun parse-extension-element-prefixes (<transform> env)
 467   (stp:with-attributes (extension-element-prefixes) <transform>
 468     (dolist (prefix (words (or extension-element-prefixes "")))
 469       (when (equal prefix "#default")
 470         (setf prefix nil))
 471       (let ((uri
 472              (or (xpath-sys:environment-find-namespace env prefix)
 473                  (xslt-error "namespace not found: ~A" prefix))))
 474         (unless (equal uri *xsl*)
 475           (push uri *extension-namespaces*)
 476           (push uri *excluded-namespaces*))))))
 477
 478 (defun parse-strip/preserve-space! (stylesheet <transform> env)
 479   (xpath:with-namespaces ((nil #.*xsl*))
 480     (dolist (elt (stp:filter-children (lambda (x)
 481                                         (or (namep x "strip-space")
 482                                             (namep x "preserve-space")))
 483                                       <transform>))
 484       (let ((*namespaces* (acons-namespaces elt))
 485             (mode
 486              (if (equal (stp:local-name elt) "strip-space")
 487                  :strip
 488                  :preserve)))
 489         (dolist (name-test (words (stp:attribute-value elt "elements")))
 490           (let* ((pos (search ":*" name-test))
 491                  (test-function
 492                   (cond
 493                     ((eql pos (- (length name-test) 2))
 494                      (let* ((prefix (subseq name-test 0 pos))
 495                             (name-test-uri
 496                              (xpath-sys:environment-find-namespace env prefix)))
 497                        (unless (xpath::nc-name-p prefix)
 498                          (xslt-error "not an NCName: ~A" prefix))
 499                        (lambda (local-name uri)
 500                          (declare (ignore local-name))
 501                          (if (equal uri name-test-uri)
 502                              mode
 503                              nil))))
 504                     ((equal name-test "*")
 505                      (lambda (local-name uri)
 506                        (declare (ignore local-name uri))
 507                        mode))
 508                     (t
 509                      (multiple-value-bind (name-test-local-name name-test-uri)
 510                          (decode-qname name-test env nil)
 511                        (lambda (local-name uri)
 512                          (if (and (equal local-name name-test-local-name)
 513                                   (equal uri name-test-uri))
 514                              mode
 515                              nil)))))))
 516             (push test-function (stylesheet-strip-tests stylesheet))))))))
 517
 518 (defstruct (output-specification
 519              (:conc-name "OUTPUT-"))
 520   method
 521   indent
 522   omit-xml-declaration
 523   encoding)
 524
 525 (defun parse-output! (stylesheet <transform>)
 526   (let ((outputs (stp:filter-children (of-name "output") <transform>)))
 527     (when outputs
 528       (when (cdr outputs)
 529         ;; FIXME:
 530         ;;   - concatenate cdata-section-elements
 531         ;;   - the others must not conflict
 532         (error "oops, merging of output elements not supported yet"))
 533       (let ((<output> (car outputs))
 534             (spec (stylesheet-output-specification stylesheet)))
 535         (stp:with-attributes (;; version
 536                               method
 537                               indent
 538                               encoding
 539 ;;;                           media-type
 540 ;;;                           doctype-system
 541 ;;;                           doctype-public
 542                               omit-xml-declaration
 543 ;;;                           standalone
 544 ;;;                           cdata-section-elements
 545                               )
 546             <output>
 547           (setf (output-method spec) method)
 548           (setf (output-indent spec) indent)
 549           (setf (output-encoding spec) encoding)
 550           (setf (output-omit-xml-declaration spec) omit-xml-declaration))))))
 551
 552 (defun make-empty-declaration-array ()
 553   (make-array 1 :fill-pointer 0 :adjustable t))
 554
 555 (defun make-variable-value-array (n-lexical-variables)
 556   (make-array n-lexical-variables :initial-element 'unbound))
 557
 558 (defun compile-global-variable (<variable> env) ;; also for <param>
 559   (stp:with-attributes (name select) <variable>
 560     (when (and select (stp:list-children <variable>))
 561       (xslt-error "variable with select and body"))
 562     (let* ((*lexical-variable-declarations* (make-empty-declaration-array))
 563            (inner (cond
 564                     (select
 565                      (compile-xpath select env))
 566                     ((stp:list-children <variable>)
 567                      (let* ((inner-sexpr `(progn ,@(parse-body <variable>)))
 568                             (inner-thunk (compile-instruction inner-sexpr env)))
 569                        (lambda (ctx)
 570                          (apply-to-result-tree-fragment ctx inner-thunk))))
 571                     (t
 572                      (lambda (ctx)
 573                        (declare (ignore ctx))
 574                        ""))))
 575            (n-lexical-variables (length *lexical-variable-declarations*)))
 576       (xslt-trace-thunk
 577        (lambda (ctx)
 578          (let* ((*lexical-variable-values*
 579                  (make-variable-value-array n-lexical-variables)))
 580            (funcall inner ctx)))
 581        "global ~s (~s) = ~s" name select :result))))
 582
 583 (defstruct (variable-information
 584              (:constructor make-variable)
 585              (:conc-name "VARIABLE-"))
 586   index
 587   thunk
 588   local-name
 589   uri
 590   param-p
 591   thunk-setter)
 592
 593 (defun parse-global-variable! (<variable> global-env) ;; also for <param>
 594   (let ((*namespaces* (acons-namespaces <variable>))
 595         (qname (stp:attribute-value <variable> "name")))
 596     (unless qname
 597       (xslt-error "name missing in ~A" (stp:local-name <variable>)))
 598     (multiple-value-bind (local-name uri)
 599         (decode-qname qname global-env nil)
 600       ;; For the normal compilation environment of templates, install it
 601       ;; into *GLOBAL-VARIABLE-DECLARATIONS*:
 602       (let ((index (intern-global-variable local-name uri)))
 603         ;; For the evaluation of a global variable itself, build a thunk
 604         ;; that lazily resolves other variables, stored into
 605         ;; INITIAL-GLOBAL-VARIABLE-THUNKS:
 606         (let* ((value-thunk :unknown)
 607                (global-variable-thunk
 608                 (lambda (ctx)
 609                   (let ((v (global-variable-value index nil)))
 610                     (when (eq v 'seen)
 611                       (xslt-error "recursive variable definition"))
 612                     (cond
 613                       ((eq v 'unbound)
 614                        ;; (print (list :computing index))
 615                        (setf (global-variable-value index) 'seen)
 616                        (setf (global-variable-value index)
 617                              (funcall value-thunk ctx))
 618                        #+nil (print (list :done-computing index
 619                                     (global-variable-value index)))
 620                        #+nil (global-variable-value index))
 621                       (t
 622                        #+nil(print (list :have
 623                                     index v))
 624                        v)))))
 625                (thunk-setter
 626                 (lambda ()
 627                   (setf value-thunk
 628                         (compile-global-variable <variable> global-env)))))
 629           (setf (gethash (cons local-name uri)
 630                          (initial-global-variable-thunks global-env))
 631                 global-variable-thunk)
 632           (make-variable :index index
 633                          :local-name local-name
 634                          :uri uri
 635                          :thunk global-variable-thunk
 636                          :param-p (namep <variable> "param")
 637                          :thunk-setter thunk-setter))))))
 638
 639 (defun parse-keys! (stylesheet <transform> env)
 640   (xpath:with-namespaces ((nil #.*xsl*))
 641     (xpath:do-node-set
 642         (<key> (xpath:evaluate "key" <transform>))
 643       (stp:with-attributes (name match use) <key>
 644         (unless name (xslt-error "key name attribute not specified"))
 645         (unless match (xslt-error "key match attribute not specified"))
 646         (unless use (xslt-error "key use attribute not specified"))
 647         (add-key stylesheet name
 648                  (compile-xpath `(xpath:xpath ,(parse-key-pattern match)) env)
 649                  (compile-xpath use env))))))
 650
 651 (defun parse-global-variables! (stylesheet <transform>)
 652   (xpath:with-namespaces ((nil #.*xsl*))
 653     (let* ((table (make-hash-table :test 'equal))
 654            (global-env (make-instance 'global-variable-environment
 655                                       :initial-global-variable-thunks table))
 656            (specs '()))
 657       (xpath:do-node-set
 658           (<variable> (xpath:evaluate "variable|param" <transform>))
 659         (let ((var (parse-global-variable! <variable> global-env)))
 660           (xslt-trace "parsing global variable ~s (uri ~s)"
 661                       (variable-local-name var)
 662                       (variable-uri var))
 663           (when (find var
 664                       specs
 665                       :test (lambda (a b)
 666                               (and (equal (variable-local-name a)
 667                                           (variable-local-name b))
 668                                    (equal (variable-uri a)
 669                                           (variable-uri b)))))
 670             (xslt-error "duplicate definition for global variable ~A"
 671                         (variable-local-name var)))
 672           (push var specs)))
 673       ;; now that the global environment knows about all variables, run the
 674       ;; thunk setters to perform their compilation
 675       (setf specs (nreverse specs))
 676       (mapc (lambda (spec) (funcall (variable-thunk-setter spec))) specs)
 677       (setf (stylesheet-global-variables stylesheet) specs))))
 678
 679 (defun parse-templates! (stylesheet <transform> env)
 680   (let ((i 0))
 681     (dolist (<template> (stp:filter-children (of-name "template") <transform>))
 682       (let ((*namespaces* (acons-namespaces <template>)))
 683         (dolist (template (compile-template <template> env i))
 684           (let ((name (template-name template)))
 685             (if name
 686                 (let* ((table (stylesheet-named-templates stylesheet))
 687                        (head (car (gethash name table))))
 688                   (when (and head (eql (template-import-priority head)
 689                                        (template-import-priority template)))
 690                     ;; fixme: is this supposed to be a run-time error?
 691                     (xslt-error "conflicting templates for ~A" name))
 692                   (push template (gethash name table)))
 693                 (let ((mode (ensure-mode/qname stylesheet
 694                                                (template-mode-qname template)
 695                                                env)))
 696                   (setf (template-mode template) mode)
 697                   (push template (mode-templates mode)))))))
 698       (incf i))))
 699
 700
 701 ;;;; APPLY-STYLESHEET
 702
 703 (defvar *stylesheet*)
 704 (defvar *mode*)
 705
 706 (deftype xml-designator () '(or runes:xstream runes:rod array stream pathname))
 707
 708 (defstruct (parameter
 709              (:constructor make-parameter (value local-name &optional uri)))
 710   (uri "")
 711   local-name
 712   value)
 713
 714 (defun find-parameter-value (local-name uri parameters)
 715   (dolist (p parameters)
 716     (when (and (equal (parameter-local-name p) local-name)
 717                (equal (parameter-uri p) uri))
 718       (return (parameter-value p)))))
 719
 720 (defvar *uri-resolver*)
 721
 722 (defun parse-allowing-microsoft-bom (pathname handler)
 723   (with-open-file (s pathname :element-type '(unsigned-byte 8))
 724     (unless (and (eql (read-byte s nil) #xef)
 725                  (eql (read-byte s nil) #xbb)
 726                  (eql (read-byte s nil) #xbf))
 727       (file-position s 0))
 728     (cxml:parse s handler)))
 729
 730 (defun %document (uri-string base-uri)
 731   (let* ((absolute-uri
 732           (puri:merge-uris uri-string base-uri))
 733          (resolved-uri
 734           (if *uri-resolver*
 735               (funcall *uri-resolver* (puri:render-uri absolute-uri nil))
 736               absolute-uri))
 737          (pathname
 738           (handler-case
 739               (uri-to-pathname resolved-uri)
 740             (cxml:xml-parse-error (c)
 741               (xslt-error "cannot find referenced document ~A: ~A"
 742                           resolved-uri c))))
 743          (document
 744           (handler-case
 745               (parse-allowing-microsoft-bom pathname (stp:make-builder))
 746             ((or file-error cxml:xml-parse-error) (c)
 747               (xslt-error "cannot parse referenced document ~A: ~A"
 748                           pathname c))))
 749          (xpath-root-node
 750           (make-whitespace-stripper document
 751                                     (stylesheet-strip-tests *stylesheet*))))
 752     (when (puri:uri-fragment absolute-uri)
 753       (xslt-error "use of fragment identifiers in document() not supported"))
 754     xpath-root-node))
 755
 756 (xpath-sys:define-extension xslt *xsl*)
 757
 758 (xpath-sys:define-xpath-function/lazy
 759     xslt :document
 760     (object &optional node-set)
 761   (let ((instruction-base-uri *instruction-base-uri*))
 762     (lambda (ctx)
 763       (let* ((object (funcall object ctx))
 764              (node-set (and node-set (funcall node-set ctx)))
 765              (uri
 766               (when node-set
 767                 ;; FIXME: should use first node of the node set
 768                 ;; _in document order_
 769                 (xpath-protocol:base-uri (xpath:first-node node-set)))))
 770         (xpath-sys:make-node-set
 771          (if (xpath:node-set-p object)
 772              (xpath:map-node-set->list
 773               (lambda (node)
 774                 (%document (xpath:string-value node)
 775                            (or uri (xpath-protocol:base-uri node))))
 776               object)
 777              (list (%document (xpath:string-value object)
 778                               (or uri instruction-base-uri)))))))))
 779
 780 (xpath-sys:define-xpath-function/eager xslt :key (name object)
 781   (handler-case
 782       (let ((key (find-key (xpath:string-value name) *stylesheet*)))
 783         (labels ((get-by-key (value)
 784                    (let ((value (xpath:string-value value)))
 785                      (xpath::filter-pipe
 786                       #'(lambda (node)
 787                           (equal value (xpath:string-value
 788                                         (xpath:evaluate-compiled
 789                                          (key-use key) node))))
 790                       (xpath-sys:pipe-of
 791                        (xpath:node-set-value
 792                         (xpath:evaluate-compiled
 793                          (key-match key) xpath:context)))))))
 794           (xpath-sys:make-node-set
 795            (xpath::sort-pipe
 796             (if (xpath:node-set-p object)
 797                 (xpath::mappend-pipe #'get-by-key (xpath-sys:pipe-of object))
 798                 (get-by-key object))))))
 799     ;; fixme: the extension mechanism would turn our condition into an
 800     ;; ERROR otherwise
 801     (xslt-error (c)
 802       (xpath::xpath-error "~A" c))))
 803
 804 ;; FIXME: add alias mechanism for XPath extensions in order to avoid duplication
 805
 806 (xpath-sys:define-xpath-function/lazy xslt :current ()
 807   #'(lambda (ctx)
 808       (xpath-sys:make-node-set
 809        (xpath-sys:make-pipe
 810         (xpath:context-starting-node ctx)
 811         nil))))
 812
 813 (xpath-sys:define-xpath-function/lazy xslt :unparsed-entity-uri (name)
 814   #'(lambda (ctx)
 815       (or (xpath-protocol:unparsed-entity-uri (xpath:context-node ctx)
 816                                               (funcall name ctx))
 817           "")))
 818
 819 (xpath-sys:define-xpath-function/lazy xslt :generate-id (&optional node-set-thunk)
 820   (if node-set-thunk
 821       #'(lambda (ctx)
 822           (xpath-sys:get-node-id (xpath:node-set-value (funcall node-set-thunk ctx))))
 823       #'(lambda (ctx)
 824           (xpath-sys:get-node-id (xpath:context-node ctx)))))
 825
 826 (xpath-sys:define-xpath-function/lazy xslt :element-available (qname)
 827   (let ((namespaces *namespaces*))
 828     #'(lambda (ctx)
 829         (let ((qname (funcall qname ctx)))
 830           (multiple-value-bind (local-name uri)
 831               (decode-qname/runtime qname namespaces nil)
 832             (and (equal uri *xsl*)
 833                  (gethash local-name *available-instructions*)
 834                  t))))))
 835
 836 (xpath-sys:define-xpath-function/lazy xslt :function-available (qname)
 837   (let ((namespaces *namespaces*))
 838     #'(lambda (ctx)
 839         (let ((qname (funcall qname ctx)))
 840           (multiple-value-bind (local-name uri)
 841               (decode-qname/runtime qname namespaces nil)
 842             (and (zerop (length uri))
 843                  (or (xpath-sys:find-xpath-function local-name *xsl*)
 844                      (xpath-sys:find-xpath-function local-name uri))
 845                  t))))))
 846
 847 (defun apply-stylesheet
 848     (stylesheet source-document
 849      &key output parameters uri-resolver navigator)
 850   (when (typep stylesheet 'xml-designator)
 851     (setf stylesheet (parse-stylesheet stylesheet)))
 852   (when (typep source-document 'xml-designator)
 853     (setf source-document (cxml:parse source-document (stp:make-builder))))
 854   (invoke-with-output-sink
 855    (lambda ()
 856      (handler-case*
 857          (let* ((xpath:*navigator* (or navigator :default-navigator))
 858                 (puri:*strict-parse* nil)
 859                 (*stylesheet* stylesheet)
 860                 (*mode* (find-mode stylesheet nil))
 861                 (*empty-mode* (make-mode))
 862                 (global-variable-specs
 863                  (stylesheet-global-variables stylesheet))
 864                 (*global-variable-values*
 865                  (make-variable-value-array (length global-variable-specs)))
 866                 (*uri-resolver* uri-resolver)
 867                 (xpath-root-node
 868                  (make-whitespace-stripper
 869                   source-document
 870                   (stylesheet-strip-tests stylesheet)))
 871                 (ctx (xpath:make-context xpath-root-node)))
 872            (mapc (lambda (spec)
 873                    (when (variable-param-p spec)
 874                      (let ((value
 875                             (find-parameter-value (variable-local-name spec)
 876                                                   (variable-uri spec)
 877                                                   parameters)))
 878                        (when value
 879                          (setf (global-variable-value (variable-index spec))
 880                                value)))))
 881                  global-variable-specs)
 882            (mapc (lambda (spec)
 883                    (funcall (variable-thunk spec) ctx))
 884                  global-variable-specs)
 885            #+nil (print global-variable-specs)
 886            #+nil (print *global-variable-values*)
 887            ;; zzz we wouldn't have to mask float traps here if we used the
 888            ;; XPath API properly.  Unfortunately I've been using FUNCALL
 889            ;; everywhere instead of EVALUATE, so let's paper over that
 890            ;; at a central place to be sure:
 891            (xpath::with-float-traps-masked ()
 892              (apply-templates ctx)))
 893        (xpath:xpath-error (c)
 894                           (xslt-error "~A" c))))
 895    (stylesheet-output-specification stylesheet)
 896    output))
 897
 898 (defun find-attribute-set (local-name uri)
 899   (or (gethash (cons local-name uri) (stylesheet-attribute-sets *stylesheet*))
 900       (xslt-error "no such attribute set: ~A/~A" local-name uri)))
 901
 902 (defun apply-templates/list (list &optional param-bindings sort-predicate)
 903   (when sort-predicate
 904     (setf list (sort list sort-predicate)))
 905   (let* ((n (length list))
 906          (s/d (lambda () n)))
 907     (loop
 908        for i from 1
 909        for child in list
 910        do
 911          (apply-templates (xpath:make-context child s/d i)
 912            param-bindings))))
 913
 914 (defvar *stack-limit* 200)
 915
 916 (defun invoke-with-stack-limit (fn)
 917   (let ((*stack-limit* (1- *stack-limit*)))
 918     (unless (plusp *stack-limit*)
 919       (xslt-error "*stack-limit* reached; stack overflow"))
 920     (funcall fn)))
 921
 922 (defun invoke-template (ctx template param-bindings)
 923   (let ((*lexical-variable-values*
 924          (make-variable-value-array (template-n-variables template))))
 925     (with-stack-limit ()
 926       (loop
 927          for (name-cons value) in param-bindings
 928          for (nil index nil) = (find name-cons
 929                                      (template-params template)
 930                                      :test #'equal
 931                                      :key #'car)
 932          do
 933          (unless index
 934            (xslt-error "invalid template parameter ~A" name-cons))
 935          (setf (lexical-variable-value index) value))
 936       (funcall (template-body template) ctx))))
 937
 938 (defun apply-default-templates (ctx)
 939   (let ((node (xpath:context-node ctx)))
 940     (cond
 941       ((or (xpath-protocol:node-type-p node :processing-instruction)
 942            (xpath-protocol:node-type-p node :comment)))
 943       ((or (xpath-protocol:node-type-p node :text)
 944            (xpath-protocol:node-type-p node :attribute))
 945        (write-text (xpath-protocol:node-text node)))
 946       (t
 947        (apply-templates/list
 948         (xpath::force
 949          (xpath-protocol:child-pipe node)))))))
 950
 951 (defvar *apply-imports*)
 952
 953 (defun apply-applicable-templates (ctx templates param-bindings finally)
 954   (labels ((apply-imports ()
 955              (if templates
 956                  (let* ((this (pop templates))
 957                         (low (template-apply-imports-limit this))
 958                         (high (template-import-priority this)))
 959                    (setf templates
 960                          (remove-if-not
 961                           (lambda (x)
 962                             (<= low (template-import-priority x) high))
 963                           templates))
 964                    (invoke-template ctx this param-bindings))
 965                  (funcall finally))))
 966     (let ((*apply-imports* #'apply-imports))
 967       (apply-imports))))
 968
 969 (defun apply-templates (ctx &optional param-bindings)
 970   (apply-applicable-templates ctx
 971                               (find-templates ctx)
 972                               param-bindings
 973                               (lambda ()
 974                                 (apply-default-templates ctx))))
 975
 976 (defun call-template (ctx name &optional param-bindings)
 977   (apply-applicable-templates ctx
 978                               (find-named-templates name)
 979                               param-bindings
 980                               (lambda ()
 981                                 (error "cannot find named template: ~s"
 982                                        name))))
 983
 984 (defun find-templates (ctx)
 985   (let* ((matching-candidates
 986           (remove-if-not (lambda (template)
 987                            (template-matches-p template ctx))
 988                          (mode-templates *mode*)))
 989          (npriorities
 990           (if matching-candidates
 991               (1+ (reduce #'max
 992                           matching-candidates
 993                           :key #'template-import-priority))
 994               0))
 995          (priority-groups (make-array npriorities :initial-element nil)))
 996     (dolist (template matching-candidates)
 997       (push template
 998             (elt priority-groups (template-import-priority template))))
 999 ;;;     (print (map 'list #'length priority-groups))
1000 ;;;     (force-output)
1001     (loop
1002        for i from (1- npriorities) downto 0
1003        for group = (elt priority-groups i)
1004        for template = (maximize #'template< group)
1005        when template
1006        collect template)))
1007
1008 (defun find-named-templates (name)
1009   (gethash name (stylesheet-named-templates *stylesheet*)))
1010
1011 (defun template< (a b)                  ;assuming same import priority
1012   (let ((p (template-priority a))
1013         (q (template-priority b)))
1014     (cond
1015       ((< p q) t)
1016       ((> p q) nil)
1017       (t
1018        (xslt-cerror "conflicting templates:~_~A,~_~A"
1019                     (template-match-expression a)
1020                     (template-match-expression b))
1021        (< (template-position a) (template-position b))))))
1022
1023 (defun maximize (< things)
1024   (when things
1025     (let ((max (car things)))
1026       (dolist (other (cdr things))
1027         (when (funcall < max other)
1028           (setf max other)))
1029       max)))
1030
1031 (defun template-matches-p (template ctx)
1032   (find (xpath:context-node ctx)
1033         (xpath:all-nodes (funcall (template-match-thunk template) ctx))))
1034
1035 (defun invoke-with-output-sink (fn output-spec output)
1036   (etypecase output
1037     (pathname
1038      (with-open-file (s output
1039                         :direction :output
1040                         :element-type '(unsigned-byte 8)
1041                         :if-exists :rename-and-delete)
1042        (invoke-with-output-sink fn output-spec s)))
1043     ((or stream null)
1044      (invoke-with-output-sink fn
1045                               output-spec
1046                               (make-output-sink output-spec output)))
1047     ((or hax:abstract-handler sax:abstract-handler)
1048      (with-xml-output output
1049        (funcall fn)))))
1050
1051 (defun make-output-sink (output-spec stream)
1052   (let* ((ystream
1053           (if stream
1054               (let ((et (stream-element-type stream)))
1055                 (cond
1056                   ((or (null et) (subtypep et '(unsigned-byte 8)))
1057                    (runes:make-octet-stream-ystream stream))
1058                   ((subtypep et 'character)
1059                    (runes:make-character-stream-ystream stream))))
1060               (runes:make-rod-ystream)))
1061          (omit-xml-declaration-p
1062           (equal (output-omit-xml-declaration output-spec) "yes"))
1063          (sax-target
1064           (make-instance 'cxml::sink
1065                          :ystream ystream
1066                          :omit-xml-declaration-p omit-xml-declaration-p)))
1067     (if (equalp (output-method output-spec) "HTML")
1068         (make-instance 'combi-sink
1069                        :hax-target (make-instance 'chtml::sink
1070                                                   :ystream ystream)
1071                        :sax-target sax-target
1072                        :encoding (output-encoding output-spec))
1073         sax-target)))
1074
1075 (defstruct template
1076   match-expression
1077   match-thunk
1078   name
1079   import-priority
1080   apply-imports-limit
1081   priority
1082   position
1083   mode
1084   mode-qname
1085   params
1086   body
1087   n-variables)
1088
1089 (defun expression-priority (form)
1090   (let ((step (second form)))
1091     (if (and (null (cddr form))
1092              (listp step)
1093              (member (car step) '(:child :attribute))
1094              (null (cddr step)))
1095         (let ((name (second step)))
1096           (cond
1097             ((or (stringp name)
1098                  (and (consp name)
1099                       (or (eq (car name) :qname)
1100                           (eq (car name) :processing-instruction))))
1101              0.0)
1102             ((and (consp name)
1103                   (or (eq (car name) :namespace)
1104                       (eq (car name) '*)))
1105              -0.25)
1106             (t
1107              -0.5)))
1108         0.5)))
1109
1110 (defun valid-expression-p (expr)
1111   (cond
1112     ((atom expr) t)
1113     ((eq (first expr) :path)
1114      (every (lambda (x)
1115               (let ((filter (third x)))
1116                 (or (null filter) (valid-expression-p filter))))
1117             (cdr expr)))
1118     ((eq (first expr) :variable)        ;(!)
1119      nil)
1120     (t
1121      (every #'valid-expression-p (cdr expr)))))
1122
1123 (defun parse-xpath (str)
1124   (handler-case
1125       (xpath:parse-xpath str)
1126     (xpath:xpath-error (c)
1127       (xslt-error "~A" c))))
1128
1129 ;; zzz also use naive-pattern-expression here?
1130 (defun parse-key-pattern (str)
1131   (let ((parsed
1132          (mapcar #'(lambda (item)
1133                      `(:path (:root :node)
1134                              (:descendant-or-self *)
1135                              ,@(cdr item)))
1136                  (parse-pattern str))))
1137     (if (null (rest parsed))
1138         (first parsed)
1139         `(:union ,@parsed))))
1140
1141 (defun parse-pattern (str)
1142   ;; zzz check here for anything not allowed as an XSLT pattern
1143   ;; zzz can we hack id() and key() here?
1144   (let ((form (parse-xpath str)))
1145     (unless (consp form)
1146       (xslt-error "not a valid pattern: ~A" str))
1147     (labels ((process-form (form)
1148                (cond ((eq (car form) :union)
1149                       (alexandria:mappend #'process-form (rest form)))
1150                      ((not (or (eq (car form) :path)
1151                                (and (eq (car form) :filter)
1152                                     (let ((filter (second form)))
1153                                       (and (consp filter)
1154                                            (member (car filter)
1155                                                    '(:key :id))))
1156                                     (equal (third form) '(:true)))
1157                                (member (car form) '(:key :id))))
1158                       (xslt-error "not a valid pattern: ~A ~A" str form))
1159                      ((not (valid-expression-p form))
1160                       (xslt-error "invalid filter"))
1161                      (t (list form)))))
1162       (process-form form))))
1163
1164 (defun naive-pattern-expression (x)
1165   (ecase (car x)
1166     (:path `(:path (:ancestor-or-self :node) ,@(cdr x)))
1167     ((:filter :key :id) x)))
1168
1169 (defun compile-value-thunk (value env)
1170   (if (and (listp value) (eq (car value) 'progn))
1171       (let ((inner-thunk (compile-instruction value env)))
1172         (lambda (ctx)
1173           (apply-to-result-tree-fragment ctx inner-thunk)))
1174       (compile-xpath value env)))
1175
1176 (defun compile-var-bindings/nointern (forms env)
1177   (loop
1178     for (name value) in forms
1179     collect (multiple-value-bind (local-name uri)
1180                 (decode-qname name env nil)
1181               (list (cons local-name uri)
1182                     (xslt-trace-thunk
1183                      (compile-value-thunk value env)
1184                      "local variable ~s = ~s" name :result)))))
1185
1186 (defun compile-var-bindings (forms env)
1187   (loop
1188      for (cons thunk) in (compile-var-bindings/nointern forms env)
1189      for (local-name . uri) = cons
1190      collect (list cons
1191                    (push-variable local-name
1192                                   uri
1193                                   *lexical-variable-declarations*)
1194                    thunk)))
1195
1196 (defun compile-template (<template> env position)
1197   (stp:with-attributes (match name priority mode) <template>
1198     (unless (or name match)
1199       (xslt-error "missing match in template"))
1200     (multiple-value-bind (params body-pos)
1201         (loop
1202           for i from 0
1203           for child in (stp:list-children <template>)
1204           while (namep child "param")
1205           collect (parse-param child) into params
1206           finally (return (values params i)))
1207       (let* ((*lexical-variable-declarations* (make-empty-declaration-array))
1208              (param-bindings (compile-var-bindings params env))
1209              (body (parse-body <template> body-pos (mapcar #'car params)))
1210              (body-thunk (compile-instruction `(progn ,@body) env))
1211              (outer-body-thunk
1212               (xslt-trace-thunk
1213                #'(lambda (ctx)
1214                    (unwind-protect
1215                        (progn
1216                          ;; set params that weren't initialized by apply-templates
1217                          (loop for (name index param-thunk) in param-bindings
1218                                when (eq (lexical-variable-value index nil) 'unbound)
1219                                  do (setf (lexical-variable-value index)
1220                                           (funcall param-thunk ctx)))
1221                          (funcall body-thunk ctx))))
1222                "template: match = ~s name = ~s" match name))
1223              (n-variables (length *lexical-variable-declarations*)))
1224         (append
1225          (when name
1226            (multiple-value-bind (local-name uri)
1227                (decode-qname name env nil)
1228              (list
1229               (make-template :name (cons local-name uri)
1230                              :import-priority *import-priority*
1231                              :apply-imports-limit *apply-imports-limit*
1232                              :params param-bindings
1233                              :body outer-body-thunk
1234                              :n-variables n-variables))))
1235          (when match
1236            (mapcar (lambda (expression)
1237                      (let ((match-thunk
1238                             (xslt-trace-thunk
1239                              (compile-xpath
1240                               `(xpath:xpath
1241                                 ,(naive-pattern-expression expression))
1242                               env)
1243                              "match-thunk for template (match ~s): ~s --> ~s"
1244                              match expression :result))
1245                            (p (if priority
1246                                   (parse-number:parse-number priority)
1247                                   (expression-priority expression))))
1248                        (make-template :match-expression expression
1249                                       :match-thunk match-thunk
1250                                       :import-priority *import-priority*
1251                                       :apply-imports-limit *apply-imports-limit*
1252                                       :priority p
1253                                       :position position
1254                                       :mode-qname mode
1255                                       :params param-bindings
1256                                       :body outer-body-thunk
1257                                       :n-variables n-variables)))
1258                    (parse-pattern match))))))))
1259 #+(or)
1260 (xuriella::parse-stylesheet #p"/home/david/src/lisp/xuriella/test.xsl")