Add Sacla to the repository.

1 files changed, 696 insertions, 0 deletions

diff --git a/Sacla/tests/must-hash-table.lisp b/Sacla/tests/must-hash-table.lisp
new file mode 100644
index 0000000..d3c1e0c
--- /dev/null
+++ b/Sacla/tests/must-hash-table.lisp
@@ -0,0 +1,696 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: must-hash-table.lisp,v 1.8 2004/08/09 02:49:54 yuji Exp $
+;; 
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;; 
+;;  * Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;;  * Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in
+;;    the documentation and/or other materials provided with the
+;;    distribution.
+;; 
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(let ((table (make-hash-table)))
+  (and (hash-table-p table)
+       (eql (setf (gethash "one" table) 1) 1)
+       (equal (multiple-value-list (gethash (copy-seq "one") table))
+	      '(NIL NIL))))
+
+(let ((table (make-hash-table :test 'equal)))
+  (and (hash-table-p table)
+       (eql (setf (gethash "one" table) 1) 1)
+       (equal (multiple-value-list (gethash (copy-seq "one") table))
+	      '(1 T))))
+
+(make-hash-table :rehash-size 1.5 :rehash-threshold 0.7)
+
+(make-hash-table)
+(hash-table-p (make-hash-table))
+#-CLISP ; Bruno: unfounded expectations about hash-table-test
+(dolist (test '(eq eql equal equalp) t)
+  (let ((hash-table (make-hash-table :test test)))
+    (unless (and (hash-table-p hash-table)
+                 (eq (hash-table-test hash-table) test))
+      (return nil))))
+#-CLISP ; Bruno: unfounded expectations about hash-table-test
+(dolist (test '(eq eql equal equalp) t)
+  (let* ((test-function (symbol-function test))
+         (hash-table (make-hash-table :test test-function)))
+    (unless (and (hash-table-p hash-table)
+		 (eq (hash-table-test hash-table) test))
+      (return nil))))
+
+(hash-table-p (make-hash-table :size 0))
+(hash-table-p (make-hash-table :size 1))
+(hash-table-p (make-hash-table :size 2))
+(hash-table-p (make-hash-table :size 3))
+(hash-table-p (make-hash-table :size 1000))
+(hash-table-p (make-hash-table :rehash-size 1))
+(hash-table-p (make-hash-table :rehash-size 100))
+(hash-table-p (make-hash-table :rehash-size 1.5))
+#-clisp (hash-table-p (make-hash-table :rehash-size 1.0))
+(hash-table-p (make-hash-table :rehash-threshold 0))
+(hash-table-p (make-hash-table :rehash-threshold 0.0))
+(hash-table-p (make-hash-table :rehash-threshold 0.1))
+(hash-table-p (make-hash-table :rehash-threshold 0.12))
+(hash-table-p (make-hash-table :rehash-threshold 0.5))
+(hash-table-p (make-hash-table :rehash-threshold 2/3))
+(hash-table-p (make-hash-table :rehash-threshold 0.888))
+(hash-table-p (make-hash-table :rehash-threshold 0.99))
+(hash-table-p (make-hash-table :rehash-threshold 1))
+(hash-table-p (make-hash-table :rehash-threshold 1.0))
+
+(let ((table (make-hash-table :size 0 :rehash-size 1.1 :rehash-threshold 0)))
+  (and (dotimes (i 10 t)
+	 (setf (gethash i table) i))
+       (dotimes (i 10 t)
+	 (unless (eql (gethash i table) i)
+	   (return nil)))
+       (hash-table-p table)))
+
+(let ((table (make-hash-table :size 1 :rehash-size 1 :rehash-threshold 1)))
+  (and (dotimes (i 100 t)
+	 (setf (gethash i table) i))
+       (dotimes (i 100 t)
+	 (unless (eql (gethash i table) i)
+	   (return nil)))
+       (hash-table-p table)))
+
+
+
+(not (hash-table-p 'hash-table))
+
+(let ((table (make-hash-table)))
+  (hash-table-p table))
+(not (hash-table-p 37))
+(not (hash-table-p '((a . 1) (b . 2))))
+(not (hash-table-p (type-of (make-hash-table))))
+
+
+(let ((table (make-hash-table)))
+  (and (zerop (hash-table-count table))
+       (equal (setf (gethash 57 table) "fifty-seven") "fifty-seven")
+       (eql (hash-table-count table) 1)
+       (dotimes (i 100 t) (setf (gethash i table) i))
+       (eql (hash-table-count table) 100)))
+
+(zerop (hash-table-count (make-hash-table)))
+(let ((table (make-hash-table)))
+  (and (eql (setf (gethash 'key table) 9) 9)
+       (= (hash-table-count table) 1)))
+
+
+#-CLISP ;Bruno: unfounded expectations about hash-table-rehash-size
+(let ((table (make-hash-table :size 100 :rehash-size 1.4)))
+  (= (hash-table-rehash-size table) 1.4))
+
+#-CLISP ;Bruno: unfounded expectations about hash-table-rehash-threshold
+(let ((table (make-hash-table :size 100 :rehash-threshold 0.5)))
+  (= (hash-table-rehash-threshold table) 0.5))
+
+(<= 0 (hash-table-size (make-hash-table)))
+
+#-CLISP ;Bruno: unfounded expectations about hash-table-test
+(eq 'eq (hash-table-test (make-hash-table :test 'eq)))
+#-CLISP ;Bruno: unfounded expectations about hash-table-test
+(eq 'eq (hash-table-test (make-hash-table :test #'eq)))
+#-CLISP ;Bruno: unfounded expectations about hash-table-test
+(eq 'eql (hash-table-test (make-hash-table)))
+#-CLISP ;Bruno: unfounded expectations about hash-table-test
+(eq 'eql (hash-table-test (make-hash-table :test 'eql)))
+#-CLISP ;Bruno: unfounded expectations about hash-table-test
+(eq 'eql (hash-table-test (make-hash-table :test #'eql)))
+#-CLISP ;Bruno: unfounded expectations about hash-table-test
+(eq 'equal (hash-table-test (make-hash-table :test 'equal)))
+#-CLISP ;Bruno: unfounded expectations about hash-table-test
+(eq 'equal (hash-table-test (make-hash-table :test #'equal)))
+#-CLISP ;Bruno: unfounded expectations about hash-table-test
+(eq 'equalp (hash-table-test (make-hash-table :test 'equalp)))
+#-CLISP ;Bruno: unfounded expectations about hash-table-test
+(eq 'equalp (hash-table-test (make-hash-table :test #'equalp)))
+
+(let* ((table0 (make-hash-table))
+       (table  (make-hash-table
+		:size (hash-table-size table0)
+		:test (hash-table-test table0)
+		:rehash-threshold (hash-table-rehash-threshold table0)
+		:rehash-size (hash-table-rehash-size table0))))
+  (and (hash-table-p table)
+       (zerop (hash-table-count table))
+       (eq (type-of table) 'hash-table)))
+
+
+(let ((table (make-hash-table)))
+  (and (equal (multiple-value-list (gethash 1 table)) '(NIL NIL))
+       (equal (multiple-value-list (gethash 1 table 2)) '(2 nil))
+       (equal (setf (gethash 1 table) "one") "one")
+       (equal (setf (gethash 2 table "two") "two") "two")
+       (multiple-value-bind (value present-p) (gethash 1 table)
+	 (and (equal value "one") present-p))
+       (multiple-value-bind (value present-p) (gethash 2 table)
+	 (and (equal value "two") present-p))
+       (equal (multiple-value-list (gethash nil table)) '(nil nil))
+       (null (setf (gethash nil table) nil))
+       (multiple-value-bind (value present-p) (gethash nil table)
+	 (and (not value) present-p))))
+
+(multiple-value-bind (value present-p)
+    (gethash 'key (make-hash-table) 'default)
+  (and (eq value 'default) (not present-p)))
+
+(multiple-value-bind (value present-p)
+    (gethash 'key (make-hash-table))
+  (and (null value) (not present-p)))
+
+
+(let ((table (make-hash-table)))
+  (and (multiple-value-bind (value present-p) (gethash 'key table)
+	 (and (null value) (not present-p)))
+       (eql (setf (gethash 'key table) 100) 100)
+       (multiple-value-bind (value present-p) (gethash 'key table)
+	 (and (eql value 100) present-p))))
+
+(let ((table (make-hash-table))
+      (list nil))
+  (and (eql (setf (gethash (progn (push 0 list) 0)
+			   (progn (push 1 list) table)
+			   (progn (push 2 list) 'default))
+		  (progn (push 3 list) 9))
+	    9)
+       (equal list '(3 2 1 0))))
+
+(let ((table (make-hash-table)))
+  (and (dotimes (i 100 t)
+	 (unless (eql (setf (gethash i table) (* i 10)) (* i 10))
+	   (return nil)))
+       (= (hash-table-count table) 100)
+       (dotimes (i 100 t)
+	 (unless (multiple-value-bind (value present-p) (gethash i table)
+		   (and (eql value (* i 10)) present-p))
+	   (return nil)))))
+
+
+(let ((table (make-hash-table)))
+  (and (equal (setf (gethash 100 table) "C") "C")
+       (multiple-value-bind (value present-p) (gethash 100 table)
+	 (and (equal value "C") present-p))
+       (remhash 100 table)
+       (multiple-value-bind (value present-p) (gethash 100 table)
+	 (and (not value) (not present-p)))
+       (not (remhash 100 table))))
+
+(let ((table (make-hash-table)))
+  (and (zerop (hash-table-count table))
+       (eql (setf (gethash 'a table) 'abc) 'abc)
+       (multiple-value-bind (value present-p) (gethash 'a table)
+	 (and (eq value 'abc) present-p))
+       (eql (hash-table-count table) 1)
+       (remhash 'a table)
+       (multiple-value-bind (value present-p) (gethash 'a table)
+	 (and (not value) (not present-p)))
+       (zerop (hash-table-count table))))
+
+(not (remhash 'key (make-hash-table)))
+
+
+(with-hash-table-iterator (iterator (make-hash-table))
+  (macrolet ((test (&environment env)
+	       (if (macro-function 'iterator env) t nil)))
+    (test)))
+
+
+(let ((table (make-hash-table))
+      (alist nil))
+  (dotimes (i 10) (setf (gethash i table) i))
+  (with-hash-table-iterator (iterator table)
+    (loop
+     (multiple-value-bind (more key value) (iterator)
+       (unless more
+	 (return))
+       (push (list key value) alist))))
+  (setq alist (sort alist #'< :key #'car))
+  (equal alist '((0 0) (1 1) (2 2) (3 3) (4 4) (5 5) (6 6) (7 7) (8 8) (9 9))))
+
+
+(let ((table (make-hash-table))
+      (eval 0))
+  (dotimes (i 10) (setf (gethash i table) i))
+  (with-hash-table-iterator (iterator (progn (incf eval) table))
+    (loop
+     (multiple-value-bind (more key value) (iterator)
+       (declare (ignore key value))
+       (unless more
+	 (return)))))
+  (eql eval 1))
+
+
+(with-hash-table-iterator (iterator (make-hash-table))
+  (null (iterator)))
+
+
+(let ((table (make-hash-table))
+      alist0 alist1 alist2)
+  (dotimes (i 100) (setf (gethash i table) i))
+  (and (with-hash-table-iterator (iterator0 table)
+	 (with-hash-table-iterator (iterator1 table)
+	   (with-hash-table-iterator (iterator2 table)
+	     (loop
+              (multiple-value-bind (more0 key0 value0) (iterator0)
+		(multiple-value-bind (more1 key1 value1) (iterator1)
+		  (multiple-value-bind (more2 key2 value2) (iterator2)
+		    (unless (or (every #'null (list more0 more1 more2))
+				(every #'identity (list more0 more1 more2)))
+		      (return nil))
+		    (when (every #'null (list more0 more1 more2))
+		      (return t))
+		    (push (cons key0 value0) alist0)
+		    (push (cons key1 value1) alist1)
+		    (push (cons key2 value2) alist2))))))))
+       (equal (sort alist0 #'< :key #'car)
+	      (setq alist1 (sort alist1 #'< :key #'car)))
+       (equal alist1 (sort alist2 #'< :key #'car))))
+       
+
+
+(let ((table (make-hash-table :rehash-size 100))
+      (n 0)
+      (alist nil))
+  (and (dolist (key '(a b c d e f g h i j k) t)
+	 (unless (eql (setf (gethash key table) n) n)
+	   (return nil))
+	 (incf n))
+       (remhash 'b table)
+       (remhash 'd table)
+       (remhash 'f table)
+       (remhash 'h table)
+       (remhash 'j table)
+       (not (remhash 'b table))
+       (not (remhash 'd table))
+       (not (remhash 'f table))
+       (not (remhash 'h table))
+       (not (remhash 'j table))
+       (with-hash-table-iterator (iterator table)
+         (loop
+	  (multiple-value-bind (more key value) (iterator)
+	    (unless more
+	      (return t))
+	    (push (cons key value) alist))))
+       (equal (sort alist #'< :key #'cdr)
+	      '((a . 0) (c . 2) (e . 4) (g . 6) (i . 8) (k . 10)))))
+
+
+(let ((table (make-hash-table)))
+  (and (null (dotimes (i 10) (setf (gethash i table) i)))
+       (eql (let ((sum-of-squares 0))
+	      (maphash #'(lambda (key val) 
+			   (let ((square (* val val)))
+			     (incf sum-of-squares square)
+			     (setf (gethash key table) square)))
+		       table)
+	      sum-of-squares)
+	    285)
+       (eql (hash-table-count table) 10)
+       (null (maphash #'(lambda (key val)
+			  (when (oddp val) (remhash key table)))
+		      table))
+       (eql (hash-table-count table) 5)
+       (let ((alist nil))
+	 (and (null (maphash #'(lambda (key val)
+				 (push (list key val) alist))
+			     table))
+	      (equalp (sort alist #'< :key #'car)
+		      '((0 0) (2 4) (4 16) (6 36) (8 64)))))))
+
+
+(let ((table (make-hash-table))
+      (alist nil))
+  (and (null (dotimes (i 10) (setf (gethash i table) i)))
+       (null (maphash #'(lambda (key val)
+			  (if (evenp key)
+			      (setf (gethash key table) (* val val))
+			    (remhash key table)))
+		      table))
+       (null (maphash #'(lambda (key val) (push (cons key val) alist)) table))
+       (equal (sort alist #'< :key #'car)
+	      '((0 . 0) (2 . 4) (4 . 16) (6 . 36) (8 . 64)))))
+
+
+
+(flet ((test-hash-table-iterator (hash-table)
+         (let ((all-entries '())
+	       (generated-entries '())
+	       (unique (list nil)))
+	   (maphash #'(lambda (key value) (push (list key value) all-entries))
+		    hash-table)
+	   (with-hash-table-iterator (generator-fn hash-table)
+	     (loop     
+	      (multiple-value-bind (more? key value) (generator-fn)
+		(unless more? (return))
+		(unless (eql value (gethash key hash-table unique))
+		  (error "Key ~S not found for value ~S" key value))
+		(push (list key value) generated-entries))))
+	   (unless (= (length all-entries)
+		      (length generated-entries)
+		      (length (union all-entries generated-entries
+				     :key #'car
+				     :test (hash-table-test hash-table))))
+	     (error "Generated entries and Maphash entries don't correspond"))
+	   t)))
+  (let ((table (make-hash-table :rehash-size 100))
+	(n 0))
+    (and (dolist (key '(a b c d e f g h i j k) t)
+	   (unless (eql (setf (gethash key table) n) n)
+	     (return nil))
+	   (incf n))
+	 (remhash 'b table)
+	 (remhash 'd table)
+	 (remhash 'f table)
+	 (remhash 'h table)
+	 (remhash 'j table)
+	 (not (remhash 'b table))
+	 (not (remhash 'd table))
+	 (not (remhash 'f table))
+	 (not (remhash 'h table))
+	 (not (remhash 'j table))
+	 (test-hash-table-iterator table)
+	 (test-hash-table-iterator (make-hash-table)))))
+
+
+
+
+(let ((table (make-hash-table)))
+  (and (null (dotimes (i 100) (setf (gethash i table) (format nil "~R" i))))
+       (eql (hash-table-count table) 100)
+       (multiple-value-bind (value present-p) (gethash 57 table)
+	 (and (equal value "fifty-seven") present-p))
+       (hash-table-p (clrhash table))
+       (zerop (hash-table-count table))
+       (multiple-value-bind (value present-p) (gethash 57 table)
+	 (and (null value) (not present-p)))))
+
+
+(let ((code (sxhash 'a)))
+  (and (typep code 'fixnum)
+       (<= 0 code)))
+
+(dolist (item '(a "" #\a (make-hash-table) (make-array '(2 3 4)) #*0101 "xx") t)
+  (let ((code (sxhash item)))
+    (unless (and (typep code 'fixnum) (<= 0 code))
+      (return nil))))
+
+
+
+(let ((table (make-hash-table :rehash-threshold 0.8)))
+  (and (eql (setf (gethash 'key table) 'value0) 'value0)
+       (eql (hash-table-count table) 1)
+       (eql (setf (gethash 'key table) 'value1) 'value1)
+       (eql (hash-table-count table) 1)
+       (eq (gethash 'key table) 'value1)))
+
+(let ((table (make-hash-table :rehash-threshold 0.8)))
+  (and (eql (setf (gethash 'key0 table) 'value0) 'value0)
+       (eql (hash-table-count table) 1)
+       (eql (setf (gethash 'key1 table) 'value1) 'value1)
+       (eql (hash-table-count table) 2)
+       (eql (setf (gethash 'key2 table) 'value2) 'value2)
+       (eql (hash-table-count table) 3)
+       (eql (setf (gethash 'key0 table) 'value00) 'value00)
+       (eql (hash-table-count table) 3)
+       (eql (setf (gethash 'key2 table) 'value22) 'value22)
+       (eql (hash-table-count table) 3)
+       (eq (gethash 'key0 table) 'value00)
+       (eq (gethash 'key1 table) 'value1)
+       (eq (gethash 'key2 table) 'value22)))
+
+
+(let ((table (make-hash-table :size 0 :test 'eq))
+      (key0 (copy-seq "key"))
+      (key1 (copy-seq "key")))
+  (and (not (eq key0 key1))
+       (eq (setf (gethash key0 table) 'value) 'value)
+       (multiple-value-bind (value present-p) (gethash key1 table)
+	 (and (null value) (not present-p)))
+       (multiple-value-bind (value present-p) (gethash key0 table)
+	 (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 0 :test 'eql))
+      (key0 (copy-seq "key"))
+      (key1 (copy-seq "key")))
+  (and (not (eql key0 key1))
+       (eq (setf (gethash key0 table) 'value) 'value)
+       (multiple-value-bind (value present-p) (gethash key1 table)
+	 (and (null value) (not present-p)))
+       (multiple-value-bind (value present-p) (gethash key0 table)
+	 (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 0 :test 'eql))
+      (key0 1.0)
+      (key1 1.0))
+  (and (eql key0 key1)
+       (eq (setf (gethash key0 table) 'value) 'value)
+       (multiple-value-bind (value present-p) (gethash key1 table)
+	 (and (eq value 'value) present-p))
+       (multiple-value-bind (value present-p) (gethash key0 table)
+	 (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 0 :test 'eql))
+      (key0 #\a)
+      (key1 #\a))
+  (and (eql key0 key1)
+       (eq (setf (gethash key0 table) 'value) 'value)
+       (multiple-value-bind (value present-p) (gethash key1 table)
+	 (and (eq value 'value) present-p))
+       (multiple-value-bind (value present-p) (gethash key0 table)
+	 (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 0 :test 'eql))
+      (key0 #\a)
+      (key1 #\A))
+  (and (not (eql key0 key1))
+       (eq (setf (gethash key0 table) 'value) 'value)
+       (multiple-value-bind (value present-p) (gethash key1 table)
+	 (and (null value) (not present-p)))
+       (multiple-value-bind (value present-p) (gethash key0 table)
+	 (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 16 :test 'equal))
+      (key0 'key)
+      (key1 'key))
+  (and (eq key0 key1)
+       (equal key0 key1)
+       (eq (setf (gethash key0 table) 'value) 'value)
+       (multiple-value-bind (value present-p) (gethash key1 table)
+	 (and (eq value 'value) present-p))
+       (multiple-value-bind (value present-p) (gethash key0 table)
+	 (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 0 :test 'equal))
+      (key0 1.0)
+      (key1 1.0))
+  (and (equal key0 key1)
+       (eq (setf (gethash key0 table) 'value) 'value)
+       (multiple-value-bind (value present-p) (gethash key1 table)
+	 (and (eq value 'value) present-p))
+       (multiple-value-bind (value present-p) (gethash key0 table)
+	 (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 0 :test 'equal))
+      (key0 #\a)
+      (key1 #\a))
+  (and (equal key0 key1)
+       (eq (setf (gethash key0 table) 'value) 'value)
+       (multiple-value-bind (value present-p) (gethash key1 table)
+	 (and (eq value 'value) present-p))
+       (multiple-value-bind (value present-p) (gethash key0 table)
+	 (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 0 :test 'equal))
+      (key0 #\a)
+      (key1 #\A))
+  (and (not (equal key0 key1))
+       (eq (setf (gethash key0 table) 'value) 'value)
+       (multiple-value-bind (value present-p) (gethash key1 table)
+	 (and (null value) (not present-p)))
+       (multiple-value-bind (value present-p) (gethash key0 table)
+	 (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 16 :test 'equal))
+      (key0 (copy-seq "key"))
+      (key1 (copy-seq "key")))
+  (and (not (eq key0 key1))
+       (equal key0 key1)
+       (eq (setf (gethash key0 table) 'value) 'value)
+       (multiple-value-bind (value present-p) (gethash key1 table)
+	 (and (eq value 'value) present-p))
+       (multiple-value-bind (value present-p) (gethash key0 table)
+	 (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 16 :test 'equal))
+      (key0 (copy-seq "key"))
+      (key1 (copy-seq "KEY")))
+  (and (not (eq key0 key1))
+       (not (equal key0 key1))
+       (eq (setf (gethash key0 table) 'value) 'value)
+       (multiple-value-bind (value present-p) (gethash key1 table)
+	 (and (null value) (not present-p)))
+       (multiple-value-bind (value present-p) (gethash key0 table)
+	 (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 10 :test 'equal))
+      (key0 (copy-seq '(key)))
+      (key1 (copy-seq '(key))))
+  (and (not (eq key0 key1))
+       (equal key0 key1)
+       (eq (setf (gethash key0 table) 'value) 'value)
+       (multiple-value-bind (value present-p) (gethash key1 table)
+	 (and (eq value 'value) present-p))
+       (multiple-value-bind (value present-p) (gethash key0 table)
+	 (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 16 :test 'equal))
+      (key0 (copy-seq #*1010))
+      (key1 (copy-seq #*1010)))
+  (and (not (eq key0 key1))
+       (equal key0 key1)
+       (eq (setf (gethash key0 table) 'value) 'value)
+       (multiple-value-bind (value present-p) (gethash key1 table)
+	 (and (eq value 'value) present-p))
+       (multiple-value-bind (value present-p) (gethash key0 table)
+	 (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 16 :test 'equal))
+      (key0 (copy-seq #(a b c)))
+      (key1 (copy-seq #(a b c))))
+  (and (not (eq key0 key1))
+       (not (equal key0 key1))
+       (eq (setf (gethash key0 table) 'value) 'value)
+       (multiple-value-bind (value present-p) (gethash key1 table)
+	 (and (null value) (not present-p)))
+       (multiple-value-bind (value present-p) (gethash key0 table)
+	 (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 10 :test 'equal))
+      (key0 (make-pathname))
+      (key1 (make-pathname)))
+  (and (not (eq key0 key1))
+       (equal key0 key1)
+       (eq (setf (gethash key0 table) 'value) 'value)
+       (multiple-value-bind (value present-p) (gethash key1 table)
+	 (and (eq value 'value) present-p))
+       (multiple-value-bind (value present-p) (gethash key0 table)
+	 (and (eq value 'value) present-p))))
+
+
+(let ((table (make-hash-table :size 0 :test 'equalp))
+      (key0 (copy-seq "key"))
+      (key1 (copy-seq "key")))
+  (and (equalp key0 key1)
+       (eq (setf (gethash key0 table) 'value) 'value)
+       (multiple-value-bind (value present-p) (gethash key1 table)
+	 (and (eq value 'value) present-p))
+       (multiple-value-bind (value present-p) (gethash key0 table)
+	 (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 0 :test 'equalp))
+      (key0 1.0)
+      (key1 1.0))
+  (and (equalp key0 key1)
+       (eq (setf (gethash key0 table) 'value) 'value)
+       (multiple-value-bind (value present-p) (gethash key1 table)
+	 (and (eq value 'value) present-p))
+       (multiple-value-bind (value present-p) (gethash key0 table)
+	 (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 100 :test 'equalp))
+      (key0 1)
+      (key1 1.0))
+  (and (not (eq key0 key1))
+       (equalp key0 key1)
+       (eq (setf (gethash key0 table) 'value) 'value)
+       (multiple-value-bind (value present-p) (gethash key1 table)
+	 (and (eq value 'value) present-p))
+       (multiple-value-bind (value present-p) (gethash key0 table)
+	 (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 0 :test 'equalp))
+      (key0 #\a)
+      (key1 #\a))
+  (and (equalp key0 key1)
+       (eq (setf (gethash key0 table) 'value) 'value)
+       (multiple-value-bind (value present-p) (gethash key1 table)
+	 (and (eq value 'value) present-p))
+       (multiple-value-bind (value present-p) (gethash key0 table)
+	 (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 10 :test 'equalp))
+      (key0 #\a)
+      (key1 #\A))
+  (and (not (eq key0 key1))
+       (equalp key0 key1)
+       (eq (setf (gethash key0 table) 'value) 'value)
+       (multiple-value-bind (value present-p) (gethash key1 table)
+	 (and (eq value 'value) present-p))
+       (multiple-value-bind (value present-p) (gethash key0 table)
+	 (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 3 :test 'equalp))
+      (key0 (copy-seq '(#\a)))
+      (key1 (copy-seq '(#\A))))
+  (and (not (eq key0 key1))
+       (equalp key0 key1)
+       (eq (setf (gethash key0 table) 'value) 'value)
+       (multiple-value-bind (value present-p) (gethash key1 table)
+	 (and (eq value 'value) present-p))
+       (multiple-value-bind (value present-p) (gethash key0 table)
+	 (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :size 3 :test 'equalp))
+      (key0 (copy-seq '(#\a (1))))
+      (key1 (copy-seq '(#\A (1.0)))))
+  (and (not (eq key0 key1))
+       (equalp key0 key1)
+       (eq (setf (gethash key0 table) 'value) 'value)
+       (multiple-value-bind (value present-p) (gethash key1 table)
+	 (and (eq value 'value) present-p))
+       (multiple-value-bind (value present-p) (gethash key0 table)
+	 (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table :test 'equalp))
+      (key0 (make-hash-table))
+      (key1 (make-hash-table)))
+  (and (not (eq key0 key1))
+       (equalp key0 key1)
+       (eq (setf (gethash key0 table) 'value) 'value)
+       (multiple-value-bind (value present-p) (gethash key1 table)
+	 (and (eq value 'value) present-p))
+       (multiple-value-bind (value present-p) (gethash key0 table)
+	 (and (eq value 'value) present-p))))
+
+(let ((table (make-hash-table)))
+  (and (zerop (hash-table-count table))
+       (dolist (pair '((a abc) (a bc) (1 "one") (1.0 "ONE") (#\a a) (#\A b)) t)
+	 (unless (eq (setf (gethash (car pair) table) (cadr pair)) (cadr pair))
+	   (return nil)))
+       (eql (hash-table-count table) 5)
+       (eq (gethash 'a table) 'bc)
+       (equal (gethash 1 table) "one")
+       (equal (gethash 1.0 table) "ONE")
+       (eql (gethash #\A table) 'b)
+       (eql (gethash #\a table) 'a)))
+