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