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
);
422 weak_gc_callback (void *ptr
, void *data
)
429 void (*callback
) (SCM
) = data
;
431 GC_REGISTER_FINALIZER_NO_ORDER (ptr
, weak_gc_callback
, data
, NULL
, NULL
);
433 callback (PTR2SCM (val
));
438 scm_c_register_weak_gc_callback (SCM obj
, void (*callback
) (SCM
))
440 void **weak
= GC_MALLOC_ATOMIC (sizeof (void**));
442 *weak
= SCM2PTR (obj
);
443 GC_GENERAL_REGISTER_DISAPPEARING_LINK (weak
, SCM2PTR (obj
));
445 GC_REGISTER_FINALIZER_NO_ORDER (weak
, weak_gc_callback
, (void*)callback
,
449 SCM_DEFINE (scm_make_weak_key_hash_table
, "make-weak-key-hash-table", 0, 1, 0,
451 "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
452 "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n"
453 "Return a weak hash table with @var{size} buckets.\n"
455 "You can modify weak hash tables in exactly the same way you\n"
456 "would modify regular hash tables. (@pxref{Hash Tables})")
457 #define FUNC_NAME s_scm_make_weak_key_hash_table
462 ret
= make_hash_table (SCM_HASHTABLEF_WEAK_CAR
, 0, FUNC_NAME
);
464 ret
= make_hash_table (SCM_HASHTABLEF_WEAK_CAR
,
465 scm_to_ulong (n
), FUNC_NAME
);
467 scm_c_register_weak_gc_callback (ret
, vacuum_weak_hash_table
);
474 SCM_DEFINE (scm_make_weak_value_hash_table
, "make-weak-value-hash-table", 0, 1, 0,
476 "Return a hash table with weak values with @var{size} buckets.\n"
477 "(@pxref{Hash Tables})")
478 #define FUNC_NAME s_scm_make_weak_value_hash_table
483 ret
= make_hash_table (SCM_HASHTABLEF_WEAK_CDR
, 0, FUNC_NAME
);
485 ret
= make_hash_table (SCM_HASHTABLEF_WEAK_CDR
,
486 scm_to_ulong (n
), FUNC_NAME
);
488 scm_c_register_weak_gc_callback (ret
, vacuum_weak_hash_table
);
495 SCM_DEFINE (scm_make_doubly_weak_hash_table
, "make-doubly-weak-hash-table", 1, 0, 0,
497 "Return a hash table with weak keys and values with @var{size}\n"
498 "buckets. (@pxref{Hash Tables})")
499 #define FUNC_NAME s_scm_make_doubly_weak_hash_table
504 ret
= make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
507 ret
= make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| 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_hash_table_p
, "hash-table?", 1, 0, 0,
519 "Return @code{#t} if @var{obj} is an abstract hash table object.")
520 #define FUNC_NAME s_scm_hash_table_p
522 return scm_from_bool (SCM_HASHTABLE_P (obj
));
527 SCM_DEFINE (scm_weak_key_hash_table_p
, "weak-key-hash-table?", 1, 0, 0,
529 "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n"
530 "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n"
531 "Return @code{#t} if @var{obj} is the specified weak hash\n"
532 "table. Note that a doubly weak hash table is neither a weak key\n"
533 "nor a weak value hash table.")
534 #define FUNC_NAME s_scm_weak_key_hash_table_p
536 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_KEY_P (obj
));
541 SCM_DEFINE (scm_weak_value_hash_table_p
, "weak-value-hash-table?", 1, 0, 0,
543 "Return @code{#t} if @var{obj} is a weak value hash table.")
544 #define FUNC_NAME s_scm_weak_value_hash_table_p
546 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_VALUE_P (obj
));
551 SCM_DEFINE (scm_doubly_weak_hash_table_p
, "doubly-weak-hash-table?", 1, 0, 0,
553 "Return @code{#t} if @var{obj} is a doubly weak hash table.")
554 #define FUNC_NAME s_scm_doubly_weak_hash_table_p
556 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_DOUBLY_WEAK_P (obj
));
561 /* Accessing hash table entries. */
564 scm_hash_fn_get_handle (SCM table
, SCM obj
,
565 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
567 #define FUNC_NAME "scm_hash_fn_get_handle"
572 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
573 buckets
= SCM_HASHTABLE_VECTOR (table
);
575 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
577 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
578 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
579 scm_out_of_range (FUNC_NAME
, scm_from_ulong (k
));
581 if (SCM_HASHTABLE_WEAK_P (table
))
582 h
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
583 assoc_fn
, obj
, closure
);
585 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
592 /* This procedure implements three optimizations, with respect to the
595 1. For weak tables, it's assumed that calling the predicate in the
596 allocation lock is safe. In practice this means that the predicate
597 cannot call arbitrary scheme functions.
599 2. We don't check for overflow / underflow and rehash.
601 3. We don't actually have to allocate a key -- instead we get the
602 hash value directly. This is useful for, for example, looking up
603 strings in the symbol table.
606 scm_hash_fn_get_handle_by_hash (SCM table
, unsigned long raw_hash
,
607 scm_t_hash_predicate_fn predicate_fn
,
609 #define FUNC_NAME "scm_hash_fn_ref_by_hash"
612 SCM buckets
, alist
, h
= SCM_BOOL_F
;
614 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
615 buckets
= SCM_HASHTABLE_VECTOR (table
);
617 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
620 k
= raw_hash
% SCM_SIMPLE_VECTOR_LENGTH (buckets
);
621 alist
= SCM_SIMPLE_VECTOR_REF (buckets
, k
);
623 if (SCM_HASHTABLE_WEAK_P (table
))
625 struct assoc_by_hash_data args
;
628 args
.ret
= SCM_BOOL_F
;
629 args
.predicate
= predicate_fn
;
630 args
.closure
= closure
;
631 GC_call_with_alloc_lock (weak_bucket_assoc_by_hash
, &args
);
635 for (; scm_is_pair (alist
); alist
= SCM_CDR (alist
))
637 SCM pair
= SCM_CAR (alist
);
638 if (predicate_fn (SCM_CAR (pair
), closure
))
651 scm_hash_fn_create_handle_x (SCM table
, SCM obj
, SCM init
,
652 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
654 #define FUNC_NAME "scm_hash_fn_create_handle_x"
659 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
660 buckets
= SCM_HASHTABLE_VECTOR (table
);
662 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
663 SCM_MISC_ERROR ("void hashtable", SCM_EOL
);
665 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
666 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
667 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
669 if (SCM_HASHTABLE_WEAK_P (table
))
670 it
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
671 assoc_fn
, obj
, closure
);
673 it
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
675 if (scm_is_pair (it
))
677 else if (scm_is_true (it
))
678 scm_wrong_type_arg_msg (NULL
, 0, it
, "a pair");
681 /* When this is a weak hashtable, running the GC can change it.
682 Thus, we must allocate the new cells first and can only then
683 access BUCKETS. Also, we need to fetch the bucket vector
684 again since the hashtable might have been rehashed. This
685 necessitates a new hash value as well.
687 SCM handle
, new_bucket
;
689 if (SCM_HASHTABLE_WEAK_P (table
))
691 /* FIXME: We don't support weak alist vectors. */
692 /* Use a weak cell. */
693 if (SCM_HASHTABLE_DOUBLY_WEAK_P (table
))
694 handle
= scm_doubly_weak_pair (obj
, init
);
695 else if (SCM_HASHTABLE_WEAK_KEY_P (table
))
696 handle
= scm_weak_car_pair (obj
, init
);
698 handle
= scm_weak_cdr_pair (obj
, init
);
701 /* Use a regular, non-weak cell. */
702 handle
= scm_cons (obj
, init
);
704 new_bucket
= scm_cons (handle
, SCM_EOL
);
706 if (!scm_is_eq (SCM_HASHTABLE_VECTOR (table
), buckets
))
708 buckets
= SCM_HASHTABLE_VECTOR (table
);
709 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
710 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
711 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
713 SCM_SETCDR (new_bucket
, SCM_SIMPLE_VECTOR_REF (buckets
, k
));
714 SCM_SIMPLE_VECTOR_SET (buckets
, k
, new_bucket
);
715 SCM_HASHTABLE_INCREMENT (table
);
717 /* Maybe rehash the table. */
718 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
)
719 || SCM_HASHTABLE_N_ITEMS (table
) > SCM_HASHTABLE_UPPER (table
))
720 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
721 return SCM_CAR (new_bucket
);
728 scm_hash_fn_ref (SCM table
, SCM obj
, SCM dflt
,
729 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
732 SCM it
= scm_hash_fn_get_handle (table
, obj
, hash_fn
, assoc_fn
, closure
);
733 if (scm_is_pair (it
))
743 scm_hash_fn_set_x (SCM table
, SCM obj
, SCM val
,
744 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
749 it
= scm_hash_fn_create_handle_x (table
, obj
, SCM_BOOL_F
, hash_fn
, assoc_fn
, closure
);
750 SCM_SETCDR (it
, val
);
752 if (SCM_HASHTABLE_WEAK_VALUE_P (table
) && SCM_NIMP (val
))
753 /* IT is a weak-cdr pair. Register a disappearing link from IT's
754 cdr to VAL like `scm_weak_cdr_pair' does. */
755 SCM_I_REGISTER_DISAPPEARING_LINK ((void *) SCM_CDRLOC (it
), SCM2PTR (val
));
762 scm_hash_fn_remove_x (SCM table
, SCM obj
,
763 scm_t_hash_fn hash_fn
,
764 scm_t_assoc_fn assoc_fn
,
766 #define FUNC_NAME "hash_fn_remove_x"
771 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
773 buckets
= SCM_HASHTABLE_VECTOR (table
);
775 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
778 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
779 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
780 scm_out_of_range (FUNC_NAME
, scm_from_ulong (k
));
782 if (SCM_HASHTABLE_WEAK_P (table
))
783 h
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
784 assoc_fn
, obj
, closure
);
786 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
790 SCM_SIMPLE_VECTOR_SET
791 (buckets
, k
, scm_delq_x (h
, SCM_SIMPLE_VECTOR_REF (buckets
, k
)));
792 SCM_HASHTABLE_DECREMENT (table
);
793 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
794 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
800 SCM_DEFINE (scm_hash_clear_x
, "hash-clear!", 1, 0, 0,
802 "Remove all items from @var{table} (without triggering a resize).")
803 #define FUNC_NAME s_scm_hash_clear_x
805 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
807 scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table
), SCM_EOL
);
808 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
810 return SCM_UNSPECIFIED
;
816 SCM_DEFINE (scm_hashq_get_handle
, "hashq-get-handle", 2, 0, 0,
817 (SCM table
, SCM key
),
818 "This procedure returns the @code{(key . value)} pair from the\n"
819 "hash table @var{table}. If @var{table} does not hold an\n"
820 "associated value for @var{key}, @code{#f} is returned.\n"
821 "Uses @code{eq?} for equality testing.")
822 #define FUNC_NAME s_scm_hashq_get_handle
824 return scm_hash_fn_get_handle (table
, key
,
825 (scm_t_hash_fn
) scm_ihashq
,
826 (scm_t_assoc_fn
) scm_sloppy_assq
,
832 SCM_DEFINE (scm_hashq_create_handle_x
, "hashq-create-handle!", 3, 0, 0,
833 (SCM table
, SCM key
, SCM init
),
834 "This function looks up @var{key} in @var{table} and returns its handle.\n"
835 "If @var{key} is not already present, a new handle is created which\n"
836 "associates @var{key} with @var{init}.")
837 #define FUNC_NAME s_scm_hashq_create_handle_x
839 return scm_hash_fn_create_handle_x (table
, key
, init
,
840 (scm_t_hash_fn
) scm_ihashq
,
841 (scm_t_assoc_fn
) scm_sloppy_assq
,
847 SCM_DEFINE (scm_hashq_ref
, "hashq-ref", 2, 1, 0,
848 (SCM table
, SCM key
, SCM dflt
),
849 "Look up @var{key} in the hash table @var{table}, and return the\n"
850 "value (if any) associated with it. If @var{key} is not found,\n"
851 "return @var{default} (or @code{#f} if no @var{default} argument\n"
852 "is supplied). Uses @code{eq?} for equality testing.")
853 #define FUNC_NAME s_scm_hashq_ref
855 if (SCM_UNBNDP (dflt
))
857 return scm_hash_fn_ref (table
, key
, dflt
,
858 (scm_t_hash_fn
) scm_ihashq
,
859 (scm_t_assoc_fn
) scm_sloppy_assq
,
866 SCM_DEFINE (scm_hashq_set_x
, "hashq-set!", 3, 0, 0,
867 (SCM table
, SCM key
, SCM val
),
868 "Find the entry in @var{table} associated with @var{key}, and\n"
869 "store @var{value} there. Uses @code{eq?} for equality testing.")
870 #define FUNC_NAME s_scm_hashq_set_x
872 return scm_hash_fn_set_x (table
, key
, val
,
873 (scm_t_hash_fn
) scm_ihashq
,
874 (scm_t_assoc_fn
) scm_sloppy_assq
,
881 SCM_DEFINE (scm_hashq_remove_x
, "hashq-remove!", 2, 0, 0,
882 (SCM table
, SCM key
),
883 "Remove @var{key} (and any value associated with it) from\n"
884 "@var{table}. Uses @code{eq?} for equality tests.")
885 #define FUNC_NAME s_scm_hashq_remove_x
887 return scm_hash_fn_remove_x (table
, key
,
888 (scm_t_hash_fn
) scm_ihashq
,
889 (scm_t_assoc_fn
) scm_sloppy_assq
,
897 SCM_DEFINE (scm_hashv_get_handle
, "hashv-get-handle", 2, 0, 0,
898 (SCM table
, SCM key
),
899 "This procedure returns the @code{(key . value)} pair from the\n"
900 "hash table @var{table}. If @var{table} does not hold an\n"
901 "associated value for @var{key}, @code{#f} is returned.\n"
902 "Uses @code{eqv?} for equality testing.")
903 #define FUNC_NAME s_scm_hashv_get_handle
905 return scm_hash_fn_get_handle (table
, key
,
906 (scm_t_hash_fn
) scm_ihashv
,
907 (scm_t_assoc_fn
) scm_sloppy_assv
,
913 SCM_DEFINE (scm_hashv_create_handle_x
, "hashv-create-handle!", 3, 0, 0,
914 (SCM table
, SCM key
, SCM init
),
915 "This function looks up @var{key} in @var{table} and returns its handle.\n"
916 "If @var{key} is not already present, a new handle is created which\n"
917 "associates @var{key} with @var{init}.")
918 #define FUNC_NAME s_scm_hashv_create_handle_x
920 return scm_hash_fn_create_handle_x (table
, key
, init
,
921 (scm_t_hash_fn
) scm_ihashv
,
922 (scm_t_assoc_fn
) scm_sloppy_assv
,
928 SCM_DEFINE (scm_hashv_ref
, "hashv-ref", 2, 1, 0,
929 (SCM table
, SCM key
, SCM dflt
),
930 "Look up @var{key} in the hash table @var{table}, and return the\n"
931 "value (if any) associated with it. If @var{key} is not found,\n"
932 "return @var{default} (or @code{#f} if no @var{default} argument\n"
933 "is supplied). Uses @code{eqv?} for equality testing.")
934 #define FUNC_NAME s_scm_hashv_ref
936 if (SCM_UNBNDP (dflt
))
938 return scm_hash_fn_ref (table
, key
, dflt
,
939 (scm_t_hash_fn
) scm_ihashv
,
940 (scm_t_assoc_fn
) scm_sloppy_assv
,
947 SCM_DEFINE (scm_hashv_set_x
, "hashv-set!", 3, 0, 0,
948 (SCM table
, SCM key
, SCM val
),
949 "Find the entry in @var{table} associated with @var{key}, and\n"
950 "store @var{value} there. Uses @code{eqv?} for equality testing.")
951 #define FUNC_NAME s_scm_hashv_set_x
953 return scm_hash_fn_set_x (table
, key
, val
,
954 (scm_t_hash_fn
) scm_ihashv
,
955 (scm_t_assoc_fn
) scm_sloppy_assv
,
961 SCM_DEFINE (scm_hashv_remove_x
, "hashv-remove!", 2, 0, 0,
962 (SCM table
, SCM key
),
963 "Remove @var{key} (and any value associated with it) from\n"
964 "@var{table}. Uses @code{eqv?} for equality tests.")
965 #define FUNC_NAME s_scm_hashv_remove_x
967 return scm_hash_fn_remove_x (table
, key
,
968 (scm_t_hash_fn
) scm_ihashv
,
969 (scm_t_assoc_fn
) scm_sloppy_assv
,
976 SCM_DEFINE (scm_hash_get_handle
, "hash-get-handle", 2, 0, 0,
977 (SCM table
, SCM key
),
978 "This procedure returns the @code{(key . value)} pair from the\n"
979 "hash table @var{table}. If @var{table} does not hold an\n"
980 "associated value for @var{key}, @code{#f} is returned.\n"
981 "Uses @code{equal?} for equality testing.")
982 #define FUNC_NAME s_scm_hash_get_handle
984 return scm_hash_fn_get_handle (table
, key
,
985 (scm_t_hash_fn
) scm_ihash
,
986 (scm_t_assoc_fn
) scm_sloppy_assoc
,
992 SCM_DEFINE (scm_hash_create_handle_x
, "hash-create-handle!", 3, 0, 0,
993 (SCM table
, SCM key
, SCM init
),
994 "This function looks up @var{key} in @var{table} and returns its handle.\n"
995 "If @var{key} is not already present, a new handle is created which\n"
996 "associates @var{key} with @var{init}.")
997 #define FUNC_NAME s_scm_hash_create_handle_x
999 return scm_hash_fn_create_handle_x (table
, key
, init
,
1000 (scm_t_hash_fn
) scm_ihash
,
1001 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1007 SCM_DEFINE (scm_hash_ref
, "hash-ref", 2, 1, 0,
1008 (SCM table
, SCM key
, SCM dflt
),
1009 "Look up @var{key} in the hash table @var{table}, and return the\n"
1010 "value (if any) associated with it. If @var{key} is not found,\n"
1011 "return @var{default} (or @code{#f} if no @var{default} argument\n"
1012 "is supplied). Uses @code{equal?} for equality testing.")
1013 #define FUNC_NAME s_scm_hash_ref
1015 if (SCM_UNBNDP (dflt
))
1017 return scm_hash_fn_ref (table
, key
, dflt
,
1018 (scm_t_hash_fn
) scm_ihash
,
1019 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1026 SCM_DEFINE (scm_hash_set_x
, "hash-set!", 3, 0, 0,
1027 (SCM table
, SCM key
, SCM val
),
1028 "Find the entry in @var{table} associated with @var{key}, and\n"
1029 "store @var{value} there. Uses @code{equal?} for equality\n"
1031 #define FUNC_NAME s_scm_hash_set_x
1033 return scm_hash_fn_set_x (table
, key
, val
,
1034 (scm_t_hash_fn
) scm_ihash
,
1035 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1042 SCM_DEFINE (scm_hash_remove_x
, "hash-remove!", 2, 0, 0,
1043 (SCM table
, SCM key
),
1044 "Remove @var{key} (and any value associated with it) from\n"
1045 "@var{table}. Uses @code{equal?} for equality tests.")
1046 #define FUNC_NAME s_scm_hash_remove_x
1048 return scm_hash_fn_remove_x (table
, key
,
1049 (scm_t_hash_fn
) scm_ihash
,
1050 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1058 typedef struct scm_t_ihashx_closure
1062 } scm_t_ihashx_closure
;
1066 static unsigned long
1067 scm_ihashx (SCM obj
, unsigned long n
, void *arg
)
1070 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
1071 answer
= scm_call_2 (closure
->hash
, obj
, scm_from_ulong (n
));
1072 return scm_to_ulong (answer
);
1078 scm_sloppy_assx (SCM obj
, SCM alist
, void *arg
)
1080 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
1081 return scm_call_2 (closure
->assoc
, obj
, alist
);
1085 SCM_DEFINE (scm_hashx_get_handle
, "hashx-get-handle", 4, 0, 0,
1086 (SCM hash
, SCM assoc
, SCM table
, SCM key
),
1087 "This behaves the same way as the corresponding\n"
1088 "@code{-get-handle} function, but uses @var{hash} as a hash\n"
1089 "function and @var{assoc} to compare keys. @code{hash} must be\n"
1090 "a function that takes two arguments, a key to be hashed and a\n"
1091 "table size. @code{assoc} must be an associator function, like\n"
1092 "@code{assoc}, @code{assq} or @code{assv}.")
1093 #define FUNC_NAME s_scm_hashx_get_handle
1095 scm_t_ihashx_closure closure
;
1096 closure
.hash
= hash
;
1097 closure
.assoc
= assoc
;
1098 return scm_hash_fn_get_handle (table
, key
, scm_ihashx
, scm_sloppy_assx
,
1104 SCM_DEFINE (scm_hashx_create_handle_x
, "hashx-create-handle!", 5, 0, 0,
1105 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM init
),
1106 "This behaves the same way as the corresponding\n"
1107 "@code{-create-handle} function, but uses @var{hash} as a hash\n"
1108 "function and @var{assoc} to compare keys. @code{hash} must be\n"
1109 "a function that takes two arguments, a key to be hashed and a\n"
1110 "table size. @code{assoc} must be an associator function, like\n"
1111 "@code{assoc}, @code{assq} or @code{assv}.")
1112 #define FUNC_NAME s_scm_hashx_create_handle_x
1114 scm_t_ihashx_closure closure
;
1115 closure
.hash
= hash
;
1116 closure
.assoc
= assoc
;
1117 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashx
,
1118 scm_sloppy_assx
, (void *)&closure
);
1124 SCM_DEFINE (scm_hashx_ref
, "hashx-ref", 4, 1, 0,
1125 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM dflt
),
1126 "This behaves the same way as the corresponding @code{ref}\n"
1127 "function, but uses @var{hash} as a hash function and\n"
1128 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1129 "that takes two arguments, a key to be hashed and a table size.\n"
1130 "@code{assoc} must be an associator function, like @code{assoc},\n"
1131 "@code{assq} or @code{assv}.\n"
1133 "By way of illustration, @code{hashq-ref table key} is\n"
1134 "equivalent to @code{hashx-ref hashq assq table key}.")
1135 #define FUNC_NAME s_scm_hashx_ref
1137 scm_t_ihashx_closure closure
;
1138 if (SCM_UNBNDP (dflt
))
1140 closure
.hash
= hash
;
1141 closure
.assoc
= assoc
;
1142 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashx
, scm_sloppy_assx
,
1150 SCM_DEFINE (scm_hashx_set_x
, "hashx-set!", 5, 0, 0,
1151 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM val
),
1152 "This behaves the same way as the corresponding @code{set!}\n"
1153 "function, but uses @var{hash} as a hash function and\n"
1154 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1155 "that takes two arguments, a key to be hashed and a table size.\n"
1156 "@code{assoc} must be an associator function, like @code{assoc},\n"
1157 "@code{assq} or @code{assv}.\n"
1159 " By way of illustration, @code{hashq-set! table key} is\n"
1160 "equivalent to @code{hashx-set! hashq assq table key}.")
1161 #define FUNC_NAME s_scm_hashx_set_x
1163 scm_t_ihashx_closure closure
;
1164 closure
.hash
= hash
;
1165 closure
.assoc
= assoc
;
1166 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashx
, scm_sloppy_assx
,
1171 SCM_DEFINE (scm_hashx_remove_x
, "hashx-remove!", 4, 0, 0,
1172 (SCM hash
, SCM assoc
, SCM table
, SCM obj
),
1173 "This behaves the same way as the corresponding @code{remove!}\n"
1174 "function, but uses @var{hash} as a hash function and\n"
1175 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1176 "that takes two arguments, a key to be hashed and a table size.\n"
1177 "@code{assoc} must be an associator function, like @code{assoc},\n"
1178 "@code{assq} or @code{assv}.\n"
1180 " By way of illustration, @code{hashq-remove! table key} is\n"
1181 "equivalent to @code{hashx-remove! hashq assq #f table key}.")
1182 #define FUNC_NAME s_scm_hashx_remove_x
1184 scm_t_ihashx_closure closure
;
1185 closure
.hash
= hash
;
1186 closure
.assoc
= assoc
;
1187 return scm_hash_fn_remove_x (table
, obj
, scm_ihashx
, scm_sloppy_assx
,
1192 /* Hash table iterators */
1194 SCM_DEFINE (scm_hash_fold
, "hash-fold", 3, 0, 0,
1195 (SCM proc
, SCM init
, SCM table
),
1196 "An iterator over hash-table elements.\n"
1197 "Accumulates and returns a result by applying PROC successively.\n"
1198 "The arguments to PROC are \"(key value prior-result)\" where key\n"
1199 "and value are successive pairs from the hash table TABLE, and\n"
1200 "prior-result is either INIT (for the first application of PROC)\n"
1201 "or the return value of the previous application of PROC.\n"
1202 "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
1203 "table into an a-list of key-value pairs.")
1204 #define FUNC_NAME s_scm_hash_fold
1206 SCM_VALIDATE_PROC (1, proc
);
1207 SCM_VALIDATE_HASHTABLE (3, table
);
1208 return scm_internal_hash_fold ((scm_t_hash_fold_fn
) scm_call_3
,
1209 (void *) SCM_UNPACK (proc
), init
, table
);
1214 for_each_proc (void *proc
, SCM handle
)
1216 return scm_call_2 (SCM_PACK (proc
), SCM_CAR (handle
), SCM_CDR (handle
));
1219 SCM_DEFINE (scm_hash_for_each
, "hash-for-each", 2, 0, 0,
1220 (SCM proc
, SCM table
),
1221 "An iterator over hash-table elements.\n"
1222 "Applies PROC successively on all hash table items.\n"
1223 "The arguments to PROC are \"(key value)\" where key\n"
1224 "and value are successive pairs from the hash table TABLE.")
1225 #define FUNC_NAME s_scm_hash_for_each
1227 SCM_VALIDATE_PROC (1, proc
);
1228 SCM_VALIDATE_HASHTABLE (2, table
);
1230 scm_internal_hash_for_each_handle (for_each_proc
,
1231 (void *) SCM_UNPACK (proc
),
1233 return SCM_UNSPECIFIED
;
1237 SCM_DEFINE (scm_hash_for_each_handle
, "hash-for-each-handle", 2, 0, 0,
1238 (SCM proc
, SCM table
),
1239 "An iterator over hash-table elements.\n"
1240 "Applies PROC successively on all hash table handles.")
1241 #define FUNC_NAME s_scm_hash_for_each_handle
1243 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)), proc
, 1, FUNC_NAME
);
1244 SCM_VALIDATE_HASHTABLE (2, table
);
1246 scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn
) scm_call_1
,
1247 (void *) SCM_UNPACK (proc
),
1249 return SCM_UNSPECIFIED
;
1254 map_proc (void *proc
, SCM key
, SCM data
, SCM value
)
1256 return scm_cons (scm_call_2 (SCM_PACK (proc
), key
, data
), value
);
1259 SCM_DEFINE (scm_hash_map_to_list
, "hash-map->list", 2, 0, 0,
1260 (SCM proc
, SCM table
),
1261 "An iterator over hash-table elements.\n"
1262 "Accumulates and returns as a list the results of applying PROC successively.\n"
1263 "The arguments to PROC are \"(key value)\" where key\n"
1264 "and value are successive pairs from the hash table TABLE.")
1265 #define FUNC_NAME s_scm_hash_map_to_list
1267 SCM_VALIDATE_PROC (1, proc
);
1268 SCM_VALIDATE_HASHTABLE (2, table
);
1269 return scm_internal_hash_fold (map_proc
,
1270 (void *) SCM_UNPACK (proc
),
1279 scm_internal_hash_fold (scm_t_hash_fold_fn fn
, void *closure
,
1280 SCM init
, SCM table
)
1281 #define FUNC_NAME s_scm_hash_fold
1284 SCM buckets
, result
= init
;
1286 SCM_VALIDATE_HASHTABLE (0, table
);
1287 buckets
= SCM_HASHTABLE_VECTOR (table
);
1289 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1290 for (i
= 0; i
< n
; ++i
)
1294 for (prev
= SCM_BOOL_F
, ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
);
1296 prev
= ls
, ls
= SCM_CDR (ls
))
1300 if (!scm_is_pair (ls
))
1301 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1303 handle
= SCM_CAR (ls
);
1304 if (!scm_is_pair (handle
))
1305 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1307 if (SCM_HASHTABLE_WEAK_P (table
))
1309 if (SCM_WEAK_PAIR_DELETED_P (handle
))
1311 /* We hit a weak pair whose car/cdr has become
1312 unreachable: unlink it from the bucket. */
1313 if (prev
!= SCM_BOOL_F
)
1314 SCM_SETCDR (prev
, SCM_CDR (ls
));
1316 SCM_SIMPLE_VECTOR_SET (buckets
, i
, SCM_CDR (ls
));
1318 /* Update the item count. */
1319 SCM_HASHTABLE_DECREMENT (table
);
1325 result
= fn (closure
, SCM_CAR (handle
), SCM_CDR (handle
), result
);
1333 /* The following redundant code is here in order to be able to support
1334 hash-for-each-handle. An alternative would have been to replace
1335 this code and scm_internal_hash_fold above with a single
1336 scm_internal_hash_fold_handles, but we don't want to promote such
1340 scm_internal_hash_for_each_handle (scm_t_hash_handle_fn fn
, void *closure
,
1342 #define FUNC_NAME s_scm_hash_for_each
1347 SCM_VALIDATE_HASHTABLE (0, table
);
1348 buckets
= SCM_HASHTABLE_VECTOR (table
);
1349 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1351 for (i
= 0; i
< n
; ++i
)
1353 SCM ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
), handle
;
1354 while (!scm_is_null (ls
))
1356 if (!scm_is_pair (ls
))
1357 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1358 handle
= SCM_CAR (ls
);
1359 if (!scm_is_pair (handle
))
1360 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1361 fn (closure
, handle
);
1374 #include "libguile/hashtab.x"