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. */
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
);
214 assert (!scm_is_pair (result
) ||
215 !SCM_WEAK_PAIR_DELETED_P (GC_is_visible (result
)));
217 scm_remember_upto_here_1 (strong_refs
);
219 if (args
.removed_items
> 0)
221 /* Update TABLE's item count and optionally trigger a rehash. */
224 assert (SCM_HASHTABLE_N_ITEMS (table
) >= args
.removed_items
);
226 remaining
= SCM_HASHTABLE_N_ITEMS (table
) - args
.removed_items
;
227 SCM_SET_HASHTABLE_N_ITEMS (table
, remaining
);
229 if (remaining
< SCM_HASHTABLE_LOWER (table
))
230 scm_i_rehash (table
, hash_fn
, closure
, "weak_bucket_assoc");
237 /* Packed arguments for `weak_bucket_assoc_by_hash'. */
238 struct assoc_by_hash_data
242 scm_t_hash_predicate_fn predicate
;
246 /* See scm_hash_fn_get_handle_by_hash below. */
248 weak_bucket_assoc_by_hash (void *args
)
250 struct assoc_by_hash_data
*data
= args
;
251 SCM alist
= data
->alist
;
253 for (; scm_is_pair (alist
); alist
= SCM_CDR (alist
))
255 SCM pair
= SCM_CAR (alist
);
257 if (!SCM_WEAK_PAIR_DELETED_P (pair
)
258 && data
->predicate (SCM_CAR (pair
), data
->closure
))
270 make_hash_table (int flags
, unsigned long k
, const char *func_name
)
274 int i
= 0, n
= k
? k
: 31;
275 while (i
< HASHTABLE_SIZE_N
&& n
> hashtable_size
[i
])
277 n
= hashtable_size
[i
];
279 /* In both cases, i.e., regardless of whether we are creating a weak hash
280 table, we return a non-weak vector. This is because the vector itself
281 is not weak in the case of a weak hash table: the alist pairs are. */
282 vector
= scm_c_make_vector (n
, SCM_EOL
);
284 t
= scm_gc_malloc_pointerless (sizeof (*t
), s_hashtable
);
285 t
->min_size_index
= t
->size_index
= i
;
288 t
->upper
= 9 * n
/ 10;
292 /* FIXME: we just need two words of storage, not three */
293 return scm_double_cell (scm_tc7_hashtable
, SCM_UNPACK (vector
),
298 scm_i_rehash (SCM table
,
299 scm_t_hash_fn hash_fn
,
301 const char* func_name
)
303 SCM buckets
, new_buckets
;
305 unsigned long old_size
;
306 unsigned long new_size
;
308 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
310 /* rehashing is not triggered when i <= min_size */
311 i
= SCM_HASHTABLE (table
)->size_index
;
314 while (i
> SCM_HASHTABLE (table
)->min_size_index
315 && SCM_HASHTABLE_N_ITEMS (table
) < hashtable_size
[i
] / 4);
319 i
= SCM_HASHTABLE (table
)->size_index
+ 1;
320 if (i
>= HASHTABLE_SIZE_N
)
324 /* Remember HASH_FN for rehash_after_gc, but only when CLOSURE
325 is not needed since CLOSURE can not be guaranteed to be valid
326 after this function returns.
329 SCM_HASHTABLE (table
)->hash_fn
= hash_fn
;
331 SCM_HASHTABLE (table
)->size_index
= i
;
333 new_size
= hashtable_size
[i
];
334 if (i
<= SCM_HASHTABLE (table
)->min_size_index
)
335 SCM_HASHTABLE (table
)->lower
= 0;
337 SCM_HASHTABLE (table
)->lower
= new_size
/ 4;
338 SCM_HASHTABLE (table
)->upper
= 9 * new_size
/ 10;
339 buckets
= SCM_HASHTABLE_VECTOR (table
);
341 new_buckets
= scm_c_make_vector (new_size
, SCM_EOL
);
343 /* When this is a weak hashtable, running the GC might change it.
344 We need to cope with this while rehashing its elements. We do
345 this by first installing the new, empty bucket vector. Then we
346 remove the elements from the old bucket vector and insert them
350 SCM_SET_HASHTABLE_VECTOR (table
, new_buckets
);
351 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
353 old_size
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
354 for (i
= 0; i
< old_size
; ++i
)
356 SCM ls
, cell
, handle
;
358 ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
);
359 SCM_SIMPLE_VECTOR_SET (buckets
, i
, SCM_EOL
);
361 while (scm_is_pair (ls
))
366 handle
= SCM_CAR (cell
);
369 if (SCM_WEAK_PAIR_DELETED_P (handle
))
370 /* HANDLE is a nullified weak pair: skip it. */
373 h
= hash_fn (SCM_CAR (handle
), new_size
, closure
);
375 scm_out_of_range (func_name
, scm_from_ulong (h
));
376 SCM_SETCDR (cell
, SCM_SIMPLE_VECTOR_REF (new_buckets
, h
));
377 SCM_SIMPLE_VECTOR_SET (new_buckets
, h
, cell
);
378 SCM_HASHTABLE_INCREMENT (table
);
385 scm_i_hashtable_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
387 scm_puts ("#<", port
);
388 if (SCM_HASHTABLE_WEAK_KEY_P (exp
))
389 scm_puts ("weak-key-", port
);
390 else if (SCM_HASHTABLE_WEAK_VALUE_P (exp
))
391 scm_puts ("weak-value-", port
);
392 else if (SCM_HASHTABLE_DOUBLY_WEAK_P (exp
))
393 scm_puts ("doubly-weak-", port
);
394 scm_puts ("hash-table ", port
);
395 scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp
), 10, port
);
396 scm_putc ('/', port
);
397 scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp
)),
399 scm_puts (">", port
);
404 scm_c_make_hash_table (unsigned long k
)
406 return make_hash_table (0, k
, "scm_c_make_hash_table");
409 SCM_DEFINE (scm_make_hash_table
, "make-hash-table", 0, 1, 0,
411 "Make a new abstract hash table object with minimum number of buckets @var{n}\n")
412 #define FUNC_NAME s_scm_make_hash_table
415 return make_hash_table (0, 0, FUNC_NAME
);
417 return make_hash_table (0, scm_to_ulong (n
), FUNC_NAME
);
421 /* The before-gc C hook only runs if GC_set_start_callback is available,
422 so if not, fall back on a finalizer-based implementation. */
424 weak_gc_callback (void **weak
)
427 void (*callback
) (SCM
) = weak
[1];
432 callback (PTR2SCM (val
));
437 #ifdef HAVE_GC_SET_START_CALLBACK
439 weak_gc_hook (void *hook_data
, void *fn_data
, void *data
)
441 if (!weak_gc_callback (fn_data
))
442 scm_c_hook_remove (&scm_before_gc_c_hook
, weak_gc_hook
, fn_data
);
448 weak_gc_finalizer (void *ptr
, void *data
)
450 if (weak_gc_callback (ptr
))
451 GC_REGISTER_FINALIZER_NO_ORDER (ptr
, weak_gc_finalizer
, data
, NULL
, NULL
);
456 scm_c_register_weak_gc_callback (SCM obj
, void (*callback
) (SCM
))
458 void **weak
= GC_MALLOC_ATOMIC (sizeof (void*) * 2);
460 weak
[0] = SCM2PTR (obj
);
461 weak
[1] = (void*)callback
;
462 GC_GENERAL_REGISTER_DISAPPEARING_LINK (weak
, SCM2PTR (obj
));
464 #ifdef HAVE_GC_SET_START_CALLBACK
465 scm_c_hook_add (&scm_before_gc_c_hook
, weak_gc_hook
, weak
, 0);
467 GC_REGISTER_FINALIZER_NO_ORDER (weak
, weak_gc_finalizer
, NULL
, NULL
, NULL
);
471 SCM_DEFINE (scm_make_weak_key_hash_table
, "make-weak-key-hash-table", 0, 1, 0,
473 "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
474 "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n"
475 "Return a weak hash table with @var{size} buckets.\n"
477 "You can modify weak hash tables in exactly the same way you\n"
478 "would modify regular hash tables. (@pxref{Hash Tables})")
479 #define FUNC_NAME s_scm_make_weak_key_hash_table
484 ret
= make_hash_table (SCM_HASHTABLEF_WEAK_CAR
, 0, FUNC_NAME
);
486 ret
= make_hash_table (SCM_HASHTABLEF_WEAK_CAR
,
487 scm_to_ulong (n
), FUNC_NAME
);
489 scm_c_register_weak_gc_callback (ret
, vacuum_weak_hash_table
);
496 SCM_DEFINE (scm_make_weak_value_hash_table
, "make-weak-value-hash-table", 0, 1, 0,
498 "Return a hash table with weak values with @var{size} buckets.\n"
499 "(@pxref{Hash Tables})")
500 #define FUNC_NAME s_scm_make_weak_value_hash_table
505 ret
= make_hash_table (SCM_HASHTABLEF_WEAK_CDR
, 0, FUNC_NAME
);
507 ret
= make_hash_table (SCM_HASHTABLEF_WEAK_CDR
,
508 scm_to_ulong (n
), FUNC_NAME
);
510 scm_c_register_weak_gc_callback (ret
, vacuum_weak_hash_table
);
517 SCM_DEFINE (scm_make_doubly_weak_hash_table
, "make-doubly-weak-hash-table", 1, 0, 0,
519 "Return a hash table with weak keys and values with @var{size}\n"
520 "buckets. (@pxref{Hash Tables})")
521 #define FUNC_NAME s_scm_make_doubly_weak_hash_table
526 ret
= make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
529 ret
= make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
530 scm_to_ulong (n
), FUNC_NAME
);
532 scm_c_register_weak_gc_callback (ret
, vacuum_weak_hash_table
);
539 SCM_DEFINE (scm_hash_table_p
, "hash-table?", 1, 0, 0,
541 "Return @code{#t} if @var{obj} is an abstract hash table object.")
542 #define FUNC_NAME s_scm_hash_table_p
544 return scm_from_bool (SCM_HASHTABLE_P (obj
));
549 SCM_DEFINE (scm_weak_key_hash_table_p
, "weak-key-hash-table?", 1, 0, 0,
551 "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n"
552 "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n"
553 "Return @code{#t} if @var{obj} is the specified weak hash\n"
554 "table. Note that a doubly weak hash table is neither a weak key\n"
555 "nor a weak value hash table.")
556 #define FUNC_NAME s_scm_weak_key_hash_table_p
558 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_KEY_P (obj
));
563 SCM_DEFINE (scm_weak_value_hash_table_p
, "weak-value-hash-table?", 1, 0, 0,
565 "Return @code{#t} if @var{obj} is a weak value hash table.")
566 #define FUNC_NAME s_scm_weak_value_hash_table_p
568 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_VALUE_P (obj
));
573 SCM_DEFINE (scm_doubly_weak_hash_table_p
, "doubly-weak-hash-table?", 1, 0, 0,
575 "Return @code{#t} if @var{obj} is a doubly weak hash table.")
576 #define FUNC_NAME s_scm_doubly_weak_hash_table_p
578 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_DOUBLY_WEAK_P (obj
));
583 /* Accessing hash table entries. */
586 scm_hash_fn_get_handle (SCM table
, SCM obj
,
587 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
589 #define FUNC_NAME "scm_hash_fn_get_handle"
594 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
595 buckets
= SCM_HASHTABLE_VECTOR (table
);
597 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
599 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
600 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
601 scm_out_of_range (FUNC_NAME
, scm_from_ulong (k
));
603 if (SCM_HASHTABLE_WEAK_P (table
))
604 h
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
605 assoc_fn
, obj
, closure
);
607 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
614 /* This procedure implements three optimizations, with respect to the
617 1. For weak tables, it's assumed that calling the predicate in the
618 allocation lock is safe. In practice this means that the predicate
619 cannot call arbitrary scheme functions.
621 2. We don't check for overflow / underflow and rehash.
623 3. We don't actually have to allocate a key -- instead we get the
624 hash value directly. This is useful for, for example, looking up
625 strings in the symbol table.
628 scm_hash_fn_get_handle_by_hash (SCM table
, unsigned long raw_hash
,
629 scm_t_hash_predicate_fn predicate_fn
,
631 #define FUNC_NAME "scm_hash_fn_ref_by_hash"
634 SCM buckets
, alist
, h
= SCM_BOOL_F
;
636 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
637 buckets
= SCM_HASHTABLE_VECTOR (table
);
639 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
642 k
= raw_hash
% SCM_SIMPLE_VECTOR_LENGTH (buckets
);
643 alist
= SCM_SIMPLE_VECTOR_REF (buckets
, k
);
645 if (SCM_HASHTABLE_WEAK_P (table
))
647 struct assoc_by_hash_data args
;
650 args
.ret
= SCM_BOOL_F
;
651 args
.predicate
= predicate_fn
;
652 args
.closure
= closure
;
653 GC_call_with_alloc_lock (weak_bucket_assoc_by_hash
, &args
);
657 for (; scm_is_pair (alist
); alist
= SCM_CDR (alist
))
659 SCM pair
= SCM_CAR (alist
);
660 if (predicate_fn (SCM_CAR (pair
), closure
))
673 scm_hash_fn_create_handle_x (SCM table
, SCM obj
, SCM init
,
674 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
676 #define FUNC_NAME "scm_hash_fn_create_handle_x"
681 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
682 buckets
= SCM_HASHTABLE_VECTOR (table
);
684 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
685 SCM_MISC_ERROR ("void hashtable", SCM_EOL
);
687 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
688 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
689 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
691 if (SCM_HASHTABLE_WEAK_P (table
))
692 it
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
693 assoc_fn
, obj
, closure
);
695 it
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
697 if (scm_is_pair (it
))
699 else if (scm_is_true (it
))
700 scm_wrong_type_arg_msg (NULL
, 0, it
, "a pair");
703 /* When this is a weak hashtable, running the GC can change it.
704 Thus, we must allocate the new cells first and can only then
705 access BUCKETS. Also, we need to fetch the bucket vector
706 again since the hashtable might have been rehashed. This
707 necessitates a new hash value as well.
709 SCM handle
, new_bucket
;
711 if (SCM_HASHTABLE_WEAK_P (table
))
713 /* FIXME: We don't support weak alist vectors. */
714 /* Use a weak cell. */
715 if (SCM_HASHTABLE_DOUBLY_WEAK_P (table
))
716 handle
= scm_doubly_weak_pair (obj
, init
);
717 else if (SCM_HASHTABLE_WEAK_KEY_P (table
))
718 handle
= scm_weak_car_pair (obj
, init
);
720 handle
= scm_weak_cdr_pair (obj
, init
);
723 /* Use a regular, non-weak cell. */
724 handle
= scm_cons (obj
, init
);
726 new_bucket
= scm_cons (handle
, SCM_EOL
);
728 if (!scm_is_eq (SCM_HASHTABLE_VECTOR (table
), buckets
))
730 buckets
= SCM_HASHTABLE_VECTOR (table
);
731 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
732 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
733 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
735 SCM_SETCDR (new_bucket
, SCM_SIMPLE_VECTOR_REF (buckets
, k
));
736 SCM_SIMPLE_VECTOR_SET (buckets
, k
, new_bucket
);
737 SCM_HASHTABLE_INCREMENT (table
);
739 /* Maybe rehash the table. */
740 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
)
741 || SCM_HASHTABLE_N_ITEMS (table
) > SCM_HASHTABLE_UPPER (table
))
742 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
743 return SCM_CAR (new_bucket
);
750 scm_hash_fn_ref (SCM table
, SCM obj
, SCM dflt
,
751 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
754 SCM it
= scm_hash_fn_get_handle (table
, obj
, hash_fn
, assoc_fn
, closure
);
755 if (scm_is_pair (it
))
764 struct set_weak_cdr_data
771 set_weak_cdr (void *data
)
773 struct set_weak_cdr_data
*d
= data
;
775 if (SCM_NIMP (SCM_WEAK_PAIR_CDR (d
->pair
)) && !SCM_NIMP (d
->new_val
))
777 GC_unregister_disappearing_link ((void *) SCM_CDRLOC (d
->pair
));
778 SCM_SETCDR (d
->pair
, d
->new_val
);
782 SCM_SETCDR (d
->pair
, d
->new_val
);
783 SCM_I_REGISTER_DISAPPEARING_LINK ((void *) SCM_CDRLOC (d
->pair
),
784 SCM2PTR (d
->new_val
));
790 scm_hash_fn_set_x (SCM table
, SCM obj
, SCM val
,
791 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
796 pair
= scm_hash_fn_create_handle_x (table
, obj
, val
,
797 hash_fn
, assoc_fn
, closure
);
799 if (SCM_UNLIKELY (!scm_is_eq (SCM_CDR (pair
), val
)))
801 if (SCM_UNLIKELY (SCM_HASHTABLE_WEAK_VALUE_P (table
)))
803 struct set_weak_cdr_data data
;
808 GC_call_with_alloc_lock (set_weak_cdr
, &data
);
811 SCM_SETCDR (pair
, val
);
819 scm_hash_fn_remove_x (SCM table
, SCM obj
,
820 scm_t_hash_fn hash_fn
,
821 scm_t_assoc_fn assoc_fn
,
823 #define FUNC_NAME "hash_fn_remove_x"
828 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
830 buckets
= SCM_HASHTABLE_VECTOR (table
);
832 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
835 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
836 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
837 scm_out_of_range (FUNC_NAME
, scm_from_ulong (k
));
839 if (SCM_HASHTABLE_WEAK_P (table
))
840 h
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
841 assoc_fn
, obj
, closure
);
843 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
847 SCM_SIMPLE_VECTOR_SET
848 (buckets
, k
, scm_delq_x (h
, SCM_SIMPLE_VECTOR_REF (buckets
, k
)));
849 SCM_HASHTABLE_DECREMENT (table
);
850 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
851 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
857 SCM_DEFINE (scm_hash_clear_x
, "hash-clear!", 1, 0, 0,
859 "Remove all items from @var{table} (without triggering a resize).")
860 #define FUNC_NAME s_scm_hash_clear_x
862 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
864 scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table
), SCM_EOL
);
865 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
867 return SCM_UNSPECIFIED
;
873 SCM_DEFINE (scm_hashq_get_handle
, "hashq-get-handle", 2, 0, 0,
874 (SCM table
, SCM key
),
875 "This procedure returns the @code{(key . value)} pair from the\n"
876 "hash table @var{table}. If @var{table} does not hold an\n"
877 "associated value for @var{key}, @code{#f} is returned.\n"
878 "Uses @code{eq?} for equality testing.")
879 #define FUNC_NAME s_scm_hashq_get_handle
881 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
882 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
884 return scm_hash_fn_get_handle (table
, key
,
885 (scm_t_hash_fn
) scm_ihashq
,
886 (scm_t_assoc_fn
) scm_sloppy_assq
,
892 SCM_DEFINE (scm_hashq_create_handle_x
, "hashq-create-handle!", 3, 0, 0,
893 (SCM table
, SCM key
, SCM init
),
894 "This function looks up @var{key} in @var{table} and returns its handle.\n"
895 "If @var{key} is not already present, a new handle is created which\n"
896 "associates @var{key} with @var{init}.")
897 #define FUNC_NAME s_scm_hashq_create_handle_x
899 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
900 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
902 return scm_hash_fn_create_handle_x (table
, key
, init
,
903 (scm_t_hash_fn
) scm_ihashq
,
904 (scm_t_assoc_fn
) scm_sloppy_assq
,
910 SCM_DEFINE (scm_hashq_ref
, "hashq-ref", 2, 1, 0,
911 (SCM table
, SCM key
, SCM dflt
),
912 "Look up @var{key} in the hash table @var{table}, and return the\n"
913 "value (if any) associated with it. If @var{key} is not found,\n"
914 "return @var{default} (or @code{#f} if no @var{default} argument\n"
915 "is supplied). Uses @code{eq?} for equality testing.")
916 #define FUNC_NAME s_scm_hashq_ref
918 if (SCM_UNBNDP (dflt
))
920 return scm_hash_fn_ref (table
, key
, dflt
,
921 (scm_t_hash_fn
) scm_ihashq
,
922 (scm_t_assoc_fn
) scm_sloppy_assq
,
929 SCM_DEFINE (scm_hashq_set_x
, "hashq-set!", 3, 0, 0,
930 (SCM table
, SCM key
, SCM val
),
931 "Find the entry in @var{table} associated with @var{key}, and\n"
932 "store @var{value} there. Uses @code{eq?} for equality testing.")
933 #define FUNC_NAME s_scm_hashq_set_x
935 return scm_hash_fn_set_x (table
, key
, val
,
936 (scm_t_hash_fn
) scm_ihashq
,
937 (scm_t_assoc_fn
) scm_sloppy_assq
,
944 SCM_DEFINE (scm_hashq_remove_x
, "hashq-remove!", 2, 0, 0,
945 (SCM table
, SCM key
),
946 "Remove @var{key} (and any value associated with it) from\n"
947 "@var{table}. Uses @code{eq?} for equality tests.")
948 #define FUNC_NAME s_scm_hashq_remove_x
950 return scm_hash_fn_remove_x (table
, key
,
951 (scm_t_hash_fn
) scm_ihashq
,
952 (scm_t_assoc_fn
) scm_sloppy_assq
,
960 SCM_DEFINE (scm_hashv_get_handle
, "hashv-get-handle", 2, 0, 0,
961 (SCM table
, SCM key
),
962 "This procedure returns the @code{(key . value)} pair from the\n"
963 "hash table @var{table}. If @var{table} does not hold an\n"
964 "associated value for @var{key}, @code{#f} is returned.\n"
965 "Uses @code{eqv?} for equality testing.")
966 #define FUNC_NAME s_scm_hashv_get_handle
968 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
969 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
971 return scm_hash_fn_get_handle (table
, key
,
972 (scm_t_hash_fn
) scm_ihashv
,
973 (scm_t_assoc_fn
) scm_sloppy_assv
,
979 SCM_DEFINE (scm_hashv_create_handle_x
, "hashv-create-handle!", 3, 0, 0,
980 (SCM table
, SCM key
, SCM init
),
981 "This function looks up @var{key} in @var{table} and returns its handle.\n"
982 "If @var{key} is not already present, a new handle is created which\n"
983 "associates @var{key} with @var{init}.")
984 #define FUNC_NAME s_scm_hashv_create_handle_x
986 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
987 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
989 return scm_hash_fn_create_handle_x (table
, key
, init
,
990 (scm_t_hash_fn
) scm_ihashv
,
991 (scm_t_assoc_fn
) scm_sloppy_assv
,
997 SCM_DEFINE (scm_hashv_ref
, "hashv-ref", 2, 1, 0,
998 (SCM table
, SCM key
, SCM dflt
),
999 "Look up @var{key} in the hash table @var{table}, and return the\n"
1000 "value (if any) associated with it. If @var{key} is not found,\n"
1001 "return @var{default} (or @code{#f} if no @var{default} argument\n"
1002 "is supplied). Uses @code{eqv?} for equality testing.")
1003 #define FUNC_NAME s_scm_hashv_ref
1005 if (SCM_UNBNDP (dflt
))
1007 return scm_hash_fn_ref (table
, key
, dflt
,
1008 (scm_t_hash_fn
) scm_ihashv
,
1009 (scm_t_assoc_fn
) scm_sloppy_assv
,
1016 SCM_DEFINE (scm_hashv_set_x
, "hashv-set!", 3, 0, 0,
1017 (SCM table
, SCM key
, SCM val
),
1018 "Find the entry in @var{table} associated with @var{key}, and\n"
1019 "store @var{value} there. Uses @code{eqv?} for equality testing.")
1020 #define FUNC_NAME s_scm_hashv_set_x
1022 return scm_hash_fn_set_x (table
, key
, val
,
1023 (scm_t_hash_fn
) scm_ihashv
,
1024 (scm_t_assoc_fn
) scm_sloppy_assv
,
1030 SCM_DEFINE (scm_hashv_remove_x
, "hashv-remove!", 2, 0, 0,
1031 (SCM table
, SCM key
),
1032 "Remove @var{key} (and any value associated with it) from\n"
1033 "@var{table}. Uses @code{eqv?} for equality tests.")
1034 #define FUNC_NAME s_scm_hashv_remove_x
1036 return scm_hash_fn_remove_x (table
, key
,
1037 (scm_t_hash_fn
) scm_ihashv
,
1038 (scm_t_assoc_fn
) scm_sloppy_assv
,
1045 SCM_DEFINE (scm_hash_get_handle
, "hash-get-handle", 2, 0, 0,
1046 (SCM table
, SCM key
),
1047 "This procedure returns the @code{(key . value)} pair from the\n"
1048 "hash table @var{table}. If @var{table} does not hold an\n"
1049 "associated value for @var{key}, @code{#f} is returned.\n"
1050 "Uses @code{equal?} for equality testing.")
1051 #define FUNC_NAME s_scm_hash_get_handle
1053 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
1054 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
1056 return scm_hash_fn_get_handle (table
, key
,
1057 (scm_t_hash_fn
) scm_ihash
,
1058 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1064 SCM_DEFINE (scm_hash_create_handle_x
, "hash-create-handle!", 3, 0, 0,
1065 (SCM table
, SCM key
, SCM init
),
1066 "This function looks up @var{key} in @var{table} and returns its handle.\n"
1067 "If @var{key} is not already present, a new handle is created which\n"
1068 "associates @var{key} with @var{init}.")
1069 #define FUNC_NAME s_scm_hash_create_handle_x
1071 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
1072 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
1074 return scm_hash_fn_create_handle_x (table
, key
, init
,
1075 (scm_t_hash_fn
) scm_ihash
,
1076 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1082 SCM_DEFINE (scm_hash_ref
, "hash-ref", 2, 1, 0,
1083 (SCM table
, SCM key
, SCM dflt
),
1084 "Look up @var{key} in the hash table @var{table}, and return the\n"
1085 "value (if any) associated with it. If @var{key} is not found,\n"
1086 "return @var{default} (or @code{#f} if no @var{default} argument\n"
1087 "is supplied). Uses @code{equal?} for equality testing.")
1088 #define FUNC_NAME s_scm_hash_ref
1090 if (SCM_UNBNDP (dflt
))
1092 return scm_hash_fn_ref (table
, key
, dflt
,
1093 (scm_t_hash_fn
) scm_ihash
,
1094 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1101 SCM_DEFINE (scm_hash_set_x
, "hash-set!", 3, 0, 0,
1102 (SCM table
, SCM key
, SCM val
),
1103 "Find the entry in @var{table} associated with @var{key}, and\n"
1104 "store @var{value} there. Uses @code{equal?} for equality\n"
1106 #define FUNC_NAME s_scm_hash_set_x
1108 return scm_hash_fn_set_x (table
, key
, val
,
1109 (scm_t_hash_fn
) scm_ihash
,
1110 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1117 SCM_DEFINE (scm_hash_remove_x
, "hash-remove!", 2, 0, 0,
1118 (SCM table
, SCM key
),
1119 "Remove @var{key} (and any value associated with it) from\n"
1120 "@var{table}. Uses @code{equal?} for equality tests.")
1121 #define FUNC_NAME s_scm_hash_remove_x
1123 return scm_hash_fn_remove_x (table
, key
,
1124 (scm_t_hash_fn
) scm_ihash
,
1125 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1133 typedef struct scm_t_ihashx_closure
1137 } scm_t_ihashx_closure
;
1141 static unsigned long
1142 scm_ihashx (SCM obj
, unsigned long n
, void *arg
)
1145 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
1146 answer
= scm_call_2 (closure
->hash
, obj
, scm_from_ulong (n
));
1147 return scm_to_ulong (answer
);
1153 scm_sloppy_assx (SCM obj
, SCM alist
, void *arg
)
1155 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
1156 return scm_call_2 (closure
->assoc
, obj
, alist
);
1160 SCM_DEFINE (scm_hashx_get_handle
, "hashx-get-handle", 4, 0, 0,
1161 (SCM hash
, SCM assoc
, SCM table
, SCM key
),
1162 "This behaves the same way as the corresponding\n"
1163 "@code{-get-handle} function, but uses @var{hash} as a hash\n"
1164 "function and @var{assoc} to compare keys. @code{hash} must be\n"
1165 "a function that takes two arguments, a key to be hashed and a\n"
1166 "table size. @code{assoc} must be an associator function, like\n"
1167 "@code{assoc}, @code{assq} or @code{assv}.")
1168 #define FUNC_NAME s_scm_hashx_get_handle
1170 scm_t_ihashx_closure closure
;
1171 closure
.hash
= hash
;
1172 closure
.assoc
= assoc
;
1174 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
1175 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
1177 return scm_hash_fn_get_handle (table
, key
, scm_ihashx
, scm_sloppy_assx
,
1183 SCM_DEFINE (scm_hashx_create_handle_x
, "hashx-create-handle!", 5, 0, 0,
1184 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM init
),
1185 "This behaves the same way as the corresponding\n"
1186 "@code{-create-handle} function, but uses @var{hash} as a hash\n"
1187 "function and @var{assoc} to compare keys. @code{hash} must be\n"
1188 "a function that takes two arguments, a key to be hashed and a\n"
1189 "table size. @code{assoc} must be an associator function, like\n"
1190 "@code{assoc}, @code{assq} or @code{assv}.")
1191 #define FUNC_NAME s_scm_hashx_create_handle_x
1193 scm_t_ihashx_closure closure
;
1194 closure
.hash
= hash
;
1195 closure
.assoc
= assoc
;
1197 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
1198 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
1200 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashx
,
1201 scm_sloppy_assx
, (void *)&closure
);
1207 SCM_DEFINE (scm_hashx_ref
, "hashx-ref", 4, 1, 0,
1208 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM dflt
),
1209 "This behaves the same way as the corresponding @code{ref}\n"
1210 "function, but uses @var{hash} as a hash function and\n"
1211 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1212 "that takes two arguments, a key to be hashed and a table size.\n"
1213 "@code{assoc} must be an associator function, like @code{assoc},\n"
1214 "@code{assq} or @code{assv}.\n"
1216 "By way of illustration, @code{hashq-ref table key} is\n"
1217 "equivalent to @code{hashx-ref hashq assq table key}.")
1218 #define FUNC_NAME s_scm_hashx_ref
1220 scm_t_ihashx_closure closure
;
1221 if (SCM_UNBNDP (dflt
))
1223 closure
.hash
= hash
;
1224 closure
.assoc
= assoc
;
1225 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashx
, scm_sloppy_assx
,
1233 SCM_DEFINE (scm_hashx_set_x
, "hashx-set!", 5, 0, 0,
1234 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM val
),
1235 "This behaves the same way as the corresponding @code{set!}\n"
1236 "function, but uses @var{hash} as a hash function and\n"
1237 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1238 "that takes two arguments, a key to be hashed and a table size.\n"
1239 "@code{assoc} must be an associator function, like @code{assoc},\n"
1240 "@code{assq} or @code{assv}.\n"
1242 " By way of illustration, @code{hashq-set! table key} is\n"
1243 "equivalent to @code{hashx-set! hashq assq table key}.")
1244 #define FUNC_NAME s_scm_hashx_set_x
1246 scm_t_ihashx_closure closure
;
1247 closure
.hash
= hash
;
1248 closure
.assoc
= assoc
;
1249 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashx
, scm_sloppy_assx
,
1254 SCM_DEFINE (scm_hashx_remove_x
, "hashx-remove!", 4, 0, 0,
1255 (SCM hash
, SCM assoc
, SCM table
, SCM obj
),
1256 "This behaves the same way as the corresponding @code{remove!}\n"
1257 "function, but uses @var{hash} as a hash function and\n"
1258 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1259 "that takes two arguments, a key to be hashed and a table size.\n"
1260 "@code{assoc} must be an associator function, like @code{assoc},\n"
1261 "@code{assq} or @code{assv}.\n"
1263 " By way of illustration, @code{hashq-remove! table key} is\n"
1264 "equivalent to @code{hashx-remove! hashq assq #f table key}.")
1265 #define FUNC_NAME s_scm_hashx_remove_x
1267 scm_t_ihashx_closure closure
;
1268 closure
.hash
= hash
;
1269 closure
.assoc
= assoc
;
1270 return scm_hash_fn_remove_x (table
, obj
, scm_ihashx
, scm_sloppy_assx
,
1275 /* Hash table iterators */
1277 SCM_DEFINE (scm_hash_fold
, "hash-fold", 3, 0, 0,
1278 (SCM proc
, SCM init
, SCM table
),
1279 "An iterator over hash-table elements.\n"
1280 "Accumulates and returns a result by applying PROC successively.\n"
1281 "The arguments to PROC are \"(key value prior-result)\" where key\n"
1282 "and value are successive pairs from the hash table TABLE, and\n"
1283 "prior-result is either INIT (for the first application of PROC)\n"
1284 "or the return value of the previous application of PROC.\n"
1285 "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
1286 "table into an a-list of key-value pairs.")
1287 #define FUNC_NAME s_scm_hash_fold
1289 SCM_VALIDATE_PROC (1, proc
);
1290 SCM_VALIDATE_HASHTABLE (3, table
);
1291 return scm_internal_hash_fold ((scm_t_hash_fold_fn
) scm_call_3
,
1292 (void *) SCM_UNPACK (proc
), init
, table
);
1297 for_each_proc (void *proc
, SCM handle
)
1299 return scm_call_2 (SCM_PACK (proc
), SCM_CAR (handle
), SCM_CDR (handle
));
1302 SCM_DEFINE (scm_hash_for_each
, "hash-for-each", 2, 0, 0,
1303 (SCM proc
, SCM table
),
1304 "An iterator over hash-table elements.\n"
1305 "Applies PROC successively on all hash table items.\n"
1306 "The arguments to PROC are \"(key value)\" where key\n"
1307 "and value are successive pairs from the hash table TABLE.")
1308 #define FUNC_NAME s_scm_hash_for_each
1310 SCM_VALIDATE_PROC (1, proc
);
1311 SCM_VALIDATE_HASHTABLE (2, table
);
1313 scm_internal_hash_for_each_handle (for_each_proc
,
1314 (void *) SCM_UNPACK (proc
),
1316 return SCM_UNSPECIFIED
;
1320 SCM_DEFINE (scm_hash_for_each_handle
, "hash-for-each-handle", 2, 0, 0,
1321 (SCM proc
, SCM table
),
1322 "An iterator over hash-table elements.\n"
1323 "Applies PROC successively on all hash table handles.")
1324 #define FUNC_NAME s_scm_hash_for_each_handle
1326 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)), proc
, 1, FUNC_NAME
);
1327 SCM_VALIDATE_HASHTABLE (2, table
);
1329 if (SCM_UNLIKELY (SCM_HASHTABLE_WEAK_P (table
)))
1330 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
1332 scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn
) scm_call_1
,
1333 (void *) SCM_UNPACK (proc
),
1335 return SCM_UNSPECIFIED
;
1340 map_proc (void *proc
, SCM key
, SCM data
, SCM value
)
1342 return scm_cons (scm_call_2 (SCM_PACK (proc
), key
, data
), value
);
1345 SCM_DEFINE (scm_hash_map_to_list
, "hash-map->list", 2, 0, 0,
1346 (SCM proc
, SCM table
),
1347 "An iterator over hash-table elements.\n"
1348 "Accumulates and returns as a list the results of applying PROC successively.\n"
1349 "The arguments to PROC are \"(key value)\" where key\n"
1350 "and value are successive pairs from the hash table TABLE.")
1351 #define FUNC_NAME s_scm_hash_map_to_list
1353 SCM_VALIDATE_PROC (1, proc
);
1354 SCM_VALIDATE_HASHTABLE (2, table
);
1355 return scm_internal_hash_fold (map_proc
,
1356 (void *) SCM_UNPACK (proc
),
1365 scm_internal_hash_fold (scm_t_hash_fold_fn fn
, void *closure
,
1366 SCM init
, SCM table
)
1367 #define FUNC_NAME s_scm_hash_fold
1370 SCM buckets
, result
= init
;
1372 SCM_VALIDATE_HASHTABLE (0, table
);
1373 buckets
= SCM_HASHTABLE_VECTOR (table
);
1375 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1376 for (i
= 0; i
< n
; ++i
)
1380 for (prev
= SCM_BOOL_F
, ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
);
1382 prev
= ls
, ls
= SCM_CDR (ls
))
1386 if (!scm_is_pair (ls
))
1387 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1389 handle
= SCM_CAR (ls
);
1390 if (!scm_is_pair (handle
))
1391 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1393 if (SCM_HASHTABLE_WEAK_P (table
))
1395 if (SCM_WEAK_PAIR_DELETED_P (handle
))
1397 /* We hit a weak pair whose car/cdr has become
1398 unreachable: unlink it from the bucket. */
1399 if (prev
!= SCM_BOOL_F
)
1400 SCM_SETCDR (prev
, SCM_CDR (ls
));
1402 SCM_SIMPLE_VECTOR_SET (buckets
, i
, SCM_CDR (ls
));
1404 /* Update the item count. */
1405 SCM_HASHTABLE_DECREMENT (table
);
1411 result
= fn (closure
, SCM_CAR (handle
), SCM_CDR (handle
), result
);
1419 /* The following redundant code is here in order to be able to support
1420 hash-for-each-handle. An alternative would have been to replace
1421 this code and scm_internal_hash_fold above with a single
1422 scm_internal_hash_fold_handles, but we don't want to promote such
1426 scm_internal_hash_for_each_handle (scm_t_hash_handle_fn fn
, void *closure
,
1428 #define FUNC_NAME s_scm_hash_for_each
1433 SCM_VALIDATE_HASHTABLE (0, table
);
1434 buckets
= SCM_HASHTABLE_VECTOR (table
);
1435 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1437 for (i
= 0; i
< n
; ++i
)
1439 SCM ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
), handle
;
1440 while (!scm_is_null (ls
))
1442 if (!scm_is_pair (ls
))
1443 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1444 handle
= SCM_CAR (ls
);
1445 if (!scm_is_pair (handle
))
1446 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1447 fn (closure
, handle
);
1460 #include "libguile/hashtab.x"