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 /* Return true if OBJ is either a weak hash table or a weak alist vector (as
125 defined in `weaks.[ch]').
126 FIXME: We should eventually keep only weah hash tables. Actually, the
127 procs in `weaks.c' already no longer return vectors. */
128 /* XXX: We assume that if OBJ is a vector, then it's a _weak_ alist vector. */
129 #define IS_WEAK_THING(_obj) \
130 ((SCM_HASHTABLE_P (table) && (SCM_HASHTABLE_WEAK_P (table))) \
131 || (SCM_I_IS_VECTOR (table)))
134 /* Packed arguments for `do_weak_bucket_fixup'. */
139 size_t removed_items
;
143 do_weak_bucket_fixup (void *data
)
145 struct t_fixup_args
*args
;
148 args
= (struct t_fixup_args
*) data
;
150 args
->bucket
= scm_fixup_weak_alist (args
->bucket
, &args
->removed_items
);
152 for (pair
= args
->bucket
, copy
= args
->bucket_copy
;
154 pair
= SCM_CDR (pair
), copy
+= 2)
156 /* At this point, all weak pairs have been removed. */
157 assert (!SCM_WEAK_PAIR_DELETED_P (SCM_CAR (pair
)));
159 /* Copy the key and value. */
160 copy
[0] = SCM_CAAR (pair
);
161 copy
[1] = SCM_CDAR (pair
);
167 /* Lookup OBJECT in weak hash table TABLE using ASSOC. OBJECT is searched
168 for in the alist that is the BUCKET_INDEXth element of BUCKETS.
169 Optionally update TABLE and rehash it. */
171 weak_bucket_assoc (SCM table
, SCM buckets
, size_t bucket_index
,
172 scm_t_hash_fn hash_fn
,
173 scm_t_assoc_fn assoc
, SCM object
, void *closure
)
176 SCM bucket
, *strong_refs
;
177 struct t_fixup_args args
;
179 bucket
= SCM_SIMPLE_VECTOR_REF (buckets
, bucket_index
);
181 /* Prepare STRONG_REFS as an array large enough to hold all the keys
182 and values in BUCKET. */
183 strong_refs
= alloca (scm_ilength (bucket
) * 2 * sizeof (SCM
));
185 args
.bucket
= bucket
;
186 args
.bucket_copy
= strong_refs
;
188 /* Fixup BUCKET. Do that with the allocation lock held to avoid
189 seeing disappearing links pointing to objects that have already
190 been reclaimed (this happens when the disappearing links that point
191 to it haven't yet been cleared.)
193 The `do_weak_bucket_fixup' call populates STRONG_REFS with a copy
194 of BUCKET's entries after it's been fixed up. Thus, all the
195 entries kept in BUCKET are still reachable when ASSOC sees
197 GC_call_with_alloc_lock (do_weak_bucket_fixup
, &args
);
199 bucket
= args
.bucket
;
200 SCM_SIMPLE_VECTOR_SET (buckets
, bucket_index
, bucket
);
202 result
= assoc (object
, bucket
, closure
);
203 assert (!scm_is_pair (result
) ||
204 !SCM_WEAK_PAIR_DELETED_P (GC_is_visible (result
)));
206 scm_remember_upto_here_1 (strong_refs
);
208 if (args
.removed_items
> 0 && SCM_HASHTABLE_P (table
))
210 /* Update TABLE's item count and optionally trigger a rehash. */
213 assert (SCM_HASHTABLE_N_ITEMS (table
) >= args
.removed_items
);
215 remaining
= SCM_HASHTABLE_N_ITEMS (table
) - args
.removed_items
;
216 SCM_SET_HASHTABLE_N_ITEMS (table
, remaining
);
218 if (remaining
< SCM_HASHTABLE_LOWER (table
))
219 scm_i_rehash (table
, hash_fn
, closure
, "weak_bucket_assoc");
228 make_hash_table (int flags
, unsigned long k
, const char *func_name
)
232 int i
= 0, n
= k
? k
: 31;
233 while (i
< HASHTABLE_SIZE_N
&& n
> hashtable_size
[i
])
235 n
= hashtable_size
[i
];
237 /* In both cases, i.e., regardless of whether we are creating a weak hash
238 table, we return a non-weak vector. This is because the vector itself
239 is not weak in the case of a weak hash table: the alist pairs are. */
240 vector
= scm_c_make_vector (n
, SCM_EOL
);
242 t
= scm_gc_malloc_pointerless (sizeof (*t
), s_hashtable
);
243 t
->min_size_index
= t
->size_index
= i
;
246 t
->upper
= 9 * n
/ 10;
250 /* FIXME: we just need two words of storage, not three */
251 return scm_double_cell (scm_tc7_hashtable
, SCM_UNPACK (vector
),
256 scm_i_rehash (SCM table
,
257 scm_t_hash_fn hash_fn
,
259 const char* func_name
)
261 SCM buckets
, new_buckets
;
263 unsigned long old_size
;
264 unsigned long new_size
;
266 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
268 /* rehashing is not triggered when i <= min_size */
269 i
= SCM_HASHTABLE (table
)->size_index
;
272 while (i
> SCM_HASHTABLE (table
)->min_size_index
273 && SCM_HASHTABLE_N_ITEMS (table
) < hashtable_size
[i
] / 4);
277 i
= SCM_HASHTABLE (table
)->size_index
+ 1;
278 if (i
>= HASHTABLE_SIZE_N
)
282 /* Remember HASH_FN for rehash_after_gc, but only when CLOSURE
283 is not needed since CLOSURE can not be guaranteed to be valid
284 after this function returns.
287 SCM_HASHTABLE (table
)->hash_fn
= hash_fn
;
289 SCM_HASHTABLE (table
)->size_index
= i
;
291 new_size
= hashtable_size
[i
];
292 if (i
<= SCM_HASHTABLE (table
)->min_size_index
)
293 SCM_HASHTABLE (table
)->lower
= 0;
295 SCM_HASHTABLE (table
)->lower
= new_size
/ 4;
296 SCM_HASHTABLE (table
)->upper
= 9 * new_size
/ 10;
297 buckets
= SCM_HASHTABLE_VECTOR (table
);
299 new_buckets
= scm_c_make_vector (new_size
, SCM_EOL
);
301 /* When this is a weak hashtable, running the GC might change it.
302 We need to cope with this while rehashing its elements. We do
303 this by first installing the new, empty bucket vector. Then we
304 remove the elements from the old bucket vector and insert them
308 SCM_SET_HASHTABLE_VECTOR (table
, new_buckets
);
309 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
311 old_size
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
312 for (i
= 0; i
< old_size
; ++i
)
314 SCM ls
, cell
, handle
;
316 ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
);
317 SCM_SIMPLE_VECTOR_SET (buckets
, i
, SCM_EOL
);
319 while (scm_is_pair (ls
))
324 handle
= SCM_CAR (cell
);
327 if (SCM_WEAK_PAIR_DELETED_P (handle
))
328 /* HANDLE is a nullified weak pair: skip it. */
331 h
= hash_fn (SCM_CAR (handle
), new_size
, closure
);
333 scm_out_of_range (func_name
, scm_from_ulong (h
));
334 SCM_SETCDR (cell
, SCM_SIMPLE_VECTOR_REF (new_buckets
, h
));
335 SCM_SIMPLE_VECTOR_SET (new_buckets
, h
, cell
);
336 SCM_HASHTABLE_INCREMENT (table
);
343 scm_i_hashtable_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
345 scm_puts ("#<", port
);
346 if (SCM_HASHTABLE_WEAK_KEY_P (exp
))
347 scm_puts ("weak-key-", port
);
348 else if (SCM_HASHTABLE_WEAK_VALUE_P (exp
))
349 scm_puts ("weak-value-", port
);
350 else if (SCM_HASHTABLE_DOUBLY_WEAK_P (exp
))
351 scm_puts ("doubly-weak-", port
);
352 scm_puts ("hash-table ", port
);
353 scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp
), 10, port
);
354 scm_putc ('/', port
);
355 scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp
)),
357 scm_puts (">", port
);
362 scm_c_make_hash_table (unsigned long k
)
364 return make_hash_table (0, k
, "scm_c_make_hash_table");
367 SCM_DEFINE (scm_make_hash_table
, "make-hash-table", 0, 1, 0,
369 "Make a new abstract hash table object with minimum number of buckets @var{n}\n")
370 #define FUNC_NAME s_scm_make_hash_table
373 return make_hash_table (0, 0, FUNC_NAME
);
375 return make_hash_table (0, scm_to_ulong (n
), FUNC_NAME
);
379 SCM_DEFINE (scm_make_weak_key_hash_table
, "make-weak-key-hash-table", 0, 1, 0,
381 "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
382 "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n"
383 "Return a weak hash table with @var{size} buckets.\n"
385 "You can modify weak hash tables in exactly the same way you\n"
386 "would modify regular hash tables. (@pxref{Hash Tables})")
387 #define FUNC_NAME s_scm_make_weak_key_hash_table
390 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
, 0, FUNC_NAME
);
392 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
,
393 scm_to_ulong (n
), FUNC_NAME
);
398 SCM_DEFINE (scm_make_weak_value_hash_table
, "make-weak-value-hash-table", 0, 1, 0,
400 "Return a hash table with weak values with @var{size} buckets.\n"
401 "(@pxref{Hash Tables})")
402 #define FUNC_NAME s_scm_make_weak_value_hash_table
405 return make_hash_table (SCM_HASHTABLEF_WEAK_CDR
, 0, FUNC_NAME
);
408 return make_hash_table (SCM_HASHTABLEF_WEAK_CDR
,
409 scm_to_ulong (n
), FUNC_NAME
);
415 SCM_DEFINE (scm_make_doubly_weak_hash_table
, "make-doubly-weak-hash-table", 1, 0, 0,
417 "Return a hash table with weak keys and values with @var{size}\n"
418 "buckets. (@pxref{Hash Tables})")
419 #define FUNC_NAME s_scm_make_doubly_weak_hash_table
422 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
427 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
435 SCM_DEFINE (scm_hash_table_p
, "hash-table?", 1, 0, 0,
437 "Return @code{#t} if @var{obj} is an abstract hash table object.")
438 #define FUNC_NAME s_scm_hash_table_p
440 return scm_from_bool (SCM_HASHTABLE_P (obj
));
445 SCM_DEFINE (scm_weak_key_hash_table_p
, "weak-key-hash-table?", 1, 0, 0,
447 "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n"
448 "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n"
449 "Return @code{#t} if @var{obj} is the specified weak hash\n"
450 "table. Note that a doubly weak hash table is neither a weak key\n"
451 "nor a weak value hash table.")
452 #define FUNC_NAME s_scm_weak_key_hash_table_p
454 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_KEY_P (obj
));
459 SCM_DEFINE (scm_weak_value_hash_table_p
, "weak-value-hash-table?", 1, 0, 0,
461 "Return @code{#t} if @var{obj} is a weak value hash table.")
462 #define FUNC_NAME s_scm_weak_value_hash_table_p
464 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_VALUE_P (obj
));
469 SCM_DEFINE (scm_doubly_weak_hash_table_p
, "doubly-weak-hash-table?", 1, 0, 0,
471 "Return @code{#t} if @var{obj} is a doubly weak hash table.")
472 #define FUNC_NAME s_scm_doubly_weak_hash_table_p
474 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_DOUBLY_WEAK_P (obj
));
479 /* Accessing hash table entries. */
482 scm_hash_fn_get_handle (SCM table
, SCM obj
,
483 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
485 #define FUNC_NAME "scm_hash_fn_get_handle"
490 if (SCM_HASHTABLE_P (table
))
491 buckets
= SCM_HASHTABLE_VECTOR (table
);
494 SCM_VALIDATE_VECTOR (1, table
);
498 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
500 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
501 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
502 scm_out_of_range ("hash_fn_get_handle", scm_from_ulong (k
));
504 if (IS_WEAK_THING (table
))
505 h
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
506 assoc_fn
, obj
, closure
);
508 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
516 scm_hash_fn_create_handle_x (SCM table
, SCM obj
, SCM init
,
517 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
519 #define FUNC_NAME "scm_hash_fn_create_handle_x"
524 if (SCM_HASHTABLE_P (table
))
525 buckets
= SCM_HASHTABLE_VECTOR (table
);
528 SCM_ASSERT (scm_is_simple_vector (table
),
529 table
, SCM_ARG1
, "hash_fn_create_handle_x");
532 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
533 SCM_MISC_ERROR ("void hashtable", SCM_EOL
);
535 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
536 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
537 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
539 if (IS_WEAK_THING (table
))
540 it
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
541 assoc_fn
, obj
, closure
);
543 it
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
545 if (scm_is_pair (it
))
547 else if (scm_is_true (it
))
548 scm_wrong_type_arg_msg (NULL
, 0, it
, "a pair");
551 /* When this is a weak hashtable, running the GC can change it.
552 Thus, we must allocate the new cells first and can only then
553 access BUCKETS. Also, we need to fetch the bucket vector
554 again since the hashtable might have been rehashed. This
555 necessitates a new hash value as well.
557 SCM handle
, new_bucket
;
559 if ((SCM_HASHTABLE_P (table
)) && (SCM_HASHTABLE_WEAK_P (table
)))
561 /* FIXME: We don't support weak alist vectors. */
562 /* Use a weak cell. */
563 if (SCM_HASHTABLE_DOUBLY_WEAK_P (table
))
564 handle
= scm_doubly_weak_pair (obj
, init
);
565 else if (SCM_HASHTABLE_WEAK_KEY_P (table
))
566 handle
= scm_weak_car_pair (obj
, init
);
568 handle
= scm_weak_cdr_pair (obj
, init
);
571 /* Use a regular, non-weak cell. */
572 handle
= scm_cons (obj
, init
);
574 new_bucket
= scm_cons (handle
, SCM_EOL
);
576 if (!scm_is_eq (table
, buckets
)
577 && !scm_is_eq (SCM_HASHTABLE_VECTOR (table
), buckets
))
579 buckets
= SCM_HASHTABLE_VECTOR (table
);
580 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
581 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
582 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
584 SCM_SETCDR (new_bucket
, SCM_SIMPLE_VECTOR_REF (buckets
, k
));
585 SCM_SIMPLE_VECTOR_SET (buckets
, k
, new_bucket
);
586 if (!scm_is_eq (table
, buckets
))
588 /* Update element count and maybe rehash the table. The
589 table might have too few entries here since weak hash
590 tables used with the hashx_* functions can not be
593 SCM_HASHTABLE_INCREMENT (table
);
594 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
)
595 || SCM_HASHTABLE_N_ITEMS (table
) > SCM_HASHTABLE_UPPER (table
))
596 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
598 return SCM_CAR (new_bucket
);
605 scm_hash_fn_ref (SCM table
, SCM obj
, SCM dflt
,
606 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
609 SCM it
= scm_hash_fn_get_handle (table
, obj
, hash_fn
, assoc_fn
, closure
);
610 if (scm_is_pair (it
))
620 scm_hash_fn_set_x (SCM table
, SCM obj
, SCM val
,
621 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
626 it
= scm_hash_fn_create_handle_x (table
, obj
, SCM_BOOL_F
, hash_fn
, assoc_fn
, closure
);
627 SCM_SETCDR (it
, val
);
629 if (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_VALUE_P (table
)
631 /* IT is a weak-cdr pair. Register a disappearing link from IT's
632 cdr to VAL like `scm_weak_cdr_pair' does. */
633 SCM_I_REGISTER_DISAPPEARING_LINK ((void *) SCM_CDRLOC (it
), SCM2PTR (val
));
640 scm_hash_fn_remove_x (SCM table
, SCM obj
,
641 scm_t_hash_fn hash_fn
,
642 scm_t_assoc_fn assoc_fn
,
648 if (SCM_HASHTABLE_P (table
))
649 buckets
= SCM_HASHTABLE_VECTOR (table
);
652 SCM_ASSERT (scm_is_simple_vector (table
), table
,
653 SCM_ARG1
, "hash_fn_remove_x");
656 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
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_remove_x", scm_from_ulong (k
));
663 if (IS_WEAK_THING (table
))
664 h
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
665 assoc_fn
, obj
, closure
);
667 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
671 SCM_SIMPLE_VECTOR_SET
672 (buckets
, k
, scm_delq_x (h
, SCM_SIMPLE_VECTOR_REF (buckets
, k
)));
673 if (!scm_is_eq (table
, buckets
))
675 SCM_HASHTABLE_DECREMENT (table
);
676 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
677 scm_i_rehash (table
, hash_fn
, closure
, "scm_hash_fn_remove_x");
683 SCM_DEFINE (scm_hash_clear_x
, "hash-clear!", 1, 0, 0,
685 "Remove all items from @var{table} (without triggering a resize).")
686 #define FUNC_NAME s_scm_hash_clear_x
688 if (SCM_HASHTABLE_P (table
))
690 scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table
), SCM_EOL
);
691 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
694 scm_vector_fill_x (table
, SCM_EOL
);
695 return SCM_UNSPECIFIED
;
701 SCM_DEFINE (scm_hashq_get_handle
, "hashq-get-handle", 2, 0, 0,
702 (SCM table
, SCM key
),
703 "This procedure returns the @code{(key . value)} pair from the\n"
704 "hash table @var{table}. If @var{table} does not hold an\n"
705 "associated value for @var{key}, @code{#f} is returned.\n"
706 "Uses @code{eq?} for equality testing.")
707 #define FUNC_NAME s_scm_hashq_get_handle
709 return scm_hash_fn_get_handle (table
, key
,
710 (scm_t_hash_fn
) scm_ihashq
,
711 (scm_t_assoc_fn
) scm_sloppy_assq
,
717 SCM_DEFINE (scm_hashq_create_handle_x
, "hashq-create-handle!", 3, 0, 0,
718 (SCM table
, SCM key
, SCM init
),
719 "This function looks up @var{key} in @var{table} and returns its handle.\n"
720 "If @var{key} is not already present, a new handle is created which\n"
721 "associates @var{key} with @var{init}.")
722 #define FUNC_NAME s_scm_hashq_create_handle_x
724 return scm_hash_fn_create_handle_x (table
, key
, init
,
725 (scm_t_hash_fn
) scm_ihashq
,
726 (scm_t_assoc_fn
) scm_sloppy_assq
,
732 SCM_DEFINE (scm_hashq_ref
, "hashq-ref", 2, 1, 0,
733 (SCM table
, SCM key
, SCM dflt
),
734 "Look up @var{key} in the hash table @var{table}, and return the\n"
735 "value (if any) associated with it. If @var{key} is not found,\n"
736 "return @var{default} (or @code{#f} if no @var{default} argument\n"
737 "is supplied). Uses @code{eq?} for equality testing.")
738 #define FUNC_NAME s_scm_hashq_ref
740 if (SCM_UNBNDP (dflt
))
742 return scm_hash_fn_ref (table
, key
, dflt
,
743 (scm_t_hash_fn
) scm_ihashq
,
744 (scm_t_assoc_fn
) scm_sloppy_assq
,
751 SCM_DEFINE (scm_hashq_set_x
, "hashq-set!", 3, 0, 0,
752 (SCM table
, SCM key
, SCM val
),
753 "Find the entry in @var{table} associated with @var{key}, and\n"
754 "store @var{value} there. Uses @code{eq?} for equality testing.")
755 #define FUNC_NAME s_scm_hashq_set_x
757 return scm_hash_fn_set_x (table
, key
, val
,
758 (scm_t_hash_fn
) scm_ihashq
,
759 (scm_t_assoc_fn
) scm_sloppy_assq
,
766 SCM_DEFINE (scm_hashq_remove_x
, "hashq-remove!", 2, 0, 0,
767 (SCM table
, SCM key
),
768 "Remove @var{key} (and any value associated with it) from\n"
769 "@var{table}. Uses @code{eq?} for equality tests.")
770 #define FUNC_NAME s_scm_hashq_remove_x
772 return scm_hash_fn_remove_x (table
, key
,
773 (scm_t_hash_fn
) scm_ihashq
,
774 (scm_t_assoc_fn
) scm_sloppy_assq
,
782 SCM_DEFINE (scm_hashv_get_handle
, "hashv-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{eqv?} for equality testing.")
788 #define FUNC_NAME s_scm_hashv_get_handle
790 return scm_hash_fn_get_handle (table
, key
,
791 (scm_t_hash_fn
) scm_ihashv
,
792 (scm_t_assoc_fn
) scm_sloppy_assv
,
798 SCM_DEFINE (scm_hashv_create_handle_x
, "hashv-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_hashv_create_handle_x
805 return scm_hash_fn_create_handle_x (table
, key
, init
,
806 (scm_t_hash_fn
) scm_ihashv
,
807 (scm_t_assoc_fn
) scm_sloppy_assv
,
813 SCM_DEFINE (scm_hashv_ref
, "hashv-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{eqv?} for equality testing.")
819 #define FUNC_NAME s_scm_hashv_ref
821 if (SCM_UNBNDP (dflt
))
823 return scm_hash_fn_ref (table
, key
, dflt
,
824 (scm_t_hash_fn
) scm_ihashv
,
825 (scm_t_assoc_fn
) scm_sloppy_assv
,
832 SCM_DEFINE (scm_hashv_set_x
, "hashv-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{eqv?} for equality testing.")
836 #define FUNC_NAME s_scm_hashv_set_x
838 return scm_hash_fn_set_x (table
, key
, val
,
839 (scm_t_hash_fn
) scm_ihashv
,
840 (scm_t_assoc_fn
) scm_sloppy_assv
,
846 SCM_DEFINE (scm_hashv_remove_x
, "hashv-remove!", 2, 0, 0,
847 (SCM table
, SCM key
),
848 "Remove @var{key} (and any value associated with it) from\n"
849 "@var{table}. Uses @code{eqv?} for equality tests.")
850 #define FUNC_NAME s_scm_hashv_remove_x
852 return scm_hash_fn_remove_x (table
, key
,
853 (scm_t_hash_fn
) scm_ihashv
,
854 (scm_t_assoc_fn
) scm_sloppy_assv
,
861 SCM_DEFINE (scm_hash_get_handle
, "hash-get-handle", 2, 0, 0,
862 (SCM table
, SCM key
),
863 "This procedure returns the @code{(key . value)} pair from the\n"
864 "hash table @var{table}. If @var{table} does not hold an\n"
865 "associated value for @var{key}, @code{#f} is returned.\n"
866 "Uses @code{equal?} for equality testing.")
867 #define FUNC_NAME s_scm_hash_get_handle
869 return scm_hash_fn_get_handle (table
, key
,
870 (scm_t_hash_fn
) scm_ihash
,
871 (scm_t_assoc_fn
) scm_sloppy_assoc
,
877 SCM_DEFINE (scm_hash_create_handle_x
, "hash-create-handle!", 3, 0, 0,
878 (SCM table
, SCM key
, SCM init
),
879 "This function looks up @var{key} in @var{table} and returns its handle.\n"
880 "If @var{key} is not already present, a new handle is created which\n"
881 "associates @var{key} with @var{init}.")
882 #define FUNC_NAME s_scm_hash_create_handle_x
884 return scm_hash_fn_create_handle_x (table
, key
, init
,
885 (scm_t_hash_fn
) scm_ihash
,
886 (scm_t_assoc_fn
) scm_sloppy_assoc
,
892 SCM_DEFINE (scm_hash_ref
, "hash-ref", 2, 1, 0,
893 (SCM table
, SCM key
, SCM dflt
),
894 "Look up @var{key} in the hash table @var{table}, and return the\n"
895 "value (if any) associated with it. If @var{key} is not found,\n"
896 "return @var{default} (or @code{#f} if no @var{default} argument\n"
897 "is supplied). Uses @code{equal?} for equality testing.")
898 #define FUNC_NAME s_scm_hash_ref
900 if (SCM_UNBNDP (dflt
))
902 return scm_hash_fn_ref (table
, key
, dflt
,
903 (scm_t_hash_fn
) scm_ihash
,
904 (scm_t_assoc_fn
) scm_sloppy_assoc
,
911 SCM_DEFINE (scm_hash_set_x
, "hash-set!", 3, 0, 0,
912 (SCM table
, SCM key
, SCM val
),
913 "Find the entry in @var{table} associated with @var{key}, and\n"
914 "store @var{value} there. Uses @code{equal?} for equality\n"
916 #define FUNC_NAME s_scm_hash_set_x
918 return scm_hash_fn_set_x (table
, key
, val
,
919 (scm_t_hash_fn
) scm_ihash
,
920 (scm_t_assoc_fn
) scm_sloppy_assoc
,
927 SCM_DEFINE (scm_hash_remove_x
, "hash-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{equal?} for equality tests.")
931 #define FUNC_NAME s_scm_hash_remove_x
933 return scm_hash_fn_remove_x (table
, key
,
934 (scm_t_hash_fn
) scm_ihash
,
935 (scm_t_assoc_fn
) scm_sloppy_assoc
,
943 typedef struct scm_t_ihashx_closure
947 } scm_t_ihashx_closure
;
952 scm_ihashx (SCM obj
, unsigned long n
, void *arg
)
955 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
956 answer
= scm_call_2 (closure
->hash
, obj
, scm_from_ulong (n
));
957 return scm_to_ulong (answer
);
963 scm_sloppy_assx (SCM obj
, SCM alist
, void *arg
)
965 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
966 return scm_call_2 (closure
->assoc
, obj
, alist
);
970 SCM_DEFINE (scm_hashx_get_handle
, "hashx-get-handle", 4, 0, 0,
971 (SCM hash
, SCM assoc
, SCM table
, SCM key
),
972 "This behaves the same way as the corresponding\n"
973 "@code{-get-handle} function, but uses @var{hash} as a hash\n"
974 "function and @var{assoc} to compare keys. @code{hash} must be\n"
975 "a function that takes two arguments, a key to be hashed and a\n"
976 "table size. @code{assoc} must be an associator function, like\n"
977 "@code{assoc}, @code{assq} or @code{assv}.")
978 #define FUNC_NAME s_scm_hashx_get_handle
980 scm_t_ihashx_closure closure
;
982 closure
.assoc
= assoc
;
983 return scm_hash_fn_get_handle (table
, key
, scm_ihashx
, scm_sloppy_assx
,
989 SCM_DEFINE (scm_hashx_create_handle_x
, "hashx-create-handle!", 5, 0, 0,
990 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM init
),
991 "This behaves the same way as the corresponding\n"
992 "@code{-create-handle} function, but uses @var{hash} as a hash\n"
993 "function and @var{assoc} to compare keys. @code{hash} must be\n"
994 "a function that takes two arguments, a key to be hashed and a\n"
995 "table size. @code{assoc} must be an associator function, like\n"
996 "@code{assoc}, @code{assq} or @code{assv}.")
997 #define FUNC_NAME s_scm_hashx_create_handle_x
999 scm_t_ihashx_closure closure
;
1000 closure
.hash
= hash
;
1001 closure
.assoc
= assoc
;
1002 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashx
,
1003 scm_sloppy_assx
, (void *)&closure
);
1009 SCM_DEFINE (scm_hashx_ref
, "hashx-ref", 4, 1, 0,
1010 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM dflt
),
1011 "This behaves the same way as the corresponding @code{ref}\n"
1012 "function, but uses @var{hash} as a hash function and\n"
1013 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1014 "that takes two arguments, a key to be hashed and a table size.\n"
1015 "@code{assoc} must be an associator function, like @code{assoc},\n"
1016 "@code{assq} or @code{assv}.\n"
1018 "By way of illustration, @code{hashq-ref table key} is\n"
1019 "equivalent to @code{hashx-ref hashq assq table key}.")
1020 #define FUNC_NAME s_scm_hashx_ref
1022 scm_t_ihashx_closure closure
;
1023 if (SCM_UNBNDP (dflt
))
1025 closure
.hash
= hash
;
1026 closure
.assoc
= assoc
;
1027 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashx
, scm_sloppy_assx
,
1035 SCM_DEFINE (scm_hashx_set_x
, "hashx-set!", 5, 0, 0,
1036 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM val
),
1037 "This behaves the same way as the corresponding @code{set!}\n"
1038 "function, but uses @var{hash} as a hash function and\n"
1039 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1040 "that takes two arguments, a key to be hashed and a table size.\n"
1041 "@code{assoc} must be an associator function, like @code{assoc},\n"
1042 "@code{assq} or @code{assv}.\n"
1044 " By way of illustration, @code{hashq-set! table key} is\n"
1045 "equivalent to @code{hashx-set! hashq assq table key}.")
1046 #define FUNC_NAME s_scm_hashx_set_x
1048 scm_t_ihashx_closure closure
;
1049 closure
.hash
= hash
;
1050 closure
.assoc
= assoc
;
1051 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashx
, scm_sloppy_assx
,
1056 SCM_DEFINE (scm_hashx_remove_x
, "hashx-remove!", 4, 0, 0,
1057 (SCM hash
, SCM assoc
, SCM table
, SCM obj
),
1058 "This behaves the same way as the corresponding @code{remove!}\n"
1059 "function, but uses @var{hash} as a hash function and\n"
1060 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1061 "that takes two arguments, a key to be hashed and a table size.\n"
1062 "@code{assoc} must be an associator function, like @code{assoc},\n"
1063 "@code{assq} or @code{assv}.\n"
1065 " By way of illustration, @code{hashq-remove! table key} is\n"
1066 "equivalent to @code{hashx-remove! hashq assq #f table key}.")
1067 #define FUNC_NAME s_scm_hashx_remove_x
1069 scm_t_ihashx_closure closure
;
1070 closure
.hash
= hash
;
1071 closure
.assoc
= assoc
;
1072 return scm_hash_fn_remove_x (table
, obj
, scm_ihashx
, scm_sloppy_assx
,
1077 /* Hash table iterators */
1079 SCM_DEFINE (scm_hash_fold
, "hash-fold", 3, 0, 0,
1080 (SCM proc
, SCM init
, SCM table
),
1081 "An iterator over hash-table elements.\n"
1082 "Accumulates and returns a result by applying PROC successively.\n"
1083 "The arguments to PROC are \"(key value prior-result)\" where key\n"
1084 "and value are successive pairs from the hash table TABLE, and\n"
1085 "prior-result is either INIT (for the first application of PROC)\n"
1086 "or the return value of the previous application of PROC.\n"
1087 "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
1088 "table into an a-list of key-value pairs.")
1089 #define FUNC_NAME s_scm_hash_fold
1091 SCM_VALIDATE_PROC (1, proc
);
1092 if (!SCM_HASHTABLE_P (table
))
1093 SCM_VALIDATE_VECTOR (3, table
);
1094 return scm_internal_hash_fold ((scm_t_hash_fold_fn
) scm_call_3
,
1095 (void *) SCM_UNPACK (proc
), init
, table
);
1100 for_each_proc (void *proc
, SCM handle
)
1102 return scm_call_2 (SCM_PACK (proc
), SCM_CAR (handle
), SCM_CDR (handle
));
1105 SCM_DEFINE (scm_hash_for_each
, "hash-for-each", 2, 0, 0,
1106 (SCM proc
, SCM table
),
1107 "An iterator over hash-table elements.\n"
1108 "Applies PROC successively on all hash table items.\n"
1109 "The arguments to PROC are \"(key value)\" where key\n"
1110 "and value are successive pairs from the hash table TABLE.")
1111 #define FUNC_NAME s_scm_hash_for_each
1113 SCM_VALIDATE_PROC (1, proc
);
1114 if (!SCM_HASHTABLE_P (table
))
1115 SCM_VALIDATE_VECTOR (2, table
);
1117 scm_internal_hash_for_each_handle (for_each_proc
,
1118 (void *) SCM_UNPACK (proc
),
1120 return SCM_UNSPECIFIED
;
1124 SCM_DEFINE (scm_hash_for_each_handle
, "hash-for-each-handle", 2, 0, 0,
1125 (SCM proc
, SCM table
),
1126 "An iterator over hash-table elements.\n"
1127 "Applies PROC successively on all hash table handles.")
1128 #define FUNC_NAME s_scm_hash_for_each_handle
1130 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)), proc
, 1, FUNC_NAME
);
1131 if (!SCM_HASHTABLE_P (table
))
1132 SCM_VALIDATE_VECTOR (2, table
);
1134 scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn
) scm_call_1
,
1135 (void *) SCM_UNPACK (proc
),
1137 return SCM_UNSPECIFIED
;
1142 map_proc (void *proc
, SCM key
, SCM data
, SCM value
)
1144 return scm_cons (scm_call_2 (SCM_PACK (proc
), key
, data
), value
);
1147 SCM_DEFINE (scm_hash_map_to_list
, "hash-map->list", 2, 0, 0,
1148 (SCM proc
, SCM table
),
1149 "An iterator over hash-table elements.\n"
1150 "Accumulates and returns as a list the results of applying PROC successively.\n"
1151 "The arguments to PROC are \"(key value)\" where key\n"
1152 "and value are successive pairs from the hash table TABLE.")
1153 #define FUNC_NAME s_scm_hash_map_to_list
1155 SCM_VALIDATE_PROC (1, proc
);
1156 if (!SCM_HASHTABLE_P (table
))
1157 SCM_VALIDATE_VECTOR (2, table
);
1158 return scm_internal_hash_fold (map_proc
,
1159 (void *) SCM_UNPACK (proc
),
1168 scm_internal_hash_fold (scm_t_hash_fold_fn fn
, void *closure
,
1169 SCM init
, SCM table
)
1172 SCM buckets
, result
= init
;
1174 if (SCM_HASHTABLE_P (table
))
1175 buckets
= SCM_HASHTABLE_VECTOR (table
);
1177 /* Weak alist vector. */
1180 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1181 for (i
= 0; i
< n
; ++i
)
1185 for (prev
= SCM_BOOL_F
, ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
);
1187 prev
= ls
, ls
= SCM_CDR (ls
))
1191 if (!scm_is_pair (ls
))
1192 scm_wrong_type_arg (s_scm_hash_fold
, SCM_ARG3
, buckets
);
1194 handle
= SCM_CAR (ls
);
1195 if (!scm_is_pair (handle
))
1196 scm_wrong_type_arg (s_scm_hash_fold
, SCM_ARG3
, buckets
);
1198 if (IS_WEAK_THING (table
))
1200 if (SCM_WEAK_PAIR_DELETED_P (handle
))
1202 /* We hit a weak pair whose car/cdr has become
1203 unreachable: unlink it from the bucket. */
1204 if (prev
!= SCM_BOOL_F
)
1205 SCM_SETCDR (prev
, SCM_CDR (ls
));
1207 SCM_SIMPLE_VECTOR_SET (buckets
, i
, SCM_CDR (ls
));
1209 if (SCM_HASHTABLE_P (table
))
1210 /* Update the item count. */
1211 SCM_HASHTABLE_DECREMENT (table
);
1217 result
= fn (closure
, SCM_CAR (handle
), SCM_CDR (handle
), result
);
1224 /* The following redundant code is here in order to be able to support
1225 hash-for-each-handle. An alternative would have been to replace
1226 this code and scm_internal_hash_fold above with a single
1227 scm_internal_hash_fold_handles, but we don't want to promote such
1231 scm_internal_hash_for_each_handle (scm_t_hash_handle_fn fn
, void *closure
,
1237 if (SCM_HASHTABLE_P (table
))
1238 buckets
= SCM_HASHTABLE_VECTOR (table
);
1242 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1243 for (i
= 0; i
< n
; ++i
)
1245 SCM ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
), handle
;
1246 while (!scm_is_null (ls
))
1248 if (!scm_is_pair (ls
))
1249 scm_wrong_type_arg (s_scm_hash_for_each
, SCM_ARG3
, buckets
);
1250 handle
= SCM_CAR (ls
);
1251 if (!scm_is_pair (handle
))
1252 scm_wrong_type_arg (s_scm_hash_for_each
, SCM_ARG3
, buckets
);
1253 fn (closure
, handle
);
1265 #include "libguile/hashtab.x"