instructions.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
   2
   3 ;;; Copyright (c) 2007,2008 David Lichteblau, Ivan Shvedunov.
   4 ;;; All rights reserved.
   5
   6 ;;; Redistribution and use in source and binary forms, with or without
   7 ;;; modification, are permitted provided that the following conditions
   8 ;;; are met:
   9 ;;;
  10 ;;;   * Redistributions of source code must retain the above copyright
  11 ;;;     notice, this list of conditions and the following disclaimer.
  12 ;;;
  13 ;;;   * Redistributions in binary form must reproduce the above
  14 ;;;     copyright notice, this list of conditions and the following
  15 ;;;     disclaimer in the documentation and/or other materials
  16 ;;;     provided with the distribution.
  17 ;;;
  18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  21 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  29
  30 (in-package :xuriella)
  31
  32 #+sbcl
  33 (declaim (optimize (debug 2)))
  34
  35
  36 ;;;; Instructions
  37
  38 (defparameter *builtin-instructions* (make-hash-table :test 'equal))
  39
  40 (defmacro define-instruction (name (args-var env-var) &body body)
  41   `(setf (get ',name 'xslt-instruction)
  42          (lambda (,args-var ,env-var)
  43            (declare (ignorable ,env-var))
  44            ,@body)))
  45
  46 (define-instruction if (args env)
  47   (destructuring-bind (test then &optional else) args
  48     (let ((test-thunk (compile-xpath test env))
  49           (then-thunk (compile-instruction then env))
  50           (else-thunk (when else (compile-instruction else env))))
  51       (lambda (ctx)
  52         (cond
  53           ((xpath:boolean-value (funcall test-thunk ctx))
  54            (funcall then-thunk ctx))
  55           (else-thunk
  56            (funcall else-thunk ctx)))))))
  57
  58 (define-instruction when (args env)
  59   (destructuring-bind (test &rest body) args
  60     (compile-instruction `(if ,test (progn ,@body)) env)))
  61
  62 (define-instruction unless (args env)
  63   (destructuring-bind (test &rest body) args
  64     (compile-instruction `(if (:not ,test) (progn ,@body)) env)))
  65
  66 (define-instruction cond (args env)
  67   (if args
  68       (destructuring-bind ((test &body body) &rest clauses) args
  69         (compile-instruction (if (eq test t)
  70                                  `(progn ,@body)
  71                                  `(if ,test
  72                                       (progn ,@body)
  73                                       (cond ,@clauses)))
  74                              env))
  75       (constantly nil)))
  76
  77 (define-instruction progn (args env)
  78   (if args
  79       (let ((first-thunk (compile-instruction (first args) env))
  80             (rest-thunk (compile-instruction `(progn ,@(rest args)) env)))
  81         (lambda (ctx)
  82           (funcall first-thunk ctx)
  83           (funcall rest-thunk ctx)))
  84       (constantly nil)))
  85
  86 (defun decode-qname/runtime (qname namespaces attributep)
  87   (handler-case
  88       (multiple-value-bind (prefix local-name)
  89           (split-qname qname)
  90         (values local-name
  91                 (if (or prefix (not attributep))
  92                     (or (cdr (assoc prefix namespaces :test 'equal))
  93                         (xslt-error "namespace not found: ~A" prefix))
  94                     "")
  95                 prefix))
  96     (cxml:well-formedness-violation ()
  97       (xslt-error "not a qname: ~A" qname))))
  98
  99 (define-instruction xsl:element (args env)
 100   (destructuring-bind ((name &key namespace use-attribute-sets)
 101                        &body body)
 102       args
 103     (declare (ignore use-attribute-sets)) ;fixme
 104     (multiple-value-bind (name-thunk constant-name-p)
 105         (compile-avt name env)
 106       (multiple-value-bind (ns-thunk constant-ns-p)
 107           (if namespace
 108               (compile-avt namespace env)
 109               (values nil t))
 110         (let ((body-thunk (compile-instruction `(progn ,@body) env)))
 111           (if (and constant-name-p constant-ns-p)
 112               (compile-element/constant-name name namespace env body-thunk)
 113               (compile-element/runtime name-thunk ns-thunk body-thunk)))))))
 114
 115 (defun compile-element/constant-name (qname namespace env body-thunk)
 116   ;; the simple case: compile-time decoding of the QName
 117   (multiple-value-bind (local-name uri prefix)
 118       (decode-qname qname env nil :allow-unknown-namespace t)
 119     (when namespace
 120       (setf uri namespace))
 121     (lambda (ctx)
 122       (cond
 123         (uri
 124          (with-element (local-name uri :suggested-prefix prefix)
 125            (funcall body-thunk ctx)))
 126         (t
 127          ;; ERROR rather than CERROR because saxon doesn't do the recovery,
 128          ;; and the official output illustrates recovery but is useless as
 129          ;; always.
 130          (xslt-error "namespace not found: ~A" prefix)
 131          #+(or)
 132          (let ((*start-tag-written-p* t))
 133            (declare (special *start-tag-written-p*))
 134            (funcall body-thunk ctx)))))))
 135
 136 (defun compile-element/runtime (name-thunk ns-thunk body-thunk)
 137   ;; run-time decoding of the QName, but using the same namespaces
 138   ;; that would have been known at compilation time.
 139   (let ((namespaces *namespaces*))
 140     (lambda (ctx)
 141       (let ((qname (funcall name-thunk ctx)))
 142         (multiple-value-bind (local-name uri prefix)
 143             (decode-qname/runtime qname namespaces nil)
 144           (when ns-thunk
 145             (setf uri (funcall ns-thunk ctx)))
 146           (unless uri
 147             (setf uri ""))
 148           (with-element (local-name uri :suggested-prefix prefix)
 149             (funcall body-thunk ctx)))))))
 150
 151 (define-instruction xsl:use-attribute-sets (args env)
 152   (destructuring-bind (str) args
 153     (let ((sets (mapcar (lambda (qname)
 154                           (multiple-value-list (decode-qname qname env nil)))
 155                         (words str))))
 156       (lambda (ctx)
 157         (loop for (local-name uri nil) in sets do
 158              (dolist (thunk (find-attribute-set local-name uri))
 159                (funcall thunk ctx)))))))
 160
 161 (define-instruction xsl:attribute (args env)
 162   (destructuring-bind ((name &key namespace) &body body) args
 163     (when (null name)
 164       (xslt-error "xsl:attribute: name not specified"))
 165     (multiple-value-bind (name-thunk constant-name-p)
 166         (compile-avt name env)
 167       (multiple-value-bind (ns-thunk constant-ns-p)
 168           (if namespace
 169               (compile-avt namespace env)
 170               (values nil t))
 171         (let ((value-thunk (compile-instruction `(progn ,@body) env)))
 172           (if (and constant-name-p constant-ns-p)
 173               (compile-attribute/constant-name name namespace env value-thunk)
 174               (compile-attribute/runtime name-thunk ns-thunk value-thunk)))))))
 175
 176 (defun compile-attribute/constant-name (qname namespace env value-thunk)
 177   ;; the simple case: compile-time decoding of the QName
 178   (multiple-value-bind (local-name uri prefix)
 179       (decode-qname qname env t :allow-unknown-namespace t)
 180     (when namespace
 181       (setf uri namespace))
 182     (lambda (ctx)
 183       (write-attribute local-name
 184                        (or uri "")
 185                        (with-toplevel-text-output-sink (s)
 186                          (with-xml-output s
 187                            (funcall value-thunk ctx)))
 188                        :suggested-prefix prefix))))
 189
 190 (defun compile-attribute/runtime (name-thunk ns-thunk value-thunk)
 191   ;; run-time decoding of the QName, but using the same namespaces
 192   ;; that would have been known at compilation time.
 193   (let ((namespaces *namespaces*))
 194     (lambda (ctx)
 195       (let ((qname (funcall name-thunk ctx)))
 196         (multiple-value-bind (local-name uri prefix)
 197             (decode-qname/runtime qname namespaces t)
 198           (when ns-thunk
 199             (setf uri (funcall ns-thunk ctx)))
 200           (write-attribute local-name
 201                            (or uri "")
 202                            (with-toplevel-text-output-sink (s)
 203                              (with-xml-output s
 204                                (funcall value-thunk ctx)))
 205                            :suggested-prefix prefix))))))
 206
 207 ;; zzz Also elides (later) namespaces hidden by (earlier) ones.
 208 ;; zzz Reverses order.
 209 ;;
 210 ;; zzz fix the huge kludge that included-after-all-for-weird-reason-uris is
 211 ;;
 212 (defun remove-excluded-namespaces
 213     (namespaces &optional (excluded-uris *excluded-namespaces*)
 214                           included-after-all-for-weird-reason-uris)
 215   (let ((koerbchen '())
 216         (kroepfchen '()))
 217     (loop
 218        for cons in namespaces
 219        for (prefix* . uri) = cons
 220        for prefix = (or prefix* "")
 221        do
 222          (cond
 223            ((find prefix kroepfchen :test #'equal))
 224            ((find prefix koerbchen :test #'equal :key #'car))
 225            ((and (find uri excluded-uris :test #'equal)
 226                  (not (find uri included-after-all-for-weird-reason-uris
 227                             :test #'equal)))
 228             (push prefix kroepfchen))
 229            (t
 230             (push cons koerbchen))))
 231     koerbchen))
 232
 233 ;; FIXME!
 234 (defun collect-literal-attribute-namespaces-KLUDGE (body)
 235   (loop
 236      for frob in body
 237      when (and (consp frob) (eq (car frob) 'xsl:literal-attribute))
 238      collect (second (second frob))))
 239
 240 ;; FIXME!
 241 (defun not-actually-excluded-namespaces-KLUDGE (element-uri body)
 242   (mapcan (lambda (uri)
 243             (multiple-value-bind (unaliased-uri matchp)
 244                 (gethash uri (stylesheet-namespace-aliases *stylesheet*))
 245               (if matchp
 246                   (list unaliased-uri)
 247                   nil)))
 248           (cons element-uri
 249                 (remove-if
 250                  (lambda (x) (zerop (length x)))
 251                  (collect-literal-attribute-namespaces-KLUDGE body)))))
 252
 253 (define-instruction xsl:literal-element (args env)
 254   (destructuring-bind
 255         ((local-name &optional (uri "") suggested-prefix) &body body)
 256       args
 257     (let ((body-thunk (compile-instruction `(progn ,@body) env))
 258           (namespaces (remove-excluded-namespaces
 259                        *namespaces*
 260                        *excluded-namespaces*
 261                        (not-actually-excluded-namespaces-KLUDGE uri body))))
 262       (lambda (ctx)
 263         (with-element (local-name (or uri "")
 264                                   :suggested-prefix suggested-prefix
 265                                   :extra-namespaces namespaces
 266                                   :process-aliases t)
 267           (funcall body-thunk ctx))))))
 268
 269 (define-instruction xsl:literal-attribute (args env)
 270   (destructuring-bind ((local-name &optional uri suggested-prefix) value) args
 271     (let ((value-thunk (compile-avt value env)))
 272       (lambda (ctx)
 273         (write-attribute local-name
 274                          uri
 275                          (funcall value-thunk ctx)
 276                          :process-aliases t
 277                          :suggested-prefix suggested-prefix)))))
 278
 279 (define-instruction xsl:text (args env)
 280   (destructuring-bind (str) args
 281     (lambda (ctx)
 282       (declare (ignore ctx))
 283       (write-text str))))
 284
 285 (define-instruction xsl:unescaped-text (args env)
 286   (destructuring-bind (str) args
 287     (lambda (ctx)
 288       (declare (ignore ctx))
 289       (write-unescaped str))))
 290
 291 (define-instruction xsl:processing-instruction (args env)
 292   (destructuring-bind (name &rest body) args
 293     (let ((name-thunk (compile-avt name env))
 294           (value-thunk (compile-instruction `(progn ,@body) env)))
 295       (lambda (ctx)
 296         (write-processing-instruction
 297          (funcall name-thunk ctx)
 298          (with-toplevel-text-output-sink (s)
 299            (with-xml-output s
 300              (funcall value-thunk ctx))))))))
 301
 302 (define-instruction xsl:comment (args env)
 303   (let ((value-thunk (compile-instruction `(progn ,@args) env)))
 304     (lambda (ctx)
 305       (write-comment (with-toplevel-text-output-sink (s)
 306                        (with-xml-output s
 307                          (funcall value-thunk ctx)))))))
 308
 309 (define-instruction xsl:value-of (args env)
 310   (destructuring-bind (xpath) args
 311     (let ((thunk (compile-xpath xpath env)))
 312       (xslt-trace-thunk
 313        (lambda (ctx)
 314          (write-text (xpath:string-value (funcall thunk ctx))))
 315        "value-of ~s = ~s" xpath :result))))
 316
 317 (define-instruction xsl:unescaped-value-of (args env)
 318   (destructuring-bind (xpath) args
 319     (let ((thunk (compile-xpath xpath env)))
 320       (lambda (ctx)
 321         (write-unescaped (xpath:string-value (funcall thunk ctx)))))))
 322
 323 (define-instruction xsl:copy-of (args env)
 324   (destructuring-bind (xpath) args
 325     (let ((thunk (compile-xpath xpath env))
 326           ;; FIXME: what was this for?  --david
 327           #+(or) (v (intern-variable "varName" "")))
 328       (xslt-trace-thunk
 329        (lambda (ctx)
 330          (let ((result (funcall thunk ctx)))
 331            (typecase result
 332              (xpath:node-set ;; FIXME: variables can contain node sets w/fragments inside. Maybe just fragments would do?
 333               (xpath:map-node-set #'copy-into-result (xpath:sort-node-set result)))
 334              (result-tree-fragment
 335               (copy-into-result result))
 336              (t
 337               (write-text (xpath:string-value result))))))
 338        "copy-of ~s" xpath))))
 339
 340 (defun copy-into-result (node)
 341   (cond
 342     ((result-tree-fragment-p node)
 343      (stp:do-children (child (result-tree-fragment-node node))
 344        (copy-into-result child)))
 345     ((xpath-protocol:node-type-p node :element)
 346      (with-element ((xpath-protocol:local-name node)
 347                     (xpath-protocol:namespace-uri node)
 348                     :suggested-prefix (xpath-protocol:namespace-prefix node)
 349                     :extra-namespaces (namespaces-as-alist node))
 350        (map-pipe-eagerly #'copy-into-result
 351                          (xpath-protocol:attribute-pipe node))
 352        (map-pipe-eagerly #'copy-into-result
 353                          (xpath-protocol:child-pipe node))))
 354     ((xpath-protocol:node-type-p node :document)
 355      (map-pipe-eagerly #'copy-into-result
 356                        (xpath-protocol:child-pipe node)))
 357     (t
 358      (copy-leaf-node node))))
 359
 360 (defparameter *lower-first-order*
 361   #(#\  #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\0 #\1 #\2
 362     #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\: #\; #\< #\= #\> #\? #\@ #\H #\J #\L #\N #\P
 363     #\R #\T #\V #\X #\Z #\\ #\^ #\` #\b #\d #\f #\h #\j #\l #\n #\p #\r #\t #\v
 364     #\x #\z #\A #\B #\C #\D #\E #\F #\G #\I #\K #\M #\O #\Q #\S #\U #\W #\Y #\[
 365     #\] #\_ #\a #\c #\e #\g #\i #\k #\m #\o #\q #\s #\u #\w #\y #\{ #\| #\} #\~
 366     #\Rubout))
 367
 368 (defparameter *upper-first-order*
 369   #(#\  #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\0 #\1 #\2
 370     #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\: #\; #\< #\= #\> #\? #\@ #\G #\I #\K #\M #\O
 371     #\Q #\S #\U #\W #\Y #\[ #\] #\_ #\a #\c #\e #\g #\i #\k #\m #\o #\q #\s #\u
 372     #\w #\y #\A #\B #\C #\D #\E #\F #\H #\J #\L #\N #\P #\R #\T #\V #\X #\Z #\\
 373     #\^ #\` #\b #\d #\f #\h #\j #\l #\n #\p #\r #\t #\v #\x #\z #\{ #\| #\} #\~
 374     #\Rubout))
 375
 376 (defun collation-char (char table)
 377   (let ((code (char-code char)))
 378     (if (<= 32 code 127)
 379         (elt table (- code 32))
 380         char)))
 381
 382 (defun make-collation-key (str table)
 383   (map 'string (lambda (char) (collation-char char table)) str))
 384
 385 (defun compare-numbers (n-a n-b)
 386   (cond ((and (xpath::nan-p n-a)
 387               (not (xpath::nan-p n-b)))
 388          -1)
 389         ((and (not (xpath::nan-p n-a))
 390               (xpath::nan-p n-b))
 391          1)
 392         ((xpath::compare-numbers '< n-a n-b) -1)
 393         ((xpath::compare-numbers '> n-a n-b) 1)
 394         (t 0)))
 395
 396 (defun mismatch* (a b)
 397   (let ((pos (mismatch a b)))
 398     (if (and pos (< pos (min (length a) (length b))))
 399         pos
 400         nil)))
 401
 402 (defun compare-strings (i j char-table)
 403   ;; zzz Unicode support!
 404   (let ((pos
 405          (or (mismatch* (string-downcase i) (string-downcase j))
 406              (mismatch* i j))))
 407     (if pos
 408         (let ((c (collation-char (elt i pos) char-table))
 409               (d (collation-char (elt j pos) char-table)))
 410           (cond
 411             ((char< c d) -1)
 412             ((char= c d) 0)
 413             (t 1)))
 414         (signum (- (length i) (length j))))))
 415
 416 (defun sort/@data-type (str)
 417   (cond
 418     ((equal str "number")
 419      t)
 420     ((or (null str) (equal str "text"))
 421      nil)
 422     (t
 423      (xslt-error "invalid data-type in sort"))))
 424
 425 (defun sort/@case-order (str)
 426   (cond
 427     ((equal str "lower-first")
 428      *lower-first-order*)
 429     ((or (null str) (equal str "upper-first"))
 430      *upper-first-order*)
 431     (t
 432      (xslt-error "invalid case-order in sort"))))
 433
 434 (defun sort/@order (str)
 435   (cond
 436     ((equal str "descending")
 437      -1)
 438     ((or (null str) (equal str "ascending"))
 439      1)
 440     (t
 441      (xslt-error "invalid order in sort"))))
 442
 443 (defun compile-optional-avt (template-string env)
 444   (if template-string
 445       (compile-avt template-string env)
 446       (values (constantly nil) t)))
 447
 448 (defun make-sorter/lazy (spec env)
 449   (destructuring-bind (&key select lang data-type order case-order)
 450       (cdr spec)
 451     (let ((select-thunk (compile-xpath (or select ".") env))
 452           (lang-thunk (compile-optional-avt lang env))
 453           (data-type-thunk (compile-optional-avt data-type env))
 454           (order-thunk (compile-optional-avt order env))
 455           (case-order-thunk (compile-optional-avt case-order env)))
 456       (lambda (ctx)
 457         (let ((numberp (sort/@data-type (funcall data-type-thunk ctx)))
 458               (char-table (sort/@case-order (funcall case-order-thunk ctx)))
 459               (f (sort/@order (funcall order-thunk ctx)))
 460               (lang (funcall lang-thunk ctx)))
 461           (declare (ignore lang))
 462           (lambda (a b)
 463             (let ((i (xpath:string-value (funcall select-thunk a)))
 464                   (j (xpath:string-value (funcall select-thunk b))))
 465               (* f
 466                  (if numberp
 467                      (compare-numbers (xpath:number-value i)
 468                                       (xpath:number-value j))
 469                      (compare-strings i j char-table))))))))))
 470
 471 (defun compose-sorters/lazy (sorters)
 472   (if sorters
 473       (let ((this-thunk (car sorters))
 474             (next-thunk (compose-sorters/lazy (rest sorters))))
 475         (lambda (ctx)
 476           (let ((this (funcall this-thunk ctx))
 477                 (next (funcall next-thunk ctx)))
 478             (lambda (a b)
 479               (let ((d (funcall this a b)))
 480                 (if (zerop d)
 481                     (funcall next a b)
 482                     d))))))
 483       (lambda (ctx)
 484         (declare (ignore ctx))
 485         (constantly 0))))
 486
 487 (defun make-sort-predicate/lazy (decls env)
 488   (let ((sorter-thunk
 489          (compose-sorters/lazy
 490           (mapcar (lambda (x) (make-sorter/lazy x env)) decls))))
 491     (lambda (ctx)
 492       (let ((sorter (funcall sorter-thunk ctx)))
 493         (lambda (a b)
 494           (minusp (funcall sorter a b)))))))
 495
 496 (defun contextify-node-list (nodes)
 497   (let ((size (length nodes)))
 498     (loop
 499        for position from 1
 500        for node in nodes
 501        collect
 502          (xpath:make-context node size position))))
 503
 504 (define-instruction xsl:for-each (args env)
 505   (destructuring-bind (select &optional decls &rest body) args
 506     (unless (and (consp decls)
 507                  (eq (car decls) 'declare))
 508       (push decls body)
 509       (setf decls nil))
 510     (let ((select-thunk (compile-xpath select env))
 511           (body-thunk (compile-instruction `(progn ,@body) env))
 512           (sort-predicate-thunk
 513            (when (cdr decls)
 514              (make-sort-predicate/lazy (cdr decls) env))))
 515       (lambda (ctx)
 516         (let ((selected (funcall select-thunk ctx))
 517               (*apply-imports*
 518                (lambda (&optional ignore)
 519                  (declare (ignore ignore))
 520                  (xslt-error "apply-imports used in for-each"))))
 521           (unless (xpath:node-set-p selected)
 522             (xslt-error "for-each select expression should yield a node-set"))
 523           (let ((nodes (xpath::force (xpath::sorted-pipe-of selected))))
 524             (when sort-predicate-thunk
 525               (setf nodes
 526                     (mapcar #'xpath:context-node
 527                             (stable-sort (contextify-node-list nodes)
 528                                          (funcall sort-predicate-thunk ctx)))))
 529             (dolist (ctx (contextify-node-list nodes))
 530               (funcall body-thunk ctx))))))))
 531
 532 (define-instruction xsl:with-namespaces (args env)
 533   (destructuring-bind ((&rest forms) &rest body) args
 534     (let ((*namespaces* *namespaces*))
 535       (dolist (form forms)
 536         (destructuring-bind (prefix uri) form
 537           (push (cons prefix uri) *namespaces*)))
 538       (compile-instruction `(progn ,@body) env))))
 539
 540 (define-instruction xsl:with-excluded-namespaces (args env)
 541   (destructuring-bind ((&rest uris) &rest body) args
 542     (let ((*excluded-namespaces* (append uris *excluded-namespaces*)))
 543       (compile-instruction `(progn ,@body) env))))
 544
 545 (define-instruction xsl:with-extension-namespaces (args env)
 546   (destructuring-bind ((&rest uris) &rest body) args
 547     (let ((*extension-namespaces* (append uris *extension-namespaces*)))
 548       (compile-instruction `(progn ,@body) env))))
 549
 550 (define-instruction xsl:with-version (args env)
 551   (destructuring-bind (version &rest body) args
 552     (let ((*forwards-compatible-p* (not (equal version "1.0"))))
 553       (compile-instruction `(progn ,@body) env))))
 554
 555 ;; XSLT disallows multiple definitions of the same variable within a
 556 ;; template.  Local variables can shadow global variables though.
 557 ;; Since our LET syntax makes it natural to shadow local variables the
 558 ;; Lisp way, we check for duplicate variables only where instructed to
 559 ;; by the XML syntax parser using WITH-DUPLICATES-CHECK:
 560 (defvar *template-variables* nil)
 561
 562 (define-instruction xsl:with-duplicates-check (args env)
 563   (let ((*template-variables* *template-variables*))
 564     (destructuring-bind ((&rest qnames) &rest body) args
 565       (dolist (qname qnames)
 566         (multiple-value-bind (local-name uri)
 567             (decode-qname qname env nil)
 568           (let ((key (cons local-name uri)))
 569             (when (find key *template-variables* :test #'equal)
 570               (xslt-error "duplicate variable: ~A, ~A" local-name uri))
 571             (push key *template-variables*))))
 572       (compile-instruction `(progn ,@body) env))))
 573
 574 (define-instruction xsl:with-base-uri (args env)
 575   (destructuring-bind (uri &rest body) args
 576     (let ((*instruction-base-uri* uri))
 577       (compile-instruction `(progn ,@body) env))))
 578
 579 (defstruct (result-tree-fragment
 580              (:constructor make-result-tree-fragment (node)))
 581   node)
 582
 583 (define-default-method xpath-protocol:node-p
 584     ((node result-tree-fragment))
 585   t)
 586
 587 (define-default-method xpath-protocol:node-text
 588     ((node result-tree-fragment))
 589   (xpath-protocol:node-text (result-tree-fragment-node node)))
 590
 591 (defun apply-to-result-tree-fragment (ctx thunk)
 592   (let ((document
 593          (with-xml-output (make-stpx-builder)
 594            (with-element ("fragment" "")
 595              (funcall thunk ctx)))))
 596     (make-result-tree-fragment (stp:document-element document))))
 597
 598 (defun compile-var-bindings/nointern (forms env)
 599   (loop
 600     for (name value) in forms
 601     collect (multiple-value-bind (local-name uri)
 602                 (decode-qname name env nil)
 603               (list (cons local-name uri)
 604                     (xslt-trace-thunk
 605                      (compile-value-thunk value env)
 606                      "local variable ~s = ~s" name :result)))))
 607
 608 (define-instruction let (args env)
 609   (destructuring-bind ((&rest forms) &rest body) args
 610     (let* ((old-top (length *lexical-variable-declarations*))
 611            (vars-and-names (compile-var-bindings/nointern forms env))
 612            (vars-and-positions
 613             (loop for ((local-name . uri) thunk) in vars-and-names
 614                collect
 615                  (list (push-variable local-name
 616                                       uri
 617                                       *lexical-variable-declarations*)
 618                        thunk))))
 619       (let ((thunk (compile-instruction `(progn ,@body) env)))
 620         (fill *lexical-variable-declarations* nil :start old-top)
 621         (lambda (ctx)
 622           (loop for (index var-thunk) in vars-and-positions
 623              do (setf (lexical-variable-value index)
 624                       (funcall var-thunk ctx)))
 625           (funcall thunk ctx))))))
 626
 627 (define-instruction let* (args env)
 628   (destructuring-bind ((&rest forms) &rest body) args
 629     (if forms
 630         (compile-instruction `(let (,(car forms))
 631                                 (let* (,@(cdr forms))
 632                                   ,@body))
 633                              env)
 634         (compile-instruction `(progn ,@body) env))))
 635
 636 (define-instruction xsl:message (args env)
 637   (compile-message #'warn args env))
 638
 639 (define-instruction xsl:terminate (args env)
 640   (compile-message #'xslt-error args env))
 641
 642 (defun namespaces-as-alist (element)
 643   (let ((namespaces '()))
 644     (do-pipe (ns (xpath-protocol:namespace-pipe element))
 645       (push (cons (xpath-protocol:local-name ns)
 646                   (xpath-protocol:node-text ns))
 647             namespaces))
 648     namespaces))
 649
 650 (define-instruction xsl:copy (args env)
 651   (let ((body (compile-instruction `(progn ,@args) env)))
 652     (lambda (ctx)
 653       (let ((node (xpath:context-node ctx)))
 654         (cond
 655           ((xpath-protocol:node-type-p node :element)
 656            (with-element
 657                ((xpath-protocol:local-name node)
 658                 (xpath-protocol:namespace-uri node)
 659                 :suggested-prefix (xpath-protocol:namespace-prefix node)
 660                 :extra-namespaces (namespaces-as-alist node))
 661              (funcall body ctx)))
 662           ((xpath-protocol:node-type-p node :document)
 663            (funcall body ctx))
 664           (t
 665            (copy-leaf-node node)))))))
 666
 667 (defun copy-leaf-node (node)
 668   (cond
 669     ((xpath-protocol:node-type-p node :text)
 670      (etypecase (if (typep node 'stripping-node)
 671                     (stripping-node-target node)
 672                     node)
 673        (unescaped-text (write-unescaped (xpath-protocol:node-text node)))
 674        (stp:text (write-text (xpath-protocol:node-text node)))))
 675     ((xpath-protocol:node-type-p node :comment)
 676      (write-comment (xpath-protocol:node-text node)))
 677     ((xpath-protocol:node-type-p node :processing-instruction)
 678      (write-processing-instruction
 679          (xpath-protocol:processing-instruction-target node)
 680        (xpath-protocol:node-text node)))
 681     ((xpath-protocol:node-type-p node :attribute)
 682      (write-attribute
 683       (xpath-protocol:local-name node)
 684       (xpath-protocol:namespace-uri node)
 685       (xpath-protocol:node-text node)
 686       :suggested-prefix (xpath-protocol:namespace-prefix node)))
 687     ((xpath-protocol:node-type-p node :namespace)
 688      (write-extra-namespace
 689       (xpath-protocol:local-name node)
 690       (xpath-protocol:node-text node)
 691       nil))
 692     (t
 693      (error "don't know how to copy node ~A" node))))
 694
 695 (defun compile-message (fn args env)
 696   (let ((thunk (compile-instruction `(progn ,@args) env)))
 697     (lambda (ctx)
 698       (funcall fn
 699                (with-xml-output (cxml:make-string-sink)
 700                  (funcall thunk ctx))))))
 701
 702 (define-instruction xsl:apply-templates (args env)
 703   (destructuring-bind ((&key select mode) &rest param-binding-specs) args
 704     (let* ((decls
 705             (when (and (consp (car param-binding-specs))
 706                        (eq (caar param-binding-specs) 'declare))
 707               (cdr (pop param-binding-specs))))
 708            (select-thunk
 709             (compile-xpath (or select "child::node()") env))
 710            (param-bindings
 711             (compile-var-bindings param-binding-specs env))
 712            (sort-predicate-thunk
 713             (when decls
 714               (make-sort-predicate/lazy decls env))))
 715       (multiple-value-bind (mode-local-name mode-uri)
 716           (and mode (decode-qname mode env nil))
 717         (lambda (ctx)
 718           (apply-templates/list
 719            (xpath::force
 720             (xpath::sorted-pipe-of (funcall select-thunk ctx)))
 721            :param-bindings
 722            (loop for (name nil value-thunk) in param-bindings
 723               collect (list name (funcall value-thunk ctx)))
 724            :sort-predicate (when sort-predicate-thunk
 725                              (funcall sort-predicate-thunk ctx))
 726            :mode (when mode
 727                    (or (find-mode *stylesheet*
 728                                   mode-local-name
 729                                   mode-uri)
 730                        *empty-mode*))))))))
 731
 732 (define-instruction xsl:apply-imports (args env)
 733   (declare (ignore args env))
 734   (lambda (ctx)
 735     (declare (ignore ctx))
 736     (funcall *apply-imports*)))
 737
 738 (define-instruction xsl:call-template (args env)
 739   (destructuring-bind (name &rest param-binding-specs) args
 740     (let ((param-bindings
 741            (compile-var-bindings param-binding-specs env)))
 742       (multiple-value-bind (local-name uri)
 743           (decode-qname name env nil)
 744         (setf name (cons local-name uri)))
 745       (lambda (ctx)
 746         (call-template ctx name
 747                        (loop for (name nil value-thunk) in param-bindings
 748                           collect (list name (funcall value-thunk ctx))))))))
 749
 750 (defun compile-instruction (form env)
 751   "@arg[form]{An XSLT instruction in sexp representation}
 752    @arg[env]{An XSLT environment}
 753    @return{A compiled function}
 754
 755    @short{Compiles an XSLT instruction.}
 756
 757    This function is for use in XSLT extensions.  When defining an
 758    extension using @macro{define-extension-compiler}, pass body forms of
 759    the extension that should be interpreted as XSLT instructions to this
 760    function.
 761
 762    The environment is an opaque object, which can be obtained using
 763    the @code{&environment} lambda list keyword in the extension compiler."
 764   (xslt-trace-thunk
 765    (funcall (or (get (car form) 'xslt-instruction)
 766                 (get (car form) 'extension-compiler)
 767                 (error "undefined instruction: ~A" (car form)))
 768             (cdr form)
 769             env)
 770    "instruction ~s" (car form)))
 771
 772 ;;: WTF: "A right curly brace inside a Literal in an expression is not
 773 ;;; recognized as terminating the expression."
 774 ;;;
 775 ;;; Da hilft nur tagbody.
 776 (defun parse-attribute-value-template (template-string)
 777   (with-input-from-string (input template-string)
 778     (let ((ordinary (make-string-output-stream))
 779           (xpath (make-string-output-stream))
 780           (tokens '())
 781           (c (read-char input nil :eof)))
 782       (flet ((emit ()
 783                (let ((o (get-output-stream-string ordinary)))
 784                  (when (plusp (length o))
 785                    (push (list :data o) tokens)))
 786                (let ((x (get-output-stream-string xpath)))
 787                  (when (plusp (length x))
 788                    (push (list :xpath x) tokens))))
 789              (collect-ordinary ()
 790                (write-char c ordinary))
 791              (collect-xpath ()
 792                (write-char c xpath)))
 793         (macrolet ((goto (target)
 794                      `(progn
 795                         (setf c (read-char input nil :eof))
 796                         (go ,target))))
 797           (tagbody
 798            ordinary
 799              (case c
 800                (#\{
 801                 (goto seen{))
 802                (#\}
 803                 (goto seen-stray-}))
 804                (:eof
 805                 (go done)))
 806              (collect-ordinary)
 807              (goto ordinary)
 808
 809            seen{
 810              (case c
 811                (#\{
 812                 (collect-ordinary)
 813                 (goto ordinary))
 814                (#\'
 815                 (collect-xpath)
 816                 (goto in-single-quote))
 817                (:eof
 818                 (xslt-error "unexpected end of avt")))
 819              (emit)
 820              (collect-xpath)
 821              (goto xpath)
 822
 823            xpath
 824              (case c
 825                (#\'
 826                 (collect-xpath)
 827                 (goto in-single-quote))
 828                (#\"
 829                 (collect-xpath)
 830                 (goto in-double-quote))
 831                (#\}
 832                 (goto seen-closing-}))
 833                (:eof
 834                 (xslt-error "unexpected end of avt")))
 835              (collect-xpath)
 836              (goto xpath)
 837
 838            in-single-quote
 839              (case c
 840                (#\'
 841                 (collect-xpath)
 842                 (goto xpath))
 843                (:eof
 844                 (xslt-error "unexpected end of avt")))
 845              (collect-xpath)
 846              (goto in-single-quote)
 847
 848            in-double-quote
 849              (case c
 850                (#\"
 851                 (collect-xpath)
 852                 (goto xpath))
 853                (:eof
 854                 (xslt-error "unexpected end of avt")))
 855              (collect-xpath)
 856              (goto in-double-quote)
 857
 858            seen-closing-}
 859              (case c
 860                (#\}
 861                 (emit)
 862                 (goto seen-stray-}))
 863                (#\{
 864                 (emit)
 865                 (goto xpath))
 866                (:eof
 867                 (goto done)))
 868              (emit)
 869              (collect-ordinary)
 870              (goto ordinary)
 871
 872            seen-stray-}
 873              (case c
 874                (#\}
 875                 (collect-ordinary)
 876                 (goto ordinary)))
 877              (xslt-error "unexpected closing brace in avt")
 878
 879            done
 880              (emit))))
 881       (nreverse tokens))))
 882
 883 (defun compile-avt (template-string env)
 884   (let* ((constantp t)
 885          (fns
 886           (mapcar (lambda (x)
 887                     (ecase (car x)
 888                       (:data
 889                        (constantly (second x)))
 890                       (:xpath
 891                        (setf constantp nil)
 892                        (compile-xpath (second x) env))))
 893                   (if template-string
 894                       (parse-attribute-value-template template-string)
 895                       (xslt-error "missing avt")))))
 896     (values (lambda (ctx)
 897               (with-output-to-string (s)
 898                 (dolist (fn fns)
 899                   (write-string (xpath:string-value (funcall fn ctx)) s))))
 900             constantp)))
 901
 902
 903 ;;;; Indentation for slime
 904
 905 (defmacro define-indentation (name (&rest args))
 906   (labels ((collect-variables (list)
 907              (loop
 908                 for sub in list
 909                 append
 910                 (etypecase sub
 911                   (list
 912                    (collect-variables sub))
 913                   (symbol
 914                    (if (eql (mismatch "&" (symbol-name sub)) 1)
 915                        nil
 916                        (list sub)))))))
 917     `(defmacro ,name (,@args)
 918        (declare (ignorable ,@(collect-variables args)))
 919        (error "XSL indentation helper ~A used literally in lisp code"
 920               ',name))))
 921
 922 (define-indentation xsl:element
 923     ((name &key namespace use-attribute-sets) &body body))
 924 (define-indentation xsl:literal-element ((name &optional uri) &body body))
 925 (define-indentation xsl:attribute ((name &key namespace) &body body))
 926 (define-indentation xsl:literal-attribute ((name &optional uri) &body body))
 927 (define-indentation xsl:text (str))
 928 (define-indentation xsl:processing-instruction (name &body body))
 929 (define-indentation xsl:comment (&body body))
 930 (define-indentation xsl:value-of (xpath))
 931 (define-indentation xsl:unescaped-value-of (xpath))
 932 (define-indentation xsl:for-each (select &body decls-and-body))
 933 (define-indentation xsl:message (&body body))
 934 (define-indentation xsl:terminate (&body body))
 935 (define-indentation xsl:apply-templates ((&key select mode) &body decls-and-body))
 936 (define-indentation xsl:call-template (name &rest parameters))
 937 (define-indentation xsl:copy-of (xpath))
 938
 939 ;;;;
 940
 941 (defun test-instruction (form document)
 942   (let ((thunk (compile-instruction form (make-instance 'lexical-environment)))
 943         (root (cxml:parse document (stp:make-builder))))
 944     (with-xml-output (cxml:make-string-sink)
 945       (funcall thunk (xpath:make-context root)))))