1 /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008 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
27 #include "libguile/_scm.h"
28 #include "libguile/alist.h"
29 #include "libguile/hash.h"
30 #include "libguile/eval.h"
31 #include "libguile/root.h"
32 #include "libguile/vectors.h"
33 #include "libguile/ports.h"
35 #include "libguile/validate.h"
36 #include "libguile/hashtab.h"
43 * 1. The current hash table implementation uses weak alist vectors
44 * (implementation in weaks.c) internally, but we do the scanning
45 * ourselves (in scan_weak_hashtables) because we need to update the
46 * hash table structure when items are dropped during GC.
48 * 2. All hash table operations still work on alist vectors.
52 /* Hash tables are either vectors of association lists or smobs
53 * containing such vectors. Currently, the vector version represents
54 * constant size tables while those wrapped in a smob represents
57 * Growing or shrinking, with following rehashing, is triggered when
60 * L = N / S (N: number of items in table, S: bucket vector length)
62 * passes an upper limit of 0.9 or a lower limit of 0.25.
64 * The implementation stores the upper and lower number of items which
65 * trigger a resize in the hashtable object.
67 * Possible hash table sizes (primes) are stored in the array
71 scm_t_bits scm_tc16_hashtable
;
73 static unsigned long hashtable_size
[] = {
74 31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363,
75 224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041
77 /* vectors are currently restricted to 2^24-1 = 16777215 elements. */
78 28762081, 57524111, 115048217, 230096423, 460192829
79 /* larger values can't be represented as INUMs */
83 #define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long))
85 static char *s_hashtable
= "hashtable";
89 /* Helper functions and macros to deal with weak pairs.
91 Weak pairs need to be accessed very carefully since their components can
92 be nullified by the GC when the object they refer to becomes unreachable.
93 Hence the macros and functions below that detect such weak pairs within
94 buckets and remove them. */
97 /* Return a ``usable'' version of ALIST, an alist of weak pairs. By
98 ``usable'', we mean that it contains only valid Scheme objects. On
99 return, REMOVED_ITEMS is set to the number of pairs that have been
102 scm_fixup_weak_alist (SCM alist
, size_t *removed_items
)
110 prev
= alist
, alist
= SCM_CDR (alist
))
112 SCM pair
= SCM_CAR (alist
);
114 if (scm_is_pair (pair
))
116 if (SCM_WEAK_PAIR_DELETED_P (pair
))
118 /* Remove from ALIST weak pair PAIR whose car/cdr has been
119 nullified by the GC. */
121 result
= SCM_CDR (alist
);
123 SCM_SETCDR (prev
, SCM_CDR (alist
));
137 /* Return true if OBJ is either a weak hash table or a weak alist vector (as
138 defined in `weaks.[ch]').
139 FIXME: We should eventually keep only weah hash tables. Actually, the
140 procs in `weaks.c' already no longer return vectors. */
141 /* XXX: We assume that if OBJ is a vector, then it's a _weak_ alist vector. */
142 #define IS_WEAK_THING(_obj) \
143 ((SCM_HASHTABLE_P (table) && (SCM_HASHTABLE_WEAK_P (table))) \
144 || (SCM_I_IS_VECTOR (table)))
148 /* Fixup BUCKET, an alist part of weak hash table OBJ. BUCKETS is the full
149 bucket vector for OBJ and IDX is the index of BUCKET within this
150 vector. See also `scm_internal_hash_fold ()'. */
151 #define START_WEAK_BUCKET_FIXUP(_obj, _buckets, _idx, _bucket, _hashfn) \
156 /* Disable the GC so that BUCKET remains valid until ASSOC_FN has \
158 /* FIXME: We could maybe trigger a rehash here depending on whether \
159 `scm_fixup_weak_alist ()' noticed some change. */ \
161 (_bucket) = scm_fixup_weak_alist ((_bucket), &_removed); \
162 SCM_SIMPLE_VECTOR_SET ((_buckets), (_idx), (_bucket)); \
164 if ((_removed) && (SCM_HASHTABLE_P (_obj))) \
166 SCM_SET_HASHTABLE_N_ITEMS ((_obj), \
167 SCM_HASHTABLE_N_ITEMS (_obj) - _removed); \
168 scm_i_rehash ((_obj), (_hashfn), \
169 NULL, "START_WEAK_BUCKET_FIXUP"); \
174 /* Terminate a weak bucket fixup phase. */
175 #define END_WEAK_BUCKET_FIXUP(_obj, _buckets, _idx, _bucket, _hashfn) \
176 do { GC_enable (); } while (0)
181 make_hash_table (int flags
, unsigned long k
, const char *func_name
)
185 int i
= 0, n
= k
? k
: 31;
186 while (i
< HASHTABLE_SIZE_N
&& n
> hashtable_size
[i
])
188 n
= hashtable_size
[i
];
190 /* In both cases, i.e., regardless of whether we are creating a weak hash
191 table, we return a non-weak vector. This is because the vector itself
192 is not weak in the case of a weak hash table: the alist pairs are. */
193 vector
= scm_c_make_vector (n
, SCM_EOL
);
195 t
= scm_gc_malloc_pointerless (sizeof (*t
), s_hashtable
);
196 t
->min_size_index
= t
->size_index
= i
;
199 t
->upper
= 9 * n
/ 10;
203 SCM_NEWSMOB2 (table
, scm_tc16_hashtable
, vector
, t
);
209 scm_i_rehash (SCM table
,
210 unsigned long (*hash_fn
)(),
212 const char* func_name
)
214 SCM buckets
, new_buckets
;
216 unsigned long old_size
;
217 unsigned long new_size
;
219 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
221 /* rehashing is not triggered when i <= min_size */
222 i
= SCM_HASHTABLE (table
)->size_index
;
225 while (i
> SCM_HASHTABLE (table
)->min_size_index
226 && SCM_HASHTABLE_N_ITEMS (table
) < hashtable_size
[i
] / 4);
230 i
= SCM_HASHTABLE (table
)->size_index
+ 1;
231 if (i
>= HASHTABLE_SIZE_N
)
235 /* Remember HASH_FN for rehash_after_gc, but only when CLOSURE
236 is not needed since CLOSURE can not be guaranteed to be valid
237 after this function returns.
240 SCM_HASHTABLE (table
)->hash_fn
= hash_fn
;
242 SCM_HASHTABLE (table
)->size_index
= i
;
244 new_size
= hashtable_size
[i
];
245 if (i
<= SCM_HASHTABLE (table
)->min_size_index
)
246 SCM_HASHTABLE (table
)->lower
= 0;
248 SCM_HASHTABLE (table
)->lower
= new_size
/ 4;
249 SCM_HASHTABLE (table
)->upper
= 9 * new_size
/ 10;
250 buckets
= SCM_HASHTABLE_VECTOR (table
);
252 new_buckets
= scm_c_make_vector (new_size
, SCM_EOL
);
254 /* When this is a weak hashtable, running the GC might change it.
255 We need to cope with this while rehashing its elements. We do
256 this by first installing the new, empty bucket vector. Then we
257 remove the elements from the old bucket vector and insert them
261 SCM_SET_HASHTABLE_VECTOR (table
, new_buckets
);
262 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
264 old_size
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
265 for (i
= 0; i
< old_size
; ++i
)
267 SCM ls
, cell
, handle
;
269 ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
);
270 SCM_SIMPLE_VECTOR_SET (buckets
, i
, SCM_EOL
);
272 while (scm_is_pair (ls
))
277 handle
= SCM_CAR (cell
);
280 if (SCM_WEAK_PAIR_DELETED_P (handle
))
281 /* HANDLE is a nullified weak pair: skip it. */
284 h
= hash_fn (SCM_CAR (handle
), new_size
, closure
);
286 scm_out_of_range (func_name
, scm_from_ulong (h
));
287 SCM_SETCDR (cell
, SCM_SIMPLE_VECTOR_REF (new_buckets
, h
));
288 SCM_SIMPLE_VECTOR_SET (new_buckets
, h
, cell
);
289 SCM_HASHTABLE_INCREMENT (table
);
296 hashtable_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
298 scm_puts ("#<", port
);
299 if (SCM_HASHTABLE_WEAK_KEY_P (exp
))
300 scm_puts ("weak-key-", port
);
301 else if (SCM_HASHTABLE_WEAK_VALUE_P (exp
))
302 scm_puts ("weak-value-", port
);
303 else if (SCM_HASHTABLE_DOUBLY_WEAK_P (exp
))
304 scm_puts ("doubly-weak-", port
);
305 scm_puts ("hash-table ", port
);
306 scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp
), 10, port
);
307 scm_putc ('/', port
);
308 scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp
)),
310 scm_puts (">", port
);
316 scm_c_make_hash_table (unsigned long k
)
318 return make_hash_table (0, k
, "scm_c_make_hash_table");
321 SCM_DEFINE (scm_make_hash_table
, "make-hash-table", 0, 1, 0,
323 "Make a new abstract hash table object with minimum number of buckets @var{n}\n")
324 #define FUNC_NAME s_scm_make_hash_table
327 return make_hash_table (0, 0, FUNC_NAME
);
329 return make_hash_table (0, scm_to_ulong (n
), FUNC_NAME
);
333 SCM_DEFINE (scm_make_weak_key_hash_table
, "make-weak-key-hash-table", 0, 1, 0,
335 "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
336 "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n"
337 "Return a weak hash table with @var{size} buckets.\n"
339 "You can modify weak hash tables in exactly the same way you\n"
340 "would modify regular hash tables. (@pxref{Hash Tables})")
341 #define FUNC_NAME s_scm_make_weak_key_hash_table
344 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
, 0, FUNC_NAME
);
346 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
,
347 scm_to_ulong (n
), FUNC_NAME
);
352 SCM_DEFINE (scm_make_weak_value_hash_table
, "make-weak-value-hash-table", 0, 1, 0,
354 "Return a hash table with weak values with @var{size} buckets.\n"
355 "(@pxref{Hash Tables})")
356 #define FUNC_NAME s_scm_make_weak_value_hash_table
359 return make_hash_table (SCM_HASHTABLEF_WEAK_CDR
, 0, FUNC_NAME
);
362 return make_hash_table (SCM_HASHTABLEF_WEAK_CDR
,
363 scm_to_ulong (n
), FUNC_NAME
);
369 SCM_DEFINE (scm_make_doubly_weak_hash_table
, "make-doubly-weak-hash-table", 1, 0, 0,
371 "Return a hash table with weak keys and values with @var{size}\n"
372 "buckets. (@pxref{Hash Tables})")
373 #define FUNC_NAME s_scm_make_doubly_weak_hash_table
376 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
381 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
389 SCM_DEFINE (scm_hash_table_p
, "hash-table?", 1, 0, 0,
391 "Return @code{#t} if @var{obj} is an abstract hash table object.")
392 #define FUNC_NAME s_scm_hash_table_p
394 return scm_from_bool (SCM_HASHTABLE_P (obj
));
399 SCM_DEFINE (scm_weak_key_hash_table_p
, "weak-key-hash-table?", 1, 0, 0,
401 "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n"
402 "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n"
403 "Return @code{#t} if @var{obj} is the specified weak hash\n"
404 "table. Note that a doubly weak hash table is neither a weak key\n"
405 "nor a weak value hash table.")
406 #define FUNC_NAME s_scm_weak_key_hash_table_p
408 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_KEY_P (obj
));
413 SCM_DEFINE (scm_weak_value_hash_table_p
, "weak-value-hash-table?", 1, 0, 0,
415 "Return @code{#t} if @var{obj} is a weak value hash table.")
416 #define FUNC_NAME s_scm_weak_value_hash_table_p
418 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_VALUE_P (obj
));
423 SCM_DEFINE (scm_doubly_weak_hash_table_p
, "doubly-weak-hash-table?", 1, 0, 0,
425 "Return @code{#t} if @var{obj} is a doubly weak hash table.")
426 #define FUNC_NAME s_scm_doubly_weak_hash_table_p
428 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_DOUBLY_WEAK_P (obj
));
434 scm_hash_fn_get_handle (SCM table
, SCM obj
, unsigned long (*hash_fn
)(), SCM (*assoc_fn
)(), void * closure
)
435 #define FUNC_NAME "scm_hash_fn_get_handle"
439 SCM buckets
, alist
, h
;
441 if (SCM_HASHTABLE_P (table
))
442 buckets
= SCM_HASHTABLE_VECTOR (table
);
445 SCM_VALIDATE_VECTOR (1, table
);
449 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
451 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
452 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
453 scm_out_of_range ("hash_fn_get_handle", scm_from_ulong (k
));
455 weak
= IS_WEAK_THING (table
);
456 alist
= SCM_SIMPLE_VECTOR_REF (buckets
, k
);
459 START_WEAK_BUCKET_FIXUP (table
, buckets
, k
, alist
, hash_fn
);
461 h
= assoc_fn (obj
, alist
, closure
);
463 END_WEAK_BUCKET_FIXUP (table
, buckets
, k
, alist
, hash_fn
);
471 scm_hash_fn_create_handle_x (SCM table
, SCM obj
, SCM init
, unsigned long (*hash_fn
)(),
472 SCM (*assoc_fn
)(), void * closure
)
473 #define FUNC_NAME "scm_hash_fn_create_handle_x"
477 SCM buckets
, alist
, it
;
479 if (SCM_HASHTABLE_P (table
))
480 buckets
= SCM_HASHTABLE_VECTOR (table
);
483 SCM_ASSERT (scm_is_simple_vector (table
),
484 table
, SCM_ARG1
, "hash_fn_create_handle_x");
487 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
488 SCM_MISC_ERROR ("void hashtable", SCM_EOL
);
490 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
491 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
492 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
494 weak
= IS_WEAK_THING (table
);
495 alist
= SCM_SIMPLE_VECTOR_REF (buckets
, k
);
497 START_WEAK_BUCKET_FIXUP (table
, buckets
, k
, alist
, hash_fn
);
499 it
= assoc_fn (obj
, alist
, closure
);
501 END_WEAK_BUCKET_FIXUP (table
, buckets
, k
, alist
, hash_fn
);
503 if (scm_is_pair (it
))
505 else if (scm_is_true (it
))
506 scm_wrong_type_arg_msg (NULL
, 0, it
, "a pair");
509 /* When this is a weak hashtable, running the GC can change it.
510 Thus, we must allocate the new cells first and can only then
511 access BUCKETS. Also, we need to fetch the bucket vector
512 again since the hashtable might have been rehashed. This
513 necessitates a new hash value as well.
515 SCM handle
, new_bucket
;
517 if ((SCM_HASHTABLE_P (table
)) && (SCM_HASHTABLE_WEAK_P (table
)))
519 /* FIXME: We don't support weak alist vectors. */
520 /* Use a weak cell. */
521 if (SCM_HASHTABLE_DOUBLY_WEAK_P (table
))
522 handle
= scm_doubly_weak_pair (obj
, init
);
523 else if (SCM_HASHTABLE_WEAK_KEY_P (table
))
524 handle
= scm_weak_car_pair (obj
, init
);
526 handle
= scm_weak_cdr_pair (obj
, init
);
529 /* Use a regular, non-weak cell. */
530 handle
= scm_cons (obj
, init
);
532 new_bucket
= scm_cons (handle
, SCM_EOL
);
534 if (!scm_is_eq (table
, buckets
)
535 && !scm_is_eq (SCM_HASHTABLE_VECTOR (table
), buckets
))
537 buckets
= SCM_HASHTABLE_VECTOR (table
);
538 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
539 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
540 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
542 SCM_SETCDR (new_bucket
, SCM_SIMPLE_VECTOR_REF (buckets
, k
));
543 SCM_SIMPLE_VECTOR_SET (buckets
, k
, new_bucket
);
544 if (!scm_is_eq (table
, buckets
))
546 /* Update element count and maybe rehash the table. The
547 table might have too few entries here since weak hash
548 tables used with the hashx_* functions can not be
551 SCM_HASHTABLE_INCREMENT (table
);
552 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
)
553 || SCM_HASHTABLE_N_ITEMS (table
) > SCM_HASHTABLE_UPPER (table
))
554 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
556 return SCM_CAR (new_bucket
);
563 scm_hash_fn_ref (SCM table
, SCM obj
, SCM dflt
, unsigned long (*hash_fn
)(),
564 SCM (*assoc_fn
)(), void * closure
)
566 SCM it
= scm_hash_fn_get_handle (table
, obj
, hash_fn
, assoc_fn
, closure
);
567 if (scm_is_pair (it
))
577 scm_hash_fn_set_x (SCM table
, SCM obj
, SCM val
, unsigned long (*hash_fn
)(),
578 SCM (*assoc_fn
)(), void * closure
)
582 it
= scm_hash_fn_create_handle_x (table
, obj
, SCM_BOOL_F
, hash_fn
, assoc_fn
, closure
);
583 SCM_SETCDR (it
, val
);
589 scm_hash_fn_remove_x (SCM table
, SCM obj
,
590 unsigned long (*hash_fn
)(),
596 SCM buckets
, alist
, h
;
598 if (SCM_HASHTABLE_P (table
))
599 buckets
= SCM_HASHTABLE_VECTOR (table
);
602 SCM_ASSERT (scm_is_simple_vector (table
), table
,
603 SCM_ARG1
, "hash_fn_remove_x");
606 if (SCM_SIMPLE_VECTOR_LENGTH (table
) == 0)
609 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
610 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
611 scm_out_of_range ("hash_fn_remove_x", scm_from_ulong (k
));
613 weak
= IS_WEAK_THING (table
);
614 alist
= SCM_SIMPLE_VECTOR_REF (buckets
, k
);
616 START_WEAK_BUCKET_FIXUP (table
, buckets
, k
, alist
, hash_fn
);
618 h
= assoc_fn (obj
, alist
, closure
);
620 END_WEAK_BUCKET_FIXUP (table
, buckets
, k
, alist
, hash_fn
);
624 SCM_SIMPLE_VECTOR_SET
625 (buckets
, k
, scm_delq_x (h
, SCM_SIMPLE_VECTOR_REF (buckets
, k
)));
626 if (!scm_is_eq (table
, buckets
))
628 SCM_HASHTABLE_DECREMENT (table
);
629 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
630 scm_i_rehash (table
, hash_fn
, closure
, "scm_hash_fn_remove_x");
636 SCM_DEFINE (scm_hash_clear_x
, "hash-clear!", 1, 0, 0,
638 "Remove all items from @var{table} (without triggering a resize).")
639 #define FUNC_NAME s_scm_hash_clear_x
641 if (SCM_HASHTABLE_P (table
))
643 scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table
), SCM_EOL
);
644 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
647 scm_vector_fill_x (table
, SCM_EOL
);
648 return SCM_UNSPECIFIED
;
654 SCM_DEFINE (scm_hashq_get_handle
, "hashq-get-handle", 2, 0, 0,
655 (SCM table
, SCM key
),
656 "This procedure returns the @code{(key . value)} pair from the\n"
657 "hash table @var{table}. If @var{table} does not hold an\n"
658 "associated value for @var{key}, @code{#f} is returned.\n"
659 "Uses @code{eq?} for equality testing.")
660 #define FUNC_NAME s_scm_hashq_get_handle
662 return scm_hash_fn_get_handle (table
, key
, scm_ihashq
, scm_sloppy_assq
, 0);
667 SCM_DEFINE (scm_hashq_create_handle_x
, "hashq-create-handle!", 3, 0, 0,
668 (SCM table
, SCM key
, SCM init
),
669 "This function looks up @var{key} in @var{table} and returns its handle.\n"
670 "If @var{key} is not already present, a new handle is created which\n"
671 "associates @var{key} with @var{init}.")
672 #define FUNC_NAME s_scm_hashq_create_handle_x
674 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashq
, scm_sloppy_assq
, 0);
679 SCM_DEFINE (scm_hashq_ref
, "hashq-ref", 2, 1, 0,
680 (SCM table
, SCM key
, SCM dflt
),
681 "Look up @var{key} in the hash table @var{table}, and return the\n"
682 "value (if any) associated with it. If @var{key} is not found,\n"
683 "return @var{default} (or @code{#f} if no @var{default} argument\n"
684 "is supplied). Uses @code{eq?} for equality testing.")
685 #define FUNC_NAME s_scm_hashq_ref
687 if (SCM_UNBNDP (dflt
))
689 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashq
, scm_sloppy_assq
, 0);
695 SCM_DEFINE (scm_hashq_set_x
, "hashq-set!", 3, 0, 0,
696 (SCM table
, SCM key
, SCM val
),
697 "Find the entry in @var{table} associated with @var{key}, and\n"
698 "store @var{value} there. Uses @code{eq?} for equality testing.")
699 #define FUNC_NAME s_scm_hashq_set_x
701 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashq
, scm_sloppy_assq
, 0);
707 SCM_DEFINE (scm_hashq_remove_x
, "hashq-remove!", 2, 0, 0,
708 (SCM table
, SCM key
),
709 "Remove @var{key} (and any value associated with it) from\n"
710 "@var{table}. Uses @code{eq?} for equality tests.")
711 #define FUNC_NAME s_scm_hashq_remove_x
713 return scm_hash_fn_remove_x (table
, key
, scm_ihashq
, scm_sloppy_assq
, 0);
720 SCM_DEFINE (scm_hashv_get_handle
, "hashv-get-handle", 2, 0, 0,
721 (SCM table
, SCM key
),
722 "This procedure returns the @code{(key . value)} pair from the\n"
723 "hash table @var{table}. If @var{table} does not hold an\n"
724 "associated value for @var{key}, @code{#f} is returned.\n"
725 "Uses @code{eqv?} for equality testing.")
726 #define FUNC_NAME s_scm_hashv_get_handle
728 return scm_hash_fn_get_handle (table
, key
, scm_ihashv
, scm_sloppy_assv
, 0);
733 SCM_DEFINE (scm_hashv_create_handle_x
, "hashv-create-handle!", 3, 0, 0,
734 (SCM table
, SCM key
, SCM init
),
735 "This function looks up @var{key} in @var{table} and returns its handle.\n"
736 "If @var{key} is not already present, a new handle is created which\n"
737 "associates @var{key} with @var{init}.")
738 #define FUNC_NAME s_scm_hashv_create_handle_x
740 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashv
,
746 SCM_DEFINE (scm_hashv_ref
, "hashv-ref", 2, 1, 0,
747 (SCM table
, SCM key
, SCM dflt
),
748 "Look up @var{key} in the hash table @var{table}, and return the\n"
749 "value (if any) associated with it. If @var{key} is not found,\n"
750 "return @var{default} (or @code{#f} if no @var{default} argument\n"
751 "is supplied). Uses @code{eqv?} for equality testing.")
752 #define FUNC_NAME s_scm_hashv_ref
754 if (SCM_UNBNDP (dflt
))
756 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashv
, scm_sloppy_assv
, 0);
762 SCM_DEFINE (scm_hashv_set_x
, "hashv-set!", 3, 0, 0,
763 (SCM table
, SCM key
, SCM val
),
764 "Find the entry in @var{table} associated with @var{key}, and\n"
765 "store @var{value} there. Uses @code{eqv?} for equality testing.")
766 #define FUNC_NAME s_scm_hashv_set_x
768 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashv
, scm_sloppy_assv
, 0);
773 SCM_DEFINE (scm_hashv_remove_x
, "hashv-remove!", 2, 0, 0,
774 (SCM table
, SCM key
),
775 "Remove @var{key} (and any value associated with it) from\n"
776 "@var{table}. Uses @code{eqv?} for equality tests.")
777 #define FUNC_NAME s_scm_hashv_remove_x
779 return scm_hash_fn_remove_x (table
, key
, scm_ihashv
, scm_sloppy_assv
, 0);
785 SCM_DEFINE (scm_hash_get_handle
, "hash-get-handle", 2, 0, 0,
786 (SCM table
, SCM key
),
787 "This procedure returns the @code{(key . value)} pair from the\n"
788 "hash table @var{table}. If @var{table} does not hold an\n"
789 "associated value for @var{key}, @code{#f} is returned.\n"
790 "Uses @code{equal?} for equality testing.")
791 #define FUNC_NAME s_scm_hash_get_handle
793 return scm_hash_fn_get_handle (table
, key
, scm_ihash
, scm_sloppy_assoc
, 0);
798 SCM_DEFINE (scm_hash_create_handle_x
, "hash-create-handle!", 3, 0, 0,
799 (SCM table
, SCM key
, SCM init
),
800 "This function looks up @var{key} in @var{table} and returns its handle.\n"
801 "If @var{key} is not already present, a new handle is created which\n"
802 "associates @var{key} with @var{init}.")
803 #define FUNC_NAME s_scm_hash_create_handle_x
805 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihash
, scm_sloppy_assoc
, 0);
810 SCM_DEFINE (scm_hash_ref
, "hash-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{equal?} for equality testing.")
816 #define FUNC_NAME s_scm_hash_ref
818 if (SCM_UNBNDP (dflt
))
820 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihash
, scm_sloppy_assoc
, 0);
826 SCM_DEFINE (scm_hash_set_x
, "hash-set!", 3, 0, 0,
827 (SCM table
, SCM key
, SCM val
),
828 "Find the entry in @var{table} associated with @var{key}, and\n"
829 "store @var{value} there. Uses @code{equal?} for equality\n"
831 #define FUNC_NAME s_scm_hash_set_x
833 return scm_hash_fn_set_x (table
, key
, val
, scm_ihash
, scm_sloppy_assoc
, 0);
839 SCM_DEFINE (scm_hash_remove_x
, "hash-remove!", 2, 0, 0,
840 (SCM table
, SCM key
),
841 "Remove @var{key} (and any value associated with it) from\n"
842 "@var{table}. Uses @code{equal?} for equality tests.")
843 #define FUNC_NAME s_scm_hash_remove_x
845 return scm_hash_fn_remove_x (table
, key
, scm_ihash
, scm_sloppy_assoc
, 0);
852 typedef struct scm_t_ihashx_closure
856 } scm_t_ihashx_closure
;
861 scm_ihashx (SCM obj
, unsigned long n
, scm_t_ihashx_closure
*closure
)
863 SCM answer
= scm_call_2 (closure
->hash
, obj
, scm_from_ulong (n
));
864 return scm_to_ulong (answer
);
870 scm_sloppy_assx (SCM obj
, SCM alist
, scm_t_ihashx_closure
*closure
)
872 return scm_call_2 (closure
->assoc
, obj
, alist
);
876 SCM_DEFINE (scm_hashx_get_handle
, "hashx-get-handle", 4, 0, 0,
877 (SCM hash
, SCM assoc
, SCM table
, SCM key
),
878 "This behaves the same way as the corresponding\n"
879 "@code{-get-handle} function, but uses @var{hash} as a hash\n"
880 "function and @var{assoc} to compare keys. @code{hash} must be\n"
881 "a function that takes two arguments, a key to be hashed and a\n"
882 "table size. @code{assoc} must be an associator function, like\n"
883 "@code{assoc}, @code{assq} or @code{assv}.")
884 #define FUNC_NAME s_scm_hashx_get_handle
886 scm_t_ihashx_closure closure
;
888 closure
.assoc
= assoc
;
889 return scm_hash_fn_get_handle (table
, key
, scm_ihashx
, scm_sloppy_assx
,
895 SCM_DEFINE (scm_hashx_create_handle_x
, "hashx-create-handle!", 5, 0, 0,
896 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM init
),
897 "This behaves the same way as the corresponding\n"
898 "@code{-create-handle} function, but uses @var{hash} as a hash\n"
899 "function and @var{assoc} to compare keys. @code{hash} must be\n"
900 "a function that takes two arguments, a key to be hashed and a\n"
901 "table size. @code{assoc} must be an associator function, like\n"
902 "@code{assoc}, @code{assq} or @code{assv}.")
903 #define FUNC_NAME s_scm_hashx_create_handle_x
905 scm_t_ihashx_closure closure
;
907 closure
.assoc
= assoc
;
908 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashx
,
909 scm_sloppy_assx
, (void *)&closure
);
915 SCM_DEFINE (scm_hashx_ref
, "hashx-ref", 4, 1, 0,
916 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM dflt
),
917 "This behaves the same way as the corresponding @code{ref}\n"
918 "function, but uses @var{hash} as a hash function and\n"
919 "@var{assoc} to compare keys. @code{hash} must be a function\n"
920 "that takes two arguments, a key to be hashed and a table size.\n"
921 "@code{assoc} must be an associator function, like @code{assoc},\n"
922 "@code{assq} or @code{assv}.\n"
924 "By way of illustration, @code{hashq-ref table key} is\n"
925 "equivalent to @code{hashx-ref hashq assq table key}.")
926 #define FUNC_NAME s_scm_hashx_ref
928 scm_t_ihashx_closure closure
;
929 if (SCM_UNBNDP (dflt
))
932 closure
.assoc
= assoc
;
933 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashx
, scm_sloppy_assx
,
941 SCM_DEFINE (scm_hashx_set_x
, "hashx-set!", 5, 0, 0,
942 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM val
),
943 "This behaves the same way as the corresponding @code{set!}\n"
944 "function, but uses @var{hash} as a hash function and\n"
945 "@var{assoc} to compare keys. @code{hash} must be a function\n"
946 "that takes two arguments, a key to be hashed and a table size.\n"
947 "@code{assoc} must be an associator function, like @code{assoc},\n"
948 "@code{assq} or @code{assv}.\n"
950 " By way of illustration, @code{hashq-set! table key} is\n"
951 "equivalent to @code{hashx-set! hashq assq table key}.")
952 #define FUNC_NAME s_scm_hashx_set_x
954 scm_t_ihashx_closure closure
;
956 closure
.assoc
= assoc
;
957 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashx
, scm_sloppy_assx
,
962 SCM_DEFINE (scm_hashx_remove_x
, "hashx-remove!", 4, 0, 0,
963 (SCM hash
, SCM assoc
, SCM table
, SCM obj
),
964 "This behaves the same way as the corresponding @code{remove!}\n"
965 "function, but uses @var{hash} as a hash function and\n"
966 "@var{assoc} to compare keys. @code{hash} must be a function\n"
967 "that takes two arguments, a key to be hashed and a table size.\n"
968 "@code{assoc} must be an associator function, like @code{assoc},\n"
969 "@code{assq} or @code{assv}.\n"
971 " By way of illustration, @code{hashq-remove! table key} is\n"
972 "equivalent to @code{hashx-remove! hashq assq #f table key}.")
973 #define FUNC_NAME s_scm_hashx_remove_x
975 scm_t_ihashx_closure closure
;
977 closure
.assoc
= assoc
;
978 return scm_hash_fn_remove_x (table
, obj
, scm_ihashx
, scm_sloppy_assx
,
983 /* Hash table iterators */
985 static const char s_scm_hash_fold
[];
988 scm_internal_hash_fold (SCM (*fn
) (), void *closure
, SCM init
, SCM table
)
991 SCM buckets
, result
= init
;
993 if (SCM_HASHTABLE_P (table
))
994 buckets
= SCM_HASHTABLE_VECTOR (table
);
996 /* Weak alist vector. */
999 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1000 for (i
= 0; i
< n
; ++i
)
1004 for (prev
= SCM_BOOL_F
, ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
);
1006 prev
= ls
, ls
= SCM_CDR (ls
))
1010 if (!scm_is_pair (ls
))
1011 scm_wrong_type_arg (s_scm_hash_fold
, SCM_ARG3
, buckets
);
1013 handle
= SCM_CAR (ls
);
1014 if (!scm_is_pair (handle
))
1015 scm_wrong_type_arg (s_scm_hash_fold
, SCM_ARG3
, buckets
);
1017 if (IS_WEAK_THING (table
))
1019 if (SCM_WEAK_PAIR_DELETED_P (handle
))
1021 /* We hit a weak pair whose car/cdr has become
1022 unreachable: unlink it from the bucket. */
1023 if (prev
!= SCM_BOOL_F
)
1024 SCM_SETCDR (prev
, SCM_CDR (ls
));
1026 SCM_SIMPLE_VECTOR_SET (buckets
, i
, SCM_CDR (ls
));
1028 if (SCM_HASHTABLE_P (table
))
1029 /* Update the item count. */
1030 SCM_HASHTABLE_DECREMENT (table
);
1036 result
= fn (closure
, SCM_CAR (handle
), SCM_CDR (handle
), result
);
1043 /* The following redundant code is here in order to be able to support
1044 hash-for-each-handle. An alternative would have been to replace
1045 this code and scm_internal_hash_fold above with a single
1046 scm_internal_hash_fold_handles, but we don't want to promote such
1049 static const char s_scm_hash_for_each
[];
1052 scm_internal_hash_for_each_handle (SCM (*fn
) (), void *closure
, SCM table
)
1057 if (SCM_HASHTABLE_P (table
))
1058 buckets
= SCM_HASHTABLE_VECTOR (table
);
1062 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1063 for (i
= 0; i
< n
; ++i
)
1065 SCM ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
), handle
;
1066 while (!scm_is_null (ls
))
1068 if (!scm_is_pair (ls
))
1069 scm_wrong_type_arg (s_scm_hash_for_each
, SCM_ARG3
, buckets
);
1070 handle
= SCM_CAR (ls
);
1071 if (!scm_is_pair (handle
))
1072 scm_wrong_type_arg (s_scm_hash_for_each
, SCM_ARG3
, buckets
);
1073 fn (closure
, handle
);
1079 SCM_DEFINE (scm_hash_fold
, "hash-fold", 3, 0, 0,
1080 (SCM proc
, SCM init
, SCM table
),
1081 "An iterator over hash-table elements.\n"
1082 "Accumulates and returns a result by applying PROC successively.\n"
1083 "The arguments to PROC are \"(key value prior-result)\" where key\n"
1084 "and value are successive pairs from the hash table TABLE, and\n"
1085 "prior-result is either INIT (for the first application of PROC)\n"
1086 "or the return value of the previous application of PROC.\n"
1087 "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
1088 "table into an a-list of key-value pairs.")
1089 #define FUNC_NAME s_scm_hash_fold
1091 SCM_VALIDATE_PROC (1, proc
);
1092 if (!SCM_HASHTABLE_P (table
))
1093 SCM_VALIDATE_VECTOR (3, table
);
1094 return scm_internal_hash_fold (scm_call_3
, (void *) SCM_UNPACK (proc
), init
, table
);
1099 for_each_proc (void *proc
, SCM handle
)
1101 return scm_call_2 (SCM_PACK (proc
), SCM_CAR (handle
), SCM_CDR (handle
));
1104 SCM_DEFINE (scm_hash_for_each
, "hash-for-each", 2, 0, 0,
1105 (SCM proc
, SCM table
),
1106 "An iterator over hash-table elements.\n"
1107 "Applies PROC successively on all hash table items.\n"
1108 "The arguments to PROC are \"(key value)\" where key\n"
1109 "and value are successive pairs from the hash table TABLE.")
1110 #define FUNC_NAME s_scm_hash_for_each
1112 SCM_VALIDATE_PROC (1, proc
);
1113 if (!SCM_HASHTABLE_P (table
))
1114 SCM_VALIDATE_VECTOR (2, table
);
1116 scm_internal_hash_for_each_handle (for_each_proc
,
1117 (void *) SCM_UNPACK (proc
),
1119 return SCM_UNSPECIFIED
;
1123 SCM_DEFINE (scm_hash_for_each_handle
, "hash-for-each-handle", 2, 0, 0,
1124 (SCM proc
, SCM table
),
1125 "An iterator over hash-table elements.\n"
1126 "Applies PROC successively on all hash table handles.")
1127 #define FUNC_NAME s_scm_hash_for_each_handle
1129 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
1130 SCM_ASSERT (call
, proc
, 1, FUNC_NAME
);
1131 if (!SCM_HASHTABLE_P (table
))
1132 SCM_VALIDATE_VECTOR (2, table
);
1134 scm_internal_hash_for_each_handle (call
,
1135 (void *) SCM_UNPACK (proc
),
1137 return SCM_UNSPECIFIED
;
1142 map_proc (void *proc
, SCM key
, SCM data
, SCM value
)
1144 return scm_cons (scm_call_2 (SCM_PACK (proc
), key
, data
), value
);
1147 SCM_DEFINE (scm_hash_map_to_list
, "hash-map->list", 2, 0, 0,
1148 (SCM proc
, SCM table
),
1149 "An iterator over hash-table elements.\n"
1150 "Accumulates and returns as a list the results of applying PROC successively.\n"
1151 "The arguments to PROC are \"(key value)\" where key\n"
1152 "and value are successive pairs from the hash table TABLE.")
1153 #define FUNC_NAME s_scm_hash_map_to_list
1155 SCM_VALIDATE_PROC (1, proc
);
1156 if (!SCM_HASHTABLE_P (table
))
1157 SCM_VALIDATE_VECTOR (2, table
);
1158 return scm_internal_hash_fold (map_proc
,
1159 (void *) SCM_UNPACK (proc
),
1169 scm_hashtab_prehistory ()
1171 /* Initialize the hashtab SMOB type. */
1172 scm_tc16_hashtable
= scm_make_smob_type (s_hashtable
, 0);
1173 scm_set_smob_print (scm_tc16_hashtable
, hashtable_print
);
1179 #include "libguile/hashtab.x"