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)