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 /* Packed arguments for `do_weak_bucket_fixup'. */
129 size_t removed_items
;
133 do_weak_bucket_fixup (void *data
)
135 struct t_fixup_args
*args
;
138 args
= (struct t_fixup_args
*) data
;
140 args
->bucket
= scm_fixup_weak_alist (args
->bucket
, &args
->removed_items
);
142 for (pair
= args
->bucket
, copy
= args
->bucket_copy
;
144 pair
= SCM_CDR (pair
), copy
+= 2)
146 /* At this point, all weak pairs have been removed. */
147 assert (!SCM_WEAK_PAIR_DELETED_P (SCM_CAR (pair
)));
149 /* Copy the key and value. */
150 copy
[0] = SCM_CAAR (pair
);
151 copy
[1] = SCM_CDAR (pair
);
157 /* Lookup OBJECT in weak hash table TABLE using ASSOC. OBJECT is searched
158 for in the alist that is the BUCKET_INDEXth element of BUCKETS.
159 Optionally update TABLE and rehash it. */
161 weak_bucket_assoc (SCM table
, SCM buckets
, size_t bucket_index
,
162 scm_t_hash_fn hash_fn
,
163 scm_t_assoc_fn assoc
, SCM object
, void *closure
)
166 SCM bucket
, *strong_refs
;
167 struct t_fixup_args args
;
169 bucket
= SCM_SIMPLE_VECTOR_REF (buckets
, bucket_index
);
171 /* Prepare STRONG_REFS as an array large enough to hold all the keys
172 and values in BUCKET. */
173 strong_refs
= alloca (scm_ilength (bucket
) * 2 * sizeof (SCM
));
175 args
.bucket
= bucket
;
176 args
.bucket_copy
= strong_refs
;
178 /* Fixup BUCKET. Do that with the allocation lock held to avoid
179 seeing disappearing links pointing to objects that have already
180 been reclaimed (this happens when the disappearing links that point
181 to it haven't yet been cleared.)
183 The `do_weak_bucket_fixup' call populates STRONG_REFS with a copy
184 of BUCKET's entries after it's been fixed up. Thus, all the
185 entries kept in BUCKET are still reachable when ASSOC sees
187 GC_call_with_alloc_lock (do_weak_bucket_fixup
, &args
);
189 bucket
= args
.bucket
;
190 SCM_SIMPLE_VECTOR_SET (buckets
, bucket_index
, bucket
);
192 result
= assoc (object
, bucket
, closure
);
193 assert (!scm_is_pair (result
) ||
194 !SCM_WEAK_PAIR_DELETED_P (GC_is_visible (result
)));
196 scm_remember_upto_here_1 (strong_refs
);
198 if (args
.removed_items
> 0)
200 /* Update TABLE's item count and optionally trigger a rehash. */
203 assert (SCM_HASHTABLE_N_ITEMS (table
) >= args
.removed_items
);
205 remaining
= SCM_HASHTABLE_N_ITEMS (table
) - args
.removed_items
;
206 SCM_SET_HASHTABLE_N_ITEMS (table
, remaining
);
208 if (remaining
< SCM_HASHTABLE_LOWER (table
))
209 scm_i_rehash (table
, hash_fn
, closure
, "weak_bucket_assoc");
216 /* Packed arguments for `weak_bucket_assoc_by_hash'. */
217 struct assoc_by_hash_data
221 scm_t_hash_predicate_fn predicate
;
225 /* See scm_hash_fn_get_handle_by_hash below. */
227 weak_bucket_assoc_by_hash (void *args
)
229 struct assoc_by_hash_data
*data
= args
;
230 SCM alist
= data
->alist
;
232 for (; scm_is_pair (alist
); alist
= SCM_CDR (alist
))
234 SCM pair
= SCM_CAR (alist
);
236 if (!SCM_WEAK_PAIR_DELETED_P (pair
)
237 && data
->predicate (SCM_CAR (pair
), data
->closure
))
249 make_hash_table (int flags
, unsigned long k
, const char *func_name
)
253 int i
= 0, n
= k
? k
: 31;
254 while (i
< HASHTABLE_SIZE_N
&& n
> hashtable_size
[i
])
256 n
= hashtable_size
[i
];
258 /* In both cases, i.e., regardless of whether we are creating a weak hash
259 table, we return a non-weak vector. This is because the vector itself
260 is not weak in the case of a weak hash table: the alist pairs are. */
261 vector
= scm_c_make_vector (n
, SCM_EOL
);
263 t
= scm_gc_malloc_pointerless (sizeof (*t
), s_hashtable
);
264 t
->min_size_index
= t
->size_index
= i
;
267 t
->upper
= 9 * n
/ 10;
271 /* FIXME: we just need two words of storage, not three */
272 return scm_double_cell (scm_tc7_hashtable
, SCM_UNPACK (vector
),
277 scm_i_rehash (SCM table
,
278 scm_t_hash_fn hash_fn
,
280 const char* func_name
)
282 SCM buckets
, new_buckets
;
284 unsigned long old_size
;
285 unsigned long new_size
;
287 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
289 /* rehashing is not triggered when i <= min_size */
290 i
= SCM_HASHTABLE (table
)->size_index
;
293 while (i
> SCM_HASHTABLE (table
)->min_size_index
294 && SCM_HASHTABLE_N_ITEMS (table
) < hashtable_size
[i
] / 4);
298 i
= SCM_HASHTABLE (table
)->size_index
+ 1;
299 if (i
>= HASHTABLE_SIZE_N
)
303 /* Remember HASH_FN for rehash_after_gc, but only when CLOSURE
304 is not needed since CLOSURE can not be guaranteed to be valid
305 after this function returns.
308 SCM_HASHTABLE (table
)->hash_fn
= hash_fn
;
310 SCM_HASHTABLE (table
)->size_index
= i
;
312 new_size
= hashtable_size
[i
];
313 if (i
<= SCM_HASHTABLE (table
)->min_size_index
)
314 SCM_HASHTABLE (table
)->lower
= 0;
316 SCM_HASHTABLE (table
)->lower
= new_size
/ 4;
317 SCM_HASHTABLE (table
)->upper
= 9 * new_size
/ 10;
318 buckets
= SCM_HASHTABLE_VECTOR (table
);
320 new_buckets
= scm_c_make_vector (new_size
, SCM_EOL
);
322 /* When this is a weak hashtable, running the GC might change it.
323 We need to cope with this while rehashing its elements. We do
324 this by first installing the new, empty bucket vector. Then we
325 remove the elements from the old bucket vector and insert them
329 SCM_SET_HASHTABLE_VECTOR (table
, new_buckets
);
330 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
332 old_size
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
333 for (i
= 0; i
< old_size
; ++i
)
335 SCM ls
, cell
, handle
;
337 ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
);
338 SCM_SIMPLE_VECTOR_SET (buckets
, i
, SCM_EOL
);
340 while (scm_is_pair (ls
))
345 handle
= SCM_CAR (cell
);
348 if (SCM_WEAK_PAIR_DELETED_P (handle
))
349 /* HANDLE is a nullified weak pair: skip it. */
352 h
= hash_fn (SCM_CAR (handle
), new_size
, closure
);
354 scm_out_of_range (func_name
, scm_from_ulong (h
));
355 SCM_SETCDR (cell
, SCM_SIMPLE_VECTOR_REF (new_buckets
, h
));
356 SCM_SIMPLE_VECTOR_SET (new_buckets
, h
, cell
);
357 SCM_HASHTABLE_INCREMENT (table
);
364 scm_i_hashtable_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
366 scm_puts ("#<", port
);
367 if (SCM_HASHTABLE_WEAK_KEY_P (exp
))
368 scm_puts ("weak-key-", port
);
369 else if (SCM_HASHTABLE_WEAK_VALUE_P (exp
))
370 scm_puts ("weak-value-", port
);
371 else if (SCM_HASHTABLE_DOUBLY_WEAK_P (exp
))
372 scm_puts ("doubly-weak-", port
);
373 scm_puts ("hash-table ", port
);
374 scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp
), 10, port
);
375 scm_putc ('/', port
);
376 scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp
)),
378 scm_puts (">", port
);
383 scm_c_make_hash_table (unsigned long k
)
385 return make_hash_table (0, k
, "scm_c_make_hash_table");
388 SCM_DEFINE (scm_make_hash_table
, "make-hash-table", 0, 1, 0,
390 "Make a new abstract hash table object with minimum number of buckets @var{n}\n")
391 #define FUNC_NAME s_scm_make_hash_table
394 return make_hash_table (0, 0, FUNC_NAME
);
396 return make_hash_table (0, scm_to_ulong (n
), FUNC_NAME
);
400 SCM_DEFINE (scm_make_weak_key_hash_table
, "make-weak-key-hash-table", 0, 1, 0,
402 "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
403 "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n"
404 "Return a weak hash table with @var{size} buckets.\n"
406 "You can modify weak hash tables in exactly the same way you\n"
407 "would modify regular hash tables. (@pxref{Hash Tables})")
408 #define FUNC_NAME s_scm_make_weak_key_hash_table
411 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
, 0, FUNC_NAME
);
413 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
,
414 scm_to_ulong (n
), FUNC_NAME
);
419 SCM_DEFINE (scm_make_weak_value_hash_table
, "make-weak-value-hash-table", 0, 1, 0,
421 "Return a hash table with weak values with @var{size} buckets.\n"
422 "(@pxref{Hash Tables})")
423 #define FUNC_NAME s_scm_make_weak_value_hash_table
426 return make_hash_table (SCM_HASHTABLEF_WEAK_CDR
, 0, FUNC_NAME
);
429 return make_hash_table (SCM_HASHTABLEF_WEAK_CDR
,
430 scm_to_ulong (n
), FUNC_NAME
);
436 SCM_DEFINE (scm_make_doubly_weak_hash_table
, "make-doubly-weak-hash-table", 1, 0, 0,
438 "Return a hash table with weak keys and values with @var{size}\n"
439 "buckets. (@pxref{Hash Tables})")
440 #define FUNC_NAME s_scm_make_doubly_weak_hash_table
443 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
448 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
456 SCM_DEFINE (scm_hash_table_p
, "hash-table?", 1, 0, 0,
458 "Return @code{#t} if @var{obj} is an abstract hash table object.")
459 #define FUNC_NAME s_scm_hash_table_p
461 return scm_from_bool (SCM_HASHTABLE_P (obj
));
466 SCM_DEFINE (scm_weak_key_hash_table_p
, "weak-key-hash-table?", 1, 0, 0,
468 "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n"
469 "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n"
470 "Return @code{#t} if @var{obj} is the specified weak hash\n"
471 "table. Note that a doubly weak hash table is neither a weak key\n"
472 "nor a weak value hash table.")
473 #define FUNC_NAME s_scm_weak_key_hash_table_p
475 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_KEY_P (obj
));
480 SCM_DEFINE (scm_weak_value_hash_table_p
, "weak-value-hash-table?", 1, 0, 0,
482 "Return @code{#t} if @var{obj} is a weak value hash table.")
483 #define FUNC_NAME s_scm_weak_value_hash_table_p
485 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_VALUE_P (obj
));
490 SCM_DEFINE (scm_doubly_weak_hash_table_p
, "doubly-weak-hash-table?", 1, 0, 0,
492 "Return @code{#t} if @var{obj} is a doubly weak hash table.")
493 #define FUNC_NAME s_scm_doubly_weak_hash_table_p
495 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_DOUBLY_WEAK_P (obj
));
500 /* Accessing hash table entries. */
503 scm_hash_fn_get_handle (SCM table
, SCM obj
,
504 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
506 #define FUNC_NAME "scm_hash_fn_get_handle"
511 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
512 buckets
= SCM_HASHTABLE_VECTOR (table
);
514 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
516 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
517 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
518 scm_out_of_range (FUNC_NAME
, scm_from_ulong (k
));
520 if (SCM_HASHTABLE_WEAK_P (table
))
521 h
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
522 assoc_fn
, obj
, closure
);
524 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
531 /* This procedure implements three optimizations, with respect to the
534 1. For weak tables, it's assumed that calling the predicate in the
535 allocation lock is safe. In practice this means that the predicate
536 cannot call arbitrary scheme functions.
538 2. We don't check for overflow / underflow and rehash.
540 3. We don't actually have to allocate a key -- instead we get the
541 hash value directly. This is useful for, for example, looking up
542 strings in the symbol table.
545 scm_hash_fn_get_handle_by_hash (SCM table
, unsigned long raw_hash
,
546 scm_t_hash_predicate_fn predicate_fn
,
548 #define FUNC_NAME "scm_hash_fn_ref_by_hash"
551 SCM buckets
, alist
, h
= SCM_BOOL_F
;
553 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
554 buckets
= SCM_HASHTABLE_VECTOR (table
);
556 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
559 k
= raw_hash
% SCM_SIMPLE_VECTOR_LENGTH (buckets
);
560 alist
= SCM_SIMPLE_VECTOR_REF (buckets
, k
);
562 if (SCM_HASHTABLE_WEAK_P (table
))
564 struct assoc_by_hash_data args
;
567 args
.ret
= SCM_BOOL_F
;
568 args
.predicate
= predicate_fn
;
569 args
.closure
= closure
;
570 GC_call_with_alloc_lock (weak_bucket_assoc_by_hash
, &args
);
574 for (; scm_is_pair (alist
); alist
= SCM_CDR (alist
))
576 SCM pair
= SCM_CAR (alist
);
577 if (predicate_fn (SCM_CAR (pair
), closure
))
590 scm_hash_fn_create_handle_x (SCM table
, SCM obj
, SCM init
,
591 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
593 #define FUNC_NAME "scm_hash_fn_create_handle_x"
598 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
599 buckets
= SCM_HASHTABLE_VECTOR (table
);
601 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
602 SCM_MISC_ERROR ("void hashtable", SCM_EOL
);
604 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
605 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
606 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
608 if (SCM_HASHTABLE_WEAK_P (table
))
609 it
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
610 assoc_fn
, obj
, closure
);
612 it
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
614 if (scm_is_pair (it
))
616 else if (scm_is_true (it
))
617 scm_wrong_type_arg_msg (NULL
, 0, it
, "a pair");
620 /* When this is a weak hashtable, running the GC can change it.
621 Thus, we must allocate the new cells first and can only then
622 access BUCKETS. Also, we need to fetch the bucket vector
623 again since the hashtable might have been rehashed. This
624 necessitates a new hash value as well.
626 SCM handle
, new_bucket
;
628 if (SCM_HASHTABLE_WEAK_P (table
))
630 /* FIXME: We don't support weak alist vectors. */
631 /* Use a weak cell. */
632 if (SCM_HASHTABLE_DOUBLY_WEAK_P (table
))
633 handle
= scm_doubly_weak_pair (obj
, init
);
634 else if (SCM_HASHTABLE_WEAK_KEY_P (table
))
635 handle
= scm_weak_car_pair (obj
, init
);
637 handle
= scm_weak_cdr_pair (obj
, init
);
640 /* Use a regular, non-weak cell. */
641 handle
= scm_cons (obj
, init
);
643 new_bucket
= scm_cons (handle
, SCM_EOL
);
645 if (!scm_is_eq (SCM_HASHTABLE_VECTOR (table
), buckets
))
647 buckets
= SCM_HASHTABLE_VECTOR (table
);
648 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
649 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
650 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
652 SCM_SETCDR (new_bucket
, SCM_SIMPLE_VECTOR_REF (buckets
, k
));
653 SCM_SIMPLE_VECTOR_SET (buckets
, k
, new_bucket
);
654 /* Update element count and maybe rehash the table. The
655 table might have too few entries here since weak hash
656 tables used with the hashx_* functions can not be
659 SCM_HASHTABLE_INCREMENT (table
);
660 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
)
661 || SCM_HASHTABLE_N_ITEMS (table
) > SCM_HASHTABLE_UPPER (table
))
662 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
663 return SCM_CAR (new_bucket
);
670 scm_hash_fn_ref (SCM table
, SCM obj
, SCM dflt
,
671 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
674 SCM it
= scm_hash_fn_get_handle (table
, obj
, hash_fn
, assoc_fn
, closure
);
675 if (scm_is_pair (it
))
685 scm_hash_fn_set_x (SCM table
, SCM obj
, SCM val
,
686 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
691 it
= scm_hash_fn_create_handle_x (table
, obj
, SCM_BOOL_F
, hash_fn
, assoc_fn
, closure
);
692 SCM_SETCDR (it
, val
);
694 if (SCM_HASHTABLE_WEAK_VALUE_P (table
) && SCM_NIMP (val
))
695 /* IT is a weak-cdr pair. Register a disappearing link from IT's
696 cdr to VAL like `scm_weak_cdr_pair' does. */
697 SCM_I_REGISTER_DISAPPEARING_LINK ((void *) SCM_CDRLOC (it
), SCM2PTR (val
));
704 scm_hash_fn_remove_x (SCM table
, SCM obj
,
705 scm_t_hash_fn hash_fn
,
706 scm_t_assoc_fn assoc_fn
,
708 #define FUNC_NAME "hash_fn_remove_x"
713 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
715 buckets
= SCM_HASHTABLE_VECTOR (table
);
717 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
720 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
721 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
722 scm_out_of_range (FUNC_NAME
, scm_from_ulong (k
));
724 if (SCM_HASHTABLE_WEAK_P (table
))
725 h
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
726 assoc_fn
, obj
, closure
);
728 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
732 SCM_SIMPLE_VECTOR_SET
733 (buckets
, k
, scm_delq_x (h
, SCM_SIMPLE_VECTOR_REF (buckets
, k
)));
734 SCM_HASHTABLE_DECREMENT (table
);
735 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
736 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
742 SCM_DEFINE (scm_hash_clear_x
, "hash-clear!", 1, 0, 0,
744 "Remove all items from @var{table} (without triggering a resize).")
745 #define FUNC_NAME s_scm_hash_clear_x
747 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
749 scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table
), SCM_EOL
);
750 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
752 return SCM_UNSPECIFIED
;
758 SCM_DEFINE (scm_hashq_get_handle
, "hashq-get-handle", 2, 0, 0,
759 (SCM table
, SCM key
),
760 "This procedure returns the @code{(key . value)} pair from the\n"
761 "hash table @var{table}. If @var{table} does not hold an\n"
762 "associated value for @var{key}, @code{#f} is returned.\n"
763 "Uses @code{eq?} for equality testing.")
764 #define FUNC_NAME s_scm_hashq_get_handle
766 return scm_hash_fn_get_handle (table
, key
,
767 (scm_t_hash_fn
) scm_ihashq
,
768 (scm_t_assoc_fn
) scm_sloppy_assq
,
774 SCM_DEFINE (scm_hashq_create_handle_x
, "hashq-create-handle!", 3, 0, 0,
775 (SCM table
, SCM key
, SCM init
),
776 "This function looks up @var{key} in @var{table} and returns its handle.\n"
777 "If @var{key} is not already present, a new handle is created which\n"
778 "associates @var{key} with @var{init}.")
779 #define FUNC_NAME s_scm_hashq_create_handle_x
781 return scm_hash_fn_create_handle_x (table
, key
, init
,
782 (scm_t_hash_fn
) scm_ihashq
,
783 (scm_t_assoc_fn
) scm_sloppy_assq
,
789 SCM_DEFINE (scm_hashq_ref
, "hashq-ref", 2, 1, 0,
790 (SCM table
, SCM key
, SCM dflt
),
791 "Look up @var{key} in the hash table @var{table}, and return the\n"
792 "value (if any) associated with it. If @var{key} is not found,\n"
793 "return @var{default} (or @code{#f} if no @var{default} argument\n"
794 "is supplied). Uses @code{eq?} for equality testing.")
795 #define FUNC_NAME s_scm_hashq_ref
797 if (SCM_UNBNDP (dflt
))
799 return scm_hash_fn_ref (table
, key
, dflt
,
800 (scm_t_hash_fn
) scm_ihashq
,
801 (scm_t_assoc_fn
) scm_sloppy_assq
,
808 SCM_DEFINE (scm_hashq_set_x
, "hashq-set!", 3, 0, 0,
809 (SCM table
, SCM key
, SCM val
),
810 "Find the entry in @var{table} associated with @var{key}, and\n"
811 "store @var{value} there. Uses @code{eq?} for equality testing.")
812 #define FUNC_NAME s_scm_hashq_set_x
814 return scm_hash_fn_set_x (table
, key
, val
,
815 (scm_t_hash_fn
) scm_ihashq
,
816 (scm_t_assoc_fn
) scm_sloppy_assq
,
823 SCM_DEFINE (scm_hashq_remove_x
, "hashq-remove!", 2, 0, 0,
824 (SCM table
, SCM key
),
825 "Remove @var{key} (and any value associated with it) from\n"
826 "@var{table}. Uses @code{eq?} for equality tests.")
827 #define FUNC_NAME s_scm_hashq_remove_x
829 return scm_hash_fn_remove_x (table
, key
,
830 (scm_t_hash_fn
) scm_ihashq
,
831 (scm_t_assoc_fn
) scm_sloppy_assq
,
839 SCM_DEFINE (scm_hashv_get_handle
, "hashv-get-handle", 2, 0, 0,
840 (SCM table
, SCM key
),
841 "This procedure returns the @code{(key . value)} pair from the\n"
842 "hash table @var{table}. If @var{table} does not hold an\n"
843 "associated value for @var{key}, @code{#f} is returned.\n"
844 "Uses @code{eqv?} for equality testing.")
845 #define FUNC_NAME s_scm_hashv_get_handle
847 return scm_hash_fn_get_handle (table
, key
,
848 (scm_t_hash_fn
) scm_ihashv
,
849 (scm_t_assoc_fn
) scm_sloppy_assv
,
855 SCM_DEFINE (scm_hashv_create_handle_x
, "hashv-create-handle!", 3, 0, 0,
856 (SCM table
, SCM key
, SCM init
),
857 "This function looks up @var{key} in @var{table} and returns its handle.\n"
858 "If @var{key} is not already present, a new handle is created which\n"
859 "associates @var{key} with @var{init}.")
860 #define FUNC_NAME s_scm_hashv_create_handle_x
862 return scm_hash_fn_create_handle_x (table
, key
, init
,
863 (scm_t_hash_fn
) scm_ihashv
,
864 (scm_t_assoc_fn
) scm_sloppy_assv
,
870 SCM_DEFINE (scm_hashv_ref
, "hashv-ref", 2, 1, 0,
871 (SCM table
, SCM key
, SCM dflt
),
872 "Look up @var{key} in the hash table @var{table}, and return the\n"
873 "value (if any) associated with it. If @var{key} is not found,\n"
874 "return @var{default} (or @code{#f} if no @var{default} argument\n"
875 "is supplied). Uses @code{eqv?} for equality testing.")
876 #define FUNC_NAME s_scm_hashv_ref
878 if (SCM_UNBNDP (dflt
))
880 return scm_hash_fn_ref (table
, key
, dflt
,
881 (scm_t_hash_fn
) scm_ihashv
,
882 (scm_t_assoc_fn
) scm_sloppy_assv
,
889 SCM_DEFINE (scm_hashv_set_x
, "hashv-set!", 3, 0, 0,
890 (SCM table
, SCM key
, SCM val
),
891 "Find the entry in @var{table} associated with @var{key}, and\n"
892 "store @var{value} there. Uses @code{eqv?} for equality testing.")
893 #define FUNC_NAME s_scm_hashv_set_x
895 return scm_hash_fn_set_x (table
, key
, val
,
896 (scm_t_hash_fn
) scm_ihashv
,
897 (scm_t_assoc_fn
) scm_sloppy_assv
,
903 SCM_DEFINE (scm_hashv_remove_x
, "hashv-remove!", 2, 0, 0,
904 (SCM table
, SCM key
),
905 "Remove @var{key} (and any value associated with it) from\n"
906 "@var{table}. Uses @code{eqv?} for equality tests.")
907 #define FUNC_NAME s_scm_hashv_remove_x
909 return scm_hash_fn_remove_x (table
, key
,
910 (scm_t_hash_fn
) scm_ihashv
,
911 (scm_t_assoc_fn
) scm_sloppy_assv
,
918 SCM_DEFINE (scm_hash_get_handle
, "hash-get-handle", 2, 0, 0,
919 (SCM table
, SCM key
),
920 "This procedure returns the @code{(key . value)} pair from the\n"
921 "hash table @var{table}. If @var{table} does not hold an\n"
922 "associated value for @var{key}, @code{#f} is returned.\n"
923 "Uses @code{equal?} for equality testing.")
924 #define FUNC_NAME s_scm_hash_get_handle
926 return scm_hash_fn_get_handle (table
, key
,
927 (scm_t_hash_fn
) scm_ihash
,
928 (scm_t_assoc_fn
) scm_sloppy_assoc
,
934 SCM_DEFINE (scm_hash_create_handle_x
, "hash-create-handle!", 3, 0, 0,
935 (SCM table
, SCM key
, SCM init
),
936 "This function looks up @var{key} in @var{table} and returns its handle.\n"
937 "If @var{key} is not already present, a new handle is created which\n"
938 "associates @var{key} with @var{init}.")
939 #define FUNC_NAME s_scm_hash_create_handle_x
941 return scm_hash_fn_create_handle_x (table
, key
, init
,
942 (scm_t_hash_fn
) scm_ihash
,
943 (scm_t_assoc_fn
) scm_sloppy_assoc
,
949 SCM_DEFINE (scm_hash_ref
, "hash-ref", 2, 1, 0,
950 (SCM table
, SCM key
, SCM dflt
),
951 "Look up @var{key} in the hash table @var{table}, and return the\n"
952 "value (if any) associated with it. If @var{key} is not found,\n"
953 "return @var{default} (or @code{#f} if no @var{default} argument\n"
954 "is supplied). Uses @code{equal?} for equality testing.")
955 #define FUNC_NAME s_scm_hash_ref
957 if (SCM_UNBNDP (dflt
))
959 return scm_hash_fn_ref (table
, key
, dflt
,
960 (scm_t_hash_fn
) scm_ihash
,
961 (scm_t_assoc_fn
) scm_sloppy_assoc
,
968 SCM_DEFINE (scm_hash_set_x
, "hash-set!", 3, 0, 0,
969 (SCM table
, SCM key
, SCM val
),
970 "Find the entry in @var{table} associated with @var{key}, and\n"
971 "store @var{value} there. Uses @code{equal?} for equality\n"
973 #define FUNC_NAME s_scm_hash_set_x
975 return scm_hash_fn_set_x (table
, key
, val
,
976 (scm_t_hash_fn
) scm_ihash
,
977 (scm_t_assoc_fn
) scm_sloppy_assoc
,
984 SCM_DEFINE (scm_hash_remove_x
, "hash-remove!", 2, 0, 0,
985 (SCM table
, SCM key
),
986 "Remove @var{key} (and any value associated with it) from\n"
987 "@var{table}. Uses @code{equal?} for equality tests.")
988 #define FUNC_NAME s_scm_hash_remove_x
990 return scm_hash_fn_remove_x (table
, key
,
991 (scm_t_hash_fn
) scm_ihash
,
992 (scm_t_assoc_fn
) scm_sloppy_assoc
,
1000 typedef struct scm_t_ihashx_closure
1004 } scm_t_ihashx_closure
;
1008 static unsigned long
1009 scm_ihashx (SCM obj
, unsigned long n
, void *arg
)
1012 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
1013 answer
= scm_call_2 (closure
->hash
, obj
, scm_from_ulong (n
));
1014 return scm_to_ulong (answer
);
1020 scm_sloppy_assx (SCM obj
, SCM alist
, void *arg
)
1022 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
1023 return scm_call_2 (closure
->assoc
, obj
, alist
);
1027 SCM_DEFINE (scm_hashx_get_handle
, "hashx-get-handle", 4, 0, 0,
1028 (SCM hash
, SCM assoc
, SCM table
, SCM key
),
1029 "This behaves the same way as the corresponding\n"
1030 "@code{-get-handle} function, but uses @var{hash} as a hash\n"
1031 "function and @var{assoc} to compare keys. @code{hash} must be\n"
1032 "a function that takes two arguments, a key to be hashed and a\n"
1033 "table size. @code{assoc} must be an associator function, like\n"
1034 "@code{assoc}, @code{assq} or @code{assv}.")
1035 #define FUNC_NAME s_scm_hashx_get_handle
1037 scm_t_ihashx_closure closure
;
1038 closure
.hash
= hash
;
1039 closure
.assoc
= assoc
;
1040 return scm_hash_fn_get_handle (table
, key
, scm_ihashx
, scm_sloppy_assx
,
1046 SCM_DEFINE (scm_hashx_create_handle_x
, "hashx-create-handle!", 5, 0, 0,
1047 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM init
),
1048 "This behaves the same way as the corresponding\n"
1049 "@code{-create-handle} function, but uses @var{hash} as a hash\n"
1050 "function and @var{assoc} to compare keys. @code{hash} must be\n"
1051 "a function that takes two arguments, a key to be hashed and a\n"
1052 "table size. @code{assoc} must be an associator function, like\n"
1053 "@code{assoc}, @code{assq} or @code{assv}.")
1054 #define FUNC_NAME s_scm_hashx_create_handle_x
1056 scm_t_ihashx_closure closure
;
1057 closure
.hash
= hash
;
1058 closure
.assoc
= assoc
;
1059 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashx
,
1060 scm_sloppy_assx
, (void *)&closure
);
1066 SCM_DEFINE (scm_hashx_ref
, "hashx-ref", 4, 1, 0,
1067 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM dflt
),
1068 "This behaves the same way as the corresponding @code{ref}\n"
1069 "function, but uses @var{hash} as a hash function and\n"
1070 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1071 "that takes two arguments, a key to be hashed and a table size.\n"
1072 "@code{assoc} must be an associator function, like @code{assoc},\n"
1073 "@code{assq} or @code{assv}.\n"
1075 "By way of illustration, @code{hashq-ref table key} is\n"
1076 "equivalent to @code{hashx-ref hashq assq table key}.")
1077 #define FUNC_NAME s_scm_hashx_ref
1079 scm_t_ihashx_closure closure
;
1080 if (SCM_UNBNDP (dflt
))
1082 closure
.hash
= hash
;
1083 closure
.assoc
= assoc
;
1084 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashx
, scm_sloppy_assx
,
1092 SCM_DEFINE (scm_hashx_set_x
, "hashx-set!", 5, 0, 0,
1093 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM val
),
1094 "This behaves the same way as the corresponding @code{set!}\n"
1095 "function, but uses @var{hash} as a hash function and\n"
1096 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1097 "that takes two arguments, a key to be hashed and a table size.\n"
1098 "@code{assoc} must be an associator function, like @code{assoc},\n"
1099 "@code{assq} or @code{assv}.\n"
1101 " By way of illustration, @code{hashq-set! table key} is\n"
1102 "equivalent to @code{hashx-set! hashq assq table key}.")
1103 #define FUNC_NAME s_scm_hashx_set_x
1105 scm_t_ihashx_closure closure
;
1106 closure
.hash
= hash
;
1107 closure
.assoc
= assoc
;
1108 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashx
, scm_sloppy_assx
,
1113 SCM_DEFINE (scm_hashx_remove_x
, "hashx-remove!", 4, 0, 0,
1114 (SCM hash
, SCM assoc
, SCM table
, SCM obj
),
1115 "This behaves the same way as the corresponding @code{remove!}\n"
1116 "function, but uses @var{hash} as a hash function and\n"
1117 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1118 "that takes two arguments, a key to be hashed and a table size.\n"
1119 "@code{assoc} must be an associator function, like @code{assoc},\n"
1120 "@code{assq} or @code{assv}.\n"
1122 " By way of illustration, @code{hashq-remove! table key} is\n"
1123 "equivalent to @code{hashx-remove! hashq assq #f table key}.")
1124 #define FUNC_NAME s_scm_hashx_remove_x
1126 scm_t_ihashx_closure closure
;
1127 closure
.hash
= hash
;
1128 closure
.assoc
= assoc
;
1129 return scm_hash_fn_remove_x (table
, obj
, scm_ihashx
, scm_sloppy_assx
,
1134 /* Hash table iterators */
1136 SCM_DEFINE (scm_hash_fold
, "hash-fold", 3, 0, 0,
1137 (SCM proc
, SCM init
, SCM table
),
1138 "An iterator over hash-table elements.\n"
1139 "Accumulates and returns a result by applying PROC successively.\n"
1140 "The arguments to PROC are \"(key value prior-result)\" where key\n"
1141 "and value are successive pairs from the hash table TABLE, and\n"
1142 "prior-result is either INIT (for the first application of PROC)\n"
1143 "or the return value of the previous application of PROC.\n"
1144 "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
1145 "table into an a-list of key-value pairs.")
1146 #define FUNC_NAME s_scm_hash_fold
1148 SCM_VALIDATE_PROC (1, proc
);
1149 SCM_VALIDATE_HASHTABLE (3, table
);
1150 return scm_internal_hash_fold ((scm_t_hash_fold_fn
) scm_call_3
,
1151 (void *) SCM_UNPACK (proc
), init
, table
);
1156 for_each_proc (void *proc
, SCM handle
)
1158 return scm_call_2 (SCM_PACK (proc
), SCM_CAR (handle
), SCM_CDR (handle
));
1161 SCM_DEFINE (scm_hash_for_each
, "hash-for-each", 2, 0, 0,
1162 (SCM proc
, SCM table
),
1163 "An iterator over hash-table elements.\n"
1164 "Applies PROC successively on all hash table items.\n"
1165 "The arguments to PROC are \"(key value)\" where key\n"
1166 "and value are successive pairs from the hash table TABLE.")
1167 #define FUNC_NAME s_scm_hash_for_each
1169 SCM_VALIDATE_PROC (1, proc
);
1170 SCM_VALIDATE_HASHTABLE (2, table
);
1172 scm_internal_hash_for_each_handle (for_each_proc
,
1173 (void *) SCM_UNPACK (proc
),
1175 return SCM_UNSPECIFIED
;
1179 SCM_DEFINE (scm_hash_for_each_handle
, "hash-for-each-handle", 2, 0, 0,
1180 (SCM proc
, SCM table
),
1181 "An iterator over hash-table elements.\n"
1182 "Applies PROC successively on all hash table handles.")
1183 #define FUNC_NAME s_scm_hash_for_each_handle
1185 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)), proc
, 1, FUNC_NAME
);
1186 SCM_VALIDATE_HASHTABLE (2, table
);
1188 scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn
) scm_call_1
,
1189 (void *) SCM_UNPACK (proc
),
1191 return SCM_UNSPECIFIED
;
1196 map_proc (void *proc
, SCM key
, SCM data
, SCM value
)
1198 return scm_cons (scm_call_2 (SCM_PACK (proc
), key
, data
), value
);
1201 SCM_DEFINE (scm_hash_map_to_list
, "hash-map->list", 2, 0, 0,
1202 (SCM proc
, SCM table
),
1203 "An iterator over hash-table elements.\n"
1204 "Accumulates and returns as a list the results of applying PROC successively.\n"
1205 "The arguments to PROC are \"(key value)\" where key\n"
1206 "and value are successive pairs from the hash table TABLE.")
1207 #define FUNC_NAME s_scm_hash_map_to_list
1209 SCM_VALIDATE_PROC (1, proc
);
1210 SCM_VALIDATE_HASHTABLE (2, table
);
1211 return scm_internal_hash_fold (map_proc
,
1212 (void *) SCM_UNPACK (proc
),
1221 scm_internal_hash_fold (scm_t_hash_fold_fn fn
, void *closure
,
1222 SCM init
, SCM table
)
1223 #define FUNC_NAME s_scm_hash_fold
1226 SCM buckets
, result
= init
;
1228 SCM_VALIDATE_HASHTABLE (0, table
);
1229 buckets
= SCM_HASHTABLE_VECTOR (table
);
1231 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1232 for (i
= 0; i
< n
; ++i
)
1236 for (prev
= SCM_BOOL_F
, ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
);
1238 prev
= ls
, ls
= SCM_CDR (ls
))
1242 if (!scm_is_pair (ls
))
1243 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1245 handle
= SCM_CAR (ls
);
1246 if (!scm_is_pair (handle
))
1247 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1249 if (SCM_HASHTABLE_WEAK_P (table
))
1251 if (SCM_WEAK_PAIR_DELETED_P (handle
))
1253 /* We hit a weak pair whose car/cdr has become
1254 unreachable: unlink it from the bucket. */
1255 if (prev
!= SCM_BOOL_F
)
1256 SCM_SETCDR (prev
, SCM_CDR (ls
));
1258 SCM_SIMPLE_VECTOR_SET (buckets
, i
, SCM_CDR (ls
));
1260 /* Update the item count. */
1261 SCM_HASHTABLE_DECREMENT (table
);
1267 result
= fn (closure
, SCM_CAR (handle
), SCM_CDR (handle
), result
);
1275 /* The following redundant code is here in order to be able to support
1276 hash-for-each-handle. An alternative would have been to replace
1277 this code and scm_internal_hash_fold above with a single
1278 scm_internal_hash_fold_handles, but we don't want to promote such
1282 scm_internal_hash_for_each_handle (scm_t_hash_handle_fn fn
, void *closure
,
1284 #define FUNC_NAME s_scm_hash_for_each
1289 SCM_VALIDATE_HASHTABLE (0, table
);
1290 buckets
= SCM_HASHTABLE_VECTOR (table
);
1291 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1293 for (i
= 0; i
< n
; ++i
)
1295 SCM ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
), handle
;
1296 while (!scm_is_null (ls
))
1298 if (!scm_is_pair (ls
))
1299 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1300 handle
= SCM_CAR (ls
);
1301 if (!scm_is_pair (handle
))
1302 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1303 fn (closure
, handle
);
1316 #include "libguile/hashtab.x"