instructions.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
   2
   3 ;;; Copyright (c) 2007,2008 David Lichteblau, Ivan Shvedunov.
   4 ;;; All rights reserved.
   5
   6 ;;; Redistribution and use in source and binary forms, with or without
   7 ;;; modification, are permitted provided that the following conditions
   8 ;;; are met:
   9 ;;;
  10 ;;;   * Redistributions of source code must retain the above copyright
  11 ;;;     notice, this list of conditions and the following disclaimer.
  12 ;;;
  13 ;;;   * Redistributions in binary form must reproduce the above
  14 ;;;     copyright notice, this list of conditions and the following
  15 ;;;     disclaimer in the documentation and/or other materials
  16 ;;;     provided with the distribution.
  17 ;;;
  18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  21 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  29
  30 (in-package :xuriella)
  31
  32 #+sbcl
  33 (declaim (optimize (debug 2)))
  34
  35
  36 ;;;; Instructions
  37
  38 (defparameter *available-instructions* (make-hash-table :test 'equal))
  39
  40 (defmacro define-instruction (name (args-var env-var) &body body)
  41   `(setf (get ',name 'xslt-instruction)
  42          (lambda (,args-var ,env-var)
  43            (declare (ignorable ,env-var))
  44            ,@body)))
  45
  46 (define-instruction if (args env)
  47   (destructuring-bind (test then &optional else) args
  48     (let ((test-thunk (compile-xpath test env))
  49           (then-thunk (compile-instruction then env))
  50           (else-thunk (when else (compile-instruction else env))))
  51       (lambda (ctx)
  52         (cond
  53           ((xpath:boolean-value (funcall test-thunk ctx))
  54            (funcall then-thunk ctx))
  55           (else-thunk
  56            (funcall else-thunk ctx)))))))
  57
  58 (define-instruction when (args env)
  59   (destructuring-bind (test &rest body) args
  60     (compile-instruction `(if ,test (progn ,@body)) env)))
  61
  62 (define-instruction unless (args env)
  63   (destructuring-bind (test &rest body) args
  64     (compile-instruction `(if (:not ,test) (progn ,@body)) env)))
  65
  66 (define-instruction cond (args env)
  67   (if args
  68       (destructuring-bind ((test &body body) &rest clauses) args
  69         (compile-instruction (if (eq test t)
  70                                  `(progn ,@body)
  71                                  `(if ,test
  72                                       (progn ,@body)
  73                                       (cond ,@clauses)))
  74                              env))
  75       (constantly nil)))
  76
  77 (define-instruction progn (args env)
  78   (if args
  79       (let ((first-thunk (compile-instruction (first args) env))
  80             (rest-thunk (compile-instruction `(progn ,@(rest args)) env)))
  81         (lambda (ctx)
  82           (funcall first-thunk ctx)
  83           (funcall rest-thunk ctx)))
  84       (constantly nil)))
  85
  86 (defun decode-qname/runtime (qname namespaces attributep)
  87   (handler-case
  88       (multiple-value-bind (prefix local-name)
  89           (split-qname qname)
  90         (values local-name
  91                 (if (or prefix (not attributep))
  92                     (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 (equal 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 (equal 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 (equal str "") (equal str "ascending"))
 439      1)
 440     (t
 441      (xslt-error "invalid order in sort"))))
 442
 443 (defun make-sorter/lazy (spec env)
 444   (destructuring-bind (&key select lang data-type order case-order)
 445       (cdr spec)
 446     (let ((select-thunk (compile-xpath (or select ".") env))
 447           (lang-thunk (compile-avt (or lang "")  env))
 448           (data-type-thunk (compile-avt (or data-type "") env))
 449           (order-thunk (compile-avt (or order "") env))
 450           (case-order-thunk (compile-avt (or case-order "") env)))
 451       (lambda (ctx)
 452         (let ((numberp (sort/@data-type (funcall data-type-thunk ctx)))
 453               (char-table (sort/@case-order (funcall case-order-thunk ctx)))
 454               (f (sort/@order (funcall order-thunk ctx)))
 455               (lang (funcall lang-thunk ctx)))
 456           (declare (ignore lang))
 457           (lambda (a b)
 458             (let ((i (xpath:string-value (funcall select-thunk a)))
 459                   (j (xpath:string-value (funcall select-thunk b))))
 460               (* f
 461                  (if numberp
 462                      (compare-numbers (xpath:number-value i)
 463                                       (xpath:number-value j))
 464                      (compare-strings i j char-table))))))))))
 465
 466 (defun compose-sorters/lazy (sorters)
 467   (if sorters
 468       (let ((this-thunk (car sorters))
 469             (next-thunk (compose-sorters/lazy (rest sorters))))
 470         (lambda (ctx)
 471           (let ((this (funcall this-thunk ctx))
 472                 (next (funcall next-thunk ctx)))
 473             (lambda (a b)
 474               (let ((d (funcall this a b)))
 475                 (if (zerop d)
 476                     (funcall next a b)
 477                     d))))))
 478       (lambda (ctx)
 479         (declare (ignore ctx))
 480         (constantly 0))))
 481
 482 (defun make-sort-predicate/lazy (decls env)
 483   (let ((sorter-thunk
 484          (compose-sorters/lazy
 485           (mapcar (lambda (x) (make-sorter/lazy x env)) decls))))
 486     (lambda (ctx)
 487       (let ((sorter (funcall sorter-thunk ctx)))
 488         (lambda (a b)
 489           (minusp (funcall sorter a b)))))))
 490
 491 (defun contextify-node-list (nodes)
 492   (let ((size (length nodes)))
 493     (loop
 494        for position from 1
 495        for node in nodes
 496        collect
 497          (xpath:make-context node size position))))
 498
 499 (define-instruction xsl:for-each (args env)
 500   (destructuring-bind (select &optional decls &rest body) args
 501     (unless (and (consp decls)
 502                  (eq (car decls) 'declare))
 503       (push decls body)
 504       (setf decls nil))
 505     (let ((select-thunk (compile-xpath select env))
 506           (body-thunk (compile-instruction `(progn ,@body) env))
 507           (sort-predicate-thunk
 508            (when (cdr decls)
 509              (make-sort-predicate/lazy (cdr decls) env))))
 510       (lambda (ctx)
 511         (let ((selected (funcall select-thunk ctx))
 512               (*apply-imports*
 513                (lambda (&optional ignore)
 514                  (declare (ignore ignore))
 515                  (xslt-error "apply-imports used in for-each"))))
 516           (unless (xpath:node-set-p selected)
 517             (xslt-error "for-each select expression should yield a node-set"))
 518           (let ((nodes (xpath::force (xpath::sorted-pipe-of selected))))
 519             (when sort-predicate-thunk
 520               (setf nodes
 521                     (mapcar #'xpath:context-node
 522                             (stable-sort (contextify-node-list nodes)
 523                                          (funcall sort-predicate-thunk ctx)))))
 524             (dolist (ctx (contextify-node-list nodes))
 525               (funcall body-thunk ctx))))))))
 526
 527 (define-instruction xsl:with-namespaces (args env)
 528   (destructuring-bind ((&rest forms) &rest body) args
 529     (let ((*namespaces* *namespaces*))
 530       (dolist (form forms)
 531         (destructuring-bind (prefix uri) form
 532           (push (cons prefix uri) *namespaces*)))
 533       (compile-instruction `(progn ,@body) env))))
 534
 535 (define-instruction xsl:with-excluded-namespaces (args env)
 536   (destructuring-bind ((&rest uris) &rest body) args
 537     (let ((*excluded-namespaces* (append uris *excluded-namespaces*)))
 538       (compile-instruction `(progn ,@body) env))))
 539
 540 (define-instruction xsl:with-extension-namespaces (args env)
 541   (destructuring-bind ((&rest uris) &rest body) args
 542     (let ((*extension-namespaces* (append uris *extension-namespaces*)))
 543       (compile-instruction `(progn ,@body) env))))
 544
 545 (define-instruction xsl:with-version (args env)
 546   (destructuring-bind (version &rest body) args
 547     (let ((*forwards-compatible-p* (not (equal version "1.0"))))
 548       (compile-instruction `(progn ,@body) env))))
 549
 550 ;; XSLT disallows multiple definitions of the same variable within a
 551 ;; template.  Local variables can shadow global variables though.
 552 ;; Since our LET syntax makes it natural to shadow local variables the
 553 ;; Lisp way, we check for duplicate variables only where instructed to
 554 ;; by the XML syntax parser using WITH-DUPLICATES-CHECK:
 555 (defvar *template-variables* nil)
 556
 557 (define-instruction xsl:with-duplicates-check (args env)
 558   (let ((*template-variables* *template-variables*))
 559     (destructuring-bind ((&rest qnames) &rest body) args
 560       (dolist (qname qnames)
 561         (multiple-value-bind (local-name uri)
 562             (decode-qname qname env nil)
 563           (let ((key (cons local-name uri)))
 564             (when (find key *template-variables* :test #'equal)
 565               (xslt-error "duplicate variable: ~A, ~A" local-name uri))
 566             (push key *template-variables*))))
 567       (compile-instruction `(progn ,@body) env))))
 568
 569 (define-instruction xsl:with-base-uri (args env)
 570   (destructuring-bind (uri &rest body) args
 571     (let ((*instruction-base-uri* uri))
 572       (compile-instruction `(progn ,@body) env))))
 573
 574 (defstruct (result-tree-fragment
 575              (:constructor make-result-tree-fragment (node)))
 576   node)
 577
 578 (define-default-method xpath-protocol:node-p
 579     ((node result-tree-fragment))
 580   t)
 581
 582 (define-default-method xpath-protocol:node-text
 583     ((node result-tree-fragment))
 584   (xpath-protocol:node-text (result-tree-fragment-node node)))
 585
 586 (defun apply-to-result-tree-fragment (ctx thunk)
 587   (let ((document
 588          (with-xml-output (make-stpx-builder)
 589            (with-element ("fragment" "")
 590              (funcall thunk ctx)))))
 591     (make-result-tree-fragment (stp:document-element document))))
 592
 593 (defun compile-var-bindings/nointern (forms env)
 594   (loop
 595     for (name value) in forms
 596     collect (multiple-value-bind (local-name uri)
 597                 (decode-qname name env nil)
 598               (list (cons local-name uri)
 599                     (xslt-trace-thunk
 600                      (compile-value-thunk value env)
 601                      "local variable ~s = ~s" name :result)))))
 602
 603 (define-instruction let (args env)
 604   (destructuring-bind ((&rest forms) &rest body) args
 605     (let* ((old-top (length *lexical-variable-declarations*))
 606            (vars-and-names (compile-var-bindings/nointern forms env))
 607            (vars-and-positions
 608             (loop for ((local-name . uri) thunk) in vars-and-names
 609                collect
 610                  (list (push-variable local-name
 611                                       uri
 612                                       *lexical-variable-declarations*)
 613                        thunk))))
 614       (let ((thunk (compile-instruction `(progn ,@body) env)))
 615         (fill *lexical-variable-declarations* nil :start old-top)
 616         (lambda (ctx)
 617           (loop for (index var-thunk) in vars-and-positions
 618              do (setf (lexical-variable-value index)
 619                       (funcall var-thunk ctx)))
 620           (funcall thunk ctx))))))
 621
 622 (define-instruction let* (args env)
 623   (destructuring-bind ((&rest forms) &rest body) args
 624     (if forms
 625         (compile-instruction `(let (,(car forms))
 626                                 (let* (,@(cdr forms))
 627                                   ,@body))
 628                              env)
 629         (compile-instruction `(progn ,@body) env))))
 630
 631 (define-instruction xsl:message (args env)
 632   (compile-message #'warn args env))
 633
 634 (define-instruction xsl:terminate (args env)
 635   (compile-message #'xslt-error args env))
 636
 637 (defun namespaces-as-alist (element)
 638   (let ((namespaces '()))
 639     (do-pipe (ns (xpath-protocol:namespace-pipe element))
 640       (push (cons (xpath-protocol:local-name ns)
 641                   (xpath-protocol:node-text ns))
 642             namespaces))
 643     namespaces))
 644
 645 (define-instruction xsl:copy (args env)
 646   (let ((body (compile-instruction `(progn ,@args) env)))
 647     (lambda (ctx)
 648       (let ((node (xpath:context-node ctx)))
 649         (cond
 650           ((xpath-protocol:node-type-p node :element)
 651            (with-element
 652                ((xpath-protocol:local-name node)
 653                 (xpath-protocol:namespace-uri node)
 654                 :suggested-prefix (xpath-protocol:namespace-prefix node)
 655                 :extra-namespaces (namespaces-as-alist node))
 656              (funcall body ctx)))
 657           ((xpath-protocol:node-type-p node :document)
 658            (funcall body ctx))
 659           (t
 660            (copy-leaf-node node)))))))
 661
 662 (defun copy-leaf-node (node)
 663   (cond
 664     ((xpath-protocol:node-type-p node :text)
 665      (etypecase (if (typep node 'stripping-node)
 666                     (stripping-node-target node)
 667                     node)
 668        (unescaped-text (write-unescaped (xpath-protocol:node-text node)))
 669        (stp:text (write-text (xpath-protocol:node-text node)))))
 670     ((xpath-protocol:node-type-p node :comment)
 671      (write-comment (xpath-protocol:node-text node)))
 672     ((xpath-protocol:node-type-p node :processing-instruction)
 673      (write-processing-instruction
 674          (xpath-protocol:processing-instruction-target node)
 675        (xpath-protocol:node-text node)))
 676     ((xpath-protocol:node-type-p node :attribute)
 677      (write-attribute
 678       (xpath-protocol:local-name node)
 679       (xpath-protocol:namespace-uri node)
 680       (xpath-protocol:node-text node)
 681       :suggested-prefix (xpath-protocol:namespace-prefix node)))
 682     ((xpath-protocol:node-type-p node :namespace)
 683      (write-extra-namespace
 684       (xpath-protocol:local-name node)
 685       (xpath-protocol:node-text node)
 686       nil))
 687     (t
 688      (error "don't know how to copy node ~A" node))))
 689
 690 (defun compile-message (fn args env)
 691   (let ((thunk (compile-instruction `(progn ,@args) env)))
 692     (lambda (ctx)
 693       (funcall fn
 694                (with-xml-output (cxml:make-string-sink)
 695                  (funcall thunk ctx))))))
 696
 697 (define-instruction xsl:apply-templates (args env)
 698   (destructuring-bind ((&key select mode) &rest param-binding-specs) args
 699     (let* ((decls
 700             (when (and (consp (car param-binding-specs))
 701                        (eq (caar param-binding-specs) 'declare))
 702               (cdr (pop param-binding-specs))))
 703            (select-thunk
 704             (compile-xpath (or select "child::node()") env))
 705            (param-bindings
 706             (compile-var-bindings param-binding-specs env))
 707            (sort-predicate-thunk
 708             (when decls
 709               (make-sort-predicate/lazy decls env))))
 710       (multiple-value-bind (mode-local-name mode-uri)
 711           (and mode (decode-qname mode env nil))
 712         (lambda (ctx)
 713           (apply-templates/list
 714            (xpath::force
 715             (xpath::sorted-pipe-of (funcall select-thunk ctx)))
 716            :param-bindings
 717            (loop for (name nil value-thunk) in param-bindings
 718               collect (list name (funcall value-thunk ctx)))
 719            :sort-predicate (when sort-predicate-thunk
 720                              (funcall sort-predicate-thunk ctx))
 721            :mode (when mode
 722                    (or (find-mode *stylesheet*
 723                                   mode-local-name
 724                                   mode-uri)
 725                        *empty-mode*))))))))
 726
 727 (define-instruction xsl:apply-imports (args env)
 728   (declare (ignore args env))
 729   (lambda (ctx)
 730     (declare (ignore ctx))
 731     (funcall *apply-imports*)))
 732
 733 (define-instruction xsl:call-template (args env)
 734   (destructuring-bind (name &rest param-binding-specs) args
 735     (let ((param-bindings
 736            (compile-var-bindings param-binding-specs env)))
 737       (multiple-value-bind (local-name uri)
 738           (decode-qname name env nil)
 739         (setf name (cons local-name uri)))
 740       (lambda (ctx)
 741         (call-template ctx name
 742                        (loop for (name nil value-thunk) in param-bindings
 743                           collect (list name (funcall value-thunk ctx))))))))
 744
 745 ;; fixme: incompatible with XSLT 2.0
 746 (define-instruction xsl:document (args env)
 747   (destructuring-bind ((href &key method indent doctype-public doctype-system)
 748                        &body body)
 749       args
 750     (declare (ignore doctype-public doctype-system)) ;fixme
 751     (let ((thunk (compile-instruction `(progn ,@body) env))
 752           (href-thunk (compile-avt href env)))
 753       (lambda (ctx)
 754         (let ((pathname
 755                (uri-to-pathname
 756                 (puri:merge-uris (funcall href-thunk ctx)
 757                                  (xpath-protocol:base-uri
 758                                   (xpath:context-node ctx))))))
 759           (ensure-directories-exist pathname) ;really?
 760           (invoke-with-output-sink
 761            (lambda ()
 762              (funcall thunk ctx))
 763            (make-output-specification :method (or method "XML") :indent indent)
 764            pathname))))))
 765
 766 (defun compile-instruction (form env)
 767   (xslt-trace-thunk
 768    (funcall (or (get (car form) 'xslt-instruction)
 769                 (error "undefined instruction: ~A" (car form)))
 770             (cdr form)
 771             env)
 772    "instruction ~s" (car form)))
 773
 774 ;;: WTF: "A right curly brace inside a Literal in an expression is not
 775 ;;; recognized as terminating the expression."
 776 ;;;
 777 ;;; Da hilft nur tagbody.
 778 (defun parse-attribute-value-template (template-string)
 779   (with-input-from-string (input template-string)
 780     (let ((ordinary (make-string-output-stream))
 781           (xpath (make-string-output-stream))
 782           (tokens '())
 783           (c (read-char input nil :eof)))
 784       (flet ((emit ()
 785                (let ((o (get-output-stream-string ordinary)))
 786                  (when (plusp (length o))
 787                    (push (list :data o) tokens)))
 788                (let ((x (get-output-stream-string xpath)))
 789                  (when (plusp (length x))
 790                    (push (list :xpath x) tokens))))
 791              (collect-ordinary ()
 792                (write-char c ordinary))
 793              (collect-xpath ()
 794                (write-char c xpath)))
 795         (macrolet ((goto (target)
 796                      `(progn
 797                         (setf c (read-char input nil :eof))
 798                         (go ,target))))
 799           (tagbody
 800            ordinary
 801              (case c
 802                (#\{
 803                 (goto seen{))
 804                (#\}
 805                 (goto seen-stray-}))
 806                (:eof
 807                 (go done)))
 808              (collect-ordinary)
 809              (goto ordinary)
 810
 811            seen{
 812              (case c
 813                (#\{
 814                 (collect-ordinary)
 815                 (goto ordinary))
 816                (#\'
 817                 (collect-xpath)
 818                 (goto in-single-quote))
 819                (:eof
 820                 (xslt-error "unexpected end of avt")))
 821              (emit)
 822              (collect-xpath)
 823              (goto xpath)
 824
 825            xpath
 826              (case c
 827                (#\'
 828                 (collect-xpath)
 829                 (goto in-single-quote))
 830                (#\"
 831                 (collect-xpath)
 832                 (goto in-double-quote))
 833                (#\}
 834                 (goto seen-closing-}))
 835                (:eof
 836                 (xslt-error "unexpected end of avt")))
 837              (collect-xpath)
 838              (goto xpath)
 839
 840            in-single-quote
 841              (case c
 842                (#\'
 843                 (collect-xpath)
 844                 (goto xpath))
 845                (:eof
 846                 (xslt-error "unexpected end of avt")))
 847              (collect-xpath)
 848              (goto in-single-quote)
 849
 850            in-double-quote
 851              (case c
 852                (#\"
 853                 (collect-xpath)
 854                 (goto xpath))
 855                (:eof
 856                 (xslt-error "unexpected end of avt")))
 857              (collect-xpath)
 858              (goto in-double-quote)
 859
 860            seen-closing-}
 861              (case c
 862                (#\}
 863                 (emit)
 864                 (goto seen-stray-}))
 865                (#\{
 866                 (emit)
 867                 (goto xpath))
 868                (:eof
 869                 (goto done)))
 870              (emit)
 871              (collect-ordinary)
 872              (goto ordinary)
 873
 874            seen-stray-}
 875              (case c
 876                (#\}
 877                 (collect-ordinary)
 878                 (goto ordinary)))
 879              (xslt-error "unexpected closing brace in avt")
 880
 881            done
 882              (emit))))
 883       (nreverse tokens))))
 884
 885 (defun compile-avt (template-string env)
 886   (let* ((constantp t)
 887          (fns
 888           (mapcar (lambda (x)
 889                     (ecase (car x)
 890                       (:data
 891                        (constantly (second x)))
 892                       (:xpath
 893                        (setf constantp nil)
 894                        (compile-xpath (second x) env))))
 895                   (if template-string
 896                       (parse-attribute-value-template template-string)
 897                       (xslt-error "missing avt")))))
 898     (values (lambda (ctx)
 899               (with-output-to-string (s)
 900                 (dolist (fn fns)
 901                   (write-string (xpath:string-value (funcall fn ctx)) s))))
 902             constantp)))
 903
 904
 905 ;;;; Indentation for slime
 906
 907 (defmacro define-indentation (name (&rest args))
 908   (labels ((collect-variables (list)
 909              (loop
 910                 for sub in list
 911                 append
 912                 (etypecase sub
 913                   (list
 914                    (collect-variables sub))
 915                   (symbol
 916                    (if (eql (mismatch "&" (symbol-name sub)) 1)
 917                        nil
 918                        (list sub)))))))
 919     `(defmacro ,name (,@args)
 920        (declare (ignorable ,@(collect-variables args)))
 921        (error "XSL indentation helper ~A used literally in lisp code"
 922               ',name))))
 923
 924 (define-indentation xsl:element
 925     ((name &key namespace use-attribute-sets) &body body))
 926 (define-indentation xsl:literal-element ((name &optional uri) &body body))
 927 (define-indentation xsl:attribute ((name &key namespace) &body body))
 928 (define-indentation xsl:literal-attribute ((name &optional uri) &body body))
 929 (define-indentation xsl:text (str))
 930 (define-indentation xsl:processing-instruction (name &body body))
 931 (define-indentation xsl:comment (&body body))
 932 (define-indentation xsl:value-of (xpath))
 933 (define-indentation xsl:unescaped-value-of (xpath))
 934 (define-indentation xsl:for-each (select &body decls-and-body))
 935 (define-indentation xsl:message (&body body))
 936 (define-indentation xsl:terminate (&body body))
 937 (define-indentation xsl:apply-templates ((&key select mode) &body decls-and-body))
 938 (define-indentation xsl:call-template (name &rest parameters))
 939 (define-indentation xsl:copy-of (xpath))
 940
 941 ;;;;
 942
 943 (defun test-instruction (form document)
 944   (let ((thunk (compile-instruction form (make-instance 'lexical-environment)))
 945         (root (cxml:parse document (stp:make-builder))))
 946     (with-xml-output (cxml:make-string-sink)
 947       (funcall thunk (xpath:make-context root)))))