From 1bd85a506685b3d3188aaf1d9d097865c38f887d Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 21 Sep 2009 14:37:05 +0000 Subject: [PATCH] 1.0.31.18: better SXHASH on pathnames Patch by Walter C. Pelissero, based on CMUCL code. Also fix stale LOGICAL-PATHNAME test, left out from 1.0.31.17. --- src/code/target-sxhash.lisp | 27 +++++++++++++++++++++------ tests/hash.pure.lisp | 8 +++++++- tests/pathnames.impure.lisp | 7 +++---- version.lisp-expr | 2 +- 4 files changed, 32 insertions(+), 12 deletions(-) diff --git a/src/code/target-sxhash.lisp b/src/code/target-sxhash.lisp index 943ed0c..953160b 100644 --- a/src/code/target-sxhash.lisp +++ b/src/code/target-sxhash.lisp @@ -183,12 +183,27 @@ (sxhash-recurse (cdr x) (1- depthoid))) 261835505))) (instance - (if (or (typep x 'structure-object) (typep x 'condition)) - (logxor 422371266 - (sxhash ; through DEFTRANSFORM - (classoid-name - (layout-classoid (%instance-layout x))))) - (sxhash-instance x))) + (if (pathnamep x) + ;; Pathnames are EQUAL if all the components are EQUAL, so + ;; we hash all of the components of a pathname together. + (let ((hash (sxhash-recurse (pathname-host x) depthoid))) + (mixf hash (sxhash-recurse (pathname-device x) depthoid)) + (mixf hash (sxhash-recurse (pathname-directory x) depthoid)) + (mixf hash (sxhash-recurse (pathname-name x) depthoid)) + (mixf hash (sxhash-recurse (pathname-type x) depthoid)) + ;; Hash :NEWEST the same as NIL because EQUAL for + ;; pathnames assumes that :newest and nil are equal. + (let ((version (%pathname-version x))) + (mixf hash (sxhash-recurse (if (eq version :newest) + nil + version) + depthoid)))) + (if (or (typep x 'structure-object) (typep x 'condition)) + (logxor 422371266 + (sxhash ; through DEFTRANSFORM + (classoid-name + (layout-classoid (%instance-layout x))))) + (sxhash-instance x)))) (symbol (sxhash x)) ; through DEFTRANSFORM (array (typecase x diff --git a/tests/hash.pure.lisp b/tests/hash.pure.lisp index a7d195e..f445896 100644 --- a/tests/hash.pure.lisp +++ b/tests/hash.pure.lisp @@ -28,4 +28,10 @@ ;; Need to make another access to the hash to disable the last-seen-element ;; cache. (setf (gethash 'y hash) t) - (assert (gethash a hash))) \ No newline at end of file + (assert (gethash a hash))) + +;;; Minimum quality checks +(assert (/= (sxhash "foo") (sxhash "bar"))) +(assert (/= (sxhash (pathname "foo.txt")) (sxhash (pathname "bar.txt")))) +(assert (/= (sxhash (list 1 2 3)) (sxhash (list 3 2 1)))) +(assert (/= (sxhash #*1010) (sxhash #*0101))) diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp index e70812f..5e9a8b8 100644 --- a/tests/pathnames.impure.lisp +++ b/tests/pathnames.impure.lisp @@ -20,12 +20,11 @@ (setf (logical-pathname-translations "demo0") '(("**;*.*.*" "/tmp/"))) -;;; In case of a parse error we want to get a condition of type -;;; CL:PARSE-ERROR (or more specifically, of type -;;; SB-KERNEL:NAMESTRING-PARSE-ERROR). +;;; In case of a parse error we want to get a condition of type TYPE-ERROR, +;;; because ANSI says so. (This used to be PARSE-ERROR.) (assert (typep (grab-condition (logical-pathname "demo0::bla;file.lisp")) - 'parse-error)) + 'type-error)) ;;; some things SBCL-0.6.9 used not to parse correctly: ;;; diff --git a/version.lisp-expr b/version.lisp-expr index c9840d5..b810a18 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.31.17" +"1.0.31.18" -- 1.7.10.4