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