From 3daf5345c300789d44de2635a6b56e44f0736613 Mon Sep 17 00:00:00 2001 From: David Lichteblau Date: Tue, 25 Mar 2008 13:26:00 +0100 Subject: [PATCH] Fixed position and last in sorting --- TEST | 4 +-- instructions.lisp | 82 ++++++++++++++++++++++++++++++------------------------- test.lisp | 12 ++------ xslt.lisp | 5 +++- 4 files changed, 54 insertions(+), 49 deletions(-) diff --git a/TEST b/TEST index 8b7f50f..22a595e 100644 --- a/TEST +++ b/TEST @@ -8583,7 +8583,7 @@ PASS sort_sort20 [XSLT-Result-Tree] Expected output (1): Xalan_Conformance_Tests/sort/sort_sort20.saxon Actual output: Xalan_Conformance_Tests/sort/sort_sort20.xuriella -FAIL sort_sort21 [XSLT-Result-Tree]: output doesn't match +PASS sort_sort21 [XSLT-Result-Tree] Stylesheet: Xalan_Conformance_Tests/sort/sort21.noindent-xsl Data: Xalan_Conformance_Tests/sort/sort21.xml Expected output (1): Xalan_Conformance_Tests/sort/sort_sort21.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 2717/3076 tests. +Passed 2718/3076 tests. diff --git a/instructions.lisp b/instructions.lisp index b99e3d3..0c9a3b2 100644 --- a/instructions.lisp +++ b/instructions.lisp @@ -352,12 +352,37 @@ (defun make-collation-key (str table) (map 'string (lambda (char) (collation-char char table)) str)) +(defun compare-numbers (n-a n-b) + (cond ((and (xpath::nan-p n-a) + (not (xpath::nan-p n-b))) + -1) + ((and (not (xpath::nan-p n-a)) + (xpath::nan-p n-b)) + 1) + ((xpath::compare-numbers '< n-a n-b) -1) + ((xpath::compare-numbers '> n-a n-b) 1) + (t 0))) + (defun mismatch* (a b) (let ((pos (mismatch a b))) (if (and pos (< pos (min (length a) (length b)))) pos nil))) +(defun compare-strings (i j char-table) + ;; zzz Unicode support! + (let ((pos + (or (mismatch* (string-downcase i) (string-downcase j)) + (mismatch* i j)))) + (if pos + (let ((c (collation-char (elt i pos) char-table)) + (d (collation-char (elt j pos) char-table))) + (cond + ((char< c d) -1) + ((char= c d) 0) + (t 1))) + (signum (- (length i) (length j)))))) + (defun make-sorter (spec env) (destructuring-bind (&key select lang data-type order case-order) (cdr spec) @@ -369,35 +394,13 @@ *lower-first-order* *upper-first-order*))) (lambda (a b) - (let ((i (xpath:string-value - (funcall select-thunk (xpath:make-context a)))) - (j (xpath:string-value - (funcall select-thunk (xpath:make-context b))))) + (let ((i (xpath:string-value (funcall select-thunk a))) + (j (xpath:string-value (funcall select-thunk b)))) (* f (if numberp - (let ((n-a (xpath:number-value i)) - (n-b (xpath:number-value j))) - (cond ((and (xpath::nan-p n-a) - (not (xpath::nan-p n-b))) - -1) - ((and (not (xpath::nan-p n-a)) - (xpath::nan-p n-b)) - 1) - ((xpath::compare-numbers '< n-a n-b) -1) - ((xpath::compare-numbers '> n-a n-b) 1) - (t 0))) - ;; zzz Unicode support! - (let ((pos - (or (mismatch* (string-downcase i) (string-downcase j)) - (mismatch* i j)))) - (if pos - (let ((c (collation-char (elt i pos) char-table)) - (d (collation-char (elt j pos) char-table))) - (cond - ((char< c d) -1) - ((char= c d) 0) - (t 1))) - (signum (- (length i) (length j)))))))))))) + (compare-numbers (xpath:number-value i) + (xpath:number-value j)) + (compare-strings i j char-table)))))))) (defun compose-sorters (sorters) (if sorters @@ -417,6 +420,14 @@ (lambda (a b) (minusp (funcall sorter a b))))) +(defun contextify-node-list (nodes) + (let ((size (length nodes))) + (loop + for position from 1 + for node in nodes + collect + (xpath:make-context node size position)))) + (define-instruction xsl:for-each (args env) (destructuring-bind (select &optional decls &rest body) args (unless (and (consp decls) @@ -432,17 +443,14 @@ (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)))) + (let ((nodes (xpath::force (xpath::sorted-pipe-of selected)))) (when sort-predicate - (setf nodes (stable-sort (copy-list nodes) sort-predicate))) - (loop - with n = (length nodes) - for node in nodes - for i from 1 - do - (funcall body-thunk - (xpath:make-context node (lambda () n) i))))))))) + (setf nodes + (mapcar #'xpath:context-node + (stable-sort (contextify-node-list nodes) + sort-predicate)))) + (dolist (ctx (contextify-node-list nodes)) + (funcall body-thunk ctx)))))))) (define-instruction xsl:with-namespaces (args env) (destructuring-bind ((&rest forms) &rest body) args diff --git a/test.lisp b/test.lisp index 8f1d64a..df40229 100644 --- a/test.lisp +++ b/test.lisp @@ -349,14 +349,8 @@ :test #'equal)))))))) (defun run-named-test (name &optional (d *tests-directory*)) - (klacks:with-open-source - (source (klacks:make-tapping-source - (cxml:make-source (merge-pathnames "katalog.xml" d)))) - (let ((*default-pathname-defaults* (merge-pathnames d)) - (*break-on-signals* 'error)) - (map-tests #'run-test - source - :test (lambda (test) (equal (test-id test) name)))))) + (let ((*break-on-signals* 'error)) + (run-tests :filter (format nil "/~A$" name) :directory d))) (defun copy-file (p q) (with-open-file (in p :element-type '(unsigned-byte 8)) @@ -842,7 +836,7 @@ (report nil ": saxon error not signalled and official output not a match"))))))))))) (defun run-xpath-tests () - (run-tests '("XPath-Expression" "XSLT-Data-Model"))) + (run-tests "XPath-Expression/|XSLT-Data-Model/")) ;;;; from cxml-stp-test diff --git a/xslt.lisp b/xslt.lisp index c815e65..a43607e 100644 --- a/xslt.lisp +++ b/xslt.lisp @@ -1170,7 +1170,10 @@ (defun apply-templates/list (list &key param-bindings sort-predicate mode) (when sort-predicate - (setf list (sort list sort-predicate))) + (setf list + (mapcar #'xpath:context-node + (stable-sort (contextify-node-list list) + sort-predicate)))) (let* ((n (length list)) (s/d (lambda () n))) (loop -- 2.11.4.GIT