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