1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; While most of SBCL is derived from the CMU CL system, the test
5 ;;;; files (like this one) were written from scratch after the fork
8 ;;;; This software is in the public domain and is provided with
9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
10 ;;;; more information.
17 ;;; SXHASH and PSXHASH should distribute hash values well over the
18 ;;; space of possible values, so that collisions between the hash
19 ;;; values of unequal objects should be very uncommon. (Except of
20 ;;; course the hash values must collide when the objects are EQUAL or
21 ;;; EQUALP respectively!)
23 ;; In order to better test not-EQ-but-EQUAL and not-EQ-but-EQUALP,
24 ;; we'd like to suppress some optimizations.
25 (declare (notinline complex float coerce + - expt))
26 (flet ((make-sxhash-subtests ()
30 (cons (cons 1 0) (cons 0 0))
31 (cons (list 1 0) (list 0 0))
32 (list (cons 1 0) (list 0 0))
33 (list (cons 0 1) (list 0 0))
34 (list (cons 0 0) (cons 1 0))
35 (list (cons 0 0) (cons 0 1))
37 44 (float 44) (coerce 44 'double-float)
38 -44 (float -44) (coerce -44 'double-float)
39 0 (float 0) (coerce 0 'double-float)
40 -0 (- (float 0)) (- (coerce 0 'double-float))
41 -121 (float -121) (coerce -121 'double-float)
42 3/4 (float 3/4) (coerce 3/4 'double-float)
43 -3/4 (float -3/4) (coerce -3/4 'double-float)
44 45 (float 45) (coerce 45 'double-float)
45 441/10 (float 441/10) (coerce (float 441/10) 'double-float)
47 (expt 2 33) (expt 2.0 33) (expt 2.0d0 33)
48 (- (expt 1/2 50)) (- (expt 0.5 50)) (- (expt 0.5d0 50))
49 (+ (expt 1/2 50)) (+ (expt 0.5 50)) (+ (expt 0.5d0 50))
51 (complex 1.0 2.0) (complex 1.0d0 2.0)
52 (complex 1.5 -3/2) (complex 1.5 -1.5d0)
56 #'allocate-instance #'no-applicable-method))
57 (make-psxhash-extra-subtests ()
65 (make-array 3 :fill-pointer 0)
66 (make-array 7 :fill-pointer 0 :element-type 'bit)
67 (make-array 8 :fill-pointer 0 :element-type 'character)
68 (vector (cons 1 0) (cons 0 0))
69 (vector (cons 0 1) (cons 0 0))
70 (vector (cons 0 0) (cons 1 0))
71 (vector (cons 0 0) (cons 0 1))
72 (vector (cons 1 0) (cons 0 0))
73 (vector (cons 0 1) (cons 0 0))
74 (vector (list 0 0) (cons 1 0))
75 (vector (list 0 0) (list 0 1))
76 (vector (vector 1 0) (list 0 0))
77 (vector (vector 0 1) (list 0 0))
78 (vector (vector 0 0) (list 1 0))
79 (vector (vector 0 0) (list 0 1))
81 (vector (vector 0 0) (list 0 1.0d0))
82 (vector (vector -0.0d0 0) (list 1.0 0))
87 (replace (make-array 101
91 (replace (make-array 14
92 :element-type '(unsigned-byte 8)
95 (replace (make-array 14
108 (replace (make-array 14
109 :element-type 'character
112 (replace (make-array 11
113 :element-type 'character
116 (replace (make-array 12
120 (replace (make-array 13
124 (replace (make-array 13
128 ;; FIXME: What about multi-dimensional arrays, hmm?
131 (make-hash-table :test 'equal)
135 (make-bar :x (list 1))
136 (make-bar :y (list 1))))
137 (t->boolean (x) (if x t nil)))
139 ;; * The APPEND noise here is to help more strenuously test
140 ;; not-EQ-but-EQUAL and not-EQ-but-EQUALP cases.
141 ;; * It seems not to be worth the hassle testing SXHASH on
142 ;; values whose structure isn't understood by EQUAL, since
143 ;; we get too many false positives "SXHASHes are equal even
144 ;; though values aren't EQUAL, what a crummy hash function!"
145 ;; FIXME: Or am I misunderstanding the intent of the
146 ;; the SXHASH specification? Perhaps SXHASH is supposed to
147 ;; descend into the structure of objects even when EQUAL
148 ;; doesn't, in order to avoid hashing together things which
149 ;; are guaranteed not to be EQUAL? The definition of SXHASH
150 ;; seems to leave this completely unspecified: should
151 ;; "well-distributed" depend on substructure that EQUAL
152 ;; ignores? For our internal hash tables, the stricter
153 ;; descend-into-the-structure behavior might improve
154 ;; performance even though it's not specified by ANSI. But
155 ;; is it reasonable for users to expect it? Hmm..
156 (sxhash-tests (append (make-sxhash-subtests)
157 (make-sxhash-subtests)))
158 (psxhash-tests (append sxhash-tests
159 (make-psxhash-extra-subtests)
160 (make-psxhash-extra-subtests))))
161 ;; Check that SXHASH compiler transforms give the same results
162 ;; as the out-of-line version of SXHASH.
163 (let* ((fundef `(lambda ()
164 (list ,@(mapcar (lambda (value)
167 (fun (compile nil fundef)))
168 (assert (equal (funcall fun)
169 (mapcar #'sxhash sxhash-tests))))
170 ;; Note: The tests for SXHASH-equality iff EQUAL and
171 ;; PSXHASH-equality iff EQUALP could fail because of an unlucky
172 ;; random collision. That's not very likely (since there are
173 ;; (EXPT 2 29) possible hash values and only on the order of 100
174 ;; test cases, so even with the birthday paradox a collision has
175 ;; probability only (/ (EXPT 100 2) (EXPT 2 29)), but it's
176 ;; probably worth checking if you are getting a mystifying error
177 ;; from this test. (SXHASH values and PSXHASH values don't
178 ;; change from run to run, so the random chance of bogus failure
179 ;; happens once every time the code is changed in such a way
180 ;; that the SXHASH distribution changes, not once every time the
182 (dolist (i sxhash-tests)
183 (unless (typep (sxhash i) '(and fixnum unsigned-byte))
184 (error "bad SXHASH behavior for ~S" i))
185 (dolist (j sxhash-tests)
186 (unless (eq (t->boolean (equal i j))
187 (t->boolean (= (sxhash i) (sxhash j))))
188 ;; (If you get a surprising failure here, maybe you were
189 ;; just very unlucky; see the notes above.)
190 (error "bad SXHASH behavior for ~S ~S" i j))))
191 (dolist (i psxhash-tests)
192 (unless (typep (sb-int:psxhash i) '(and fixnum unsigned-byte))
193 (error "bad PSXHASH behavior for ~S" i))
194 (dolist (j psxhash-tests)
195 (unless (eq (t->boolean (equalp i j))
196 (t->boolean (= (sb-int:psxhash i) (sb-int:psxhash j))))
197 ;; (If you get a surprising failure here, maybe you were
198 ;; just very unlucky; see the notes above.)
199 (error "bad PSXHASH behavior for ~S ~S" i j))))
202 ;;; As of sbcl-0.6.12.10, writing hash tables readably should work.
203 ;;; This isn't required by the ANSI standard, but it should be, since
204 ;;; it's well-defined useful behavior which ANSI prohibits the users
205 ;;; from implementing themselves. (ANSI says the users can't define
206 ;;; their own their own PRINT-OBJECT (HASH-TABLE T) methods, and they
207 ;;; can't even wiggle out of it by subclassing HASH-TABLE or STREAM.)
208 (let ((original-ht (make-hash-table :test 'equal :size 111))
209 (original-keys '(1 10 11 400030002 -100000000)))
210 (dolist (key original-keys)
211 (setf (gethash key original-ht)
213 (let* ((written-ht (with-output-to-string (s)
214 (write original-ht :stream s :readably t)))
215 (read-ht (with-input-from-string (s written-ht)
217 (assert (= (hash-table-count read-ht)
218 (hash-table-count original-ht)
219 (length original-keys)))
220 (assert (eql (hash-table-test original-ht) (hash-table-test read-ht)))
221 (assert (eql (hash-table-size original-ht) (hash-table-size read-ht)))
222 (dolist (key original-keys)
223 (assert (eql (gethash key read-ht)
224 (gethash key original-ht))))))
226 ;;; NIL is both SYMBOL and LIST
227 (dolist (fun '(sxhash sb-impl::psxhash))
228 (assert (= (funcall fun nil)
229 (funcall (compile nil `(lambda (x)
233 (funcall (compile nil `(lambda (x)
239 (quit :unix-status 104)