1 /* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2003, 2004, 2006,
2 * 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
30 #include "libguile/_scm.h"
31 #include "libguile/alist.h"
32 #include "libguile/hash.h"
33 #include "libguile/eval.h"
34 #include "libguile/root.h"
35 #include "libguile/vectors.h"
36 #include "libguile/ports.h"
37 #include "libguile/bdw-gc.h"
39 #include "libguile/validate.h"
40 #include "libguile/hashtab.h"
45 /* A hash table is a cell containing a vector of association lists.
47 * Growing or shrinking, with following rehashing, is triggered when
50 * L = N / S (N: number of items in table, S: bucket vector length)
52 * passes an upper limit of 0.9 or a lower limit of 0.25.
54 * The implementation stores the upper and lower number of items which
55 * trigger a resize in the hashtable object.
57 * Possible hash table sizes (primes) are stored in the array
61 static unsigned long hashtable_size
[] = {
62 31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363,
63 224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041
64 #if SIZEOF_SCM_T_BITS > 4
65 /* vector lengths are stored in the first word of vectors, shifted by
66 8 bits for the tc8, so for 32-bit we only get 2^24-1 = 16777215
67 elements. But we allow a few more sizes for 64-bit. */
68 , 28762081, 57524111, 115048217, 230096423, 460192829
72 #define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long))
74 static char *s_hashtable
= "hashtable";
77 make_hash_table (unsigned long k
, const char *func_name
)
81 int i
= 0, n
= k
? k
: 31;
82 while (i
+ 1 < HASHTABLE_SIZE_N
&& n
> hashtable_size
[i
])
84 n
= hashtable_size
[i
];
86 vector
= scm_c_make_vector (n
, SCM_EOL
);
88 t
= scm_gc_malloc_pointerless (sizeof (*t
), s_hashtable
);
89 t
->min_size_index
= t
->size_index
= i
;
92 t
->upper
= 9 * n
/ 10;
94 /* FIXME: we just need two words of storage, not three */
95 return scm_double_cell (scm_tc7_hashtable
, SCM_UNPACK (vector
),
100 scm_i_rehash (SCM table
,
101 scm_t_hash_fn hash_fn
,
103 const char* func_name
)
105 SCM buckets
, new_buckets
;
107 unsigned long old_size
;
108 unsigned long new_size
;
110 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
112 /* rehashing is not triggered when i <= min_size */
113 i
= SCM_HASHTABLE (table
)->size_index
;
116 while (i
> SCM_HASHTABLE (table
)->min_size_index
117 && SCM_HASHTABLE_N_ITEMS (table
) < hashtable_size
[i
] / 4);
121 i
= SCM_HASHTABLE (table
)->size_index
+ 1;
122 if (i
>= HASHTABLE_SIZE_N
)
126 SCM_HASHTABLE (table
)->size_index
= i
;
128 new_size
= hashtable_size
[i
];
129 if (i
<= SCM_HASHTABLE (table
)->min_size_index
)
130 SCM_HASHTABLE (table
)->lower
= 0;
132 SCM_HASHTABLE (table
)->lower
= new_size
/ 4;
133 SCM_HASHTABLE (table
)->upper
= 9 * new_size
/ 10;
134 buckets
= SCM_HASHTABLE_VECTOR (table
);
136 new_buckets
= scm_c_make_vector (new_size
, SCM_EOL
);
138 SCM_SET_HASHTABLE_VECTOR (table
, new_buckets
);
139 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
141 old_size
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
142 for (i
= 0; i
< old_size
; ++i
)
144 SCM ls
, cell
, handle
;
146 ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
);
147 SCM_SIMPLE_VECTOR_SET (buckets
, i
, SCM_EOL
);
149 while (scm_is_pair (ls
))
154 handle
= SCM_CAR (cell
);
157 h
= hash_fn (SCM_CAR (handle
), new_size
, closure
);
159 scm_out_of_range (func_name
, scm_from_ulong (h
));
160 SCM_SETCDR (cell
, SCM_SIMPLE_VECTOR_REF (new_buckets
, h
));
161 SCM_SIMPLE_VECTOR_SET (new_buckets
, h
, cell
);
162 SCM_HASHTABLE_INCREMENT (table
);
169 scm_i_hashtable_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
171 scm_puts_unlocked ("#<hash-table ", port
);
172 scm_uintprint (SCM_UNPACK (exp
), 16, port
);
173 scm_putc (' ', port
);
174 scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp
), 10, port
);
175 scm_putc_unlocked ('/', port
);
176 scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp
)),
178 scm_puts_unlocked (">", port
);
183 scm_c_make_hash_table (unsigned long k
)
185 return make_hash_table (k
, "scm_c_make_hash_table");
188 SCM_DEFINE (scm_make_hash_table
, "make-hash-table", 0, 1, 0,
190 "Make a new abstract hash table object with minimum number of buckets @var{n}\n")
191 #define FUNC_NAME s_scm_make_hash_table
193 return make_hash_table (SCM_UNBNDP (n
) ? 0 : scm_to_ulong (n
), FUNC_NAME
);
197 #define SCM_WEAK_TABLE_P(x) (scm_is_true (scm_weak_table_p (x)))
199 SCM_DEFINE (scm_hash_table_p
, "hash-table?", 1, 0, 0,
201 "Return @code{#t} if @var{obj} is an abstract hash table object.")
202 #define FUNC_NAME s_scm_hash_table_p
204 return scm_from_bool (SCM_HASHTABLE_P (obj
) || SCM_WEAK_TABLE_P (obj
));
210 /* Accessing hash table entries. */
213 scm_hash_fn_get_handle (SCM table
, SCM obj
,
214 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
216 #define FUNC_NAME "scm_hash_fn_get_handle"
221 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
222 buckets
= SCM_HASHTABLE_VECTOR (table
);
224 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
226 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
227 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
228 scm_out_of_range (FUNC_NAME
, scm_from_ulong (k
));
230 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
238 scm_hash_fn_create_handle_x (SCM table
, SCM obj
, SCM init
,
239 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
241 #define FUNC_NAME "scm_hash_fn_create_handle_x"
246 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
247 buckets
= SCM_HASHTABLE_VECTOR (table
);
249 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
250 SCM_MISC_ERROR ("void hashtable", SCM_EOL
);
252 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
253 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
254 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
256 it
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
258 if (scm_is_pair (it
))
260 else if (scm_is_true (it
))
261 scm_wrong_type_arg_msg (NULL
, 0, it
, "a pair");
264 SCM handle
, new_bucket
;
266 handle
= scm_cons (obj
, init
);
267 new_bucket
= scm_cons (handle
, SCM_EOL
);
269 if (!scm_is_eq (SCM_HASHTABLE_VECTOR (table
), buckets
))
271 buckets
= SCM_HASHTABLE_VECTOR (table
);
272 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
273 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
274 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
276 SCM_SETCDR (new_bucket
, SCM_SIMPLE_VECTOR_REF (buckets
, k
));
277 SCM_SIMPLE_VECTOR_SET (buckets
, k
, new_bucket
);
278 SCM_HASHTABLE_INCREMENT (table
);
280 /* Maybe rehash the table. */
281 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
)
282 || SCM_HASHTABLE_N_ITEMS (table
) > SCM_HASHTABLE_UPPER (table
))
283 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
284 return SCM_CAR (new_bucket
);
291 scm_hash_fn_ref (SCM table
, SCM obj
, SCM dflt
,
292 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
295 SCM it
= scm_hash_fn_get_handle (table
, obj
, hash_fn
, assoc_fn
, closure
);
296 if (scm_is_pair (it
))
303 scm_hash_fn_set_x (SCM table
, SCM obj
, SCM val
,
304 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
309 pair
= scm_hash_fn_create_handle_x (table
, obj
, val
,
310 hash_fn
, assoc_fn
, closure
);
312 if (!scm_is_eq (SCM_CDR (pair
), val
))
313 SCM_SETCDR (pair
, val
);
320 scm_hash_fn_remove_x (SCM table
, SCM obj
,
321 scm_t_hash_fn hash_fn
,
322 scm_t_assoc_fn assoc_fn
,
324 #define FUNC_NAME "hash_fn_remove_x"
329 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
331 buckets
= SCM_HASHTABLE_VECTOR (table
);
333 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
336 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
337 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
338 scm_out_of_range (FUNC_NAME
, scm_from_ulong (k
));
340 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
344 SCM_SIMPLE_VECTOR_SET
345 (buckets
, k
, scm_delq_x (h
, SCM_SIMPLE_VECTOR_REF (buckets
, k
)));
346 SCM_HASHTABLE_DECREMENT (table
);
347 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
348 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
354 SCM_DEFINE (scm_hash_clear_x
, "hash-clear!", 1, 0, 0,
356 "Remove all items from @var{table} (without triggering a resize).")
357 #define FUNC_NAME s_scm_hash_clear_x
359 if (SCM_WEAK_TABLE_P (table
))
361 scm_weak_table_clear_x (table
);
362 return SCM_UNSPECIFIED
;
365 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
367 scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table
), SCM_EOL
);
368 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
370 return SCM_UNSPECIFIED
;
376 SCM_DEFINE (scm_hashq_get_handle
, "hashq-get-handle", 2, 0, 0,
377 (SCM table
, SCM key
),
378 "This procedure returns the @code{(key . value)} pair from the\n"
379 "hash table @var{table}. If @var{table} does not hold an\n"
380 "associated value for @var{key}, @code{#f} is returned.\n"
381 "Uses @code{eq?} for equality testing.")
382 #define FUNC_NAME s_scm_hashq_get_handle
384 return scm_hash_fn_get_handle (table
, key
,
385 (scm_t_hash_fn
) scm_ihashq
,
386 (scm_t_assoc_fn
) scm_sloppy_assq
,
392 SCM_DEFINE (scm_hashq_create_handle_x
, "hashq-create-handle!", 3, 0, 0,
393 (SCM table
, SCM key
, SCM init
),
394 "This function looks up @var{key} in @var{table} and returns its handle.\n"
395 "If @var{key} is not already present, a new handle is created which\n"
396 "associates @var{key} with @var{init}.")
397 #define FUNC_NAME s_scm_hashq_create_handle_x
399 return scm_hash_fn_create_handle_x (table
, key
, init
,
400 (scm_t_hash_fn
) scm_ihashq
,
401 (scm_t_assoc_fn
) scm_sloppy_assq
,
407 SCM_DEFINE (scm_hashq_ref
, "hashq-ref", 2, 1, 0,
408 (SCM table
, SCM key
, SCM dflt
),
409 "Look up @var{key} in the hash table @var{table}, and return the\n"
410 "value (if any) associated with it. If @var{key} is not found,\n"
411 "return @var{dflt} (or @code{#f} if no @var{dflt} argument\n"
412 "is supplied). Uses @code{eq?} for equality testing.")
413 #define FUNC_NAME s_scm_hashq_ref
415 if (SCM_UNBNDP (dflt
))
418 if (SCM_WEAK_TABLE_P (table
))
419 return scm_weak_table_refq (table
, key
, dflt
);
421 return scm_hash_fn_ref (table
, key
, dflt
,
422 (scm_t_hash_fn
) scm_ihashq
,
423 (scm_t_assoc_fn
) scm_sloppy_assq
,
430 SCM_DEFINE (scm_hashq_set_x
, "hashq-set!", 3, 0, 0,
431 (SCM table
, SCM key
, SCM val
),
432 "Find the entry in @var{table} associated with @var{key}, and\n"
433 "store @var{val} there. Uses @code{eq?} for equality testing.")
434 #define FUNC_NAME s_scm_hashq_set_x
436 if (SCM_WEAK_TABLE_P (table
))
438 scm_weak_table_putq_x (table
, key
, val
);
442 return scm_hash_fn_set_x (table
, key
, val
,
443 (scm_t_hash_fn
) scm_ihashq
,
444 (scm_t_assoc_fn
) scm_sloppy_assq
,
451 SCM_DEFINE (scm_hashq_remove_x
, "hashq-remove!", 2, 0, 0,
452 (SCM table
, SCM key
),
453 "Remove @var{key} (and any value associated with it) from\n"
454 "@var{table}. Uses @code{eq?} for equality tests.")
455 #define FUNC_NAME s_scm_hashq_remove_x
457 if (SCM_WEAK_TABLE_P (table
))
459 scm_weak_table_remq_x (table
, key
);
460 /* This return value is for historical compatibility with
461 hash-remove!, which returns either the "handle" corresponding
462 to the entry, or #f. Since weak tables don't have handles, we
463 have to return #f. */
467 return scm_hash_fn_remove_x (table
, key
,
468 (scm_t_hash_fn
) scm_ihashq
,
469 (scm_t_assoc_fn
) scm_sloppy_assq
,
477 SCM_DEFINE (scm_hashv_get_handle
, "hashv-get-handle", 2, 0, 0,
478 (SCM table
, SCM key
),
479 "This procedure returns the @code{(key . value)} pair from the\n"
480 "hash table @var{table}. If @var{table} does not hold an\n"
481 "associated value for @var{key}, @code{#f} is returned.\n"
482 "Uses @code{eqv?} for equality testing.")
483 #define FUNC_NAME s_scm_hashv_get_handle
485 return scm_hash_fn_get_handle (table
, key
,
486 (scm_t_hash_fn
) scm_ihashv
,
487 (scm_t_assoc_fn
) scm_sloppy_assv
,
493 SCM_DEFINE (scm_hashv_create_handle_x
, "hashv-create-handle!", 3, 0, 0,
494 (SCM table
, SCM key
, SCM init
),
495 "This function looks up @var{key} in @var{table} and returns its handle.\n"
496 "If @var{key} is not already present, a new handle is created which\n"
497 "associates @var{key} with @var{init}.")
498 #define FUNC_NAME s_scm_hashv_create_handle_x
500 return scm_hash_fn_create_handle_x (table
, key
, init
,
501 (scm_t_hash_fn
) scm_ihashv
,
502 (scm_t_assoc_fn
) scm_sloppy_assv
,
509 assv_predicate (SCM k
, SCM v
, void *closure
)
511 return scm_is_true (scm_eqv_p (k
, SCM_PACK_POINTER (closure
)));
514 SCM_DEFINE (scm_hashv_ref
, "hashv-ref", 2, 1, 0,
515 (SCM table
, SCM key
, SCM dflt
),
516 "Look up @var{key} in the hash table @var{table}, and return the\n"
517 "value (if any) associated with it. If @var{key} is not found,\n"
518 "return @var{dflt} (or @code{#f} if no @var{dflt} argument\n"
519 "is supplied). Uses @code{eqv?} for equality testing.")
520 #define FUNC_NAME s_scm_hashv_ref
522 if (SCM_UNBNDP (dflt
))
525 if (SCM_WEAK_TABLE_P (table
))
526 return scm_c_weak_table_ref (table
, scm_ihashv (key
, -1),
527 assv_predicate
, SCM_PACK (key
), dflt
);
529 return scm_hash_fn_ref (table
, key
, dflt
,
530 (scm_t_hash_fn
) scm_ihashv
,
531 (scm_t_assoc_fn
) scm_sloppy_assv
,
538 SCM_DEFINE (scm_hashv_set_x
, "hashv-set!", 3, 0, 0,
539 (SCM table
, SCM key
, SCM val
),
540 "Find the entry in @var{table} associated with @var{key}, and\n"
541 "store @var{value} there. Uses @code{eqv?} for equality testing.")
542 #define FUNC_NAME s_scm_hashv_set_x
544 if (SCM_WEAK_TABLE_P (table
))
546 scm_c_weak_table_put_x (table
, scm_ihashv (key
, -1),
547 assv_predicate
, SCM_PACK (key
),
552 return scm_hash_fn_set_x (table
, key
, val
,
553 (scm_t_hash_fn
) scm_ihashv
,
554 (scm_t_assoc_fn
) scm_sloppy_assv
,
560 SCM_DEFINE (scm_hashv_remove_x
, "hashv-remove!", 2, 0, 0,
561 (SCM table
, SCM key
),
562 "Remove @var{key} (and any value associated with it) from\n"
563 "@var{table}. Uses @code{eqv?} for equality tests.")
564 #define FUNC_NAME s_scm_hashv_remove_x
566 if (SCM_WEAK_TABLE_P (table
))
568 scm_c_weak_table_remove_x (table
, scm_ihashv (key
, -1),
569 assv_predicate
, SCM_PACK (key
));
570 /* See note in hashq-remove!. */
574 return scm_hash_fn_remove_x (table
, key
,
575 (scm_t_hash_fn
) scm_ihashv
,
576 (scm_t_assoc_fn
) scm_sloppy_assv
,
583 SCM_DEFINE (scm_hash_get_handle
, "hash-get-handle", 2, 0, 0,
584 (SCM table
, SCM key
),
585 "This procedure returns the @code{(key . value)} pair from the\n"
586 "hash table @var{table}. If @var{table} does not hold an\n"
587 "associated value for @var{key}, @code{#f} is returned.\n"
588 "Uses @code{equal?} for equality testing.")
589 #define FUNC_NAME s_scm_hash_get_handle
591 return scm_hash_fn_get_handle (table
, key
,
592 (scm_t_hash_fn
) scm_ihash
,
593 (scm_t_assoc_fn
) scm_sloppy_assoc
,
599 SCM_DEFINE (scm_hash_create_handle_x
, "hash-create-handle!", 3, 0, 0,
600 (SCM table
, SCM key
, SCM init
),
601 "This function looks up @var{key} in @var{table} and returns its handle.\n"
602 "If @var{key} is not already present, a new handle is created which\n"
603 "associates @var{key} with @var{init}.")
604 #define FUNC_NAME s_scm_hash_create_handle_x
606 return scm_hash_fn_create_handle_x (table
, key
, init
,
607 (scm_t_hash_fn
) scm_ihash
,
608 (scm_t_assoc_fn
) scm_sloppy_assoc
,
615 assoc_predicate (SCM k
, SCM v
, void *closure
)
617 return scm_is_true (scm_equal_p (k
, SCM_PACK_POINTER (closure
)));
620 SCM_DEFINE (scm_hash_ref
, "hash-ref", 2, 1, 0,
621 (SCM table
, SCM key
, SCM dflt
),
622 "Look up @var{key} in the hash table @var{table}, and return the\n"
623 "value (if any) associated with it. If @var{key} is not found,\n"
624 "return @var{dflt} (or @code{#f} if no @var{dflt} argument\n"
625 "is supplied). Uses @code{equal?} for equality testing.")
626 #define FUNC_NAME s_scm_hash_ref
628 if (SCM_UNBNDP (dflt
))
631 if (SCM_WEAK_TABLE_P (table
))
632 return scm_c_weak_table_ref (table
, scm_ihash (key
, -1),
633 assoc_predicate
, SCM_PACK (key
), dflt
);
635 return scm_hash_fn_ref (table
, key
, dflt
,
636 (scm_t_hash_fn
) scm_ihash
,
637 (scm_t_assoc_fn
) scm_sloppy_assoc
,
644 SCM_DEFINE (scm_hash_set_x
, "hash-set!", 3, 0, 0,
645 (SCM table
, SCM key
, SCM val
),
646 "Find the entry in @var{table} associated with @var{key}, and\n"
647 "store @var{val} there. Uses @code{equal?} for equality\n"
649 #define FUNC_NAME s_scm_hash_set_x
651 if (SCM_WEAK_TABLE_P (table
))
653 scm_c_weak_table_put_x (table
, scm_ihash (key
, -1),
654 assoc_predicate
, SCM_PACK (key
),
659 return scm_hash_fn_set_x (table
, key
, val
,
660 (scm_t_hash_fn
) scm_ihash
,
661 (scm_t_assoc_fn
) scm_sloppy_assoc
,
668 SCM_DEFINE (scm_hash_remove_x
, "hash-remove!", 2, 0, 0,
669 (SCM table
, SCM key
),
670 "Remove @var{key} (and any value associated with it) from\n"
671 "@var{table}. Uses @code{equal?} for equality tests.")
672 #define FUNC_NAME s_scm_hash_remove_x
674 if (SCM_WEAK_TABLE_P (table
))
676 scm_c_weak_table_remove_x (table
, scm_ihash (key
, -1),
677 assoc_predicate
, SCM_PACK (key
));
678 /* See note in hashq-remove!. */
682 return scm_hash_fn_remove_x (table
, key
,
683 (scm_t_hash_fn
) scm_ihash
,
684 (scm_t_assoc_fn
) scm_sloppy_assoc
,
692 typedef struct scm_t_ihashx_closure
697 } scm_t_ihashx_closure
;
700 scm_ihashx (SCM obj
, unsigned long n
, void *arg
)
703 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
704 answer
= scm_call_2 (closure
->hash
, obj
, scm_from_ulong (n
));
705 return scm_to_ulong (answer
);
709 scm_sloppy_assx (SCM obj
, SCM alist
, void *arg
)
711 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
712 return scm_call_2 (closure
->assoc
, obj
, alist
);
716 assx_predicate (SCM k
, SCM v
, void *closure
)
718 scm_t_ihashx_closure
*c
= (scm_t_ihashx_closure
*) closure
;
720 /* FIXME: The hashx interface is crazy. Hash tables have nothing to
721 do with alists in principle. Instead of getting an assoc proc,
722 hashx functions should use an equality predicate. Perhaps we can
723 change this before 2.2, but until then, add a terrible, terrible
726 return scm_is_true (scm_call_2 (c
->assoc
, c
->key
, scm_acons (k
, v
, SCM_EOL
)));
730 SCM_DEFINE (scm_hashx_get_handle
, "hashx-get-handle", 4, 0, 0,
731 (SCM hash
, SCM assoc
, SCM table
, SCM key
),
732 "This behaves the same way as the corresponding\n"
733 "@code{-get-handle} function, but uses @var{hash} as a hash\n"
734 "function and @var{assoc} to compare keys. @code{hash} must be\n"
735 "a function that takes two arguments, a key to be hashed and a\n"
736 "table size. @code{assoc} must be an associator function, like\n"
737 "@code{assoc}, @code{assq} or @code{assv}.")
738 #define FUNC_NAME s_scm_hashx_get_handle
740 scm_t_ihashx_closure closure
;
742 closure
.assoc
= assoc
;
745 return scm_hash_fn_get_handle (table
, key
, scm_ihashx
, scm_sloppy_assx
,
751 SCM_DEFINE (scm_hashx_create_handle_x
, "hashx-create-handle!", 5, 0, 0,
752 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM init
),
753 "This behaves the same way as the corresponding\n"
754 "@code{-create-handle} function, but uses @var{hash} as a hash\n"
755 "function and @var{assoc} to compare keys. @code{hash} must be\n"
756 "a function that takes two arguments, a key to be hashed and a\n"
757 "table size. @code{assoc} must be an associator function, like\n"
758 "@code{assoc}, @code{assq} or @code{assv}.")
759 #define FUNC_NAME s_scm_hashx_create_handle_x
761 scm_t_ihashx_closure closure
;
763 closure
.assoc
= assoc
;
766 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashx
,
767 scm_sloppy_assx
, (void *)&closure
);
773 SCM_DEFINE (scm_hashx_ref
, "hashx-ref", 4, 1, 0,
774 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM dflt
),
775 "This behaves the same way as the corresponding @code{ref}\n"
776 "function, but uses @var{hash} as a hash function and\n"
777 "@var{assoc} to compare keys. @code{hash} must be a function\n"
778 "that takes two arguments, a key to be hashed and a table size.\n"
779 "@code{assoc} must be an associator function, like @code{assoc},\n"
780 "@code{assq} or @code{assv}.\n"
782 "By way of illustration, @code{hashq-ref table key} is\n"
783 "equivalent to @code{hashx-ref hashq assq table key}.")
784 #define FUNC_NAME s_scm_hashx_ref
786 scm_t_ihashx_closure closure
;
787 if (SCM_UNBNDP (dflt
))
790 closure
.assoc
= assoc
;
793 if (SCM_WEAK_TABLE_P (table
))
795 unsigned long h
= scm_to_ulong (scm_call_2 (hash
, key
,
796 scm_from_ulong (-1)));
797 return scm_c_weak_table_ref (table
, h
, assx_predicate
, &closure
, dflt
);
800 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashx
, scm_sloppy_assx
,
808 SCM_DEFINE (scm_hashx_set_x
, "hashx-set!", 5, 0, 0,
809 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM val
),
810 "This behaves the same way as the corresponding @code{set!}\n"
811 "function, but uses @var{hash} as a hash function and\n"
812 "@var{assoc} to compare keys. @code{hash} must be a function\n"
813 "that takes two arguments, a key to be hashed and a table size.\n"
814 "@code{assoc} must be an associator function, like @code{assoc},\n"
815 "@code{assq} or @code{assv}.\n"
817 " By way of illustration, @code{hashq-set! table key} is\n"
818 "equivalent to @code{hashx-set! hashq assq table key}.")
819 #define FUNC_NAME s_scm_hashx_set_x
821 scm_t_ihashx_closure closure
;
823 closure
.assoc
= assoc
;
826 if (SCM_WEAK_TABLE_P (table
))
828 unsigned long h
= scm_to_ulong (scm_call_2 (hash
, key
,
829 scm_from_ulong (-1)));
830 scm_c_weak_table_put_x (table
, h
, assx_predicate
, &closure
, key
, val
);
834 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashx
, scm_sloppy_assx
,
839 SCM_DEFINE (scm_hashx_remove_x
, "hashx-remove!", 4, 0, 0,
840 (SCM hash
, SCM assoc
, SCM table
, SCM obj
),
841 "This behaves the same way as the corresponding @code{remove!}\n"
842 "function, but uses @var{hash} as a hash function and\n"
843 "@var{assoc} to compare keys. @code{hash} must be a function\n"
844 "that takes two arguments, a key to be hashed and a table size.\n"
845 "@code{assoc} must be an associator function, like @code{assoc},\n"
846 "@code{assq} or @code{assv}.\n"
848 " By way of illustration, @code{hashq-remove! table key} is\n"
849 "equivalent to @code{hashx-remove! hashq assq #f table key}.")
850 #define FUNC_NAME s_scm_hashx_remove_x
852 scm_t_ihashx_closure closure
;
854 closure
.assoc
= assoc
;
857 if (SCM_WEAK_TABLE_P (table
))
859 unsigned long h
= scm_to_ulong (scm_call_2 (hash
, obj
,
860 scm_from_ulong (-1)));
861 scm_c_weak_table_remove_x (table
, h
, assx_predicate
, &closure
);
862 /* See note in hashq-remove!. */
866 return scm_hash_fn_remove_x (table
, obj
, scm_ihashx
, scm_sloppy_assx
,
871 /* Hash table iterators */
873 SCM_DEFINE (scm_hash_fold
, "hash-fold", 3, 0, 0,
874 (SCM proc
, SCM init
, SCM table
),
875 "An iterator over hash-table elements.\n"
876 "Accumulates and returns a result by applying PROC successively.\n"
877 "The arguments to PROC are \"(key value prior-result)\" where key\n"
878 "and value are successive pairs from the hash table TABLE, and\n"
879 "prior-result is either INIT (for the first application of PROC)\n"
880 "or the return value of the previous application of PROC.\n"
881 "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
882 "table into an a-list of key-value pairs.")
883 #define FUNC_NAME s_scm_hash_fold
885 SCM_VALIDATE_PROC (1, proc
);
887 if (SCM_WEAK_TABLE_P (table
))
888 return scm_weak_table_fold (proc
, init
, table
);
890 SCM_VALIDATE_HASHTABLE (3, table
);
891 return scm_internal_hash_fold ((scm_t_hash_fold_fn
) scm_call_3
,
892 (void *) SCM_UNPACK (proc
), init
, table
);
897 for_each_proc (void *proc
, SCM handle
)
899 return scm_call_2 (SCM_PACK (proc
), SCM_CAR (handle
), SCM_CDR (handle
));
902 SCM_DEFINE (scm_hash_for_each
, "hash-for-each", 2, 0, 0,
903 (SCM proc
, SCM table
),
904 "An iterator over hash-table elements.\n"
905 "Applies PROC successively on all hash table items.\n"
906 "The arguments to PROC are \"(key value)\" where key\n"
907 "and value are successive pairs from the hash table TABLE.")
908 #define FUNC_NAME s_scm_hash_for_each
910 SCM_VALIDATE_PROC (1, proc
);
912 if (SCM_WEAK_TABLE_P (table
))
914 scm_weak_table_for_each (proc
, table
);
915 return SCM_UNSPECIFIED
;
918 SCM_VALIDATE_HASHTABLE (2, table
);
920 scm_internal_hash_for_each_handle (for_each_proc
,
921 (void *) SCM_UNPACK (proc
),
923 return SCM_UNSPECIFIED
;
927 SCM_DEFINE (scm_hash_for_each_handle
, "hash-for-each-handle", 2, 0, 0,
928 (SCM proc
, SCM table
),
929 "An iterator over hash-table elements.\n"
930 "Applies PROC successively on all hash table handles.")
931 #define FUNC_NAME s_scm_hash_for_each_handle
933 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)), proc
, 1, FUNC_NAME
);
934 SCM_VALIDATE_HASHTABLE (2, table
);
936 scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn
) scm_call_1
,
937 (void *) SCM_UNPACK (proc
),
939 return SCM_UNSPECIFIED
;
944 map_proc (void *proc
, SCM key
, SCM data
, SCM value
)
946 return scm_cons (scm_call_2 (SCM_PACK (proc
), key
, data
), value
);
949 SCM_DEFINE (scm_hash_map_to_list
, "hash-map->list", 2, 0, 0,
950 (SCM proc
, SCM table
),
951 "An iterator over hash-table elements.\n"
952 "Accumulates and returns as a list the results of applying PROC successively.\n"
953 "The arguments to PROC are \"(key value)\" where key\n"
954 "and value are successive pairs from the hash table TABLE.")
955 #define FUNC_NAME s_scm_hash_map_to_list
957 SCM_VALIDATE_PROC (1, proc
);
959 if (SCM_WEAK_TABLE_P (table
))
960 return scm_weak_table_map_to_list (proc
, table
);
962 SCM_VALIDATE_HASHTABLE (2, table
);
963 return scm_internal_hash_fold (map_proc
,
964 (void *) SCM_UNPACK (proc
),
971 count_proc (void *pred
, SCM key
, SCM data
, SCM value
)
973 if (scm_is_false (scm_call_2 (SCM_PACK (pred
), key
, data
)))
976 return scm_oneplus(value
);
979 SCM_DEFINE (scm_hash_count
, "hash-count", 2, 0, 0,
980 (SCM pred
, SCM table
),
981 "Return the number of elements in the given hash TABLE that\n"
982 "cause `(PRED KEY VALUE)' to return true. To quickly determine\n"
983 "the total number of elements, use `(const #t)' for PRED.")
984 #define FUNC_NAME s_scm_hash_count
988 SCM_VALIDATE_PROC (1, pred
);
989 SCM_VALIDATE_HASHTABLE (2, table
);
991 init
= scm_from_int (0);
992 return scm_internal_hash_fold ((scm_t_hash_fold_fn
) count_proc
,
993 (void *) SCM_UNPACK (pred
), init
, table
);
1000 scm_internal_hash_fold (scm_t_hash_fold_fn fn
, void *closure
,
1001 SCM init
, SCM table
)
1002 #define FUNC_NAME s_scm_hash_fold
1005 SCM buckets
, result
= init
;
1007 if (SCM_WEAK_TABLE_P (table
))
1008 return scm_c_weak_table_fold (fn
, closure
, init
, table
);
1010 SCM_VALIDATE_HASHTABLE (0, table
);
1011 buckets
= SCM_HASHTABLE_VECTOR (table
);
1013 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1014 for (i
= 0; i
< n
; ++i
)
1018 for (ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
); !scm_is_null (ls
);
1021 handle
= SCM_CAR (ls
);
1022 result
= fn (closure
, SCM_CAR (handle
), SCM_CDR (handle
), result
);
1030 /* The following redundant code is here in order to be able to support
1031 hash-for-each-handle. An alternative would have been to replace
1032 this code and scm_internal_hash_fold above with a single
1033 scm_internal_hash_fold_handles, but we don't want to promote such
1037 scm_internal_hash_for_each_handle (scm_t_hash_handle_fn fn
, void *closure
,
1039 #define FUNC_NAME s_scm_hash_for_each
1044 SCM_VALIDATE_HASHTABLE (0, table
);
1045 buckets
= SCM_HASHTABLE_VECTOR (table
);
1046 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1048 for (i
= 0; i
< n
; ++i
)
1050 SCM ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
), handle
;
1051 while (!scm_is_null (ls
))
1053 if (!scm_is_pair (ls
))
1054 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1055 handle
= SCM_CAR (ls
);
1056 if (!scm_is_pair (handle
))
1057 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1058 fn (closure
, handle
);
1071 #include "libguile/hashtab.x"