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 * Weak hash tables use weak pairs in the bucket lists rather than
60 * Possible hash table sizes (primes) are stored in the array
64 static unsigned long hashtable_size
[] = {
65 31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363,
66 224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041
67 #if SIZEOF_SCM_T_BITS > 4
68 /* vector lengths are stored in the first word of vectors, shifted by
69 8 bits for the tc8, so for 32-bit we only get 2^24-1 = 16777215
70 elements. But we allow a few more sizes for 64-bit. */
71 , 28762081, 57524111, 115048217, 230096423, 460192829
75 #define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long))
77 static char *s_hashtable
= "hashtable";
81 /* Helper functions and macros to deal with weak pairs.
83 Weak pairs need to be accessed very carefully since their components can
84 be nullified by the GC when the object they refer to becomes unreachable.
85 Hence the macros and functions below that detect such weak pairs within
86 buckets and remove them. */
89 /* Remove nullified weak pairs from ALIST such that the result contains only
90 valid pairs. Set REMOVED_ITEMS to the number of pairs that have been
93 scm_fixup_weak_alist (SCM alist
, size_t *removed_items
)
101 alist
= SCM_CDR (alist
))
103 SCM pair
= SCM_CAR (alist
);
105 if (SCM_WEAK_PAIR_DELETED_P (pair
))
107 /* Remove from ALIST weak pair PAIR whose car/cdr has been
108 nullified by the GC. */
109 if (scm_is_null (prev
))
110 result
= SCM_CDR (alist
);
112 SCM_SETCDR (prev
, SCM_CDR (alist
));
116 /* Leave PREV unchanged. */
126 vacuum_weak_hash_table (SCM table
)
128 SCM buckets
= SCM_HASHTABLE_VECTOR (table
);
129 unsigned long k
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
130 size_t len
= SCM_HASHTABLE_N_ITEMS (table
);
135 SCM alist
= SCM_SIMPLE_VECTOR_REF (buckets
, k
);
136 alist
= scm_fixup_weak_alist (alist
, &removed
);
137 assert (removed
<= len
);
139 SCM_SIMPLE_VECTOR_SET (buckets
, k
, alist
);
142 SCM_SET_HASHTABLE_N_ITEMS (table
, len
);
146 /* Packed arguments for `do_weak_bucket_fixup'. */
151 size_t removed_items
;
155 do_weak_bucket_fixup (void *data
)
157 struct t_fixup_args
*args
;
160 args
= (struct t_fixup_args
*) data
;
162 args
->bucket
= scm_fixup_weak_alist (args
->bucket
, &args
->removed_items
);
164 for (pair
= args
->bucket
, copy
= args
->bucket_copy
;
166 pair
= SCM_CDR (pair
), copy
+= 2)
168 /* At this point, all weak pairs have been removed. */
169 assert (!SCM_WEAK_PAIR_DELETED_P (SCM_CAR (pair
)));
171 /* Copy the key and value. */
172 copy
[0] = SCM_CAAR (pair
);
173 copy
[1] = SCM_CDAR (pair
);
179 /* Lookup OBJECT in weak hash table TABLE using ASSOC. OBJECT is searched
180 for in the alist that is the BUCKET_INDEXth element of BUCKETS.
181 Optionally update TABLE and rehash it. */
183 weak_bucket_assoc (SCM table
, SCM buckets
, size_t bucket_index
,
184 scm_t_hash_fn hash_fn
,
185 scm_t_assoc_fn assoc
, SCM object
, void *closure
)
188 SCM bucket
, *strong_refs
;
189 struct t_fixup_args args
;
191 bucket
= SCM_SIMPLE_VECTOR_REF (buckets
, bucket_index
);
193 /* Prepare STRONG_REFS as an array large enough to hold all the keys
194 and values in BUCKET. */
195 strong_refs
= alloca (scm_ilength (bucket
) * 2 * sizeof (SCM
));
197 args
.bucket
= bucket
;
198 args
.bucket_copy
= strong_refs
;
200 /* Fixup BUCKET. Do that with the allocation lock held to avoid
201 seeing disappearing links pointing to objects that have already
202 been reclaimed (this happens when the disappearing links that point
203 to it haven't yet been cleared.)
205 The `do_weak_bucket_fixup' call populates STRONG_REFS with a copy
206 of BUCKET's entries after it's been fixed up. Thus, all the
207 entries kept in BUCKET are still reachable when ASSOC sees
209 GC_call_with_alloc_lock (do_weak_bucket_fixup
, &args
);
211 bucket
= args
.bucket
;
212 SCM_SIMPLE_VECTOR_SET (buckets
, bucket_index
, bucket
);
214 result
= assoc (object
, bucket
, closure
);
216 /* If we got a result, it should not have NULL fields. */
217 if (scm_is_pair (result
) && SCM_WEAK_PAIR_DELETED_P (result
))
220 scm_remember_upto_here_1 (strong_refs
);
222 if (args
.removed_items
> 0)
224 /* Update TABLE's item count and optionally trigger a rehash. */
227 assert (SCM_HASHTABLE_N_ITEMS (table
) >= args
.removed_items
);
229 remaining
= SCM_HASHTABLE_N_ITEMS (table
) - args
.removed_items
;
230 SCM_SET_HASHTABLE_N_ITEMS (table
, remaining
);
232 if (remaining
< SCM_HASHTABLE_LOWER (table
))
233 scm_i_rehash (table
, hash_fn
, closure
, "weak_bucket_assoc");
240 /* Packed arguments for `weak_bucket_assoc_by_hash'. */
241 struct assoc_by_hash_data
245 scm_t_hash_predicate_fn predicate
;
249 /* See scm_hash_fn_get_handle_by_hash below. */
251 weak_bucket_assoc_by_hash (void *args
)
253 struct assoc_by_hash_data
*data
= args
;
254 SCM alist
= data
->alist
;
256 for (; scm_is_pair (alist
); alist
= SCM_CDR (alist
))
258 SCM pair
= SCM_CAR (alist
);
260 if (!SCM_WEAK_PAIR_DELETED_P (pair
)
261 && data
->predicate (SCM_CAR (pair
), data
->closure
))
273 make_hash_table (int flags
, unsigned long k
, const char *func_name
)
277 int i
= 0, n
= k
? k
: 31;
278 while (i
+ 1 < HASHTABLE_SIZE_N
&& n
> hashtable_size
[i
])
280 n
= hashtable_size
[i
];
282 /* In both cases, i.e., regardless of whether we are creating a weak hash
283 table, we return a non-weak vector. This is because the vector itself
284 is not weak in the case of a weak hash table: the alist pairs are. */
285 vector
= scm_c_make_vector (n
, SCM_EOL
);
287 t
= scm_gc_malloc_pointerless (sizeof (*t
), s_hashtable
);
288 t
->min_size_index
= t
->size_index
= i
;
291 t
->upper
= 9 * n
/ 10;
295 /* FIXME: we just need two words of storage, not three */
296 return scm_double_cell (scm_tc7_hashtable
, SCM_UNPACK (vector
),
301 scm_i_rehash (SCM table
,
302 scm_t_hash_fn hash_fn
,
304 const char* func_name
)
306 SCM buckets
, new_buckets
;
308 unsigned long old_size
;
309 unsigned long new_size
;
311 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
313 /* rehashing is not triggered when i <= min_size */
314 i
= SCM_HASHTABLE (table
)->size_index
;
317 while (i
> SCM_HASHTABLE (table
)->min_size_index
318 && SCM_HASHTABLE_N_ITEMS (table
) < hashtable_size
[i
] / 4);
322 i
= SCM_HASHTABLE (table
)->size_index
+ 1;
323 if (i
>= HASHTABLE_SIZE_N
)
327 /* Remember HASH_FN for rehash_after_gc, but only when CLOSURE
328 is not needed since CLOSURE can not be guaranteed to be valid
329 after this function returns.
332 SCM_HASHTABLE (table
)->hash_fn
= hash_fn
;
334 SCM_HASHTABLE (table
)->size_index
= i
;
336 new_size
= hashtable_size
[i
];
337 if (i
<= SCM_HASHTABLE (table
)->min_size_index
)
338 SCM_HASHTABLE (table
)->lower
= 0;
340 SCM_HASHTABLE (table
)->lower
= new_size
/ 4;
341 SCM_HASHTABLE (table
)->upper
= 9 * new_size
/ 10;
342 buckets
= SCM_HASHTABLE_VECTOR (table
);
344 new_buckets
= scm_c_make_vector (new_size
, SCM_EOL
);
346 /* When this is a weak hashtable, running the GC might change it.
347 We need to cope with this while rehashing its elements. We do
348 this by first installing the new, empty bucket vector. Then we
349 remove the elements from the old bucket vector and insert them
353 SCM_SET_HASHTABLE_VECTOR (table
, new_buckets
);
354 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
356 old_size
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
357 for (i
= 0; i
< old_size
; ++i
)
359 SCM ls
, cell
, handle
;
361 ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
);
362 SCM_SIMPLE_VECTOR_SET (buckets
, i
, SCM_EOL
);
364 while (scm_is_pair (ls
))
369 handle
= SCM_CAR (cell
);
372 if (SCM_WEAK_PAIR_DELETED_P (handle
))
373 /* HANDLE is a nullified weak pair: skip it. */
376 h
= hash_fn (SCM_CAR (handle
), new_size
, closure
);
378 scm_out_of_range (func_name
, scm_from_ulong (h
));
379 SCM_SETCDR (cell
, SCM_SIMPLE_VECTOR_REF (new_buckets
, h
));
380 SCM_SIMPLE_VECTOR_SET (new_buckets
, h
, cell
);
381 SCM_HASHTABLE_INCREMENT (table
);
388 scm_i_hashtable_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
390 scm_puts ("#<", port
);
391 if (SCM_HASHTABLE_WEAK_KEY_P (exp
))
392 scm_puts ("weak-key-", port
);
393 else if (SCM_HASHTABLE_WEAK_VALUE_P (exp
))
394 scm_puts ("weak-value-", port
);
395 else if (SCM_HASHTABLE_DOUBLY_WEAK_P (exp
))
396 scm_puts ("doubly-weak-", port
);
397 scm_puts ("hash-table ", port
);
398 scm_uintprint (SCM_UNPACK (exp
), 16, port
);
399 scm_putc (' ', port
);
400 scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp
), 10, port
);
401 scm_putc ('/', port
);
402 scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp
)),
404 scm_puts (">", port
);
409 scm_c_make_hash_table (unsigned long k
)
411 return make_hash_table (0, k
, "scm_c_make_hash_table");
414 SCM_DEFINE (scm_make_hash_table
, "make-hash-table", 0, 1, 0,
416 "Make a new abstract hash table object with minimum number of buckets @var{n}\n")
417 #define FUNC_NAME s_scm_make_hash_table
420 return make_hash_table (0, 0, FUNC_NAME
);
422 return make_hash_table (0, scm_to_ulong (n
), FUNC_NAME
);
426 /* The before-gc C hook only runs if GC_set_start_callback is available,
427 so if not, fall back on a finalizer-based implementation. */
429 weak_gc_callback (void **weak
)
432 void (*callback
) (SCM
) = weak
[1];
437 callback (PTR2SCM (val
));
442 #ifdef HAVE_GC_SET_START_CALLBACK
444 weak_gc_hook (void *hook_data
, void *fn_data
, void *data
)
446 if (!weak_gc_callback (fn_data
))
447 scm_c_hook_remove (&scm_before_gc_c_hook
, weak_gc_hook
, fn_data
);
453 weak_gc_finalizer (void *ptr
, void *data
)
455 if (weak_gc_callback (ptr
))
456 GC_REGISTER_FINALIZER_NO_ORDER (ptr
, weak_gc_finalizer
, data
, NULL
, NULL
);
461 scm_c_register_weak_gc_callback (SCM obj
, void (*callback
) (SCM
))
463 void **weak
= GC_MALLOC_ATOMIC (sizeof (void*) * 2);
465 weak
[0] = SCM2PTR (obj
);
466 weak
[1] = (void*)callback
;
467 GC_GENERAL_REGISTER_DISAPPEARING_LINK (weak
, SCM2PTR (obj
));
469 #ifdef HAVE_GC_SET_START_CALLBACK
470 scm_c_hook_add (&scm_before_gc_c_hook
, weak_gc_hook
, weak
, 0);
472 GC_REGISTER_FINALIZER_NO_ORDER (weak
, weak_gc_finalizer
, NULL
, NULL
, NULL
);
476 SCM_DEFINE (scm_make_weak_key_hash_table
, "make-weak-key-hash-table", 0, 1, 0,
478 "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
479 "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n"
480 "Return a weak hash table with @var{size} buckets.\n"
482 "You can modify weak hash tables in exactly the same way you\n"
483 "would modify regular hash tables. (@pxref{Hash Tables})")
484 #define FUNC_NAME s_scm_make_weak_key_hash_table
489 ret
= make_hash_table (SCM_HASHTABLEF_WEAK_CAR
, 0, FUNC_NAME
);
491 ret
= make_hash_table (SCM_HASHTABLEF_WEAK_CAR
,
492 scm_to_ulong (n
), FUNC_NAME
);
494 scm_c_register_weak_gc_callback (ret
, vacuum_weak_hash_table
);
501 SCM_DEFINE (scm_make_weak_value_hash_table
, "make-weak-value-hash-table", 0, 1, 0,
503 "Return a hash table with weak values with @var{size} buckets.\n"
504 "(@pxref{Hash Tables})")
505 #define FUNC_NAME s_scm_make_weak_value_hash_table
510 ret
= make_hash_table (SCM_HASHTABLEF_WEAK_CDR
, 0, FUNC_NAME
);
512 ret
= make_hash_table (SCM_HASHTABLEF_WEAK_CDR
,
513 scm_to_ulong (n
), FUNC_NAME
);
515 scm_c_register_weak_gc_callback (ret
, vacuum_weak_hash_table
);
522 SCM_DEFINE (scm_make_doubly_weak_hash_table
, "make-doubly-weak-hash-table", 0, 1, 0,
524 "Return a hash table with weak keys and values with @var{size}\n"
525 "buckets. (@pxref{Hash Tables})")
526 #define FUNC_NAME s_scm_make_doubly_weak_hash_table
531 ret
= make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
534 ret
= make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
535 scm_to_ulong (n
), FUNC_NAME
);
537 scm_c_register_weak_gc_callback (ret
, vacuum_weak_hash_table
);
544 SCM_DEFINE (scm_hash_table_p
, "hash-table?", 1, 0, 0,
546 "Return @code{#t} if @var{obj} is an abstract hash table object.")
547 #define FUNC_NAME s_scm_hash_table_p
549 return scm_from_bool (SCM_HASHTABLE_P (obj
));
554 SCM_DEFINE (scm_weak_key_hash_table_p
, "weak-key-hash-table?", 1, 0, 0,
556 "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n"
557 "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n"
558 "Return @code{#t} if @var{obj} is the specified weak hash\n"
559 "table. Note that a doubly weak hash table is neither a weak key\n"
560 "nor a weak value hash table.")
561 #define FUNC_NAME s_scm_weak_key_hash_table_p
563 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_KEY_P (obj
));
568 SCM_DEFINE (scm_weak_value_hash_table_p
, "weak-value-hash-table?", 1, 0, 0,
570 "Return @code{#t} if @var{obj} is a weak value hash table.")
571 #define FUNC_NAME s_scm_weak_value_hash_table_p
573 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_VALUE_P (obj
));
578 SCM_DEFINE (scm_doubly_weak_hash_table_p
, "doubly-weak-hash-table?", 1, 0, 0,
580 "Return @code{#t} if @var{obj} is a doubly weak hash table.")
581 #define FUNC_NAME s_scm_doubly_weak_hash_table_p
583 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_DOUBLY_WEAK_P (obj
));
589 /* Accessing hash table entries. */
592 scm_hash_fn_get_handle (SCM table
, SCM obj
,
593 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
595 #define FUNC_NAME "scm_hash_fn_get_handle"
600 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
601 buckets
= SCM_HASHTABLE_VECTOR (table
);
603 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
605 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
606 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
607 scm_out_of_range (FUNC_NAME
, scm_from_ulong (k
));
609 if (SCM_HASHTABLE_WEAK_P (table
))
610 h
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
611 assoc_fn
, obj
, closure
);
613 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
620 /* This procedure implements three optimizations, with respect to the
623 1. For weak tables, it's assumed that calling the predicate in the
624 allocation lock is safe. In practice this means that the predicate
625 cannot call arbitrary scheme functions.
627 2. We don't check for overflow / underflow and rehash.
629 3. We don't actually have to allocate a key -- instead we get the
630 hash value directly. This is useful for, for example, looking up
631 strings in the symbol table.
634 scm_hash_fn_get_handle_by_hash (SCM table
, unsigned long raw_hash
,
635 scm_t_hash_predicate_fn predicate_fn
,
637 #define FUNC_NAME "scm_hash_fn_ref_by_hash"
640 SCM buckets
, alist
, h
= SCM_BOOL_F
;
642 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
643 buckets
= SCM_HASHTABLE_VECTOR (table
);
645 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
648 k
= raw_hash
% SCM_SIMPLE_VECTOR_LENGTH (buckets
);
649 alist
= SCM_SIMPLE_VECTOR_REF (buckets
, k
);
651 if (SCM_HASHTABLE_WEAK_P (table
))
653 struct assoc_by_hash_data args
;
656 args
.ret
= SCM_BOOL_F
;
657 args
.predicate
= predicate_fn
;
658 args
.closure
= closure
;
659 GC_call_with_alloc_lock (weak_bucket_assoc_by_hash
, &args
);
663 for (; scm_is_pair (alist
); alist
= SCM_CDR (alist
))
665 SCM pair
= SCM_CAR (alist
);
666 if (predicate_fn (SCM_CAR (pair
), closure
))
679 scm_hash_fn_create_handle_x (SCM table
, SCM obj
, SCM init
,
680 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
682 #define FUNC_NAME "scm_hash_fn_create_handle_x"
687 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
688 buckets
= SCM_HASHTABLE_VECTOR (table
);
690 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
691 SCM_MISC_ERROR ("void hashtable", SCM_EOL
);
693 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
694 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
695 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
697 if (SCM_HASHTABLE_WEAK_P (table
))
698 it
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
699 assoc_fn
, obj
, closure
);
701 it
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
703 if (scm_is_pair (it
))
705 else if (scm_is_true (it
))
706 scm_wrong_type_arg_msg (NULL
, 0, it
, "a pair");
709 /* When this is a weak hashtable, running the GC can change it.
710 Thus, we must allocate the new cells first and can only then
711 access BUCKETS. Also, we need to fetch the bucket vector
712 again since the hashtable might have been rehashed. This
713 necessitates a new hash value as well.
715 SCM handle
, new_bucket
;
717 if (SCM_HASHTABLE_WEAK_P (table
))
719 /* FIXME: We don't support weak alist vectors. */
720 /* Use a weak cell. */
721 if (SCM_HASHTABLE_DOUBLY_WEAK_P (table
))
722 handle
= scm_doubly_weak_pair (obj
, init
);
723 else if (SCM_HASHTABLE_WEAK_KEY_P (table
))
724 handle
= scm_weak_car_pair (obj
, init
);
726 handle
= scm_weak_cdr_pair (obj
, init
);
729 /* Use a regular, non-weak cell. */
730 handle
= scm_cons (obj
, init
);
732 new_bucket
= scm_cons (handle
, SCM_EOL
);
734 if (!scm_is_eq (SCM_HASHTABLE_VECTOR (table
), buckets
))
736 buckets
= SCM_HASHTABLE_VECTOR (table
);
737 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
738 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
739 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
741 SCM_SETCDR (new_bucket
, SCM_SIMPLE_VECTOR_REF (buckets
, k
));
742 SCM_SIMPLE_VECTOR_SET (buckets
, k
, new_bucket
);
743 SCM_HASHTABLE_INCREMENT (table
);
745 /* Maybe rehash the table. */
746 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
)
747 || SCM_HASHTABLE_N_ITEMS (table
) > SCM_HASHTABLE_UPPER (table
))
748 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
749 return SCM_CAR (new_bucket
);
756 scm_hash_fn_ref (SCM table
, SCM obj
, SCM dflt
,
757 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
760 SCM it
= scm_hash_fn_get_handle (table
, obj
, hash_fn
, assoc_fn
, closure
);
761 if (scm_is_pair (it
))
774 get_weak_cdr (void *data
)
776 struct weak_cdr_data
*d
= data
;
778 if (SCM_WEAK_PAIR_CDR_DELETED_P (d
->pair
))
781 d
->cdr
= SCM_CDR (d
->pair
);
787 weak_pair_cdr (SCM x
)
789 struct weak_cdr_data data
;
792 GC_call_with_alloc_lock (get_weak_cdr
, &data
);
798 scm_hash_fn_set_x (SCM table
, SCM obj
, SCM val
,
799 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
804 pair
= scm_hash_fn_create_handle_x (table
, obj
, val
,
805 hash_fn
, assoc_fn
, closure
);
807 if (!scm_is_eq (SCM_CDR (pair
), val
))
809 if (SCM_UNLIKELY (SCM_HASHTABLE_WEAK_VALUE_P (table
)))
811 /* If the former value was on the heap, we need to unregister
813 SCM prev
= weak_pair_cdr (pair
);
815 SCM_SETCDR (pair
, val
);
817 if (SCM_NIMP (prev
) && !SCM_NIMP (val
))
818 GC_unregister_disappearing_link ((void **) SCM_CDRLOC (pair
));
820 SCM_I_REGISTER_DISAPPEARING_LINK ((void **) SCM_CDRLOC (pair
),
824 SCM_SETCDR (pair
, val
);
832 scm_hash_fn_remove_x (SCM table
, SCM obj
,
833 scm_t_hash_fn hash_fn
,
834 scm_t_assoc_fn assoc_fn
,
836 #define FUNC_NAME "hash_fn_remove_x"
841 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
843 buckets
= SCM_HASHTABLE_VECTOR (table
);
845 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
848 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
849 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
850 scm_out_of_range (FUNC_NAME
, scm_from_ulong (k
));
852 if (SCM_HASHTABLE_WEAK_P (table
))
853 h
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
854 assoc_fn
, obj
, closure
);
856 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
860 SCM_SIMPLE_VECTOR_SET
861 (buckets
, k
, scm_delq_x (h
, SCM_SIMPLE_VECTOR_REF (buckets
, k
)));
862 SCM_HASHTABLE_DECREMENT (table
);
863 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
864 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
870 SCM_DEFINE (scm_hash_clear_x
, "hash-clear!", 1, 0, 0,
872 "Remove all items from @var{table} (without triggering a resize).")
873 #define FUNC_NAME s_scm_hash_clear_x
875 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
877 scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table
), SCM_EOL
);
878 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
880 return SCM_UNSPECIFIED
;
886 SCM_DEFINE (scm_hashq_get_handle
, "hashq-get-handle", 2, 0, 0,
887 (SCM table
, SCM key
),
888 "This procedure returns the @code{(key . value)} pair from the\n"
889 "hash table @var{table}. If @var{table} does not hold an\n"
890 "associated value for @var{key}, @code{#f} is returned.\n"
891 "Uses @code{eq?} for equality testing.")
892 #define FUNC_NAME s_scm_hashq_get_handle
894 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
895 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
897 return scm_hash_fn_get_handle (table
, key
,
898 (scm_t_hash_fn
) scm_ihashq
,
899 (scm_t_assoc_fn
) scm_sloppy_assq
,
905 SCM_DEFINE (scm_hashq_create_handle_x
, "hashq-create-handle!", 3, 0, 0,
906 (SCM table
, SCM key
, SCM init
),
907 "This function looks up @var{key} in @var{table} and returns its handle.\n"
908 "If @var{key} is not already present, a new handle is created which\n"
909 "associates @var{key} with @var{init}.")
910 #define FUNC_NAME s_scm_hashq_create_handle_x
912 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
913 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
915 return scm_hash_fn_create_handle_x (table
, key
, init
,
916 (scm_t_hash_fn
) scm_ihashq
,
917 (scm_t_assoc_fn
) scm_sloppy_assq
,
923 SCM_DEFINE (scm_hashq_ref
, "hashq-ref", 2, 1, 0,
924 (SCM table
, SCM key
, SCM dflt
),
925 "Look up @var{key} in the hash table @var{table}, and return the\n"
926 "value (if any) associated with it. If @var{key} is not found,\n"
927 "return @var{dflt} (or @code{#f} if no @var{dflt} argument\n"
928 "is supplied). Uses @code{eq?} for equality testing.")
929 #define FUNC_NAME s_scm_hashq_ref
931 if (SCM_UNBNDP (dflt
))
933 return scm_hash_fn_ref (table
, key
, dflt
,
934 (scm_t_hash_fn
) scm_ihashq
,
935 (scm_t_assoc_fn
) scm_sloppy_assq
,
942 SCM_DEFINE (scm_hashq_set_x
, "hashq-set!", 3, 0, 0,
943 (SCM table
, SCM key
, SCM val
),
944 "Find the entry in @var{table} associated with @var{key}, and\n"
945 "store @var{val} there. Uses @code{eq?} for equality testing.")
946 #define FUNC_NAME s_scm_hashq_set_x
948 return scm_hash_fn_set_x (table
, key
, val
,
949 (scm_t_hash_fn
) scm_ihashq
,
950 (scm_t_assoc_fn
) scm_sloppy_assq
,
957 SCM_DEFINE (scm_hashq_remove_x
, "hashq-remove!", 2, 0, 0,
958 (SCM table
, SCM key
),
959 "Remove @var{key} (and any value associated with it) from\n"
960 "@var{table}. Uses @code{eq?} for equality tests.")
961 #define FUNC_NAME s_scm_hashq_remove_x
963 return scm_hash_fn_remove_x (table
, key
,
964 (scm_t_hash_fn
) scm_ihashq
,
965 (scm_t_assoc_fn
) scm_sloppy_assq
,
973 SCM_DEFINE (scm_hashv_get_handle
, "hashv-get-handle", 2, 0, 0,
974 (SCM table
, SCM key
),
975 "This procedure returns the @code{(key . value)} pair from the\n"
976 "hash table @var{table}. If @var{table} does not hold an\n"
977 "associated value for @var{key}, @code{#f} is returned.\n"
978 "Uses @code{eqv?} for equality testing.")
979 #define FUNC_NAME s_scm_hashv_get_handle
981 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
982 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
984 return scm_hash_fn_get_handle (table
, key
,
985 (scm_t_hash_fn
) scm_ihashv
,
986 (scm_t_assoc_fn
) scm_sloppy_assv
,
992 SCM_DEFINE (scm_hashv_create_handle_x
, "hashv-create-handle!", 3, 0, 0,
993 (SCM table
, SCM key
, SCM init
),
994 "This function looks up @var{key} in @var{table} and returns its handle.\n"
995 "If @var{key} is not already present, a new handle is created which\n"
996 "associates @var{key} with @var{init}.")
997 #define FUNC_NAME s_scm_hashv_create_handle_x
999 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
1000 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
1002 return scm_hash_fn_create_handle_x (table
, key
, init
,
1003 (scm_t_hash_fn
) scm_ihashv
,
1004 (scm_t_assoc_fn
) scm_sloppy_assv
,
1010 SCM_DEFINE (scm_hashv_ref
, "hashv-ref", 2, 1, 0,
1011 (SCM table
, SCM key
, SCM dflt
),
1012 "Look up @var{key} in the hash table @var{table}, and return the\n"
1013 "value (if any) associated with it. If @var{key} is not found,\n"
1014 "return @var{dflt} (or @code{#f} if no @var{dflt} argument\n"
1015 "is supplied). Uses @code{eqv?} for equality testing.")
1016 #define FUNC_NAME s_scm_hashv_ref
1018 if (SCM_UNBNDP (dflt
))
1020 return scm_hash_fn_ref (table
, key
, dflt
,
1021 (scm_t_hash_fn
) scm_ihashv
,
1022 (scm_t_assoc_fn
) scm_sloppy_assv
,
1029 SCM_DEFINE (scm_hashv_set_x
, "hashv-set!", 3, 0, 0,
1030 (SCM table
, SCM key
, SCM val
),
1031 "Find the entry in @var{table} associated with @var{key}, and\n"
1032 "store @var{value} there. Uses @code{eqv?} for equality testing.")
1033 #define FUNC_NAME s_scm_hashv_set_x
1035 return scm_hash_fn_set_x (table
, key
, val
,
1036 (scm_t_hash_fn
) scm_ihashv
,
1037 (scm_t_assoc_fn
) scm_sloppy_assv
,
1043 SCM_DEFINE (scm_hashv_remove_x
, "hashv-remove!", 2, 0, 0,
1044 (SCM table
, SCM key
),
1045 "Remove @var{key} (and any value associated with it) from\n"
1046 "@var{table}. Uses @code{eqv?} for equality tests.")
1047 #define FUNC_NAME s_scm_hashv_remove_x
1049 return scm_hash_fn_remove_x (table
, key
,
1050 (scm_t_hash_fn
) scm_ihashv
,
1051 (scm_t_assoc_fn
) scm_sloppy_assv
,
1058 SCM_DEFINE (scm_hash_get_handle
, "hash-get-handle", 2, 0, 0,
1059 (SCM table
, SCM key
),
1060 "This procedure returns the @code{(key . value)} pair from the\n"
1061 "hash table @var{table}. If @var{table} does not hold an\n"
1062 "associated value for @var{key}, @code{#f} is returned.\n"
1063 "Uses @code{equal?} for equality testing.")
1064 #define FUNC_NAME s_scm_hash_get_handle
1066 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
1067 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
1069 return scm_hash_fn_get_handle (table
, key
,
1070 (scm_t_hash_fn
) scm_ihash
,
1071 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1077 SCM_DEFINE (scm_hash_create_handle_x
, "hash-create-handle!", 3, 0, 0,
1078 (SCM table
, SCM key
, SCM init
),
1079 "This function looks up @var{key} in @var{table} and returns its handle.\n"
1080 "If @var{key} is not already present, a new handle is created which\n"
1081 "associates @var{key} with @var{init}.")
1082 #define FUNC_NAME s_scm_hash_create_handle_x
1084 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
1085 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
1087 return scm_hash_fn_create_handle_x (table
, key
, init
,
1088 (scm_t_hash_fn
) scm_ihash
,
1089 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1095 SCM_DEFINE (scm_hash_ref
, "hash-ref", 2, 1, 0,
1096 (SCM table
, SCM key
, SCM dflt
),
1097 "Look up @var{key} in the hash table @var{table}, and return the\n"
1098 "value (if any) associated with it. If @var{key} is not found,\n"
1099 "return @var{dflt} (or @code{#f} if no @var{dflt} argument\n"
1100 "is supplied). Uses @code{equal?} for equality testing.")
1101 #define FUNC_NAME s_scm_hash_ref
1103 if (SCM_UNBNDP (dflt
))
1105 return scm_hash_fn_ref (table
, key
, dflt
,
1106 (scm_t_hash_fn
) scm_ihash
,
1107 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1114 SCM_DEFINE (scm_hash_set_x
, "hash-set!", 3, 0, 0,
1115 (SCM table
, SCM key
, SCM val
),
1116 "Find the entry in @var{table} associated with @var{key}, and\n"
1117 "store @var{val} there. Uses @code{equal?} for equality\n"
1119 #define FUNC_NAME s_scm_hash_set_x
1121 return scm_hash_fn_set_x (table
, key
, val
,
1122 (scm_t_hash_fn
) scm_ihash
,
1123 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1130 SCM_DEFINE (scm_hash_remove_x
, "hash-remove!", 2, 0, 0,
1131 (SCM table
, SCM key
),
1132 "Remove @var{key} (and any value associated with it) from\n"
1133 "@var{table}. Uses @code{equal?} for equality tests.")
1134 #define FUNC_NAME s_scm_hash_remove_x
1136 return scm_hash_fn_remove_x (table
, key
,
1137 (scm_t_hash_fn
) scm_ihash
,
1138 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1146 typedef struct scm_t_ihashx_closure
1150 } scm_t_ihashx_closure
;
1154 static unsigned long
1155 scm_ihashx (SCM obj
, unsigned long n
, void *arg
)
1158 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
1159 answer
= scm_call_2 (closure
->hash
, obj
, scm_from_ulong (n
));
1160 return scm_to_ulong (answer
);
1166 scm_sloppy_assx (SCM obj
, SCM alist
, void *arg
)
1168 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
1169 return scm_call_2 (closure
->assoc
, obj
, alist
);
1173 SCM_DEFINE (scm_hashx_get_handle
, "hashx-get-handle", 4, 0, 0,
1174 (SCM hash
, SCM assoc
, SCM table
, SCM key
),
1175 "This behaves the same way as the corresponding\n"
1176 "@code{-get-handle} function, but uses @var{hash} as a hash\n"
1177 "function and @var{assoc} to compare keys. @code{hash} must be\n"
1178 "a function that takes two arguments, a key to be hashed and a\n"
1179 "table size. @code{assoc} must be an associator function, like\n"
1180 "@code{assoc}, @code{assq} or @code{assv}.")
1181 #define FUNC_NAME s_scm_hashx_get_handle
1183 scm_t_ihashx_closure closure
;
1184 closure
.hash
= hash
;
1185 closure
.assoc
= assoc
;
1187 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
1188 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
1190 return scm_hash_fn_get_handle (table
, key
, scm_ihashx
, scm_sloppy_assx
,
1196 SCM_DEFINE (scm_hashx_create_handle_x
, "hashx-create-handle!", 5, 0, 0,
1197 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM init
),
1198 "This behaves the same way as the corresponding\n"
1199 "@code{-create-handle} function, but uses @var{hash} as a hash\n"
1200 "function and @var{assoc} to compare keys. @code{hash} must be\n"
1201 "a function that takes two arguments, a key to be hashed and a\n"
1202 "table size. @code{assoc} must be an associator function, like\n"
1203 "@code{assoc}, @code{assq} or @code{assv}.")
1204 #define FUNC_NAME s_scm_hashx_create_handle_x
1206 scm_t_ihashx_closure closure
;
1207 closure
.hash
= hash
;
1208 closure
.assoc
= assoc
;
1210 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
1211 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
1213 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashx
,
1214 scm_sloppy_assx
, (void *)&closure
);
1220 SCM_DEFINE (scm_hashx_ref
, "hashx-ref", 4, 1, 0,
1221 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM dflt
),
1222 "This behaves the same way as the corresponding @code{ref}\n"
1223 "function, but uses @var{hash} as a hash function and\n"
1224 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1225 "that takes two arguments, a key to be hashed and a table size.\n"
1226 "@code{assoc} must be an associator function, like @code{assoc},\n"
1227 "@code{assq} or @code{assv}.\n"
1229 "By way of illustration, @code{hashq-ref table key} is\n"
1230 "equivalent to @code{hashx-ref hashq assq table key}.")
1231 #define FUNC_NAME s_scm_hashx_ref
1233 scm_t_ihashx_closure closure
;
1234 if (SCM_UNBNDP (dflt
))
1236 closure
.hash
= hash
;
1237 closure
.assoc
= assoc
;
1238 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashx
, scm_sloppy_assx
,
1246 SCM_DEFINE (scm_hashx_set_x
, "hashx-set!", 5, 0, 0,
1247 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM val
),
1248 "This behaves the same way as the corresponding @code{set!}\n"
1249 "function, but uses @var{hash} as a hash function and\n"
1250 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1251 "that takes two arguments, a key to be hashed and a table size.\n"
1252 "@code{assoc} must be an associator function, like @code{assoc},\n"
1253 "@code{assq} or @code{assv}.\n"
1255 " By way of illustration, @code{hashq-set! table key} is\n"
1256 "equivalent to @code{hashx-set! hashq assq table key}.")
1257 #define FUNC_NAME s_scm_hashx_set_x
1259 scm_t_ihashx_closure closure
;
1260 closure
.hash
= hash
;
1261 closure
.assoc
= assoc
;
1262 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashx
, scm_sloppy_assx
,
1267 SCM_DEFINE (scm_hashx_remove_x
, "hashx-remove!", 4, 0, 0,
1268 (SCM hash
, SCM assoc
, SCM table
, SCM obj
),
1269 "This behaves the same way as the corresponding @code{remove!}\n"
1270 "function, but uses @var{hash} as a hash function and\n"
1271 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1272 "that takes two arguments, a key to be hashed and a table size.\n"
1273 "@code{assoc} must be an associator function, like @code{assoc},\n"
1274 "@code{assq} or @code{assv}.\n"
1276 " By way of illustration, @code{hashq-remove! table key} is\n"
1277 "equivalent to @code{hashx-remove! hashq assq #f table key}.")
1278 #define FUNC_NAME s_scm_hashx_remove_x
1280 scm_t_ihashx_closure closure
;
1281 closure
.hash
= hash
;
1282 closure
.assoc
= assoc
;
1283 return scm_hash_fn_remove_x (table
, obj
, scm_ihashx
, scm_sloppy_assx
,
1288 /* Hash table iterators */
1290 SCM_DEFINE (scm_hash_fold
, "hash-fold", 3, 0, 0,
1291 (SCM proc
, SCM init
, SCM table
),
1292 "An iterator over hash-table elements.\n"
1293 "Accumulates and returns a result by applying PROC successively.\n"
1294 "The arguments to PROC are \"(key value prior-result)\" where key\n"
1295 "and value are successive pairs from the hash table TABLE, and\n"
1296 "prior-result is either INIT (for the first application of PROC)\n"
1297 "or the return value of the previous application of PROC.\n"
1298 "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
1299 "table into an a-list of key-value pairs.")
1300 #define FUNC_NAME s_scm_hash_fold
1302 SCM_VALIDATE_PROC (1, proc
);
1303 SCM_VALIDATE_HASHTABLE (3, table
);
1304 return scm_internal_hash_fold ((scm_t_hash_fold_fn
) scm_call_3
,
1305 (void *) SCM_UNPACK (proc
), init
, table
);
1310 for_each_proc (void *proc
, SCM handle
)
1312 return scm_call_2 (SCM_PACK (proc
), SCM_CAR (handle
), SCM_CDR (handle
));
1315 SCM_DEFINE (scm_hash_for_each
, "hash-for-each", 2, 0, 0,
1316 (SCM proc
, SCM table
),
1317 "An iterator over hash-table elements.\n"
1318 "Applies PROC successively on all hash table items.\n"
1319 "The arguments to PROC are \"(key value)\" where key\n"
1320 "and value are successive pairs from the hash table TABLE.")
1321 #define FUNC_NAME s_scm_hash_for_each
1323 SCM_VALIDATE_PROC (1, proc
);
1324 SCM_VALIDATE_HASHTABLE (2, table
);
1326 scm_internal_hash_for_each_handle (for_each_proc
,
1327 (void *) SCM_UNPACK (proc
),
1329 return SCM_UNSPECIFIED
;
1333 SCM_DEFINE (scm_hash_for_each_handle
, "hash-for-each-handle", 2, 0, 0,
1334 (SCM proc
, SCM table
),
1335 "An iterator over hash-table elements.\n"
1336 "Applies PROC successively on all hash table handles.")
1337 #define FUNC_NAME s_scm_hash_for_each_handle
1339 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)), proc
, 1, FUNC_NAME
);
1340 SCM_VALIDATE_HASHTABLE (2, table
);
1342 if (SCM_UNLIKELY (SCM_HASHTABLE_WEAK_P (table
)))
1343 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
1345 scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn
) scm_call_1
,
1346 (void *) SCM_UNPACK (proc
),
1348 return SCM_UNSPECIFIED
;
1353 map_proc (void *proc
, SCM key
, SCM data
, SCM value
)
1355 return scm_cons (scm_call_2 (SCM_PACK (proc
), key
, data
), value
);
1358 SCM_DEFINE (scm_hash_map_to_list
, "hash-map->list", 2, 0, 0,
1359 (SCM proc
, SCM table
),
1360 "An iterator over hash-table elements.\n"
1361 "Accumulates and returns as a list the results of applying PROC successively.\n"
1362 "The arguments to PROC are \"(key value)\" where key\n"
1363 "and value are successive pairs from the hash table TABLE.")
1364 #define FUNC_NAME s_scm_hash_map_to_list
1366 SCM_VALIDATE_PROC (1, proc
);
1367 SCM_VALIDATE_HASHTABLE (2, table
);
1368 return scm_internal_hash_fold (map_proc
,
1369 (void *) SCM_UNPACK (proc
),
1376 count_proc (void *pred
, SCM key
, SCM data
, SCM value
)
1378 if (scm_is_false (scm_call_2 (SCM_PACK (pred
), key
, data
)))
1381 return scm_oneplus(value
);
1384 SCM_DEFINE (scm_hash_count
, "hash-count", 2, 0, 0,
1385 (SCM pred
, SCM table
),
1386 "Return the number of elements in the given hash TABLE that\n"
1387 "cause `(PRED KEY VALUE)' to return true. To quickly determine\n"
1388 "the total number of elements, use `(const #t)' for PRED.")
1389 #define FUNC_NAME s_scm_hash_count
1393 SCM_VALIDATE_PROC (1, pred
);
1394 SCM_VALIDATE_HASHTABLE (2, table
);
1396 init
= scm_from_int (0);
1397 return scm_internal_hash_fold ((scm_t_hash_fold_fn
) count_proc
,
1398 (void *) SCM_UNPACK (pred
), init
, table
);
1405 scm_internal_hash_fold (scm_t_hash_fold_fn fn
, void *closure
,
1406 SCM init
, SCM table
)
1407 #define FUNC_NAME s_scm_hash_fold
1410 SCM buckets
, result
= init
;
1412 SCM_VALIDATE_HASHTABLE (0, table
);
1413 buckets
= SCM_HASHTABLE_VECTOR (table
);
1415 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1416 for (i
= 0; i
< n
; ++i
)
1420 for (ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
); !scm_is_null (ls
);
1423 handle
= SCM_CAR (ls
);
1425 if (SCM_HASHTABLE_WEAK_P (table
) && SCM_WEAK_PAIR_DELETED_P (handle
))
1426 /* Don't try to unlink this weak pair, as we're not within
1427 the allocation lock. Instead rely on
1428 vacuum_weak_hash_table to do its job. */
1431 result
= fn (closure
, SCM_CAR (handle
), SCM_CDR (handle
), result
);
1439 /* The following redundant code is here in order to be able to support
1440 hash-for-each-handle. An alternative would have been to replace
1441 this code and scm_internal_hash_fold above with a single
1442 scm_internal_hash_fold_handles, but we don't want to promote such
1446 scm_internal_hash_for_each_handle (scm_t_hash_handle_fn fn
, void *closure
,
1448 #define FUNC_NAME s_scm_hash_for_each
1453 SCM_VALIDATE_HASHTABLE (0, table
);
1454 buckets
= SCM_HASHTABLE_VECTOR (table
);
1455 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1457 for (i
= 0; i
< n
; ++i
)
1459 SCM ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
), handle
;
1460 while (!scm_is_null (ls
))
1462 if (!scm_is_pair (ls
))
1463 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1464 handle
= SCM_CAR (ls
);
1465 if (!scm_is_pair (handle
))
1466 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1467 if (!SCM_HASHTABLE_WEAK_P (table
)
1468 || !SCM_WEAK_PAIR_DELETED_P (handle
))
1469 fn (closure
, handle
);
1482 #include "libguile/hashtab.x"