0.pre7.14:
[sbcl.git] / tests / hash.impure.lisp
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3 ;;;;
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
6 ;;;; from CMU CL.
7 ;;;; 
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.
11
12 (in-package :cl-user)
13
14 (defstruct foo)
15 (defstruct bar x y)
16
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!)
22 (locally
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 ()
27            (list (cons 0 1)
28                  (list 0 1)
29                  (cons 1 0)
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))
36
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)
46
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))
50                
51                  (complex 1.0 2.0) (complex 1.0d0 2.0)
52                  (complex 1.5 -3/2) (complex 1.5 -1.5d0)
53                
54                  #\x #\X #\*))
55          (make-psxhash-extra-subtests ()
56            (list (copy-seq "")
57                  (copy-seq #*)
58                  (copy-seq #())
59                  (copy-seq ())
60                  (copy-seq '(()))
61                  (copy-seq #(()))
62                  (copy-seq '(#()))
63                  (make-array 3 :fill-pointer 0)
64                  (make-array 7 :fill-pointer 0 :element-type 'bit)
65                  (make-array 8 :fill-pointer 0 :element-type 'character)
66                  (vector (cons 1 0) (cons 0 0))
67                  (vector (cons 0 1) (cons 0 0))
68                  (vector (cons 0 0) (cons 1 0))
69                  (vector (cons 0 0) (cons 0 1))
70                  (vector (cons 1 0) (cons 0 0))
71                  (vector (cons 0 1) (cons 0 0))
72                  (vector (list 0 0) (cons 1 0))
73                  (vector (list 0 0) (list 0 1))
74                  (vector (vector 1 0) (list 0 0))
75                  (vector (vector 0 1) (list 0 0))
76                  (vector (vector 0 0) (list 1 0))
77                  (vector (vector 0 0) (list 0 1))
78                  (vector #*00 #*10)
79                  (vector (vector 0 0) (list 0 1.0d0))
80                  (vector (vector -0.0d0 0) (list 1.0 0))
81                  (vector 1 0 1 0)
82                  (vector 0 0 0)
83                  (copy-seq #*1010)
84                  (copy-seq #*000)
85                  (replace (make-array 101
86                                       :element-type 'bit
87                                       :fill-pointer 4)
88                           #*1010)
89                  (replace (make-array 14
90                                       :element-type '(unsigned-byte 8)
91                                       :fill-pointer 3)
92                           #*000)
93                  (replace (make-array 14
94                                       :element-type t
95                                       :fill-pointer 3)
96                           #*000)
97                  (copy-seq "abc")
98                  (copy-seq "ABC")
99                  (copy-seq "aBc")
100                  (copy-seq "abcc")
101                  (copy-seq "1001")
102                  'abc
103                  (vector #\a #\b #\c)
104                  (vector 'a 'b 'c)
105                  (vector "A" 'b 'c)
106                  (replace (make-array 14
107                                       :element-type 'character
108                                       :fill-pointer 3)
109                           "aBc")
110                  (replace (make-array 11
111                                       :element-type 'character
112                                       :fill-pointer 4)
113                           "1001")
114                  (replace (make-array 12
115                                       :element-type 'bit
116                                       :fill-pointer 4)
117                           #*1001)
118                  (replace (make-array 13
119                                       :element-type t
120                                       :fill-pointer 4)
121                           "1001")
122                  (replace (make-array 13
123                                       :element-type t
124                                       :fill-pointer 4)
125                           #*1001)
126                  ;; FIXME: What about multi-dimensional arrays, hmm?
127
128                  (make-hash-table) 
129                  (make-hash-table :test 'equal)
130
131                  (make-foo)
132                  (make-bar)
133                  (make-bar :x (list 1))
134                  (make-bar :y (list 1))))
135          (t->boolean (x) (if x t nil)))
136     (let* (;; Note:
137            ;;   * The APPEND noise here is to help more strenuously test
138            ;;     not-EQ-but-EQUAL and not-EQ-but-EQUALP cases.
139            ;;   * It seems not to be worth the hassle testing SXHASH on
140            ;;     values whose structure isn't understood by EQUAL, since
141            ;;     we get too many false positives "SXHASHes are equal even
142            ;;     though values aren't EQUAL, what a crummy hash function!"
143            ;;     FIXME: Or am I misunderstanding the intent of the
144            ;;     the SXHASH specification? Perhaps SXHASH is supposed to
145            ;;     descend into the structure of objects even when EQUAL
146            ;;     doesn't, in order to avoid hashing together things which
147            ;;     are guaranteed not to be EQUAL? The definition of SXHASH
148            ;;     seems to leave this completely unspecified: should
149            ;;     "well-distributed" depend on substructure that EQUAL
150            ;;     ignores? For our internal hash tables, the stricter
151            ;;     descend-into-the-structure behavior might improve
152            ;;     performance even though it's not specified by ANSI. But
153            ;;     is it reasonable for users to expect it? Hmm..
154            (sxhash-tests (append (make-sxhash-subtests)
155                                  (make-sxhash-subtests)))
156            (psxhash-tests (append sxhash-tests
157                                   (make-psxhash-extra-subtests)
158                                   (make-psxhash-extra-subtests))))
159       ;; Check that SXHASH compiler transforms give the same results
160       ;; as the out-of-line version of SXHASH.
161       (let* ((fundef `(lambda ()
162                         (list ,@(mapcar (lambda (value)
163                                           `(sxhash ',value))
164                                         sxhash-tests))))
165              (fun (compile nil fundef)))
166         (assert (equal (funcall fun)
167                        (mapcar #'sxhash sxhash-tests))))
168       ;; Note: The tests for SXHASH-equality iff EQUAL and
169       ;; PSXHASH-equality iff EQUALP could fail because of an unlucky
170       ;; random collision. That's not very likely (since there are
171       ;; (EXPT 2 29) possible hash values and only on the order of 100
172       ;; test cases, so even with the birthday paradox a collision has
173       ;; probability only (/ (EXPT 100 2) (EXPT 2 29)), but it's
174       ;; probably worth checking if you are getting a mystifying error
175       ;; from this test. (SXHASH values and PSXHASH values don't
176       ;; change from run to run, so the random chance of bogus failure
177       ;; happens once every time the code is changed in such a way
178       ;; that the SXHASH distribution changes, not once every time the
179       ;; tests are run.)
180       (dolist (i sxhash-tests)
181         (unless (typep (sxhash i) '(and fixnum unsigned-byte))
182           (error "bad SXHASH behavior for ~S" i))
183         (dolist (j sxhash-tests)
184           (unless (eq (t->boolean (equal i j))
185                       (t->boolean (= (sxhash i) (sxhash j))))
186             ;; (If you get a surprising failure here, maybe you were
187             ;; just very unlucky; see the notes above.)
188             (error "bad SXHASH behavior for ~S ~S" i j))))
189       (dolist (i psxhash-tests)
190         (unless (typep (sb-int:psxhash i) '(and fixnum unsigned-byte))
191           (error "bad PSXHASH behavior for ~S" i))
192         (dolist (j psxhash-tests)
193           (unless (eq (t->boolean (equalp i j))
194                       (t->boolean (= (sb-int:psxhash i) (sb-int:psxhash j))))
195             ;; (If you get a surprising failure here, maybe you were
196             ;; just very unlucky; see the notes above.)
197             (error "bad PSXHASH behavior for ~S ~S" i j))))
198       )))
199
200 ;;; As of sbcl-0.6.12.10, writing hash tables readably should work.
201 ;;; This isn't required by the ANSI standard, but it should be, since
202 ;;; it's well-defined useful behavior which ANSI prohibits the users
203 ;;; from implementing themselves. (ANSI says the users can't define
204 ;;; their own their own PRINT-OBJECT (HASH-TABLE T) methods, and they
205 ;;; can't even wiggle out of it by subclassing HASH-TABLE or STREAM.)
206 (let ((original-ht (make-hash-table :test 'equal :size 111))
207       (original-keys '(1 10 11 400030002 -100000000)))
208   (dolist (key original-keys)
209     (setf (gethash key original-ht)
210           (expt key 4)))
211   (let* ((written-ht (with-output-to-string (s)
212                        (write original-ht :stream s :readably t)))
213          (read-ht (with-input-from-string (s written-ht)
214                     (read s))))
215     (assert (= (hash-table-count read-ht)
216                (hash-table-count original-ht)
217                (length original-keys)))
218     (assert (eql (hash-table-test original-ht) (hash-table-test read-ht)))
219     (assert (eql (hash-table-size original-ht) (hash-table-size read-ht)))
220     (dolist (key original-keys)
221       (assert (eql (gethash key read-ht)
222                    (gethash key original-ht))))))
223
224 ;;; success
225 (quit :unix-status 104)