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
);
359 scm_i_hashtable_equal_p (SCM x
, SCM y
)
366 scm_c_make_hash_table (unsigned long k
)
368 return make_hash_table (0, k
, "scm_c_make_hash_table");
371 SCM_DEFINE (scm_make_hash_table
, "make-hash-table", 0, 1, 0,
373 "Make a new abstract hash table object with minimum number of buckets @var{n}\n")
374 #define FUNC_NAME s_scm_make_hash_table
377 return make_hash_table (0, 0, FUNC_NAME
);
379 return make_hash_table (0, scm_to_ulong (n
), FUNC_NAME
);
383 SCM_DEFINE (scm_make_weak_key_hash_table
, "make-weak-key-hash-table", 0, 1, 0,
385 "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
386 "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n"
387 "Return a weak hash table with @var{size} buckets.\n"
389 "You can modify weak hash tables in exactly the same way you\n"
390 "would modify regular hash tables. (@pxref{Hash Tables})")
391 #define FUNC_NAME s_scm_make_weak_key_hash_table
394 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
, 0, FUNC_NAME
);
396 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
,
397 scm_to_ulong (n
), FUNC_NAME
);
402 SCM_DEFINE (scm_make_weak_value_hash_table
, "make-weak-value-hash-table", 0, 1, 0,
404 "Return a hash table with weak values with @var{size} buckets.\n"
405 "(@pxref{Hash Tables})")
406 #define FUNC_NAME s_scm_make_weak_value_hash_table
409 return make_hash_table (SCM_HASHTABLEF_WEAK_CDR
, 0, FUNC_NAME
);
412 return make_hash_table (SCM_HASHTABLEF_WEAK_CDR
,
413 scm_to_ulong (n
), FUNC_NAME
);
419 SCM_DEFINE (scm_make_doubly_weak_hash_table
, "make-doubly-weak-hash-table", 1, 0, 0,
421 "Return a hash table with weak keys and values with @var{size}\n"
422 "buckets. (@pxref{Hash Tables})")
423 #define FUNC_NAME s_scm_make_doubly_weak_hash_table
426 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
431 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
439 SCM_DEFINE (scm_hash_table_p
, "hash-table?", 1, 0, 0,
441 "Return @code{#t} if @var{obj} is an abstract hash table object.")
442 #define FUNC_NAME s_scm_hash_table_p
444 return scm_from_bool (SCM_HASHTABLE_P (obj
));
449 SCM_DEFINE (scm_weak_key_hash_table_p
, "weak-key-hash-table?", 1, 0, 0,
451 "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n"
452 "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n"
453 "Return @code{#t} if @var{obj} is the specified weak hash\n"
454 "table. Note that a doubly weak hash table is neither a weak key\n"
455 "nor a weak value hash table.")
456 #define FUNC_NAME s_scm_weak_key_hash_table_p
458 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_KEY_P (obj
));
463 SCM_DEFINE (scm_weak_value_hash_table_p
, "weak-value-hash-table?", 1, 0, 0,
465 "Return @code{#t} if @var{obj} is a weak value hash table.")
466 #define FUNC_NAME s_scm_weak_value_hash_table_p
468 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_VALUE_P (obj
));
473 SCM_DEFINE (scm_doubly_weak_hash_table_p
, "doubly-weak-hash-table?", 1, 0, 0,
475 "Return @code{#t} if @var{obj} is a doubly weak hash table.")
476 #define FUNC_NAME s_scm_doubly_weak_hash_table_p
478 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_DOUBLY_WEAK_P (obj
));
483 /* Accessing hash table entries. */
486 scm_hash_fn_get_handle (SCM table
, SCM obj
,
487 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
489 #define FUNC_NAME "scm_hash_fn_get_handle"
494 if (SCM_HASHTABLE_P (table
))
495 buckets
= SCM_HASHTABLE_VECTOR (table
);
498 SCM_VALIDATE_VECTOR (1, table
);
502 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
504 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
505 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
506 scm_out_of_range ("hash_fn_get_handle", scm_from_ulong (k
));
508 if (IS_WEAK_THING (table
))
509 h
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
510 assoc_fn
, obj
, closure
);
512 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
520 scm_hash_fn_create_handle_x (SCM table
, SCM obj
, SCM init
,
521 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
523 #define FUNC_NAME "scm_hash_fn_create_handle_x"
528 if (SCM_HASHTABLE_P (table
))
529 buckets
= SCM_HASHTABLE_VECTOR (table
);
532 SCM_ASSERT (scm_is_simple_vector (table
),
533 table
, SCM_ARG1
, "hash_fn_create_handle_x");
536 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
537 SCM_MISC_ERROR ("void hashtable", SCM_EOL
);
539 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
540 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
541 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
543 if (IS_WEAK_THING (table
))
544 it
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
545 assoc_fn
, obj
, closure
);
547 it
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
549 if (scm_is_pair (it
))
551 else if (scm_is_true (it
))
552 scm_wrong_type_arg_msg (NULL
, 0, it
, "a pair");
555 /* When this is a weak hashtable, running the GC can change it.
556 Thus, we must allocate the new cells first and can only then
557 access BUCKETS. Also, we need to fetch the bucket vector
558 again since the hashtable might have been rehashed. This
559 necessitates a new hash value as well.
561 SCM handle
, new_bucket
;
563 if ((SCM_HASHTABLE_P (table
)) && (SCM_HASHTABLE_WEAK_P (table
)))
565 /* FIXME: We don't support weak alist vectors. */
566 /* Use a weak cell. */
567 if (SCM_HASHTABLE_DOUBLY_WEAK_P (table
))
568 handle
= scm_doubly_weak_pair (obj
, init
);
569 else if (SCM_HASHTABLE_WEAK_KEY_P (table
))
570 handle
= scm_weak_car_pair (obj
, init
);
572 handle
= scm_weak_cdr_pair (obj
, init
);
575 /* Use a regular, non-weak cell. */
576 handle
= scm_cons (obj
, init
);
578 new_bucket
= scm_cons (handle
, SCM_EOL
);
580 if (!scm_is_eq (table
, buckets
)
581 && !scm_is_eq (SCM_HASHTABLE_VECTOR (table
), buckets
))
583 buckets
= SCM_HASHTABLE_VECTOR (table
);
584 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
585 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
586 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
588 SCM_SETCDR (new_bucket
, SCM_SIMPLE_VECTOR_REF (buckets
, k
));
589 SCM_SIMPLE_VECTOR_SET (buckets
, k
, new_bucket
);
590 if (!scm_is_eq (table
, buckets
))
592 /* Update element count and maybe rehash the table. The
593 table might have too few entries here since weak hash
594 tables used with the hashx_* functions can not be
597 SCM_HASHTABLE_INCREMENT (table
);
598 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
)
599 || SCM_HASHTABLE_N_ITEMS (table
) > SCM_HASHTABLE_UPPER (table
))
600 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
602 return SCM_CAR (new_bucket
);
609 scm_hash_fn_ref (SCM table
, SCM obj
, SCM dflt
,
610 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
613 SCM it
= scm_hash_fn_get_handle (table
, obj
, hash_fn
, assoc_fn
, closure
);
614 if (scm_is_pair (it
))
624 scm_hash_fn_set_x (SCM table
, SCM obj
, SCM val
,
625 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
630 it
= scm_hash_fn_create_handle_x (table
, obj
, SCM_BOOL_F
, hash_fn
, assoc_fn
, closure
);
631 SCM_SETCDR (it
, val
);
637 scm_hash_fn_remove_x (SCM table
, SCM obj
,
638 scm_t_hash_fn hash_fn
,
639 scm_t_assoc_fn assoc_fn
,
645 if (SCM_HASHTABLE_P (table
))
646 buckets
= SCM_HASHTABLE_VECTOR (table
);
649 SCM_ASSERT (scm_is_simple_vector (table
), table
,
650 SCM_ARG1
, "hash_fn_remove_x");
653 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
656 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
657 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
658 scm_out_of_range ("hash_fn_remove_x", scm_from_ulong (k
));
660 if (IS_WEAK_THING (table
))
661 h
= weak_bucket_assoc (table
, buckets
, k
, hash_fn
,
662 assoc_fn
, obj
, closure
);
664 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
668 SCM_SIMPLE_VECTOR_SET
669 (buckets
, k
, scm_delq_x (h
, SCM_SIMPLE_VECTOR_REF (buckets
, k
)));
670 if (!scm_is_eq (table
, buckets
))
672 SCM_HASHTABLE_DECREMENT (table
);
673 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
674 scm_i_rehash (table
, hash_fn
, closure
, "scm_hash_fn_remove_x");
680 SCM_DEFINE (scm_hash_clear_x
, "hash-clear!", 1, 0, 0,
682 "Remove all items from @var{table} (without triggering a resize).")
683 #define FUNC_NAME s_scm_hash_clear_x
685 if (SCM_HASHTABLE_P (table
))
687 scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table
), SCM_EOL
);
688 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
691 scm_vector_fill_x (table
, SCM_EOL
);
692 return SCM_UNSPECIFIED
;
698 SCM_DEFINE (scm_hashq_get_handle
, "hashq-get-handle", 2, 0, 0,
699 (SCM table
, SCM key
),
700 "This procedure returns the @code{(key . value)} pair from the\n"
701 "hash table @var{table}. If @var{table} does not hold an\n"
702 "associated value for @var{key}, @code{#f} is returned.\n"
703 "Uses @code{eq?} for equality testing.")
704 #define FUNC_NAME s_scm_hashq_get_handle
706 return scm_hash_fn_get_handle (table
, key
,
707 (scm_t_hash_fn
) scm_ihashq
,
708 (scm_t_assoc_fn
) scm_sloppy_assq
,
714 SCM_DEFINE (scm_hashq_create_handle_x
, "hashq-create-handle!", 3, 0, 0,
715 (SCM table
, SCM key
, SCM init
),
716 "This function looks up @var{key} in @var{table} and returns its handle.\n"
717 "If @var{key} is not already present, a new handle is created which\n"
718 "associates @var{key} with @var{init}.")
719 #define FUNC_NAME s_scm_hashq_create_handle_x
721 return scm_hash_fn_create_handle_x (table
, key
, init
,
722 (scm_t_hash_fn
) scm_ihashq
,
723 (scm_t_assoc_fn
) scm_sloppy_assq
,
729 SCM_DEFINE (scm_hashq_ref
, "hashq-ref", 2, 1, 0,
730 (SCM table
, SCM key
, SCM dflt
),
731 "Look up @var{key} in the hash table @var{table}, and return the\n"
732 "value (if any) associated with it. If @var{key} is not found,\n"
733 "return @var{default} (or @code{#f} if no @var{default} argument\n"
734 "is supplied). Uses @code{eq?} for equality testing.")
735 #define FUNC_NAME s_scm_hashq_ref
737 if (SCM_UNBNDP (dflt
))
739 return scm_hash_fn_ref (table
, key
, dflt
,
740 (scm_t_hash_fn
) scm_ihashq
,
741 (scm_t_assoc_fn
) scm_sloppy_assq
,
748 SCM_DEFINE (scm_hashq_set_x
, "hashq-set!", 3, 0, 0,
749 (SCM table
, SCM key
, SCM val
),
750 "Find the entry in @var{table} associated with @var{key}, and\n"
751 "store @var{value} there. Uses @code{eq?} for equality testing.")
752 #define FUNC_NAME s_scm_hashq_set_x
754 return scm_hash_fn_set_x (table
, key
, val
,
755 (scm_t_hash_fn
) scm_ihashq
,
756 (scm_t_assoc_fn
) scm_sloppy_assq
,
763 SCM_DEFINE (scm_hashq_remove_x
, "hashq-remove!", 2, 0, 0,
764 (SCM table
, SCM key
),
765 "Remove @var{key} (and any value associated with it) from\n"
766 "@var{table}. Uses @code{eq?} for equality tests.")
767 #define FUNC_NAME s_scm_hashq_remove_x
769 return scm_hash_fn_remove_x (table
, key
,
770 (scm_t_hash_fn
) scm_ihashq
,
771 (scm_t_assoc_fn
) scm_sloppy_assq
,
779 SCM_DEFINE (scm_hashv_get_handle
, "hashv-get-handle", 2, 0, 0,
780 (SCM table
, SCM key
),
781 "This procedure returns the @code{(key . value)} pair from the\n"
782 "hash table @var{table}. If @var{table} does not hold an\n"
783 "associated value for @var{key}, @code{#f} is returned.\n"
784 "Uses @code{eqv?} for equality testing.")
785 #define FUNC_NAME s_scm_hashv_get_handle
787 return scm_hash_fn_get_handle (table
, key
,
788 (scm_t_hash_fn
) scm_ihashv
,
789 (scm_t_assoc_fn
) scm_sloppy_assv
,
795 SCM_DEFINE (scm_hashv_create_handle_x
, "hashv-create-handle!", 3, 0, 0,
796 (SCM table
, SCM key
, SCM init
),
797 "This function looks up @var{key} in @var{table} and returns its handle.\n"
798 "If @var{key} is not already present, a new handle is created which\n"
799 "associates @var{key} with @var{init}.")
800 #define FUNC_NAME s_scm_hashv_create_handle_x
802 return scm_hash_fn_create_handle_x (table
, key
, init
,
803 (scm_t_hash_fn
) scm_ihashv
,
804 (scm_t_assoc_fn
) scm_sloppy_assv
,
810 SCM_DEFINE (scm_hashv_ref
, "hashv-ref", 2, 1, 0,
811 (SCM table
, SCM key
, SCM dflt
),
812 "Look up @var{key} in the hash table @var{table}, and return the\n"
813 "value (if any) associated with it. If @var{key} is not found,\n"
814 "return @var{default} (or @code{#f} if no @var{default} argument\n"
815 "is supplied). Uses @code{eqv?} for equality testing.")
816 #define FUNC_NAME s_scm_hashv_ref
818 if (SCM_UNBNDP (dflt
))
820 return scm_hash_fn_ref (table
, key
, dflt
,
821 (scm_t_hash_fn
) scm_ihashv
,
822 (scm_t_assoc_fn
) scm_sloppy_assv
,
829 SCM_DEFINE (scm_hashv_set_x
, "hashv-set!", 3, 0, 0,
830 (SCM table
, SCM key
, SCM val
),
831 "Find the entry in @var{table} associated with @var{key}, and\n"
832 "store @var{value} there. Uses @code{eqv?} for equality testing.")
833 #define FUNC_NAME s_scm_hashv_set_x
835 return scm_hash_fn_set_x (table
, key
, val
,
836 (scm_t_hash_fn
) scm_ihashv
,
837 (scm_t_assoc_fn
) scm_sloppy_assv
,
843 SCM_DEFINE (scm_hashv_remove_x
, "hashv-remove!", 2, 0, 0,
844 (SCM table
, SCM key
),
845 "Remove @var{key} (and any value associated with it) from\n"
846 "@var{table}. Uses @code{eqv?} for equality tests.")
847 #define FUNC_NAME s_scm_hashv_remove_x
849 return scm_hash_fn_remove_x (table
, key
,
850 (scm_t_hash_fn
) scm_ihashv
,
851 (scm_t_assoc_fn
) scm_sloppy_assv
,
858 SCM_DEFINE (scm_hash_get_handle
, "hash-get-handle", 2, 0, 0,
859 (SCM table
, SCM key
),
860 "This procedure returns the @code{(key . value)} pair from the\n"
861 "hash table @var{table}. If @var{table} does not hold an\n"
862 "associated value for @var{key}, @code{#f} is returned.\n"
863 "Uses @code{equal?} for equality testing.")
864 #define FUNC_NAME s_scm_hash_get_handle
866 return scm_hash_fn_get_handle (table
, key
,
867 (scm_t_hash_fn
) scm_ihash
,
868 (scm_t_assoc_fn
) scm_sloppy_assoc
,
874 SCM_DEFINE (scm_hash_create_handle_x
, "hash-create-handle!", 3, 0, 0,
875 (SCM table
, SCM key
, SCM init
),
876 "This function looks up @var{key} in @var{table} and returns its handle.\n"
877 "If @var{key} is not already present, a new handle is created which\n"
878 "associates @var{key} with @var{init}.")
879 #define FUNC_NAME s_scm_hash_create_handle_x
881 return scm_hash_fn_create_handle_x (table
, key
, init
,
882 (scm_t_hash_fn
) scm_ihash
,
883 (scm_t_assoc_fn
) scm_sloppy_assoc
,
889 SCM_DEFINE (scm_hash_ref
, "hash-ref", 2, 1, 0,
890 (SCM table
, SCM key
, SCM dflt
),
891 "Look up @var{key} in the hash table @var{table}, and return the\n"
892 "value (if any) associated with it. If @var{key} is not found,\n"
893 "return @var{default} (or @code{#f} if no @var{default} argument\n"
894 "is supplied). Uses @code{equal?} for equality testing.")
895 #define FUNC_NAME s_scm_hash_ref
897 if (SCM_UNBNDP (dflt
))
899 return scm_hash_fn_ref (table
, key
, dflt
,
900 (scm_t_hash_fn
) scm_ihash
,
901 (scm_t_assoc_fn
) scm_sloppy_assoc
,
908 SCM_DEFINE (scm_hash_set_x
, "hash-set!", 3, 0, 0,
909 (SCM table
, SCM key
, SCM val
),
910 "Find the entry in @var{table} associated with @var{key}, and\n"
911 "store @var{value} there. Uses @code{equal?} for equality\n"
913 #define FUNC_NAME s_scm_hash_set_x
915 return scm_hash_fn_set_x (table
, key
, val
,
916 (scm_t_hash_fn
) scm_ihash
,
917 (scm_t_assoc_fn
) scm_sloppy_assoc
,
924 SCM_DEFINE (scm_hash_remove_x
, "hash-remove!", 2, 0, 0,
925 (SCM table
, SCM key
),
926 "Remove @var{key} (and any value associated with it) from\n"
927 "@var{table}. Uses @code{equal?} for equality tests.")
928 #define FUNC_NAME s_scm_hash_remove_x
930 return scm_hash_fn_remove_x (table
, key
,
931 (scm_t_hash_fn
) scm_ihash
,
932 (scm_t_assoc_fn
) scm_sloppy_assoc
,
940 typedef struct scm_t_ihashx_closure
944 } scm_t_ihashx_closure
;
949 scm_ihashx (SCM obj
, unsigned long n
, void *arg
)
952 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
953 answer
= scm_call_2 (closure
->hash
, obj
, scm_from_ulong (n
));
954 return scm_to_ulong (answer
);
960 scm_sloppy_assx (SCM obj
, SCM alist
, void *arg
)
962 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
963 return scm_call_2 (closure
->assoc
, obj
, alist
);
967 SCM_DEFINE (scm_hashx_get_handle
, "hashx-get-handle", 4, 0, 0,
968 (SCM hash
, SCM assoc
, SCM table
, SCM key
),
969 "This behaves the same way as the corresponding\n"
970 "@code{-get-handle} function, but uses @var{hash} as a hash\n"
971 "function and @var{assoc} to compare keys. @code{hash} must be\n"
972 "a function that takes two arguments, a key to be hashed and a\n"
973 "table size. @code{assoc} must be an associator function, like\n"
974 "@code{assoc}, @code{assq} or @code{assv}.")
975 #define FUNC_NAME s_scm_hashx_get_handle
977 scm_t_ihashx_closure closure
;
979 closure
.assoc
= assoc
;
980 return scm_hash_fn_get_handle (table
, key
, scm_ihashx
, scm_sloppy_assx
,
986 SCM_DEFINE (scm_hashx_create_handle_x
, "hashx-create-handle!", 5, 0, 0,
987 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM init
),
988 "This behaves the same way as the corresponding\n"
989 "@code{-create-handle} function, but uses @var{hash} as a hash\n"
990 "function and @var{assoc} to compare keys. @code{hash} must be\n"
991 "a function that takes two arguments, a key to be hashed and a\n"
992 "table size. @code{assoc} must be an associator function, like\n"
993 "@code{assoc}, @code{assq} or @code{assv}.")
994 #define FUNC_NAME s_scm_hashx_create_handle_x
996 scm_t_ihashx_closure closure
;
998 closure
.assoc
= assoc
;
999 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashx
,
1000 scm_sloppy_assx
, (void *)&closure
);
1006 SCM_DEFINE (scm_hashx_ref
, "hashx-ref", 4, 1, 0,
1007 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM dflt
),
1008 "This behaves the same way as the corresponding @code{ref}\n"
1009 "function, but uses @var{hash} as a hash function and\n"
1010 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1011 "that takes two arguments, a key to be hashed and a table size.\n"
1012 "@code{assoc} must be an associator function, like @code{assoc},\n"
1013 "@code{assq} or @code{assv}.\n"
1015 "By way of illustration, @code{hashq-ref table key} is\n"
1016 "equivalent to @code{hashx-ref hashq assq table key}.")
1017 #define FUNC_NAME s_scm_hashx_ref
1019 scm_t_ihashx_closure closure
;
1020 if (SCM_UNBNDP (dflt
))
1022 closure
.hash
= hash
;
1023 closure
.assoc
= assoc
;
1024 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashx
, scm_sloppy_assx
,
1032 SCM_DEFINE (scm_hashx_set_x
, "hashx-set!", 5, 0, 0,
1033 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM val
),
1034 "This behaves the same way as the corresponding @code{set!}\n"
1035 "function, but uses @var{hash} as a hash function and\n"
1036 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1037 "that takes two arguments, a key to be hashed and a table size.\n"
1038 "@code{assoc} must be an associator function, like @code{assoc},\n"
1039 "@code{assq} or @code{assv}.\n"
1041 " By way of illustration, @code{hashq-set! table key} is\n"
1042 "equivalent to @code{hashx-set! hashq assq table key}.")
1043 #define FUNC_NAME s_scm_hashx_set_x
1045 scm_t_ihashx_closure closure
;
1046 closure
.hash
= hash
;
1047 closure
.assoc
= assoc
;
1048 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashx
, scm_sloppy_assx
,
1053 SCM_DEFINE (scm_hashx_remove_x
, "hashx-remove!", 4, 0, 0,
1054 (SCM hash
, SCM assoc
, SCM table
, SCM obj
),
1055 "This behaves the same way as the corresponding @code{remove!}\n"
1056 "function, but uses @var{hash} as a hash function and\n"
1057 "@var{assoc} to compare keys. @code{hash} must be a function\n"
1058 "that takes two arguments, a key to be hashed and a table size.\n"
1059 "@code{assoc} must be an associator function, like @code{assoc},\n"
1060 "@code{assq} or @code{assv}.\n"
1062 " By way of illustration, @code{hashq-remove! table key} is\n"
1063 "equivalent to @code{hashx-remove! hashq assq #f table key}.")
1064 #define FUNC_NAME s_scm_hashx_remove_x
1066 scm_t_ihashx_closure closure
;
1067 closure
.hash
= hash
;
1068 closure
.assoc
= assoc
;
1069 return scm_hash_fn_remove_x (table
, obj
, scm_ihashx
, scm_sloppy_assx
,
1074 /* Hash table iterators */
1076 static const char s_scm_hash_fold
[];
1079 scm_internal_hash_fold (scm_t_hash_fold_fn fn
, void *closure
,
1080 SCM init
, SCM table
)
1083 SCM buckets
, result
= init
;
1085 if (SCM_HASHTABLE_P (table
))
1086 buckets
= SCM_HASHTABLE_VECTOR (table
);
1088 /* Weak alist vector. */
1091 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1092 for (i
= 0; i
< n
; ++i
)
1096 for (prev
= SCM_BOOL_F
, ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
);
1098 prev
= ls
, ls
= SCM_CDR (ls
))
1102 if (!scm_is_pair (ls
))
1103 scm_wrong_type_arg (s_scm_hash_fold
, SCM_ARG3
, buckets
);
1105 handle
= SCM_CAR (ls
);
1106 if (!scm_is_pair (handle
))
1107 scm_wrong_type_arg (s_scm_hash_fold
, SCM_ARG3
, buckets
);
1109 if (IS_WEAK_THING (table
))
1111 if (SCM_WEAK_PAIR_DELETED_P (handle
))
1113 /* We hit a weak pair whose car/cdr has become
1114 unreachable: unlink it from the bucket. */
1115 if (prev
!= SCM_BOOL_F
)
1116 SCM_SETCDR (prev
, SCM_CDR (ls
));
1118 SCM_SIMPLE_VECTOR_SET (buckets
, i
, SCM_CDR (ls
));
1120 if (SCM_HASHTABLE_P (table
))
1121 /* Update the item count. */
1122 SCM_HASHTABLE_DECREMENT (table
);
1128 result
= fn (closure
, SCM_CAR (handle
), SCM_CDR (handle
), result
);
1135 /* The following redundant code is here in order to be able to support
1136 hash-for-each-handle. An alternative would have been to replace
1137 this code and scm_internal_hash_fold above with a single
1138 scm_internal_hash_fold_handles, but we don't want to promote such
1141 static const char s_scm_hash_for_each
[];
1144 scm_internal_hash_for_each_handle (scm_t_hash_handle_fn fn
, void *closure
,
1150 if (SCM_HASHTABLE_P (table
))
1151 buckets
= SCM_HASHTABLE_VECTOR (table
);
1155 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1156 for (i
= 0; i
< n
; ++i
)
1158 SCM ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
), handle
;
1159 while (!scm_is_null (ls
))
1161 if (!scm_is_pair (ls
))
1162 scm_wrong_type_arg (s_scm_hash_for_each
, SCM_ARG3
, buckets
);
1163 handle
= SCM_CAR (ls
);
1164 if (!scm_is_pair (handle
))
1165 scm_wrong_type_arg (s_scm_hash_for_each
, SCM_ARG3
, buckets
);
1166 fn (closure
, handle
);
1172 SCM_DEFINE (scm_hash_fold
, "hash-fold", 3, 0, 0,
1173 (SCM proc
, SCM init
, SCM table
),
1174 "An iterator over hash-table elements.\n"
1175 "Accumulates and returns a result by applying PROC successively.\n"
1176 "The arguments to PROC are \"(key value prior-result)\" where key\n"
1177 "and value are successive pairs from the hash table TABLE, and\n"
1178 "prior-result is either INIT (for the first application of PROC)\n"
1179 "or the return value of the previous application of PROC.\n"
1180 "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
1181 "table into an a-list of key-value pairs.")
1182 #define FUNC_NAME s_scm_hash_fold
1184 SCM_VALIDATE_PROC (1, proc
);
1185 if (!SCM_HASHTABLE_P (table
))
1186 SCM_VALIDATE_VECTOR (3, table
);
1187 return scm_internal_hash_fold ((scm_t_hash_fold_fn
) scm_call_3
,
1188 (void *) SCM_UNPACK (proc
), init
, table
);
1193 for_each_proc (void *proc
, SCM handle
)
1195 return scm_call_2 (SCM_PACK (proc
), SCM_CAR (handle
), SCM_CDR (handle
));
1198 SCM_DEFINE (scm_hash_for_each
, "hash-for-each", 2, 0, 0,
1199 (SCM proc
, SCM table
),
1200 "An iterator over hash-table elements.\n"
1201 "Applies PROC successively on all hash table items.\n"
1202 "The arguments to PROC are \"(key value)\" where key\n"
1203 "and value are successive pairs from the hash table TABLE.")
1204 #define FUNC_NAME s_scm_hash_for_each
1206 SCM_VALIDATE_PROC (1, proc
);
1207 if (!SCM_HASHTABLE_P (table
))
1208 SCM_VALIDATE_VECTOR (2, table
);
1210 scm_internal_hash_for_each_handle (for_each_proc
,
1211 (void *) SCM_UNPACK (proc
),
1213 return SCM_UNSPECIFIED
;
1217 SCM_DEFINE (scm_hash_for_each_handle
, "hash-for-each-handle", 2, 0, 0,
1218 (SCM proc
, SCM table
),
1219 "An iterator over hash-table elements.\n"
1220 "Applies PROC successively on all hash table handles.")
1221 #define FUNC_NAME s_scm_hash_for_each_handle
1223 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)), proc
, 1, FUNC_NAME
);
1224 if (!SCM_HASHTABLE_P (table
))
1225 SCM_VALIDATE_VECTOR (2, table
);
1227 scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn
) scm_call_1
,
1228 (void *) SCM_UNPACK (proc
),
1230 return SCM_UNSPECIFIED
;
1235 map_proc (void *proc
, SCM key
, SCM data
, SCM value
)
1237 return scm_cons (scm_call_2 (SCM_PACK (proc
), key
, data
), value
);
1240 SCM_DEFINE (scm_hash_map_to_list
, "hash-map->list", 2, 0, 0,
1241 (SCM proc
, SCM table
),
1242 "An iterator over hash-table elements.\n"
1243 "Accumulates and returns as a list the results of applying PROC successively.\n"
1244 "The arguments to PROC are \"(key value)\" where key\n"
1245 "and value are successive pairs from the hash table TABLE.")
1246 #define FUNC_NAME s_scm_hash_map_to_list
1248 SCM_VALIDATE_PROC (1, proc
);
1249 if (!SCM_HASHTABLE_P (table
))
1250 SCM_VALIDATE_VECTOR (2, table
);
1251 return scm_internal_hash_fold (map_proc
,
1252 (void *) SCM_UNPACK (proc
),
1264 #include "libguile/hashtab.x"