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 (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"))
  40
  41
  42 ;;;; XSLT-ERROR
  43
  44 (define-condition xslt-error (simple-error)
  45   ()
  46   (:documentation "The class of all XSLT errors."))
  47
  48 (define-condition recoverable-xslt-error (xslt-error)
  49   ()
  50   (:documentation "The class of recoverable XSLT errors."))
  51
  52 (defun xslt-error (fmt &rest args)
  53   (error 'xslt-error :format-control fmt :format-arguments args))
  54
  55 ;; Many errors in XSLT are "recoverable", with a specified action that must
  56 ;; be taken if the error isn't raised.  My original plan was to implement
  57 ;; such issues as continuable conditions, so that users are alerted about
  58 ;; portability issues with their stylesheet, but can contiue anyway.
  59 ;;
  60 ;; However, our current test suite driver compares against Saxon results,
  61 ;; and Saxon recovers (nearly) always.  So our coverage of these errors
  62 ;; is very incomplete.
  63 ;;
  64 ;; Re-enable this code once we can check that it's actually being used
  65 ;; everywhere.
  66 (defun xslt-cerror (fmt &rest args)
  67   (declare (ignore fmt args))
  68   #+(or)
  69   (with-simple-restart (recover "recover")
  70     (error 'recoverable-xslt-error
  71            :format-control fmt
  72            :format-arguments args)))
  73
  74 (defvar *debug* nil)
  75
  76 (defmacro handler-case* (form &rest clauses)
  77   ;; like HANDLER-CASE if *DEBUG* is off.  If it's on, don't establish
  78   ;; a handler at all so that we see the real stack traces.  (We could use
  79   ;; HANDLER-BIND here and check at signalling time, but doesn't seem
  80   ;; important.)
  81   (let ((doit (gensym)))
  82     `(flet ((,doit () ,form))
  83        (if *debug*
  84            (,doit)
  85            (handler-case
  86                (,doit)
  87              ,@clauses)))))
  88
  89 (defmacro with-resignalled-errors ((&optional) &body body)
  90   `(invoke-with-resignalled-errors (lambda () ,@body)))
  91
  92 (defun invoke-with-resignalled-errors (fn)
  93   (handler-bind
  94       ((xpath:xpath-error
  95         (lambda (c)
  96           (xslt-error "~A" c)))
  97        (babel-encodings:character-encoding-error
  98         (lambda (c)
  99           (xslt-error "~A" c))))
 100     (funcall fn)))
 101
 102 (defmacro with-forward-compatible-errors (error-form &body body)
 103   `(invoke-with-forward-compatible-errors (lambda () ,@body)
 104                                           (lambda () ,error-form)))
 105
 106 (defvar *forwards-compatible-p*)
 107
 108 (defun invoke-with-forward-compatible-errors (fn error-fn)
 109   (let ((result))
 110     (tagbody
 111        (handler-bind
 112            ((xpath:xpath-error
 113              (lambda (c)
 114                (declare (ignore c))
 115                (when *forwards-compatible-p*
 116                  (go error)))))
 117          (setf result (funcall fn)))
 118        (go done)
 119      error
 120        (setf result (funcall error-fn))
 121      done)
 122     result))
 123
 124 (defun compile-xpath (xpath &optional env)
 125   (with-resignalled-errors ()
 126     (with-forward-compatible-errors
 127         (lambda (ctx)
 128           (xslt-error "attempt to evaluate an XPath expression with compile-time errors, delayed due to forwards compatible processing: ~A"
 129                       xpath))
 130       (xpath:compile-xpath xpath env))))
 131
 132 (defmacro with-stack-limit ((&optional) &body body)
 133   `(invoke-with-stack-limit (lambda () ,@body)))
 134
 135 (defparameter *without-xslt-current-p* nil)
 136
 137 (defmacro without-xslt-current ((&optional) &body body)
 138   `(invoke-without-xslt-current (lambda () ,@body)))
 139
 140 (defun invoke-without-xslt-current (fn)
 141   (let ((*without-xslt-current-p* t))
 142     (funcall fn)))
 143
 144 ;;; (defun invoke-without-xslt-current (fn)
 145 ;;;   (let ((non-extensions (gethash "" xpath::*extensions*))
 146 ;;;         (xpath::*extensions*
 147 ;;;          ;; hide XSLT extensions
 148 ;;;          (make-hash-table :test #'equal)))
 149 ;;;     (setf (gethash "" xpath::*extensions*) non-extensions)
 150 ;;;     (funcall fn)))
 151
 152
 153 ;;;; Helper functions and macros
 154
 155 (defun check-for-invalid-attributes (valid-names node)
 156   (labels ((check-attribute (a)
 157              (unless
 158                  (let ((uri (stp:namespace-uri a)))
 159                    (or (and (plusp (length uri)) (not (equal uri *xsl*)))
 160                        (find (cons (stp:local-name a) uri)
 161                              valid-names
 162                              :test #'equal)))
 163                (xslt-error "attribute ~A not allowed on ~A"
 164                            (stp:local-name a)
 165                            (stp:local-name node)))))
 166     (stp:map-attributes nil #'check-attribute node)))
 167
 168 (defmacro only-with-attributes ((&rest specs) node &body body)
 169   (let ((valid-names
 170          (mapcar (lambda (entry)
 171                    (if (and (listp entry) (cdr entry))
 172                        (destructuring-bind (name &optional (uri ""))
 173                            (cdr entry)
 174                          (cons name uri))
 175                        (cons (string-downcase
 176                               (princ-to-string
 177                                (symbol-name entry)))
 178                              "")))
 179                  specs))
 180         (%node (gensym)))
 181     `(let ((,%NODE ,node))
 182        (check-for-invalid-attributes ',valid-names ,%NODE)
 183        (stp:with-attributes ,specs ,%NODE
 184          ,@body))))
 185
 186 (defun map-pipe-eagerly (fn pipe)
 187   (xpath::enumerate pipe :key fn :result nil))
 188
 189 (defmacro do-pipe ((var pipe &optional result) &body body)
 190   `(block nil
 191      (map-pipe-eagerly #'(lambda (,var) ,@body) ,pipe)
 192      ,result))
 193
 194
 195 ;;;; XSLT-ENVIRONMENT and XSLT-CONTEXT
 196
 197 (defparameter *initial-namespaces*
 198   '((nil . "")
 199     ("xmlns" . #"http://www.w3.org/2000/xmlns/")
 200     ("xml" . #"http://www.w3.org/XML/1998/namespace")))
 201
 202 (defparameter *namespaces*
 203   *initial-namespaces*)
 204
 205 (defvar *global-variable-declarations*)
 206 (defvar *lexical-variable-declarations*)
 207
 208 (defvar *global-variable-values*)
 209 (defvar *lexical-variable-values*)
 210
 211 (defclass xslt-environment () ())
 212
 213 (defun split-qname (str)
 214   (handler-case
 215       (multiple-value-bind (prefix local-name)
 216           (cxml::split-qname str)
 217         (unless
 218             ;; FIXME: cxml should really offer a function that does
 219             ;; checks for NCName and QName in a sensible way for user code.
 220             ;; cxml::split-qname is tailored to the needs of the parser.
 221             ;;
 222             ;; For now, let's just check the syntax explicitly.
 223             (and (or (null prefix) (xpath::nc-name-p prefix))
 224                  (xpath::nc-name-p local-name))
 225           (xslt-error "not a qname: ~A" str))
 226         (values prefix local-name))
 227     (cxml:well-formedness-violation ()
 228       (xslt-error "not a qname: ~A" str))))
 229
 230 (defun decode-qname (qname env attributep &key allow-unknown-namespace)
 231   (unless qname
 232     (xslt-error "missing name"))
 233   (multiple-value-bind (prefix local-name)
 234       (split-qname qname)
 235     (values local-name
 236             (if (or prefix (not attributep))
 237                 (or (xpath-sys:environment-find-namespace env (or prefix ""))
 238                     (if allow-unknown-namespace
 239                         nil
 240                         (xslt-error "namespace not found: ~A" prefix)))
 241                 "")
 242             prefix)))
 243
 244 (defmethod xpath-sys:environment-find-namespace ((env xslt-environment) prefix)
 245   (or (cdr (assoc prefix *namespaces* :test 'equal))
 246       ;; zzz gross hack.
 247       ;; Change the entire code base to represent "no prefix" as the
 248       ;; empty string consistently.  unparse.lisp has already been changed.
 249       (and (equal prefix "")
 250            (cdr (assoc nil *namespaces* :test 'equal)))
 251       (and (eql prefix nil)
 252            (cdr (assoc "" *namespaces* :test 'equal)))))
 253
 254 (defun find-variable-index (local-name uri table)
 255   (position (cons local-name uri) table :test 'equal))
 256
 257 (defun intern-global-variable (local-name uri)
 258   (or (find-variable-index local-name uri *global-variable-declarations*)
 259       (push-variable local-name uri *global-variable-declarations*)))
 260
 261 (defun push-variable (local-name uri table)
 262   (prog1
 263       (length table)
 264     (vector-push-extend (cons local-name uri) table)))
 265
 266 (defun lexical-variable-value (index &optional (errorp t))
 267   (let ((result (svref *lexical-variable-values* index)))
 268     (when errorp
 269       (assert (not (eq result 'unbound))))
 270     result))
 271
 272 (defun (setf lexical-variable-value) (newval index)
 273   (assert (not (eq newval 'unbound)))
 274   (setf (svref *lexical-variable-values* index) newval))
 275
 276 (defun global-variable-value (index &optional (errorp t))
 277   (let ((result (svref *global-variable-values* index)))
 278     (when errorp
 279       (assert (not (eq result 'unbound))))
 280     result))
 281
 282 (defun (setf global-variable-value) (newval index)
 283   (assert (not (eq newval 'unbound)))
 284   (setf (svref *global-variable-values* index) newval))
 285
 286 (defmethod xpath-sys:environment-find-function
 287     ((env xslt-environment) lname uri)
 288   (or (if (string= uri "")
 289           (or (xpath-sys:find-xpath-function lname *xsl*)
 290               (xpath-sys:find-xpath-function lname uri))
 291           (xpath-sys:find-xpath-function lname uri))
 292       (when *forwards-compatible-p*
 293         (lambda (&rest ignore)
 294           (declare (ignore ignore))
 295           (xslt-error "attempt to call an unknown XPath function (~A); error delayed until run-time due to forwards compatible processing"
 296                       lname)))))
 297
 298 (defmethod xpath-sys:environment-find-variable
 299     ((env xslt-environment) lname uri)
 300   (let ((index
 301          (find-variable-index lname uri *lexical-variable-declarations*)))
 302     (when index
 303       (lambda (ctx)
 304         (declare (ignore ctx))
 305         (svref *lexical-variable-values* index)))))
 306
 307 (defclass lexical-xslt-environment (xslt-environment) ())
 308
 309 (defmethod xpath-sys:environment-find-variable
 310     ((env lexical-xslt-environment) lname uri)
 311   (or (call-next-method)
 312       (let ((index
 313              (find-variable-index lname uri *global-variable-declarations*)))
 314         (when index
 315           (xslt-trace-thunk
 316            (lambda (ctx)
 317              (declare (ignore ctx))
 318              (svref *global-variable-values* index))
 319            "global ~s (uri ~s) = ~s" lname uri :result)))))
 320
 321 (defclass key-environment (xslt-environment) ())
 322
 323 (defmethod xpath-sys:environment-find-variable
 324     ((env key-environment) lname uri)
 325   (declare (ignore lname uri))
 326   (xslt-error "disallowed variable reference"))
 327
 328 (defclass global-variable-environment (xslt-environment)
 329   ((initial-global-variable-thunks
 330     :initarg :initial-global-variable-thunks
 331     :accessor initial-global-variable-thunks)))
 332
 333 (defmethod xpath-sys:environment-find-variable
 334     ((env global-variable-environment) lname uri)
 335   (or (call-next-method)
 336       (gethash (cons lname uri) (initial-global-variable-thunks env))))
 337
 338
 339 ;;;; TOPLEVEL-TEXT-OUTPUT-SINK
 340 ;;;;
 341 ;;;; A sink that serializes only text not contained in any element.
 342
 343 (defmacro with-toplevel-text-output-sink ((var) &body body)
 344   `(invoke-with-toplevel-text-output-sink (lambda (,var) ,@body)))
 345
 346 (defclass toplevel-text-output-sink (sax:default-handler)
 347   ((target :initarg :target :accessor text-output-sink-target)
 348    (depth :initform 0 :accessor textoutput-sink-depth)))
 349
 350 (defmethod sax:start-element ((sink toplevel-text-output-sink)
 351                               namespace-uri local-name qname attributes)
 352   (declare (ignore namespace-uri local-name qname attributes))
 353   (incf (textoutput-sink-depth sink)))
 354
 355 (defmethod sax:characters ((sink toplevel-text-output-sink) data)
 356   (when (zerop (textoutput-sink-depth sink))
 357     (write-string data (text-output-sink-target sink))))
 358
 359 (defmethod sax:unescaped ((sink toplevel-text-output-sink) data)
 360   (sax:characters sink data))
 361
 362 (defmethod sax:end-element ((sink toplevel-text-output-sink)
 363                               namespace-uri local-name qname)
 364   (declare (ignore namespace-uri local-name qname))
 365   (decf (textoutput-sink-depth sink)))
 366
 367 (defun invoke-with-toplevel-text-output-sink (fn)
 368   (with-output-to-string (s)
 369     (funcall fn (make-instance 'toplevel-text-output-sink :target s))))
 370
 371
 372 ;;;; TEXT-FILTER
 373 ;;;;
 374 ;;;; A sink that passes through only text (at any level) and turns to
 375 ;;;; into unescaped characters.
 376
 377 (defclass text-filter (sax:default-handler)
 378   ((target :initarg :target :accessor text-filter-target)))
 379
 380 (defmethod sax:characters ((sink text-filter) data)
 381   (sax:unescaped (text-filter-target sink) data))
 382
 383 (defmethod sax:unescaped ((sink text-filter) data)
 384   (sax:unescaped (text-filter-target sink) data))
 385
 386 (defmethod sax:end-document ((sink text-filter))
 387   (sax:end-document (text-filter-target sink)))
 388
 389 (defun make-text-filter (target)
 390   (make-instance 'text-filter :target target))
 391
 392
 393 ;;;; ESCAPER
 394 ;;;;
 395 ;;;; A sink that recovers from sax:unescaped using sax:characters, as per
 396 ;;;; XSLT 16.4.
 397
 398 (defclass escaper (cxml:broadcast-handler)
 399   ())
 400
 401 (defmethod sax:unescaped ((sink escaper) data)
 402   (sax:characters sink data))
 403
 404 (defun make-escaper (target)
 405   (make-instance 'escaper :handlers (list target)))
 406
 407
 408 ;;;; Names
 409
 410 (defun of-name (local-name)
 411   (stp:of-name local-name *xsl*))
 412
 413 (defun namep (node local-name)
 414   (and (typep node '(or stp:element stp:attribute))
 415        (equal (stp:namespace-uri node) *xsl*)
 416        (equal (stp:local-name node) local-name)))
 417
 418
 419 ;;;; PARSE-STYLESHEET
 420
 421 (defstruct stylesheet
 422   (modes (make-hash-table :test 'equal))
 423   (global-variables (make-empty-declaration-array))
 424   (output-specification (make-output-specification))
 425   (strip-tests nil)
 426   (strip-thunk nil)
 427   (named-templates (make-hash-table :test 'equal))
 428   (attribute-sets (make-hash-table :test 'equal))
 429   (keys (make-hash-table :test 'equal))
 430   (namespace-aliases (make-hash-table :test 'equal))
 431   (decimal-formats (make-hash-table :test 'equal))
 432   (initial-global-variable-thunks (make-hash-table :test 'equal)))
 433
 434 (defstruct mode
 435   (templates nil)
 436   (match-thunk (lambda (ignore) (declare (ignore ignore)) nil)))
 437
 438 (defun find-mode (stylesheet local-name &optional uri)
 439   (gethash (cons local-name uri) (stylesheet-modes stylesheet)))
 440
 441 (defun ensure-mode (stylesheet &optional local-name uri)
 442   (or (find-mode stylesheet local-name uri)
 443       (setf (gethash (cons local-name uri) (stylesheet-modes stylesheet))
 444             (make-mode))))
 445
 446 (defun ensure-mode/qname (stylesheet qname env)
 447   (if qname
 448       (multiple-value-bind (local-name uri)
 449           (decode-qname qname env nil)
 450         (ensure-mode stylesheet local-name uri))
 451       (find-mode stylesheet nil)))
 452
 453 (defun acons-namespaces
 454     (element &optional (bindings *namespaces*) include-redeclared)
 455   (map-namespace-declarations (lambda (prefix uri)
 456                                 (push (cons prefix uri) bindings))
 457                               element
 458                               include-redeclared)
 459   bindings)
 460
 461 (defun find-key (name stylesheet)
 462   (or (gethash name (stylesheet-keys stylesheet))
 463       (xslt-error "unknown key: ~a" name)))
 464
 465 (defun make-key (match use) (cons match use))
 466
 467 (defun key-match (key) (car key))
 468
 469 (defun key-use (key) (cdr key))
 470
 471 (defun add-key (stylesheet name match use)
 472   (push (make-key match use)
 473         (gethash name (stylesheet-keys stylesheet))))
 474
 475 (defvar *excluded-namespaces* (list *xsl*))
 476 (defvar *empty-mode*)
 477 (defvar *default-mode*)
 478
 479 (defvar *xsl-include-stack* nil)
 480
 481 (defun uri-to-pathname (uri)
 482   (cxml::uri-to-pathname (puri:parse-uri uri)))
 483
 484 ;; Why this extra check for literal result element used as stylesheets,
 485 ;; instead of a general check for every literal result element?  Because
 486 ;; Stylesheet__91804 says so.
 487 (defun check-Errors_err035 (literal-result-element)
 488   (let ((*namespaces* (acons-namespaces literal-result-element))
 489         (env (make-instance 'lexical-xslt-environment)))
 490     (stp:with-attributes ((extension-element-prefixes
 491                            "extension-element-prefixes"
 492                            *xsl*))
 493         literal-result-element
 494       (dolist (prefix (words (or extension-element-prefixes "")))
 495         (if (equal prefix "#default")
 496             (setf prefix nil)
 497             (unless (cxml-stp-impl::nc-name-p prefix)
 498               (xslt-error "invalid prefix: ~A" prefix)))
 499         (let ((uri
 500                (or (xpath-sys:environment-find-namespace env prefix)
 501                    (xslt-error "namespace not found: ~A" prefix))))
 502           (when (equal uri (stp:namespace-uri literal-result-element))
 503             (xslt-error "literal result element used as stylesheet, but is ~
 504                          declared as an extension element")))))))
 505
 506 (defun unwrap-2.3 (document)
 507   (let ((literal-result-element (stp:document-element document))
 508         (new-template (stp:make-element "template" *xsl*))
 509         (new-document-element (stp:make-element "stylesheet" *xsl*)))
 510     (check-Errors_err035 literal-result-element)
 511     (setf (stp:attribute-value new-document-element "version")
 512           (or (stp:attribute-value literal-result-element "version" *xsl*)
 513               (xslt-error "not a stylesheet: root element lacks xsl:version")))
 514     (setf (stp:attribute-value new-template "match") "/")
 515     (setf (stp:document-element document) new-document-element)
 516     (stp:append-child new-document-element new-template)
 517     (stp:append-child new-template literal-result-element)
 518     new-document-element))
 519
 520 (defun parse-stylesheet-to-stp (input uri-resolver)
 521   (let* ((d (cxml:parse input (make-text-normalizer (cxml-stp:make-builder))))
 522          (<transform> (stp:document-element d)))
 523     (unless (equal (stp:namespace-uri <transform>) *xsl*)
 524       (setf <transform> (unwrap-2.3 d)))
 525     (strip-stylesheet <transform>)
 526     (unless (and (equal (stp:namespace-uri <transform>) *xsl*)
 527                  (or (equal (stp:local-name <transform>) "transform")
 528                      (equal (stp:local-name <transform>) "stylesheet")))
 529       (xslt-error "not a stylesheet"))
 530     (check-for-invalid-attributes
 531      '(("version" . "")
 532        ("exclude-result-prefixes" . "")
 533        ("extension-element-prefixes" . "")
 534        ("space" . "http://www.w3.org/XML/1998/namespace")
 535        ("id" . ""))
 536      <transform>)
 537     (let ((invalid
 538            (or (stp:find-child-if (of-name "stylesheet") <transform>)
 539                (stp:find-child-if (of-name "transform") <transform>))))
 540       (when invalid
 541         (xslt-error "invalid top-level element ~A" (stp:local-name invalid))))
 542     (dolist (include (stp:filter-children (of-name "include") <transform>))
 543       (let* ((uri (puri:merge-uris (or (stp:attribute-value include "href")
 544                                        (xslt-error "include without href"))
 545                                    (stp:base-uri include)))
 546              (uri (if uri-resolver
 547                       (funcall uri-resolver uri)
 548                       uri))
 549              (str (puri:render-uri uri nil))
 550              (pathname
 551               (handler-case
 552                   (uri-to-pathname uri)
 553                 (cxml:xml-parse-error (c)
 554                   (xslt-error "cannot find included stylesheet ~A: ~A"
 555                               uri c)))))
 556         (with-open-file
 557             (stream pathname
 558                     :element-type '(unsigned-byte 8)
 559                     :if-does-not-exist nil)
 560           (unless stream
 561             (xslt-error "cannot find included stylesheet ~A at ~A"
 562                         uri pathname))
 563           (when (find str *xsl-include-stack* :test #'equal)
 564             (xslt-error "recursive inclusion of ~A" uri))
 565           (let* ((*xsl-include-stack* (cons str *xsl-include-stack*))
 566                  (<transform>2 (parse-stylesheet-to-stp stream uri-resolver)))
 567             (stp:insert-child-after <transform>
 568                                     (stp:copy <transform>2)
 569                                     include)
 570             (stp:detach include)))))
 571     <transform>))
 572
 573 (defvar *instruction-base-uri*) ;misnamed, is also used in other attributes
 574 (defvar *apply-imports-limit*)
 575 (defvar *import-priority*)
 576 (defvar *extension-namespaces*)
 577
 578 (defmacro do-toplevel ((var xpath <transform>) &body body)
 579   `(map-toplevel (lambda (,var) ,@body) ,xpath ,<transform>))
 580
 581 (defun map-toplevel (fn xpath <transform>)
 582   (dolist (node (list-toplevel xpath <transform>))
 583     (let ((*namespaces* *initial-namespaces*))
 584       (xpath:do-node-set (ancestor (xpath:evaluate "ancestor::node()" node))
 585         (xpath:with-namespaces (("" #.*xsl*))
 586           (when (xpath:node-matches-p ancestor "stylesheet|transform")
 587             ;; discard namespaces from including stylesheets
 588             (setf *namespaces* *initial-namespaces*)))
 589         (when (xpath-protocol:node-type-p ancestor :element)
 590           (setf *namespaces* (acons-namespaces ancestor *namespaces* t))))
 591       (funcall fn node))))
 592
 593 (defun list-toplevel (xpath <transform>)
 594   (labels ((recurse (sub)
 595              (let ((subsubs
 596                     (xpath-sys:pipe-of
 597                      (xpath:evaluate "transform|stylesheet" sub))))
 598                (xpath::append-pipes
 599                 (xpath-sys:pipe-of (xpath:evaluate xpath sub))
 600                 (xpath::mappend-pipe #'recurse subsubs)))))
 601     (xpath::sort-nodes (recurse <transform>))))
 602
 603 (defmacro with-import-magic ((node env) &body body)
 604   `(invoke-with-import-magic (lambda () ,@body) ,node ,env))
 605
 606 (defun invoke-with-import-magic (fn node env)
 607   (unless (or (namep node "stylesheet") (namep node "transform"))
 608     (setf node (stp:parent node)))
 609   (let ((*excluded-namespaces* (list *xsl*))
 610         (*extension-namespaces* '())
 611         (*forwards-compatible-p*
 612          (not (equal (stp:attribute-value node "version") "1.0"))))
 613     (parse-exclude-result-prefixes! node env)
 614     (parse-extension-element-prefixes! node env)
 615     (funcall fn)))
 616
 617 (defun parse-1-stylesheet (env stylesheet designator uri-resolver)
 618   (let* ((<transform> (parse-stylesheet-to-stp designator uri-resolver))
 619          (instruction-base-uri (stp:base-uri <transform>))
 620          (namespaces (acons-namespaces <transform>))
 621          (apply-imports-limit (1+ *import-priority*))
 622          (continuations '()))
 623     (let ((*namespaces* namespaces))
 624       (invoke-with-import-magic (constantly t) <transform> env))
 625     (do-toplevel (elt "node()" <transform>)
 626       (let ((version (stp:attribute-value (stp:parent elt) "version")))
 627         (cond
 628           ((null version)
 629            (xslt-error "stylesheet lacks version"))
 630           ((equal version "1.0")
 631            (if (typep elt 'stp:element)
 632                (when (or (equal (stp:namespace-uri elt) "")
 633                          (and (equal (stp:namespace-uri elt) *xsl*)
 634                               (not (find (stp:local-name elt)
 635                                          '("key" "template" "output"
 636                                            "strip-space" "preserve-space"
 637                                            "attribute-set" "namespace-alias"
 638                                            "decimal-format" "variable" "param"
 639                                            "import" "include"
 640                                            ;; for include handling:
 641                                            "stylesheet" "transform")
 642                                          :test #'equal))))
 643                  (xslt-error "unknown top-level element ~A" (stp:local-name elt)))
 644                (xslt-error "text at top-level"))))))
 645     (macrolet ((with-specials ((&optional) &body body)
 646                  `(let ((*instruction-base-uri* instruction-base-uri)
 647                         (*namespaces* namespaces)
 648                         (*apply-imports-limit* apply-imports-limit))
 649                     ,@body)))
 650       (with-specials ()
 651         (do-toplevel (import "import" <transform>)
 652           (when (let ((prev (xpath:first-node
 653                              (xpath:evaluate "preceding-sibling::*"
 654                                              import
 655                                              t))))
 656                   (and prev (not (namep prev "import"))))
 657             (xslt-error "import not at beginning of stylesheet"))
 658           (let ((uri (puri:merge-uris (or (stp:attribute-value import "href")
 659                                           (xslt-error "import without href"))
 660                                       (stp:base-uri import))))
 661             (push (parse-imported-stylesheet env stylesheet uri uri-resolver)
 662                   continuations))))
 663       (let ((import-priority
 664              (incf *import-priority*))
 665             (var-cont (prepare-global-variables stylesheet <transform>)))
 666         (parse-namespace-aliases! stylesheet <transform> env)
 667         ;; delay the rest of compilation until we've seen all global
 668         ;; variables:
 669         (lambda ()
 670           (mapc #'funcall (nreverse continuations))
 671           (with-specials ()
 672             (let ((*import-priority* import-priority))
 673               (funcall var-cont)
 674               (parse-keys! stylesheet <transform> env)
 675               (parse-templates! stylesheet <transform> env)
 676               (parse-output! stylesheet <transform> env)
 677               (parse-strip/preserve-space! stylesheet <transform> env)
 678               (parse-attribute-sets! stylesheet <transform> env)
 679               (parse-decimal-formats! stylesheet <transform> env))))))))
 680
 681 (defvar *xsl-import-stack* nil)
 682
 683 (defun parse-imported-stylesheet (env stylesheet uri uri-resolver)
 684   (let* ((uri (if uri-resolver
 685                   (funcall uri-resolver uri)
 686                   uri))
 687          (str (puri:render-uri uri nil))
 688          (pathname
 689           (handler-case
 690               (uri-to-pathname uri)
 691             (cxml:xml-parse-error (c)
 692               (xslt-error "cannot find imported stylesheet ~A: ~A"
 693                           uri c)))))
 694     (with-open-file
 695         (stream pathname
 696                 :element-type '(unsigned-byte 8)
 697                 :if-does-not-exist nil)
 698       (unless stream
 699         (xslt-error "cannot find imported stylesheet ~A at ~A"
 700                     uri pathname))
 701       (when (find str *xsl-import-stack* :test #'equal)
 702         (xslt-error "recursive inclusion of ~A" uri))
 703       (let ((*xsl-import-stack* (cons str *xsl-import-stack*)))
 704         (parse-1-stylesheet env stylesheet stream uri-resolver)))))
 705
 706 (defvar *included-attribute-sets*)
 707
 708 (defun parse-stylesheet (designator &key uri-resolver)
 709   (with-resignalled-errors ()
 710     (xpath:with-namespaces ((nil #.*xsl*))
 711       (let* ((*import-priority* 0)
 712              (xpath:*allow-variables-in-patterns* nil)
 713              (puri:*strict-parse* nil)
 714              (stylesheet (make-stylesheet))
 715              (*stylesheet*
 716               ;; zzz this is for remove-excluded-namespaces only
 717               stylesheet)
 718              (env (make-instance 'lexical-xslt-environment))
 719              (*excluded-namespaces* *excluded-namespaces*)
 720              (*global-variable-declarations* (make-empty-declaration-array))
 721              (*included-attribute-sets* nil))
 722         (ensure-mode stylesheet nil)
 723         (funcall (parse-1-stylesheet env stylesheet designator uri-resolver))
 724         ;; reverse attribute sets:
 725         (let ((table (stylesheet-attribute-sets stylesheet)))
 726           (maphash (lambda (k v)
 727                      (setf (gethash k table) (nreverse v)))
 728                    table))
 729         ;; for Errors_err011
 730         (dolist (sets *included-attribute-sets*)
 731           (loop for (local-name uri nil) in sets do
 732                (find-attribute-set local-name uri stylesheet)))
 733         ;; add default df
 734         (unless (find-decimal-format "" "" stylesheet nil)
 735           (setf (find-decimal-format "" "" stylesheet)
 736                 (make-decimal-format)))
 737         ;; compile a template matcher for each mode:
 738         (loop
 739            for mode being each hash-value in (stylesheet-modes stylesheet)
 740            do
 741              (setf (mode-match-thunk mode)
 742                    (xpath:make-pattern-matcher
 743                     (mapcar #'template-compiled-pattern
 744                             (mode-templates mode)))))
 745         ;; and for the strip tests
 746         (setf (stylesheet-strip-thunk stylesheet)
 747               (let ((patterns (stylesheet-strip-tests stylesheet)))
 748                 (and patterns
 749                      (xpath:make-pattern-matcher
 750                       (mapcar #'strip-test-compiled-pattern patterns)))))
 751         stylesheet))))
 752
 753 (defun parse-attribute-sets! (stylesheet <transform> env)
 754   (do-toplevel (elt "attribute-set" <transform>)
 755     (with-import-magic (elt env)
 756       (push (let* ((sets
 757                     (mapcar (lambda (qname)
 758                               (multiple-value-list (decode-qname qname env nil)))
 759                             (words
 760                              (stp:attribute-value elt "use-attribute-sets"))))
 761                    (instructions
 762                     (stp:map-children
 763                      'list
 764                      (lambda (child)
 765                        (unless
 766                            (and (typep child 'stp:element)
 767                                 (or (and (equal (stp:namespace-uri child) *xsl*)
 768                                          (equal (stp:local-name child)
 769                                                 "attribute"))
 770                                     (find (stp:namespace-uri child)
 771                                           *extension-namespaces*
 772                                           :test 'equal)))
 773                          (xslt-error "non-attribute found in attribute set"))
 774                        (parse-instruction child))
 775                      elt))
 776                    (*lexical-variable-declarations*
 777                     (make-empty-declaration-array))
 778                    (thunk
 779                     (compile-instruction `(progn ,@instructions) env))
 780                    (n-variables (length *lexical-variable-declarations*)))
 781               (push sets *included-attribute-sets*)
 782               (lambda (ctx)
 783                 (with-stack-limit ()
 784                   (loop for (local-name uri nil) in sets do
 785                        (dolist (thunk (find-attribute-set local-name uri))
 786                          (funcall thunk ctx)))
 787                   (let ((*lexical-variable-values*
 788                          (make-variable-value-array n-variables)))
 789                     (funcall thunk ctx)))))
 790             (gethash (multiple-value-bind (local-name uri)
 791                          (decode-qname (or (stp:attribute-value elt "name")
 792                                            (xslt-error "missing name"))
 793                                        env
 794                                        nil)
 795                        (cons local-name uri))
 796                      (stylesheet-attribute-sets stylesheet))))))
 797
 798 (defun parse-namespace-aliases! (stylesheet <transform> env)
 799   (do-toplevel (elt "namespace-alias" <transform>)
 800     (let ((*namespaces* (acons-namespaces elt)))
 801       (only-with-attributes (stylesheet-prefix result-prefix) elt
 802         (unless stylesheet-prefix
 803           (xslt-error "missing stylesheet-prefix in namespace-alias"))
 804         (unless result-prefix
 805           (xslt-error "missing result-prefix in namespace-alias"))
 806         (setf (gethash
 807                (if (equal stylesheet-prefix "#default")
 808                    ""
 809                    (or (xpath-sys:environment-find-namespace
 810                         env
 811                         stylesheet-prefix)
 812                        (xslt-error "stylesheet namespace not found in alias: ~A"
 813                                    stylesheet-prefix)))
 814                (stylesheet-namespace-aliases stylesheet))
 815               (or (xpath-sys:environment-find-namespace
 816                    env
 817                    (if (equal result-prefix "#default")
 818                        ""
 819                        result-prefix))
 820                   (xslt-error "result namespace not found in alias: ~A"
 821                               result-prefix)))))))
 822
 823 (defun parse-decimal-formats! (stylesheet <transform> env)
 824   (do-toplevel (elt "decimal-format" <transform>)
 825     (stp:with-attributes (name
 826                           ;; strings
 827                           infinity
 828                           (nan "NaN")
 829                           ;; characters:
 830                           decimal-separator
 831                           grouping-separator
 832                           zero-digit
 833                           percent
 834                           per-mille
 835                           digit
 836                           pattern-separator
 837                           minus-sign)
 838         elt
 839       (multiple-value-bind (local-name uri)
 840           (if name
 841               (decode-qname name env nil)
 842               (values "" ""))
 843         (let ((current (find-decimal-format local-name uri stylesheet nil))
 844               (new
 845                (let ((seen '()))
 846                  (flet ((chr (key x)
 847                           (when x
 848                             (unless (eql (length x) 1)
 849                               (xslt-error "not a single character: ~A" x))
 850                             (let ((chr (elt x 0)))
 851                               (when (find chr seen)
 852                                 (xslt-error
 853                                  "conflicting decimal format characters: ~A"
 854                                  chr))
 855                               (push chr seen)
 856                               (list key chr))))
 857                         (str (key x)
 858                           (when x
 859                             (list key x))))
 860                    (apply #'make-decimal-format
 861                           (append (str :infinity infinity)
 862                                   (str :nan nan)
 863                                   (chr :decimal-separator decimal-separator)
 864                                   (chr :grouping-separator grouping-separator)
 865                                   (chr :zero-digit zero-digit)
 866                                   (chr :percent percent)
 867                                   (chr :per-mille per-mille)
 868                                   (chr :digit digit)
 869                                   (chr :pattern-separator pattern-separator)
 870                                   (chr :minus-sign minus-sign)))))))
 871           (if current
 872               (unless (decimal-format= current new)
 873                 (xslt-error "decimal format mismatch for ~S" local-name))
 874               (setf (find-decimal-format local-name uri stylesheet) new)))))))
 875
 876 (defun parse-exclude-result-prefixes! (node env)
 877   (stp:with-attributes (exclude-result-prefixes)
 878       node
 879     (dolist (prefix (words (or exclude-result-prefixes "")))
 880       (if (equal prefix "#default")
 881           (setf prefix nil)
 882           (unless (cxml-stp-impl::nc-name-p prefix)
 883             (xslt-error "invalid prefix: ~A" prefix)))
 884       (push (or (xpath-sys:environment-find-namespace env prefix)
 885                 (xslt-error "namespace not found: ~A" prefix))
 886             *excluded-namespaces*))))
 887
 888 (defun parse-extension-element-prefixes! (node env)
 889   (stp:with-attributes (extension-element-prefixes)
 890       node
 891     (dolist (prefix (words (or extension-element-prefixes "")))
 892       (if (equal prefix "#default")
 893           (setf prefix nil)
 894           (unless (cxml-stp-impl::nc-name-p prefix)
 895             (xslt-error "invalid prefix: ~A" prefix)))
 896       (let ((uri
 897              (or (xpath-sys:environment-find-namespace env prefix)
 898                  (xslt-error "namespace not found: ~A" prefix))))
 899         (unless (equal uri *xsl*)
 900           (push uri *extension-namespaces*)
 901           (push uri *excluded-namespaces*))))))
 902
 903 (defun parse-nametest-tokens (str)
 904   (labels ((check (boolean)
 905              (unless boolean
 906                (xslt-error "invalid nametest token")))
 907            (check-null (boolean)
 908              (check (not boolean))))
 909     (cons
 910      :patterns
 911      (mapcar (lambda (name-test)
 912                (destructuring-bind (&optional path &rest junk)
 913                    (cdr (xpath:parse-pattern-expression name-test))
 914                  (check-null junk)
 915                  (check (eq (car path) :path))
 916                  (destructuring-bind (&optional child &rest junk) (cdr path)
 917                    (check-null junk)
 918                    (check (eq (car child) :child))
 919                    (destructuring-bind (nodetest &rest junk) (cdr child)
 920                      (check-null junk)
 921                      (check (or (stringp nodetest)
 922                                 (eq nodetest '*)
 923                                 (and (consp nodetest)
 924                                      (or (eq (car nodetest) :namespace)
 925                                          (eq (car nodetest) :qname)))))))
 926                  path))
 927              (words str)))))
 928
 929 (defstruct strip-test
 930   compiled-pattern
 931   priority
 932   position
 933   value)
 934
 935 (defun parse-strip/preserve-space! (stylesheet <transform> env)
 936   (let ((i 0))
 937     (do-toplevel (elt "strip-space|preserve-space" <transform>)
 938       (let ((*namespaces* (acons-namespaces elt))
 939             (value
 940              (if (equal (stp:local-name elt) "strip-space")
 941                  :strip
 942                  :preserve)))
 943         (dolist (expression
 944                   (cdr (parse-nametest-tokens
 945                         (stp:attribute-value elt "elements"))))
 946           (let* ((compiled-pattern
 947                   (car (without-xslt-current ()
 948                          (xpath:compute-patterns
 949                           `(:patterns ,expression)
 950                           *import-priority*
 951                           "will set below"
 952                           env))))
 953                  (strip-test
 954                   (make-strip-test :compiled-pattern compiled-pattern
 955                                    :priority (expression-priority expression)
 956                                    :position i
 957                                    :value value)))
 958             (setf (xpath:pattern-value compiled-pattern) strip-test)
 959             (push strip-test (stylesheet-strip-tests stylesheet)))))
 960       (incf i))))
 961
 962 (defstruct (output-specification
 963              (:conc-name "OUTPUT-"))
 964   method
 965   indent
 966   omit-xml-declaration
 967   encoding
 968   doctype-system
 969   doctype-public
 970   cdata-section-matchers
 971   standalone-p
 972   media-type)
 973
 974 (defun parse-output! (stylesheet <transform> env)
 975   (dolist (<output> (list-toplevel "output" <transform>))
 976     (let ((spec (stylesheet-output-specification stylesheet)))
 977       (only-with-attributes (version
 978                              method
 979                              indent
 980                              encoding
 981                              media-type
 982                              doctype-system
 983                              doctype-public
 984                              omit-xml-declaration
 985                              standalone
 986                              cdata-section-elements)
 987           <output>
 988         (declare (ignore version))
 989         (when method
 990           (multiple-value-bind  (local-name uri)
 991               (decode-qname method env t)
 992             (setf (output-method spec)
 993                   (if (plusp (length uri))
 994                       nil
 995                       (cond
 996                         ((equalp local-name "HTML") :html)
 997                         ((equalp local-name "TEXT") :text)
 998                         ((equalp local-name "XML") :xml)
 999                         (t
1000                          (xslt-error "invalid output method: ~A" method)))))))
1001         (when indent
1002           (setf (output-indent spec) indent))
1003         (when encoding
1004           (setf (output-encoding spec) encoding))
1005         (when doctype-system
1006           (setf (output-doctype-system spec) doctype-system))
1007         (when doctype-public
1008           (setf (output-doctype-public spec) doctype-public))
1009         (when omit-xml-declaration
1010           (setf (output-omit-xml-declaration spec) omit-xml-declaration))
1011         (when cdata-section-elements
1012           (dolist (qname (words cdata-section-elements))
1013             (decode-qname qname env nil) ;check the syntax
1014             (push (xpath:make-pattern-matcher* qname env)
1015                   (output-cdata-section-matchers spec))))
1016         (when standalone
1017           (setf (output-standalone-p spec)
1018                 (boolean-or-error standalone)))
1019         (when media-type
1020           (setf (output-media-type spec) media-type))))))
1021
1022 (defun make-empty-declaration-array ()
1023   (make-array 1 :fill-pointer 0 :adjustable t))
1024
1025 (defun make-variable-value-array (n-lexical-variables)
1026   (make-array n-lexical-variables :initial-element 'unbound))
1027
1028 (defun compile-global-variable (<variable> env) ;; also for <param>
1029   (stp:with-attributes (name select) <variable>
1030     (when (and select (stp:list-children <variable>))
1031       (xslt-error "variable with select and body"))
1032     (let* ((*lexical-variable-declarations* (make-empty-declaration-array))
1033            (inner (cond
1034                     (select
1035                      (compile-xpath select env))
1036                     ((stp:list-children <variable>)
1037                      (let* ((inner-sexpr `(progn ,@(parse-body <variable>)))
1038                             (inner-thunk (compile-instruction inner-sexpr env)))
1039                        (lambda (ctx)
1040                          (apply-to-result-tree-fragment ctx inner-thunk))))
1041                     (t
1042                      (lambda (ctx)
1043                        (declare (ignore ctx))
1044                        ""))))
1045            (n-lexical-variables (length *lexical-variable-declarations*)))
1046       (xslt-trace-thunk
1047        (lambda (ctx)
1048          (let* ((*lexical-variable-values*
1049                  (make-variable-value-array n-lexical-variables)))
1050            (funcall inner ctx)))
1051        "global ~s (~s) = ~s" name select :result))))
1052
1053 (defstruct (variable-chain
1054              (:constructor make-variable-chain)
1055              (:conc-name "VARIABLE-CHAIN-"))
1056   definitions
1057   index
1058   local-name
1059   thunk
1060   uri)
1061
1062 (defstruct (import-variable
1063              (:constructor make-variable)
1064              (:conc-name "VARIABLE-"))
1065   value-thunk
1066   value-thunk-setter
1067   param-p)
1068
1069 (defun parse-global-variable! (stylesheet <variable> global-env)
1070   (let* ((*namespaces* (acons-namespaces <variable>))
1071          (instruction-base-uri (stp:base-uri <variable>))
1072          (*instruction-base-uri* instruction-base-uri)
1073          (*excluded-namespaces* (list *xsl*))
1074          (*extension-namespaces* '())
1075          (qname (stp:attribute-value <variable> "name")))
1076     (with-import-magic (<variable> global-env)
1077       (unless qname
1078         (xslt-error "name missing in ~A" (stp:local-name <variable>)))
1079       (multiple-value-bind (local-name uri)
1080           (decode-qname qname global-env nil)
1081         ;; For the normal compilation environment of templates, install it
1082         ;; into *GLOBAL-VARIABLE-DECLARATIONS*:
1083         (let ((index (intern-global-variable local-name uri)))
1084           ;; For the evaluation of a global variable itself, build a thunk
1085           ;; that lazily resolves other variables, stored into
1086           ;; INITIAL-GLOBAL-VARIABLE-THUNKS:
1087           (let* ((value-thunk :unknown)
1088                  (sgv (stylesheet-global-variables stylesheet))
1089                  (chain
1090                   (if (< index (length sgv))
1091                       (elt sgv index)
1092                       (make-variable-chain
1093                        :index index
1094                        :local-name local-name
1095                        :uri uri)))
1096                  (next (car (variable-chain-definitions chain)))
1097                  (global-variable-thunk
1098                   (lambda (ctx)
1099                     (let ((v (global-variable-value index nil)))
1100                       (cond
1101                         ((eq v 'seen)
1102                          (unless next
1103                            (xslt-error "no next definition for: ~A"
1104                                        local-name))
1105                          (funcall (variable-value-thunk next) ctx))
1106                         ((eq v 'unbound)
1107                          (setf (global-variable-value index) 'seen)
1108                          (setf (global-variable-value index)
1109                                (funcall value-thunk ctx)))
1110                         (t
1111                          v)))))
1112                  (excluded-namespaces *excluded-namespaces*)
1113                  (extension-namespaces *extension-namespaces*)
1114                  (variable
1115                   (make-variable :param-p (namep <variable> "param")))
1116                  (forwards-compatible-p *forwards-compatible-p*)
1117                  (value-thunk-setter
1118                   (lambda ()
1119                     (let* ((*instruction-base-uri* instruction-base-uri)
1120                            (*excluded-namespaces* excluded-namespaces)
1121                            (*extension-namespaces* extension-namespaces)
1122                            (*forwards-compatible-p* forwards-compatible-p)
1123                            (fn
1124                             (compile-global-variable <variable> global-env)))
1125                       (setf value-thunk fn)
1126                       (setf (variable-value-thunk variable) fn)))))
1127             (setf (variable-value-thunk-setter variable)
1128                   value-thunk-setter)
1129             (setf (gethash (cons local-name uri)
1130                            (initial-global-variable-thunks global-env))
1131                   global-variable-thunk)
1132             (setf (variable-chain-thunk chain) global-variable-thunk)
1133             (push variable (variable-chain-definitions chain))
1134             chain))))))
1135
1136 (defun parse-keys! (stylesheet <transform> env)
1137   (xpath:with-namespaces ((nil #.*xsl*))
1138     (do-toplevel (<key> "key" <transform>)
1139       (with-import-magic (<key> env)
1140         (let ((*instruction-base-uri* (stp:base-uri <key>)))
1141           (only-with-attributes (name match use) <key>
1142             (unless name (xslt-error "key name attribute not specified"))
1143             (unless match (xslt-error "key match attribute not specified"))
1144             (unless use (xslt-error "key use attribute not specified"))
1145             (multiple-value-bind (local-name uri)
1146                 (decode-qname name env nil)
1147               (add-key stylesheet
1148                        (cons local-name uri)
1149                        (compile-xpath `(xpath:xpath ,(parse-key-pattern match))
1150                                       env)
1151                        (compile-xpath use
1152                                       (make-instance 'key-environment))))))))))
1153
1154 (defun prepare-global-variables (stylesheet <transform>)
1155   (xpath:with-namespaces ((nil #.*xsl*))
1156     (let* ((igvt (stylesheet-initial-global-variable-thunks stylesheet))
1157            (global-env (make-instance 'global-variable-environment
1158                                       :initial-global-variable-thunks igvt))
1159            (chains '()))
1160       (do-toplevel (<variable> "variable|param" <transform>)
1161         (let ((chain
1162                (parse-global-variable! stylesheet <variable> global-env)))
1163           (xslt-trace "parsing global variable ~s (uri ~s)"
1164                       (variable-chain-local-name chain)
1165                       (variable-chain-uri chain))
1166           (when (find chain
1167                       chains
1168                       :test (lambda (a b)
1169                               (and (equal (variable-chain-local-name a)
1170                                           (variable-chain-local-name b))
1171                                    (equal (variable-chain-uri a)
1172                                           (variable-chain-uri b)))))
1173             (xslt-error "duplicate definition for global variable ~A"
1174                         (variable-chain-local-name chain)))
1175           (push chain chains)))
1176       (setf chains (nreverse chains))
1177       (let ((table (stylesheet-global-variables stylesheet))
1178             (newlen (length *global-variable-declarations*)))
1179         (adjust-array table newlen :fill-pointer newlen)
1180         (dolist (chain chains)
1181           (setf (elt table (variable-chain-index chain)) chain)))
1182       (lambda ()
1183         ;; now that the global environment knows about all variables, run the
1184         ;; thunk setters to perform their compilation
1185         (mapc (lambda (chain)
1186                 (dolist (var (variable-chain-definitions chain))
1187                   (funcall (variable-value-thunk-setter var))))
1188               chains)))))
1189
1190 (defun parse-templates! (stylesheet <transform> env)
1191   (let ((i 0))
1192     (do-toplevel (<template> "template" <transform>)
1193       (let ((*namespaces* (acons-namespaces <template>))
1194             (*instruction-base-uri* (stp:base-uri <template>)))
1195         (with-import-magic (<template> env)
1196           (dolist (template (compile-template <template> env i))
1197             (let ((name (template-name template)))
1198               (if name
1199                   (let* ((table (stylesheet-named-templates stylesheet))
1200                          (head (car (gethash name table))))
1201                     (when (and head (eql (template-import-priority head)
1202                                          (template-import-priority template)))
1203                       ;; fixme: is this supposed to be a run-time error?
1204                       (xslt-error "conflicting templates for ~A" name))
1205                     (push template (gethash name table)))
1206                   (let ((mode (ensure-mode/qname stylesheet
1207                                                  (template-mode-qname template)
1208                                                  env)))
1209                     (setf (template-mode template) mode)
1210                     (push template (mode-templates mode))))))))
1211       (incf i))))
1212
1213
1214 ;;;; APPLY-STYLESHEET
1215
1216 (defvar *stylesheet*)
1217
1218 (deftype xml-designator () '(or runes:xstream runes:rod array stream pathname))
1219
1220 (defun unalias-uri (uri)
1221   (let ((result
1222          (gethash uri (stylesheet-namespace-aliases *stylesheet*)
1223                   uri)))
1224     (check-type result string)
1225     result))
1226
1227 (defstruct (parameter
1228              (:constructor make-parameter (value local-name &optional uri)))
1229   (uri "")
1230   local-name
1231   value)
1232
1233 (defun find-parameter-value (local-name uri parameters)
1234   (dolist (p parameters)
1235     (when (and (equal (parameter-local-name p) local-name)
1236                (equal (parameter-uri p) uri))
1237       (return (parameter-value p)))))
1238
1239 (defvar *uri-resolver*)
1240
1241 (defun parse-allowing-microsoft-bom (pathname handler)
1242   (with-open-file (s pathname :element-type '(unsigned-byte 8))
1243     (unless (and (eql (read-byte s nil) #xef)
1244                  (eql (read-byte s nil) #xbb)
1245                  (eql (read-byte s nil) #xbf))
1246       (file-position s 0))
1247     (cxml:parse s handler)))
1248
1249 (defvar *documents*)
1250
1251 (defun %document (uri-string base-uri)
1252   (let* ((absolute-uri
1253           (puri:merge-uris uri-string (or base-uri "")))
1254          (resolved-uri
1255           (if *uri-resolver*
1256               (funcall *uri-resolver* absolute-uri)
1257               absolute-uri))
1258          (pathname
1259           (handler-case
1260               (uri-to-pathname resolved-uri)
1261             (cxml:xml-parse-error (c)
1262               (xslt-error "cannot find referenced document ~A: ~A"
1263                           resolved-uri c))))
1264          (xpath-root-node
1265           (or (gethash pathname *documents*)
1266               (setf (gethash pathname *documents*)
1267                     (make-whitespace-stripper
1268                      (handler-case
1269                          (parse-allowing-microsoft-bom pathname
1270                                                        (stp:make-builder))
1271                        ((or file-error cxml:xml-parse-error) (c)
1272                          (xslt-error "cannot parse referenced document ~A: ~A"
1273                                      pathname c)))
1274                      (stylesheet-strip-thunk *stylesheet*))))))
1275     (when (puri:uri-fragment absolute-uri)
1276       (xslt-error "use of fragment identifiers in document() not supported"))
1277     xpath-root-node))
1278
1279 (xpath-sys:define-extension xslt *xsl*)
1280
1281 (defun document-base-uri (node)
1282   (xpath-protocol:base-uri
1283    (cond
1284      ((xpath-protocol:node-type-p node :document)
1285       (xpath::find-in-pipe-if
1286        (lambda (x)
1287          (xpath-protocol:node-type-p x :element))
1288        (xpath-protocol:child-pipe node)))
1289      ((xpath-protocol:node-type-p node :element)
1290       node)
1291      (t
1292       (xpath-protocol:parent-node node)))))
1293
1294 (xpath-sys:define-xpath-function/lazy
1295     xslt :document
1296     (object &optional node-set)
1297   (let ((instruction-base-uri *instruction-base-uri*))
1298     (lambda (ctx)
1299       (let* ((object (funcall object ctx))
1300              (node-set (and node-set (funcall node-set ctx)))
1301              (base-uri
1302               (if node-set
1303                   (document-base-uri (xpath::textually-first-node node-set))
1304                   instruction-base-uri)))
1305         (xpath-sys:make-node-set
1306          (if (xpath:node-set-p object)
1307              (xpath:map-node-set->list
1308               (lambda (node)
1309                 (%document (xpath:string-value node)
1310                            (if node-set
1311                                base-uri
1312                                (document-base-uri node))))
1313               object)
1314              (list (%document (xpath:string-value object) base-uri))))))))
1315
1316 ;; FIXME: the point of keys is that we are meant to optimize this
1317 ;; by building a table mapping nodes to values for each key.
1318 ;; We should run over all matching nodes and store them in such a table
1319 ;; when seeing their document for the first time.
1320 (xpath-sys:define-xpath-function/lazy xslt :key (name object)
1321   (let ((namespaces *namespaces*))
1322     (lambda (ctx)
1323       (let* ((qname (xpath:string-value (funcall name ctx)))
1324              (object (funcall object ctx))
1325              (expanded-name
1326               (multiple-value-bind (local-name uri)
1327                   (decode-qname/runtime qname namespaces nil)
1328                 (cons local-name uri)))
1329              (key-conses (find-key expanded-name *stylesheet*)))
1330         (xpath-sys:make-node-set
1331          (xpath::mappend-pipe
1332           (lambda (key)
1333             (labels ((get-by-key (value)
1334                        (let ((value (xpath:string-value value)))
1335                          (xpath::filter-pipe
1336                           #'(lambda (node)
1337                               (let ((uses
1338                                      (xpath:evaluate-compiled (key-use key)
1339                                                               node)))
1340                                 (if (xpath:node-set-p uses)
1341                                     (xpath::find-in-pipe
1342                                      value
1343                                      (xpath-sys:pipe-of uses)
1344                                      :key #'xpath:string-value
1345                                      :test #'equal)
1346                                     (equal value (xpath:string-value uses)))))
1347                           (xpath-sys:pipe-of
1348                            (xpath:node-set-value
1349                             (xpath:evaluate-compiled (key-match key) ctx)))))))
1350               (xpath::sort-pipe
1351                (if (xpath:node-set-p object)
1352                    (xpath::mappend-pipe #'get-by-key
1353                                         (xpath-sys:pipe-of object))
1354                    (get-by-key object)))))
1355           key-conses))))))
1356
1357 ;; FIXME: add alias mechanism for XPath extensions in order to avoid duplication
1358
1359 (xpath-sys:define-xpath-function/lazy xslt :current ()
1360   (when *without-xslt-current-p*
1361     (xslt-error "current() not allowed here"))
1362   #'(lambda (ctx)
1363       (xpath-sys:make-node-set
1364        (xpath-sys:make-pipe
1365         (xpath:context-starting-node ctx)
1366         nil))))
1367
1368 (xpath-sys:define-xpath-function/lazy xslt :unparsed-entity-uri (name)
1369   #'(lambda (ctx)
1370       (or (xpath-protocol:unparsed-entity-uri (xpath:context-node ctx)
1371                                               (funcall name ctx))
1372           "")))
1373
1374 (defun %get-node-id (node)
1375   (when (xpath:node-set-p node)
1376     (setf node (xpath::textually-first-node node)))
1377   (when node
1378     (let ((id (xpath-sys:get-node-id node))
1379           (highest-base-uri
1380            (loop
1381               for parent = node then next
1382               for next = (xpath-protocol:parent-node parent)
1383               for this-base-uri = (xpath-protocol:base-uri parent)
1384               for highest-base-uri = (if (plusp (length this-base-uri))
1385                                          this-base-uri
1386                                          highest-base-uri)
1387               while next
1388               finally (return highest-base-uri))))
1389       ;; FIXME: Now that we intern documents, we could use a short ID for
1390       ;; the document instead of the base URI.
1391       (nreverse (concatenate 'string highest-base-uri "//" id)))))
1392
1393 (xpath-sys:define-xpath-function/lazy xslt :generate-id (&optional node-set-thunk)
1394   (if node-set-thunk
1395       #'(lambda (ctx)
1396           (%get-node-id (xpath:node-set-value (funcall node-set-thunk ctx))))
1397       #'(lambda (ctx)
1398           (%get-node-id (xpath:context-node ctx)))))
1399
1400 (declaim (special *builtin-instructions*))
1401
1402 (xpath-sys:define-xpath-function/lazy xslt :element-available (qname)
1403   (let ((namespaces *namespaces*)
1404         (extensions *extension-namespaces*))
1405     #'(lambda (ctx)
1406         (let ((qname (funcall qname ctx)))
1407           (multiple-value-bind (local-name uri)
1408               (decode-qname/runtime qname namespaces nil)
1409             (cond
1410               ((equal uri *xsl*)
1411                (and (gethash local-name *builtin-instructions*) t))
1412               ((find uri extensions :test #'equal)
1413                (and (find-extension-element local-name uri) t))
1414               (t
1415                nil)))))))
1416
1417 (xpath-sys:define-xpath-function/lazy xslt :function-available (qname)
1418   (let ((namespaces *namespaces*))
1419     #'(lambda (ctx)
1420         (let ((qname (funcall qname ctx)))
1421           (multiple-value-bind (local-name uri)
1422               (decode-qname/runtime qname namespaces nil)
1423             (and (zerop (length uri))
1424                  (or (xpath-sys:find-xpath-function local-name *xsl*)
1425                      (xpath-sys:find-xpath-function local-name uri))
1426                  t))))))
1427
1428 (xpath-sys:define-xpath-function/lazy xslt :system-property (qname)
1429   (let ((namespaces *namespaces*))
1430     (lambda (ctx)
1431       (let ((qname (xpath:string-value (funcall qname ctx))))
1432         (multiple-value-bind (local-name uri)
1433             (decode-qname/runtime qname namespaces nil)
1434           (if (equal uri *xsl*)
1435               (cond
1436                 ((equal local-name "version")
1437                  "1")
1438                 ((equal local-name "vendor")
1439                  "Xuriella")
1440                 ((equal local-name "vendor-url")
1441                  "http://repo.or.cz/w/xuriella.git")
1442                 (t
1443                  ""))
1444               ""))))))
1445
1446 ;; FIXME: should there be separate uri-resolver arguments for stylesheet
1447 ;; and data?
1448 (defun apply-stylesheet
1449     (stylesheet source-designator
1450      &key output parameters uri-resolver navigator)
1451   (when (typep stylesheet 'xml-designator)
1452     (setf stylesheet
1453           (handler-bind
1454               ((cxml:xml-parse-error
1455                 (lambda (c)
1456                   (xslt-error "cannot parse stylesheet: ~A" c))))
1457             (parse-stylesheet stylesheet :uri-resolver uri-resolver))))
1458   (with-resignalled-errors ()
1459     (invoke-with-output-sink
1460      (lambda ()
1461        (let* ((*documents* (make-hash-table :test 'equal))
1462               (xpath:*navigator* (or navigator :default-navigator))
1463               (puri:*strict-parse* nil)
1464               (*stylesheet* stylesheet)
1465               (*empty-mode* (make-mode))
1466               (*default-mode* (find-mode stylesheet nil))
1467               (global-variable-chains
1468                (stylesheet-global-variables stylesheet))
1469               (*global-variable-values*
1470                (make-variable-value-array (length global-variable-chains)))
1471               (*uri-resolver* uri-resolver)
1472               (source-document
1473                (if (typep source-designator 'xml-designator)
1474                    (cxml:parse source-designator (stp:make-builder))
1475                    source-designator))
1476               (xpath-root-node
1477                (make-whitespace-stripper
1478                 source-document
1479                 (stylesheet-strip-thunk stylesheet)))
1480               (ctx (xpath:make-context xpath-root-node)))
1481          (when (pathnamep source-designator)
1482            (setf (gethash source-designator *documents*) xpath-root-node))
1483          (map nil
1484               (lambda (chain)
1485                 (let ((head (car (variable-chain-definitions chain))))
1486                   (when (variable-param-p head)
1487                     (let ((value
1488                            (find-parameter-value
1489                             (variable-chain-local-name chain)
1490                             (variable-chain-uri chain)
1491                             parameters)))
1492                       (when value
1493                         (setf (global-variable-value
1494                                (variable-chain-index chain))
1495                               value))))))
1496               global-variable-chains)
1497          (map nil
1498               (lambda (chain)
1499                 (funcall (variable-chain-thunk chain) ctx))
1500               global-variable-chains)
1501          ;; zzz we wouldn't have to mask float traps here if we used the
1502          ;; XPath API properly.  Unfortunately I've been using FUNCALL
1503          ;; everywhere instead of EVALUATE, so let's paper over that
1504          ;; at a central place to be sure:
1505          (xpath::with-float-traps-masked ()
1506            (apply-templates ctx :mode *default-mode*))))
1507      (stylesheet-output-specification stylesheet)
1508      output)))
1509
1510 (defun find-attribute-set (local-name uri &optional (stylesheet *stylesheet*))
1511   (or (gethash (cons local-name uri) (stylesheet-attribute-sets stylesheet))
1512       (xslt-error "no such attribute set: ~A/~A" local-name uri)))
1513
1514 (defun apply-templates/list (list &key param-bindings sort-predicate mode)
1515   (when sort-predicate
1516     (setf list
1517           (mapcar #'xpath:context-node
1518                   (stable-sort (contextify-node-list list)
1519                                sort-predicate))))
1520   (let* ((n (length list))
1521          (s/d (lambda () n)))
1522     (loop
1523        for i from 1
1524        for child in list
1525        do
1526          (apply-templates (xpath:make-context child s/d i)
1527                           :param-bindings param-bindings
1528                           :mode mode))))
1529
1530 (defvar *stack-limit* 200)
1531
1532 (defun invoke-with-stack-limit (fn)
1533   (let ((*stack-limit* (1- *stack-limit*)))
1534     (unless (plusp *stack-limit*)
1535       (xslt-error "*stack-limit* reached; stack overflow"))
1536     (funcall fn)))
1537
1538 (defun invoke-template (ctx template param-bindings)
1539   (let ((*lexical-variable-values*
1540          (make-variable-value-array (template-n-variables template))))
1541     (with-stack-limit ()
1542       (loop
1543          for (name-cons value) in param-bindings
1544          for (nil index nil) = (find name-cons
1545                                      (template-params template)
1546                                      :test #'equal
1547                                      :key #'car)
1548          do
1549            (when index
1550              (setf (lexical-variable-value index) value)))
1551       (funcall (template-body template) ctx))))
1552
1553 (defun apply-default-templates (ctx mode)
1554   (let ((node (xpath:context-node ctx)))
1555     (cond
1556       ((or (xpath-protocol:node-type-p node :processing-instruction)
1557            (xpath-protocol:node-type-p node :comment)))
1558       ((or (xpath-protocol:node-type-p node :text)
1559            (xpath-protocol:node-type-p node :attribute))
1560        (write-text (xpath-protocol:node-text node)))
1561       (t
1562        (apply-templates/list
1563         (xpath::force
1564          (xpath-protocol:child-pipe node))
1565         :mode mode)))))
1566
1567 (defvar *apply-imports*)
1568
1569 (defun apply-applicable-templates (ctx templates param-bindings finally)
1570   (labels ((apply-imports (&optional actual-param-bindings)
1571              (if templates
1572                  (let* ((this (pop templates))
1573                         (low (template-apply-imports-limit this))
1574                         (high (template-import-priority this)))
1575                    (setf templates
1576                          (remove-if-not
1577                           (lambda (x)
1578                             (<= low (template-import-priority x) high))
1579                           templates))
1580                    (invoke-template ctx this actual-param-bindings))
1581                  (funcall finally))))
1582     (let ((*apply-imports* #'apply-imports))
1583       (apply-imports param-bindings))))
1584
1585 (defun apply-templates (ctx &key param-bindings mode)
1586   (apply-applicable-templates ctx
1587                               (find-templates ctx (or mode *default-mode*))
1588                               param-bindings
1589                               (lambda ()
1590                                 (apply-default-templates ctx mode))))
1591
1592 (defun call-template (ctx name &optional param-bindings)
1593   (apply-applicable-templates ctx
1594                               (find-named-templates name)
1595                               param-bindings
1596                               (lambda ()
1597                                 (xslt-error "cannot find named template: ~s"
1598                                             name))))
1599
1600 (defun find-templates (ctx mode)
1601   (let* ((matching-candidates
1602           (xpath:matching-values (mode-match-thunk mode)
1603                                  (xpath:context-node ctx)))
1604          (npriorities
1605           (if matching-candidates
1606               (1+ (reduce #'max
1607                           matching-candidates
1608                           :key #'template-import-priority))
1609               0))
1610          (priority-groups (make-array npriorities :initial-element nil)))
1611     (dolist (template matching-candidates)
1612       (push template
1613             (elt priority-groups (template-import-priority template))))
1614     (loop
1615        for i from (1- npriorities) downto 0
1616        for group = (elt priority-groups i)
1617        for template = (maximize #'template< group)
1618        when template
1619        collect template)))
1620
1621 (defun find-named-templates (name)
1622   (gethash name (stylesheet-named-templates *stylesheet*)))
1623
1624 (defun template< (a b)                  ;assuming same import priority
1625   (let ((p (template-priority a))
1626         (q (template-priority b)))
1627     (cond
1628       ((< p q) t)
1629       ((> p q) nil)
1630       (t
1631        (xslt-cerror "conflicting templates:~_~A,~_~A"
1632                     (template-match-expression a)
1633                     (template-match-expression b))
1634        (< (template-position a) (template-position b))))))
1635
1636 (defun maximize (< things)
1637   (when things
1638     (let ((max (car things)))
1639       (dolist (other (cdr things))
1640         (when (funcall < max other)
1641           (setf max other)))
1642       max)))
1643
1644 (defun invoke-with-output-sink (fn output-spec output)
1645   (etypecase output
1646     (pathname
1647      (with-open-file (s output
1648                         :direction :output
1649                         :element-type '(unsigned-byte 8)
1650                         :if-exists :rename-and-delete)
1651        (invoke-with-output-sink fn output-spec s)))
1652     ((or stream null)
1653      (invoke-with-output-sink fn
1654                               output-spec
1655                               (make-output-sink output-spec output)))
1656     ((or hax:abstract-handler sax:abstract-handler)
1657      (with-xml-output output
1658        (when (typep output '(or combi-sink auto-detect-sink))
1659          (sax:start-dtd output
1660                         :autodetect-me-please
1661                         (output-doctype-public output-spec)
1662                         (output-doctype-system output-spec)))
1663        (funcall fn)))))
1664
1665 (defun make-output-sink (output-spec stream)
1666   (let* ((ystream
1667           (if stream
1668               (let ((et (stream-element-type stream)))
1669                 (cond
1670                   ((or (null et) (subtypep et '(unsigned-byte 8)))
1671                    (runes:make-octet-stream-ystream stream))
1672                   ((subtypep et 'character)
1673                    (runes:make-character-stream-ystream stream))))
1674               (runes:make-rod-ystream)))
1675          (omit-xml-declaration-p
1676           (boolean-or-error (output-omit-xml-declaration output-spec)))
1677          (sink-encoding (or (output-encoding output-spec) "UTF-8"))
1678          (sax-target
1679           (progn
1680             (setf (runes:ystream-encoding ystream)
1681                   (cxml::find-output-encoding sink-encoding))
1682             (make-instance 'cxml::sink
1683                            :ystream ystream
1684                            :omit-xml-declaration-p omit-xml-declaration-p
1685                            :encoding sink-encoding))))
1686     (flet ((make-combi-sink ()
1687              (make-instance 'combi-sink
1688                             :hax-target (make-instance 'chtml::sink
1689                                                        :ystream ystream)
1690                             :sax-target sax-target
1691                             :media-type (output-media-type output-spec)
1692                             :encoding sink-encoding)))
1693       (let ((method-key (output-method output-spec)))
1694         (cond
1695           ((and (eq method-key :html)
1696                 (null (output-doctype-system output-spec))
1697                 (null (output-doctype-public output-spec)))
1698            (make-combi-sink))
1699           ((eq method-key :text)
1700            (make-text-filter sax-target))
1701           ((and (eq method-key :xml)
1702                 (null (output-doctype-system output-spec)))
1703            sax-target)
1704           (t
1705            (make-auto-detect-sink (make-combi-sink) method-key)))))))
1706
1707 (defstruct template
1708   match-expression
1709   compiled-pattern
1710   name
1711   import-priority
1712   apply-imports-limit
1713   priority
1714   position
1715   mode
1716   mode-qname
1717   params
1718   body
1719   n-variables)
1720
1721 (defun expression-priority (form)
1722   (let ((step (second form)))
1723     (if (and (null (cddr form))
1724              (listp step)
1725              (member (car step) '(:child :attribute))
1726              (null (cddr step)))
1727         (let ((name (second step)))
1728           (cond
1729             ((or (stringp name)
1730                  (and (consp name)
1731                       (or (eq (car name) :qname)
1732                           (eq (car name) :processing-instruction))))
1733              0.0)
1734             ((and (consp name)
1735                   (or (eq (car name) :namespace)
1736                       (eq (car name) '*)))
1737              -0.25)
1738             (t
1739              -0.5)))
1740         0.5)))
1741
1742 (defun parse-key-pattern (str)
1743   (with-resignalled-errors ()
1744     (with-forward-compatible-errors
1745         (xpath:parse-xpath "compile-time-error()") ;hack
1746       (let ((parsed
1747              (mapcar #'(lambda (item)
1748                          `(:path (:root :node)
1749                                  (:descendant-or-self :node)
1750                                  ,@(cdr item)))
1751                      (cdr (xpath::parse-pattern-expression str)))))
1752         (if (null (rest parsed))
1753             (first parsed)
1754             `(:union ,@parsed))))))
1755
1756 (defun compile-value-thunk (value env)
1757   (if (and (listp value) (eq (car value) 'progn))
1758       (let ((inner-thunk (compile-instruction value env)))
1759         (lambda (ctx)
1760           (apply-to-result-tree-fragment ctx inner-thunk)))
1761       (compile-xpath value env)))
1762
1763 (defun compile-var-binding (name value env)
1764   (multiple-value-bind (local-name uri)
1765       (decode-qname name env nil)
1766     (let ((thunk (xslt-trace-thunk
1767                   (compile-value-thunk value env)
1768                   "local variable ~s = ~s" name :result)))
1769       (list (cons local-name uri)
1770             (push-variable local-name
1771                            uri
1772                            *lexical-variable-declarations*)
1773             thunk))))
1774
1775 (defun compile-var-bindings (forms env)
1776   (loop
1777      for (name value) in forms
1778      collect (compile-var-binding name value env)))
1779
1780 (defmacro sometimes-with-attributes ((&rest attrs) node &body body)
1781   (let ((x (gensym)))
1782     `(let ((,x ,node))
1783        (if *forwards-compatible-p*
1784            (stp:with-attributes (,@attrs) ,x ,@body)
1785            (only-with-attributes (,@attrs) ,x ,@body)))))
1786
1787 (defun compile-template (<template> env position)
1788   (sometimes-with-attributes (match name priority mode) <template>
1789     (unless (or name match)
1790       (xslt-error "missing match in template"))
1791     (multiple-value-bind (params body-pos)
1792         (loop
1793           for i from 0
1794           for child in (stp:list-children <template>)
1795           while (namep child "param")
1796           collect (parse-param child) into params
1797           finally (return (values params i)))
1798       (let* ((*lexical-variable-declarations* (make-empty-declaration-array))
1799              (param-bindings (compile-var-bindings params env))
1800              (body (parse-body <template> body-pos (mapcar #'car params)))
1801              (body-thunk (compile-instruction `(progn ,@body) env))
1802              (outer-body-thunk
1803               (xslt-trace-thunk
1804                #'(lambda (ctx)
1805                    (unwind-protect
1806                        (progn
1807                          ;; set params that weren't initialized by apply-templates
1808                          (loop for (name index param-thunk) in param-bindings
1809                                when (eq (lexical-variable-value index nil) 'unbound)
1810                                  do (setf (lexical-variable-value index)
1811                                           (funcall param-thunk ctx)))
1812                          (funcall body-thunk ctx))))
1813                "template: match = ~s name = ~s" match name))
1814              (n-variables (length *lexical-variable-declarations*)))
1815         (append
1816          (when name
1817            (multiple-value-bind (local-name uri)
1818                (decode-qname name env nil)
1819              (list
1820               (make-template :name (cons local-name uri)
1821                              :import-priority *import-priority*
1822                              :apply-imports-limit *apply-imports-limit*
1823                              :params param-bindings
1824                              :body outer-body-thunk
1825                              :n-variables n-variables))))
1826          (when match
1827            (mapcar (lambda (expression)
1828                      (let* ((compiled-pattern
1829                              (xslt-trace-thunk
1830                               (car (without-xslt-current ()
1831                                      (xpath:compute-patterns
1832                                       `(:patterns ,expression)
1833                                       42
1834                                       :dummy
1835                                       env)))
1836                               "match-thunk for template (match ~s): ~s --> ~s"
1837                               match expression :result))
1838                             (p (if priority
1839                                    (xpath::parse-xnum priority)
1840                                    (expression-priority expression)))
1841                             (p
1842                              (progn
1843                                (unless (and (numberp p)
1844                                             (not (xpath::inf-p p))
1845                                             (not (xpath::nan-p p)))
1846                                  (xslt-error "failed to parse priority"))
1847                                (float p 1.0d0)))
1848                             (template
1849                              (make-template :match-expression expression
1850                                             :compiled-pattern compiled-pattern
1851                                             :import-priority *import-priority*
1852                                             :apply-imports-limit *apply-imports-limit*
1853                                             :priority p
1854                                             :position position
1855                                             :mode-qname mode
1856                                             :params param-bindings
1857                                             :body outer-body-thunk
1858                                             :n-variables n-variables)))
1859                        (setf (xpath:pattern-value compiled-pattern)
1860                              template)
1861                        template))
1862                    (cdr (xpath:parse-pattern-expression match)))))))))
1863 #+(or)
1864 (xuriella::parse-stylesheet #p"/home/david/src/lisp/xuriella/test.xsl")