From 68ec409e2d8998dddcf4c63e55b41870d749bcc1 Mon Sep 17 00:00:00 2001 From: David Lichteblau Date: Tue, 25 Mar 2008 13:47:20 +0100 Subject: [PATCH] xsl:sort parameters are AVTs --- TEST | 8 ++--- instructions.lisp | 94 +++++++++++++++++++++++++++++++++---------------------- 2 files changed, 60 insertions(+), 42 deletions(-) diff --git a/TEST b/TEST index 22a595e..de85f91 100644 --- a/TEST +++ b/TEST @@ -8649,19 +8649,19 @@ PASS sort_sort31 [XSLT-Result-Tree] Expected output (1): Xalan_Conformance_Tests/sort/sort_sort31.saxon Actual output: Xalan_Conformance_Tests/sort/sort_sort31.xuriella -FAIL sort_sort32 [XSLT-Result-Tree]: output doesn't match +PASS sort_sort32 [XSLT-Result-Tree] Stylesheet: Xalan_Conformance_Tests/sort/sort32.noindent-xsl Data: Xalan_Conformance_Tests/sort/sort32.xml Expected output (1): Xalan_Conformance_Tests/sort/sort_sort32.saxon Actual output: Xalan_Conformance_Tests/sort/sort_sort32.xuriella -FAIL sort_sort33 [XSLT-Result-Tree]: output doesn't match +PASS sort_sort33 [XSLT-Result-Tree] Stylesheet: Xalan_Conformance_Tests/sort/sort33.noindent-xsl Data: Xalan_Conformance_Tests/sort/sort33.xml Expected output (1): Xalan_Conformance_Tests/sort/sort_sort33.saxon Actual output: Xalan_Conformance_Tests/sort/sort_sort33.xuriella -FAIL sort_sort34 [XSLT-Result-Tree]: output doesn't match +PASS sort_sort34 [XSLT-Result-Tree] Stylesheet: Xalan_Conformance_Tests/sort/sort34.noindent-xsl Data: Xalan_Conformance_Tests/sort/sort34.xml Expected output (1): Xalan_Conformance_Tests/sort/sort_sort34.saxon @@ -22607,4 +22607,4 @@ PASS XSLTFunctions_DocumentFuncWithEmptyArg [Mixed] Expected output (1): MSFT_Conformance_Tests/XSLTFunctions/XSLTFunctions_DocumentFuncWithEmptyArg.saxon Actual output: MSFT_Conformance_Tests/XSLTFunctions/XSLTFunctions_DocumentFuncWithEmptyArg.xuriella -Passed 2718/3076 tests. +Passed 2721/3076 tests. diff --git a/instructions.lisp b/instructions.lisp index 0c9a3b2..3af1a31 100644 --- a/instructions.lisp +++ b/instructions.lisp @@ -383,42 +383,59 @@ (t 1))) (signum (- (length i) (length j)))))) -(defun make-sorter (spec env) +(defun make-sorter/lazy (spec env) (destructuring-bind (&key select lang data-type order case-order) (cdr spec) - (declare (ignore lang)) (let ((select-thunk (compile-xpath (or select ".") env)) - (numberp (equal data-type "number")) - (f (if (equal order "descending") -1 1)) - (char-table (if (equal case-order "lower-first") - *lower-first-order* - *upper-first-order*))) - (lambda (a b) - (let ((i (xpath:string-value (funcall select-thunk a))) - (j (xpath:string-value (funcall select-thunk b)))) - (* f - (if numberp - (compare-numbers (xpath:number-value i) - (xpath:number-value j)) - (compare-strings i j char-table)))))))) - -(defun compose-sorters (sorters) + (lang-thunk (compile-avt (or lang "") env)) + (data-type-thunk (compile-avt (or data-type "") env)) + (order-thunk (compile-avt (or order "") env)) + (case-order-thunk (compile-avt (or case-order "") env))) + (lambda (ctx) + (let ((numberp + (equal (funcall data-type-thunk ctx) "number")) + (char-table + (if (equal (funcall case-order-thunk ctx) "lower-first") + *lower-first-order* + *upper-first-order*)) + (f + (if (equal (funcall order-thunk ctx) "descending") -1 1)) + (lang + (funcall lang-thunk ctx))) + (declare (ignore lang)) + (lambda (a b) + (let ((i (xpath:string-value (funcall select-thunk a))) + (j (xpath:string-value (funcall select-thunk b)))) + (* f + (if numberp + (compare-numbers (xpath:number-value i) + (xpath:number-value j)) + (compare-strings i j char-table)))))))))) + +(defun compose-sorters/lazy (sorters) (if sorters - (let ((this (car sorters)) - (next (compose-sorters (rest sorters)))) + (let ((this-thunk (car sorters)) + (next-thunk (compose-sorters/lazy (rest sorters)))) + (lambda (ctx) + (let ((this (funcall this-thunk ctx)) + (next (funcall next-thunk ctx))) + (lambda (a b) + (let ((d (funcall this a b))) + (if (zerop d) + (funcall next a b) + d)))))) + (lambda (ctx) + (declare (ignore ctx)) + (constantly 0)))) + +(defun make-sort-predicate/lazy (decls env) + (let ((sorter-thunk + (compose-sorters/lazy + (mapcar (lambda (x) (make-sorter/lazy x env)) decls)))) + (lambda (ctx) + (let ((sorter (funcall sorter-thunk ctx))) (lambda (a b) - (let ((d (funcall this a b))) - (if (zerop d) - (funcall next a b) - d)))) - (constantly 0))) - -(defun make-sort-predicate (decls env) - (let ((sorter - (compose-sorters - (mapcar (lambda (x) (make-sorter x env)) decls)))) - (lambda (a b) - (minusp (funcall sorter a b))))) + (minusp (funcall sorter a b))))))) (defun contextify-node-list (nodes) (let ((size (length nodes))) @@ -436,19 +453,19 @@ (setf decls nil)) (let ((select-thunk (compile-xpath select env)) (body-thunk (compile-instruction `(progn ,@body) env)) - (sort-predicate + (sort-predicate-thunk (when (cdr decls) - (make-sort-predicate (cdr decls) env)))) + (make-sort-predicate/lazy (cdr decls) env)))) (lambda (ctx) (let ((selected (funcall select-thunk ctx))) (unless (xpath:node-set-p selected) (xslt-error "for-each select expression should yield a node-set")) (let ((nodes (xpath::force (xpath::sorted-pipe-of selected)))) - (when sort-predicate + (when sort-predicate-thunk (setf nodes (mapcar #'xpath:context-node (stable-sort (contextify-node-list nodes) - sort-predicate)))) + (funcall sort-predicate-thunk ctx))))) (dolist (ctx (contextify-node-list nodes)) (funcall body-thunk ctx)))))))) @@ -617,9 +634,9 @@ (compile-xpath (or select "child::node()") env)) (param-bindings (compile-var-bindings param-binding-specs env)) - (sort-predicate + (sort-predicate-thunk (when decls - (make-sort-predicate decls env)))) + (make-sort-predicate/lazy decls env)))) (multiple-value-bind (mode-local-name mode-uri) (and mode (decode-qname mode env nil)) (lambda (ctx) @@ -629,7 +646,8 @@ :param-bindings (loop for (name nil value-thunk) in param-bindings collect (list name (funcall value-thunk ctx))) - :sort-predicate sort-predicate + :sort-predicate (when sort-predicate-thunk + (funcall sort-predicate-thunk ctx)) :mode (when mode (or (find-mode *stylesheet* mode-local-name -- 2.11.4.GIT