source: trunk/source/tests/ansi-tests/sxhash.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 12 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 7.5 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Fri Nov 28 21:18:12 2003
4;;;; Contains: Tests of SXHASH
5
6(in-package :cl-test)
7
8(deftest sxhash.1
9  (check-predicate #'(lambda (x) (typep (sxhash x) '(and unsigned-byte fixnum))))
10  nil)
11
12(deftest sxhash.2
13  (loop for i from 0 below 256
14        for c = (code-char i)
15        when (and c
16                  (not (= (sxhash (string c))
17                          (sxhash (string c)))))
18        collect c)
19  nil)
20
21(deftest sxhash.3
22  (=t (sxhash "") (sxhash (copy-seq "")))
23  t)
24
25(deftest sxhash.4
26  (loop for bv1 in '(#* #*0 #*1 #*01 #*00 #*10 #*11
27                        #*1100101101100 #*110010101011001011010000111001011)
28        for bv2 = (copy-seq bv1)
29        for sx1 = (sxhash bv1)
30        for sx2 = (sxhash bv2)
31        always (and (not (eq bv1 bv2))
32                    (equal bv1 bv2)
33                    (typep sx1 '(and unsigned-byte fixnum))
34                    (typep sx2 '(and unsigned-byte fixnum))
35                    (= sx1 sx2)))
36  t)
37
38(deftest sxhash.5
39  (let ((s1 "abcd")
40        (s2 (make-array 10 :element-type 'character
41                        :initial-contents "abcdefghij"
42                        :fill-pointer 4)))
43    (and (equalt s1 s2)
44         (=t (sxhash s1) (sxhash s2))))
45  t)
46
47(deftest sxhash.6
48  (let ((s1 #*01101)
49        (s2 (make-array 10 :element-type 'bit
50                        :initial-contents #*0110111101
51                        :fill-pointer 5)))
52    (and (equalt s1 s2)
53         (=t (sxhash s1) (sxhash s2))))
54  t)
55
56(deftest sxhash.7
57  (let* ((a (make-array 10 :initial-element nil))
58         (sx1 (sxhash a)))
59    (setf (aref a 4) 'x)
60    (let ((sx2 (sxhash a)))
61      (and (typep sx1 '(and unsigned-byte fixnum))
62           (eqlt sx1 sx2))))
63  t)
64
65(deftest sxhash.8
66  :notes (:nil-vectors-are-strings)
67  (eqlt (sxhash (make-array 0 :element-type nil))
68        (sxhash ""))
69  t)
70
71(deftest sxhash.9
72  (let ((s1 (make-array 5 :element-type 'base-char :initial-contents "abcde"))
73        (s2 (copy-seq "abcde")))
74    (eqlt (sxhash s1) (sxhash s2)))
75  t)
76
77(deftest sxhash.10
78  (let ((s1 "abcd")
79        (s2 (make-array 10 :element-type 'base-char
80                        :initial-contents "abcdefghij"
81                        :fill-pointer 4)))
82    (and (equalt s1 s2)
83         (=t (sxhash s1) (sxhash s2))))
84  t)
85
86(deftest sxhash.11
87  (let* ((x (cons 'a 'b))
88         (sx1 (sxhash x))
89         (sx2 (sxhash '(a . b))))
90    (setf (car x) 'c)
91    (let* ((sx3 (sxhash x))
92           (sx4 (sxhash '(c . b))))
93      (and (=t sx1 sx2)
94           (=t sx3 sx4))))
95  t)
96
97(deftest sxhash.12
98  (let ((x (1+ most-positive-fixnum))
99        (y (1+ most-positive-fixnum)))
100    (=t (sxhash x) (sxhash y)))
101  t)
102
103(deftest sxhash.13
104  (let ((sx1 (sxhash (make-symbol "FOO")))
105        (sx2 (sxhash (make-symbol "FOO"))))                   
106    (and (typep sx1 '(and unsigned-byte fixnum))
107         (eqlt sx1 sx2)))
108  t)
109
110;; (deftest sxhash.14
111;;  (let ((sx1 (sxhash :foo))
112;;      (sx2 (sxhash '#:foo)))
113;;    (and (typep sx1 '(and unsigned-byte fixnum))
114;;       (eqlt sx1 sx2)))
115;;  t)
116
117(deftest sxhash.15
118  (let* ((package-name
119          (loop for i from 0
120                for name = (format nil "PACKAGE-~A" i)
121                for package = (find-package name)
122                unless package do (return name)))
123         (sx1
124          (let* ((package (make-package package-name :nicknames nil :use nil))
125                 (symbol (intern "FOO" package)))
126            (prog1
127               (sxhash symbol)
128              (delete-package package))))
129         (sx2
130          (let* ((package (make-package package-name :nicknames nil :use nil))
131                 (symbol (intern "FOO" package)))
132            (prog1
133               (sxhash symbol)
134              (delete-package package)))))
135    (assert (typep sx1 '(and unsigned-byte fixnum)))
136    (if (= sx1 sx2) :good (list sx1 sx2)))
137  :good)
138
139(deftest sxhash.16
140  (let ((c1 (list 'a))
141        (c2 (list 'a)))
142    (setf (cdr c1) c1)
143    (setf (cdr c2) c2)
144    (let ((sx1 (sxhash c1))
145          (sx2 (sxhash c2)))
146      (or (eqlt sx1 sx2) (list sx1 sx2))))
147  t)
148
149;;; Since similarity of numbers is 'same type and same mathematical value',
150;;; and since sxhash must produce the same value for similar numeric arguments,
151;;; (sxhash 0.0) and (sxhash -0.0) must be eql for all float types.
152;;; This may be a spec bug, so I've added a note.
153
154(deftest sxhash.17
155  :notes (:negative-zero-is-similar-to-positive-zero)
156  (loop for c1 in '(0.0s0 0.0f0 0.0d0 0.0l0)
157        for c2 in '(-0.0s0 -0.0f0 -0.0d0 -0.0l0)
158        for t1 = (type-of c1)
159        for t2 = (type-of c2)
160        for sx1 = (sxhash c1)
161        for sx2 = (sxhash c2)
162        unless (or (not (subtypep t1 t2))
163                   (not (subtypep t2 t1))
164                   (eql sx1 sx2))
165        collect (list c1 c2 sx1 sx2))
166  nil)
167
168(deftest sxhash.18
169  :notes (:negative-zero-is-similar-to-positive-zero)
170  (loop for r1 in '(0.0s0 0.0f0 0.0d0 0.0l0)
171        for c1 = (complex r1)
172        for r2 in '(-0.0s0 -0.0f0 -0.0d0 -0.0l0)
173        for c2 = (complex r2)
174        for t1 = (type-of c1)
175        for t2 = (type-of c2)
176        for sx1 = (sxhash c1)
177        for sx2 = (sxhash c2)
178        unless (or (not (subtypep t1 t2))
179                   (not (subtypep t2 t1))
180                   (eql sx1 sx2))
181        collect (list c1 c2 sx1 sx2))
182  nil)
183
184(deftest sxhash.19
185  :notes (:negative-zero-is-similar-to-positive-zero)
186  (loop for r1 in '(0.0s0 0.0f0 0.0d0 0.0l0)
187        for c1 = (complex 0 r1)
188        for r2 in '(-0.0s0 -0.0f0 -0.0d0 -0.0l0)
189        for c2 = (complex 0 r2)
190        for t1 = (type-of c1)
191        for t2 = (type-of c2)
192        for sx1 = (sxhash c1)
193        for sx2 = (sxhash c2)
194        unless (or (not (subtypep t1 t2))
195                   (not (subtypep t2 t1))
196                   (eql sx1 sx2))
197        collect (list c1 c2 sx1 sx2))
198  nil)
199
200;;; Similar pathnames have the same hash
201(deftest sxhash.20
202  (let* ((pathspec "sxhash.lsp")
203         (sx1 (sxhash (pathname (copy-seq pathspec))))
204         (sx2 (sxhash (pathname (copy-seq pathspec)))))
205    (if (and (typep sx1 '(and fixnum unsigned-byte))
206             (eql sx1 sx2))
207        :good
208      (list sx1 sx2)))
209  :good)
210
211;;; Similarity for strings
212(deftest sxhash.21
213  (let* ((s1 "abc")
214         (s2 (make-array '(3) :element-type 'character
215                         :initial-contents s1))
216         (s3 (make-array '(3) :element-type 'base-char
217                         :initial-contents s1))
218         (s4 (make-array '(3) :element-type 'standard-char
219                         :initial-contents s1))
220         (s5 (make-array '(3) :element-type 'character
221                         :adjustable t
222                         :initial-contents "abc"))
223         (s6 (make-array '(5) :element-type 'character
224                         :fill-pointer 3
225                         :initial-contents "abcde"))
226         (s7 (make-array '(3) :element-type 'character
227                         :displaced-to s2
228                         :displaced-index-offset 0))
229         (s8 (make-array '(3) :element-type 'character
230                         :displaced-to (make-array '(7) :element-type 'character
231                                                   :initial-contents "xxabcyy")
232                         :displaced-index-offset 2))
233         (strings (list s1 s2 s3 s4 s5 s6 s7 s8))
234         (hashes (mapcar #'sxhash strings)))
235    (if (and (every #'(lambda (h) (typep h '(and unsigned-byte fixnum))) hashes)
236             (not (position (car hashes) hashes :test #'/=)))
237        :good
238      hashes))
239  :good)
240
241;;; Similarity for bit vectors
242(deftest sxhash.22
243  (let* ((bv1 #*010)
244         (bv2 (make-array '(3) :element-type 'bit
245                         :initial-contents bv1))
246         (bv5 (make-array '(3) :element-type 'bit
247                         :adjustable t
248                         :initial-contents bv1))
249         (bv6 (make-array '(5) :element-type 'bit
250                         :fill-pointer 3
251                         :initial-contents #*01010))
252         (bv7 (make-array '(3) :element-type 'bit
253                         :displaced-to bv2
254                         :displaced-index-offset 0))
255         (bv8 (make-array '(3) :element-type 'bit
256                         :displaced-to (make-array '(7) :element-type 'bit
257                                                   :initial-contents #*1101001)
258                         :displaced-index-offset 2))
259         (bit-vectors (list bv1 bv2 bv5 bv6 bv7 bv8))
260         (hashes (mapcar #'sxhash bit-vectors)))
261    (if (and (every #'(lambda (h) (typep h '(and unsigned-byte fixnum))) hashes)
262             (not (position (car hashes) hashes :test #'/=)))
263        :good
264      hashes))
265  :good)
266
267;;; The hash of a symbol does not change when its package changes
268(deftest sxhash.23
269  (progn
270    (safely-delete-package "A")
271    (defpackage "A" (:use))
272    (let* ((pkg (find-package "A"))
273           (sym (intern "FOO" pkg))
274           (hash (sxhash sym)))
275      (unintern sym pkg)
276      (let ((hash2 (sxhash sym)))
277        (if (eql hash hash2) nil (list hash hash2)))))
278  nil)     
279
280;;; Error cases
281
282(deftest sxhash.error.1
283  (signals-error (sxhash) program-error)
284  t)
285
286(deftest sxhash.error.2
287  (signals-error (sxhash nil nil) program-error)
288  t)
Note: See TracBrowser for help on using the repository browser.