instructions.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 ;;;; Instructions
  37
  38 (defparameter *available-instructions* (make-hash-table :test 'equal))
  39
  40 (defmacro define-instruction (name (args-var env-var) &body body)
  41   `(setf (get ',name 'xslt-instruction)
  42          (lambda (,args-var ,env-var)
  43            (declare (ignorable ,env-var))
  44            ,@body)))
  45
  46 (define-instruction if (args env)
  47   (destructuring-bind (test then &optional else) args
  48     (let ((test-thunk (compile-xpath test env))
  49           (then-thunk (compile-instruction then env))
  50           (else-thunk (when else (compile-instruction else env))))
  51       (lambda (ctx)
  52         (cond
  53           ((xpath:boolean-value (funcall test-thunk ctx))
  54            (funcall then-thunk ctx))
  55           (else-thunk
  56            (funcall else-thunk ctx)))))))
  57
  58 (define-instruction when (args env)
  59   (destructuring-bind (test &rest body) args
  60     (compile-instruction `(if ,test (progn ,@body)) env)))
  61
  62 (define-instruction unless (args env)
  63   (destructuring-bind (test &rest body) args
  64     (compile-instruction `(if (:not ,test) (progn ,@body)) env)))
  65
  66 (define-instruction cond (args env)
  67   (if args
  68       (destructuring-bind ((test &body body) &rest clauses) args
  69         (compile-instruction (if (eq test t)
  70                                  `(progn ,@body)
  71                                  `(if ,test
  72                                       (progn ,@body)
  73                                       (cond ,@clauses)))
  74                              env))
  75       (constantly nil)))
  76
  77 (define-instruction progn (args env)
  78   (if args
  79       (let ((first-thunk (compile-instruction (first args) env))
  80             (rest-thunk (compile-instruction `(progn ,@(rest args)) env)))
  81         (lambda (ctx)
  82           (funcall first-thunk ctx)
  83           (funcall rest-thunk ctx)))
  84       (constantly nil)))
  85
  86 (defun decode-qname/runtime (qname namespaces attributep)
  87   (handler-case
  88       (multiple-value-bind (prefix local-name)
  89           (split-qname qname)
  90         (values local-name
  91                 (if (or prefix (not attributep))
  92                     (cdr (assoc prefix namespaces :test 'equal))
  93                     "")
  94                 prefix))
  95     (cxml:well-formedness-violation ()
  96       (xslt-error "not a qname: ~A" qname))))
  97
  98 (define-instruction xsl:element (args env)
  99   (destructuring-bind ((name &key namespace use-attribute-sets)
 100                        &body body)
 101       args
 102     (declare (ignore use-attribute-sets)) ;fixme
 103     (multiple-value-bind (name-thunk constant-name-p)
 104         (compile-avt name env)
 105       (multiple-value-bind (ns-thunk constant-ns-p)
 106           (if namespace
 107               (compile-avt namespace env)
 108               (values nil t))
 109         (let ((body-thunk (compile-instruction `(progn ,@body) env)))
 110           (if (and constant-name-p constant-ns-p)
 111               (compile-element/constant-name name namespace env body-thunk)
 112               (compile-element/runtime name-thunk ns-thunk body-thunk)))))))
 113
 114 (defun compile-element/constant-name (qname namespace env body-thunk)
 115   ;; the simple case: compile-time decoding of the QName
 116   (multiple-value-bind (local-name uri prefix)
 117       (decode-qname qname env nil)
 118     (when namespace
 119       (setf uri namespace))
 120     (lambda (ctx)
 121       (with-element (local-name uri :suggested-prefix prefix)
 122         (funcall body-thunk ctx)))))
 123
 124 (defun compile-element/runtime (name-thunk ns-thunk body-thunk)
 125   ;; run-time decoding of the QName, but using the same namespaces
 126   ;; that would have been known at compilation time.
 127   (let ((namespaces *namespaces*))
 128     (lambda (ctx)
 129       (let ((qname (funcall name-thunk ctx)))
 130         (multiple-value-bind (local-name uri prefix)
 131             (decode-qname/runtime qname namespaces nil)
 132           (when ns-thunk
 133             (setf uri (funcall ns-thunk ctx)))
 134           (unless uri
 135             (setf uri ""))
 136           (with-element (local-name uri :suggested-prefix prefix)
 137             (funcall body-thunk ctx)))))))
 138
 139 (define-instruction xsl:use-attribute-sets (args env)
 140   (destructuring-bind (str) args
 141     (let ((sets (mapcar (lambda (qname)
 142                           (multiple-value-list (decode-qname qname env nil)))
 143                         (words str))))
 144       (lambda (ctx)
 145         (loop for (local-name uri nil) in sets do
 146              (dolist (thunk (find-attribute-set local-name uri))
 147                (funcall thunk ctx)))))))
 148
 149 (define-instruction xsl:attribute (args env)
 150   (destructuring-bind ((name &key namespace) &body body) args
 151     (when (null name)
 152       (xslt-error "xsl:attribute: name not specified"))
 153     (multiple-value-bind (name-thunk constant-name-p)
 154         (compile-avt name env)
 155       (multiple-value-bind (ns-thunk constant-ns-p)
 156           (if namespace
 157               (compile-avt namespace env)
 158               (values nil t))
 159         (let ((value-thunk (compile-instruction `(progn ,@body) env)))
 160           (if (and constant-name-p constant-ns-p)
 161               (compile-attribute/constant-name name namespace env value-thunk)
 162               (compile-attribute/runtime name-thunk ns-thunk value-thunk)))))))
 163
 164 (defun compile-attribute/constant-name (qname namespace env value-thunk)
 165   ;; the simple case: compile-time decoding of the QName
 166   (multiple-value-bind (local-name uri prefix)
 167       (decode-qname qname env nil)
 168     (when namespace
 169       (setf uri namespace))
 170     (lambda (ctx)
 171       (write-attribute local-name
 172                        uri
 173                        (with-toplevel-text-output-sink (s)
 174                          (with-xml-output s
 175                            (funcall value-thunk ctx)))
 176                        :suggested-prefix prefix))))
 177
 178 (defun compile-attribute/runtime (name-thunk ns-thunk value-thunk)
 179   ;; run-time decoding of the QName, but using the same namespaces
 180   ;; that would have been known at compilation time.
 181   (let ((namespaces *namespaces*))
 182     (lambda (ctx)
 183       (let ((qname (funcall name-thunk ctx)))
 184         (multiple-value-bind (local-name uri prefix)
 185             (decode-qname/runtime qname namespaces nil)
 186           (when ns-thunk
 187             (setf uri (funcall ns-thunk ctx)))
 188           (write-attribute local-name
 189                            (or uri "")
 190                            (with-toplevel-text-output-sink (s)
 191                              (with-xml-output s
 192                                (funcall value-thunk ctx)))
 193                            :suggested-prefix prefix))))))
 194
 195 (defun remove-excluded-namespaces
 196     (namespaces &optional (excluded-uris *excluded-namespaces*))
 197   (let ((koerbchen '())
 198         (kroepfchen '()))
 199     (loop
 200        for cons in namespaces
 201        for (prefix . uri) = cons
 202        do
 203          (cond
 204            ((find prefix kroepfchen :test #'equal))
 205            ((find uri excluded-uris :test #'equal)
 206             (push prefix kroepfchen))
 207            (t
 208             (push cons koerbchen))))
 209     koerbchen))
 210
 211 (define-instruction xsl:literal-element (args env)
 212   (destructuring-bind
 213         ((local-name &optional (uri "") suggested-prefix) &body body)
 214       args
 215     (let ((body-thunk (compile-instruction `(progn ,@body) env))
 216           (namespaces (remove-excluded-namespaces *namespaces*)))
 217       (lambda (ctx)
 218         (with-element (local-name uri
 219                                   :suggested-prefix suggested-prefix
 220                                   :extra-namespaces namespaces)
 221           (funcall body-thunk ctx))))))
 222
 223 (define-instruction xsl:literal-attribute (args env)
 224   (destructuring-bind ((local-name &optional uri suggested-prefix) value) args
 225     (let ((value-thunk (compile-avt value env)))
 226       (lambda (ctx)
 227         (write-attribute local-name
 228                          uri
 229                          (funcall value-thunk ctx)
 230                          :suggested-prefix suggested-prefix)))))
 231
 232 (define-instruction xsl:text (args env)
 233   (destructuring-bind (str) args
 234     (lambda (ctx)
 235       (declare (ignore ctx))
 236       (write-text str))))
 237
 238 (define-instruction xsl:processing-instruction (args env)
 239   (destructuring-bind (name &rest body) args
 240     (let ((name-thunk (compile-avt name env))
 241           (value-thunk (compile-instruction `(progn ,@body) env)))
 242       (lambda (ctx)
 243         (write-processing-instruction
 244          (funcall name-thunk ctx)
 245          (with-toplevel-text-output-sink (s)
 246            (with-xml-output s
 247              (funcall value-thunk ctx))))))))
 248
 249 (define-instruction xsl:comment (args env)
 250   (let ((value-thunk (compile-instruction `(progn ,@args) env)))
 251     (lambda (ctx)
 252       (write-comment (with-toplevel-text-output-sink (s)
 253                        (with-xml-output s
 254                          (funcall value-thunk ctx)))))))
 255
 256 (define-instruction xsl:value-of (args env)
 257   (destructuring-bind (xpath) args
 258     (let ((thunk (compile-xpath xpath env)))
 259       (xslt-trace-thunk
 260        (lambda (ctx)
 261          (write-text (xpath:string-value (funcall thunk ctx))))
 262        "value-of ~s = ~s" xpath :result))))
 263
 264 (define-instruction xsl:unescaped-value-of (args env)
 265   (destructuring-bind (xpath) args
 266     (let ((thunk (compile-xpath xpath env)))
 267       (lambda (ctx)
 268         (write-unescaped (xpath:string-value (funcall thunk ctx)))))))
 269
 270 (define-instruction xsl:copy-of (args env)
 271   (destructuring-bind (xpath) args
 272     (let ((thunk (compile-xpath xpath env))
 273           ;; FIXME: what was this for?  --david
 274           #+(or) (v (intern-variable "varName" "")))
 275       (xslt-trace-thunk
 276        (lambda (ctx)
 277          (let ((result (funcall thunk ctx)))
 278            (typecase result
 279              (xpath:node-set ;; FIXME: variables can contain node sets w/fragments inside. Maybe just fragments would do?
 280               (xpath:map-node-set #'copy-into-result (xpath:sort-node-set result)))
 281              (result-tree-fragment
 282               (copy-into-result result))
 283              (t
 284               (write-text (xpath:string-value result))))))
 285        "copy-of ~s" xpath))))
 286
 287 (defun copy-into-result (node)
 288   (cond
 289     ((result-tree-fragment-p node)
 290      (stp:do-children (child (result-tree-fragment-node node))
 291        (copy-into-result child)))
 292     ((xpath-protocol:node-type-p node :element)
 293      (with-element ((xpath-protocol:local-name node)
 294                     (xpath-protocol:namespace-uri node)
 295                     :suggested-prefix (xpath-protocol:namespace-prefix node)
 296                     :extra-namespaces (namespaces-as-alist node))
 297        (map-pipe-eagerly #'copy-into-result
 298                          (xpath-protocol:attribute-pipe node))
 299        (map-pipe-eagerly #'copy-into-result
 300                          (xpath-protocol:child-pipe node))))
 301     ((xpath-protocol:node-type-p node :document)
 302      (map-pipe-eagerly #'copy-into-result
 303                        (xpath-protocol:child-pipe node)))
 304     (t
 305      (copy-leaf-node node))))
 306
 307 (defun make-sorter (spec env)
 308   (destructuring-bind (&key select lang data-type order case-order)
 309       (cdr spec)
 310     ;; FIXME: implement case-order
 311     (declare (ignore lang case-order))
 312     (let ((select-thunk (compile-xpath (or select ".") env))
 313           (numberp (equal data-type "number"))
 314           (f (if (equal order "descending") -1 1)))
 315       (lambda (a b)
 316         (let ((i (xpath:string-value
 317                   (funcall select-thunk (xpath:make-context a))))
 318               (j (xpath:string-value
 319                   (funcall select-thunk (xpath:make-context b)))))
 320           (* f
 321              (if numberp
 322                  (let ((n-a (xpath:number-value i))
 323                        (n-b (xpath:number-value j)))
 324                    (cond ((and (xpath::nan-p a)
 325                                (not (xpath::nan-p b)))
 326                           -1)
 327                          ((and (not (xpath::nan-p a))
 328                                (xpath::nan-p b))
 329                           1)
 330                          ((xpath::compare-numbers '< n-a n-b) -1)
 331                          ((xpath::compare-numbers '> n-a n-b) 1)
 332                          (t 0)))
 333                  (cond
 334                    ((string< i j) -1)
 335                    ((equal i j) 0)
 336                    (t 1)))))))))
 337
 338 (defun compose-sorters (sorters)
 339   (if sorters
 340       (let ((this (car sorters))
 341             (next (compose-sorters (rest sorters))))
 342         (lambda (a b)
 343           (let ((d (funcall this a b)))
 344             (if (zerop d)
 345                 (funcall next a b)
 346                 d))))
 347       (constantly 0)))
 348
 349 (defun make-sort-predicate (decls env)
 350   (let ((sorter
 351          (compose-sorters
 352           (mapcar (lambda (x) (make-sorter x env)) decls))))
 353     (lambda (a b)
 354       (minusp (funcall sorter a b)))))
 355
 356 (define-instruction xsl:for-each (args env)
 357   (destructuring-bind (select &optional decls &rest body) args
 358     (unless (and (consp decls)
 359                  (eq (car decls) 'declare))
 360       (push decls body)
 361       (setf decls nil))
 362     (let ((select-thunk (compile-xpath select env))
 363           (body-thunk (compile-instruction `(progn ,@body) env))
 364           (sort-predicate
 365            (when (cdr decls)
 366              (make-sort-predicate (cdr decls) env))))
 367       (lambda (ctx)
 368         (let ((selected (funcall select-thunk ctx)))
 369           (unless (xpath:node-set-p selected)
 370             (xslt-error "for-each select expression should yield a node-set"))
 371           (let ((nodes (xpath::force
 372                         (xpath::sorted-pipe-of selected))))
 373             (when sort-predicate
 374               (setf nodes (sort (copy-list nodes) sort-predicate)))
 375             (loop
 376               with n = (length nodes)
 377               for node in nodes
 378               for i from 1
 379               do
 380            (funcall body-thunk
 381                     (xpath:make-context node (lambda () n) i)))))))))
 382
 383 (define-instruction xsl:with-namespaces (args env)
 384   (destructuring-bind ((&rest forms) &rest body) args
 385     (let ((*namespaces* *namespaces*))
 386       (dolist (form forms)
 387         (destructuring-bind (prefix uri) form
 388           (push (cons prefix uri) *namespaces*)))
 389       (compile-instruction `(progn ,@body) env))))
 390
 391 (define-instruction xsl:with-excluded-namespaces (args env)
 392   (destructuring-bind ((&rest uris) &rest body) args
 393     (let ((*excluded-namespaces* (append uris *excluded-namespaces*)))
 394       (compile-instruction `(progn ,@body) env))))
 395
 396 (define-instruction xsl:with-extension-namespaces (args env)
 397   (destructuring-bind ((&rest uris) &rest body) args
 398     (let ((*extension-namespaces* (append uris *extension-namespaces*)))
 399       (compile-instruction `(progn ,@body) env))))
 400
 401 ;; XSLT disallows multiple definitions of the same variable within a
 402 ;; template.  Local variables can shadow global variables though.
 403 ;; Since our LET syntax makes it natural to shadow local variables the
 404 ;; Lisp way, we check for duplicate variables only where instructed to
 405 ;; by the XML syntax parser using WITH-DUPLICATES-CHECK:
 406 (defvar *template-variables* nil)
 407
 408 (define-instruction xsl:with-duplicates-check (args env)
 409   (let ((*template-variables* *template-variables*))
 410     (destructuring-bind ((&rest qnames) &rest body) args
 411       (dolist (qname qnames)
 412         (multiple-value-bind (local-name uri)
 413             (decode-qname qname env nil)
 414           (let ((key (cons local-name uri)))
 415             (when (find key *template-variables* :test #'equal)
 416               (xslt-error "duplicate variable: ~A, ~A" local-name uri))
 417             (push key *template-variables*))))
 418       (compile-instruction `(progn ,@body) env))))
 419
 420 (define-instruction xsl:with-base-uri (args env)
 421   (destructuring-bind (uri &rest body) args
 422     (let ((*instruction-base-uri* uri))
 423       (compile-instruction `(progn ,@body) env))))
 424
 425 (defstruct (result-tree-fragment
 426              (:constructor make-result-tree-fragment (node)))
 427   node)
 428
 429 (define-default-method xpath-protocol:node-p
 430     ((node result-tree-fragment))
 431   t)
 432
 433 (define-default-method xpath-protocol:node-text
 434     ((node result-tree-fragment))
 435   (xpath-protocol:node-text (result-tree-fragment-node node)))
 436
 437 (defun apply-to-result-tree-fragment (ctx thunk)
 438   (let ((document
 439          (with-xml-output (stp:make-builder)
 440            (with-element ("fragment" "")
 441              (funcall thunk ctx)))))
 442     (make-result-tree-fragment (stp:document-element document))))
 443
 444 (define-instruction let (args env)
 445   (destructuring-bind ((&rest forms) &rest body) args
 446     (let* ((old-top (length *lexical-variable-declarations*))
 447            (vars-and-names (compile-var-bindings/nointern forms env))
 448            (vars-and-positions
 449             (loop for ((local-name . uri) thunk) in vars-and-names
 450                collect
 451                  (list (push-variable local-name
 452                                       uri
 453                                       *lexical-variable-declarations*)
 454                        thunk))))
 455       (let ((thunk (compile-instruction `(progn ,@body) env)))
 456         (fill *lexical-variable-declarations* nil :start old-top)
 457         (lambda (ctx)
 458           (loop for (index var-thunk) in vars-and-positions
 459              do (setf (lexical-variable-value index)
 460                       (funcall var-thunk ctx)))
 461           (funcall thunk ctx))))))
 462
 463 (define-instruction let* (args env)
 464   (destructuring-bind ((&rest forms) &rest body) args
 465     (if forms
 466         (compile-instruction `(let (,(car forms))
 467                                 (let* (,@(cdr forms))
 468                                   ,@body))
 469                              env)
 470         (compile-instruction `(progn ,@body) env))))
 471
 472 (define-instruction xsl:message (args env)
 473   (compile-message #'warn args env))
 474
 475 (define-instruction xsl:terminate (args env)
 476   (compile-message #'error args env))
 477
 478 (defun namespaces-as-alist (element)
 479   (let ((namespaces '()))
 480     (do-pipe (ns (xpath-protocol:namespace-pipe element))
 481       (push (cons (xpath-protocol:local-name ns)
 482                   (xpath-protocol:namespace-uri ns))
 483             namespaces))
 484     namespaces))
 485
 486 (define-instruction xsl:copy (args env)
 487   (let ((body (compile-instruction `(progn ,@args) env)))
 488     (lambda (ctx)
 489       (let ((node (xpath:context-node ctx)))
 490         (cond
 491           ((xpath-protocol:node-type-p node :element)
 492            (with-element
 493                ((xpath-protocol:local-name node)
 494                 (xpath-protocol:namespace-uri node)
 495                 :suggested-prefix (xpath-protocol:namespace-prefix node)
 496                 :extra-namespaces (namespaces-as-alist node))
 497              (funcall body ctx)))
 498           ((xpath-protocol:node-type-p node :document)
 499            (funcall body ctx))
 500           (t
 501            (copy-leaf-node node)))))))
 502
 503 (defun copy-leaf-node (node)
 504   (cond
 505     ((xpath-protocol:node-type-p node :text)
 506      (write-text (xpath-protocol:node-text node)))
 507     ((xpath-protocol:node-type-p node :comment)
 508      (write-comment (xpath-protocol:node-text node)))
 509     ((xpath-protocol:node-type-p node :processing-instruction)
 510      (write-processing-instruction
 511          (xpath-protocol:processing-instruction-target node)
 512        (xpath-protocol:node-text node)))
 513     ((xpath-protocol:node-type-p node :attribute)
 514      (write-attribute
 515       (xpath-protocol:local-name node)
 516       (xpath-protocol:namespace-uri node)
 517       (xpath-protocol:node-text node)
 518       :suggested-prefix (xpath-protocol:namespace-prefix node)))
 519     ((xpath-protocol:node-type-p node :namespace)
 520      (write-extra-namespace
 521       (xpath-protocol:local-name node)
 522       (xpath-protocol:namespace-uri node)))
 523     (t
 524      (error "don't know how to copy node ~A" node))))
 525
 526 (defun compile-message (fn args env)
 527   (let ((thunk (compile-instruction `(progn ,@args) env)))
 528     (lambda (ctx)
 529       (funcall fn
 530                (with-xml-output (cxml:make-string-sink)
 531                  (funcall thunk ctx))))))
 532
 533 (define-instruction xsl:apply-templates (args env)
 534   (destructuring-bind ((&key select mode) &rest param-binding-specs) args
 535     (let* ((decls
 536             (when (and (consp (car param-binding-specs))
 537                        (eq (caar param-binding-specs) 'declare))
 538               (cdr (pop param-binding-specs))))
 539            (select-thunk
 540             (compile-xpath (or select "child::node()") env))
 541            (param-bindings
 542             (compile-var-bindings param-binding-specs env))
 543            (sort-predicate
 544             (when decls
 545               (make-sort-predicate decls env))))
 546       (multiple-value-bind (mode-local-name mode-uri)
 547           (and mode (decode-qname mode env nil))
 548         (lambda (ctx)
 549           (apply-templates/list
 550            (xpath::force
 551             (xpath::sorted-pipe-of (funcall select-thunk ctx)))
 552            :param-bindings
 553            (loop for (name nil value-thunk) in param-bindings
 554               collect (list name (funcall value-thunk ctx)))
 555            :sort-predicate sort-predicate
 556            :mode (when mode
 557                    (or (find-mode *stylesheet*
 558                                   mode-local-name
 559                                   mode-uri)
 560                        *empty-mode*))))))))
 561
 562 (define-instruction xsl:apply-imports (args env)
 563   (declare (ignore args env))
 564   (lambda (ctx)
 565     (declare (ignore ctx))
 566     (funcall *apply-imports*)))
 567
 568 (define-instruction xsl:call-template (args env)
 569   (destructuring-bind (name &rest param-binding-specs) args
 570       (let ((param-bindings
 571              (compile-var-bindings param-binding-specs env)))
 572         (multiple-value-bind (local-name uri)
 573             (decode-qname name env nil)
 574           (setf name (cons local-name uri)))
 575         (lambda (ctx)
 576           (call-template ctx name
 577                          (loop for (name nil value-thunk) in param-bindings
 578                                collect (list name (funcall value-thunk ctx))))))))
 579
 580 ;; fixme: incompatible with XSLT 2.0
 581 (define-instruction xsl:document (args env)
 582   (destructuring-bind ((href &key method indent doctype-public doctype-system)
 583                        &body body)
 584       args
 585     (declare (ignore doctype-public doctype-system)) ;fixme
 586     (let ((thunk (compile-instruction `(progn ,@body) env))
 587           (href-thunk (compile-avt href env)))
 588       (lambda (ctx)
 589         (let ((pathname
 590                (uri-to-pathname
 591                 (puri:merge-uris (funcall href-thunk ctx)
 592                                  (xpath-protocol:base-uri
 593                                   (xpath:context-node ctx))))))
 594           (ensure-directories-exist pathname) ;really?
 595           (invoke-with-output-sink
 596            (lambda ()
 597              (funcall thunk ctx))
 598            (make-output-specification :method (or method "XML") :indent indent)
 599            pathname))))))
 600
 601 (defun compile-instruction (form env)
 602   (xslt-trace-thunk
 603    (funcall (or (get (car form) 'xslt-instruction)
 604                 (error "undefined instruction: ~A" (car form)))
 605             (cdr form)
 606             env)
 607    "instruction ~s" (car form)))
 608
 609 ;;: WTF: "A right curly brace inside a Literal in an expression is not
 610 ;;; recognized as terminating the expression."
 611 ;;;
 612 ;;; Da hilft nur tagbody.
 613 (defun parse-attribute-value-template (template-string)
 614   (with-input-from-string (input template-string)
 615     (let ((ordinary (make-string-output-stream))
 616           (xpath (make-string-output-stream))
 617           (tokens '())
 618           (c (read-char input nil :eof)))
 619       (flet ((emit ()
 620                (let ((o (get-output-stream-string ordinary)))
 621                  (when (plusp (length o))
 622                    (push (list :data o) tokens)))
 623                (let ((x (get-output-stream-string xpath)))
 624                  (when (plusp (length x))
 625                    (push (list :xpath x) tokens))))
 626              (collect-ordinary ()
 627                (write-char c ordinary))
 628              (collect-xpath ()
 629                (write-char c xpath)))
 630         (macrolet ((goto (target)
 631                      `(progn
 632                         (setf c (read-char input nil :eof))
 633                         (go ,target))))
 634           (tagbody
 635            ordinary
 636              (case c
 637                (#\{
 638                 (goto seen{))
 639                (#\}
 640                 (goto seen-stray-}))
 641                (:eof
 642                 (go done)))
 643              (collect-ordinary)
 644              (goto ordinary)
 645
 646            seen{
 647              (case c
 648                (#\{
 649                 (collect-ordinary)
 650                 (goto ordinary))
 651                (#\'
 652                 (collect-xpath)
 653                 (goto in-single-quote))
 654                (:eof
 655                 (xslt-error "unexpected end of avt")))
 656              (emit)
 657              (collect-xpath)
 658              (goto xpath)
 659
 660            xpath
 661              (case c
 662                (#\'
 663                 (collect-xpath)
 664                 (goto in-single-quote))
 665                (#\"
 666                 (collect-xpath)
 667                 (goto in-double-quote))
 668                (#\}
 669                 (goto seen-closing-}))
 670                (:eof
 671                 (xslt-error "unexpected end of avt")))
 672              (collect-xpath)
 673              (goto xpath)
 674
 675            in-single-quote
 676              (case c
 677                (#\'
 678                 (collect-xpath)
 679                 (goto xpath))
 680                (:eof
 681                 (xslt-error "unexpected end of avt")))
 682              (collect-xpath)
 683              (goto in-single-quote)
 684
 685            in-double-quote
 686              (case c
 687                (#\"
 688                 (collect-xpath)
 689                 (goto xpath))
 690                (:eof
 691                 (xslt-error "unexpected end of avt")))
 692              (collect-xpath)
 693              (goto in-double-quote)
 694
 695            seen-closing-}
 696              (case c
 697                (#\}
 698                 (collect-xpath)
 699                 (goto xpath))
 700                (#\{
 701                 (emit)
 702                 (goto xpath))
 703                (:eof
 704                 (goto done)))
 705              (emit)
 706              (collect-ordinary)
 707              (goto ordinary)
 708
 709            seen-stray-}
 710              (case c
 711                (#\}
 712                 (collect-ordinary)
 713                 (goto ordinary)))
 714              (xslt-error "unexpected closing brace in avt")
 715
 716            done
 717              (emit))))
 718       (nreverse tokens))))
 719
 720 (defun compile-avt (template-string env)
 721   (let* ((constantp t)
 722          (fns
 723           (mapcar (lambda (x)
 724                     (ecase (car x)
 725                       (:data
 726                        (constantly (second x)))
 727                       (:xpath
 728                        (setf constantp nil)
 729                        (compile-xpath (second x) env))))
 730                   (parse-attribute-value-template template-string))))
 731     (values (lambda (ctx)
 732               (with-output-to-string (s)
 733                 (dolist (fn fns)
 734                   (write-string (xpath:string-value (funcall fn ctx)) s))))
 735             constantp)))
 736
 737
 738 ;;;; Indentation for slime
 739
 740 (defmacro define-indentation (name (&rest args))
 741   (labels ((collect-variables (list)
 742              (loop
 743                 for sub in list
 744                 append
 745                 (etypecase sub
 746                   (list
 747                    (collect-variables sub))
 748                   (symbol
 749                    (if (eql (mismatch "&" (symbol-name sub)) 1)
 750                        nil
 751                        (list sub)))))))
 752     `(defmacro ,name (,@args)
 753        (declare (ignorable ,@(collect-variables args)))
 754        (error "XSL indentation helper ~A used literally in lisp code"
 755               ',name))))
 756
 757 (define-indentation xsl:element
 758     ((name &key namespace use-attribute-sets) &body body))
 759 (define-indentation xsl:literal-element ((name &optional uri) &body body))
 760 (define-indentation xsl:attribute ((name &key namespace) &body body))
 761 (define-indentation xsl:literal-attribute ((name &optional uri) &body body))
 762 (define-indentation xsl:text (str))
 763 (define-indentation xsl:processing-instruction (name &body body))
 764 (define-indentation xsl:comment (&body body))
 765 (define-indentation xsl:value-of (xpath))
 766 (define-indentation xsl:unescaped-value-of (xpath))
 767 (define-indentation xsl:for-each (select &body decls-and-body))
 768 (define-indentation xsl:message (&body body))
 769 (define-indentation xsl:terminate (&body body))
 770 (define-indentation xsl:apply-templates ((&key select mode) &body decls-and-body))
 771 (define-indentation xsl:call-template (name &rest parameters))
 772 (define-indentation xsl:copy-of (xpath))
 773
 774 ;;;;
 775
 776 (defun test-instruction (form document)
 777   (let ((thunk (compile-instruction form (make-instance 'lexical-environment)))
 778         (root (cxml:parse document (stp:make-builder))))
 779     (with-xml-output (cxml:make-string-sink)
 780       (funcall thunk (xpath:make-context root)))))