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
  56                  #'allocate-instance #'no-applicable-method))
  57          (make-psxhash-extra-subtests ()
  58            (list (copy-seq "")
  59                  (copy-seq #*)
  60                  (copy-seq #())
  61                  (copy-seq ())
  62                  (copy-seq '(()))
  63                  (copy-seq #(()))
  64                  (copy-seq '(#()))
  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))
  80                  (vector #*00 #*10)
  81                  (vector (vector 0 0) (list 0 1.0d0))
  82                  (vector (vector -0.0d0 0) (list 1.0 0))
  83                  (vector 1 0 1 0)
  84                  (vector 0 0 0)
  85                  (copy-seq #*1010)
  86                  (copy-seq #*000)
  87                  (replace (make-array 101
  88                                       :element-type 'bit
  89                                       :fill-pointer 4)
  90                           #*1010)
  91                  (replace (make-array 14
  92                                       :element-type '(unsigned-byte 8)
  93                                       :fill-pointer 3)
  94                           #*000)
  95                  (replace (make-array 14
  96                                       :element-type t
  97                                       :fill-pointer 3)
  98                           #*000)
  99                  (copy-seq "abc")
 100                  (copy-seq "ABC")
 101                  (copy-seq "aBc")
 102                  (copy-seq "abcc")
 103                  (copy-seq "1001")
 104                  'abc
 105                  (vector #\a #\b #\c)
 106                  (vector 'a 'b 'c)
 107                  (vector "A" 'b 'c)
 108                  (replace (make-array 14
 109                                       :element-type 'character
 110                                       :fill-pointer 3)
 111                           "aBc")
 112                  (replace (make-array 11
 113                                       :element-type 'character
 114                                       :fill-pointer 4)
 115                           "1001")
 116                  (replace (make-array 12
 117                                       :element-type 'bit
 118                                       :fill-pointer 4)
 119                           #*1001)
 120                  (replace (make-array 13
 121                                       :element-type t
 122                                       :fill-pointer 4)
 123                           "1001")
 124                  (replace (make-array 13
 125                                       :element-type t
 126                                       :fill-pointer 4)
 127                           #*1001)
 128                  ;; FIXME: What about multi-dimensional arrays, hmm?
 129
 130                  (make-hash-table)
 131                  (make-hash-table :test 'equal)
 132
 133                  (make-foo)
 134                  (make-bar)
 135                  (make-bar :x (list 1))
 136                  (make-bar :y (list 1))))
 137          (t->boolean (x) (if x t nil)))
 138     (let* (;; Note:
 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)
 165                                           `(sxhash ',value))
 166                                         sxhash-tests))))
 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
 181       ;; tests are run.)
 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))))
 200       )))
 201
 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)
 212           (expt key 4)))
 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)
 216                     (read s))))
 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))))))
 225
 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)
 230                                       (declare (symbol x))
 231                                       (,fun x)))
 232                       nil)
 233              (funcall (compile nil `(lambda (x)
 234                                       (declare (list x))
 235                                       (,fun x)))
 236                       nil))))
 237
 238 ;;; success
 239 (quit :unix-status 104)