[bpt/guile.git] / test-suite / tests / hash.test

;;;; hash.test --- test guile hashing     -*- scheme -*-
;;;;
;;;; Copyright (C) 2004, 2005, 2006, 2008, 2011, 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite test-numbers)
  #:use-module (test-suite lib)
  #:use-module (ice-9 documentation)
  #:use-module (ice-9 hash-table))

;;;
;;; hash
;;;

(with-test-prefix "hash"
  (pass-if (->bool (object-documentation hash)))
  (pass-if-exception "hash #t -1" exception:out-of-range
    (hash #t -1))
  (pass-if-exception "hash #t 0" exception:out-of-range
    (hash #t 0))
  (pass-if (= 0 (hash #t 1)))
  (pass-if (= 0 (hash #f 1)))
  (pass-if (= 0 (hash noop 1)))
  (pass-if (= 0 (hash +inf.0 1)))
  (pass-if (= 0 (hash -inf.0 1)))
  (pass-if (= 0 (hash +nan.0 1))))

;;;
;;; hashv
;;;

(with-test-prefix "hashv"
  (pass-if (->bool (object-documentation hashv)))
  (pass-if-exception "hashv #t -1" exception:out-of-range
    (hashv #t -1))
  (pass-if-exception "hashv #t 0" exception:out-of-range
    (hashv #t 0))
  (pass-if (= 0 (hashv #t 1)))
  (pass-if (= 0 (hashv #f 1)))
  (pass-if (= 0 (hashv noop 1))))

;;;
;;; hashq
;;;

(with-test-prefix "hashq"
  (pass-if (->bool (object-documentation hashq)))
  (pass-if-exception "hashq #t -1" exception:out-of-range
    (hashq #t -1))
  (pass-if-exception "hashq #t 0" exception:out-of-range
    (hashq #t 0))
  (pass-if (= 0 (hashq #t 1)))
  (pass-if (= 0 (hashq #f 1)))
  (pass-if (= 0 (hashq noop 1))))

;;;
;;; make-hash-table
;;;

(with-test-prefix
 "make-hash-table, hash-table?"
 (pass-if-exception "make-hash-table -1" exception:out-of-range
		    (make-hash-table -1))
 (pass-if (hash-table? (make-hash-table 0))) ;; default
 (pass-if (not (hash-table? 'not-a-hash-table)))
 (pass-if (string-suffix? " 0/113>"
                          (with-output-to-string
                            (lambda ()
                              (write (make-hash-table 100)))))))

;;;
;;; alist->hash-table
;;;

(with-test-prefix
  "alist conversion"

  (pass-if "alist->hash-table"
    (let ((table (alist->hash-table '(("foo" . 1)
                                      ("bar" . 2)
                                      ("foo" . 3)))))
      (and (= (hash-ref table "foo") 1)
           (= (hash-ref table "bar") 2))))

  (pass-if "alist->hashq-table"
    (let ((table (alist->hashq-table '((foo . 1)
                                       (bar . 2)
                                       (foo . 3)))))
      (and (= (hashq-ref table 'foo) 1)
           (= (hashq-ref table 'bar) 2))))

  (pass-if "alist->hashv-table"
    (let ((table (alist->hashv-table '((1 . 1)
                                       (2 . 2)
                                       (1 . 3)))))
      (and (= (hashv-ref table 1) 1)
           (= (hashv-ref table 2) 2))))

  (pass-if "alist->hashx-table"
    (let ((table (alist->hashx-table hash assoc '((foo . 1)
                                                  (bar . 2)
                                                  (foo . 3)))))
      (and (= (hashx-ref hash assoc table 'foo) 1)
           (= (hashx-ref hash assoc table 'bar) 2)))))

;;;
;;; usual set and reference
;;;

(with-test-prefix
 "hash-set and hash-ref"

 ;; auto-resizing
 (pass-if (let ((table (make-hash-table 1))) ;;actually makes size 31
	    (hash-set! table 'one 1)
	    (hash-set! table 'two #t)
	    (hash-set! table 'three #t)
	    (hash-set! table 'four #t)
	    (hash-set! table 'five #t)
	    (hash-set! table 'six #t)
	    (hash-set! table 'seven #t)
	    (hash-set! table 'eight #t)
	    (hash-set! table 'nine 9)
	    (hash-set! table 'ten #t)
	    (hash-set! table 'eleven #t)
	    (hash-set! table 'twelve #t)
	    (hash-set! table 'thirteen #t)
	    (hash-set! table 'fourteen #t)
	    (hash-set! table 'fifteen #t)
	    (hash-set! table 'sixteen #t)
	    (hash-set! table 'seventeen #t)
	    (hash-set! table 18 #t)
	    (hash-set! table 19 #t)
	    (hash-set! table 20 #t)
	    (hash-set! table 21 #t)
	    (hash-set! table 22 #t)
	    (hash-set! table 23 #t)
	    (hash-set! table 24 #t)
	    (hash-set! table 25 #t)
	    (hash-set! table 26 #t)
	    (hash-set! table 27 #t)
	    (hash-set! table 28 #t)
	    (hash-set! table 29 #t)
	    (hash-set! table 30 'thirty)
	    (hash-set! table 31 #t)
	    (hash-set! table 32 #t)
	    (hash-set! table 33 'thirty-three)
	    (hash-set! table 34 #t)
	    (hash-set! table 35 #t)
	    (hash-set! table 'foo 'bar)
	    (and (equal? 1 (hash-ref table 'one)) 
		 (equal? 9 (hash-ref table 'nine)) 
		 (equal? 'thirty (hash-ref table 30))
		 (equal? 'thirty-three (hash-ref table 33))
		 (equal? 'bar (hash-ref table 'foo))
		 (string-suffix? " 36/61>"
                                 (with-output-to-string
                                   (lambda () (write table)))))))

 ;; 1 and 1 are equal? and eqv? (but not necessarily eq?)
 (pass-if (equal? 'foo
		  (let ((table (make-hash-table)))
		    (hash-set! table 1 'foo)
		    (hash-ref table 1))))
 (pass-if (equal? 'foo
		  (let ((table (make-hash-table)))
		    (hashv-set! table 1 'foo)
		    (hashv-ref table 1))))

 ;; 1/2 and 2/4 are equal? and eqv? (but not necessarily eq?)
 (pass-if (equal? 'foo
		  (let ((table (make-hash-table)))
		    (hash-set! table 1/2 'foo)
		    (hash-ref table 2/4))))
 (pass-if (equal? 'foo
		  (let ((table (make-hash-table)))
		    (hashv-set! table 1/2 'foo)
		    (hashv-ref table 2/4))))

 ;; (list 1 2) is equal? but not eqv? or eq? to another (list 1 2)
 (pass-if (equal? 'foo
		  (let ((table (make-hash-table)))
		    (hash-set! table (list 1 2) 'foo)
		    (hash-ref table (list 1 2)))))
 (pass-if (equal? #f
		  (let ((table (make-hash-table)))
		    (hashv-set! table (list 1 2) 'foo)
		    (hashv-ref table (list 1 2)))))
 (pass-if (equal? #f
		  (let ((table (make-hash-table)))
		    (hashq-set! table (list 1 2) 'foo)
		    (hashq-ref table (list 1 2)))))

 ;; ref default argument
 (pass-if (equal? 'bar
		  (let ((table (make-hash-table)))
		    (hash-ref table 'foo 'bar))))
 (pass-if (equal? 'bar
		  (let ((table (make-hash-table)))
		    (hashv-ref table 'foo 'bar))))
 (pass-if (equal? 'bar
		  (let ((table (make-hash-table)))
		    (hashq-ref table 'foo 'bar))))
 (pass-if (equal? 'bar
		  (let ((table (make-hash-table)))
		    (hashx-ref hash equal? table 'foo 'bar))))
 
 ;; wrong type argument
 (pass-if-exception "(hash-ref 'not-a-table 'key)" exception:wrong-type-arg
		    (hash-ref 'not-a-table 'key))
 )

;;;
;;; hashx
;;;

(with-test-prefix
 "auto-resizing hashx"
 ;; auto-resizing
 (let ((table (make-hash-table 1))) ;;actually makes size 31
   (hashx-set! hash assoc table 1/2 'equal)
   (hashx-set! hash assoc table 1/3 'equal)
   (hashx-set! hash assoc table 4 'equal)
   (hashx-set! hash assoc table 1/5 'equal)
   (hashx-set! hash assoc table 1/6 'equal)
   (hashx-set! hash assoc table 7 'equal)
   (hashx-set! hash assoc table 1/8 'equal)
   (hashx-set! hash assoc table 1/9 'equal)
   (hashx-set! hash assoc table 10 'equal)
   (hashx-set! hash assoc table 1/11 'equal)
   (hashx-set! hash assoc table 1/12 'equal)
   (hashx-set! hash assoc table 13 'equal)
   (hashx-set! hash assoc table 1/14 'equal)
   (hashx-set! hash assoc table 1/15 'equal)
   (hashx-set! hash assoc table 16 'equal)
   (hashx-set! hash assoc table 1/17 'equal)
   (hashx-set! hash assoc table 1/18 'equal)
   (hashx-set! hash assoc table 19 'equal)
   (hashx-set! hash assoc table 1/20 'equal)
   (hashx-set! hash assoc table 1/21 'equal)
   (hashx-set! hash assoc table 22 'equal)
   (hashx-set! hash assoc table 1/23 'equal)
   (hashx-set! hash assoc table 1/24 'equal)
   (hashx-set! hash assoc table 25 'equal)
   (hashx-set! hash assoc table 1/26 'equal)
   (hashx-set! hash assoc table 1/27 'equal)
   (hashx-set! hash assoc table 28 'equal)
   (hashx-set! hash assoc table 1/29 'equal)
   (hashx-set! hash assoc table 1/30 'equal)
   (hashx-set! hash assoc table 31 'equal)
   (hashx-set! hash assoc table 1/32 'equal)
   (hashx-set! hash assoc table 1/33 'equal)
   (hashx-set! hash assoc table 34 'equal)
   (pass-if (equal? 'equal (hash-ref table 2/4)))
   (pass-if (equal? 'equal (hash-ref table 2/6)))
   (pass-if (equal? 'equal (hash-ref table 4)))
   (pass-if (equal? 'equal (hashx-ref hash assoc table 2/64)))
   (pass-if (equal? 'equal (hashx-ref hash assoc table 2/66)))
   (pass-if (equal? 'equal (hashx-ref hash assoc table 34)))
   (pass-if (string-suffix? " 33/61>"
                            (with-output-to-string
                              (lambda () (write table)))))))

(with-test-prefix 
 "hashx"
 (pass-if (let ((table (make-hash-table)))
	    (hashx-set! (lambda (k v) 1) 
			(lambda (k al) (assoc 'foo al)) 
			table 'foo 'bar)
	    (equal? 
	     'bar (hashx-ref (lambda (k v) 1) 
			     (lambda (k al) (assoc 'foo al)) 
			     table 'baz))))
 (pass-if (let ((table (make-hash-table 31)))
	    (hashx-set! (lambda (k v) 1) assoc table 'foo 'bar)
	    (equal? #f
		    (hashx-ref (lambda (k v) 2) assoc table 'foo))))
 (pass-if (let ((table (make-hash-table)))
	    (hashx-set! hash assoc table 'foo 'bar)
	    (equal? #f 
		    (hashx-ref hash (lambda (k al) #f) table 'foo))))
 (pass-if-exception 
  "hashx-set! (lambda (k s) 1) equal? table 'foo 'bar"
  exception:wrong-type-arg ;; there must be a better exception than that...
  (hashx-set! (lambda (k s) 1) (lambda (k al) #t) (make-hash-table) 'foo 'bar))
 )


;;;
;;; hashx-remove!
;;;
(with-test-prefix "hashx-remove!"
  (pass-if (->bool (object-documentation hashx-remove!)))

  (pass-if (let ((table (make-hash-table)))
	     (hashx-set! hashq assq table 'x 123)
	     (hashx-remove! hashq assq table 'x)
	     (null? (hash-map->list noop table)))))

;;;
;;; hashx
;;;

(with-test-prefix "hashx"
  (pass-if-exception 
   "hashx-set! (lambda (k s) 1) (lambda (k al) #t) table 'foo 'bar"
   exception:wrong-type-arg
   (hashx-set! (lambda (k s) 1) (lambda (k al) #t) (make-hash-table) 'foo 'bar))
  )


;;;
;;; hash-count
;;;

(with-test-prefix "hash-count"
  (let ((table (make-hash-table)))
    (hashq-set! table 'foo "bar")
    (hashq-set! table 'braz "zonk")
    (hashq-create-handle! table 'frob #f)

    (pass-if (equal? 3 (hash-count (const #t) table)))

    (pass-if (equal? 2 (hash-count (lambda (k v)
                                     (string? v)) table)))))
Commit	Line	Data
40339d6b KR	1	;;;; hash.test --- test guile hashing -- scheme --
40339d6b KR	2	;;;;
73c080f9	3	;;;; Copyright (C) 2004, 2005, 2006, 2008, 2011, 2012 Free Software Foundation, Inc.
40339d6b KR	4	;;;;
	5	;;;; This library is free software; you can redistribute it and/or
	6	;;;; modify it under the terms of the GNU Lesser General Public
	7	;;;; License as published by the Free Software Foundation; either
53befeb7	8	;;;; version 3 of the License, or (at your option) any later version.
40339d6b KR	9	;;;;
	10	;;;; This library is distributed in the hope that it will be useful,
	11	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	12	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	13	;;;; Lesser General Public License for more details.
	14	;;;;
	15	;;;; You should have received a copy of the GNU Lesser General Public
	16	;;;; License along with this library; if not, write to the Free Software
92205699	17	;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
40339d6b KR	18
	19	(define-module (test-suite test-numbers)
	20	#:use-module (test-suite lib)
5063f0a9 DT	21	#:use-module (ice-9 documentation)
5063f0a9 DT	22	#:use-module (ice-9 hash-table))
40339d6b KR	23
	24	;;;
	25	;;; hash
	26	;;;
	27
	28	(with-test-prefix "hash"
	29	(pass-if (->bool (object-documentation hash)))
	30	(pass-if-exception "hash #t -1" exception:out-of-range
	31	(hash #t -1))
	32	(pass-if-exception "hash #t 0" exception:out-of-range
	33	(hash #t 0))
	34	(pass-if (= 0 (hash #t 1)))
	35	(pass-if (= 0 (hash #f 1)))
10483f9e AW	36	(pass-if (= 0 (hash noop 1)))
	37	(pass-if (= 0 (hash +inf.0 1)))
	38	(pass-if (= 0 (hash -inf.0 1)))
	39	(pass-if (= 0 (hash +nan.0 1))))
40339d6b KR	40
	41	;;;
	42	;;; hashv
	43	;;;
	44
	45	(with-test-prefix "hashv"
	46	(pass-if (->bool (object-documentation hashv)))
	47	(pass-if-exception "hashv #t -1" exception:out-of-range
	48	(hashv #t -1))
	49	(pass-if-exception "hashv #t 0" exception:out-of-range
	50	(hashv #t 0))
	51	(pass-if (= 0 (hashv #t 1)))
	52	(pass-if (= 0 (hashv #f 1)))
	53	(pass-if (= 0 (hashv noop 1))))
	54
	55	;;;
	56	;;; hashq
	57	;;;
	58
	59	(with-test-prefix "hashq"
	60	(pass-if (->bool (object-documentation hashq)))
	61	(pass-if-exception "hashq #t -1" exception:out-of-range
	62	(hashq #t -1))
	63	(pass-if-exception "hashq #t 0" exception:out-of-range
	64	(hashq #t 0))
	65	(pass-if (= 0 (hashq #t 1)))
	66	(pass-if (= 0 (hashq #f 1)))
	67	(pass-if (= 0 (hashq noop 1))))
87c08ac0	68
38ff4606 NJ	69	;;;
	70	;;; make-hash-table
	71	;;;
	72
	73	(with-test-prefix
	74	"make-hash-table, hash-table?"
	75	(pass-if-exception "make-hash-table -1" exception:out-of-range
	76	(make-hash-table -1))
	77	(pass-if (hash-table? (make-hash-table 0))) ;; default
	78	(pass-if (not (hash-table? 'not-a-hash-table)))
73c080f9 LC	79	(pass-if (string-suffix? " 0/113>"
	80	(with-output-to-string
	81	(lambda ()
	82	(write (make-hash-table 100)))))))
5063f0a9 DT	83
	84	;;;
	85	;;; alist->hash-table
	86	;;;
	87
	88	(with-test-prefix
	89	"alist conversion"
	90
	91	(pass-if "alist->hash-table"
	92	(let ((table (alist->hash-table '(("foo" . 1)
	93	("bar" . 2)
	94	("foo" . 3)))))
	95	(and (= (hash-ref table "foo") 1)
	96	(= (hash-ref table "bar") 2))))
	97
	98	(pass-if "alist->hashq-table"
	99	(let ((table (alist->hashq-table '((foo . 1)
	100	(bar . 2)
	101	(foo . 3)))))
	102	(and (= (hashq-ref table 'foo) 1)
	103	(= (hashq-ref table 'bar) 2))))
	104
	105	(pass-if "alist->hashv-table"
	106	(let ((table (alist->hashv-table '((1 . 1)
	107	(2 . 2)
	108	(1 . 3)))))
	109	(and (= (hashv-ref table 1) 1)
	110	(= (hashv-ref table 2) 2))))
	111
	112	(pass-if "alist->hashx-table"
	113	(let ((table (alist->hashx-table hash assoc '((foo . 1)
	114	(bar . 2)
	115	(foo . 3)))))
	116	(and (= (hashx-ref hash assoc table 'foo) 1)
	117	(= (hashx-ref hash assoc table 'bar) 2)))))
38ff4606 NJ	118
	119	;;;
	120	;;; usual set and reference
	121	;;;
	122
	123	(with-test-prefix
	124	"hash-set and hash-ref"
	125
	126	;; auto-resizing
	127	(pass-if (let ((table (make-hash-table 1))) ;;actually makes size 31
	128	(hash-set! table 'one 1)
	129	(hash-set! table 'two #t)
	130	(hash-set! table 'three #t)
	131	(hash-set! table 'four #t)
	132	(hash-set! table 'five #t)
	133	(hash-set! table 'six #t)
	134	(hash-set! table 'seven #t)
	135	(hash-set! table 'eight #t)
	136	(hash-set! table 'nine 9)
	137	(hash-set! table 'ten #t)
	138	(hash-set! table 'eleven #t)
	139	(hash-set! table 'twelve #t)
	140	(hash-set! table 'thirteen #t)
	141	(hash-set! table 'fourteen #t)
	142	(hash-set! table 'fifteen #t)
	143	(hash-set! table 'sixteen #t)
	144	(hash-set! table 'seventeen #t)
	145	(hash-set! table 18 #t)
	146	(hash-set! table 19 #t)
	147	(hash-set! table 20 #t)
	148	(hash-set! table 21 #t)
	149	(hash-set! table 22 #t)
	150	(hash-set! table 23 #t)
	151	(hash-set! table 24 #t)
	152	(hash-set! table 25 #t)
	153	(hash-set! table 26 #t)
	154	(hash-set! table 27 #t)
	155	(hash-set! table 28 #t)
	156	(hash-set! table 29 #t)
	157	(hash-set! table 30 'thirty)
	158	(hash-set! table 31 #t)
	159	(hash-set! table 32 #t)
	160	(hash-set! table 33 'thirty-three)
	161	(hash-set! table 34 #t)
	162	(hash-set! table 35 #t)
	163	(hash-set! table 'foo 'bar)
	164	(and (equal? 1 (hash-ref table 'one))
	165	(equal? 9 (hash-ref table 'nine))
	166	(equal? 'thirty (hash-ref table 30))
	167	(equal? 'thirty-three (hash-ref table 33))
	168	(equal? 'bar (hash-ref table 'foo))
73c080f9 LC	169	(string-suffix? " 36/61>"
	170	(with-output-to-string
	171	(lambda () (write table)))))))
38ff4606	172
764246cf	173	;; 1 and 1 are equal? and eqv? (but not necessarily eq?)
38ff4606 NJ	174	(pass-if (equal? 'foo
	175	(let ((table (make-hash-table)))
	176	(hash-set! table 1 'foo)
	177	(hash-ref table 1))))
	178	(pass-if (equal? 'foo
	179	(let ((table (make-hash-table)))
	180	(hashv-set! table 1 'foo)
	181	(hashv-ref table 1))))
38ff4606	182
90a16232	183	;; 1/2 and 2/4 are equal? and eqv? (but not necessarily eq?)
38ff4606 NJ	184	(pass-if (equal? 'foo
	185	(let ((table (make-hash-table)))
	186	(hash-set! table 1/2 'foo)
	187	(hash-ref table 2/4))))
	188	(pass-if (equal? 'foo
	189	(let ((table (make-hash-table)))
	190	(hashv-set! table 1/2 'foo)
	191	(hashv-ref table 2/4))))
38ff4606 NJ	192
	193	;; (list 1 2) is equal? but not eqv? or eq? to another (list 1 2)
	194	(pass-if (equal? 'foo
	195	(let ((table (make-hash-table)))
	196	(hash-set! table (list 1 2) 'foo)
	197	(hash-ref table (list 1 2)))))
	198	(pass-if (equal? #f
	199	(let ((table (make-hash-table)))
	200	(hashv-set! table (list 1 2) 'foo)
	201	(hashv-ref table (list 1 2)))))
	202	(pass-if (equal? #f
	203	(let ((table (make-hash-table)))
	204	(hashq-set! table (list 1 2) 'foo)
	205	(hashq-ref table (list 1 2)))))
	206
	207	;; ref default argument
	208	(pass-if (equal? 'bar
	209	(let ((table (make-hash-table)))
	210	(hash-ref table 'foo 'bar))))
	211	(pass-if (equal? 'bar
	212	(let ((table (make-hash-table)))
	213	(hashv-ref table 'foo 'bar))))
	214	(pass-if (equal? 'bar
	215	(let ((table (make-hash-table)))
	216	(hashq-ref table 'foo 'bar))))
	217	(pass-if (equal? 'bar
	218	(let ((table (make-hash-table)))
	219	(hashx-ref hash equal? table 'foo 'bar))))
	220
	221	;; wrong type argument
	222	(pass-if-exception "(hash-ref 'not-a-table 'key)" exception:wrong-type-arg
	223	(hash-ref 'not-a-table 'key))
	224	)
	225
	226	;;;
	227	;;; hashx
	228	;;;
	229
	230	(with-test-prefix
	231	"auto-resizing hashx"
	232	;; auto-resizing
	233	(let ((table (make-hash-table 1))) ;;actually makes size 31
	234	(hashx-set! hash assoc table 1/2 'equal)
	235	(hashx-set! hash assoc table 1/3 'equal)
	236	(hashx-set! hash assoc table 4 'equal)
	237	(hashx-set! hash assoc table 1/5 'equal)
	238	(hashx-set! hash assoc table 1/6 'equal)
	239	(hashx-set! hash assoc table 7 'equal)
	240	(hashx-set! hash assoc table 1/8 'equal)
	241	(hashx-set! hash assoc table 1/9 'equal)
	242	(hashx-set! hash assoc table 10 'equal)
	243	(hashx-set! hash assoc table 1/11 'equal)
	244	(hashx-set! hash assoc table 1/12 'equal)
	245	(hashx-set! hash assoc table 13 'equal)
	246	(hashx-set! hash assoc table 1/14 'equal)
	247	(hashx-set! hash assoc table 1/15 'equal)
	248	(hashx-set! hash assoc table 16 'equal)
	249	(hashx-set! hash assoc table 1/17 'equal)
	250	(hashx-set! hash assoc table 1/18 'equal)
	251	(hashx-set! hash assoc table 19 'equal)
	252	(hashx-set! hash assoc table 1/20 'equal)
	253	(hashx-set! hash assoc table 1/21 'equal)
	254	(hashx-set! hash assoc table 22 'equal)
	255	(hashx-set! hash assoc table 1/23 'equal)
256	(hashx-set! hash assoc table 1/24 'equal)
257	(hashx-set! hash assoc table 25 'equal)
258	(hashx-set! hash assoc table 1/26 'equal)
259	(hashx-set! hash assoc table 1/27 'equal)
260	(hashx-set! hash assoc table 28 'equal)
261	(hashx-set! hash assoc table 1/29 'equal)
262	(hashx-set! hash assoc table 1/30 'equal)
263	(hashx-set! hash assoc table 31 'equal)
264	(hashx-set! hash assoc table 1/32 'equal)
265	(hashx-set! hash assoc table 1/33 'equal)
266	(hashx-set! hash assoc table 34 'equal)
267	(pass-if (equal? 'equal (hash-ref table 2/4)))
268	(pass-if (equal? 'equal (hash-ref table 2/6)))
269	(pass-if (equal? 'equal (hash-ref table 4)))
270	(pass-if (equal? 'equal (hashx-ref hash assoc table 2/64)))
271	(pass-if (equal? 'equal (hashx-ref hash assoc table 2/66)))
272	(pass-if (equal? 'equal (hashx-ref hash assoc table 34)))
73c080f9 LC	273	(pass-if (string-suffix? " 33/61>"
	274	(with-output-to-string
	275	(lambda () (write table)))))))
38ff4606 NJ	276
	277	(with-test-prefix
	278	"hashx"
	279	(pass-if (let ((table (make-hash-table)))
	280	(hashx-set! (lambda (k v) 1)
	281	(lambda (k al) (assoc 'foo al))
	282	table 'foo 'bar)
	283	(equal?
	284	'bar (hashx-ref (lambda (k v) 1)
	285	(lambda (k al) (assoc 'foo al))
	286	table 'baz))))
	287	(pass-if (let ((table (make-hash-table 31)))
	288	(hashx-set! (lambda (k v) 1) assoc table 'foo 'bar)
	289	(equal? #f
	290	(hashx-ref (lambda (k v) 2) assoc table 'foo))))
	291	(pass-if (let ((table (make-hash-table)))
	292	(hashx-set! hash assoc table 'foo 'bar)
	293	(equal? #f
	294	(hashx-ref hash (lambda (k al) #f) table 'foo))))
	295	(pass-if-exception
	296	"hashx-set! (lambda (k s) 1) equal? table 'foo 'bar"
	297	exception:wrong-type-arg ;; there must be a better exception than that...
	298	(hashx-set! (lambda (k s) 1) (lambda (k al) #t) (make-hash-table) 'foo 'bar))
	299	)
	300
	301
87c08ac0 KR	302	;;;
	303	;;; hashx-remove!
	304	;;;
87c08ac0 KR	305	(with-test-prefix "hashx-remove!"
	306	(pass-if (->bool (object-documentation hashx-remove!)))
	307
	308	(pass-if (let ((table (make-hash-table)))
	309	(hashx-set! hashq assq table 'x 123)
	310	(hashx-remove! hashq assq table 'x)
	311	(null? (hash-map->list noop table)))))
15bd90ea NJ	312
	313	;;;
	314	;;; hashx
	315	;;;
	316
	317	(with-test-prefix "hashx"
	318	(pass-if-exception
	319	"hashx-set! (lambda (k s) 1) (lambda (k al) #t) table 'foo 'bar"
	320	exception:wrong-type-arg
	321	(hashx-set! (lambda (k s) 1) (lambda (k al) #t) (make-hash-table) 'foo 'bar))
	322	)
3330f00f DH	323
	324
	325	;;;
	326	;;; hash-count
	327	;;;
	328
	329	(with-test-prefix "hash-count"
	330	(let ((table (make-hash-table)))
	331	(hashq-set! table 'foo "bar")
	332	(hashq-set! table 'braz "zonk")
	333	(hashq-create-handle! table 'frob #f)
	334
	335	(pass-if (equal? 3 (hash-count (const #t) table)))
	336
	337	(pass-if (equal? 2 (hash-count (lambda (k v)
	338	(string? v)) table)))))