xslt.lisp

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