1 /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
29 #include "libguile/_scm.h"
30 #include "libguile/alist.h"
31 #include "libguile/hash.h"
32 #include "libguile/eval.h"
33 #include "libguile/root.h"
34 #include "libguile/vectors.h"
35 #include "libguile/ports.h"
36 #include "libguile/bdw-gc.h"
38 #include "libguile/validate.h"
39 #include "libguile/hashtab.h"
44 /* A hash table is a cell containing a vector of association lists.
46 * Growing or shrinking, with following rehashing, is triggered when
49 * L = N / S (N: number of items in table, S: bucket vector length)
51 * passes an upper limit of 0.9 or a lower limit of 0.25.
53 * The implementation stores the upper and lower number of items which
54 * trigger a resize in the hashtable object.
56 * Weak hash tables use weak pairs in the bucket lists rather than
59 * Possible hash table sizes (primes) are stored in the array
63 static unsigned long hashtable_size
[] = {
64 31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363,
65 224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041
66 #if SIZEOF_SCM_T_BITS > 4
67 /* vector lengths are stored in the first word of vectors, shifted by
68 8 bits for the tc8, so for 32-bit we only get 2^24-1 = 16777215
69 elements. But we allow a few more sizes for 64-bit. */
70 , 28762081, 57524111, 115048217, 230096423, 460192829
74 #define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long))
76 static char *s_hashtable
= "hashtable";
80 /* Helper functions and macros to deal with weak pairs.
82 Weak pairs need to be accessed very carefully since their components can
83 be nullified by the GC when the object they refer to becomes unreachable.
84 Hence the macros and functions below that detect such weak pairs within
85 buckets and remove them. */
88 /* Remove nullified weak pairs from ALIST such that the result contains only
89 valid pairs. Set REMOVED_ITEMS to the number of pairs that have been
92 scm_fixup_weak_alist (SCM alist
, size_t *removed_items
)
100 alist
= SCM_CDR (alist
))
102 SCM pair
= SCM_CAR (alist
);
104 if (SCM_WEAK_PAIR_DELETED_P (pair
))
106 /* Remove from ALIST weak pair PAIR whose car/cdr has been
107 nullified by the GC. */
108 if (scm_is_null (prev
))
109 result
= SCM_CDR (alist
);
111 SCM_SETCDR (prev
, SCM_CDR (alist
));
115 /* Leave PREV unchanged. */
125 vacuum_weak_hash_table (SCM table
)
127 SCM buckets
= SCM_HASHTABLE_VECTOR (table
);
128 unsigned long k
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
129 size_t len
= SCM_HASHTABLE_N_ITEMS (table
);
134 SCM alist
= SCM_SIMPLE_VECTOR_REF (buckets
, k
);
135 alist
= scm_fixup_weak_alist (alist
, &removed
);
136 assert (removed
<= len
);
138 SCM_SIMPLE_VECTOR_SET (buckets
, k
, alist
);
141 SCM_SET_HASHTABLE_N_ITEMS (table
, len
);
145 /* Packed arguments for `do_weak_bucket_fixup'. */
150 size_t removed_items
;
154 do_weak_bucket_fixup (void *data
)
156 struct t_fixup_args
*args
;
159 args
= (struct t_fixup_args
*) data
;
161 args
->bucket
= scm_fixup_weak_alist (args
->bucket
, &args
->removed_items
);
163 for (pair
= args
->bucket
, copy
= args
->bucket_copy
;
165 pair
= SCM_CDR (pair
), copy
+= 2)
167 /* At this point, all weak pairs have been removed. */
168 assert (!SCM_WEAK_PAIR_DELETED_P (SCM_CAR (pair
)));
170 /* Copy the key and value. */
171 copy
[0] = SCM_CAAR (pair
);
172 copy
[1] = SCM_CDAR (pair
);
178 /* Lookup OBJECT in weak hash table TABLE using ASSOC. OBJECT is searched
179 for in the alist that is the BUCKET_INDEXth element of BUCKETS.
180 Optionally update TABLE and rehash it. */
182 weak_bucket_assoc (SCM table
, SCM buckets
, size_t bucket_index
,
183 scm_t_hash_fn hash_fn
,
184 scm_t_assoc_fn assoc
, SCM object
, void *closure
)
187 SCM bucket
, *strong_refs
;
188 struct t_fixup_args args
;
190 bucket
= SCM_SIMPLE_VECTOR_REF (buckets
, bucket_index
);
192 /* Prepare STRONG_REFS as an array large enough to hold all the keys
193 and values in BUCKET. */
194 strong_refs
= alloca (scm_ilength (bucket
) * 2 * sizeof (SCM
));
196 args
.bucket
= bucket
;
197 args
.bucket_copy
= strong_refs
;
199 /* Fixup BUCKET. Do that with the allocation lock held to avoid
200 seeing disappearing links pointing to objects that have already
201 been reclaimed (this happens when the disappearing links that point
202 to it haven't yet been cleared.)
204 The `do_weak_bucket_fixup' call populates STRONG_REFS with a copy
205 of BUCKET's entries after it's been fixed up. Thus, all the
206 entries kept in BUCKET are still reachable when ASSOC sees
208 GC_call_with_alloc_lock (do_weak_bucket_fixup
, &args
);
210 bucket
= args
.bucket
;
211 SCM_SIMPLE_VECTOR_SET (buckets
, bucket_index
, bucket
);
213 result
= assoc (object
, bucket
, closure
);
215 /* If we got a result, it should not have NULL fields. */
216 if (scm_is_pair (result
) && SCM_WEAK_PAIR_DELETED_P (result
))
219 scm_remember_upto_here_1 (strong_refs
);
221 if (args
.removed_items
> 0)
223 /* Update TABLE's item count and optionally trigger a rehash. */
226 assert (SCM_HASHTABLE_N_ITEMS (table
) >= args
.removed_items
);
228 remaining
= SCM_HASHTABLE_N_ITEMS (table
) - args
.removed_items
;
229 SCM_SET_HASHTABLE_N_ITEMS (table
, remaining
);
231 if (remaining
< SCM_HASHTABLE_LOWER (table
))
232 scm_i_rehash (table
, hash_fn
, closure
, "weak_bucket_assoc");
239 /* Packed arguments for `weak_bucket_assoc_by_hash'. */
240 struct assoc_by_hash_data
244 scm_t_hash_predicate_fn predicate
;
248 /* See scm_hash_fn_get_handle_by_hash below. */
250 weak_bucket_assoc_by_hash (void *args
)
252 struct assoc_by_hash_data
*data
= args
;
253 SCM alist
= data
->alist
;
255 for (; scm_is_pair (alist
); alist
= SCM_CDR (alist
))
257 SCM pair
= SCM_CAR (alist
);
259 if (!SCM_WEAK_PAIR_DELETED_P (pair
)
260 && data
->predicate (SCM_CAR (pair
), data
->closure
))
272 make_hash_table (int flags
, unsigned long k
, const char *func_name
)
276 int i
= 0, n
= k
? k
: 31;
277 while (i
< HASHTABLE_SIZE_N
&& n
> hashtable_size
[i
])
279 n
= hashtable_size
[i
];
281 /* In both cases, i.e., regardless of whether we are creating a weak hash
282 table, we return a non-weak vector. This is because the vector itself
283 is not weak in the case of a weak hash table: the alist pairs are. */
284 vector
= scm_c_make_vector (n
, SCM_EOL
);
286 t
= scm_gc_malloc_pointerless (sizeof (*t
), s_hashtable
);
287 t
->min_size_index
= t
->size_index
= i
;
290 t
->upper
= 9 * n
/ 10;
294 /* FIXME: we just need two words of storage, not three */
295 return scm_double_cell (scm_tc7_hashtable
, SCM_UNPACK (vector
),
300 scm_i_rehash (SCM table
,
301 scm_t_hash_fn hash_fn
,
303 const char* func_name
)
305 SCM buckets
, new_buckets
;
307 unsigned long old_size
;
308 unsigned long new_size
;
310 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
312 /* rehashing is not triggered when i <= min_size */
313 i
= SCM_HASHTABLE (table
)->size_index
;
316 while (i
> SCM_HASHTABLE (table
)->min_size_index
317 && SCM_HASHTABLE_N_ITEMS (table
) < hashtable_size
[i
] / 4);
321 i
= SCM_HASHTABLE (table
)->size_index
+ 1;
322 if (i
>= HASHTABLE_SIZE_N
)
326 /* Remember HASH_FN for rehash_after_gc, but only when CLOSURE
327 is not needed since CLOSURE can not be guaranteed to be valid
328 after this function returns.
331 SCM_HASHTABLE (table
)->hash_fn
= hash_fn
;
333 SCM_HASHTABLE (table
)->size_index
= i
;
335 new_size
= hashtable_size
[i
];
336 if (i
<= SCM_HASHTABLE (table
)->min_size_index
)
337 SCM_HASHTABLE (table
)->lower
= 0;
339 SCM_HASHTABLE (table
)->lower
= new_size
/ 4;
340 SCM_HASHTABLE (table
)->upper
= 9 * new_size
/ 10;
341 buckets
= SCM_HASHTABLE_VECTOR (table
);
343 new_buckets
= scm_c_make_vector (new_size
, SCM_EOL
);
345 /* When this is a weak hashtable, running the GC might change it.
346 We need to cope with this while rehashing its elements. We do
347 this by first installing the new, empty bucket vector. Then we
348 remove the elements from the old bucket vector and insert them
352 SCM_SET_HASHTABLE_VECTOR (table
, new_buckets
);
353 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
355 old_size
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
356 for (i
= 0; i
< old_size
; ++i
)
358 SCM ls
, cell
, handle
;
360 ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
);
361 SCM_SIMPLE_VECTOR_SET (buckets
, i
, SCM_EOL
);
363 while (scm_is_pair (ls
))
368 handle
= SCM_CAR (cell
);
371 if (SCM_WEAK_PAIR_DELETED_P (handle
))
372 /* HANDLE is a nullified weak pair: skip it. */
375 h
= hash_fn (SCM_CAR (handle
), new_size
, closure
);
377 scm_out_of_range (func_name
, scm_from_ulong (h
));
378 SCM_SETCDR (cell
, SCM_SIMPLE_VECTOR_REF (new_buckets
, h
));
379 SCM_SIMPLE_VECTOR_SET (new_buckets
, h
, cell
);
380 SCM_HASHTABLE_INCREMENT (table
);
387 scm_i_hashtable_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
389 scm_puts ("#<", port
);
390 if (SCM_HASHTABLE_WEAK_KEY_P (exp
))
391 scm_puts ("weak-key-", port
);
392 else if (SCM_HASHTABLE_WEAK_VALUE_P (exp
))
393 scm_puts ("weak-value-", port
);
394 else if (SCM_HASHTABLE_DOUBLY_WEAK_P (exp
))
395 scm_puts ("doubly-weak-", port
);
396 scm_puts ("hash-table ", port
);
397 scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp
), 10, port
);
398 scm_putc ('/', port
);
399 scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp
)),
401 scm_puts (">", port
);
406 scm_c_make_hash_table (unsigned long k
)
408 return make_hash_table (0, k
, "scm_c_make_hash_table");
411 SCM_DEFINE (scm_make_hash_table
, "make-hash-table", 0, 1, 0,
413 "Make a new abstract hash table object with minimum number of buckets @var{n}\n")
414 #define FUNC_NAME s_scm_make_hash_table
417 return make_hash_table (0, 0, FUNC_NAME
);
419 return make_hash_table (0, scm_to_ulong (n
), FUNC_NAME
);
423 /* The before-gc C hook only runs if GC_set_start_callback is available,
424 so if not, fall back on a finalizer-based implementation. */
426 weak_gc_callback (void **weak
)
429 void (*callback
) (SCM
) = weak
[1];
434 callback (PTR2SCM (val
));
439 #ifdef HAVE_GC_SET_START_CALLBACK
441 weak_gc_hook (void *hook_data
, void *fn_data
, void *data
)
443 if (!weak_gc_callback (fn_data
))
444 scm_c_hook_remove (&scm_before_gc_c_hook
, weak_gc_hook
, fn_data
);
450 weak_gc_finalizer (void *ptr
, void *data
)
452 if (weak_gc_callback (ptr
))
453 GC_REGISTER_FINALIZER_NO_ORDER (ptr
, weak_gc_finalizer
, data
, NULL
, NULL
);
458 scm_c_register_weak_gc_callback (SCM obj
, void (*callback
) (SCM
))
460 void **weak
= GC_MALLOC_ATOMIC (sizeof (void*) * 2);
462 weak
[0] = SCM2PTR (obj
);
463 weak
[1] = (void*)callback
;
464 GC_GENERAL_REGISTER_DISAPPEARING_LINK (weak
, SCM2PTR (obj
));
466 #ifdef HAVE_GC_SET_START_CALLBACK
467 scm_c_hook_add (&scm_before_gc_c_hook
, weak_gc_hook
, weak
, 0);
469 GC_REGISTER_FINALIZER_NO_ORDER (weak
, weak_gc_finalizer
, NULL
, NULL
, NULL
);
473 SCM_DEFINE (scm_make_weak_key_hash_table
, "make-weak-key-hash-table", 0, 1, 0,
475 "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
476 "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n"
477 "Return a weak hash table with @var{size} buckets.\n"
479 "You can modify weak hash tables in exactly the same way you\n"
480 "would modify regular hash tables. (@pxref{Hash Tables})")
481 #define FUNC_NAME s_scm_make_weak_key_hash_table
486 ret
= make_hash_table (SCM_HASHTABLEF_WEAK_CAR
, 0, FUNC_NAME
);
488 ret
= make_hash_table (SCM_HASHTABLEF_WEAK_CAR
,
489 scm_to_ulong (n
), FUNC_NAME
);
491 scm_c_register_weak_gc_callback (ret
, vacuum_weak_hash_table
);
498 SCM_DEFINE (scm_make_weak_value_hash_table
, "make-weak-value-hash-table", 0, 1, 0,
500 "Return a hash table with weak values with @var{size} buckets.\n"
501 "(@pxref{Hash Tables})")
502 #define FUNC_NAME s_scm_make_weak_value_hash_table
507 ret
= make_hash_table (SCM_HASHTABLEF_WEAK_CDR
, 0, FUNC_NAME
);
509 ret
= make_hash_table (SCM_HASHTABLEF_WEAK_CDR
,
510 scm_to_ulong (n
), FUNC_NAME
);
512 scm_c_register_weak_gc_callback (ret
, vacuum_weak_hash_table
);
519 SCM_DEFINE (scm_make_doubly_weak_hash_table
, "make-doubly-weak-hash-table", 1, 0, 0,
521 "Return a hash table with weak keys and values with @var{size}\n"
522 "buckets. (@pxref{Hash Tables})")
523 #define FUNC_NAME s_scm_make_doubly_weak_hash_table
528 ret
= make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
531 ret
= make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
532 scm_to_ulong (n
), FUNC_NAME
);
534 scm_c_register_weak_gc_callback (ret
, vacuum_weak_hash_table
);
541 SCM_DEFINE (scm_hash_table_p
, "hash-table?", 1, 0, 0,
543 "Return @code{#t} if @var{obj} is an abstract hash table object.")
544 #define FUNC_NAME s_scm_hash_table_p
546 return scm_from_bool (SCM_HASHTABLE_P (obj
));
551 SCM_DEFINE (scm_weak_key_hash_table_p
, "weak-key-hash-table?", 1, 0, 0,
553 "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n"
554 "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n"
555 "Return @code{#t} if @var{obj} is the specified weak hash\n"
556 "table. Note that a doubly weak hash table is neither a weak key\n"
557 "nor a weak value hash table.")
558 #define FUNC_NAME s_scm_weak_key_hash_table_p
560 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_KEY_P (obj
));
565 SCM_DEFINE (scm_weak_value_hash_table_p
, "weak-value-hash-table?", 1, 0, 0,
567 "Return @code{#t} if @var{obj} is a weak value hash table.")
568 #define FUNC_NAME s_scm_weak_value_hash_table_p
570 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_VALUE_P (obj
));
575 SCM_DEFINE (scm_doubly_weak_hash_table_p
, "doubly-weak-hash-table?", 1, 0, 0,
577 "Return @code{#t} if @var{obj} is a doubly weak hash table.")
578 #define FUNC_NAME s_scm_doubly_weak_hash_table_p
580 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_DOUBLY_WEAK_P (obj
));
585 /* Accessing hash table entries. */
588 scm_hash_fn_get_handle (SCM table
, SCM obj
,
589 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
591 #define FUNC_NAME "scm_hash_fn_get_handle"
596 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
597 buckets
= SCM_HASHTABLE_VECTOR (table
);
599 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
601 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
602 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
603 scm_out_of_range (FUNC_NAME
, scm_from_ulong (k
));
605 if (SCM_HASHTABLE_WEAK_P (table
))
606 h
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
607 assoc_fn
, obj
, closure
);
609 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
616 /* This procedure implements three optimizations, with respect to the
619 1. For weak tables, it's assumed that calling the predicate in the
620 allocation lock is safe. In practice this means that the predicate
621 cannot call arbitrary scheme functions.
623 2. We don't check for overflow / underflow and rehash.
625 3. We don't actually have to allocate a key -- instead we get the
626 hash value directly. This is useful for, for example, looking up
627 strings in the symbol table.
630 scm_hash_fn_get_handle_by_hash (SCM table
, unsigned long raw_hash
,
631 scm_t_hash_predicate_fn predicate_fn
,
633 #define FUNC_NAME "scm_hash_fn_ref_by_hash"
636 SCM buckets
, alist
, h
= SCM_BOOL_F
;
638 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
639 buckets
= SCM_HASHTABLE_VECTOR (table
);
641 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
644 k
= raw_hash
% SCM_SIMPLE_VECTOR_LENGTH (buckets
);
645 alist
= SCM_SIMPLE_VECTOR_REF (buckets
, k
);
647 if (SCM_HASHTABLE_WEAK_P (table
))
649 struct assoc_by_hash_data args
;
652 args
.ret
= SCM_BOOL_F
;
653 args
.predicate
= predicate_fn
;
654 args
.closure
= closure
;
655 GC_call_with_alloc_lock (weak_bucket_assoc_by_hash
, &args
);
659 for (; scm_is_pair (alist
); alist
= SCM_CDR (alist
))
661 SCM pair
= SCM_CAR (alist
);
662 if (predicate_fn (SCM_CAR (pair
), closure
))
675 scm_hash_fn_create_handle_x (SCM table
, SCM obj
, SCM init
,
676 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
678 #define FUNC_NAME "scm_hash_fn_create_handle_x"
683 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
684 buckets
= SCM_HASHTABLE_VECTOR (table
);
686 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
687 SCM_MISC_ERROR ("void hashtable", SCM_EOL
);
689 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
690 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
691 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
693 if (SCM_HASHTABLE_WEAK_P (table
))
694 it
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
695 assoc_fn
, obj
, closure
);
697 it
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
699 if (scm_is_pair (it
))
701 else if (scm_is_true (it
))
702 scm_wrong_type_arg_msg (NULL
, 0, it
, "a pair");
705 /* When this is a weak hashtable, running the GC can change it.
706 Thus, we must allocate the new cells first and can only then
707 access BUCKETS. Also, we need to fetch the bucket vector
708 again since the hashtable might have been rehashed. This
709 necessitates a new hash value as well.
711 SCM handle
, new_bucket
;
713 if (SCM_HASHTABLE_WEAK_P (table
))
715 /* FIXME: We don't support weak alist vectors. */
716 /* Use a weak cell. */
717 if (SCM_HASHTABLE_DOUBLY_WEAK_P (table
))
718 handle
= scm_doubly_weak_pair (obj
, init
);
719 else if (SCM_HASHTABLE_WEAK_KEY_P (table
))
720 handle
= scm_weak_car_pair (obj
, init
);
722 handle
= scm_weak_cdr_pair (obj
, init
);
725 /* Use a regular, non-weak cell. */
726 handle
= scm_cons (obj
, init
);
728 new_bucket
= scm_cons (handle
, SCM_EOL
);
730 if (!scm_is_eq (SCM_HASHTABLE_VECTOR (table
), buckets
))
732 buckets
= SCM_HASHTABLE_VECTOR (table
);
733 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
734 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
735 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
737 SCM_SETCDR (new_bucket
, SCM_SIMPLE_VECTOR_REF (buckets
, k
));
738 SCM_SIMPLE_VECTOR_SET (buckets
, k
, new_bucket
);
739 SCM_HASHTABLE_INCREMENT (table
);
741 /* Maybe rehash the table. */
742 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
)
743 || SCM_HASHTABLE_N_ITEMS (table
) > SCM_HASHTABLE_UPPER (table
))
744 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
745 return SCM_CAR (new_bucket
);
752 scm_hash_fn_ref (SCM table
, SCM obj
, SCM dflt
,
753 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
756 SCM it
= scm_hash_fn_get_handle (table
, obj
, hash_fn
, assoc_fn
, closure
);
757 if (scm_is_pair (it
))
766 struct set_weak_cdr_data
773 set_weak_cdr (void *data
)
775 struct set_weak_cdr_data
*d
= data
;
777 if (SCM_NIMP (SCM_WEAK_PAIR_CDR (d
->pair
)) && !SCM_NIMP (d
->new_val
))
779 GC_unregister_disappearing_link ((GC_PTR
) SCM_CDRLOC (d
->pair
));
780 SCM_SETCDR (d
->pair
, d
->new_val
);
784 SCM_SETCDR (d
->pair
, d
->new_val
);
785 SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR
) SCM_CDRLOC (d
->pair
),
786 (GC_PTR
) SCM2PTR (d
->new_val
));
792 scm_hash_fn_set_x (SCM table
, SCM obj
, SCM val
,
793 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
798 pair
= scm_hash_fn_create_handle_x (table
, obj
, val
,
799 hash_fn
, assoc_fn
, closure
);
801 if (SCM_UNLIKELY (!scm_is_eq (SCM_CDR (pair
), val
)))
803 if (SCM_UNLIKELY (SCM_HASHTABLE_WEAK_VALUE_P (table
)))
805 struct set_weak_cdr_data data
;
810 GC_call_with_alloc_lock (set_weak_cdr
, &data
);
813 SCM_SETCDR (pair
, val
);
821 scm_hash_fn_remove_x (SCM table
, SCM obj
,
822 scm_t_hash_fn hash_fn
,
823 scm_t_assoc_fn assoc_fn
,
825 #define FUNC_NAME "hash_fn_remove_x"
830 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
832 buckets
= SCM_HASHTABLE_VECTOR (table
);
834 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
837 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
838 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
839 scm_out_of_range (FUNC_NAME
, scm_from_ulong (k
));
841 if (SCM_HASHTABLE_WEAK_P (table
))
842 h
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
843 assoc_fn
, obj
, closure
);
845 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
849 SCM_SIMPLE_VECTOR_SET
850 (buckets
, k
, scm_delq_x (h
, SCM_SIMPLE_VECTOR_REF (buckets
, k
)));
851 SCM_HASHTABLE_DECREMENT (table
);
852 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
853 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
859 SCM_DEFINE (scm_hash_clear_x
, "hash-clear!", 1, 0, 0,
861 "Remove all items from @var{table} (without triggering a resize).")
862 #define FUNC_NAME s_scm_hash_clear_x
864 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
866 scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table
), SCM_EOL
);
867 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
869 return SCM_UNSPECIFIED
;
875 SCM_DEFINE (scm_hashq_get_handle
, "hashq-get-handle", 2, 0, 0,
876 (SCM table
, SCM key
),
877 "This procedure returns the @code{(key . value)} pair from the\n"
878 "hash table @var{table}. If @var{table} does not hold an\n"
879 "associated value for @var{key}, @code{#f} is returned.\n"
880 "Uses @code{eq?} for equality testing.")
881 #define FUNC_NAME s_scm_hashq_get_handle
883 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
884 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
886 return scm_hash_fn_get_handle (table
, key
,
887 (scm_t_hash_fn
) scm_ihashq
,
888 (scm_t_assoc_fn
) scm_sloppy_assq
,
894 SCM_DEFINE (scm_hashq_create_handle_x
, "hashq-create-handle!", 3, 0, 0,
895 (SCM table
, SCM key
, SCM init
),
896 "This function looks up @var{key} in @var{table} and returns its handle.\n"
897 "If @var{key} is not already present, a new handle is created which\n"
898 "associates @var{key} with @var{init}.")
899 #define FUNC_NAME s_scm_hashq_create_handle_x
901 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
902 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
904 return scm_hash_fn_create_handle_x (table
, key
, init
,
905 (scm_t_hash_fn
) scm_ihashq
,
906 (scm_t_assoc_fn
) scm_sloppy_assq
,
912 SCM_DEFINE (scm_hashq_ref
, "hashq-ref", 2, 1, 0,
913 (SCM table
, SCM key
, SCM dflt
),
914 "Look up @var{key} in the hash table @var{table}, and return the\n"
915 "value (if any) associated with it. If @var{key} is not found,\n"
916 "return @var{default} (or @code{#f} if no @var{default} argument\n"
917 "is supplied). Uses @code{eq?} for equality testing.")
918 #define FUNC_NAME s_scm_hashq_ref
920 if (SCM_UNBNDP (dflt
))
922 return scm_hash_fn_ref (table
, key
, dflt
,
923 (scm_t_hash_fn
) scm_ihashq
,
924 (scm_t_assoc_fn
) scm_sloppy_assq
,
931 SCM_DEFINE (scm_hashq_set_x
, "hashq-set!", 3, 0, 0,
932 (SCM table
, SCM key
, SCM val
),
933 "Find the entry in @var{table} associated with @var{key}, and\n"
934 "store @var{value} there. Uses @code{eq?} for equality testing.")
935 #define FUNC_NAME s_scm_hashq_set_x
937 return scm_hash_fn_set_x (table
, key
, val
,
938 (scm_t_hash_fn
) scm_ihashq
,
939 (scm_t_assoc_fn
) scm_sloppy_assq
,
946 SCM_DEFINE (scm_hashq_remove_x
, "hashq-remove!", 2, 0, 0,
947 (SCM table
, SCM key
),
948 "Remove @var{key} (and any value associated with it) from\n"
949 "@var{table}. Uses @code{eq?} for equality tests.")
950 #define FUNC_NAME s_scm_hashq_remove_x
952 return scm_hash_fn_remove_x (table
, key
,
953 (scm_t_hash_fn
) scm_ihashq
,
954 (scm_t_assoc_fn
) scm_sloppy_assq
,
962 SCM_DEFINE (scm_hashv_get_handle
, "hashv-get-handle", 2, 0, 0,
963 (SCM table
, SCM key
),
964 "This procedure returns the @code{(key . value)} pair from the\n"
965 "hash table @var{table}. If @var{table} does not hold an\n"
966 "associated value for @var{key}, @code{#f} is returned.\n"
967 "Uses @code{eqv?} for equality testing.")
968 #define FUNC_NAME s_scm_hashv_get_handle
970 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
971 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
973 return scm_hash_fn_get_handle (table
, key
,
974 (scm_t_hash_fn
) scm_ihashv
,
975 (scm_t_assoc_fn
) scm_sloppy_assv
,
981 SCM_DEFINE (scm_hashv_create_handle_x
, "hashv-create-handle!", 3, 0, 0,
982 (SCM table
, SCM key
, SCM init
),
983 "This function looks up @var{key} in @var{table} and returns its handle.\n"
984 "If @var{key} is not already present, a new handle is created which\n"
985 "associates @var{key} with @var{init}.")
986 #define FUNC_NAME s_scm_hashv_create_handle_x
988 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
989 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
991 return scm_hash_fn_create_handle_x (table
, key
, init
,
992 (scm_t_hash_fn
) scm_ihashv
,
993 (scm_t_assoc_fn
) scm_sloppy_assv
,
999 SCM_DEFINE (scm_hashv_ref
, "hashv-ref", 2, 1, 0,
1000 (SCM table
, SCM key
, SCM dflt
),
1001 "Look up @var{key} in the hash table @var{table}, and return the\n"
1002 "value (if any) associated with it. If @var{key} is not found,\n"
1003 "return @var{default} (or @code{#f} if no @var{default} argument\n"
1004 "is supplied). Uses @code{eqv?} for equality testing.")
1005 #define FUNC_NAME s_scm_hashv_ref
1007 if (SCM_UNBNDP (dflt
))
1009 return scm_hash_fn_ref (table
, key
, dflt
,
1010 (scm_t_hash_fn
) scm_ihashv
,
1011 (scm_t_assoc_fn
) scm_sloppy_assv
,
1018 SCM_DEFINE (scm_hashv_set_x
, "hashv-set!", 3, 0, 0,
1019 (SCM table
, SCM key
, SCM val
),
1020 "Find the entry in @var{table} associated with @var{key}, and\n"
1021 "store @var{value} there. Uses @code{eqv?} for equality testing.")
1022 #define FUNC_NAME s_scm_hashv_set_x
1024 return scm_hash_fn_set_x (table
, key
, val
,
1025 (scm_t_hash_fn
) scm_ihashv
,
1026 (scm_t_assoc_fn
) scm_sloppy_assv
,
1032 SCM_DEFINE (scm_hashv_remove_x
, "hashv-remove!", 2, 0, 0,
1033 (SCM table
, SCM key
),
1034 "Remove @var{key} (and any value associated with it) from\n"
1035 "@var{table}. Uses @code{eqv?} for equality tests.")
1036 #define FUNC_NAME s_scm_hashv_remove_x
1038 return scm_hash_fn_remove_x (table
, key
,
1039 (scm_t_hash_fn
) scm_ihashv
,
1040 (scm_t_assoc_fn
) scm_sloppy_assv
,
1047 SCM_DEFINE (scm_hash_get_handle
, "hash-get-handle", 2, 0, 0,
1048 (SCM table
, SCM key
),
1049 "This procedure returns the @code{(key . value)} pair from the\n"
1050 "hash table @var{table}. If @var{table} does not hold an\n"
1051 "associated value for @var{key}, @code{#f} is returned.\n"
1052 "Uses @code{equal?} for equality testing.")
1053 #define FUNC_NAME s_scm_hash_get_handle
1055 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
1056 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
1058 return scm_hash_fn_get_handle (table
, key
,
1059 (scm_t_hash_fn
) scm_ihash
,
1060 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1066 SCM_DEFINE (scm_hash_create_handle_x
, "hash-create-handle!", 3, 0, 0,
1067 (SCM table
, SCM key
, SCM init
),
1068 "This function looks up @var{key} in @var{table} and returns its handle.\n"
1069 "If @var{key} is not already present, a new handle is created which\n"
1070 "associates @var{key} with @var{init}.")
1071 #define FUNC_NAME s_scm_hash_create_handle_x
1073 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
1074 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
1076 return scm_hash_fn_create_handle_x (table
, key
, init
,
1077 (scm_t_hash_fn
) scm_ihash
,
1078 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1084 SCM_DEFINE (scm_hash_ref
, "hash-ref", 2, 1, 0,
1085 (SCM table
, SCM key
, SCM dflt
),
1086 "Look up @var{key} in the hash table @var{table}, and return the\n"
1087 "value (if any) associated with it. If @var{key} is not found,\n"
1088 "return @var{default} (or @code{#f} if no @var{default} argument\n"
1089 "is supplied). Uses @code{equal?} for equality testing.")
1090 #define FUNC_NAME s_scm_hash_ref
1092 if (SCM_UNBNDP (dflt
))
1094 return scm_hash_fn_ref (table
, key
, dflt
,
1095 (scm_t_hash_fn
) scm_ihash
,
1096 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1103 SCM_DEFINE (scm_hash_set_x
, "hash-set!", 3, 0, 0,
1104 (SCM table
, SCM key
, SCM val
),
1105 "Find the entry in @var{table} associated with @var{key}, and\n"
1106 "store @var{value} there. Uses @code{equal?} for equality\n"
1108 #define FUNC_NAME s_scm_hash_set_x
1110 return scm_hash_fn_set_x (table
, key
, val
,
1111 (scm_t_hash_fn
) scm_ihash
,
1112 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1119 SCM_DEFINE (scm_hash_remove_x
, "hash-remove!", 2, 0, 0,
1120 (SCM table
, SCM key
),
1121 "Remove @var{key} (and any value associated with it) from\n"
1122 "@var{table}. Uses @code{equal?} for equality tests.")
1123 #define FUNC_NAME s_scm_hash_remove_x
1125 return scm_hash_fn_remove_x (table
, key
,
1126 (scm_t_hash_fn
) scm_ihash
,
1127 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1135 typedef struct scm_t_ihashx_closure
1139 } scm_t_ihashx_closure
;
1143 static unsigned long
1144 scm_ihashx (SCM obj
, unsigned long n
, void *arg
)
1147 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
1148 answer
= scm_call_2 (closure
->hash
, obj
, scm_from_ulong (n
));
1149 return scm_to_ulong (answer
);
1155 scm_sloppy_assx (SCM obj
, SCM alist
, void *arg
)
1157 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
1158 return scm_call_2 (closure
->assoc
, obj
, alist
);
1162 SCM_DEFINE (scm_hashx_get_handle
, "hashx-get-handle", 4, 0, 0,
1163 (SCM hash
, SCM assoc
, SCM table
, SCM key
),
1164 "This behaves the same way as the corresponding\n"
1165 "@code{-get-handle} function, but uses @var{hash} as a hash\n"
1166 "function and @var{assoc} to compare keys. @code{hash} must be\n"
1167 "a function that takes two arguments, a key to be hashed and a\n"
1168 "table size. @code{assoc} must be an associator function, like\n"
1169 "@code{assoc}, @code{assq} or @code{assv}.")
1170 #define FUNC_NAME s_scm_hashx_get_handle
1172 scm_t_ihashx_closure closure
;
1173 closure
.hash
= hash
;
1174 closure
.assoc
= assoc
;
1176 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
1177 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
1179 return scm_hash_fn_get_handle (table
, key
, scm_ihashx
, scm_sloppy_assx
,
1185 SCM_DEFINE (scm_hashx_create_handle_x
, "hashx-create-handle!", 5, 0, 0,
1186 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM init
),
1187 "This behaves the same way as the corresponding\n"
1188 "@code{-create-handle} function, but uses @var{hash} as a hash\n"
1189 "function and @var{assoc} to compare keys. @code{hash} must be\n"
1190 "a function that takes two arguments, a key to be hashed and a\n"
1191 "table size. @code{assoc} must be an associator function, like\n"
1192 "@code{assoc}, @code{assq} or @code{assv}.")
1193 #define FUNC_NAME s_scm_hashx_create_handle_x
1195 scm_t_ihashx_closure closure
;
1196 closure
.hash
= hash
;
1197 closure
.assoc
= assoc
;
1199 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
1200 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
1202 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashx
,
1203 scm_sloppy_assx
, (void *)&closure
);
1209 SCM_DEFINE (scm_hashx_ref
, "hashx-ref", 4, 1, 0,
1210 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM dflt
),
1211 "This behaves the same way as the corresponding @code{ref}\n"
1212 "function, but uses @var{hash} as a hash function and\n"
1213 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1214 "that takes two arguments, a key to be hashed and a table size.\n"
1215 "@code{assoc} must be an associator function, like @code{assoc},\n"
1216 "@code{assq} or @code{assv}.\n"
1218 "By way of illustration, @code{hashq-ref table key} is\n"
1219 "equivalent to @code{hashx-ref hashq assq table key}.")
1220 #define FUNC_NAME s_scm_hashx_ref
1222 scm_t_ihashx_closure closure
;
1223 if (SCM_UNBNDP (dflt
))
1225 closure
.hash
= hash
;
1226 closure
.assoc
= assoc
;
1227 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashx
, scm_sloppy_assx
,
1235 SCM_DEFINE (scm_hashx_set_x
, "hashx-set!", 5, 0, 0,
1236 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM val
),
1237 "This behaves the same way as the corresponding @code{set!}\n"
1238 "function, but uses @var{hash} as a hash function and\n"
1239 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1240 "that takes two arguments, a key to be hashed and a table size.\n"
1241 "@code{assoc} must be an associator function, like @code{assoc},\n"
1242 "@code{assq} or @code{assv}.\n"
1244 " By way of illustration, @code{hashq-set! table key} is\n"
1245 "equivalent to @code{hashx-set! hashq assq table key}.")
1246 #define FUNC_NAME s_scm_hashx_set_x
1248 scm_t_ihashx_closure closure
;
1249 closure
.hash
= hash
;
1250 closure
.assoc
= assoc
;
1251 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashx
, scm_sloppy_assx
,
1256 SCM_DEFINE (scm_hashx_remove_x
, "hashx-remove!", 4, 0, 0,
1257 (SCM hash
, SCM assoc
, SCM table
, SCM obj
),
1258 "This behaves the same way as the corresponding @code{remove!}\n"
1259 "function, but uses @var{hash} as a hash function and\n"
1260 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1261 "that takes two arguments, a key to be hashed and a table size.\n"
1262 "@code{assoc} must be an associator function, like @code{assoc},\n"
1263 "@code{assq} or @code{assv}.\n"
1265 " By way of illustration, @code{hashq-remove! table key} is\n"
1266 "equivalent to @code{hashx-remove! hashq assq #f table key}.")
1267 #define FUNC_NAME s_scm_hashx_remove_x
1269 scm_t_ihashx_closure closure
;
1270 closure
.hash
= hash
;
1271 closure
.assoc
= assoc
;
1272 return scm_hash_fn_remove_x (table
, obj
, scm_ihashx
, scm_sloppy_assx
,
1277 /* Hash table iterators */
1279 SCM_DEFINE (scm_hash_fold
, "hash-fold", 3, 0, 0,
1280 (SCM proc
, SCM init
, SCM table
),
1281 "An iterator over hash-table elements.\n"
1282 "Accumulates and returns a result by applying PROC successively.\n"
1283 "The arguments to PROC are \"(key value prior-result)\" where key\n"
1284 "and value are successive pairs from the hash table TABLE, and\n"
1285 "prior-result is either INIT (for the first application of PROC)\n"
1286 "or the return value of the previous application of PROC.\n"
1287 "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
1288 "table into an a-list of key-value pairs.")
1289 #define FUNC_NAME s_scm_hash_fold
1291 SCM_VALIDATE_PROC (1, proc
);
1292 SCM_VALIDATE_HASHTABLE (3, table
);
1293 return scm_internal_hash_fold ((scm_t_hash_fold_fn
) scm_call_3
,
1294 (void *) SCM_UNPACK (proc
), init
, table
);
1299 for_each_proc (void *proc
, SCM handle
)
1301 return scm_call_2 (SCM_PACK (proc
), SCM_CAR (handle
), SCM_CDR (handle
));
1304 SCM_DEFINE (scm_hash_for_each
, "hash-for-each", 2, 0, 0,
1305 (SCM proc
, SCM table
),
1306 "An iterator over hash-table elements.\n"
1307 "Applies PROC successively on all hash table items.\n"
1308 "The arguments to PROC are \"(key value)\" where key\n"
1309 "and value are successive pairs from the hash table TABLE.")
1310 #define FUNC_NAME s_scm_hash_for_each
1312 SCM_VALIDATE_PROC (1, proc
);
1313 SCM_VALIDATE_HASHTABLE (2, table
);
1315 scm_internal_hash_for_each_handle (for_each_proc
,
1316 (void *) SCM_UNPACK (proc
),
1318 return SCM_UNSPECIFIED
;
1322 SCM_DEFINE (scm_hash_for_each_handle
, "hash-for-each-handle", 2, 0, 0,
1323 (SCM proc
, SCM table
),
1324 "An iterator over hash-table elements.\n"
1325 "Applies PROC successively on all hash table handles.")
1326 #define FUNC_NAME s_scm_hash_for_each_handle
1328 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)), proc
, 1, FUNC_NAME
);
1329 SCM_VALIDATE_HASHTABLE (2, table
);
1331 if (SCM_UNLIKELY (SCM_HASHTABLE_WEAK_P (table
)))
1332 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
1334 scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn
) scm_call_1
,
1335 (void *) SCM_UNPACK (proc
),
1337 return SCM_UNSPECIFIED
;
1342 map_proc (void *proc
, SCM key
, SCM data
, SCM value
)
1344 return scm_cons (scm_call_2 (SCM_PACK (proc
), key
, data
), value
);
1347 SCM_DEFINE (scm_hash_map_to_list
, "hash-map->list", 2, 0, 0,
1348 (SCM proc
, SCM table
),
1349 "An iterator over hash-table elements.\n"
1350 "Accumulates and returns as a list the results of applying PROC successively.\n"
1351 "The arguments to PROC are \"(key value)\" where key\n"
1352 "and value are successive pairs from the hash table TABLE.")
1353 #define FUNC_NAME s_scm_hash_map_to_list
1355 SCM_VALIDATE_PROC (1, proc
);
1356 SCM_VALIDATE_HASHTABLE (2, table
);
1357 return scm_internal_hash_fold (map_proc
,
1358 (void *) SCM_UNPACK (proc
),
1367 scm_internal_hash_fold (scm_t_hash_fold_fn fn
, void *closure
,
1368 SCM init
, SCM table
)
1369 #define FUNC_NAME s_scm_hash_fold
1372 SCM buckets
, result
= init
;
1374 SCM_VALIDATE_HASHTABLE (0, table
);
1375 buckets
= SCM_HASHTABLE_VECTOR (table
);
1377 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1378 for (i
= 0; i
< n
; ++i
)
1382 for (prev
= SCM_BOOL_F
, ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
);
1384 prev
= ls
, ls
= SCM_CDR (ls
))
1388 if (!scm_is_pair (ls
))
1389 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1391 handle
= SCM_CAR (ls
);
1392 if (!scm_is_pair (handle
))
1393 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1395 if (SCM_HASHTABLE_WEAK_P (table
))
1397 if (SCM_WEAK_PAIR_DELETED_P (handle
))
1399 /* We hit a weak pair whose car/cdr has become
1400 unreachable: unlink it from the bucket. */
1401 if (scm_is_true (prev
))
1402 SCM_SETCDR (prev
, SCM_CDR (ls
));
1404 SCM_SIMPLE_VECTOR_SET (buckets
, i
, SCM_CDR (ls
));
1406 /* Update the item count. */
1407 SCM_HASHTABLE_DECREMENT (table
);
1413 result
= fn (closure
, SCM_CAR (handle
), SCM_CDR (handle
), result
);
1421 /* The following redundant code is here in order to be able to support
1422 hash-for-each-handle. An alternative would have been to replace
1423 this code and scm_internal_hash_fold above with a single
1424 scm_internal_hash_fold_handles, but we don't want to promote such
1428 scm_internal_hash_for_each_handle (scm_t_hash_handle_fn fn
, void *closure
,
1430 #define FUNC_NAME s_scm_hash_for_each
1435 SCM_VALIDATE_HASHTABLE (0, table
);
1436 buckets
= SCM_HASHTABLE_VECTOR (table
);
1437 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1439 for (i
= 0; i
< n
; ++i
)
1441 SCM ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
), handle
;
1442 while (!scm_is_null (ls
))
1444 if (!scm_is_pair (ls
))
1445 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1446 handle
= SCM_CAR (ls
);
1447 if (!scm_is_pair (handle
))
1448 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1449 fn (closure
, handle
);
1462 #include "libguile/hashtab.x"