X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fhash.impure.lisp;h=0c398171460164abb2e5a236fac6c8c2d191f345;hb=a189a69454ef7635149319ae213b337f17c50d20;hp=231939ec3e9036b1bf78859b474b55a68c3bed7e;hpb=1479483c5f40fc470053da0fc5cd8e42fc77676e;p=sbcl.git diff --git a/tests/hash.impure.lisp b/tests/hash.impure.lisp index 231939e..0c39817 100644 --- a/tests/hash.impure.lisp +++ b/tests/hash.impure.lisp @@ -261,13 +261,16 @@ ;;; 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 @@ -281,14 +284,14 @@ (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)))) -(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 @@ -302,9 +305,6 @@ (gc :full t) (assert (= n (hash-table-count ht))))))) -(defun take (&rest args) - (declare (ignore args))) - (defun add-removable-stuff (ht &key (n 100) (size 10)) (flet ((unique-object () (make-array size :fill-pointer 0))) @@ -330,7 +330,7 @@ (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) @@ -357,7 +357,7 @@ (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) @@ -365,7 +365,7 @@ (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))) @@ -376,7 +376,7 @@ 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 ())) @@ -390,4 +390,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