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
460 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
, 0, FUNC_NAME
);
462 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
,
463 scm_to_ulong (n
), FUNC_NAME
);
468 SCM_DEFINE (scm_make_weak_value_hash_table
, "make-weak-value-hash-table", 0, 1, 0,
470 "Return a hash table with weak values with @var{size} buckets.\n"
471 "(@pxref{Hash Tables})")
472 #define FUNC_NAME s_scm_make_weak_value_hash_table
477 ret
= make_hash_table (SCM_HASHTABLEF_WEAK_CDR
, 0, FUNC_NAME
);
479 ret
= make_hash_table (SCM_HASHTABLEF_WEAK_CDR
,
480 scm_to_ulong (n
), FUNC_NAME
);
482 scm_c_register_weak_gc_callback (ret
, vacuum_weak_hash_table
);
489 SCM_DEFINE (scm_make_doubly_weak_hash_table
, "make-doubly-weak-hash-table", 1, 0, 0,
491 "Return a hash table with weak keys and values with @var{size}\n"
492 "buckets. (@pxref{Hash Tables})")
493 #define FUNC_NAME s_scm_make_doubly_weak_hash_table
498 ret
= make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
501 ret
= make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
502 scm_to_ulong (n
), FUNC_NAME
);
504 scm_c_register_weak_gc_callback (ret
, vacuum_weak_hash_table
);
511 SCM_DEFINE (scm_hash_table_p
, "hash-table?", 1, 0, 0,
513 "Return @code{#t} if @var{obj} is an abstract hash table object.")
514 #define FUNC_NAME s_scm_hash_table_p
516 return scm_from_bool (SCM_HASHTABLE_P (obj
));
521 SCM_DEFINE (scm_weak_key_hash_table_p
, "weak-key-hash-table?", 1, 0, 0,
523 "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n"
524 "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n"
525 "Return @code{#t} if @var{obj} is the specified weak hash\n"
526 "table. Note that a doubly weak hash table is neither a weak key\n"
527 "nor a weak value hash table.")
528 #define FUNC_NAME s_scm_weak_key_hash_table_p
530 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_KEY_P (obj
));
535 SCM_DEFINE (scm_weak_value_hash_table_p
, "weak-value-hash-table?", 1, 0, 0,
537 "Return @code{#t} if @var{obj} is a weak value hash table.")
538 #define FUNC_NAME s_scm_weak_value_hash_table_p
540 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_VALUE_P (obj
));
545 SCM_DEFINE (scm_doubly_weak_hash_table_p
, "doubly-weak-hash-table?", 1, 0, 0,
547 "Return @code{#t} if @var{obj} is a doubly weak hash table.")
548 #define FUNC_NAME s_scm_doubly_weak_hash_table_p
550 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_DOUBLY_WEAK_P (obj
));
555 /* Accessing hash table entries. */
558 scm_hash_fn_get_handle (SCM table
, SCM obj
,
559 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
561 #define FUNC_NAME "scm_hash_fn_get_handle"
566 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
567 buckets
= SCM_HASHTABLE_VECTOR (table
);
569 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
571 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
572 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
573 scm_out_of_range (FUNC_NAME
, scm_from_ulong (k
));
575 if (SCM_HASHTABLE_WEAK_P (table
))
576 h
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
577 assoc_fn
, obj
, closure
);
579 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
586 /* This procedure implements three optimizations, with respect to the
589 1. For weak tables, it's assumed that calling the predicate in the
590 allocation lock is safe. In practice this means that the predicate
591 cannot call arbitrary scheme functions.
593 2. We don't check for overflow / underflow and rehash.
595 3. We don't actually have to allocate a key -- instead we get the
596 hash value directly. This is useful for, for example, looking up
597 strings in the symbol table.
600 scm_hash_fn_get_handle_by_hash (SCM table
, unsigned long raw_hash
,
601 scm_t_hash_predicate_fn predicate_fn
,
603 #define FUNC_NAME "scm_hash_fn_ref_by_hash"
606 SCM buckets
, alist
, h
= SCM_BOOL_F
;
608 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
609 buckets
= SCM_HASHTABLE_VECTOR (table
);
611 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
614 k
= raw_hash
% SCM_SIMPLE_VECTOR_LENGTH (buckets
);
615 alist
= SCM_SIMPLE_VECTOR_REF (buckets
, k
);
617 if (SCM_HASHTABLE_WEAK_P (table
))
619 struct assoc_by_hash_data args
;
622 args
.ret
= SCM_BOOL_F
;
623 args
.predicate
= predicate_fn
;
624 args
.closure
= closure
;
625 GC_call_with_alloc_lock (weak_bucket_assoc_by_hash
, &args
);
629 for (; scm_is_pair (alist
); alist
= SCM_CDR (alist
))
631 SCM pair
= SCM_CAR (alist
);
632 if (predicate_fn (SCM_CAR (pair
), closure
))
645 scm_hash_fn_create_handle_x (SCM table
, SCM obj
, SCM init
,
646 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
648 #define FUNC_NAME "scm_hash_fn_create_handle_x"
653 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
654 buckets
= SCM_HASHTABLE_VECTOR (table
);
656 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
657 SCM_MISC_ERROR ("void hashtable", SCM_EOL
);
659 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
660 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
661 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
663 if (SCM_HASHTABLE_WEAK_P (table
))
664 it
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
665 assoc_fn
, obj
, closure
);
667 it
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
669 if (scm_is_pair (it
))
671 else if (scm_is_true (it
))
672 scm_wrong_type_arg_msg (NULL
, 0, it
, "a pair");
675 /* When this is a weak hashtable, running the GC can change it.
676 Thus, we must allocate the new cells first and can only then
677 access BUCKETS. Also, we need to fetch the bucket vector
678 again since the hashtable might have been rehashed. This
679 necessitates a new hash value as well.
681 SCM handle
, new_bucket
;
683 if (SCM_HASHTABLE_WEAK_P (table
))
685 /* FIXME: We don't support weak alist vectors. */
686 /* Use a weak cell. */
687 if (SCM_HASHTABLE_DOUBLY_WEAK_P (table
))
688 handle
= scm_doubly_weak_pair (obj
, init
);
689 else if (SCM_HASHTABLE_WEAK_KEY_P (table
))
690 handle
= scm_weak_car_pair (obj
, init
);
692 handle
= scm_weak_cdr_pair (obj
, init
);
695 /* Use a regular, non-weak cell. */
696 handle
= scm_cons (obj
, init
);
698 new_bucket
= scm_cons (handle
, SCM_EOL
);
700 if (!scm_is_eq (SCM_HASHTABLE_VECTOR (table
), buckets
))
702 buckets
= SCM_HASHTABLE_VECTOR (table
);
703 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
704 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
705 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
707 SCM_SETCDR (new_bucket
, SCM_SIMPLE_VECTOR_REF (buckets
, k
));
708 SCM_SIMPLE_VECTOR_SET (buckets
, k
, new_bucket
);
709 SCM_HASHTABLE_INCREMENT (table
);
711 /* Maybe rehash the table. */
712 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
)
713 || SCM_HASHTABLE_N_ITEMS (table
) > SCM_HASHTABLE_UPPER (table
))
714 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
715 return SCM_CAR (new_bucket
);
722 scm_hash_fn_ref (SCM table
, SCM obj
, SCM dflt
,
723 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
726 SCM it
= scm_hash_fn_get_handle (table
, obj
, hash_fn
, assoc_fn
, closure
);
727 if (scm_is_pair (it
))
737 scm_hash_fn_set_x (SCM table
, SCM obj
, SCM val
,
738 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
743 it
= scm_hash_fn_create_handle_x (table
, obj
, SCM_BOOL_F
, hash_fn
, assoc_fn
, closure
);
744 SCM_SETCDR (it
, val
);
746 if (SCM_HASHTABLE_WEAK_VALUE_P (table
) && SCM_NIMP (val
))
747 /* IT is a weak-cdr pair. Register a disappearing link from IT's
748 cdr to VAL like `scm_weak_cdr_pair' does. */
749 SCM_I_REGISTER_DISAPPEARING_LINK ((void *) SCM_CDRLOC (it
), SCM2PTR (val
));
756 scm_hash_fn_remove_x (SCM table
, SCM obj
,
757 scm_t_hash_fn hash_fn
,
758 scm_t_assoc_fn assoc_fn
,
760 #define FUNC_NAME "hash_fn_remove_x"
765 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
767 buckets
= SCM_HASHTABLE_VECTOR (table
);
769 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
772 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
773 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
774 scm_out_of_range (FUNC_NAME
, scm_from_ulong (k
));
776 if (SCM_HASHTABLE_WEAK_P (table
))
777 h
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
778 assoc_fn
, obj
, closure
);
780 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
784 SCM_SIMPLE_VECTOR_SET
785 (buckets
, k
, scm_delq_x (h
, SCM_SIMPLE_VECTOR_REF (buckets
, k
)));
786 SCM_HASHTABLE_DECREMENT (table
);
787 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
788 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
794 SCM_DEFINE (scm_hash_clear_x
, "hash-clear!", 1, 0, 0,
796 "Remove all items from @var{table} (without triggering a resize).")
797 #define FUNC_NAME s_scm_hash_clear_x
799 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
801 scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table
), SCM_EOL
);
802 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
804 return SCM_UNSPECIFIED
;
810 SCM_DEFINE (scm_hashq_get_handle
, "hashq-get-handle", 2, 0, 0,
811 (SCM table
, SCM key
),
812 "This procedure returns the @code{(key . value)} pair from the\n"
813 "hash table @var{table}. If @var{table} does not hold an\n"
814 "associated value for @var{key}, @code{#f} is returned.\n"
815 "Uses @code{eq?} for equality testing.")
816 #define FUNC_NAME s_scm_hashq_get_handle
818 return scm_hash_fn_get_handle (table
, key
,
819 (scm_t_hash_fn
) scm_ihashq
,
820 (scm_t_assoc_fn
) scm_sloppy_assq
,
826 SCM_DEFINE (scm_hashq_create_handle_x
, "hashq-create-handle!", 3, 0, 0,
827 (SCM table
, SCM key
, SCM init
),
828 "This function looks up @var{key} in @var{table} and returns its handle.\n"
829 "If @var{key} is not already present, a new handle is created which\n"
830 "associates @var{key} with @var{init}.")
831 #define FUNC_NAME s_scm_hashq_create_handle_x
833 return scm_hash_fn_create_handle_x (table
, key
, init
,
834 (scm_t_hash_fn
) scm_ihashq
,
835 (scm_t_assoc_fn
) scm_sloppy_assq
,
841 SCM_DEFINE (scm_hashq_ref
, "hashq-ref", 2, 1, 0,
842 (SCM table
, SCM key
, SCM dflt
),
843 "Look up @var{key} in the hash table @var{table}, and return the\n"
844 "value (if any) associated with it. If @var{key} is not found,\n"
845 "return @var{default} (or @code{#f} if no @var{default} argument\n"
846 "is supplied). Uses @code{eq?} for equality testing.")
847 #define FUNC_NAME s_scm_hashq_ref
849 if (SCM_UNBNDP (dflt
))
851 return scm_hash_fn_ref (table
, key
, dflt
,
852 (scm_t_hash_fn
) scm_ihashq
,
853 (scm_t_assoc_fn
) scm_sloppy_assq
,
860 SCM_DEFINE (scm_hashq_set_x
, "hashq-set!", 3, 0, 0,
861 (SCM table
, SCM key
, SCM val
),
862 "Find the entry in @var{table} associated with @var{key}, and\n"
863 "store @var{value} there. Uses @code{eq?} for equality testing.")
864 #define FUNC_NAME s_scm_hashq_set_x
866 return scm_hash_fn_set_x (table
, key
, val
,
867 (scm_t_hash_fn
) scm_ihashq
,
868 (scm_t_assoc_fn
) scm_sloppy_assq
,
875 SCM_DEFINE (scm_hashq_remove_x
, "hashq-remove!", 2, 0, 0,
876 (SCM table
, SCM key
),
877 "Remove @var{key} (and any value associated with it) from\n"
878 "@var{table}. Uses @code{eq?} for equality tests.")
879 #define FUNC_NAME s_scm_hashq_remove_x
881 return scm_hash_fn_remove_x (table
, key
,
882 (scm_t_hash_fn
) scm_ihashq
,
883 (scm_t_assoc_fn
) scm_sloppy_assq
,
891 SCM_DEFINE (scm_hashv_get_handle
, "hashv-get-handle", 2, 0, 0,
892 (SCM table
, SCM key
),
893 "This procedure returns the @code{(key . value)} pair from the\n"
894 "hash table @var{table}. If @var{table} does not hold an\n"
895 "associated value for @var{key}, @code{#f} is returned.\n"
896 "Uses @code{eqv?} for equality testing.")
897 #define FUNC_NAME s_scm_hashv_get_handle
899 return scm_hash_fn_get_handle (table
, key
,
900 (scm_t_hash_fn
) scm_ihashv
,
901 (scm_t_assoc_fn
) scm_sloppy_assv
,
907 SCM_DEFINE (scm_hashv_create_handle_x
, "hashv-create-handle!", 3, 0, 0,
908 (SCM table
, SCM key
, SCM init
),
909 "This function looks up @var{key} in @var{table} and returns its handle.\n"
910 "If @var{key} is not already present, a new handle is created which\n"
911 "associates @var{key} with @var{init}.")
912 #define FUNC_NAME s_scm_hashv_create_handle_x
914 return scm_hash_fn_create_handle_x (table
, key
, init
,
915 (scm_t_hash_fn
) scm_ihashv
,
916 (scm_t_assoc_fn
) scm_sloppy_assv
,
922 SCM_DEFINE (scm_hashv_ref
, "hashv-ref", 2, 1, 0,
923 (SCM table
, SCM key
, SCM dflt
),
924 "Look up @var{key} in the hash table @var{table}, and return the\n"
925 "value (if any) associated with it. If @var{key} is not found,\n"
926 "return @var{default} (or @code{#f} if no @var{default} argument\n"
927 "is supplied). Uses @code{eqv?} for equality testing.")
928 #define FUNC_NAME s_scm_hashv_ref
930 if (SCM_UNBNDP (dflt
))
932 return scm_hash_fn_ref (table
, key
, dflt
,
933 (scm_t_hash_fn
) scm_ihashv
,
934 (scm_t_assoc_fn
) scm_sloppy_assv
,
941 SCM_DEFINE (scm_hashv_set_x
, "hashv-set!", 3, 0, 0,
942 (SCM table
, SCM key
, SCM val
),
943 "Find the entry in @var{table} associated with @var{key}, and\n"
944 "store @var{value} there. Uses @code{eqv?} for equality testing.")
945 #define FUNC_NAME s_scm_hashv_set_x
947 return scm_hash_fn_set_x (table
, key
, val
,
948 (scm_t_hash_fn
) scm_ihashv
,
949 (scm_t_assoc_fn
) scm_sloppy_assv
,
955 SCM_DEFINE (scm_hashv_remove_x
, "hashv-remove!", 2, 0, 0,
956 (SCM table
, SCM key
),
957 "Remove @var{key} (and any value associated with it) from\n"
958 "@var{table}. Uses @code{eqv?} for equality tests.")
959 #define FUNC_NAME s_scm_hashv_remove_x
961 return scm_hash_fn_remove_x (table
, key
,
962 (scm_t_hash_fn
) scm_ihashv
,
963 (scm_t_assoc_fn
) scm_sloppy_assv
,
970 SCM_DEFINE (scm_hash_get_handle
, "hash-get-handle", 2, 0, 0,
971 (SCM table
, SCM key
),
972 "This procedure returns the @code{(key . value)} pair from the\n"
973 "hash table @var{table}. If @var{table} does not hold an\n"
974 "associated value for @var{key}, @code{#f} is returned.\n"
975 "Uses @code{equal?} for equality testing.")
976 #define FUNC_NAME s_scm_hash_get_handle
978 return scm_hash_fn_get_handle (table
, key
,
979 (scm_t_hash_fn
) scm_ihash
,
980 (scm_t_assoc_fn
) scm_sloppy_assoc
,
986 SCM_DEFINE (scm_hash_create_handle_x
, "hash-create-handle!", 3, 0, 0,
987 (SCM table
, SCM key
, SCM init
),
988 "This function looks up @var{key} in @var{table} and returns its handle.\n"
989 "If @var{key} is not already present, a new handle is created which\n"
990 "associates @var{key} with @var{init}.")
991 #define FUNC_NAME s_scm_hash_create_handle_x
993 return scm_hash_fn_create_handle_x (table
, key
, init
,
994 (scm_t_hash_fn
) scm_ihash
,
995 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1001 SCM_DEFINE (scm_hash_ref
, "hash-ref", 2, 1, 0,
1002 (SCM table
, SCM key
, SCM dflt
),
1003 "Look up @var{key} in the hash table @var{table}, and return the\n"
1004 "value (if any) associated with it. If @var{key} is not found,\n"
1005 "return @var{default} (or @code{#f} if no @var{default} argument\n"
1006 "is supplied). Uses @code{equal?} for equality testing.")
1007 #define FUNC_NAME s_scm_hash_ref
1009 if (SCM_UNBNDP (dflt
))
1011 return scm_hash_fn_ref (table
, key
, dflt
,
1012 (scm_t_hash_fn
) scm_ihash
,
1013 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1020 SCM_DEFINE (scm_hash_set_x
, "hash-set!", 3, 0, 0,
1021 (SCM table
, SCM key
, SCM val
),
1022 "Find the entry in @var{table} associated with @var{key}, and\n"
1023 "store @var{value} there. Uses @code{equal?} for equality\n"
1025 #define FUNC_NAME s_scm_hash_set_x
1027 return scm_hash_fn_set_x (table
, key
, val
,
1028 (scm_t_hash_fn
) scm_ihash
,
1029 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1036 SCM_DEFINE (scm_hash_remove_x
, "hash-remove!", 2, 0, 0,
1037 (SCM table
, SCM key
),
1038 "Remove @var{key} (and any value associated with it) from\n"
1039 "@var{table}. Uses @code{equal?} for equality tests.")
1040 #define FUNC_NAME s_scm_hash_remove_x
1042 return scm_hash_fn_remove_x (table
, key
,
1043 (scm_t_hash_fn
) scm_ihash
,
1044 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1052 typedef struct scm_t_ihashx_closure
1056 } scm_t_ihashx_closure
;
1060 static unsigned long
1061 scm_ihashx (SCM obj
, unsigned long n
, void *arg
)
1064 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
1065 answer
= scm_call_2 (closure
->hash
, obj
, scm_from_ulong (n
));
1066 return scm_to_ulong (answer
);
1072 scm_sloppy_assx (SCM obj
, SCM alist
, void *arg
)
1074 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
1075 return scm_call_2 (closure
->assoc
, obj
, alist
);
1079 SCM_DEFINE (scm_hashx_get_handle
, "hashx-get-handle", 4, 0, 0,
1080 (SCM hash
, SCM assoc
, SCM table
, SCM key
),
1081 "This behaves the same way as the corresponding\n"
1082 "@code{-get-handle} function, but uses @var{hash} as a hash\n"
1083 "function and @var{assoc} to compare keys. @code{hash} must be\n"
1084 "a function that takes two arguments, a key to be hashed and a\n"
1085 "table size. @code{assoc} must be an associator function, like\n"
1086 "@code{assoc}, @code{assq} or @code{assv}.")
1087 #define FUNC_NAME s_scm_hashx_get_handle
1089 scm_t_ihashx_closure closure
;
1090 closure
.hash
= hash
;
1091 closure
.assoc
= assoc
;
1092 return scm_hash_fn_get_handle (table
, key
, scm_ihashx
, scm_sloppy_assx
,
1098 SCM_DEFINE (scm_hashx_create_handle_x
, "hashx-create-handle!", 5, 0, 0,
1099 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM init
),
1100 "This behaves the same way as the corresponding\n"
1101 "@code{-create-handle} function, but uses @var{hash} as a hash\n"
1102 "function and @var{assoc} to compare keys. @code{hash} must be\n"
1103 "a function that takes two arguments, a key to be hashed and a\n"
1104 "table size. @code{assoc} must be an associator function, like\n"
1105 "@code{assoc}, @code{assq} or @code{assv}.")
1106 #define FUNC_NAME s_scm_hashx_create_handle_x
1108 scm_t_ihashx_closure closure
;
1109 closure
.hash
= hash
;
1110 closure
.assoc
= assoc
;
1111 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashx
,
1112 scm_sloppy_assx
, (void *)&closure
);
1118 SCM_DEFINE (scm_hashx_ref
, "hashx-ref", 4, 1, 0,
1119 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM dflt
),
1120 "This behaves the same way as the corresponding @code{ref}\n"
1121 "function, but uses @var{hash} as a hash function and\n"
1122 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1123 "that takes two arguments, a key to be hashed and a table size.\n"
1124 "@code{assoc} must be an associator function, like @code{assoc},\n"
1125 "@code{assq} or @code{assv}.\n"
1127 "By way of illustration, @code{hashq-ref table key} is\n"
1128 "equivalent to @code{hashx-ref hashq assq table key}.")
1129 #define FUNC_NAME s_scm_hashx_ref
1131 scm_t_ihashx_closure closure
;
1132 if (SCM_UNBNDP (dflt
))
1134 closure
.hash
= hash
;
1135 closure
.assoc
= assoc
;
1136 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashx
, scm_sloppy_assx
,
1144 SCM_DEFINE (scm_hashx_set_x
, "hashx-set!", 5, 0, 0,
1145 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM val
),
1146 "This behaves the same way as the corresponding @code{set!}\n"
1147 "function, but uses @var{hash} as a hash function and\n"
1148 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1149 "that takes two arguments, a key to be hashed and a table size.\n"
1150 "@code{assoc} must be an associator function, like @code{assoc},\n"
1151 "@code{assq} or @code{assv}.\n"
1153 " By way of illustration, @code{hashq-set! table key} is\n"
1154 "equivalent to @code{hashx-set! hashq assq table key}.")
1155 #define FUNC_NAME s_scm_hashx_set_x
1157 scm_t_ihashx_closure closure
;
1158 closure
.hash
= hash
;
1159 closure
.assoc
= assoc
;
1160 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashx
, scm_sloppy_assx
,
1165 SCM_DEFINE (scm_hashx_remove_x
, "hashx-remove!", 4, 0, 0,
1166 (SCM hash
, SCM assoc
, SCM table
, SCM obj
),
1167 "This behaves the same way as the corresponding @code{remove!}\n"
1168 "function, but uses @var{hash} as a hash function and\n"
1169 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1170 "that takes two arguments, a key to be hashed and a table size.\n"
1171 "@code{assoc} must be an associator function, like @code{assoc},\n"
1172 "@code{assq} or @code{assv}.\n"
1174 " By way of illustration, @code{hashq-remove! table key} is\n"
1175 "equivalent to @code{hashx-remove! hashq assq #f table key}.")
1176 #define FUNC_NAME s_scm_hashx_remove_x
1178 scm_t_ihashx_closure closure
;
1179 closure
.hash
= hash
;
1180 closure
.assoc
= assoc
;
1181 return scm_hash_fn_remove_x (table
, obj
, scm_ihashx
, scm_sloppy_assx
,
1186 /* Hash table iterators */
1188 SCM_DEFINE (scm_hash_fold
, "hash-fold", 3, 0, 0,
1189 (SCM proc
, SCM init
, SCM table
),
1190 "An iterator over hash-table elements.\n"
1191 "Accumulates and returns a result by applying PROC successively.\n"
1192 "The arguments to PROC are \"(key value prior-result)\" where key\n"
1193 "and value are successive pairs from the hash table TABLE, and\n"
1194 "prior-result is either INIT (for the first application of PROC)\n"
1195 "or the return value of the previous application of PROC.\n"
1196 "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
1197 "table into an a-list of key-value pairs.")
1198 #define FUNC_NAME s_scm_hash_fold
1200 SCM_VALIDATE_PROC (1, proc
);
1201 SCM_VALIDATE_HASHTABLE (3, table
);
1202 return scm_internal_hash_fold ((scm_t_hash_fold_fn
) scm_call_3
,
1203 (void *) SCM_UNPACK (proc
), init
, table
);
1208 for_each_proc (void *proc
, SCM handle
)
1210 return scm_call_2 (SCM_PACK (proc
), SCM_CAR (handle
), SCM_CDR (handle
));
1213 SCM_DEFINE (scm_hash_for_each
, "hash-for-each", 2, 0, 0,
1214 (SCM proc
, SCM table
),
1215 "An iterator over hash-table elements.\n"
1216 "Applies PROC successively on all hash table items.\n"
1217 "The arguments to PROC are \"(key value)\" where key\n"
1218 "and value are successive pairs from the hash table TABLE.")
1219 #define FUNC_NAME s_scm_hash_for_each
1221 SCM_VALIDATE_PROC (1, proc
);
1222 SCM_VALIDATE_HASHTABLE (2, table
);
1224 scm_internal_hash_for_each_handle (for_each_proc
,
1225 (void *) SCM_UNPACK (proc
),
1227 return SCM_UNSPECIFIED
;
1231 SCM_DEFINE (scm_hash_for_each_handle
, "hash-for-each-handle", 2, 0, 0,
1232 (SCM proc
, SCM table
),
1233 "An iterator over hash-table elements.\n"
1234 "Applies PROC successively on all hash table handles.")
1235 #define FUNC_NAME s_scm_hash_for_each_handle
1237 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)), proc
, 1, FUNC_NAME
);
1238 SCM_VALIDATE_HASHTABLE (2, table
);
1240 scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn
) scm_call_1
,
1241 (void *) SCM_UNPACK (proc
),
1243 return SCM_UNSPECIFIED
;
1248 map_proc (void *proc
, SCM key
, SCM data
, SCM value
)
1250 return scm_cons (scm_call_2 (SCM_PACK (proc
), key
, data
), value
);
1253 SCM_DEFINE (scm_hash_map_to_list
, "hash-map->list", 2, 0, 0,
1254 (SCM proc
, SCM table
),
1255 "An iterator over hash-table elements.\n"
1256 "Accumulates and returns as a list the results of applying PROC successively.\n"
1257 "The arguments to PROC are \"(key value)\" where key\n"
1258 "and value are successive pairs from the hash table TABLE.")
1259 #define FUNC_NAME s_scm_hash_map_to_list
1261 SCM_VALIDATE_PROC (1, proc
);
1262 SCM_VALIDATE_HASHTABLE (2, table
);
1263 return scm_internal_hash_fold (map_proc
,
1264 (void *) SCM_UNPACK (proc
),
1273 scm_internal_hash_fold (scm_t_hash_fold_fn fn
, void *closure
,
1274 SCM init
, SCM table
)
1275 #define FUNC_NAME s_scm_hash_fold
1278 SCM buckets
, result
= init
;
1280 SCM_VALIDATE_HASHTABLE (0, table
);
1281 buckets
= SCM_HASHTABLE_VECTOR (table
);
1283 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1284 for (i
= 0; i
< n
; ++i
)
1288 for (prev
= SCM_BOOL_F
, ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
);
1290 prev
= ls
, ls
= SCM_CDR (ls
))
1294 if (!scm_is_pair (ls
))
1295 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1297 handle
= SCM_CAR (ls
);
1298 if (!scm_is_pair (handle
))
1299 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1301 if (SCM_HASHTABLE_WEAK_P (table
))
1303 if (SCM_WEAK_PAIR_DELETED_P (handle
))
1305 /* We hit a weak pair whose car/cdr has become
1306 unreachable: unlink it from the bucket. */
1307 if (prev
!= SCM_BOOL_F
)
1308 SCM_SETCDR (prev
, SCM_CDR (ls
));
1310 SCM_SIMPLE_VECTOR_SET (buckets
, i
, SCM_CDR (ls
));
1312 /* Update the item count. */
1313 SCM_HASHTABLE_DECREMENT (table
);
1319 result
= fn (closure
, SCM_CAR (handle
), SCM_CDR (handle
), result
);
1327 /* The following redundant code is here in order to be able to support
1328 hash-for-each-handle. An alternative would have been to replace
1329 this code and scm_internal_hash_fold above with a single
1330 scm_internal_hash_fold_handles, but we don't want to promote such
1334 scm_internal_hash_for_each_handle (scm_t_hash_handle_fn fn
, void *closure
,
1336 #define FUNC_NAME s_scm_hash_for_each
1341 SCM_VALIDATE_HASHTABLE (0, table
);
1342 buckets
= SCM_HASHTABLE_VECTOR (table
);
1343 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1345 for (i
= 0; i
< n
; ++i
)
1347 SCM ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
), handle
;
1348 while (!scm_is_null (ls
))
1350 if (!scm_is_pair (ls
))
1351 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1352 handle
= SCM_CAR (ls
);
1353 if (!scm_is_pair (handle
))
1354 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1355 fn (closure
, handle
);
1368 #include "libguile/hashtab.x"