1 /* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2003, 2004, 2006,
2 * 2008, 2009, 2010, 2011, 2012, 2013 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),
528 (void *) SCM_UNPACK (key
), dflt
);
530 return scm_hash_fn_ref (table
, key
, dflt
,
531 (scm_t_hash_fn
) scm_ihashv
,
532 (scm_t_assoc_fn
) scm_sloppy_assv
,
539 SCM_DEFINE (scm_hashv_set_x
, "hashv-set!", 3, 0, 0,
540 (SCM table
, SCM key
, SCM val
),
541 "Find the entry in @var{table} associated with @var{key}, and\n"
542 "store @var{value} there. Uses @code{eqv?} for equality testing.")
543 #define FUNC_NAME s_scm_hashv_set_x
545 if (SCM_WEAK_TABLE_P (table
))
547 scm_c_weak_table_put_x (table
, scm_ihashv (key
, -1),
548 assv_predicate
, (void *) SCM_UNPACK (key
),
553 return scm_hash_fn_set_x (table
, key
, val
,
554 (scm_t_hash_fn
) scm_ihashv
,
555 (scm_t_assoc_fn
) scm_sloppy_assv
,
561 SCM_DEFINE (scm_hashv_remove_x
, "hashv-remove!", 2, 0, 0,
562 (SCM table
, SCM key
),
563 "Remove @var{key} (and any value associated with it) from\n"
564 "@var{table}. Uses @code{eqv?} for equality tests.")
565 #define FUNC_NAME s_scm_hashv_remove_x
567 if (SCM_WEAK_TABLE_P (table
))
569 scm_c_weak_table_remove_x (table
, scm_ihashv (key
, -1),
570 assv_predicate
, (void *) SCM_UNPACK (key
));
571 /* See note in hashq-remove!. */
575 return scm_hash_fn_remove_x (table
, key
,
576 (scm_t_hash_fn
) scm_ihashv
,
577 (scm_t_assoc_fn
) scm_sloppy_assv
,
584 SCM_DEFINE (scm_hash_get_handle
, "hash-get-handle", 2, 0, 0,
585 (SCM table
, SCM key
),
586 "This procedure returns the @code{(key . value)} pair from the\n"
587 "hash table @var{table}. If @var{table} does not hold an\n"
588 "associated value for @var{key}, @code{#f} is returned.\n"
589 "Uses @code{equal?} for equality testing.")
590 #define FUNC_NAME s_scm_hash_get_handle
592 return scm_hash_fn_get_handle (table
, key
,
593 (scm_t_hash_fn
) scm_ihash
,
594 (scm_t_assoc_fn
) scm_sloppy_assoc
,
600 SCM_DEFINE (scm_hash_create_handle_x
, "hash-create-handle!", 3, 0, 0,
601 (SCM table
, SCM key
, SCM init
),
602 "This function looks up @var{key} in @var{table} and returns its handle.\n"
603 "If @var{key} is not already present, a new handle is created which\n"
604 "associates @var{key} with @var{init}.")
605 #define FUNC_NAME s_scm_hash_create_handle_x
607 return scm_hash_fn_create_handle_x (table
, key
, init
,
608 (scm_t_hash_fn
) scm_ihash
,
609 (scm_t_assoc_fn
) scm_sloppy_assoc
,
616 assoc_predicate (SCM k
, SCM v
, void *closure
)
618 return scm_is_true (scm_equal_p (k
, SCM_PACK_POINTER (closure
)));
621 SCM_DEFINE (scm_hash_ref
, "hash-ref", 2, 1, 0,
622 (SCM table
, SCM key
, SCM dflt
),
623 "Look up @var{key} in the hash table @var{table}, and return the\n"
624 "value (if any) associated with it. If @var{key} is not found,\n"
625 "return @var{dflt} (or @code{#f} if no @var{dflt} argument\n"
626 "is supplied). Uses @code{equal?} for equality testing.")
627 #define FUNC_NAME s_scm_hash_ref
629 if (SCM_UNBNDP (dflt
))
632 if (SCM_WEAK_TABLE_P (table
))
633 return scm_c_weak_table_ref (table
, scm_ihash (key
, -1),
635 (void *) SCM_UNPACK (key
), dflt
);
637 return scm_hash_fn_ref (table
, key
, dflt
,
638 (scm_t_hash_fn
) scm_ihash
,
639 (scm_t_assoc_fn
) scm_sloppy_assoc
,
646 SCM_DEFINE (scm_hash_set_x
, "hash-set!", 3, 0, 0,
647 (SCM table
, SCM key
, SCM val
),
648 "Find the entry in @var{table} associated with @var{key}, and\n"
649 "store @var{val} there. Uses @code{equal?} for equality\n"
651 #define FUNC_NAME s_scm_hash_set_x
653 if (SCM_WEAK_TABLE_P (table
))
655 scm_c_weak_table_put_x (table
, scm_ihash (key
, -1),
656 assoc_predicate
, (void *) SCM_UNPACK (key
),
661 return scm_hash_fn_set_x (table
, key
, val
,
662 (scm_t_hash_fn
) scm_ihash
,
663 (scm_t_assoc_fn
) scm_sloppy_assoc
,
670 SCM_DEFINE (scm_hash_remove_x
, "hash-remove!", 2, 0, 0,
671 (SCM table
, SCM key
),
672 "Remove @var{key} (and any value associated with it) from\n"
673 "@var{table}. Uses @code{equal?} for equality tests.")
674 #define FUNC_NAME s_scm_hash_remove_x
676 if (SCM_WEAK_TABLE_P (table
))
678 scm_c_weak_table_remove_x (table
, scm_ihash (key
, -1),
679 assoc_predicate
, (void *) SCM_UNPACK (key
));
680 /* See note in hashq-remove!. */
684 return scm_hash_fn_remove_x (table
, key
,
685 (scm_t_hash_fn
) scm_ihash
,
686 (scm_t_assoc_fn
) scm_sloppy_assoc
,
694 typedef struct scm_t_ihashx_closure
699 } scm_t_ihashx_closure
;
702 scm_ihashx (SCM obj
, unsigned long n
, void *arg
)
705 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
706 answer
= scm_call_2 (closure
->hash
, obj
, scm_from_ulong (n
));
707 return scm_to_ulong (answer
);
711 scm_sloppy_assx (SCM obj
, SCM alist
, void *arg
)
713 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
714 return scm_call_2 (closure
->assoc
, obj
, alist
);
718 assx_predicate (SCM k
, SCM v
, void *closure
)
720 scm_t_ihashx_closure
*c
= (scm_t_ihashx_closure
*) closure
;
722 /* FIXME: The hashx interface is crazy. Hash tables have nothing to
723 do with alists in principle. Instead of getting an assoc proc,
724 hashx functions should use an equality predicate. Perhaps we can
725 change this before 2.2, but until then, add a terrible, terrible
728 return scm_is_true (scm_call_2 (c
->assoc
, c
->key
, scm_acons (k
, v
, SCM_EOL
)));
732 SCM_DEFINE (scm_hashx_get_handle
, "hashx-get-handle", 4, 0, 0,
733 (SCM hash
, SCM assoc
, SCM table
, SCM key
),
734 "This behaves the same way as the corresponding\n"
735 "@code{-get-handle} function, but uses @var{hash} as a hash\n"
736 "function and @var{assoc} to compare keys. @code{hash} must be\n"
737 "a function that takes two arguments, a key to be hashed and a\n"
738 "table size. @code{assoc} must be an associator function, like\n"
739 "@code{assoc}, @code{assq} or @code{assv}.")
740 #define FUNC_NAME s_scm_hashx_get_handle
742 scm_t_ihashx_closure closure
;
744 closure
.assoc
= assoc
;
747 return scm_hash_fn_get_handle (table
, key
, scm_ihashx
, scm_sloppy_assx
,
753 SCM_DEFINE (scm_hashx_create_handle_x
, "hashx-create-handle!", 5, 0, 0,
754 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM init
),
755 "This behaves the same way as the corresponding\n"
756 "@code{-create-handle} function, but uses @var{hash} as a hash\n"
757 "function and @var{assoc} to compare keys. @code{hash} must be\n"
758 "a function that takes two arguments, a key to be hashed and a\n"
759 "table size. @code{assoc} must be an associator function, like\n"
760 "@code{assoc}, @code{assq} or @code{assv}.")
761 #define FUNC_NAME s_scm_hashx_create_handle_x
763 scm_t_ihashx_closure closure
;
765 closure
.assoc
= assoc
;
768 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashx
,
769 scm_sloppy_assx
, (void *)&closure
);
775 SCM_DEFINE (scm_hashx_ref
, "hashx-ref", 4, 1, 0,
776 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM dflt
),
777 "This behaves the same way as the corresponding @code{ref}\n"
778 "function, but uses @var{hash} as a hash function and\n"
779 "@var{assoc} to compare keys. @code{hash} must be a function\n"
780 "that takes two arguments, a key to be hashed and a table size.\n"
781 "@code{assoc} must be an associator function, like @code{assoc},\n"
782 "@code{assq} or @code{assv}.\n"
784 "By way of illustration, @code{hashq-ref table key} is\n"
785 "equivalent to @code{hashx-ref hashq assq table key}.")
786 #define FUNC_NAME s_scm_hashx_ref
788 scm_t_ihashx_closure closure
;
789 if (SCM_UNBNDP (dflt
))
792 closure
.assoc
= assoc
;
795 if (SCM_WEAK_TABLE_P (table
))
797 unsigned long h
= scm_to_ulong (scm_call_2 (hash
, key
,
798 scm_from_ulong (-1)));
799 return scm_c_weak_table_ref (table
, h
, assx_predicate
, &closure
, dflt
);
802 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashx
, scm_sloppy_assx
,
810 SCM_DEFINE (scm_hashx_set_x
, "hashx-set!", 5, 0, 0,
811 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM val
),
812 "This behaves the same way as the corresponding @code{set!}\n"
813 "function, but uses @var{hash} as a hash function and\n"
814 "@var{assoc} to compare keys. @code{hash} must be a function\n"
815 "that takes two arguments, a key to be hashed and a table size.\n"
816 "@code{assoc} must be an associator function, like @code{assoc},\n"
817 "@code{assq} or @code{assv}.\n"
819 " By way of illustration, @code{hashq-set! table key} is\n"
820 "equivalent to @code{hashx-set! hashq assq table key}.")
821 #define FUNC_NAME s_scm_hashx_set_x
823 scm_t_ihashx_closure closure
;
825 closure
.assoc
= assoc
;
828 if (SCM_WEAK_TABLE_P (table
))
830 unsigned long h
= scm_to_ulong (scm_call_2 (hash
, key
,
831 scm_from_ulong (-1)));
832 scm_c_weak_table_put_x (table
, h
, assx_predicate
, &closure
, key
, val
);
836 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashx
, scm_sloppy_assx
,
841 SCM_DEFINE (scm_hashx_remove_x
, "hashx-remove!", 4, 0, 0,
842 (SCM hash
, SCM assoc
, SCM table
, SCM obj
),
843 "This behaves the same way as the corresponding @code{remove!}\n"
844 "function, but uses @var{hash} as a hash function and\n"
845 "@var{assoc} to compare keys. @code{hash} must be a function\n"
846 "that takes two arguments, a key to be hashed and a table size.\n"
847 "@code{assoc} must be an associator function, like @code{assoc},\n"
848 "@code{assq} or @code{assv}.\n"
850 " By way of illustration, @code{hashq-remove! table key} is\n"
851 "equivalent to @code{hashx-remove! hashq assq #f table key}.")
852 #define FUNC_NAME s_scm_hashx_remove_x
854 scm_t_ihashx_closure closure
;
856 closure
.assoc
= assoc
;
859 if (SCM_WEAK_TABLE_P (table
))
861 unsigned long h
= scm_to_ulong (scm_call_2 (hash
, obj
,
862 scm_from_ulong (-1)));
863 scm_c_weak_table_remove_x (table
, h
, assx_predicate
, &closure
);
864 /* See note in hashq-remove!. */
868 return scm_hash_fn_remove_x (table
, obj
, scm_ihashx
, scm_sloppy_assx
,
873 /* Hash table iterators */
875 SCM_DEFINE (scm_hash_fold
, "hash-fold", 3, 0, 0,
876 (SCM proc
, SCM init
, SCM table
),
877 "An iterator over hash-table elements.\n"
878 "Accumulates and returns a result by applying PROC successively.\n"
879 "The arguments to PROC are \"(key value prior-result)\" where key\n"
880 "and value are successive pairs from the hash table TABLE, and\n"
881 "prior-result is either INIT (for the first application of PROC)\n"
882 "or the return value of the previous application of PROC.\n"
883 "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
884 "table into an a-list of key-value pairs.")
885 #define FUNC_NAME s_scm_hash_fold
887 SCM_VALIDATE_PROC (1, proc
);
889 if (SCM_WEAK_TABLE_P (table
))
890 return scm_weak_table_fold (proc
, init
, table
);
892 SCM_VALIDATE_HASHTABLE (3, table
);
893 return scm_internal_hash_fold ((scm_t_hash_fold_fn
) scm_call_3
,
894 (void *) SCM_UNPACK (proc
), init
, table
);
899 for_each_proc (void *proc
, SCM handle
)
901 return scm_call_2 (SCM_PACK (proc
), SCM_CAR (handle
), SCM_CDR (handle
));
904 SCM_DEFINE (scm_hash_for_each
, "hash-for-each", 2, 0, 0,
905 (SCM proc
, SCM table
),
906 "An iterator over hash-table elements.\n"
907 "Applies PROC successively on all hash table items.\n"
908 "The arguments to PROC are \"(key value)\" where key\n"
909 "and value are successive pairs from the hash table TABLE.")
910 #define FUNC_NAME s_scm_hash_for_each
912 SCM_VALIDATE_PROC (1, proc
);
914 if (SCM_WEAK_TABLE_P (table
))
916 scm_weak_table_for_each (proc
, table
);
917 return SCM_UNSPECIFIED
;
920 SCM_VALIDATE_HASHTABLE (2, table
);
922 scm_internal_hash_for_each_handle (for_each_proc
,
923 (void *) SCM_UNPACK (proc
),
925 return SCM_UNSPECIFIED
;
929 SCM_DEFINE (scm_hash_for_each_handle
, "hash-for-each-handle", 2, 0, 0,
930 (SCM proc
, SCM table
),
931 "An iterator over hash-table elements.\n"
932 "Applies PROC successively on all hash table handles.")
933 #define FUNC_NAME s_scm_hash_for_each_handle
935 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)), proc
, 1, FUNC_NAME
);
936 SCM_VALIDATE_HASHTABLE (2, table
);
938 scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn
) scm_call_1
,
939 (void *) SCM_UNPACK (proc
),
941 return SCM_UNSPECIFIED
;
946 map_proc (void *proc
, SCM key
, SCM data
, SCM value
)
948 return scm_cons (scm_call_2 (SCM_PACK (proc
), key
, data
), value
);
951 SCM_DEFINE (scm_hash_map_to_list
, "hash-map->list", 2, 0, 0,
952 (SCM proc
, SCM table
),
953 "An iterator over hash-table elements.\n"
954 "Accumulates and returns as a list the results of applying PROC successively.\n"
955 "The arguments to PROC are \"(key value)\" where key\n"
956 "and value are successive pairs from the hash table TABLE.")
957 #define FUNC_NAME s_scm_hash_map_to_list
959 SCM_VALIDATE_PROC (1, proc
);
961 if (SCM_WEAK_TABLE_P (table
))
962 return scm_weak_table_map_to_list (proc
, table
);
964 SCM_VALIDATE_HASHTABLE (2, table
);
965 return scm_internal_hash_fold (map_proc
,
966 (void *) SCM_UNPACK (proc
),
973 count_proc (void *pred
, SCM key
, SCM data
, SCM value
)
975 if (scm_is_false (scm_call_2 (SCM_PACK (pred
), key
, data
)))
978 return scm_oneplus(value
);
981 SCM_DEFINE (scm_hash_count
, "hash-count", 2, 0, 0,
982 (SCM pred
, SCM table
),
983 "Return the number of elements in the given hash TABLE that\n"
984 "cause `(PRED KEY VALUE)' to return true. To quickly determine\n"
985 "the total number of elements, use `(const #t)' for PRED.")
986 #define FUNC_NAME s_scm_hash_count
990 SCM_VALIDATE_PROC (1, pred
);
991 SCM_VALIDATE_HASHTABLE (2, table
);
993 init
= scm_from_int (0);
994 return scm_internal_hash_fold ((scm_t_hash_fold_fn
) count_proc
,
995 (void *) SCM_UNPACK (pred
), init
, table
);
1002 scm_internal_hash_fold (scm_t_hash_fold_fn fn
, void *closure
,
1003 SCM init
, SCM table
)
1004 #define FUNC_NAME s_scm_hash_fold
1007 SCM buckets
, result
= init
;
1009 if (SCM_WEAK_TABLE_P (table
))
1010 return scm_c_weak_table_fold (fn
, closure
, init
, table
);
1012 SCM_VALIDATE_HASHTABLE (0, table
);
1013 buckets
= SCM_HASHTABLE_VECTOR (table
);
1015 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1016 for (i
= 0; i
< n
; ++i
)
1020 for (ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
); !scm_is_null (ls
);
1023 handle
= SCM_CAR (ls
);
1024 result
= fn (closure
, SCM_CAR (handle
), SCM_CDR (handle
), result
);
1032 /* The following redundant code is here in order to be able to support
1033 hash-for-each-handle. An alternative would have been to replace
1034 this code and scm_internal_hash_fold above with a single
1035 scm_internal_hash_fold_handles, but we don't want to promote such
1039 scm_internal_hash_for_each_handle (scm_t_hash_handle_fn fn
, void *closure
,
1041 #define FUNC_NAME s_scm_hash_for_each
1046 SCM_VALIDATE_HASHTABLE (0, table
);
1047 buckets
= SCM_HASHTABLE_VECTOR (table
);
1048 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1050 for (i
= 0; i
< n
; ++i
)
1052 SCM ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
), handle
;
1053 while (!scm_is_null (ls
))
1055 if (!scm_is_pair (ls
))
1056 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1057 handle
= SCM_CAR (ls
);
1058 if (!scm_is_pair (handle
))
1059 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1060 fn (closure
, handle
);
1073 #include "libguile/hashtab.x"