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       (let ((body-thunk (compile-instruction `(progn ,@body) env)))
 101         (if constant-name-p
 102             (compile-element/constant-name name namespace env body-thunk)
 103             (compile-element/runtime name-thunk namespace body-thunk))))))
 104
 105 (defun compile-element/constant-name (qname namespace env body-thunk)
 106   ;; the simple case: compile-time decoding of the QName
 107   (multiple-value-bind (local-name uri prefix)
 108       (decode-qname qname env nil)
 109     (when namespace
 110       (setf uri namespace))
 111     (lambda (ctx)
 112       (with-element (local-name uri :suggested-prefix prefix)
 113         (funcall body-thunk ctx)))))
 114
 115 (defun compile-element/runtime (name-thunk namespace body-thunk)
 116   ;; run-time decoding of the QName, but using the same namespaces
 117   ;; that would have been known at compilation time.
 118   (let ((namespaces *namespaces*))
 119     (lambda (ctx)
 120       (let ((qname (funcall name-thunk ctx)))
 121         (multiple-value-bind (local-name uri prefix)
 122             (decode-qname/runtime qname namespaces nil)
 123           (when namespace
 124             (setf uri namespace))
 125           (lambda (ctx)
 126             (with-element (local-name uri :suggested-prefix prefix)
 127               (funcall body-thunk ctx))))))))
 128
 129 (define-instruction xsl:use-attribute-sets (args env)
 130   (destructuring-bind (str) args
 131     (let ((sets (mapcar (lambda (qname)
 132                           (multiple-value-list (decode-qname qname env nil)))
 133                         (words str))))
 134       (lambda (ctx)
 135         (loop for (local-name uri nil) in sets do
 136              (dolist (thunk (find-attribute-set local-name uri))
 137                (funcall thunk ctx)))))))
 138
 139 (define-instruction xsl:attribute (args env)
 140   (destructuring-bind ((name &key namespace) &body body) args
 141     (multiple-value-bind (name-thunk constant-name-p)
 142         (compile-attribute-value-template name env)
 143       (let ((value-thunk (compile-instruction `(progn ,@body) env)))
 144         (if constant-name-p
 145             (compile-attribute/constant-name name namespace env value-thunk)
 146             (compile-attribute/runtime name-thunk namespace value-thunk))))))
 147
 148 (defun compile-attribute/constant-name (qname namespace env value-thunk)
 149   ;; the simple case: compile-time decoding of the QName
 150   (multiple-value-bind (local-name uri prefix)
 151       (decode-qname qname env nil)
 152     (when namespace
 153       (setf uri namespace))
 154     (lambda (ctx)
 155       (write-attribute local-name
 156                        uri
 157                        (with-text-output-sink (s)
 158                          (with-xml-output s
 159                            (funcall value-thunk ctx)))
 160                        :suggested-prefix prefix))))
 161
 162 (defun compile-attribute/runtime (name-thunk namespace value-thunk)
 163   ;; run-time decoding of the QName, but using the same namespaces
 164   ;; that would have been known at compilation time.
 165   (let ((namespaces *namespaces*))
 166     (lambda (ctx)
 167       (let ((qname (funcall name-thunk ctx)))
 168         (multiple-value-bind (local-name uri prefix)
 169             (decode-qname/runtime qname namespaces nil)
 170           (when namespace
 171             (setf uri namespace))
 172           (lambda (ctx)
 173             (write-attribute local-name
 174                              uri
 175                              (with-text-output-sink (s)
 176                                (with-xml-output s
 177                                  (funcall value-thunk ctx)))
 178                              :suggested-prefix prefix)))))))
 179
 180 (defun remove-excluded-namespaces
 181     (namespaces &optional (excluded-uris *excluded-namespaces*))
 182   (let ((koerbchen '())
 183         (kroepfchen '()))
 184     (loop
 185        for cons in namespaces
 186        for (prefix . uri) = cons
 187        do
 188          (cond
 189            ((find prefix kroepfchen :test #'equal))
 190            ((find uri excluded-uris :test #'equal)
 191             (push prefix kroepfchen))
 192            (t
 193             (push cons koerbchen))))
 194     koerbchen))
 195
 196 (define-instruction xsl:literal-element (args env)
 197   (destructuring-bind
 198         ((local-name &optional (uri "") suggested-prefix) &body body)
 199       args
 200     (let ((body-thunk (compile-instruction `(progn ,@body) env))
 201           (namespaces (remove-excluded-namespaces *namespaces*)))
 202       (lambda (ctx)
 203         (with-element (local-name uri
 204                                   :suggested-prefix suggested-prefix
 205                                   :extra-namespaces namespaces)
 206           (funcall body-thunk ctx))))))
 207
 208 (define-instruction xsl:literal-attribute (args env)
 209   (destructuring-bind ((local-name &optional uri suggested-prefix) value) args
 210     (let ((value-thunk (compile-attribute-value-template value env)))
 211       (lambda (ctx)
 212         (write-attribute local-name
 213                          uri
 214                          (funcall value-thunk ctx)
 215                          :suggested-prefix suggested-prefix)))))
 216
 217 (define-instruction xsl:text (args env)
 218   (destructuring-bind (str) args
 219     (lambda (ctx)
 220       (declare (ignore ctx))
 221       (write-text str))))
 222
 223 (define-instruction xsl:processing-instruction (args env)
 224   (destructuring-bind (name &rest body) args
 225     (let ((name-thunk (compile-attribute-value-template name env))
 226           (value-thunk (compile-instruction `(progn ,@body) env)))
 227       (lambda (ctx)
 228         (write-processing-instruction
 229          (funcall name-thunk ctx)
 230          (with-text-output-sink (s)
 231            (with-xml-output s
 232              (funcall value-thunk ctx))))))))
 233
 234 (define-instruction xsl:comment (args env)
 235   (destructuring-bind (str) args
 236     (lambda (ctx)
 237       (declare (ignore ctx))
 238       (write-comment str))))
 239
 240 (define-instruction xsl:value-of (args env)
 241   (destructuring-bind (xpath) args
 242     (let ((thunk (compile-xpath xpath env)))
 243       (lambda (ctx)
 244         (write-text (xpath:string-value (funcall thunk ctx)))))))
 245
 246 (define-instruction xsl:unescaped-value-of (args env)
 247   (destructuring-bind (xpath) args
 248     (let ((thunk (compile-xpath xpath env)))
 249       (lambda (ctx)
 250         (write-unescaped (xpath:string-value (funcall thunk ctx)))))))
 251
 252 (define-instruction xsl:copy-of (args env)
 253   (destructuring-bind (xpath) args
 254     (let ((thunk (compile-xpath xpath env))
 255           ;; FIXME: what was this for?  --david
 256           #+(or) (v (intern-variable "varName" "")))
 257       (lambda (ctx)
 258         (let ((result (funcall thunk ctx)))
 259           (typecase result
 260             (xpath:node-set ;; FIXME: variables can contain node sets w/fragments inside. Maybe just fragments would do?
 261              (xpath:map-node-set #'copy-into-result result))
 262             (result-tree-fragment
 263              (copy-into-result result))
 264             (t
 265              (write-text (xpath:string-value result)))))))))
 266
 267 (defun copy-into-result (node)
 268   (cond
 269     ((result-tree-fragment-p node)
 270      (stp:do-children (child (result-tree-fragment-node node))
 271        (copy-into-result child)))
 272     ((xpath-protocol:node-type-p node :element)
 273      (with-element ((xpath-protocol:local-name node)
 274                     (xpath-protocol:namespace-uri node)
 275                     :suggested-prefix (xpath-protocol:namespace-prefix node)
 276                     ;; FIXME: is remove-excluded-namespaces correct here?
 277                     :extra-namespaces (remove-excluded-namespaces
 278                                        (namespaces-as-alist node)))
 279        (map-pipe-eagerly #'copy-into-result
 280                          (xpath-protocol:attribute-pipe node))
 281        (map-pipe-eagerly #'copy-into-result
 282                          (xpath-protocol:child-pipe node))))
 283     ((xpath-protocol:node-type-p node :document)
 284      (map-pipe-eagerly #'copy-into-result
 285                        (xpath-protocol:child-pipe node)))
 286     (t
 287      (copy-leaf-node node))))
 288
 289 (defun make-sorter (spec env)
 290   (destructuring-bind (&key select lang data-type order case-order)
 291       (cdr spec)
 292     ;; FIXME: implement case-order
 293     (declare (ignore lang case-order))
 294     (let ((select-thunk (compile-xpath (or select ".") env))
 295           (numberp (equal data-type "number"))
 296           (f (if (equal order "descending") -1 1)))
 297       (lambda (a b)
 298         (let ((i (xpath:string-value
 299                   (funcall select-thunk (xpath:make-context a))))
 300               (j (xpath:string-value
 301                   (funcall select-thunk (xpath:make-context b)))))
 302           (* f
 303              (if numberp
 304                  (signum (- (xpath:number-value i) (xpath:number-value j)))
 305                  (cond
 306                    ((string< i j) -1)
 307                    ((equal i j) 0)
 308                    (t 1)))))))))
 309
 310 (defun compose-sorters (sorters)
 311   (if sorters
 312       (let ((this (car sorters))
 313             (next (compose-sorters (rest sorters))))
 314         (lambda (a b)
 315           (let ((d (funcall this a b)))
 316             (if (zerop d)
 317                 (funcall next a b)
 318                 d))))
 319       (constantly 0)))
 320
 321 (defun make-sort-predicate (decls env)
 322   (let ((sorter
 323          (compose-sorters
 324           (mapcar (lambda (x) (make-sorter x env)) decls))))
 325     (lambda (a b)
 326       (minusp (funcall sorter a b)))))
 327
 328 (define-instruction xsl:for-each (args env)
 329   (destructuring-bind (select &optional decls &rest body) args
 330     (unless (and (consp decls)
 331                  (eq (car decls) 'declare))
 332       (push decls body)
 333       (setf decls nil))
 334     (let ((select-thunk (compile-xpath select env))
 335           (body-thunk (compile-instruction `(progn ,@body) env))
 336           (sort-predicate
 337            (when decls
 338              (make-sort-predicate (cdr decls) env))))
 339       (lambda (ctx)
 340         (let* ((nodes (xpath:all-nodes (funcall select-thunk ctx)))
 341                (n (length nodes)))
 342           (when sort-predicate
 343             (setf nodes (sort nodes sort-predicate)))
 344           (loop
 345              for node in nodes
 346              for i from 1
 347              do
 348                (funcall body-thunk
 349                         (xpath:make-context node (lambda () n) i))))))))
 350
 351 (define-instruction xsl:with-namespaces (args env)
 352   (destructuring-bind ((&rest forms) &rest body) args
 353     (let ((*namespaces* *namespaces*))
 354       (dolist (form forms)
 355         (destructuring-bind (prefix uri) form
 356           (push (cons prefix uri) *namespaces*)))
 357       (compile-instruction `(progn ,@body) env))))
 358
 359 (define-instruction xsl:with-excluded-namespaces (args env)
 360   (destructuring-bind ((&rest uris) &rest body) args
 361     (let ((*excluded-namespaces* (append uris *excluded-namespaces*)))
 362       (compile-instruction `(progn ,@body) env))))
 363
 364 ;; XSLT disallows multiple definitions of the same variable within a
 365 ;; template.  Local variables can shadow global variables though.
 366 ;; Since our LET syntax makes it natural to shadow local variables the
 367 ;; Lisp way, we check for duplicate variables only where instructed to
 368 ;; by the XML syntax parser using WITH-DUPLICATES-CHECK:
 369 (defvar *template-variables* nil)
 370
 371 (define-instruction xsl:with-duplicates-check (args env)
 372   (let ((*template-variables* *template-variables*))
 373     (destructuring-bind ((&rest qnames) &rest body) args
 374       (dolist (qname qnames)
 375         (multiple-value-bind (local-name uri)
 376             (decode-qname qname env nil)
 377           (let ((key (cons local-name uri)))
 378             (when (find key *template-variables* :test #'equal)
 379               (xslt-error "duplicate variable: ~A, ~A" local-name uri))
 380             (push key *template-variables*))))
 381       (compile-instruction `(progn ,@body) env))))
 382
 383 (define-instruction xsl:with-base-uri (args env)
 384   (destructuring-bind (uri &rest body) args
 385     (let ((*instruction-base-uri* uri))
 386       (compile-instruction `(progn ,@body) env))))
 387
 388 (defstruct (result-tree-fragment
 389              (:constructor make-result-tree-fragment (node)))
 390   node)
 391
 392 (defmethod xpath-protocol:node-p ((node result-tree-fragment))
 393   t)
 394
 395 (defmethod xpath-protocol:string-value ((node result-tree-fragment))
 396   (xpath-protocol:string-value (result-tree-fragment-node node)))
 397
 398 (defun apply-to-result-tree-fragment (ctx thunk)
 399   (let ((document
 400          (with-xml-output (stp:make-builder)
 401            (with-element ("fragment" "")
 402              (funcall thunk ctx)))))
 403     (make-result-tree-fragment (stp:document-element document))))
 404
 405 (define-instruction let (args env)
 406   (destructuring-bind ((&rest forms) &rest body) args
 407     (let* ((old-top (length *lexical-variable-declarations*))
 408            (vars-and-names (compile-var-bindings/nointern forms env))
 409            (vars-and-positions
 410             (loop for ((local-name . uri) thunk) in vars-and-names
 411                collect
 412                  (list (push-variable local-name
 413                                       uri
 414                                       *lexical-variable-declarations*)
 415                        thunk))))
 416       (let ((thunk (compile-instruction `(progn ,@body) env)))
 417         (fill *lexical-variable-declarations* nil :start old-top)
 418         (lambda (ctx)
 419           (loop for (index var-thunk) in vars-and-positions
 420              do (setf (lexical-variable-value index)
 421                       (funcall var-thunk ctx)))
 422           (funcall thunk ctx))))))
 423
 424 (define-instruction let* (args env)
 425   (destructuring-bind ((&rest forms) &rest body) args
 426     (if forms
 427         (compile-instruction `(let (,(car forms))
 428                                 (let* (,@(cdr forms))
 429                                   ,@body))
 430                              env)
 431         (compile-instruction `(progn ,@body) env))))
 432
 433 (define-instruction xsl:message (args env)
 434   (compile-message #'warn args env))
 435
 436 (define-instruction xsl:terminate (args env)
 437   (compile-message #'error args env))
 438
 439 (defun namespaces-as-alist (element)
 440   (let ((namespaces '()))
 441     (do-pipe (ns (xpath-protocol:namespace-pipe element))
 442       (push (cons (xpath-protocol:local-name ns)
 443                   (xpath-protocol:namespace-uri ns))
 444             namespaces))
 445     namespaces))
 446
 447 (define-instruction xsl:copy (args env)
 448   (let ((body (compile-instruction `(progn ,@args) env)))
 449     (lambda (ctx)
 450       (let ((node (xpath:context-node ctx)))
 451         (cond
 452           ((xpath-protocol:node-type-p node :element)
 453            (with-element
 454                ((xpath-protocol:local-name node)
 455                 (xpath-protocol:namespace-uri node)
 456                 :suggested-prefix (xpath-protocol:namespace-prefix node)
 457                 :extra-namespaces (namespaces-as-alist node))
 458              (funcall body ctx)))
 459           ((xpath-protocol:node-type-p node :document)
 460            (funcall body ctx))
 461           (t
 462            (copy-leaf-node node)))))))
 463
 464 (defun copy-leaf-node (node)
 465   (cond
 466     ((xpath-protocol:node-type-p node :text)
 467      (write-text (xpath-protocol:string-value node)))
 468     ((xpath-protocol:node-type-p node :comment)
 469      (write-comment (xpath-protocol:string-value node)))
 470     ((xpath-protocol:node-type-p node :processing-instruction)
 471      (write-processing-instruction
 472          (xpath-protocol:processing-instruction-target node)
 473        (xpath-protocol:string-value node)))
 474     ((xpath-protocol:node-type-p node :attribute)
 475      (write-attribute
 476       (xpath-protocol:local-name node)
 477       (xpath-protocol:namespace-uri node)
 478       (xpath-protocol:string-value node)
 479       :suggested-prefix (xpath-protocol:namespace-prefix node)))
 480     (t
 481      (error "don't know how to copy node ~A" node))))
 482
 483 (defun compile-message (fn args env)
 484   (let ((thunk (compile-instruction `(progn ,@args) env)))
 485     (lambda (ctx)
 486       (funcall fn
 487                (with-xml-output (cxml:make-string-sink)
 488                  (funcall thunk ctx))))))
 489
 490 (define-instruction xsl:apply-templates (args env)
 491   (destructuring-bind ((&key select mode) &rest param-binding-specs) args
 492     (let* ((decls
 493             (when (and (consp (car param-binding-specs))
 494                        (eq (caar param-binding-specs) 'declare))
 495               (cdr (pop param-binding-specs))))
 496            (select-thunk
 497             (compile-xpath (or select "child::node()") env))
 498            (param-bindings
 499             (compile-var-bindings param-binding-specs env))
 500            (sort-predicate
 501             (when decls
 502               (make-sort-predicate decls env))))
 503       (multiple-value-bind (mode-local-name mode-uri)
 504           (and mode (decode-qname mode env nil))
 505         (lambda (ctx)
 506           (let ((*mode* (if mode
 507                             (or (find-mode *stylesheet*
 508                                            mode-local-name
 509                                            mode-uri)
 510                                 *empty-mode*)
 511                             *mode*)))
 512             (apply-templates/list
 513              (xpath:all-nodes (funcall select-thunk ctx))
 514              (loop for (name nil value-thunk) in param-bindings
 515                 collect (list name (funcall value-thunk ctx)))
 516              sort-predicate)))))))
 517
 518 (define-instruction xsl:apply-imports (args env)
 519   (lambda (ctx)
 520     (declare (ignore ctx))
 521     (funcall *apply-imports*)))
 522
 523 (define-instruction xsl:call-template (args env)
 524   (destructuring-bind (name &rest param-binding-specs) args
 525       (let ((param-bindings
 526              (compile-var-bindings param-binding-specs env)))
 527         (multiple-value-bind (local-name uri)
 528             (decode-qname name env nil)
 529           (setf name (cons local-name uri)))
 530         (lambda (ctx)
 531           (call-template ctx name
 532                          (loop for (name nil value-thunk) in param-bindings
 533                                collect (list name (funcall value-thunk ctx))))))))
 534
 535 (defun compile-instruction (form env)
 536   (funcall (or (get (car form) 'xslt-instruction)
 537                (error "undefined instruction: ~A" (car form)))
 538            (cdr form)
 539            env))
 540
 541 (xpath::deflexer make-attribute-template-lexer
 542   ("([^{]+)" (data) (values :data data))
 543   ("{([^}]+)}" (xpath) (values :xpath xpath)))
 544
 545 (defun compile-attribute-value-template (template-string env)
 546   (let* ((lexer (make-attribute-template-lexer template-string))
 547          (constantp t)
 548          (fns
 549           (loop
 550              collect
 551                (multiple-value-bind (kind str) (funcall lexer)
 552                  (ecase kind
 553                    (:data
 554                     (constantly str))
 555                    (:xpath
 556                     (setf constantp nil)
 557                     (xpath:compile-xpath str env))
 558                    ((nil)
 559                     (return result))))
 560              into result)))
 561     (values (lambda (ctx)
 562               (with-output-to-string (s)
 563                 (dolist (fn fns)
 564                   (write-string (xpath:string-value (funcall fn ctx)) s))))
 565             constantp)))
 566
 567
 568 ;;;; Indentation for slime
 569
 570 (defmacro define-indentation (name (&rest args))
 571   (labels ((collect-variables (list)
 572              (loop
 573                 for sub in list
 574                 append
 575                 (etypecase sub
 576                   (list
 577                    (collect-variables sub))
 578                   (symbol
 579                    (if (eql (mismatch "&" (symbol-name sub)) 1)
 580                        nil
 581                        (list sub)))))))
 582     `(defmacro ,name (,@args)
 583        (declare (ignorable ,@(collect-variables args)))
 584        (error "XSL indentation helper ~A used literally in lisp code"
 585               ',name))))
 586
 587 (define-indentation xsl:element
 588     ((name &key namespace use-attribute-sets) &body body))
 589 (define-indentation xsl:literal-element ((name &optional uri) &body body))
 590 (define-indentation xsl:attribute ((name &key namespace) &body body))
 591 (define-indentation xsl:literal-attribute ((name &optional uri) &body body))
 592 (define-indentation xsl:text (str))
 593 (define-indentation xsl:processing-instruction (name &body body))
 594 (define-indentation xsl:comment (str))
 595 (define-indentation xsl:value-of (xpath))
 596 (define-indentation xsl:unescaped-value-of (xpath))
 597 (define-indentation xsl:for-each (select &body decls-and-body))
 598 (define-indentation xsl:message (&body body))
 599 (define-indentation xsl:terminate (&body body))
 600 (define-indentation xsl:apply-templates ((&key select mode) &body decls-and-body))
 601 (define-indentation xsl:call-template (name &rest parameters))
 602 (define-indentation xsl:copy-of (xpath))
 603
 604 ;;;;
 605
 606 (defun test-instruction (form document)
 607   (let ((thunk (compile-instruction form (make-instance 'lexical-environment)))
 608         (root (cxml:parse document (stp:make-builder))))
 609     (with-xml-output (cxml:make-string-sink)
 610       (funcall thunk (xpath:make-context root)))))