1 /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010 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
);
627 if (SCM_HASHTABLE_P (table
) && SCM_HASHTABLE_WEAK_VALUE_P (table
)
629 /* IT is a weak-cdr pair. Register a disappearing link from IT's
630 cdr to VAL like `scm_weak_cdr_pair' does. */
631 SCM_I_REGISTER_DISAPPEARING_LINK ((void *) SCM_CDRLOC (it
), SCM2PTR (val
));
638 scm_hash_fn_remove_x (SCM table
, SCM obj
,
639 scm_t_hash_fn hash_fn
,
640 scm_t_assoc_fn assoc_fn
,
646 if (SCM_HASHTABLE_P (table
))
647 buckets
= SCM_HASHTABLE_VECTOR (table
);
650 SCM_ASSERT (scm_is_simple_vector (table
), table
,
651 SCM_ARG1
, "hash_fn_remove_x");
654 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
657 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
658 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
659 scm_out_of_range ("hash_fn_remove_x", scm_from_ulong (k
));
661 if (IS_WEAK_THING (table
))
662 h
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
663 assoc_fn
, obj
, closure
);
665 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
669 SCM_SIMPLE_VECTOR_SET
670 (buckets
, k
, scm_delq_x (h
, SCM_SIMPLE_VECTOR_REF (buckets
, k
)));
671 if (!scm_is_eq (table
, buckets
))
673 SCM_HASHTABLE_DECREMENT (table
);
674 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
675 scm_i_rehash (table
, hash_fn
, closure
, "scm_hash_fn_remove_x");
681 SCM_DEFINE (scm_hash_clear_x
, "hash-clear!", 1, 0, 0,
683 "Remove all items from @var{table} (without triggering a resize).")
684 #define FUNC_NAME s_scm_hash_clear_x
686 if (SCM_HASHTABLE_P (table
))
688 scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table
), SCM_EOL
);
689 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
692 scm_vector_fill_x (table
, SCM_EOL
);
693 return SCM_UNSPECIFIED
;
699 SCM_DEFINE (scm_hashq_get_handle
, "hashq-get-handle", 2, 0, 0,
700 (SCM table
, SCM key
),
701 "This procedure returns the @code{(key . value)} pair from the\n"
702 "hash table @var{table}. If @var{table} does not hold an\n"
703 "associated value for @var{key}, @code{#f} is returned.\n"
704 "Uses @code{eq?} for equality testing.")
705 #define FUNC_NAME s_scm_hashq_get_handle
707 return scm_hash_fn_get_handle (table
, key
,
708 (scm_t_hash_fn
) scm_ihashq
,
709 (scm_t_assoc_fn
) scm_sloppy_assq
,
715 SCM_DEFINE (scm_hashq_create_handle_x
, "hashq-create-handle!", 3, 0, 0,
716 (SCM table
, SCM key
, SCM init
),
717 "This function looks up @var{key} in @var{table} and returns its handle.\n"
718 "If @var{key} is not already present, a new handle is created which\n"
719 "associates @var{key} with @var{init}.")
720 #define FUNC_NAME s_scm_hashq_create_handle_x
722 return scm_hash_fn_create_handle_x (table
, key
, init
,
723 (scm_t_hash_fn
) scm_ihashq
,
724 (scm_t_assoc_fn
) scm_sloppy_assq
,
730 SCM_DEFINE (scm_hashq_ref
, "hashq-ref", 2, 1, 0,
731 (SCM table
, SCM key
, SCM dflt
),
732 "Look up @var{key} in the hash table @var{table}, and return the\n"
733 "value (if any) associated with it. If @var{key} is not found,\n"
734 "return @var{default} (or @code{#f} if no @var{default} argument\n"
735 "is supplied). Uses @code{eq?} for equality testing.")
736 #define FUNC_NAME s_scm_hashq_ref
738 if (SCM_UNBNDP (dflt
))
740 return scm_hash_fn_ref (table
, key
, dflt
,
741 (scm_t_hash_fn
) scm_ihashq
,
742 (scm_t_assoc_fn
) scm_sloppy_assq
,
749 SCM_DEFINE (scm_hashq_set_x
, "hashq-set!", 3, 0, 0,
750 (SCM table
, SCM key
, SCM val
),
751 "Find the entry in @var{table} associated with @var{key}, and\n"
752 "store @var{value} there. Uses @code{eq?} for equality testing.")
753 #define FUNC_NAME s_scm_hashq_set_x
755 return scm_hash_fn_set_x (table
, key
, val
,
756 (scm_t_hash_fn
) scm_ihashq
,
757 (scm_t_assoc_fn
) scm_sloppy_assq
,
764 SCM_DEFINE (scm_hashq_remove_x
, "hashq-remove!", 2, 0, 0,
765 (SCM table
, SCM key
),
766 "Remove @var{key} (and any value associated with it) from\n"
767 "@var{table}. Uses @code{eq?} for equality tests.")
768 #define FUNC_NAME s_scm_hashq_remove_x
770 return scm_hash_fn_remove_x (table
, key
,
771 (scm_t_hash_fn
) scm_ihashq
,
772 (scm_t_assoc_fn
) scm_sloppy_assq
,
780 SCM_DEFINE (scm_hashv_get_handle
, "hashv-get-handle", 2, 0, 0,
781 (SCM table
, SCM key
),
782 "This procedure returns the @code{(key . value)} pair from the\n"
783 "hash table @var{table}. If @var{table} does not hold an\n"
784 "associated value for @var{key}, @code{#f} is returned.\n"
785 "Uses @code{eqv?} for equality testing.")
786 #define FUNC_NAME s_scm_hashv_get_handle
788 return scm_hash_fn_get_handle (table
, key
,
789 (scm_t_hash_fn
) scm_ihashv
,
790 (scm_t_assoc_fn
) scm_sloppy_assv
,
796 SCM_DEFINE (scm_hashv_create_handle_x
, "hashv-create-handle!", 3, 0, 0,
797 (SCM table
, SCM key
, SCM init
),
798 "This function looks up @var{key} in @var{table} and returns its handle.\n"
799 "If @var{key} is not already present, a new handle is created which\n"
800 "associates @var{key} with @var{init}.")
801 #define FUNC_NAME s_scm_hashv_create_handle_x
803 return scm_hash_fn_create_handle_x (table
, key
, init
,
804 (scm_t_hash_fn
) scm_ihashv
,
805 (scm_t_assoc_fn
) scm_sloppy_assv
,
811 SCM_DEFINE (scm_hashv_ref
, "hashv-ref", 2, 1, 0,
812 (SCM table
, SCM key
, SCM dflt
),
813 "Look up @var{key} in the hash table @var{table}, and return the\n"
814 "value (if any) associated with it. If @var{key} is not found,\n"
815 "return @var{default} (or @code{#f} if no @var{default} argument\n"
816 "is supplied). Uses @code{eqv?} for equality testing.")
817 #define FUNC_NAME s_scm_hashv_ref
819 if (SCM_UNBNDP (dflt
))
821 return scm_hash_fn_ref (table
, key
, dflt
,
822 (scm_t_hash_fn
) scm_ihashv
,
823 (scm_t_assoc_fn
) scm_sloppy_assv
,
830 SCM_DEFINE (scm_hashv_set_x
, "hashv-set!", 3, 0, 0,
831 (SCM table
, SCM key
, SCM val
),
832 "Find the entry in @var{table} associated with @var{key}, and\n"
833 "store @var{value} there. Uses @code{eqv?} for equality testing.")
834 #define FUNC_NAME s_scm_hashv_set_x
836 return scm_hash_fn_set_x (table
, key
, val
,
837 (scm_t_hash_fn
) scm_ihashv
,
838 (scm_t_assoc_fn
) scm_sloppy_assv
,
844 SCM_DEFINE (scm_hashv_remove_x
, "hashv-remove!", 2, 0, 0,
845 (SCM table
, SCM key
),
846 "Remove @var{key} (and any value associated with it) from\n"
847 "@var{table}. Uses @code{eqv?} for equality tests.")
848 #define FUNC_NAME s_scm_hashv_remove_x
850 return scm_hash_fn_remove_x (table
, key
,
851 (scm_t_hash_fn
) scm_ihashv
,
852 (scm_t_assoc_fn
) scm_sloppy_assv
,
859 SCM_DEFINE (scm_hash_get_handle
, "hash-get-handle", 2, 0, 0,
860 (SCM table
, SCM key
),
861 "This procedure returns the @code{(key . value)} pair from the\n"
862 "hash table @var{table}. If @var{table} does not hold an\n"
863 "associated value for @var{key}, @code{#f} is returned.\n"
864 "Uses @code{equal?} for equality testing.")
865 #define FUNC_NAME s_scm_hash_get_handle
867 return scm_hash_fn_get_handle (table
, key
,
868 (scm_t_hash_fn
) scm_ihash
,
869 (scm_t_assoc_fn
) scm_sloppy_assoc
,
875 SCM_DEFINE (scm_hash_create_handle_x
, "hash-create-handle!", 3, 0, 0,
876 (SCM table
, SCM key
, SCM init
),
877 "This function looks up @var{key} in @var{table} and returns its handle.\n"
878 "If @var{key} is not already present, a new handle is created which\n"
879 "associates @var{key} with @var{init}.")
880 #define FUNC_NAME s_scm_hash_create_handle_x
882 return scm_hash_fn_create_handle_x (table
, key
, init
,
883 (scm_t_hash_fn
) scm_ihash
,
884 (scm_t_assoc_fn
) scm_sloppy_assoc
,
890 SCM_DEFINE (scm_hash_ref
, "hash-ref", 2, 1, 0,
891 (SCM table
, SCM key
, SCM dflt
),
892 "Look up @var{key} in the hash table @var{table}, and return the\n"
893 "value (if any) associated with it. If @var{key} is not found,\n"
894 "return @var{default} (or @code{#f} if no @var{default} argument\n"
895 "is supplied). Uses @code{equal?} for equality testing.")
896 #define FUNC_NAME s_scm_hash_ref
898 if (SCM_UNBNDP (dflt
))
900 return scm_hash_fn_ref (table
, key
, dflt
,
901 (scm_t_hash_fn
) scm_ihash
,
902 (scm_t_assoc_fn
) scm_sloppy_assoc
,
909 SCM_DEFINE (scm_hash_set_x
, "hash-set!", 3, 0, 0,
910 (SCM table
, SCM key
, SCM val
),
911 "Find the entry in @var{table} associated with @var{key}, and\n"
912 "store @var{value} there. Uses @code{equal?} for equality\n"
914 #define FUNC_NAME s_scm_hash_set_x
916 return scm_hash_fn_set_x (table
, key
, val
,
917 (scm_t_hash_fn
) scm_ihash
,
918 (scm_t_assoc_fn
) scm_sloppy_assoc
,
925 SCM_DEFINE (scm_hash_remove_x
, "hash-remove!", 2, 0, 0,
926 (SCM table
, SCM key
),
927 "Remove @var{key} (and any value associated with it) from\n"
928 "@var{table}. Uses @code{equal?} for equality tests.")
929 #define FUNC_NAME s_scm_hash_remove_x
931 return scm_hash_fn_remove_x (table
, key
,
932 (scm_t_hash_fn
) scm_ihash
,
933 (scm_t_assoc_fn
) scm_sloppy_assoc
,
941 typedef struct scm_t_ihashx_closure
945 } scm_t_ihashx_closure
;
950 scm_ihashx (SCM obj
, unsigned long n
, void *arg
)
953 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
954 answer
= scm_call_2 (closure
->hash
, obj
, scm_from_ulong (n
));
955 return scm_to_ulong (answer
);
961 scm_sloppy_assx (SCM obj
, SCM alist
, void *arg
)
963 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
964 return scm_call_2 (closure
->assoc
, obj
, alist
);
968 SCM_DEFINE (scm_hashx_get_handle
, "hashx-get-handle", 4, 0, 0,
969 (SCM hash
, SCM assoc
, SCM table
, SCM key
),
970 "This behaves the same way as the corresponding\n"
971 "@code{-get-handle} function, but uses @var{hash} as a hash\n"
972 "function and @var{assoc} to compare keys. @code{hash} must be\n"
973 "a function that takes two arguments, a key to be hashed and a\n"
974 "table size. @code{assoc} must be an associator function, like\n"
975 "@code{assoc}, @code{assq} or @code{assv}.")
976 #define FUNC_NAME s_scm_hashx_get_handle
978 scm_t_ihashx_closure closure
;
980 closure
.assoc
= assoc
;
981 return scm_hash_fn_get_handle (table
, key
, scm_ihashx
, scm_sloppy_assx
,
987 SCM_DEFINE (scm_hashx_create_handle_x
, "hashx-create-handle!", 5, 0, 0,
988 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM init
),
989 "This behaves the same way as the corresponding\n"
990 "@code{-create-handle} function, but uses @var{hash} as a hash\n"
991 "function and @var{assoc} to compare keys. @code{hash} must be\n"
992 "a function that takes two arguments, a key to be hashed and a\n"
993 "table size. @code{assoc} must be an associator function, like\n"
994 "@code{assoc}, @code{assq} or @code{assv}.")
995 #define FUNC_NAME s_scm_hashx_create_handle_x
997 scm_t_ihashx_closure closure
;
999 closure
.assoc
= assoc
;
1000 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashx
,
1001 scm_sloppy_assx
, (void *)&closure
);
1007 SCM_DEFINE (scm_hashx_ref
, "hashx-ref", 4, 1, 0,
1008 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM dflt
),
1009 "This behaves the same way as the corresponding @code{ref}\n"
1010 "function, but uses @var{hash} as a hash function and\n"
1011 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1012 "that takes two arguments, a key to be hashed and a table size.\n"
1013 "@code{assoc} must be an associator function, like @code{assoc},\n"
1014 "@code{assq} or @code{assv}.\n"
1016 "By way of illustration, @code{hashq-ref table key} is\n"
1017 "equivalent to @code{hashx-ref hashq assq table key}.")
1018 #define FUNC_NAME s_scm_hashx_ref
1020 scm_t_ihashx_closure closure
;
1021 if (SCM_UNBNDP (dflt
))
1023 closure
.hash
= hash
;
1024 closure
.assoc
= assoc
;
1025 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashx
, scm_sloppy_assx
,
1033 SCM_DEFINE (scm_hashx_set_x
, "hashx-set!", 5, 0, 0,
1034 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM val
),
1035 "This behaves the same way as the corresponding @code{set!}\n"
1036 "function, but uses @var{hash} as a hash function and\n"
1037 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1038 "that takes two arguments, a key to be hashed and a table size.\n"
1039 "@code{assoc} must be an associator function, like @code{assoc},\n"
1040 "@code{assq} or @code{assv}.\n"
1042 " By way of illustration, @code{hashq-set! table key} is\n"
1043 "equivalent to @code{hashx-set! hashq assq table key}.")
1044 #define FUNC_NAME s_scm_hashx_set_x
1046 scm_t_ihashx_closure closure
;
1047 closure
.hash
= hash
;
1048 closure
.assoc
= assoc
;
1049 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashx
, scm_sloppy_assx
,
1054 SCM_DEFINE (scm_hashx_remove_x
, "hashx-remove!", 4, 0, 0,
1055 (SCM hash
, SCM assoc
, SCM table
, SCM obj
),
1056 "This behaves the same way as the corresponding @code{remove!}\n"
1057 "function, but uses @var{hash} as a hash function and\n"
1058 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1059 "that takes two arguments, a key to be hashed and a table size.\n"
1060 "@code{assoc} must be an associator function, like @code{assoc},\n"
1061 "@code{assq} or @code{assv}.\n"
1063 " By way of illustration, @code{hashq-remove! table key} is\n"
1064 "equivalent to @code{hashx-remove! hashq assq #f table key}.")
1065 #define FUNC_NAME s_scm_hashx_remove_x
1067 scm_t_ihashx_closure closure
;
1068 closure
.hash
= hash
;
1069 closure
.assoc
= assoc
;
1070 return scm_hash_fn_remove_x (table
, obj
, scm_ihashx
, scm_sloppy_assx
,
1075 /* Hash table iterators */
1077 SCM_DEFINE (scm_hash_fold
, "hash-fold", 3, 0, 0,
1078 (SCM proc
, SCM init
, SCM table
),
1079 "An iterator over hash-table elements.\n"
1080 "Accumulates and returns a result by applying PROC successively.\n"
1081 "The arguments to PROC are \"(key value prior-result)\" where key\n"
1082 "and value are successive pairs from the hash table TABLE, and\n"
1083 "prior-result is either INIT (for the first application of PROC)\n"
1084 "or the return value of the previous application of PROC.\n"
1085 "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
1086 "table into an a-list of key-value pairs.")
1087 #define FUNC_NAME s_scm_hash_fold
1089 SCM_VALIDATE_PROC (1, proc
);
1090 if (!SCM_HASHTABLE_P (table
))
1091 SCM_VALIDATE_VECTOR (3, table
);
1092 return scm_internal_hash_fold ((scm_t_hash_fold_fn
) scm_call_3
,
1093 (void *) SCM_UNPACK (proc
), init
, table
);
1098 for_each_proc (void *proc
, SCM handle
)
1100 return scm_call_2 (SCM_PACK (proc
), SCM_CAR (handle
), SCM_CDR (handle
));
1103 SCM_DEFINE (scm_hash_for_each
, "hash-for-each", 2, 0, 0,
1104 (SCM proc
, SCM table
),
1105 "An iterator over hash-table elements.\n"
1106 "Applies PROC successively on all hash table items.\n"
1107 "The arguments to PROC are \"(key value)\" where key\n"
1108 "and value are successive pairs from the hash table TABLE.")
1109 #define FUNC_NAME s_scm_hash_for_each
1111 SCM_VALIDATE_PROC (1, proc
);
1112 if (!SCM_HASHTABLE_P (table
))
1113 SCM_VALIDATE_VECTOR (2, table
);
1115 scm_internal_hash_for_each_handle (for_each_proc
,
1116 (void *) SCM_UNPACK (proc
),
1118 return SCM_UNSPECIFIED
;
1122 SCM_DEFINE (scm_hash_for_each_handle
, "hash-for-each-handle", 2, 0, 0,
1123 (SCM proc
, SCM table
),
1124 "An iterator over hash-table elements.\n"
1125 "Applies PROC successively on all hash table handles.")
1126 #define FUNC_NAME s_scm_hash_for_each_handle
1128 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)), proc
, 1, FUNC_NAME
);
1129 if (!SCM_HASHTABLE_P (table
))
1130 SCM_VALIDATE_VECTOR (2, table
);
1132 scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn
) scm_call_1
,
1133 (void *) SCM_UNPACK (proc
),
1135 return SCM_UNSPECIFIED
;
1140 map_proc (void *proc
, SCM key
, SCM data
, SCM value
)
1142 return scm_cons (scm_call_2 (SCM_PACK (proc
), key
, data
), value
);
1145 SCM_DEFINE (scm_hash_map_to_list
, "hash-map->list", 2, 0, 0,
1146 (SCM proc
, SCM table
),
1147 "An iterator over hash-table elements.\n"
1148 "Accumulates and returns as a list the results of applying PROC successively.\n"
1149 "The arguments to PROC are \"(key value)\" where key\n"
1150 "and value are successive pairs from the hash table TABLE.")
1151 #define FUNC_NAME s_scm_hash_map_to_list
1153 SCM_VALIDATE_PROC (1, proc
);
1154 if (!SCM_HASHTABLE_P (table
))
1155 SCM_VALIDATE_VECTOR (2, table
);
1156 return scm_internal_hash_fold (map_proc
,
1157 (void *) SCM_UNPACK (proc
),
1166 scm_internal_hash_fold (scm_t_hash_fold_fn fn
, void *closure
,
1167 SCM init
, SCM table
)
1170 SCM buckets
, result
= init
;
1172 if (SCM_HASHTABLE_P (table
))
1173 buckets
= SCM_HASHTABLE_VECTOR (table
);
1175 /* Weak alist vector. */
1178 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1179 for (i
= 0; i
< n
; ++i
)
1183 for (prev
= SCM_BOOL_F
, ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
);
1185 prev
= ls
, ls
= SCM_CDR (ls
))
1189 if (!scm_is_pair (ls
))
1190 scm_wrong_type_arg (s_scm_hash_fold
, SCM_ARG3
, buckets
);
1192 handle
= SCM_CAR (ls
);
1193 if (!scm_is_pair (handle
))
1194 scm_wrong_type_arg (s_scm_hash_fold
, SCM_ARG3
, buckets
);
1196 if (IS_WEAK_THING (table
))
1198 if (SCM_WEAK_PAIR_DELETED_P (handle
))
1200 /* We hit a weak pair whose car/cdr has become
1201 unreachable: unlink it from the bucket. */
1202 if (prev
!= SCM_BOOL_F
)
1203 SCM_SETCDR (prev
, SCM_CDR (ls
));
1205 SCM_SIMPLE_VECTOR_SET (buckets
, i
, SCM_CDR (ls
));
1207 if (SCM_HASHTABLE_P (table
))
1208 /* Update the item count. */
1209 SCM_HASHTABLE_DECREMENT (table
);
1215 result
= fn (closure
, SCM_CAR (handle
), SCM_CDR (handle
), result
);
1222 /* The following redundant code is here in order to be able to support
1223 hash-for-each-handle. An alternative would have been to replace
1224 this code and scm_internal_hash_fold above with a single
1225 scm_internal_hash_fold_handles, but we don't want to promote such
1229 scm_internal_hash_for_each_handle (scm_t_hash_handle_fn fn
, void *closure
,
1235 if (SCM_HASHTABLE_P (table
))
1236 buckets
= SCM_HASHTABLE_VECTOR (table
);
1240 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1241 for (i
= 0; i
< n
; ++i
)
1243 SCM ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
), handle
;
1244 while (!scm_is_null (ls
))
1246 if (!scm_is_pair (ls
))
1247 scm_wrong_type_arg (s_scm_hash_for_each
, SCM_ARG3
, buckets
);
1248 handle
= SCM_CAR (ls
);
1249 if (!scm_is_pair (handle
))
1250 scm_wrong_type_arg (s_scm_hash_for_each
, SCM_ARG3
, buckets
);
1251 fn (closure
, handle
);
1263 #include "libguile/hashtab.x"