;;; This test works reliably on non-conservative platforms and
;;; somewhat reliably on conservative platforms with threads.
-#+(or (not (or x86 x86-64)) sb-thread)
(progn
(defparameter *ht* nil)
(defvar *cons-here*)
+(declaim (notinline args))
+(defun take (&rest args)
+ (declare (ignore args)))
+
(defmacro alloc (&body body)
"Execute BODY and try to reduce the chance of leaking a conservative root."
#-sb-thread
(sem (gensym)))
`(let ((,sem (sb-thread::make-semaphore))
,values)
- (sb-thread:make-thread (lambda ()
- (setq ,values
- (multiple-value-list (progn ,@body)))
- (sb-thread::signal-semaphore ,sem)))
+ (make-join-thread (lambda ()
+ (setq ,values
+ (multiple-value-list (progn ,@body)))
+ (sb-thread::signal-semaphore ,sem)))
(sb-thread::wait-on-semaphore ,sem)
(values-list ,values))))
-(defun take (&rest args)
- (declare (ignore args)))
-
-(with-test (:name (:hash-table :weakness :eql :numbers))
+(with-test (:name (:hash-table :weakness :eql :numbers) :skipped-on '(and :c-stack-is-control-stack (not :sb-thread)))
(flet ((random-number ()
(random 1000)))
(loop for weakness in '(nil :key :value :key-and-value :key-or-value) do
(format stream "Hash: ~S~%" (sb-impl::hash-table-hash-vector ht))
(force-output stream))
-(with-test (:name (:hash-table :weakness :removal))
+(with-test (:name (:hash-table :weakness :removal) :skipped-on '(and :c-stack-is-control-stack (not :sb-thread)))
(loop for test in '(eq eql equal equalp) do
(format t "test: ~A~%" test)
(loop for weakness in '(:key :value :key-and-value :key-or-value)
(return)))
(gc :full t))))))
-(with-test (:name (:hash-table :weakness :string-interning))
+(with-test (:name (:hash-table :weakness :string-interning) :skipped-on '(and :c-stack-is-control-stack (not :sb-thread)))
(let ((ht (make-hash-table :test 'equal :weakness :key))
(s "a"))
(setf (gethash s ht) s)
(assert (eq (gethash (copy-seq s) ht) s))))
;;; see if hash_vector is not written when there is none ...
-(with-test (:name (:hash-table :weakness :eq))
+(with-test (:name (:hash-table :weakness :eq) :skipped-on '(and :c-stack-is-control-stack (not :sb-thread)))
(loop repeat 10 do
(let ((index (random 2000)))
(let ((first (+ most-positive-fixnum (mod (* index 31) 9)))
hash-table)))))
;; used to crash in gc
-(with-test (:name (:hash-table :weakness :keep))
+(with-test (:name (:hash-table :weakness :keep) :skipped-on '(and :c-stack-is-control-stack (not :sb-thread)))
(loop repeat 2 do
(let ((h1 (make-hash-table :weakness :key :test #'equal))
(keep ()))
)
+;;; 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