Mercurial > hg > xemacs-beta
annotate tests/automated/hash-table-tests.el @ 4792:95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
lisp/ChangeLog addition:
2009-11-08 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (cl-string-vector-equalp)
(cl-bit-vector-vector-equalp, cl-vector-array-equalp)
(cl-hash-table-contents-equalp): New functions, to implement
equalp treating arrays with identical contents as equivalent, as
specified by Common Lisp.
(equalp): Revise this function to implement array equivalence,
and the hash-table equalp behaviour specified by CL.
* cl-macs.el (equalp): Add a compiler macro for this function,
used when one of the arguments is constant, and as such, its type
is known at compile time.
man/ChangeLog addition:
2009-11-08 Aidan Kehoe <kehoea@parhasard.net>
* lispref/objects.texi (Equality Predicates):
Document #'equalp here, as well as #'equal and #'eq.
tests/ChangeLog addition:
2009-12-31 Aidan Kehoe <kehoea@parhasard.net>
* automated/lisp-tests.el:
Test much of the functionality of equalp; add a pointer to Paul
Dietz' ANSI test suite for this function, converted to Emacs
Lisp. Not including the tests themselves in XEmacs because who
owns the copyright on the files is unclear and the GCL people
didn't respond to my queries.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Thu, 31 Dec 2009 15:09:41 +0000 |
| parents | 479443c0f95a |
| children | 189fb67ca31a |
| rev | line source |
|---|---|
| 428 | 1 ;; Copyright (C) 1998 Free Software Foundation, Inc. |
| 2 | |
| 3 ;; Author: Martin Buchholz <martin@xemacs.org> | |
| 4 ;; Maintainer: Martin Buchholz <martin@xemacs.org> | |
| 5 ;; Created: 1998 | |
| 6 ;; Keywords: tests, database | |
| 7 | |
| 8 ;; This file is part of XEmacs. | |
| 9 | |
| 10 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 11 ;; under the terms of the GNU General Public License as published by | |
| 12 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 13 ;; any later version. | |
| 14 | |
| 15 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 18 ;; General Public License for more details. | |
| 19 | |
| 20 ;; You should have received a copy of the GNU General Public License | |
| 21 ;; along with XEmacs; see the file COPYING. If not, write to the Free | |
| 22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA | |
| 23 ;; 02111-1307, USA. | |
| 24 | |
| 25 ;;; Synched up with: Not in FSF. | |
| 26 | |
| 27 ;;; Commentary: | |
| 28 | |
| 29 ;;; Test hash tables implementation | |
| 30 ;;; See test-harness.el | |
| 31 | |
| 32 (condition-case err | |
| 33 (require 'test-harness) | |
| 34 (file-error | |
| 35 (when (and (boundp 'load-file-name) (stringp load-file-name)) | |
| 36 (push (file-name-directory load-file-name) load-path) | |
| 37 (require 'test-harness)))) | |
| 38 | |
| 39 ;; Test all combinations of make-hash-table keywords | |
| 40 (dolist (test '(eq eql equal)) | |
| 41 (dolist (size '(0 1 100)) | |
| 42 (dolist (rehash-size '(1.1 9.9)) | |
| 43 (dolist (rehash-threshold '(0.2 .9)) | |
| 442 | 44 (dolist (weakness '(nil key value key-or-value key-and-value)) |
| 428 | 45 (dolist (data '(() (1 2) (1 2 3 4))) |
| 46 (let ((ht (make-hash-table | |
| 47 :test test | |
| 48 :size size | |
| 49 :rehash-size rehash-size | |
| 50 :rehash-threshold rehash-threshold | |
| 51 :weakness weakness))) | |
| 52 (Assert (equal ht (car (let ((print-readably t)) | |
| 53 (read-from-string (prin1-to-string ht)))))) | |
| 54 (Assert (eq test (hash-table-test ht))) | |
| 55 (Assert (<= size (hash-table-size ht))) | |
| 56 (Assert (eql rehash-size (hash-table-rehash-size ht))) | |
| 57 (Assert (eql rehash-threshold (hash-table-rehash-threshold ht))) | |
| 58 (Assert (eq weakness (hash-table-weakness ht)))))))))) | |
| 59 | |
| 60 (loop for (fun weakness) in '((make-hashtable nil) | |
| 442 | 61 (make-weak-hashtable key-and-value) |
| 428 | 62 (make-key-weak-hashtable key) |
| 63 (make-value-weak-hashtable value)) | |
| 64 do (Assert (eq weakness (hash-table-weakness (funcall fun 10))))) | |
| 65 | |
| 66 (loop for (type weakness) in '((non-weak nil) | |
| 442 | 67 (weak key-and-value) |
| 428 | 68 (key-weak key) |
| 69 (value-weak value)) | |
| 70 do (Assert (equal (make-hash-table :type type) | |
| 71 (make-hash-table :weakness weakness)))) | |
| 72 | |
| 73 (Assert (not (equal (make-hash-table :weakness nil) | |
| 74 (make-hash-table :weakness t)))) | |
| 75 | |
| 76 (let ((ht (make-hash-table :size 20 :rehash-threshold .75 :test 'eq)) | |
| 77 (size 80)) | |
| 78 (Assert (hashtablep ht)) | |
| 79 (Assert (hash-table-p ht)) | |
| 80 (Assert (eq 'eq (hash-table-test ht))) | |
| 81 (Assert (eq 'non-weak (hash-table-type ht))) | |
| 82 (Assert (eq 'non-weak (hashtable-type ht))) | |
| 83 (Assert (eq 'nil (hash-table-weakness ht))) | |
| 84 (dotimes (j size) | |
| 85 (puthash j (- j) ht) | |
| 86 (Assert (eq (gethash j ht) (- j))) | |
| 87 (Assert (= (hash-table-count ht) (1+ j))) | |
| 88 (Assert (= (hashtable-fullness ht) (hash-table-count ht))) | |
| 89 (puthash j j ht) | |
| 90 (Assert (eq (gethash j ht 'foo) j)) | |
| 91 (Assert (= (hash-table-count ht) (1+ j))) | |
| 92 (setf (gethash j ht) (- j)) | |
| 93 (Assert (eq (gethash j ht) (- j))) | |
| 94 (Assert (= (hash-table-count ht) (1+ j)))) | |
| 95 | |
| 96 (clrhash ht) | |
| 97 (Assert (= 0 (hash-table-count ht))) | |
| 98 | |
| 99 (dotimes (j size) | |
| 100 (puthash j (- j) ht) | |
| 101 (Assert (eq (gethash j ht) (- j))) | |
| 102 (Assert (= (hash-table-count ht) (1+ j)))) | |
| 103 | |
| 104 (let ((k-sum 0) (v-sum 0)) | |
| 105 (maphash #'(lambda (k v) (incf k-sum k) (incf v-sum v)) ht) | |
| 106 (Assert (= k-sum (/ (* size (- size 1)) 2))) | |
| 107 (Assert (= v-sum (- k-sum)))) | |
| 108 | |
| 109 (let ((count size)) | |
| 110 (dotimes (j size) | |
| 111 (remhash j ht) | |
| 112 (Assert (eq (gethash j ht) nil)) | |
| 113 (Assert (eq (gethash j ht 'foo) 'foo)) | |
| 114 (Assert (= (hash-table-count ht) (decf count)))))) | |
| 115 | |
| 116 (let ((ht (make-hash-table :size 30 :rehash-threshold .25 :test 'equal)) | |
| 117 (size 70)) | |
| 118 (Assert (hashtablep ht)) | |
| 119 (Assert (hash-table-p ht)) | |
| 120 (Assert (>= (hash-table-size ht) (/ 30 .25))) | |
| 121 (Assert (eql .25 (hash-table-rehash-threshold ht))) | |
| 122 (Assert (eq 'equal (hash-table-test ht))) | |
| 123 (Assert (eq (hash-table-test ht) (hashtable-test-function ht))) | |
| 124 (Assert (eq 'non-weak (hash-table-type ht))) | |
| 125 (dotimes (j size) | |
| 126 (puthash (int-to-string j) (- j) ht) | |
| 127 (Assert (eq (gethash (int-to-string j) ht) (- j))) | |
| 128 (Assert (= (hash-table-count ht) (1+ j))) | |
| 129 (puthash (int-to-string j) j ht) | |
| 130 (Assert (eq (gethash (int-to-string j) ht 'foo) j)) | |
| 131 (Assert (= (hash-table-count ht) (1+ j)))) | |
| 132 | |
| 133 (clrhash ht) | |
| 134 (Assert (= 0 (hash-table-count ht))) | |
| 135 (Assert (equal ht (copy-hash-table ht))) | |
| 136 | |
| 137 (dotimes (j size) | |
| 138 (setf (gethash (int-to-string j) ht) (- j)) | |
| 139 (Assert (eq (gethash (int-to-string j) ht) (- j))) | |
| 140 (Assert (= (hash-table-count ht) (1+ j)))) | |
| 141 | |
| 142 (let ((count size)) | |
| 143 (dotimes (j size) | |
| 144 (remhash (int-to-string j) ht) | |
| 145 (Assert (eq (gethash (int-to-string j) ht) nil)) | |
| 146 (Assert (eq (gethash (int-to-string j) ht 'foo) 'foo)) | |
| 147 (Assert (= (hash-table-count ht) (decf count)))))) | |
| 148 | |
| 149 (let ((iterations 5) (one 1.0) (two 2.0)) | |
| 150 (flet ((check-copy | |
| 151 (ht) | |
| 152 (let ((copy-of-ht (copy-hash-table ht))) | |
| 153 (Assert (equal ht copy-of-ht)) | |
| 154 (Assert (not (eq ht copy-of-ht))) | |
| 155 (Assert (eq (hash-table-count ht) (hash-table-count copy-of-ht))) | |
| 156 (Assert (eq (hash-table-type ht) (hash-table-type copy-of-ht))) | |
| 157 (Assert (eq (hash-table-size ht) (hash-table-size copy-of-ht))) | |
| 158 (Assert (eql (hash-table-rehash-size ht) (hash-table-rehash-size copy-of-ht))) | |
| 159 (Assert (eql (hash-table-rehash-threshold ht) (hash-table-rehash-threshold copy-of-ht)))))) | |
| 160 | |
| 161 (let ((ht (make-hash-table :size 100 :rehash-threshold .6 :test 'eq))) | |
| 162 (dotimes (j iterations) | |
| 163 (puthash (+ one 0.0) t ht) | |
| 164 (puthash (+ two 0.0) t ht) | |
| 444 | 165 (puthash (cons 1 2) t ht) |
| 166 (puthash (cons 3 4) t ht)) | |
| 428 | 167 (Assert (eq (hashtable-test-function ht) 'eq)) |
| 168 (Assert (eq (hash-table-test ht) 'eq)) | |
| 169 (Assert (= (* iterations 4) (hash-table-count ht))) | |
| 170 (Assert (eq nil (gethash 1.0 ht))) | |
| 444 | 171 (Assert (eq nil (gethash '(1 . 2) ht))) |
| 428 | 172 (check-copy ht) |
| 173 ) | |
| 174 | |
| 175 (let ((ht (make-hash-table :size 100 :rehash-threshold .6 :test 'eql))) | |
| 176 (dotimes (j iterations) | |
| 177 (puthash (+ one 0.0) t ht) | |
| 178 (puthash (+ two 0.0) t ht) | |
| 444 | 179 (puthash (cons 1 2) t ht) |
| 180 (puthash (cons 3 4) t ht)) | |
| 428 | 181 (Assert (eq (hashtable-test-function ht) 'eql)) |
| 182 (Assert (eq (hash-table-test ht) 'eql)) | |
| 183 (Assert (= (+ 2 (* 2 iterations)) (hash-table-count ht))) | |
| 184 (Assert (eq t (gethash 1.0 ht))) | |
| 444 | 185 (Assert (eq nil (gethash '(1 . 2) ht))) |
| 428 | 186 (check-copy ht) |
| 187 ) | |
| 188 | |
| 189 (let ((ht (make-hash-table :size 100 :rehash-threshold .6 :test 'equal))) | |
| 190 (dotimes (j iterations) | |
| 191 (puthash (+ one 0.0) t ht) | |
| 192 (puthash (+ two 0.0) t ht) | |
| 444 | 193 (puthash (cons 1 2) t ht) |
| 194 (puthash (cons 3 4) t ht)) | |
| 428 | 195 (Assert (eq (hashtable-test-function ht) 'equal)) |
| 196 (Assert (eq (hash-table-test ht) 'equal)) | |
| 197 (Assert (= 4 (hash-table-count ht))) | |
| 198 (Assert (eq t (gethash 1.0 ht))) | |
| 444 | 199 (Assert (eq t (gethash '(1 . 2) ht))) |
| 428 | 200 (check-copy ht) |
| 201 ) | |
| 202 | |
| 203 )) | |
| 204 | |
| 205 ;; Test that weak hash-tables are properly handled | |
| 206 (loop for (weakness expected-count expected-k-sum expected-v-sum) in | |
| 207 '((nil 6 38 25) | |
| 208 (t 3 6 9) | |
| 209 (key 4 38 9) | |
| 210 (value 4 6 25)) | |
| 211 do | |
| 212 (let* ((ht (make-hash-table :weakness weakness)) | |
| 213 (my-obj (cons ht ht))) | |
| 214 (garbage-collect) | |
| 215 (puthash my-obj 1 ht) | |
| 216 (puthash 2 my-obj ht) | |
| 217 (puthash 4 8 ht) | |
| 218 (puthash (cons ht ht) 16 ht) | |
| 219 (puthash 32 (cons ht ht) ht) | |
| 220 (puthash (cons ht ht) (cons ht ht) ht) | |
| 221 (let ((k-sum 0) (v-sum 0)) | |
| 222 (maphash #'(lambda (k v) | |
| 223 (when (integerp k) (incf k-sum k)) | |
| 224 (when (integerp v) (incf v-sum v))) | |
| 225 ht) | |
| 226 (Assert (eq 38 k-sum)) | |
| 227 (Assert (eq 25 v-sum))) | |
| 228 (Assert (eq 6 (hash-table-count ht))) | |
| 229 (garbage-collect) | |
| 230 (Assert (eq expected-count (hash-table-count ht))) | |
| 231 (let ((k-sum 0) (v-sum 0)) | |
| 232 (maphash #'(lambda (k v) | |
| 233 (when (integerp k) (incf k-sum k)) | |
| 234 (when (integerp v) (incf v-sum v))) | |
| 235 ht) | |
| 236 (Assert (eq expected-k-sum k-sum)) | |
| 237 (Assert (eq expected-v-sum v-sum))))) | |
| 238 | |
| 239 ;;; Test the ability to puthash and remhash the current elt of a maphash | |
| 240 (let ((ht (make-hash-table :test 'eql))) | |
| 241 (dotimes (j 100) (setf (gethash j ht) (- j))) | |
| 242 (maphash #'(lambda (k v) | |
| 243 (if (oddp k) (remhash k ht) (puthash k (- v) ht))) | |
| 244 ht) | |
| 245 (let ((k-sum 0) (v-sum 0)) | |
| 246 (maphash #'(lambda (k v) (incf k-sum k) (incf v-sum v)) ht) | |
| 247 (Assert (= (* 50 49) k-sum)) | |
| 248 (Assert (= v-sum k-sum)))) | |
| 249 | |
| 250 ;;; Test reading and printing of hash-table objects | |
| 251 (let ((h1 #s(hashtable weakness t rehash-size 3.0 rehash-threshold .2 test eq data (1 2 3 4))) | |
| 252 (h2 #s(hash-table weakness t rehash-size 3.0 rehash-threshold .2 test eq data (1 2 3 4))) | |
| 253 (h3 (make-hash-table :weakness t :rehash-size 3.0 :rehash-threshold .2 :test 'eq))) | |
| 254 (Assert (equal h1 h2)) | |
| 255 (Assert (not (equal h1 h3))) | |
| 256 (puthash 1 2 h3) | |
| 257 (puthash 3 4 h3) | |
| 258 (Assert (equal h1 h3))) | |
| 259 | |
| 260 ;;; Testing equality of hash tables | |
| 261 (Assert (equal (make-hash-table :test 'eql :size 300 :rehash-threshold .9 :rehash-size 3.0) | |
| 262 (make-hash-table :test 'eql))) | |
| 263 (Assert (not (equal (make-hash-table :test 'eq) | |
| 264 (make-hash-table :test 'equal)))) | |
| 265 (let ((h1 (make-hash-table)) | |
| 266 (h2 (make-hash-table))) | |
| 267 (Assert (equal h1 h2)) | |
| 268 (Assert (not (eq h1 h2))) | |
| 269 (puthash 1 2 h1) | |
| 270 (Assert (not (equal h1 h2))) | |
| 271 (puthash 1 2 h2) | |
| 272 (Assert (equal h1 h2)) | |
| 273 (puthash 1 3 h2) | |
| 274 (Assert (not (equal h1 h2))) | |
| 275 (clrhash h1) | |
| 276 (Assert (not (equal h1 h2))) | |
| 277 (clrhash h2) | |
| 278 (Assert (equal h1 h2)) | |
| 279 ) | |
| 280 | |
| 281 ;;; Test sxhash | |
| 282 (Assert (= (sxhash "foo") (sxhash "foo"))) | |
| 283 (Assert (= (sxhash '(1 2 3)) (sxhash '(1 2 3)))) | |
|
4398
479443c0f95a
Have list hashes depend on the order of the contents, as is the case for vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
1761
diff
changeset
|
284 (Assert (/= (sxhash '(1 2 3)) (sxhash '(3 2 1)))) |