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
))
770 get_weak_cdr (void *data
)
772 struct weak_cdr_data
*d
= data
;
774 if (SCM_WEAK_PAIR_CDR_DELETED_P (d
->pair
))
777 d
->cdr
= SCM_CDR (d
->pair
);
783 weak_pair_cdr (SCM x
)
785 struct weak_cdr_data data
;
788 GC_call_with_alloc_lock (get_weak_cdr
, &data
);
794 scm_hash_fn_set_x (SCM table
, SCM obj
, SCM val
,
795 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
800 pair
= scm_hash_fn_create_handle_x (table
, obj
, val
,
801 hash_fn
, assoc_fn
, closure
);
803 if (!scm_is_eq (SCM_CDR (pair
), val
))
805 if (SCM_UNLIKELY (SCM_HASHTABLE_WEAK_VALUE_P (table
)))
807 /* If the former value was on the heap, we need to unregister
809 SCM prev
= weak_pair_cdr (pair
);
811 SCM_SETCDR (pair
, val
);
813 if (SCM_NIMP (prev
) && !SCM_NIMP (val
))
814 GC_unregister_disappearing_link ((GC_PTR
) SCM_CDRLOC (pair
));
816 SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR
) SCM_CDRLOC (pair
),
817 (GC_PTR
) SCM2PTR (val
));
820 SCM_SETCDR (pair
, val
);
828 scm_hash_fn_remove_x (SCM table
, SCM obj
,
829 scm_t_hash_fn hash_fn
,
830 scm_t_assoc_fn assoc_fn
,
832 #define FUNC_NAME "hash_fn_remove_x"
837 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
839 buckets
= SCM_HASHTABLE_VECTOR (table
);
841 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
844 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
845 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
846 scm_out_of_range (FUNC_NAME
, scm_from_ulong (k
));
848 if (SCM_HASHTABLE_WEAK_P (table
))
849 h
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
850 assoc_fn
, obj
, closure
);
852 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
856 SCM_SIMPLE_VECTOR_SET
857 (buckets
, k
, scm_delq_x (h
, SCM_SIMPLE_VECTOR_REF (buckets
, k
)));
858 SCM_HASHTABLE_DECREMENT (table
);
859 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
860 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
866 SCM_DEFINE (scm_hash_clear_x
, "hash-clear!", 1, 0, 0,
868 "Remove all items from @var{table} (without triggering a resize).")
869 #define FUNC_NAME s_scm_hash_clear_x
871 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
873 scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table
), SCM_EOL
);
874 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
876 return SCM_UNSPECIFIED
;
882 SCM_DEFINE (scm_hashq_get_handle
, "hashq-get-handle", 2, 0, 0,
883 (SCM table
, SCM key
),
884 "This procedure returns the @code{(key . value)} pair from the\n"
885 "hash table @var{table}. If @var{table} does not hold an\n"
886 "associated value for @var{key}, @code{#f} is returned.\n"
887 "Uses @code{eq?} for equality testing.")
888 #define FUNC_NAME s_scm_hashq_get_handle
890 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
891 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
893 return scm_hash_fn_get_handle (table
, key
,
894 (scm_t_hash_fn
) scm_ihashq
,
895 (scm_t_assoc_fn
) scm_sloppy_assq
,
901 SCM_DEFINE (scm_hashq_create_handle_x
, "hashq-create-handle!", 3, 0, 0,
902 (SCM table
, SCM key
, SCM init
),
903 "This function looks up @var{key} in @var{table} and returns its handle.\n"
904 "If @var{key} is not already present, a new handle is created which\n"
905 "associates @var{key} with @var{init}.")
906 #define FUNC_NAME s_scm_hashq_create_handle_x
908 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
909 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
911 return scm_hash_fn_create_handle_x (table
, key
, init
,
912 (scm_t_hash_fn
) scm_ihashq
,
913 (scm_t_assoc_fn
) scm_sloppy_assq
,
919 SCM_DEFINE (scm_hashq_ref
, "hashq-ref", 2, 1, 0,
920 (SCM table
, SCM key
, SCM dflt
),
921 "Look up @var{key} in the hash table @var{table}, and return the\n"
922 "value (if any) associated with it. If @var{key} is not found,\n"
923 "return @var{default} (or @code{#f} if no @var{default} argument\n"
924 "is supplied). Uses @code{eq?} for equality testing.")
925 #define FUNC_NAME s_scm_hashq_ref
927 if (SCM_UNBNDP (dflt
))
929 return scm_hash_fn_ref (table
, key
, dflt
,
930 (scm_t_hash_fn
) scm_ihashq
,
931 (scm_t_assoc_fn
) scm_sloppy_assq
,
938 SCM_DEFINE (scm_hashq_set_x
, "hashq-set!", 3, 0, 0,
939 (SCM table
, SCM key
, SCM val
),
940 "Find the entry in @var{table} associated with @var{key}, and\n"
941 "store @var{value} there. Uses @code{eq?} for equality testing.")
942 #define FUNC_NAME s_scm_hashq_set_x
944 return scm_hash_fn_set_x (table
, key
, val
,
945 (scm_t_hash_fn
) scm_ihashq
,
946 (scm_t_assoc_fn
) scm_sloppy_assq
,
953 SCM_DEFINE (scm_hashq_remove_x
, "hashq-remove!", 2, 0, 0,
954 (SCM table
, SCM key
),
955 "Remove @var{key} (and any value associated with it) from\n"
956 "@var{table}. Uses @code{eq?} for equality tests.")
957 #define FUNC_NAME s_scm_hashq_remove_x
959 return scm_hash_fn_remove_x (table
, key
,
960 (scm_t_hash_fn
) scm_ihashq
,
961 (scm_t_assoc_fn
) scm_sloppy_assq
,
969 SCM_DEFINE (scm_hashv_get_handle
, "hashv-get-handle", 2, 0, 0,
970 (SCM table
, SCM key
),
971 "This procedure returns the @code{(key . value)} pair from the\n"
972 "hash table @var{table}. If @var{table} does not hold an\n"
973 "associated value for @var{key}, @code{#f} is returned.\n"
974 "Uses @code{eqv?} for equality testing.")
975 #define FUNC_NAME s_scm_hashv_get_handle
977 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
978 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
980 return scm_hash_fn_get_handle (table
, key
,
981 (scm_t_hash_fn
) scm_ihashv
,
982 (scm_t_assoc_fn
) scm_sloppy_assv
,
988 SCM_DEFINE (scm_hashv_create_handle_x
, "hashv-create-handle!", 3, 0, 0,
989 (SCM table
, SCM key
, SCM init
),
990 "This function looks up @var{key} in @var{table} and returns its handle.\n"
991 "If @var{key} is not already present, a new handle is created which\n"
992 "associates @var{key} with @var{init}.")
993 #define FUNC_NAME s_scm_hashv_create_handle_x
995 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
996 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
998 return scm_hash_fn_create_handle_x (table
, key
, init
,
999 (scm_t_hash_fn
) scm_ihashv
,
1000 (scm_t_assoc_fn
) scm_sloppy_assv
,
1006 SCM_DEFINE (scm_hashv_ref
, "hashv-ref", 2, 1, 0,
1007 (SCM table
, SCM key
, SCM dflt
),
1008 "Look up @var{key} in the hash table @var{table}, and return the\n"
1009 "value (if any) associated with it. If @var{key} is not found,\n"
1010 "return @var{default} (or @code{#f} if no @var{default} argument\n"
1011 "is supplied). Uses @code{eqv?} for equality testing.")
1012 #define FUNC_NAME s_scm_hashv_ref
1014 if (SCM_UNBNDP (dflt
))
1016 return scm_hash_fn_ref (table
, key
, dflt
,
1017 (scm_t_hash_fn
) scm_ihashv
,
1018 (scm_t_assoc_fn
) scm_sloppy_assv
,
1025 SCM_DEFINE (scm_hashv_set_x
, "hashv-set!", 3, 0, 0,
1026 (SCM table
, SCM key
, SCM val
),
1027 "Find the entry in @var{table} associated with @var{key}, and\n"
1028 "store @var{value} there. Uses @code{eqv?} for equality testing.")
1029 #define FUNC_NAME s_scm_hashv_set_x
1031 return scm_hash_fn_set_x (table
, key
, val
,
1032 (scm_t_hash_fn
) scm_ihashv
,
1033 (scm_t_assoc_fn
) scm_sloppy_assv
,
1039 SCM_DEFINE (scm_hashv_remove_x
, "hashv-remove!", 2, 0, 0,
1040 (SCM table
, SCM key
),
1041 "Remove @var{key} (and any value associated with it) from\n"
1042 "@var{table}. Uses @code{eqv?} for equality tests.")
1043 #define FUNC_NAME s_scm_hashv_remove_x
1045 return scm_hash_fn_remove_x (table
, key
,
1046 (scm_t_hash_fn
) scm_ihashv
,
1047 (scm_t_assoc_fn
) scm_sloppy_assv
,
1054 SCM_DEFINE (scm_hash_get_handle
, "hash-get-handle", 2, 0, 0,
1055 (SCM table
, SCM key
),
1056 "This procedure returns the @code{(key . value)} pair from the\n"
1057 "hash table @var{table}. If @var{table} does not hold an\n"
1058 "associated value for @var{key}, @code{#f} is returned.\n"
1059 "Uses @code{equal?} for equality testing.")
1060 #define FUNC_NAME s_scm_hash_get_handle
1062 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
1063 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
1065 return scm_hash_fn_get_handle (table
, key
,
1066 (scm_t_hash_fn
) scm_ihash
,
1067 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1073 SCM_DEFINE (scm_hash_create_handle_x
, "hash-create-handle!", 3, 0, 0,
1074 (SCM table
, SCM key
, SCM init
),
1075 "This function looks up @var{key} in @var{table} and returns its handle.\n"
1076 "If @var{key} is not already present, a new handle is created which\n"
1077 "associates @var{key} with @var{init}.")
1078 #define FUNC_NAME s_scm_hash_create_handle_x
1080 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
1081 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
1083 return scm_hash_fn_create_handle_x (table
, key
, init
,
1084 (scm_t_hash_fn
) scm_ihash
,
1085 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1091 SCM_DEFINE (scm_hash_ref
, "hash-ref", 2, 1, 0,
1092 (SCM table
, SCM key
, SCM dflt
),
1093 "Look up @var{key} in the hash table @var{table}, and return the\n"
1094 "value (if any) associated with it. If @var{key} is not found,\n"
1095 "return @var{default} (or @code{#f} if no @var{default} argument\n"
1096 "is supplied). Uses @code{equal?} for equality testing.")
1097 #define FUNC_NAME s_scm_hash_ref
1099 if (SCM_UNBNDP (dflt
))
1101 return scm_hash_fn_ref (table
, key
, dflt
,
1102 (scm_t_hash_fn
) scm_ihash
,
1103 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1110 SCM_DEFINE (scm_hash_set_x
, "hash-set!", 3, 0, 0,
1111 (SCM table
, SCM key
, SCM val
),
1112 "Find the entry in @var{table} associated with @var{key}, and\n"
1113 "store @var{value} there. Uses @code{equal?} for equality\n"
1115 #define FUNC_NAME s_scm_hash_set_x
1117 return scm_hash_fn_set_x (table
, key
, val
,
1118 (scm_t_hash_fn
) scm_ihash
,
1119 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1126 SCM_DEFINE (scm_hash_remove_x
, "hash-remove!", 2, 0, 0,
1127 (SCM table
, SCM key
),
1128 "Remove @var{key} (and any value associated with it) from\n"
1129 "@var{table}. Uses @code{equal?} for equality tests.")
1130 #define FUNC_NAME s_scm_hash_remove_x
1132 return scm_hash_fn_remove_x (table
, key
,
1133 (scm_t_hash_fn
) scm_ihash
,
1134 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1142 typedef struct scm_t_ihashx_closure
1146 } scm_t_ihashx_closure
;
1150 static unsigned long
1151 scm_ihashx (SCM obj
, unsigned long n
, void *arg
)
1154 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
1155 answer
= scm_call_2 (closure
->hash
, obj
, scm_from_ulong (n
));
1156 return scm_to_ulong (answer
);
1162 scm_sloppy_assx (SCM obj
, SCM alist
, void *arg
)
1164 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
1165 return scm_call_2 (closure
->assoc
, obj
, alist
);
1169 SCM_DEFINE (scm_hashx_get_handle
, "hashx-get-handle", 4, 0, 0,
1170 (SCM hash
, SCM assoc
, SCM table
, SCM key
),
1171 "This behaves the same way as the corresponding\n"
1172 "@code{-get-handle} function, but uses @var{hash} as a hash\n"
1173 "function and @var{assoc} to compare keys. @code{hash} must be\n"
1174 "a function that takes two arguments, a key to be hashed and a\n"
1175 "table size. @code{assoc} must be an associator function, like\n"
1176 "@code{assoc}, @code{assq} or @code{assv}.")
1177 #define FUNC_NAME s_scm_hashx_get_handle
1179 scm_t_ihashx_closure closure
;
1180 closure
.hash
= hash
;
1181 closure
.assoc
= assoc
;
1183 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
1184 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
1186 return scm_hash_fn_get_handle (table
, key
, scm_ihashx
, scm_sloppy_assx
,
1192 SCM_DEFINE (scm_hashx_create_handle_x
, "hashx-create-handle!", 5, 0, 0,
1193 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM init
),
1194 "This behaves the same way as the corresponding\n"
1195 "@code{-create-handle} function, but uses @var{hash} as a hash\n"
1196 "function and @var{assoc} to compare keys. @code{hash} must be\n"
1197 "a function that takes two arguments, a key to be hashed and a\n"
1198 "table size. @code{assoc} must be an associator function, like\n"
1199 "@code{assoc}, @code{assq} or @code{assv}.")
1200 #define FUNC_NAME s_scm_hashx_create_handle_x
1202 scm_t_ihashx_closure closure
;
1203 closure
.hash
= hash
;
1204 closure
.assoc
= assoc
;
1206 if (SCM_UNLIKELY (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_P (table
)))
1207 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
1209 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashx
,
1210 scm_sloppy_assx
, (void *)&closure
);
1216 SCM_DEFINE (scm_hashx_ref
, "hashx-ref", 4, 1, 0,
1217 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM dflt
),
1218 "This behaves the same way as the corresponding @code{ref}\n"
1219 "function, but uses @var{hash} as a hash function and\n"
1220 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1221 "that takes two arguments, a key to be hashed and a table size.\n"
1222 "@code{assoc} must be an associator function, like @code{assoc},\n"
1223 "@code{assq} or @code{assv}.\n"
1225 "By way of illustration, @code{hashq-ref table key} is\n"
1226 "equivalent to @code{hashx-ref hashq assq table key}.")
1227 #define FUNC_NAME s_scm_hashx_ref
1229 scm_t_ihashx_closure closure
;
1230 if (SCM_UNBNDP (dflt
))
1232 closure
.hash
= hash
;
1233 closure
.assoc
= assoc
;
1234 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashx
, scm_sloppy_assx
,
1242 SCM_DEFINE (scm_hashx_set_x
, "hashx-set!", 5, 0, 0,
1243 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM val
),
1244 "This behaves the same way as the corresponding @code{set!}\n"
1245 "function, but uses @var{hash} as a hash function and\n"
1246 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1247 "that takes two arguments, a key to be hashed and a table size.\n"
1248 "@code{assoc} must be an associator function, like @code{assoc},\n"
1249 "@code{assq} or @code{assv}.\n"
1251 " By way of illustration, @code{hashq-set! table key} is\n"
1252 "equivalent to @code{hashx-set! hashq assq table key}.")
1253 #define FUNC_NAME s_scm_hashx_set_x
1255 scm_t_ihashx_closure closure
;
1256 closure
.hash
= hash
;
1257 closure
.assoc
= assoc
;
1258 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashx
, scm_sloppy_assx
,
1263 SCM_DEFINE (scm_hashx_remove_x
, "hashx-remove!", 4, 0, 0,
1264 (SCM hash
, SCM assoc
, SCM table
, SCM obj
),
1265 "This behaves the same way as the corresponding @code{remove!}\n"
1266 "function, but uses @var{hash} as a hash function and\n"
1267 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1268 "that takes two arguments, a key to be hashed and a table size.\n"
1269 "@code{assoc} must be an associator function, like @code{assoc},\n"
1270 "@code{assq} or @code{assv}.\n"
1272 " By way of illustration, @code{hashq-remove! table key} is\n"
1273 "equivalent to @code{hashx-remove! hashq assq #f table key}.")
1274 #define FUNC_NAME s_scm_hashx_remove_x
1276 scm_t_ihashx_closure closure
;
1277 closure
.hash
= hash
;
1278 closure
.assoc
= assoc
;
1279 return scm_hash_fn_remove_x (table
, obj
, scm_ihashx
, scm_sloppy_assx
,
1284 /* Hash table iterators */
1286 SCM_DEFINE (scm_hash_fold
, "hash-fold", 3, 0, 0,
1287 (SCM proc
, SCM init
, SCM table
),
1288 "An iterator over hash-table elements.\n"
1289 "Accumulates and returns a result by applying PROC successively.\n"
1290 "The arguments to PROC are \"(key value prior-result)\" where key\n"
1291 "and value are successive pairs from the hash table TABLE, and\n"
1292 "prior-result is either INIT (for the first application of PROC)\n"
1293 "or the return value of the previous application of PROC.\n"
1294 "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
1295 "table into an a-list of key-value pairs.")
1296 #define FUNC_NAME s_scm_hash_fold
1298 SCM_VALIDATE_PROC (1, proc
);
1299 SCM_VALIDATE_HASHTABLE (3, table
);
1300 return scm_internal_hash_fold ((scm_t_hash_fold_fn
) scm_call_3
,
1301 (void *) SCM_UNPACK (proc
), init
, table
);
1306 for_each_proc (void *proc
, SCM handle
)
1308 return scm_call_2 (SCM_PACK (proc
), SCM_CAR (handle
), SCM_CDR (handle
));
1311 SCM_DEFINE (scm_hash_for_each
, "hash-for-each", 2, 0, 0,
1312 (SCM proc
, SCM table
),
1313 "An iterator over hash-table elements.\n"
1314 "Applies PROC successively on all hash table items.\n"
1315 "The arguments to PROC are \"(key value)\" where key\n"
1316 "and value are successive pairs from the hash table TABLE.")
1317 #define FUNC_NAME s_scm_hash_for_each
1319 SCM_VALIDATE_PROC (1, proc
);
1320 SCM_VALIDATE_HASHTABLE (2, table
);
1322 scm_internal_hash_for_each_handle (for_each_proc
,
1323 (void *) SCM_UNPACK (proc
),
1325 return SCM_UNSPECIFIED
;
1329 SCM_DEFINE (scm_hash_for_each_handle
, "hash-for-each-handle", 2, 0, 0,
1330 (SCM proc
, SCM table
),
1331 "An iterator over hash-table elements.\n"
1332 "Applies PROC successively on all hash table handles.")
1333 #define FUNC_NAME s_scm_hash_for_each_handle
1335 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)), proc
, 1, FUNC_NAME
);
1336 SCM_VALIDATE_HASHTABLE (2, table
);
1338 if (SCM_UNLIKELY (SCM_HASHTABLE_WEAK_P (table
)))
1339 SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL
);
1341 scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn
) scm_call_1
,
1342 (void *) SCM_UNPACK (proc
),
1344 return SCM_UNSPECIFIED
;
1349 map_proc (void *proc
, SCM key
, SCM data
, SCM value
)
1351 return scm_cons (scm_call_2 (SCM_PACK (proc
), key
, data
), value
);
1354 SCM_DEFINE (scm_hash_map_to_list
, "hash-map->list", 2, 0, 0,
1355 (SCM proc
, SCM table
),
1356 "An iterator over hash-table elements.\n"
1357 "Accumulates and returns as a list the results of applying PROC successively.\n"
1358 "The arguments to PROC are \"(key value)\" where key\n"
1359 "and value are successive pairs from the hash table TABLE.")
1360 #define FUNC_NAME s_scm_hash_map_to_list
1362 SCM_VALIDATE_PROC (1, proc
);
1363 SCM_VALIDATE_HASHTABLE (2, table
);
1364 return scm_internal_hash_fold (map_proc
,
1365 (void *) SCM_UNPACK (proc
),
1374 scm_internal_hash_fold (scm_t_hash_fold_fn fn
, void *closure
,
1375 SCM init
, SCM table
)
1376 #define FUNC_NAME s_scm_hash_fold
1379 SCM buckets
, result
= init
;
1381 SCM_VALIDATE_HASHTABLE (0, table
);
1382 buckets
= SCM_HASHTABLE_VECTOR (table
);
1384 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1385 for (i
= 0; i
< n
; ++i
)
1389 for (ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
); !scm_is_null (ls
);
1392 handle
= SCM_CAR (ls
);
1394 if (SCM_HASHTABLE_WEAK_P (table
) && SCM_WEAK_PAIR_DELETED_P (handle
))
1395 /* Don't try to unlink this weak pair, as we're not within
1396 the allocation lock. Instead rely on
1397 vacuum_weak_hash_table to do its job. */
1400 result
= fn (closure
, SCM_CAR (handle
), SCM_CDR (handle
), result
);
1408 /* The following redundant code is here in order to be able to support
1409 hash-for-each-handle. An alternative would have been to replace
1410 this code and scm_internal_hash_fold above with a single
1411 scm_internal_hash_fold_handles, but we don't want to promote such
1415 scm_internal_hash_for_each_handle (scm_t_hash_handle_fn fn
, void *closure
,
1417 #define FUNC_NAME s_scm_hash_for_each
1422 SCM_VALIDATE_HASHTABLE (0, table
);
1423 buckets
= SCM_HASHTABLE_VECTOR (table
);
1424 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1426 for (i
= 0; i
< n
; ++i
)
1428 SCM ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
), handle
;
1429 while (!scm_is_null (ls
))
1431 if (!scm_is_pair (ls
))
1432 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1433 handle
= SCM_CAR (ls
);
1434 if (!scm_is_pair (handle
))
1435 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1436 fn (closure
, handle
);
1449 #include "libguile/hashtab.x"