From 854f6b9a6946f3f908445ad78fec3e9c1c30d32c Mon Sep 17 00:00:00 2001 From: David Lichteblau Date: Sat, 5 Apr 2008 16:13:56 +0200 Subject: [PATCH] Fixed variable import --- TEST | 4 +- test.lisp | 71 ++++++++++++++++++++---------- xslt.lisp | 147 +++++++++++++++++++++++++++++++++++++------------------------- 3 files changed, 137 insertions(+), 85 deletions(-) diff --git a/TEST b/TEST index 6735251..b8c73ec 100644 --- a/TEST +++ b/TEST @@ -11161,7 +11161,7 @@ PASS BVTs_bvt043 [Mixed] Expected output (1): MSFT_Conformance_Tests/BVTs/BVTs_bvt043.saxon Actual output: MSFT_Conformance_Tests/BVTs/BVTs_bvt043.xuriella -FAIL BVTs_bvt044 [Mixed]: recursive variable definition +PASS BVTs_bvt044 [Mixed] Stylesheet: MSFT_Conformance_Tests/BVTs/import-var.noindent-xsl Data: MSFT_Conformance_Tests/BVTs/data.xml Supplemental stylesheet: MSFT_Conformance_Tests/BVTs/inc/include-var3.inc @@ -22469,4 +22469,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 2817/3073 tests. +Passed 2818/3073 tests. diff --git a/test.lisp b/test.lisp index dc5ce7c..06780e1 100644 --- a/test.lisp +++ b/test.lisp @@ -342,6 +342,19 @@ "numbering_numbering95" "Import__91164")) +;; Tests where the output isn't a match because of extraneous whitespace. +;; For these tests, we force space normalization before comparing. +;; +;; (SANITIZE-STYLESHEET is supposed to get rid of indent="yes", but it +;; misses imported stylesheets.) +;; +;; FIXME: Perhaps some *bad-tests* could instead be *whitespace-issues*, +;; at least those where the official output wuold be a match. +;; +(defparameter *whitespace-issues* + '("BVTs_bvt044" + "Namespace-alias__91782")) + (defun run-tests (&key filter (directory *tests-directory*)) (when (typep filter '(or string cons)) (setf filter (cl-ppcre:create-scanner filter))) @@ -612,28 +625,37 @@ ;; So let's normalize spaces in test output that looks like an XSLT ;; stylesheet, allowing us to pass these tests using the official test output. (defun maybe-normalize-test-spaces (wrapper force) - (stp:do-children (wrapper-child wrapper) - (when (and (typep wrapper-child 'stp:element) - (or (equal (stp:namespace-uri wrapper-child) *xsl*) - force)) - (strip-stylesheet wrapper-child) - (labels ((recurse (e &optional preserve) - (stp:do-children (child e) - (typecase child - (stp:text - (setf (stp:data child) - (normalize-whitespace (stp:data child)))) - (stp:element - (stp:with-attributes ((space "space" *xml*)) - child - (let ((new-preserve - (cond - ((namep child "text") t) - ((not space) preserve) - ((equal space "preserve") t) - (t nil)))) - (recurse child new-preserve)))))))) - (recurse wrapper-child))))) + (let ((i 0)) + (loop while (< i (length (cxml-stp-impl::%children wrapper))) do + (let ((wrapper-child (stp:nth-child i wrapper))) + (cond + ((not (typep wrapper-child 'stp:element)) + (if force + (stp:delete-nth-child i wrapper) + (incf i))) + ((or (equal (stp:namespace-uri wrapper-child) *xsl*) + force) + (strip-stylesheet wrapper-child) + (labels ((recurse (e &optional preserve) + (stp:do-children (child e) + (typecase child + (stp:text + (setf (stp:data child) + (normalize-whitespace (stp:data child)))) + (stp:element + (stp:with-attributes ((space "space" *xml*)) + child + (let ((new-preserve + (cond + ((namep child "text") t) + ((not space) preserve) + ((equal space "preserve") t) + (t nil)))) + (recurse child new-preserve)))))))) + (recurse wrapper-child)) + (incf i)) + (t + (incf i))))))) (defun xml-output-equal-p (p q normalize) (let ((r (parse-for-comparison p)) @@ -731,7 +753,7 @@ (actual (test-output-pathname test "xuriella")) (official (test-official-output-pathname test)) (force-normalization - (find (test-id test) '("Namespace-alias__91782") :test #'equal)) + (find (test-id test) *whitespace-issues* :test #'equal)) (output-method nil)) (handler-bind ((|hey test suite, this is an HTML document| (lambda (c) @@ -801,7 +823,8 @@ (saxon-matches-p (output-equal-p output-method expected-saxon - actual)) + actual + :normalize force-normalization)) #+xuriella::xsltproc (xsltproc-matches-p (output-equal-p output-method diff --git a/xslt.lisp b/xslt.lisp index e4d311b..4335868 100644 --- a/xslt.lisp +++ b/xslt.lisp @@ -340,7 +340,8 @@ (attribute-sets (make-hash-table :test 'equal)) (keys (make-hash-table :test 'equal)) (namespace-aliases (make-hash-table :test 'equal)) - (decimal-formats (make-hash-table :test 'equal))) + (decimal-formats (make-hash-table :test 'equal)) + (initial-global-variable-thunks (make-hash-table :test 'equal))) (defstruct mode (templates nil)) @@ -836,17 +837,23 @@ (funcall inner ctx))) "global ~s (~s) = ~s" name select :result)))) -(defstruct (variable-information - (:constructor make-variable) - (:conc-name "VARIABLE-")) +(defstruct (variable-chain + (:constructor make-variable-chain) + (:conc-name "VARIABLE-CHAIN-")) + definitions index - thunk local-name - uri - param-p - thunk-setter) + thunk + uri) + +(defstruct (import-variable + (:constructor make-variable) + (:conc-name "VARIABLE-")) + value-thunk + value-thunk-setter + param-p) -(defun parse-global-variable! ( global-env) ;; also for +(defun parse-global-variable! (stylesheet global-env) (let* ((*namespaces* (acons-namespaces )) (instruction-base-uri (stp:base-uri )) (*instruction-base-uri* instruction-base-uri) @@ -865,12 +872,24 @@ ;; that lazily resolves other variables, stored into ;; INITIAL-GLOBAL-VARIABLE-THUNKS: (let* ((value-thunk :unknown) + (sgv (stylesheet-global-variables stylesheet)) + (chain + (if (< index (length sgv)) + (elt sgv index) + (make-variable-chain + :index index + :local-name local-name + :uri uri))) + (next (car (variable-chain-definitions chain))) (global-variable-thunk (lambda (ctx) (let ((v (global-variable-value index nil))) - (when (eq v 'seen) - (xslt-error "recursive variable definition")) (cond + ((eq v 'seen) + (unless next + (xslt-error "no next definition for: ~A" + local-name)) + (funcall (variable-value-thunk next) ctx)) ((eq v 'unbound) (setf (global-variable-value index) 'seen) (setf (global-variable-value index) @@ -879,22 +898,25 @@ v))))) (excluded-namespaces *excluded-namespaces*) (extension-namespaces *extension-namespaces*) - (thunk-setter + (variable + (make-variable :param-p (namep "param"))) + (value-thunk-setter (lambda () - (let ((*instruction-base-uri* instruction-base-uri) - (*excluded-namespaces* excluded-namespaces) - (*extension-namespaces* extension-namespaces)) - (setf value-thunk - (compile-global-variable global-env)))))) + (let* ((*instruction-base-uri* instruction-base-uri) + (*excluded-namespaces* excluded-namespaces) + (*extension-namespaces* extension-namespaces) + (fn + (compile-global-variable global-env))) + (setf value-thunk fn) + (setf (variable-value-thunk variable) fn))))) + (setf (variable-value-thunk-setter variable) + value-thunk-setter) (setf (gethash (cons local-name uri) (initial-global-variable-thunks global-env)) global-variable-thunk) - (make-variable :index index - :local-name local-name - :uri uri - :thunk global-variable-thunk - :param-p (namep "param") - :thunk-setter thunk-setter))))))) + (setf (variable-chain-thunk chain) global-variable-thunk) + (push variable (variable-chain-definitions chain)) + chain)))))) (defun parse-keys! (stylesheet env) (xpath:with-namespaces ((nil #.*xsl*)) @@ -913,35 +935,39 @@ (defun prepare-global-variables (stylesheet ) (xpath:with-namespaces ((nil #.*xsl*)) - (let* ((table (make-hash-table :test 'equal)) + (let* ((igvt (stylesheet-initial-global-variable-thunks stylesheet)) (global-env (make-instance 'global-variable-environment - :initial-global-variable-thunks table)) - (specs '())) + :initial-global-variable-thunks igvt)) + (chains '())) (do-toplevel ( "variable|param" ) - (let ((var (parse-global-variable! global-env))) + (let ((chain + (parse-global-variable! stylesheet global-env))) (xslt-trace "parsing global variable ~s (uri ~s)" - (variable-local-name var) - (variable-uri var)) - (when (find var - specs + (variable-chain-local-name chain) + (variable-chain-uri chain)) + (when (find chain + chains :test (lambda (a b) - (and (equal (variable-local-name a) - (variable-local-name b)) - (equal (variable-uri a) - (variable-uri b))))) + (and (equal (variable-chain-local-name a) + (variable-chain-local-name b)) + (equal (variable-chain-uri a) + (variable-chain-uri b))))) (xslt-error "duplicate definition for global variable ~A" - (variable-local-name var))) - (push var specs))) - (setf specs (nreverse specs)) + (variable-chain-local-name chain))) + (push chain chains))) + (setf chains (nreverse chains)) + (let ((table (stylesheet-global-variables stylesheet)) + (newlen (length *global-variable-declarations*))) + (adjust-array table newlen :fill-pointer newlen) + (dolist (chain chains) + (setf (elt table (variable-chain-index chain)) chain))) (lambda () ;; now that the global environment knows about all variables, run the ;; thunk setters to perform their compilation - (mapc (lambda (spec) (funcall (variable-thunk-setter spec))) specs) - (let ((table (stylesheet-global-variables stylesheet)) - (newlen (length *global-variable-declarations*))) - (adjust-array table newlen :fill-pointer newlen) - (dolist (spec specs) - (setf (elt table (variable-index spec)) spec))))))) + (mapc (lambda (chain) + (dolist (var (variable-chain-definitions chain)) + (funcall (variable-value-thunk-setter var)))) + chains))))) (defun parse-templates! (stylesheet env) (let ((i 0)) @@ -1204,10 +1230,10 @@ (*stylesheet* stylesheet) (*empty-mode* (make-mode)) (*default-mode* (find-mode stylesheet nil)) - (global-variable-specs + (global-variable-chains (stylesheet-global-variables stylesheet)) (*global-variable-values* - (make-variable-value-array (length global-variable-specs))) + (make-variable-value-array (length global-variable-chains))) (*uri-resolver* uri-resolver) (source-document (if (typep source-designator 'xml-designator) @@ -1221,20 +1247,23 @@ (when (pathnamep source-designator) (setf (gethash source-designator *documents*) xpath-root-node)) (map nil - (lambda (spec) - (when (variable-param-p spec) - (let ((value - (find-parameter-value (variable-local-name spec) - (variable-uri spec) - parameters))) - (when value - (setf (global-variable-value (variable-index spec)) - value))))) - global-variable-specs) + (lambda (chain) + (let ((head (car (variable-chain-definitions chain)))) + (when (variable-param-p head) + (let ((value + (find-parameter-value + (variable-chain-local-name chain) + (variable-chain-uri chain) + parameters))) + (when value + (setf (global-variable-value + (variable-chain-index chain)) + value)))))) + global-variable-chains) (map nil - (lambda (spec) - (funcall (variable-thunk spec) ctx)) - global-variable-specs) + (lambda (chain) + (funcall (variable-chain-thunk chain) ctx)) + global-variable-chains) ;; zzz we wouldn't have to mask float traps here if we used the ;; XPath API properly. Unfortunately I've been using FUNCALL ;; everywhere instead of EVALUATE, so let's paper over that -- 2.11.4.GIT