1 /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2009 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
28 #include "libguile/_scm.h"
29 #include "libguile/alist.h"
30 #include "libguile/hash.h"
31 #include "libguile/eval.h"
32 #include "libguile/root.h"
33 #include "libguile/vectors.h"
34 #include "libguile/ports.h"
36 #include "libguile/validate.h"
37 #include "libguile/hashtab.h"
44 * 1. The current hash table implementation uses weak alist vectors
45 * (implementation in weaks.c) internally, but we do the scanning
46 * ourselves (in scan_weak_hashtables) because we need to update the
47 * hash table structure when items are dropped during GC.
49 * 2. All hash table operations still work on alist vectors.
53 /* A hash table is a cell containing a vector of association lists.
55 * Growing or shrinking, with following rehashing, is triggered when
58 * L = N / S (N: number of items in table, S: bucket vector length)
60 * passes an upper limit of 0.9 or a lower limit of 0.25.
62 * The implementation stores the upper and lower number of items which
63 * trigger a resize in the hashtable object.
65 * Possible hash table sizes (primes) are stored in the array
69 static unsigned long hashtable_size
[] = {
70 31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363,
71 224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041
73 /* vectors are currently restricted to 2^24-1 = 16777215 elements. */
74 28762081, 57524111, 115048217, 230096423, 460192829
75 /* larger values can't be represented as INUMs */
79 #define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long))
81 static char *s_hashtable
= "hashtable";
85 /* Helper functions and macros to deal with weak pairs.
87 Weak pairs need to be accessed very carefully since their components can
88 be nullified by the GC when the object they refer to becomes unreachable.
89 Hence the macros and functions below that detect such weak pairs within
90 buckets and remove them. */
93 /* Remove nullified weak pairs from ALIST such that the result contains only
94 valid pairs. Set REMOVED_ITEMS to the number of pairs that have been
97 scm_fixup_weak_alist (SCM alist
, size_t *removed_items
)
105 prev
= alist
, alist
= SCM_CDR (alist
))
107 SCM pair
= SCM_CAR (alist
);
109 if (scm_is_pair (pair
))
111 if (SCM_WEAK_PAIR_DELETED_P (pair
))
113 /* Remove from ALIST weak pair PAIR whose car/cdr has been
114 nullified by the GC. */
116 result
= SCM_CDR (alist
);
118 SCM_SETCDR (prev
, SCM_CDR (alist
));
130 /* Return true if OBJ is either a weak hash table or a weak alist vector (as
131 defined in `weaks.[ch]').
132 FIXME: We should eventually keep only weah hash tables. Actually, the
133 procs in `weaks.c' already no longer return vectors. */
134 /* XXX: We assume that if OBJ is a vector, then it's a _weak_ alist vector. */
135 #define IS_WEAK_THING(_obj) \
136 ((SCM_HASHTABLE_P (table) && (SCM_HASHTABLE_WEAK_P (table))) \
137 || (SCM_I_IS_VECTOR (table)))
140 /* Packed arguments for `do_weak_bucket_assoc ()'. */
143 /* Input arguments. */
147 scm_t_assoc_fn assoc_fn
;
150 /* Output arguments. */
152 size_t removed_items
;
156 do_weak_bucket_assoc (void *data
)
158 struct t_assoc_args
*args
;
162 args
= (struct t_assoc_args
*) data
;
164 bucket
= SCM_SIMPLE_VECTOR_REF (args
->buckets
, args
->bucket_index
);
165 bucket
= scm_fixup_weak_alist (bucket
, &removed
);
167 SCM_SIMPLE_VECTOR_SET (args
->buckets
, args
->bucket_index
, bucket
);
169 /* Run ASSOC_FN on the now clean BUCKET. */
170 result
= args
->assoc_fn (args
->object
, bucket
, args
->closure
);
172 args
->result
= result
;
173 args
->removed_items
= removed
;
178 /* Lookup OBJECT in weak hash table TABLE using ASSOC. OBJECT is searched
179 for in the alist that is the BUCKET_INDEXth element of BUCKETS.
180 Optionally update TABLE and rehash it. */
182 weak_bucket_assoc (SCM table
, SCM buckets
, size_t bucket_index
,
183 scm_t_hash_fn hash_fn
,
184 scm_t_assoc_fn assoc
, SCM object
, void *closure
)
187 struct t_assoc_args args
;
189 args
.object
= object
;
190 args
.buckets
= buckets
;
191 args
.bucket_index
= bucket_index
;
192 args
.assoc_fn
= assoc
;
193 args
.closure
= closure
;
195 /* Fixup the bucket and pass the clean bucket to ASSOC. Do that with the
196 allocation lock held to avoid seeing disappearing links pointing to
197 objects that have already been reclaimed (this happens when the
198 disappearing links that point to it haven't yet been cleared.)
199 Thus, ASSOC must not take long, and it must not make any non-local
201 GC_call_with_alloc_lock (do_weak_bucket_assoc
, &args
);
203 result
= args
.result
;
204 assert (!scm_is_pair (result
) ||
205 !SCM_WEAK_PAIR_DELETED_P (GC_is_visible (result
)));
207 if (args
.removed_items
> 0 && SCM_HASHTABLE_P (table
))
209 /* Update TABLE's item count and optionally trigger a rehash. */
212 assert (SCM_HASHTABLE_N_ITEMS (table
) >= args
.removed_items
);
214 remaining
= SCM_HASHTABLE_N_ITEMS (table
) - args
.removed_items
;
215 SCM_SET_HASHTABLE_N_ITEMS (table
, remaining
);
217 scm_i_rehash (table
, hash_fn
, closure
, "weak_bucket_assoc");
226 make_hash_table (int flags
, unsigned long k
, const char *func_name
)
230 int i
= 0, n
= k
? k
: 31;
231 while (i
< HASHTABLE_SIZE_N
&& n
> hashtable_size
[i
])
233 n
= hashtable_size
[i
];
235 /* In both cases, i.e., regardless of whether we are creating a weak hash
236 table, we return a non-weak vector. This is because the vector itself
237 is not weak in the case of a weak hash table: the alist pairs are. */
238 vector
= scm_c_make_vector (n
, SCM_EOL
);
240 t
= scm_gc_malloc_pointerless (sizeof (*t
), s_hashtable
);
241 t
->min_size_index
= t
->size_index
= i
;
244 t
->upper
= 9 * n
/ 10;
248 /* FIXME: we just need two words of storage, not three */
249 return scm_double_cell (scm_tc7_hashtable
, SCM_UNPACK (vector
),
254 scm_i_rehash (SCM table
,
255 scm_t_hash_fn hash_fn
,
257 const char* func_name
)
259 SCM buckets
, new_buckets
;
261 unsigned long old_size
;
262 unsigned long new_size
;
264 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
266 /* rehashing is not triggered when i <= min_size */
267 i
= SCM_HASHTABLE (table
)->size_index
;
270 while (i
> SCM_HASHTABLE (table
)->min_size_index
271 && SCM_HASHTABLE_N_ITEMS (table
) < hashtable_size
[i
] / 4);
275 i
= SCM_HASHTABLE (table
)->size_index
+ 1;
276 if (i
>= HASHTABLE_SIZE_N
)
280 /* Remember HASH_FN for rehash_after_gc, but only when CLOSURE
281 is not needed since CLOSURE can not be guaranteed to be valid
282 after this function returns.
285 SCM_HASHTABLE (table
)->hash_fn
= hash_fn
;
287 SCM_HASHTABLE (table
)->size_index
= i
;
289 new_size
= hashtable_size
[i
];
290 if (i
<= SCM_HASHTABLE (table
)->min_size_index
)
291 SCM_HASHTABLE (table
)->lower
= 0;
293 SCM_HASHTABLE (table
)->lower
= new_size
/ 4;
294 SCM_HASHTABLE (table
)->upper
= 9 * new_size
/ 10;
295 buckets
= SCM_HASHTABLE_VECTOR (table
);
297 new_buckets
= scm_c_make_vector (new_size
, SCM_EOL
);
299 /* When this is a weak hashtable, running the GC might change it.
300 We need to cope with this while rehashing its elements. We do
301 this by first installing the new, empty bucket vector. Then we
302 remove the elements from the old bucket vector and insert them
306 SCM_SET_HASHTABLE_VECTOR (table
, new_buckets
);
307 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
309 old_size
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
310 for (i
= 0; i
< old_size
; ++i
)
312 SCM ls
, cell
, handle
;
314 ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
);
315 SCM_SIMPLE_VECTOR_SET (buckets
, i
, SCM_EOL
);
317 while (scm_is_pair (ls
))
322 handle
= SCM_CAR (cell
);
325 if (SCM_WEAK_PAIR_DELETED_P (handle
))
326 /* HANDLE is a nullified weak pair: skip it. */
329 h
= hash_fn (SCM_CAR (handle
), new_size
, closure
);
331 scm_out_of_range (func_name
, scm_from_ulong (h
));
332 SCM_SETCDR (cell
, SCM_SIMPLE_VECTOR_REF (new_buckets
, h
));
333 SCM_SIMPLE_VECTOR_SET (new_buckets
, h
, cell
);
334 SCM_HASHTABLE_INCREMENT (table
);
341 scm_i_hashtable_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
343 scm_puts ("#<", port
);
344 if (SCM_HASHTABLE_WEAK_KEY_P (exp
))
345 scm_puts ("weak-key-", port
);
346 else if (SCM_HASHTABLE_WEAK_VALUE_P (exp
))
347 scm_puts ("weak-value-", port
);
348 else if (SCM_HASHTABLE_DOUBLY_WEAK_P (exp
))
349 scm_puts ("doubly-weak-", port
);
350 scm_puts ("hash-table ", port
);
351 scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp
), 10, port
);
352 scm_putc ('/', port
);
353 scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp
)),
355 scm_puts (">", port
);
360 scm_c_make_hash_table (unsigned long k
)
362 return make_hash_table (0, k
, "scm_c_make_hash_table");
365 SCM_DEFINE (scm_make_hash_table
, "make-hash-table", 0, 1, 0,
367 "Make a new abstract hash table object with minimum number of buckets @var{n}\n")
368 #define FUNC_NAME s_scm_make_hash_table
371 return make_hash_table (0, 0, FUNC_NAME
);
373 return make_hash_table (0, scm_to_ulong (n
), FUNC_NAME
);
377 SCM_DEFINE (scm_make_weak_key_hash_table
, "make-weak-key-hash-table", 0, 1, 0,
379 "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
380 "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n"
381 "Return a weak hash table with @var{size} buckets.\n"
383 "You can modify weak hash tables in exactly the same way you\n"
384 "would modify regular hash tables. (@pxref{Hash Tables})")
385 #define FUNC_NAME s_scm_make_weak_key_hash_table
388 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
, 0, FUNC_NAME
);
390 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
,
391 scm_to_ulong (n
), FUNC_NAME
);
396 SCM_DEFINE (scm_make_weak_value_hash_table
, "make-weak-value-hash-table", 0, 1, 0,
398 "Return a hash table with weak values with @var{size} buckets.\n"
399 "(@pxref{Hash Tables})")
400 #define FUNC_NAME s_scm_make_weak_value_hash_table
403 return make_hash_table (SCM_HASHTABLEF_WEAK_CDR
, 0, FUNC_NAME
);
406 return make_hash_table (SCM_HASHTABLEF_WEAK_CDR
,
407 scm_to_ulong (n
), FUNC_NAME
);
413 SCM_DEFINE (scm_make_doubly_weak_hash_table
, "make-doubly-weak-hash-table", 1, 0, 0,
415 "Return a hash table with weak keys and values with @var{size}\n"
416 "buckets. (@pxref{Hash Tables})")
417 #define FUNC_NAME s_scm_make_doubly_weak_hash_table
420 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
425 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
433 SCM_DEFINE (scm_hash_table_p
, "hash-table?", 1, 0, 0,
435 "Return @code{#t} if @var{obj} is an abstract hash table object.")
436 #define FUNC_NAME s_scm_hash_table_p
438 return scm_from_bool (SCM_HASHTABLE_P (obj
));
443 SCM_DEFINE (scm_weak_key_hash_table_p
, "weak-key-hash-table?", 1, 0, 0,
445 "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n"
446 "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n"
447 "Return @code{#t} if @var{obj} is the specified weak hash\n"
448 "table. Note that a doubly weak hash table is neither a weak key\n"
449 "nor a weak value hash table.")
450 #define FUNC_NAME s_scm_weak_key_hash_table_p
452 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_KEY_P (obj
));
457 SCM_DEFINE (scm_weak_value_hash_table_p
, "weak-value-hash-table?", 1, 0, 0,
459 "Return @code{#t} if @var{obj} is a weak value hash table.")
460 #define FUNC_NAME s_scm_weak_value_hash_table_p
462 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_VALUE_P (obj
));
467 SCM_DEFINE (scm_doubly_weak_hash_table_p
, "doubly-weak-hash-table?", 1, 0, 0,
469 "Return @code{#t} if @var{obj} is a doubly weak hash table.")
470 #define FUNC_NAME s_scm_doubly_weak_hash_table_p
472 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_DOUBLY_WEAK_P (obj
));
477 /* Accessing hash table entries. */
480 scm_hash_fn_get_handle (SCM table
, SCM obj
,
481 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
483 #define FUNC_NAME "scm_hash_fn_get_handle"
488 if (SCM_HASHTABLE_P (table
))
489 buckets
= SCM_HASHTABLE_VECTOR (table
);
492 SCM_VALIDATE_VECTOR (1, table
);
496 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
498 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
499 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
500 scm_out_of_range ("hash_fn_get_handle", scm_from_ulong (k
));
502 if (IS_WEAK_THING (table
))
503 h
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
504 assoc_fn
, obj
, closure
);
506 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
514 scm_hash_fn_create_handle_x (SCM table
, SCM obj
, SCM init
,
515 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
517 #define FUNC_NAME "scm_hash_fn_create_handle_x"
522 if (SCM_HASHTABLE_P (table
))
523 buckets
= SCM_HASHTABLE_VECTOR (table
);
526 SCM_ASSERT (scm_is_simple_vector (table
),
527 table
, SCM_ARG1
, "hash_fn_create_handle_x");
530 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
531 SCM_MISC_ERROR ("void hashtable", SCM_EOL
);
533 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
534 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
535 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
537 if (IS_WEAK_THING (table
))
538 it
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
539 assoc_fn
, obj
, closure
);
541 it
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
543 if (scm_is_pair (it
))
545 else if (scm_is_true (it
))
546 scm_wrong_type_arg_msg (NULL
, 0, it
, "a pair");
549 /* When this is a weak hashtable, running the GC can change it.
550 Thus, we must allocate the new cells first and can only then
551 access BUCKETS. Also, we need to fetch the bucket vector
552 again since the hashtable might have been rehashed. This
553 necessitates a new hash value as well.
555 SCM handle
, new_bucket
;
557 if ((SCM_HASHTABLE_P (table
)) && (SCM_HASHTABLE_WEAK_P (table
)))
559 /* FIXME: We don't support weak alist vectors. */
560 /* Use a weak cell. */
561 if (SCM_HASHTABLE_DOUBLY_WEAK_P (table
))
562 handle
= scm_doubly_weak_pair (obj
, init
);
563 else if (SCM_HASHTABLE_WEAK_KEY_P (table
))
564 handle
= scm_weak_car_pair (obj
, init
);
566 handle
= scm_weak_cdr_pair (obj
, init
);
569 /* Use a regular, non-weak cell. */
570 handle
= scm_cons (obj
, init
);
572 new_bucket
= scm_cons (handle
, SCM_EOL
);
574 if (!scm_is_eq (table
, buckets
)
575 && !scm_is_eq (SCM_HASHTABLE_VECTOR (table
), buckets
))
577 buckets
= SCM_HASHTABLE_VECTOR (table
);
578 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
579 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
580 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
582 SCM_SETCDR (new_bucket
, SCM_SIMPLE_VECTOR_REF (buckets
, k
));
583 SCM_SIMPLE_VECTOR_SET (buckets
, k
, new_bucket
);
584 if (!scm_is_eq (table
, buckets
))
586 /* Update element count and maybe rehash the table. The
587 table might have too few entries here since weak hash
588 tables used with the hashx_* functions can not be
591 SCM_HASHTABLE_INCREMENT (table
);
592 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
)
593 || SCM_HASHTABLE_N_ITEMS (table
) > SCM_HASHTABLE_UPPER (table
))
594 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
596 return SCM_CAR (new_bucket
);
603 scm_hash_fn_ref (SCM table
, SCM obj
, SCM dflt
,
604 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
607 SCM it
= scm_hash_fn_get_handle (table
, obj
, hash_fn
, assoc_fn
, closure
);
608 if (scm_is_pair (it
))
618 scm_hash_fn_set_x (SCM table
, SCM obj
, SCM val
,
619 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
624 it
= scm_hash_fn_create_handle_x (table
, obj
, SCM_BOOL_F
, hash_fn
, assoc_fn
, closure
);
625 SCM_SETCDR (it
, val
);
631 scm_hash_fn_remove_x (SCM table
, SCM obj
,
632 scm_t_hash_fn hash_fn
,
633 scm_t_assoc_fn assoc_fn
,
639 if (SCM_HASHTABLE_P (table
))
640 buckets
= SCM_HASHTABLE_VECTOR (table
);
643 SCM_ASSERT (scm_is_simple_vector (table
), table
,
644 SCM_ARG1
, "hash_fn_remove_x");
647 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
650 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
651 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
652 scm_out_of_range ("hash_fn_remove_x", scm_from_ulong (k
));
654 if (IS_WEAK_THING (table
))
655 h
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
656 assoc_fn
, obj
, closure
);
658 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
662 SCM_SIMPLE_VECTOR_SET
663 (buckets
, k
, scm_delq_x (h
, SCM_SIMPLE_VECTOR_REF (buckets
, k
)));
664 if (!scm_is_eq (table
, buckets
))
666 SCM_HASHTABLE_DECREMENT (table
);
667 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
668 scm_i_rehash (table
, hash_fn
, closure
, "scm_hash_fn_remove_x");
674 SCM_DEFINE (scm_hash_clear_x
, "hash-clear!", 1, 0, 0,
676 "Remove all items from @var{table} (without triggering a resize).")
677 #define FUNC_NAME s_scm_hash_clear_x
679 if (SCM_HASHTABLE_P (table
))
681 scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table
), SCM_EOL
);
682 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
685 scm_vector_fill_x (table
, SCM_EOL
);
686 return SCM_UNSPECIFIED
;
692 SCM_DEFINE (scm_hashq_get_handle
, "hashq-get-handle", 2, 0, 0,
693 (SCM table
, SCM key
),
694 "This procedure returns the @code{(key . value)} pair from the\n"
695 "hash table @var{table}. If @var{table} does not hold an\n"
696 "associated value for @var{key}, @code{#f} is returned.\n"
697 "Uses @code{eq?} for equality testing.")
698 #define FUNC_NAME s_scm_hashq_get_handle
700 return scm_hash_fn_get_handle (table
, key
,
701 (scm_t_hash_fn
) scm_ihashq
,
702 (scm_t_assoc_fn
) scm_sloppy_assq
,
708 SCM_DEFINE (scm_hashq_create_handle_x
, "hashq-create-handle!", 3, 0, 0,
709 (SCM table
, SCM key
, SCM init
),
710 "This function looks up @var{key} in @var{table} and returns its handle.\n"
711 "If @var{key} is not already present, a new handle is created which\n"
712 "associates @var{key} with @var{init}.")
713 #define FUNC_NAME s_scm_hashq_create_handle_x
715 return scm_hash_fn_create_handle_x (table
, key
, init
,
716 (scm_t_hash_fn
) scm_ihashq
,
717 (scm_t_assoc_fn
) scm_sloppy_assq
,
723 SCM_DEFINE (scm_hashq_ref
, "hashq-ref", 2, 1, 0,
724 (SCM table
, SCM key
, SCM dflt
),
725 "Look up @var{key} in the hash table @var{table}, and return the\n"
726 "value (if any) associated with it. If @var{key} is not found,\n"
727 "return @var{default} (or @code{#f} if no @var{default} argument\n"
728 "is supplied). Uses @code{eq?} for equality testing.")
729 #define FUNC_NAME s_scm_hashq_ref
731 if (SCM_UNBNDP (dflt
))
733 return scm_hash_fn_ref (table
, key
, dflt
,
734 (scm_t_hash_fn
) scm_ihashq
,
735 (scm_t_assoc_fn
) scm_sloppy_assq
,
742 SCM_DEFINE (scm_hashq_set_x
, "hashq-set!", 3, 0, 0,
743 (SCM table
, SCM key
, SCM val
),
744 "Find the entry in @var{table} associated with @var{key}, and\n"
745 "store @var{value} there. Uses @code{eq?} for equality testing.")
746 #define FUNC_NAME s_scm_hashq_set_x
748 return scm_hash_fn_set_x (table
, key
, val
,
749 (scm_t_hash_fn
) scm_ihashq
,
750 (scm_t_assoc_fn
) scm_sloppy_assq
,
757 SCM_DEFINE (scm_hashq_remove_x
, "hashq-remove!", 2, 0, 0,
758 (SCM table
, SCM key
),
759 "Remove @var{key} (and any value associated with it) from\n"
760 "@var{table}. Uses @code{eq?} for equality tests.")
761 #define FUNC_NAME s_scm_hashq_remove_x
763 return scm_hash_fn_remove_x (table
, key
,
764 (scm_t_hash_fn
) scm_ihashq
,
765 (scm_t_assoc_fn
) scm_sloppy_assq
,
773 SCM_DEFINE (scm_hashv_get_handle
, "hashv-get-handle", 2, 0, 0,
774 (SCM table
, SCM key
),
775 "This procedure returns the @code{(key . value)} pair from the\n"
776 "hash table @var{table}. If @var{table} does not hold an\n"
777 "associated value for @var{key}, @code{#f} is returned.\n"
778 "Uses @code{eqv?} for equality testing.")
779 #define FUNC_NAME s_scm_hashv_get_handle
781 return scm_hash_fn_get_handle (table
, key
,
782 (scm_t_hash_fn
) scm_ihashv
,
783 (scm_t_assoc_fn
) scm_sloppy_assv
,
789 SCM_DEFINE (scm_hashv_create_handle_x
, "hashv-create-handle!", 3, 0, 0,
790 (SCM table
, SCM key
, SCM init
),
791 "This function looks up @var{key} in @var{table} and returns its handle.\n"
792 "If @var{key} is not already present, a new handle is created which\n"
793 "associates @var{key} with @var{init}.")
794 #define FUNC_NAME s_scm_hashv_create_handle_x
796 return scm_hash_fn_create_handle_x (table
, key
, init
,
797 (scm_t_hash_fn
) scm_ihashv
,
798 (scm_t_assoc_fn
) scm_sloppy_assv
,
804 SCM_DEFINE (scm_hashv_ref
, "hashv-ref", 2, 1, 0,
805 (SCM table
, SCM key
, SCM dflt
),
806 "Look up @var{key} in the hash table @var{table}, and return the\n"
807 "value (if any) associated with it. If @var{key} is not found,\n"
808 "return @var{default} (or @code{#f} if no @var{default} argument\n"
809 "is supplied). Uses @code{eqv?} for equality testing.")
810 #define FUNC_NAME s_scm_hashv_ref
812 if (SCM_UNBNDP (dflt
))
814 return scm_hash_fn_ref (table
, key
, dflt
,
815 (scm_t_hash_fn
) scm_ihashv
,
816 (scm_t_assoc_fn
) scm_sloppy_assv
,
823 SCM_DEFINE (scm_hashv_set_x
, "hashv-set!", 3, 0, 0,
824 (SCM table
, SCM key
, SCM val
),
825 "Find the entry in @var{table} associated with @var{key}, and\n"
826 "store @var{value} there. Uses @code{eqv?} for equality testing.")
827 #define FUNC_NAME s_scm_hashv_set_x
829 return scm_hash_fn_set_x (table
, key
, val
,
830 (scm_t_hash_fn
) scm_ihashv
,
831 (scm_t_assoc_fn
) scm_sloppy_assv
,
837 SCM_DEFINE (scm_hashv_remove_x
, "hashv-remove!", 2, 0, 0,
838 (SCM table
, SCM key
),
839 "Remove @var{key} (and any value associated with it) from\n"
840 "@var{table}. Uses @code{eqv?} for equality tests.")
841 #define FUNC_NAME s_scm_hashv_remove_x
843 return scm_hash_fn_remove_x (table
, key
,
844 (scm_t_hash_fn
) scm_ihashv
,
845 (scm_t_assoc_fn
) scm_sloppy_assv
,
852 SCM_DEFINE (scm_hash_get_handle
, "hash-get-handle", 2, 0, 0,
853 (SCM table
, SCM key
),
854 "This procedure returns the @code{(key . value)} pair from the\n"
855 "hash table @var{table}. If @var{table} does not hold an\n"
856 "associated value for @var{key}, @code{#f} is returned.\n"
857 "Uses @code{equal?} for equality testing.")
858 #define FUNC_NAME s_scm_hash_get_handle
860 return scm_hash_fn_get_handle (table
, key
,
861 (scm_t_hash_fn
) scm_ihash
,
862 (scm_t_assoc_fn
) scm_sloppy_assoc
,
868 SCM_DEFINE (scm_hash_create_handle_x
, "hash-create-handle!", 3, 0, 0,
869 (SCM table
, SCM key
, SCM init
),
870 "This function looks up @var{key} in @var{table} and returns its handle.\n"
871 "If @var{key} is not already present, a new handle is created which\n"
872 "associates @var{key} with @var{init}.")
873 #define FUNC_NAME s_scm_hash_create_handle_x
875 return scm_hash_fn_create_handle_x (table
, key
, init
,
876 (scm_t_hash_fn
) scm_ihash
,
877 (scm_t_assoc_fn
) scm_sloppy_assoc
,
883 SCM_DEFINE (scm_hash_ref
, "hash-ref", 2, 1, 0,
884 (SCM table
, SCM key
, SCM dflt
),
885 "Look up @var{key} in the hash table @var{table}, and return the\n"
886 "value (if any) associated with it. If @var{key} is not found,\n"
887 "return @var{default} (or @code{#f} if no @var{default} argument\n"
888 "is supplied). Uses @code{equal?} for equality testing.")
889 #define FUNC_NAME s_scm_hash_ref
891 if (SCM_UNBNDP (dflt
))
893 return scm_hash_fn_ref (table
, key
, dflt
,
894 (scm_t_hash_fn
) scm_ihash
,
895 (scm_t_assoc_fn
) scm_sloppy_assoc
,
902 SCM_DEFINE (scm_hash_set_x
, "hash-set!", 3, 0, 0,
903 (SCM table
, SCM key
, SCM val
),
904 "Find the entry in @var{table} associated with @var{key}, and\n"
905 "store @var{value} there. Uses @code{equal?} for equality\n"
907 #define FUNC_NAME s_scm_hash_set_x
909 return scm_hash_fn_set_x (table
, key
, val
,
910 (scm_t_hash_fn
) scm_ihash
,
911 (scm_t_assoc_fn
) scm_sloppy_assoc
,
918 SCM_DEFINE (scm_hash_remove_x
, "hash-remove!", 2, 0, 0,
919 (SCM table
, SCM key
),
920 "Remove @var{key} (and any value associated with it) from\n"
921 "@var{table}. Uses @code{equal?} for equality tests.")
922 #define FUNC_NAME s_scm_hash_remove_x
924 return scm_hash_fn_remove_x (table
, key
,
925 (scm_t_hash_fn
) scm_ihash
,
926 (scm_t_assoc_fn
) scm_sloppy_assoc
,
934 typedef struct scm_t_ihashx_closure
938 } scm_t_ihashx_closure
;
943 scm_ihashx (SCM obj
, unsigned long n
, void *arg
)
946 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
947 answer
= scm_call_2 (closure
->hash
, obj
, scm_from_ulong (n
));
948 return scm_to_ulong (answer
);
954 scm_sloppy_assx (SCM obj
, SCM alist
, void *arg
)
956 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
957 return scm_call_2 (closure
->assoc
, obj
, alist
);
961 SCM_DEFINE (scm_hashx_get_handle
, "hashx-get-handle", 4, 0, 0,
962 (SCM hash
, SCM assoc
, SCM table
, SCM key
),
963 "This behaves the same way as the corresponding\n"
964 "@code{-get-handle} function, but uses @var{hash} as a hash\n"
965 "function and @var{assoc} to compare keys. @code{hash} must be\n"
966 "a function that takes two arguments, a key to be hashed and a\n"
967 "table size. @code{assoc} must be an associator function, like\n"
968 "@code{assoc}, @code{assq} or @code{assv}.")
969 #define FUNC_NAME s_scm_hashx_get_handle
971 scm_t_ihashx_closure closure
;
973 closure
.assoc
= assoc
;
974 return scm_hash_fn_get_handle (table
, key
, scm_ihashx
, scm_sloppy_assx
,
980 SCM_DEFINE (scm_hashx_create_handle_x
, "hashx-create-handle!", 5, 0, 0,
981 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM init
),
982 "This behaves the same way as the corresponding\n"
983 "@code{-create-handle} function, but uses @var{hash} as a hash\n"
984 "function and @var{assoc} to compare keys. @code{hash} must be\n"
985 "a function that takes two arguments, a key to be hashed and a\n"
986 "table size. @code{assoc} must be an associator function, like\n"
987 "@code{assoc}, @code{assq} or @code{assv}.")
988 #define FUNC_NAME s_scm_hashx_create_handle_x
990 scm_t_ihashx_closure closure
;
992 closure
.assoc
= assoc
;
993 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashx
,
994 scm_sloppy_assx
, (void *)&closure
);
1000 SCM_DEFINE (scm_hashx_ref
, "hashx-ref", 4, 1, 0,
1001 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM dflt
),
1002 "This behaves the same way as the corresponding @code{ref}\n"
1003 "function, but uses @var{hash} as a hash function and\n"
1004 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1005 "that takes two arguments, a key to be hashed and a table size.\n"
1006 "@code{assoc} must be an associator function, like @code{assoc},\n"
1007 "@code{assq} or @code{assv}.\n"
1009 "By way of illustration, @code{hashq-ref table key} is\n"
1010 "equivalent to @code{hashx-ref hashq assq table key}.")
1011 #define FUNC_NAME s_scm_hashx_ref
1013 scm_t_ihashx_closure closure
;
1014 if (SCM_UNBNDP (dflt
))
1016 closure
.hash
= hash
;
1017 closure
.assoc
= assoc
;
1018 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashx
, scm_sloppy_assx
,
1026 SCM_DEFINE (scm_hashx_set_x
, "hashx-set!", 5, 0, 0,
1027 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM val
),
1028 "This behaves the same way as the corresponding @code{set!}\n"
1029 "function, but uses @var{hash} as a hash function and\n"
1030 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1031 "that takes two arguments, a key to be hashed and a table size.\n"
1032 "@code{assoc} must be an associator function, like @code{assoc},\n"
1033 "@code{assq} or @code{assv}.\n"
1035 " By way of illustration, @code{hashq-set! table key} is\n"
1036 "equivalent to @code{hashx-set! hashq assq table key}.")
1037 #define FUNC_NAME s_scm_hashx_set_x
1039 scm_t_ihashx_closure closure
;
1040 closure
.hash
= hash
;
1041 closure
.assoc
= assoc
;
1042 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashx
, scm_sloppy_assx
,
1047 SCM_DEFINE (scm_hashx_remove_x
, "hashx-remove!", 4, 0, 0,
1048 (SCM hash
, SCM assoc
, SCM table
, SCM obj
),
1049 "This behaves the same way as the corresponding @code{remove!}\n"
1050 "function, but uses @var{hash} as a hash function and\n"
1051 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1052 "that takes two arguments, a key to be hashed and a table size.\n"
1053 "@code{assoc} must be an associator function, like @code{assoc},\n"
1054 "@code{assq} or @code{assv}.\n"
1056 " By way of illustration, @code{hashq-remove! table key} is\n"
1057 "equivalent to @code{hashx-remove! hashq assq #f table key}.")
1058 #define FUNC_NAME s_scm_hashx_remove_x
1060 scm_t_ihashx_closure closure
;
1061 closure
.hash
= hash
;
1062 closure
.assoc
= assoc
;
1063 return scm_hash_fn_remove_x (table
, obj
, scm_ihashx
, scm_sloppy_assx
,
1068 /* Hash table iterators */
1070 static const char s_scm_hash_fold
[];
1073 scm_internal_hash_fold (scm_t_hash_fold_fn fn
, void *closure
,
1074 SCM init
, SCM table
)
1077 SCM buckets
, result
= init
;
1079 if (SCM_HASHTABLE_P (table
))
1080 buckets
= SCM_HASHTABLE_VECTOR (table
);
1082 /* Weak alist vector. */
1085 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1086 for (i
= 0; i
< n
; ++i
)
1090 for (prev
= SCM_BOOL_F
, ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
);
1092 prev
= ls
, ls
= SCM_CDR (ls
))
1096 if (!scm_is_pair (ls
))
1097 scm_wrong_type_arg (s_scm_hash_fold
, SCM_ARG3
, buckets
);
1099 handle
= SCM_CAR (ls
);
1100 if (!scm_is_pair (handle
))
1101 scm_wrong_type_arg (s_scm_hash_fold
, SCM_ARG3
, buckets
);
1103 if (IS_WEAK_THING (table
))
1105 if (SCM_WEAK_PAIR_DELETED_P (handle
))
1107 /* We hit a weak pair whose car/cdr has become
1108 unreachable: unlink it from the bucket. */
1109 if (prev
!= SCM_BOOL_F
)
1110 SCM_SETCDR (prev
, SCM_CDR (ls
));
1112 SCM_SIMPLE_VECTOR_SET (buckets
, i
, SCM_CDR (ls
));
1114 if (SCM_HASHTABLE_P (table
))
1115 /* Update the item count. */
1116 SCM_HASHTABLE_DECREMENT (table
);
1122 result
= fn (closure
, SCM_CAR (handle
), SCM_CDR (handle
), result
);
1129 /* The following redundant code is here in order to be able to support
1130 hash-for-each-handle. An alternative would have been to replace
1131 this code and scm_internal_hash_fold above with a single
1132 scm_internal_hash_fold_handles, but we don't want to promote such
1135 static const char s_scm_hash_for_each
[];
1138 scm_internal_hash_for_each_handle (scm_t_hash_handle_fn fn
, void *closure
,
1144 if (SCM_HASHTABLE_P (table
))
1145 buckets
= SCM_HASHTABLE_VECTOR (table
);
1149 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1150 for (i
= 0; i
< n
; ++i
)
1152 SCM ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
), handle
;
1153 while (!scm_is_null (ls
))
1155 if (!scm_is_pair (ls
))
1156 scm_wrong_type_arg (s_scm_hash_for_each
, SCM_ARG3
, buckets
);
1157 handle
= SCM_CAR (ls
);
1158 if (!scm_is_pair (handle
))
1159 scm_wrong_type_arg (s_scm_hash_for_each
, SCM_ARG3
, buckets
);
1160 fn (closure
, handle
);
1166 SCM_DEFINE (scm_hash_fold
, "hash-fold", 3, 0, 0,
1167 (SCM proc
, SCM init
, SCM table
),
1168 "An iterator over hash-table elements.\n"
1169 "Accumulates and returns a result by applying PROC successively.\n"
1170 "The arguments to PROC are \"(key value prior-result)\" where key\n"
1171 "and value are successive pairs from the hash table TABLE, and\n"
1172 "prior-result is either INIT (for the first application of PROC)\n"
1173 "or the return value of the previous application of PROC.\n"
1174 "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
1175 "table into an a-list of key-value pairs.")
1176 #define FUNC_NAME s_scm_hash_fold
1178 SCM_VALIDATE_PROC (1, proc
);
1179 if (!SCM_HASHTABLE_P (table
))
1180 SCM_VALIDATE_VECTOR (3, table
);
1181 return scm_internal_hash_fold ((scm_t_hash_fold_fn
) scm_call_3
,
1182 (void *) SCM_UNPACK (proc
), init
, table
);
1187 for_each_proc (void *proc
, SCM handle
)
1189 return scm_call_2 (SCM_PACK (proc
), SCM_CAR (handle
), SCM_CDR (handle
));
1192 SCM_DEFINE (scm_hash_for_each
, "hash-for-each", 2, 0, 0,
1193 (SCM proc
, SCM table
),
1194 "An iterator over hash-table elements.\n"
1195 "Applies PROC successively on all hash table items.\n"
1196 "The arguments to PROC are \"(key value)\" where key\n"
1197 "and value are successive pairs from the hash table TABLE.")
1198 #define FUNC_NAME s_scm_hash_for_each
1200 SCM_VALIDATE_PROC (1, proc
);
1201 if (!SCM_HASHTABLE_P (table
))
1202 SCM_VALIDATE_VECTOR (2, table
);
1204 scm_internal_hash_for_each_handle (for_each_proc
,
1205 (void *) SCM_UNPACK (proc
),
1207 return SCM_UNSPECIFIED
;
1211 SCM_DEFINE (scm_hash_for_each_handle
, "hash-for-each-handle", 2, 0, 0,
1212 (SCM proc
, SCM table
),
1213 "An iterator over hash-table elements.\n"
1214 "Applies PROC successively on all hash table handles.")
1215 #define FUNC_NAME s_scm_hash_for_each_handle
1217 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)), proc
, 1, FUNC_NAME
);
1218 if (!SCM_HASHTABLE_P (table
))
1219 SCM_VALIDATE_VECTOR (2, table
);
1221 scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn
) scm_call_1
,
1222 (void *) SCM_UNPACK (proc
),
1224 return SCM_UNSPECIFIED
;
1229 map_proc (void *proc
, SCM key
, SCM data
, SCM value
)
1231 return scm_cons (scm_call_2 (SCM_PACK (proc
), key
, data
), value
);
1234 SCM_DEFINE (scm_hash_map_to_list
, "hash-map->list", 2, 0, 0,
1235 (SCM proc
, SCM table
),
1236 "An iterator over hash-table elements.\n"
1237 "Accumulates and returns as a list the results of applying PROC successively.\n"
1238 "The arguments to PROC are \"(key value)\" where key\n"
1239 "and value are successive pairs from the hash table TABLE.")
1240 #define FUNC_NAME s_scm_hash_map_to_list
1242 SCM_VALIDATE_PROC (1, proc
);
1243 if (!SCM_HASHTABLE_P (table
))
1244 SCM_VALIDATE_VECTOR (2, table
);
1245 return scm_internal_hash_fold (map_proc
,
1246 (void *) SCM_UNPACK (proc
),
1258 #include "libguile/hashtab.x"