Update of /cvsroot/sbcl/sbcl/tests
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv28702/tests
Modified Files:
hash.impure.lisp
Log Message:
1.0.28.63: SB-EXT:DEFINE-HASH-TABLE-TEST
* Based on old SB-INT:DEFINE-HASH-TABLE-TEST, but:
** macro, not a function.
** only two arguments: name of the test function, and the hash function
(which can also be a lambda form.)
** :TEST accepts both 'NAME, and #'NAME as well.
** pick up redefinitions of the test and hash-function without
re-executing the D-H-T-T form.
** protected by package locks.
* MAKE-HASH-TABLE :HASH-FUNCTION supported as well. EQ-based hashing
not legal for user-provided hash functions, accidents prevented by
wrapping functions which may return a true secondary value in
a closure.
* Documentation -- other hash-table extensions as well.
* Documentation generation improvements:
** use the shortest package name available -- CL:FOO, not
COMMON-LISP:FOO.
** kludge around texi2pdf making &key and company bold
** add exceptions so that we don't format words ANSI and CLHS
as lowecase symbols.
Index: hash.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/hash.impure.lisp,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -d -r1.13 -r1.14
--- hash.impure.lisp 26 May 2008 18:27:17 -0000 1.13
+++ hash.impure.lisp 21 May 2009 09:56:16 -0000 1.14
@@ -391,4 +391,65 @@
)
+;;; DEFINE-HASH-TABLE-TEST
+
+(defstruct custom-hash-key name)
+(defun custom-hash-test (x y)
+ (equal (custom-hash-key-name x)
+ (custom-hash-key-name y)))
+(defun custom-hash-hash (x)
+ (sxhash (custom-hash-key-name x)))
+(define-hash-table-test custom-hash-test custom-hash-hash)
+(with-test (:name define-hash-table-test.1)
+ (let ((table (make-hash-table :test 'custom-hash-test)))
+ (setf (gethash (make-custom-hash-key :name "foo") table) :foo)
+ (setf (gethash (make-custom-hash-key :name "bar") table) :bar)
+ (assert (eq :foo (gethash (make-custom-hash-key :name "foo") table)))
+ (assert (eq :bar (gethash (make-custom-hash-key :name "bar") table)))
+ (assert (eq 'custom-hash-test (hash-table-test table))))
+ (let ((table (make-hash-table :test #'custom-hash-test)))
+ (setf (gethash (make-custom-hash-key :name "foo") table) :foo)
+ (setf (gethash (make-custom-hash-key :name "bar") table) :bar)
+ (assert (eq :foo (gethash (make-custom-hash-key :name "foo") table)))
+ (assert (eq :bar (gethash (make-custom-hash-key :name "bar") table)))
+ (assert (eq 'custom-hash-test (hash-table-test table)))))
+
+
+(defun head-eql (x y)
+ (every #'eql (subseq x 0 3) (subseq y 0 3)))
+(define-hash-table-test head-eql
+ (lambda (x)
+ (logand most-positive-fixnum
+ (reduce #'+ (map 'list #'sxhash (subseq x 0 3))))))
+(with-test (:name define-hash-table-test.2)
+ (let ((table (make-hash-table :test 'head-eql)))
+ (setf (gethash #(1 2 3 4) table) :|123|)
+ (setf (gethash '(2 3 4 7) table) :|234|)
+ (setf (gethash "foobar" table) :foo)
+ (assert (eq :|123| (gethash '(1 2 3 ! 6) table)))
+ (assert (eq :|234| (gethash #(2 3 4 0 2 1 a) table)))
+ (assert (eq :foo (gethash '(#\f #\o #\o 1 2 3) table)))
+ (assert (eq 'head-eql (hash-table-test table))))
+ (let ((table (make-hash-table :test #'head-eql)))
+ (setf (gethash #(1 2 3 4) table) :|123|)
+ (setf (gethash '(2 3 4 7) table) :|234|)
+ (setf (gethash "foobar" table) :foo)
+ (assert (eq :|123| (gethash '(1 2 3 ! 6) table)))
+ (assert (eq :|234| (gethash #(2 3 4 0 2 1 a) table)))
+ (assert (eq :foo (gethash '(#\f #\o #\o 1 2 3) table)))
+ (assert (eq 'head-eql (hash-table-test table)))))
+
+(with-test (:name make-hash-table/hash-fun)
+ (let ((table (make-hash-table
+ :test #'=
+ :hash-function (lambda (x)
+ (sxhash (coerce (abs x) 'double-float))))))
+ (incf (gethash 1 table 0))
+ (incf (gethash 1.0f0 table))
+ (incf (gethash 1.0d0 table))
+ (incf (gethash (complex 1.0f0 0.0f0) table))
+ (incf (gethash (complex 1.0d0 0.0d0) table))
+ (assert (= 5 (gethash 1 table)))
+ (assert (eq '= (hash-table-test table)))))
+
;;; success
|