From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Mon, 21 Sep 2009 14:37:05 +0000 (+0000)
Subject: 1.0.31.18: better SXHASH on pathnames
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=1bd85a506685b3d3188aaf1d9d097865c38f887d;p=sbcl.git

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.
---

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"