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