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"
37 #include "libguile/validate.h"
38 #include "libguile/hashtab.h"
43 /* A hash table is a cell containing a vector of association lists.
45 * Growing or shrinking, with following rehashing, is triggered when
48 * L = N / S (N: number of items in table, S: bucket vector length)
50 * passes an upper limit of 0.9 or a lower limit of 0.25.
52 * The implementation stores the upper and lower number of items which
53 * trigger a resize in the hashtable object.
55 * Weak hash tables use weak pairs in the bucket lists rather than
58 * Possible hash table sizes (primes) are stored in the array
62 static unsigned long hashtable_size
[] = {
63 31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363,
64 224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041
65 #if SIZEOF_SCM_T_BITS > 4
66 /* vector lengths are stored in the first word of vectors, shifted by
67 8 bits for the tc8, so for 32-bit we only get 2^24-1 = 16777215
68 elements. But we allow a few more sizes for 64-bit. */
69 , 28762081, 57524111, 115048217, 230096423, 460192829
73 #define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long))
75 static char *s_hashtable
= "hashtable";
79 /* Helper functions and macros to deal with weak pairs.
81 Weak pairs need to be accessed very carefully since their components can
82 be nullified by the GC when the object they refer to becomes unreachable.
83 Hence the macros and functions below that detect such weak pairs within
84 buckets and remove them. */
87 /* Remove nullified weak pairs from ALIST such that the result contains only
88 valid pairs. Set REMOVED_ITEMS to the number of pairs that have been
91 scm_fixup_weak_alist (SCM alist
, size_t *removed_items
)
99 alist
= SCM_CDR (alist
))
101 SCM pair
= SCM_CAR (alist
);
103 if (SCM_WEAK_PAIR_DELETED_P (pair
))
105 /* Remove from ALIST weak pair PAIR whose car/cdr has been
106 nullified by the GC. */
108 result
= SCM_CDR (alist
);
110 SCM_SETCDR (prev
, SCM_CDR (alist
));
114 /* Leave PREV unchanged. */
124 vacuum_weak_hash_table (SCM table
)
126 SCM buckets
= SCM_HASHTABLE_VECTOR (table
);
127 unsigned long k
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
128 size_t len
= SCM_HASHTABLE_N_ITEMS (table
);
133 SCM alist
= SCM_SIMPLE_VECTOR_REF (buckets
, k
);
134 alist
= scm_fixup_weak_alist (alist
, &removed
);
135 assert (removed
<= len
);
137 SCM_SIMPLE_VECTOR_SET (buckets
, k
, alist
);
140 SCM_SET_HASHTABLE_N_ITEMS (table
, len
);
144 /* Packed arguments for `do_weak_bucket_fixup'. */
149 size_t removed_items
;
153 do_weak_bucket_fixup (void *data
)
155 struct t_fixup_args
*args
;
158 args
= (struct t_fixup_args
*) data
;
160 args
->bucket
= scm_fixup_weak_alist (args
->bucket
, &args
->removed_items
);
162 for (pair
= args
->bucket
, copy
= args
->bucket_copy
;
164 pair
= SCM_CDR (pair
), copy
+= 2)
166 /* At this point, all weak pairs have been removed. */
167 assert (!SCM_WEAK_PAIR_DELETED_P (SCM_CAR (pair
)));
169 /* Copy the key and value. */
170 copy
[0] = SCM_CAAR (pair
);
171 copy
[1] = SCM_CDAR (pair
);
177 /* Lookup OBJECT in weak hash table TABLE using ASSOC. OBJECT is searched
178 for in the alist that is the BUCKET_INDEXth element of BUCKETS.
179 Optionally update TABLE and rehash it. */
181 weak_bucket_assoc (SCM table
, SCM buckets
, size_t bucket_index
,
182 scm_t_hash_fn hash_fn
,
183 scm_t_assoc_fn assoc
, SCM object
, void *closure
)
186 SCM bucket
, *strong_refs
;
187 struct t_fixup_args args
;
189 bucket
= SCM_SIMPLE_VECTOR_REF (buckets
, bucket_index
);
191 /* Prepare STRONG_REFS as an array large enough to hold all the keys
192 and values in BUCKET. */
193 strong_refs
= alloca (scm_ilength (bucket
) * 2 * sizeof (SCM
));
195 args
.bucket
= bucket
;
196 args
.bucket_copy
= strong_refs
;
198 /* Fixup BUCKET. Do that with the allocation lock held to avoid
199 seeing disappearing links pointing to objects that have already
200 been reclaimed (this happens when the disappearing links that point
201 to it haven't yet been cleared.)
203 The `do_weak_bucket_fixup' call populates STRONG_REFS with a copy
204 of BUCKET's entries after it's been fixed up. Thus, all the
205 entries kept in BUCKET are still reachable when ASSOC sees
207 GC_call_with_alloc_lock (do_weak_bucket_fixup
, &args
);
209 bucket
= args
.bucket
;
210 SCM_SIMPLE_VECTOR_SET (buckets
, bucket_index
, bucket
);
212 result
= assoc (object
, bucket
, closure
);
213 assert (!scm_is_pair (result
) ||
214 !SCM_WEAK_PAIR_DELETED_P (GC_is_visible (result
)));
216 scm_remember_upto_here_1 (strong_refs
);
218 if (args
.removed_items
> 0)
220 /* Update TABLE's item count and optionally trigger a rehash. */
223 assert (SCM_HASHTABLE_N_ITEMS (table
) >= args
.removed_items
);
225 remaining
= SCM_HASHTABLE_N_ITEMS (table
) - args
.removed_items
;
226 SCM_SET_HASHTABLE_N_ITEMS (table
, remaining
);
228 if (remaining
< SCM_HASHTABLE_LOWER (table
))
229 scm_i_rehash (table
, hash_fn
, closure
, "weak_bucket_assoc");
236 /* Packed arguments for `weak_bucket_assoc_by_hash'. */
237 struct assoc_by_hash_data
241 scm_t_hash_predicate_fn predicate
;
245 /* See scm_hash_fn_get_handle_by_hash below. */
247 weak_bucket_assoc_by_hash (void *args
)
249 struct assoc_by_hash_data
*data
= args
;
250 SCM alist
= data
->alist
;
252 for (; scm_is_pair (alist
); alist
= SCM_CDR (alist
))
254 SCM pair
= SCM_CAR (alist
);
256 if (!SCM_WEAK_PAIR_DELETED_P (pair
)
257 && data
->predicate (SCM_CAR (pair
), data
->closure
))
269 make_hash_table (int flags
, unsigned long k
, const char *func_name
)
273 int i
= 0, n
= k
? k
: 31;
274 while (i
< HASHTABLE_SIZE_N
&& n
> hashtable_size
[i
])
276 n
= hashtable_size
[i
];
278 /* In both cases, i.e., regardless of whether we are creating a weak hash
279 table, we return a non-weak vector. This is because the vector itself
280 is not weak in the case of a weak hash table: the alist pairs are. */
281 vector
= scm_c_make_vector (n
, SCM_EOL
);
283 t
= scm_gc_malloc_pointerless (sizeof (*t
), s_hashtable
);
284 t
->min_size_index
= t
->size_index
= i
;
287 t
->upper
= 9 * n
/ 10;
291 /* FIXME: we just need two words of storage, not three */
292 return scm_double_cell (scm_tc7_hashtable
, SCM_UNPACK (vector
),
297 scm_i_rehash (SCM table
,
298 scm_t_hash_fn hash_fn
,
300 const char* func_name
)
302 SCM buckets
, new_buckets
;
304 unsigned long old_size
;
305 unsigned long new_size
;
307 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
309 /* rehashing is not triggered when i <= min_size */
310 i
= SCM_HASHTABLE (table
)->size_index
;
313 while (i
> SCM_HASHTABLE (table
)->min_size_index
314 && SCM_HASHTABLE_N_ITEMS (table
) < hashtable_size
[i
] / 4);
318 i
= SCM_HASHTABLE (table
)->size_index
+ 1;
319 if (i
>= HASHTABLE_SIZE_N
)
323 /* Remember HASH_FN for rehash_after_gc, but only when CLOSURE
324 is not needed since CLOSURE can not be guaranteed to be valid
325 after this function returns.
328 SCM_HASHTABLE (table
)->hash_fn
= hash_fn
;
330 SCM_HASHTABLE (table
)->size_index
= i
;
332 new_size
= hashtable_size
[i
];
333 if (i
<= SCM_HASHTABLE (table
)->min_size_index
)
334 SCM_HASHTABLE (table
)->lower
= 0;
336 SCM_HASHTABLE (table
)->lower
= new_size
/ 4;
337 SCM_HASHTABLE (table
)->upper
= 9 * new_size
/ 10;
338 buckets
= SCM_HASHTABLE_VECTOR (table
);
340 new_buckets
= scm_c_make_vector (new_size
, SCM_EOL
);
342 /* When this is a weak hashtable, running the GC might change it.
343 We need to cope with this while rehashing its elements. We do
344 this by first installing the new, empty bucket vector. Then we
345 remove the elements from the old bucket vector and insert them
349 SCM_SET_HASHTABLE_VECTOR (table
, new_buckets
);
350 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
352 old_size
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
353 for (i
= 0; i
< old_size
; ++i
)
355 SCM ls
, cell
, handle
;
357 ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
);
358 SCM_SIMPLE_VECTOR_SET (buckets
, i
, SCM_EOL
);
360 while (scm_is_pair (ls
))
365 handle
= SCM_CAR (cell
);
368 if (SCM_WEAK_PAIR_DELETED_P (handle
))
369 /* HANDLE is a nullified weak pair: skip it. */
372 h
= hash_fn (SCM_CAR (handle
), new_size
, closure
);
374 scm_out_of_range (func_name
, scm_from_ulong (h
));
375 SCM_SETCDR (cell
, SCM_SIMPLE_VECTOR_REF (new_buckets
, h
));
376 SCM_SIMPLE_VECTOR_SET (new_buckets
, h
, cell
);
377 SCM_HASHTABLE_INCREMENT (table
);
384 scm_i_hashtable_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
386 scm_puts ("#<", port
);
387 if (SCM_HASHTABLE_WEAK_KEY_P (exp
))
388 scm_puts ("weak-key-", port
);
389 else if (SCM_HASHTABLE_WEAK_VALUE_P (exp
))
390 scm_puts ("weak-value-", port
);
391 else if (SCM_HASHTABLE_DOUBLY_WEAK_P (exp
))
392 scm_puts ("doubly-weak-", port
);
393 scm_puts ("hash-table ", port
);
394 scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp
), 10, port
);
395 scm_putc ('/', port
);
396 scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp
)),
398 scm_puts (">", port
);
403 scm_c_make_hash_table (unsigned long k
)
405 return make_hash_table (0, k
, "scm_c_make_hash_table");
408 SCM_DEFINE (scm_make_hash_table
, "make-hash-table", 0, 1, 0,
410 "Make a new abstract hash table object with minimum number of buckets @var{n}\n")
411 #define FUNC_NAME s_scm_make_hash_table
414 return make_hash_table (0, 0, FUNC_NAME
);
416 return make_hash_table (0, scm_to_ulong (n
), FUNC_NAME
);
420 SCM_DEFINE (scm_make_weak_key_hash_table
, "make-weak-key-hash-table", 0, 1, 0,
422 "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
423 "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n"
424 "Return a weak hash table with @var{size} buckets.\n"
426 "You can modify weak hash tables in exactly the same way you\n"
427 "would modify regular hash tables. (@pxref{Hash Tables})")
428 #define FUNC_NAME s_scm_make_weak_key_hash_table
431 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
, 0, FUNC_NAME
);
433 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
,
434 scm_to_ulong (n
), FUNC_NAME
);
439 SCM_DEFINE (scm_make_weak_value_hash_table
, "make-weak-value-hash-table", 0, 1, 0,
441 "Return a hash table with weak values with @var{size} buckets.\n"
442 "(@pxref{Hash Tables})")
443 #define FUNC_NAME s_scm_make_weak_value_hash_table
446 return make_hash_table (SCM_HASHTABLEF_WEAK_CDR
, 0, FUNC_NAME
);
449 return make_hash_table (SCM_HASHTABLEF_WEAK_CDR
,
450 scm_to_ulong (n
), FUNC_NAME
);
456 SCM_DEFINE (scm_make_doubly_weak_hash_table
, "make-doubly-weak-hash-table", 1, 0, 0,
458 "Return a hash table with weak keys and values with @var{size}\n"
459 "buckets. (@pxref{Hash Tables})")
460 #define FUNC_NAME s_scm_make_doubly_weak_hash_table
463 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
468 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
476 SCM_DEFINE (scm_hash_table_p
, "hash-table?", 1, 0, 0,
478 "Return @code{#t} if @var{obj} is an abstract hash table object.")
479 #define FUNC_NAME s_scm_hash_table_p
481 return scm_from_bool (SCM_HASHTABLE_P (obj
));
486 SCM_DEFINE (scm_weak_key_hash_table_p
, "weak-key-hash-table?", 1, 0, 0,
488 "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n"
489 "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n"
490 "Return @code{#t} if @var{obj} is the specified weak hash\n"
491 "table. Note that a doubly weak hash table is neither a weak key\n"
492 "nor a weak value hash table.")
493 #define FUNC_NAME s_scm_weak_key_hash_table_p
495 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_KEY_P (obj
));
500 SCM_DEFINE (scm_weak_value_hash_table_p
, "weak-value-hash-table?", 1, 0, 0,
502 "Return @code{#t} if @var{obj} is a weak value hash table.")
503 #define FUNC_NAME s_scm_weak_value_hash_table_p
505 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_VALUE_P (obj
));
510 SCM_DEFINE (scm_doubly_weak_hash_table_p
, "doubly-weak-hash-table?", 1, 0, 0,
512 "Return @code{#t} if @var{obj} is a doubly weak hash table.")
513 #define FUNC_NAME s_scm_doubly_weak_hash_table_p
515 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_DOUBLY_WEAK_P (obj
));
520 /* Accessing hash table entries. */
523 scm_hash_fn_get_handle (SCM table
, SCM obj
,
524 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
526 #define FUNC_NAME "scm_hash_fn_get_handle"
531 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
532 buckets
= SCM_HASHTABLE_VECTOR (table
);
534 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
536 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
537 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
538 scm_out_of_range (FUNC_NAME
, scm_from_ulong (k
));
540 if (SCM_HASHTABLE_WEAK_P (table
))
541 h
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
542 assoc_fn
, obj
, closure
);
544 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
551 /* This procedure implements three optimizations, with respect to the
554 1. For weak tables, it's assumed that calling the predicate in the
555 allocation lock is safe. In practice this means that the predicate
556 cannot call arbitrary scheme functions.
558 2. We don't check for overflow / underflow and rehash.
560 3. We don't actually have to allocate a key -- instead we get the
561 hash value directly. This is useful for, for example, looking up
562 strings in the symbol table.
565 scm_hash_fn_get_handle_by_hash (SCM table
, unsigned long raw_hash
,
566 scm_t_hash_predicate_fn predicate_fn
,
568 #define FUNC_NAME "scm_hash_fn_ref_by_hash"
571 SCM buckets
, alist
, h
= SCM_BOOL_F
;
573 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
574 buckets
= SCM_HASHTABLE_VECTOR (table
);
576 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
579 k
= raw_hash
% SCM_SIMPLE_VECTOR_LENGTH (buckets
);
580 alist
= SCM_SIMPLE_VECTOR_REF (buckets
, k
);
582 if (SCM_HASHTABLE_WEAK_P (table
))
584 struct assoc_by_hash_data args
;
587 args
.ret
= SCM_BOOL_F
;
588 args
.predicate
= predicate_fn
;
589 args
.closure
= closure
;
590 GC_call_with_alloc_lock (weak_bucket_assoc_by_hash
, &args
);
594 for (; scm_is_pair (alist
); alist
= SCM_CDR (alist
))
596 SCM pair
= SCM_CAR (alist
);
597 if (predicate_fn (SCM_CAR (pair
), closure
))
610 scm_hash_fn_create_handle_x (SCM table
, SCM obj
, SCM init
,
611 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
613 #define FUNC_NAME "scm_hash_fn_create_handle_x"
618 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
619 buckets
= SCM_HASHTABLE_VECTOR (table
);
621 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
622 SCM_MISC_ERROR ("void hashtable", SCM_EOL
);
624 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
625 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
626 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
628 if (SCM_HASHTABLE_WEAK_P (table
))
629 it
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
630 assoc_fn
, obj
, closure
);
632 it
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
634 if (scm_is_pair (it
))
636 else if (scm_is_true (it
))
637 scm_wrong_type_arg_msg (NULL
, 0, it
, "a pair");
640 /* When this is a weak hashtable, running the GC can change it.
641 Thus, we must allocate the new cells first and can only then
642 access BUCKETS. Also, we need to fetch the bucket vector
643 again since the hashtable might have been rehashed. This
644 necessitates a new hash value as well.
646 SCM handle
, new_bucket
;
648 if (SCM_HASHTABLE_WEAK_P (table
))
650 /* FIXME: We don't support weak alist vectors. */
651 /* Use a weak cell. */
652 if (SCM_HASHTABLE_DOUBLY_WEAK_P (table
))
653 handle
= scm_doubly_weak_pair (obj
, init
);
654 else if (SCM_HASHTABLE_WEAK_KEY_P (table
))
655 handle
= scm_weak_car_pair (obj
, init
);
657 handle
= scm_weak_cdr_pair (obj
, init
);
660 /* Use a regular, non-weak cell. */
661 handle
= scm_cons (obj
, init
);
663 new_bucket
= scm_cons (handle
, SCM_EOL
);
665 if (!scm_is_eq (SCM_HASHTABLE_VECTOR (table
), buckets
))
667 buckets
= SCM_HASHTABLE_VECTOR (table
);
668 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
669 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
670 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
672 SCM_SETCDR (new_bucket
, SCM_SIMPLE_VECTOR_REF (buckets
, k
));
673 SCM_SIMPLE_VECTOR_SET (buckets
, k
, new_bucket
);
674 SCM_HASHTABLE_INCREMENT (table
);
676 /* Maybe rehash the table. If it's a weak table, pump all of the
677 buckets first to remove stale links. If the weak table is of
678 the kind that gets lots of insertions of short-lived values, we
679 might never need to actually rehash. */
680 if (SCM_HASHTABLE_WEAK_P (table
)
681 && SCM_HASHTABLE_N_ITEMS (table
) > SCM_HASHTABLE_UPPER (table
))
682 vacuum_weak_hash_table (table
);
684 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
)
685 || SCM_HASHTABLE_N_ITEMS (table
) > SCM_HASHTABLE_UPPER (table
))
686 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
687 return SCM_CAR (new_bucket
);
694 scm_hash_fn_ref (SCM table
, SCM obj
, SCM dflt
,
695 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
698 SCM it
= scm_hash_fn_get_handle (table
, obj
, hash_fn
, assoc_fn
, closure
);
699 if (scm_is_pair (it
))
709 scm_hash_fn_set_x (SCM table
, SCM obj
, SCM val
,
710 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
715 it
= scm_hash_fn_create_handle_x (table
, obj
, SCM_BOOL_F
, hash_fn
, assoc_fn
, closure
);
716 SCM_SETCDR (it
, val
);
718 if (SCM_HASHTABLE_WEAK_VALUE_P (table
) && SCM_NIMP (val
))
719 /* IT is a weak-cdr pair. Register a disappearing link from IT's
720 cdr to VAL like `scm_weak_cdr_pair' does. */
721 SCM_I_REGISTER_DISAPPEARING_LINK ((void *) SCM_CDRLOC (it
), SCM2PTR (val
));
728 scm_hash_fn_remove_x (SCM table
, SCM obj
,
729 scm_t_hash_fn hash_fn
,
730 scm_t_assoc_fn assoc_fn
,
732 #define FUNC_NAME "hash_fn_remove_x"
737 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
739 buckets
= SCM_HASHTABLE_VECTOR (table
);
741 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
744 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
745 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
746 scm_out_of_range (FUNC_NAME
, scm_from_ulong (k
));
748 if (SCM_HASHTABLE_WEAK_P (table
))
749 h
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
750 assoc_fn
, obj
, closure
);
752 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
756 SCM_SIMPLE_VECTOR_SET
757 (buckets
, k
, scm_delq_x (h
, SCM_SIMPLE_VECTOR_REF (buckets
, k
)));
758 SCM_HASHTABLE_DECREMENT (table
);
759 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
760 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
766 SCM_DEFINE (scm_hash_clear_x
, "hash-clear!", 1, 0, 0,
768 "Remove all items from @var{table} (without triggering a resize).")
769 #define FUNC_NAME s_scm_hash_clear_x
771 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
773 scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table
), SCM_EOL
);
774 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
776 return SCM_UNSPECIFIED
;
782 SCM_DEFINE (scm_hashq_get_handle
, "hashq-get-handle", 2, 0, 0,
783 (SCM table
, SCM key
),
784 "This procedure returns the @code{(key . value)} pair from the\n"
785 "hash table @var{table}. If @var{table} does not hold an\n"
786 "associated value for @var{key}, @code{#f} is returned.\n"
787 "Uses @code{eq?} for equality testing.")
788 #define FUNC_NAME s_scm_hashq_get_handle
790 return scm_hash_fn_get_handle (table
, key
,
791 (scm_t_hash_fn
) scm_ihashq
,
792 (scm_t_assoc_fn
) scm_sloppy_assq
,
798 SCM_DEFINE (scm_hashq_create_handle_x
, "hashq-create-handle!", 3, 0, 0,
799 (SCM table
, SCM key
, SCM init
),
800 "This function looks up @var{key} in @var{table} and returns its handle.\n"
801 "If @var{key} is not already present, a new handle is created which\n"
802 "associates @var{key} with @var{init}.")
803 #define FUNC_NAME s_scm_hashq_create_handle_x
805 return scm_hash_fn_create_handle_x (table
, key
, init
,
806 (scm_t_hash_fn
) scm_ihashq
,
807 (scm_t_assoc_fn
) scm_sloppy_assq
,
813 SCM_DEFINE (scm_hashq_ref
, "hashq-ref", 2, 1, 0,
814 (SCM table
, SCM key
, SCM dflt
),
815 "Look up @var{key} in the hash table @var{table}, and return the\n"
816 "value (if any) associated with it. If @var{key} is not found,\n"
817 "return @var{default} (or @code{#f} if no @var{default} argument\n"
818 "is supplied). Uses @code{eq?} for equality testing.")
819 #define FUNC_NAME s_scm_hashq_ref
821 if (SCM_UNBNDP (dflt
))
823 return scm_hash_fn_ref (table
, key
, dflt
,
824 (scm_t_hash_fn
) scm_ihashq
,
825 (scm_t_assoc_fn
) scm_sloppy_assq
,
832 SCM_DEFINE (scm_hashq_set_x
, "hashq-set!", 3, 0, 0,
833 (SCM table
, SCM key
, SCM val
),
834 "Find the entry in @var{table} associated with @var{key}, and\n"
835 "store @var{value} there. Uses @code{eq?} for equality testing.")
836 #define FUNC_NAME s_scm_hashq_set_x
838 return scm_hash_fn_set_x (table
, key
, val
,
839 (scm_t_hash_fn
) scm_ihashq
,
840 (scm_t_assoc_fn
) scm_sloppy_assq
,
847 SCM_DEFINE (scm_hashq_remove_x
, "hashq-remove!", 2, 0, 0,
848 (SCM table
, SCM key
),
849 "Remove @var{key} (and any value associated with it) from\n"
850 "@var{table}. Uses @code{eq?} for equality tests.")
851 #define FUNC_NAME s_scm_hashq_remove_x
853 return scm_hash_fn_remove_x (table
, key
,
854 (scm_t_hash_fn
) scm_ihashq
,
855 (scm_t_assoc_fn
) scm_sloppy_assq
,
863 SCM_DEFINE (scm_hashv_get_handle
, "hashv-get-handle", 2, 0, 0,
864 (SCM table
, SCM key
),
865 "This procedure returns the @code{(key . value)} pair from the\n"
866 "hash table @var{table}. If @var{table} does not hold an\n"
867 "associated value for @var{key}, @code{#f} is returned.\n"
868 "Uses @code{eqv?} for equality testing.")
869 #define FUNC_NAME s_scm_hashv_get_handle
871 return scm_hash_fn_get_handle (table
, key
,
872 (scm_t_hash_fn
) scm_ihashv
,
873 (scm_t_assoc_fn
) scm_sloppy_assv
,
879 SCM_DEFINE (scm_hashv_create_handle_x
, "hashv-create-handle!", 3, 0, 0,
880 (SCM table
, SCM key
, SCM init
),
881 "This function looks up @var{key} in @var{table} and returns its handle.\n"
882 "If @var{key} is not already present, a new handle is created which\n"
883 "associates @var{key} with @var{init}.")
884 #define FUNC_NAME s_scm_hashv_create_handle_x
886 return scm_hash_fn_create_handle_x (table
, key
, init
,
887 (scm_t_hash_fn
) scm_ihashv
,
888 (scm_t_assoc_fn
) scm_sloppy_assv
,
894 SCM_DEFINE (scm_hashv_ref
, "hashv-ref", 2, 1, 0,
895 (SCM table
, SCM key
, SCM dflt
),
896 "Look up @var{key} in the hash table @var{table}, and return the\n"
897 "value (if any) associated with it. If @var{key} is not found,\n"
898 "return @var{default} (or @code{#f} if no @var{default} argument\n"
899 "is supplied). Uses @code{eqv?} for equality testing.")
900 #define FUNC_NAME s_scm_hashv_ref
902 if (SCM_UNBNDP (dflt
))
904 return scm_hash_fn_ref (table
, key
, dflt
,
905 (scm_t_hash_fn
) scm_ihashv
,
906 (scm_t_assoc_fn
) scm_sloppy_assv
,
913 SCM_DEFINE (scm_hashv_set_x
, "hashv-set!", 3, 0, 0,
914 (SCM table
, SCM key
, SCM val
),
915 "Find the entry in @var{table} associated with @var{key}, and\n"
916 "store @var{value} there. Uses @code{eqv?} for equality testing.")
917 #define FUNC_NAME s_scm_hashv_set_x
919 return scm_hash_fn_set_x (table
, key
, val
,
920 (scm_t_hash_fn
) scm_ihashv
,
921 (scm_t_assoc_fn
) scm_sloppy_assv
,
927 SCM_DEFINE (scm_hashv_remove_x
, "hashv-remove!", 2, 0, 0,
928 (SCM table
, SCM key
),
929 "Remove @var{key} (and any value associated with it) from\n"
930 "@var{table}. Uses @code{eqv?} for equality tests.")
931 #define FUNC_NAME s_scm_hashv_remove_x
933 return scm_hash_fn_remove_x (table
, key
,
934 (scm_t_hash_fn
) scm_ihashv
,
935 (scm_t_assoc_fn
) scm_sloppy_assv
,
942 SCM_DEFINE (scm_hash_get_handle
, "hash-get-handle", 2, 0, 0,
943 (SCM table
, SCM key
),
944 "This procedure returns the @code{(key . value)} pair from the\n"
945 "hash table @var{table}. If @var{table} does not hold an\n"
946 "associated value for @var{key}, @code{#f} is returned.\n"
947 "Uses @code{equal?} for equality testing.")
948 #define FUNC_NAME s_scm_hash_get_handle
950 return scm_hash_fn_get_handle (table
, key
,
951 (scm_t_hash_fn
) scm_ihash
,
952 (scm_t_assoc_fn
) scm_sloppy_assoc
,
958 SCM_DEFINE (scm_hash_create_handle_x
, "hash-create-handle!", 3, 0, 0,
959 (SCM table
, SCM key
, SCM init
),
960 "This function looks up @var{key} in @var{table} and returns its handle.\n"
961 "If @var{key} is not already present, a new handle is created which\n"
962 "associates @var{key} with @var{init}.")
963 #define FUNC_NAME s_scm_hash_create_handle_x
965 return scm_hash_fn_create_handle_x (table
, key
, init
,
966 (scm_t_hash_fn
) scm_ihash
,
967 (scm_t_assoc_fn
) scm_sloppy_assoc
,
973 SCM_DEFINE (scm_hash_ref
, "hash-ref", 2, 1, 0,
974 (SCM table
, SCM key
, SCM dflt
),
975 "Look up @var{key} in the hash table @var{table}, and return the\n"
976 "value (if any) associated with it. If @var{key} is not found,\n"
977 "return @var{default} (or @code{#f} if no @var{default} argument\n"
978 "is supplied). Uses @code{equal?} for equality testing.")
979 #define FUNC_NAME s_scm_hash_ref
981 if (SCM_UNBNDP (dflt
))
983 return scm_hash_fn_ref (table
, key
, dflt
,
984 (scm_t_hash_fn
) scm_ihash
,
985 (scm_t_assoc_fn
) scm_sloppy_assoc
,
992 SCM_DEFINE (scm_hash_set_x
, "hash-set!", 3, 0, 0,
993 (SCM table
, SCM key
, SCM val
),
994 "Find the entry in @var{table} associated with @var{key}, and\n"
995 "store @var{value} there. Uses @code{equal?} for equality\n"
997 #define FUNC_NAME s_scm_hash_set_x
999 return scm_hash_fn_set_x (table
, key
, val
,
1000 (scm_t_hash_fn
) scm_ihash
,
1001 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1008 SCM_DEFINE (scm_hash_remove_x
, "hash-remove!", 2, 0, 0,
1009 (SCM table
, SCM key
),
1010 "Remove @var{key} (and any value associated with it) from\n"
1011 "@var{table}. Uses @code{equal?} for equality tests.")
1012 #define FUNC_NAME s_scm_hash_remove_x
1014 return scm_hash_fn_remove_x (table
, key
,
1015 (scm_t_hash_fn
) scm_ihash
,
1016 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1024 typedef struct scm_t_ihashx_closure
1028 } scm_t_ihashx_closure
;
1032 static unsigned long
1033 scm_ihashx (SCM obj
, unsigned long n
, void *arg
)
1036 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
1037 answer
= scm_call_2 (closure
->hash
, obj
, scm_from_ulong (n
));
1038 return scm_to_ulong (answer
);
1044 scm_sloppy_assx (SCM obj
, SCM alist
, void *arg
)
1046 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
1047 return scm_call_2 (closure
->assoc
, obj
, alist
);
1051 SCM_DEFINE (scm_hashx_get_handle
, "hashx-get-handle", 4, 0, 0,
1052 (SCM hash
, SCM assoc
, SCM table
, SCM key
),
1053 "This behaves the same way as the corresponding\n"
1054 "@code{-get-handle} function, but uses @var{hash} as a hash\n"
1055 "function and @var{assoc} to compare keys. @code{hash} must be\n"
1056 "a function that takes two arguments, a key to be hashed and a\n"
1057 "table size. @code{assoc} must be an associator function, like\n"
1058 "@code{assoc}, @code{assq} or @code{assv}.")
1059 #define FUNC_NAME s_scm_hashx_get_handle
1061 scm_t_ihashx_closure closure
;
1062 closure
.hash
= hash
;
1063 closure
.assoc
= assoc
;
1064 return scm_hash_fn_get_handle (table
, key
, scm_ihashx
, scm_sloppy_assx
,
1070 SCM_DEFINE (scm_hashx_create_handle_x
, "hashx-create-handle!", 5, 0, 0,
1071 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM init
),
1072 "This behaves the same way as the corresponding\n"
1073 "@code{-create-handle} function, but uses @var{hash} as a hash\n"
1074 "function and @var{assoc} to compare keys. @code{hash} must be\n"
1075 "a function that takes two arguments, a key to be hashed and a\n"
1076 "table size. @code{assoc} must be an associator function, like\n"
1077 "@code{assoc}, @code{assq} or @code{assv}.")
1078 #define FUNC_NAME s_scm_hashx_create_handle_x
1080 scm_t_ihashx_closure closure
;
1081 closure
.hash
= hash
;
1082 closure
.assoc
= assoc
;
1083 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashx
,
1084 scm_sloppy_assx
, (void *)&closure
);
1090 SCM_DEFINE (scm_hashx_ref
, "hashx-ref", 4, 1, 0,
1091 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM dflt
),
1092 "This behaves the same way as the corresponding @code{ref}\n"
1093 "function, but uses @var{hash} as a hash function and\n"
1094 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1095 "that takes two arguments, a key to be hashed and a table size.\n"
1096 "@code{assoc} must be an associator function, like @code{assoc},\n"
1097 "@code{assq} or @code{assv}.\n"
1099 "By way of illustration, @code{hashq-ref table key} is\n"
1100 "equivalent to @code{hashx-ref hashq assq table key}.")
1101 #define FUNC_NAME s_scm_hashx_ref
1103 scm_t_ihashx_closure closure
;
1104 if (SCM_UNBNDP (dflt
))
1106 closure
.hash
= hash
;
1107 closure
.assoc
= assoc
;
1108 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashx
, scm_sloppy_assx
,
1116 SCM_DEFINE (scm_hashx_set_x
, "hashx-set!", 5, 0, 0,
1117 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM val
),
1118 "This behaves the same way as the corresponding @code{set!}\n"
1119 "function, but uses @var{hash} as a hash function and\n"
1120 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1121 "that takes two arguments, a key to be hashed and a table size.\n"
1122 "@code{assoc} must be an associator function, like @code{assoc},\n"
1123 "@code{assq} or @code{assv}.\n"
1125 " By way of illustration, @code{hashq-set! table key} is\n"
1126 "equivalent to @code{hashx-set! hashq assq table key}.")
1127 #define FUNC_NAME s_scm_hashx_set_x
1129 scm_t_ihashx_closure closure
;
1130 closure
.hash
= hash
;
1131 closure
.assoc
= assoc
;
1132 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashx
, scm_sloppy_assx
,
1137 SCM_DEFINE (scm_hashx_remove_x
, "hashx-remove!", 4, 0, 0,
1138 (SCM hash
, SCM assoc
, SCM table
, SCM obj
),
1139 "This behaves the same way as the corresponding @code{remove!}\n"
1140 "function, but uses @var{hash} as a hash function and\n"
1141 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1142 "that takes two arguments, a key to be hashed and a table size.\n"
1143 "@code{assoc} must be an associator function, like @code{assoc},\n"
1144 "@code{assq} or @code{assv}.\n"
1146 " By way of illustration, @code{hashq-remove! table key} is\n"
1147 "equivalent to @code{hashx-remove! hashq assq #f table key}.")
1148 #define FUNC_NAME s_scm_hashx_remove_x
1150 scm_t_ihashx_closure closure
;
1151 closure
.hash
= hash
;
1152 closure
.assoc
= assoc
;
1153 return scm_hash_fn_remove_x (table
, obj
, scm_ihashx
, scm_sloppy_assx
,
1158 /* Hash table iterators */
1160 SCM_DEFINE (scm_hash_fold
, "hash-fold", 3, 0, 0,
1161 (SCM proc
, SCM init
, SCM table
),
1162 "An iterator over hash-table elements.\n"
1163 "Accumulates and returns a result by applying PROC successively.\n"
1164 "The arguments to PROC are \"(key value prior-result)\" where key\n"
1165 "and value are successive pairs from the hash table TABLE, and\n"
1166 "prior-result is either INIT (for the first application of PROC)\n"
1167 "or the return value of the previous application of PROC.\n"
1168 "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
1169 "table into an a-list of key-value pairs.")
1170 #define FUNC_NAME s_scm_hash_fold
1172 SCM_VALIDATE_PROC (1, proc
);
1173 SCM_VALIDATE_HASHTABLE (3, table
);
1174 return scm_internal_hash_fold ((scm_t_hash_fold_fn
) scm_call_3
,
1175 (void *) SCM_UNPACK (proc
), init
, table
);
1180 for_each_proc (void *proc
, SCM handle
)
1182 return scm_call_2 (SCM_PACK (proc
), SCM_CAR (handle
), SCM_CDR (handle
));
1185 SCM_DEFINE (scm_hash_for_each
, "hash-for-each", 2, 0, 0,
1186 (SCM proc
, SCM table
),
1187 "An iterator over hash-table elements.\n"
1188 "Applies PROC successively on all hash table items.\n"
1189 "The arguments to PROC are \"(key value)\" where key\n"
1190 "and value are successive pairs from the hash table TABLE.")
1191 #define FUNC_NAME s_scm_hash_for_each
1193 SCM_VALIDATE_PROC (1, proc
);
1194 SCM_VALIDATE_HASHTABLE (2, table
);
1196 scm_internal_hash_for_each_handle (for_each_proc
,
1197 (void *) SCM_UNPACK (proc
),
1199 return SCM_UNSPECIFIED
;
1203 SCM_DEFINE (scm_hash_for_each_handle
, "hash-for-each-handle", 2, 0, 0,
1204 (SCM proc
, SCM table
),
1205 "An iterator over hash-table elements.\n"
1206 "Applies PROC successively on all hash table handles.")
1207 #define FUNC_NAME s_scm_hash_for_each_handle
1209 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)), proc
, 1, FUNC_NAME
);
1210 SCM_VALIDATE_HASHTABLE (2, table
);
1212 scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn
) scm_call_1
,
1213 (void *) SCM_UNPACK (proc
),
1215 return SCM_UNSPECIFIED
;
1220 map_proc (void *proc
, SCM key
, SCM data
, SCM value
)
1222 return scm_cons (scm_call_2 (SCM_PACK (proc
), key
, data
), value
);
1225 SCM_DEFINE (scm_hash_map_to_list
, "hash-map->list", 2, 0, 0,
1226 (SCM proc
, SCM table
),
1227 "An iterator over hash-table elements.\n"
1228 "Accumulates and returns as a list the results of applying PROC successively.\n"
1229 "The arguments to PROC are \"(key value)\" where key\n"
1230 "and value are successive pairs from the hash table TABLE.")
1231 #define FUNC_NAME s_scm_hash_map_to_list
1233 SCM_VALIDATE_PROC (1, proc
);
1234 SCM_VALIDATE_HASHTABLE (2, table
);
1235 return scm_internal_hash_fold (map_proc
,
1236 (void *) SCM_UNPACK (proc
),
1245 scm_internal_hash_fold (scm_t_hash_fold_fn fn
, void *closure
,
1246 SCM init
, SCM table
)
1247 #define FUNC_NAME s_scm_hash_fold
1250 SCM buckets
, result
= init
;
1252 SCM_VALIDATE_HASHTABLE (0, table
);
1253 buckets
= SCM_HASHTABLE_VECTOR (table
);
1255 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1256 for (i
= 0; i
< n
; ++i
)
1260 for (prev
= SCM_BOOL_F
, ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
);
1262 prev
= ls
, ls
= SCM_CDR (ls
))
1266 if (!scm_is_pair (ls
))
1267 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1269 handle
= SCM_CAR (ls
);
1270 if (!scm_is_pair (handle
))
1271 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1273 if (SCM_HASHTABLE_WEAK_P (table
))
1275 if (SCM_WEAK_PAIR_DELETED_P (handle
))
1277 /* We hit a weak pair whose car/cdr has become
1278 unreachable: unlink it from the bucket. */
1279 if (prev
!= SCM_BOOL_F
)
1280 SCM_SETCDR (prev
, SCM_CDR (ls
));
1282 SCM_SIMPLE_VECTOR_SET (buckets
, i
, SCM_CDR (ls
));
1284 /* Update the item count. */
1285 SCM_HASHTABLE_DECREMENT (table
);
1291 result
= fn (closure
, SCM_CAR (handle
), SCM_CDR (handle
), result
);
1299 /* The following redundant code is here in order to be able to support
1300 hash-for-each-handle. An alternative would have been to replace
1301 this code and scm_internal_hash_fold above with a single
1302 scm_internal_hash_fold_handles, but we don't want to promote such
1306 scm_internal_hash_for_each_handle (scm_t_hash_handle_fn fn
, void *closure
,
1308 #define FUNC_NAME s_scm_hash_for_each
1313 SCM_VALIDATE_HASHTABLE (0, table
);
1314 buckets
= SCM_HASHTABLE_VECTOR (table
);
1315 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1317 for (i
= 0; i
< n
; ++i
)
1319 SCM ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
), handle
;
1320 while (!scm_is_null (ls
))
1322 if (!scm_is_pair (ls
))
1323 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1324 handle
= SCM_CAR (ls
);
1325 if (!scm_is_pair (handle
))
1326 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1327 fn (closure
, handle
);
1340 #include "libguile/hashtab.x"