1 /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004 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
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful,
9 * but 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 02110-1301 USA
23 #include "libguile/_scm.h"
24 #include "libguile/alist.h"
25 #include "libguile/hash.h"
26 #include "libguile/eval.h"
27 #include "libguile/root.h"
28 #include "libguile/vectors.h"
29 #include "libguile/ports.h"
31 #include "libguile/validate.h"
32 #include "libguile/hashtab.h"
37 * 1. The current hash table implementation uses weak alist vectors
38 * (implementation in weaks.c) internally, but we do the scanning
39 * ourselves (in scan_weak_hashtables) because we need to update the
40 * hash table structure when items are dropped during GC.
42 * 2. All hash table operations still work on alist vectors.
46 /* Hash tables are either vectors of association lists or smobs
47 * containing such vectors. Currently, the vector version represents
48 * constant size tables while those wrapped in a smob represents
51 * Growing or shrinking, with following rehashing, is triggered when
54 * L = N / S (N: number of items in table, S: bucket vector length)
56 * passes an upper limit of 0.9 or a lower limit of 0.25.
58 * The implementation stores the upper and lower number of items which
59 * trigger a resize in the hashtable object.
61 * Possible hash table sizes (primes) are stored in the array
65 scm_t_bits scm_tc16_hashtable
;
67 static unsigned long hashtable_size
[] = {
68 31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363,
69 224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041
71 /* vectors are currently restricted to 2^24-1 = 16777215 elements. */
72 28762081, 57524111, 115048217, 230096423, 460192829
73 /* larger values can't be represented as INUMs */
77 #define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long))
79 static char *s_hashtable
= "hashtable";
81 SCM weak_hashtables
= SCM_EOL
;
84 make_hash_table (int flags
, unsigned long k
, const char *func_name
)
88 int i
= 0, n
= k
? k
: 31;
89 while (i
< HASHTABLE_SIZE_N
&& n
> hashtable_size
[i
])
91 n
= hashtable_size
[i
];
93 vector
= scm_i_allocate_weak_vector (flags
, scm_from_int (n
), SCM_EOL
);
95 vector
= scm_c_make_vector (n
, SCM_EOL
);
96 t
= scm_gc_malloc (sizeof (*t
), s_hashtable
);
97 t
->min_size_index
= t
->size_index
= i
;
100 t
->upper
= 9 * n
/ 10;
105 SCM_NEWSMOB3 (table
, scm_tc16_hashtable
, vector
, t
, weak_hashtables
);
106 weak_hashtables
= table
;
109 SCM_NEWSMOB3 (table
, scm_tc16_hashtable
, vector
, t
, SCM_EOL
);
114 scm_i_rehash (SCM table
,
115 unsigned long (*hash_fn
)(),
117 const char* func_name
)
119 SCM buckets
, new_buckets
;
121 unsigned long old_size
;
122 unsigned long new_size
;
124 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
126 /* rehashing is not triggered when i <= min_size */
127 i
= SCM_HASHTABLE (table
)->size_index
;
130 while (i
> SCM_HASHTABLE (table
)->min_size_index
131 && SCM_HASHTABLE_N_ITEMS (table
) < hashtable_size
[i
] / 4);
135 i
= SCM_HASHTABLE (table
)->size_index
+ 1;
136 if (i
>= HASHTABLE_SIZE_N
)
140 /* Remember HASH_FN for rehash_after_gc, but only when CLOSURE
141 is not needed since CLOSURE can not be guaranteed to be valid
142 after this function returns.
145 SCM_HASHTABLE (table
)->hash_fn
= hash_fn
;
147 SCM_HASHTABLE (table
)->size_index
= i
;
149 new_size
= hashtable_size
[i
];
150 if (i
<= SCM_HASHTABLE (table
)->min_size_index
)
151 SCM_HASHTABLE (table
)->lower
= 0;
153 SCM_HASHTABLE (table
)->lower
= new_size
/ 4;
154 SCM_HASHTABLE (table
)->upper
= 9 * new_size
/ 10;
155 buckets
= SCM_HASHTABLE_VECTOR (table
);
157 if (SCM_HASHTABLE_WEAK_P (table
))
158 new_buckets
= scm_i_allocate_weak_vector (SCM_HASHTABLE_FLAGS (table
),
159 scm_from_ulong (new_size
),
162 new_buckets
= scm_c_make_vector (new_size
, SCM_EOL
);
164 /* When this is a weak hashtable, running the GC might change it.
165 We need to cope with this while rehashing its elements. We do
166 this by first installing the new, empty bucket vector. Then we
167 remove the elements from the old bucket vector and insert them
171 SCM_SET_HASHTABLE_VECTOR (table
, new_buckets
);
172 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
174 old_size
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
175 for (i
= 0; i
< old_size
; ++i
)
177 SCM ls
, cell
, handle
;
179 ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
);
180 SCM_SIMPLE_VECTOR_SET (buckets
, i
, SCM_EOL
);
182 while (scm_is_pair (ls
))
186 handle
= SCM_CAR (cell
);
188 h
= hash_fn (SCM_CAR (handle
), new_size
, closure
);
190 scm_out_of_range (func_name
, scm_from_ulong (h
));
191 SCM_SETCDR (cell
, SCM_SIMPLE_VECTOR_REF (new_buckets
, h
));
192 SCM_SIMPLE_VECTOR_SET (new_buckets
, h
, cell
);
193 SCM_HASHTABLE_INCREMENT (table
);
200 hashtable_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
202 scm_puts ("#<", port
);
203 if (SCM_HASHTABLE_WEAK_KEY_P (exp
))
204 scm_puts ("weak-key-", port
);
205 else if (SCM_HASHTABLE_WEAK_VALUE_P (exp
))
206 scm_puts ("weak-value-", port
);
207 else if (SCM_HASHTABLE_DOUBLY_WEAK_P (exp
))
208 scm_puts ("doubly-weak-", port
);
209 scm_puts ("hash-table ", port
);
210 scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp
), 10, port
);
211 scm_putc ('/', port
);
212 scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp
)),
214 scm_puts (">", port
);
218 #define UNMARKED_CELL_P(x) (SCM_NIMP(x) && !SCM_GC_MARK_P (x))
220 /* keep track of hash tables that need to shrink after scan */
221 static SCM to_rehash
= SCM_EOL
;
223 /* scan hash tables and update hash tables item count */
225 scm_i_scan_weak_hashtables ()
227 SCM
*next
= &weak_hashtables
;
229 while (!scm_is_null (h
))
231 if (!SCM_GC_MARK_P (h
))
232 *next
= h
= SCM_HASHTABLE_NEXT (h
);
235 SCM vec
= SCM_HASHTABLE_VECTOR (h
);
236 size_t delta
= SCM_I_WVECT_DELTA (vec
);
237 SCM_I_SET_WVECT_DELTA (vec
, 0);
238 SCM_SET_HASHTABLE_N_ITEMS (h
, SCM_HASHTABLE_N_ITEMS (h
) - delta
);
240 if (SCM_HASHTABLE_N_ITEMS (h
) < SCM_HASHTABLE_LOWER (h
))
242 SCM tmp
= SCM_HASHTABLE_NEXT (h
);
243 /* temporarily move table from weak_hashtables to to_rehash */
244 SCM_SET_HASHTABLE_NEXT (h
, to_rehash
);
250 next
= SCM_HASHTABLE_NEXTLOC (h
);
251 h
= SCM_HASHTABLE_NEXT (h
);
258 rehash_after_gc (void *dummy1 SCM_UNUSED
,
259 void *dummy2 SCM_UNUSED
,
260 void *dummy3 SCM_UNUSED
)
262 if (!scm_is_null (to_rehash
))
264 SCM first
= to_rehash
, last
, h
;
265 /* important to clear to_rehash here so that we don't get stuck
266 in an infinite loop if scm_i_rehash causes GC */
271 /* Rehash only when we have a hash_fn.
273 if (SCM_HASHTABLE (h
)->hash_fn
)
274 scm_i_rehash (h
, SCM_HASHTABLE (h
)->hash_fn
, NULL
,
277 h
= SCM_HASHTABLE_NEXT (h
);
278 } while (!scm_is_null (h
));
279 /* move tables back to weak_hashtables */
280 SCM_SET_HASHTABLE_NEXT (last
, weak_hashtables
);
281 weak_hashtables
= first
;
287 hashtable_free (SCM obj
)
289 scm_gc_free (SCM_HASHTABLE (obj
), sizeof (scm_t_hashtable
), s_hashtable
);
295 scm_c_make_hash_table (unsigned long k
)
297 return make_hash_table (0, k
, "scm_c_make_hash_table");
300 SCM_DEFINE (scm_make_hash_table
, "make-hash-table", 0, 1, 0,
302 "Make a new abstract hash table object with minimum number of buckets @var{n}\n")
303 #define FUNC_NAME s_scm_make_hash_table
306 return make_hash_table (0, 0, FUNC_NAME
);
308 return make_hash_table (0, scm_to_ulong (n
), FUNC_NAME
);
312 SCM_DEFINE (scm_make_weak_key_hash_table
, "make-weak-key-hash-table", 0, 1, 0,
314 "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
315 "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n"
316 "Return a weak hash table with @var{size} buckets.\n"
318 "You can modify weak hash tables in exactly the same way you\n"
319 "would modify regular hash tables. (@pxref{Hash Tables})")
320 #define FUNC_NAME s_scm_make_weak_key_hash_table
323 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
, 0, FUNC_NAME
);
325 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
,
326 scm_to_ulong (n
), FUNC_NAME
);
331 SCM_DEFINE (scm_make_weak_value_hash_table
, "make-weak-value-hash-table", 0, 1, 0,
333 "Return a hash table with weak values with @var{size} buckets.\n"
334 "(@pxref{Hash Tables})")
335 #define FUNC_NAME s_scm_make_weak_value_hash_table
338 return make_hash_table (SCM_HASHTABLEF_WEAK_CDR
, 0, FUNC_NAME
);
341 return make_hash_table (SCM_HASHTABLEF_WEAK_CDR
,
342 scm_to_ulong (n
), FUNC_NAME
);
348 SCM_DEFINE (scm_make_doubly_weak_hash_table
, "make-doubly-weak-hash-table", 1, 0, 0,
350 "Return a hash table with weak keys and values with @var{size}\n"
351 "buckets. (@pxref{Hash Tables})")
352 #define FUNC_NAME s_scm_make_doubly_weak_hash_table
355 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
360 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
368 SCM_DEFINE (scm_hash_table_p
, "hash-table?", 1, 0, 0,
370 "Return @code{#t} if @var{obj} is an abstract hash table object.")
371 #define FUNC_NAME s_scm_hash_table_p
373 return scm_from_bool (SCM_HASHTABLE_P (obj
));
378 SCM_DEFINE (scm_weak_key_hash_table_p
, "weak-key-hash-table?", 1, 0, 0,
380 "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n"
381 "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n"
382 "Return @code{#t} if @var{obj} is the specified weak hash\n"
383 "table. Note that a doubly weak hash table is neither a weak key\n"
384 "nor a weak value hash table.")
385 #define FUNC_NAME s_scm_weak_key_hash_table_p
387 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_KEY_P (obj
));
392 SCM_DEFINE (scm_weak_value_hash_table_p
, "weak-value-hash-table?", 1, 0, 0,
394 "Return @code{#t} if @var{obj} is a weak value hash table.")
395 #define FUNC_NAME s_scm_weak_value_hash_table_p
397 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_VALUE_P (obj
));
402 SCM_DEFINE (scm_doubly_weak_hash_table_p
, "doubly-weak-hash-table?", 1, 0, 0,
404 "Return @code{#t} if @var{obj} is a doubly weak hash table.")
405 #define FUNC_NAME s_scm_doubly_weak_hash_table_p
407 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_DOUBLY_WEAK_P (obj
));
413 scm_hash_fn_get_handle (SCM table
, SCM obj
, unsigned long (*hash_fn
)(), SCM (*assoc_fn
)(), void * closure
)
414 #define FUNC_NAME "scm_hash_fn_get_handle"
419 if (SCM_HASHTABLE_P (table
))
420 table
= SCM_HASHTABLE_VECTOR (table
);
422 SCM_VALIDATE_VECTOR (1, table
);
423 if (SCM_SIMPLE_VECTOR_LENGTH (table
) == 0)
425 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (table
), closure
);
426 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (table
))
427 scm_out_of_range ("hash_fn_get_handle", scm_from_ulong (k
));
428 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (table
, k
), closure
);
435 scm_hash_fn_create_handle_x (SCM table
, SCM obj
, SCM init
, unsigned long (*hash_fn
)(),
436 SCM (*assoc_fn
)(), void * closure
)
437 #define FUNC_NAME "scm_hash_fn_create_handle_x"
442 if (SCM_HASHTABLE_P (table
))
443 buckets
= SCM_HASHTABLE_VECTOR (table
);
446 SCM_ASSERT (scm_is_simple_vector (table
),
447 table
, SCM_ARG1
, "hash_fn_create_handle_x");
450 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
451 SCM_MISC_ERROR ("void hashtable", SCM_EOL
);
453 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
454 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
455 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
456 it
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
457 if (scm_is_true (it
))
461 /* When this is a weak hashtable, running the GC can change it.
462 Thus, we must allocate the new cells first and can only then
463 access BUCKETS. Also, we need to fetch the bucket vector
464 again since the hashtable might have been rehashed. This
465 necessitates a new hash value as well.
467 SCM new_bucket
= scm_acons (obj
, init
, SCM_EOL
);
468 if (!scm_is_eq (table
, buckets
)
469 && !scm_is_eq (SCM_HASHTABLE_VECTOR (table
), buckets
))
471 buckets
= SCM_HASHTABLE_VECTOR (table
);
472 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
473 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
474 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
476 SCM_SETCDR (new_bucket
, SCM_SIMPLE_VECTOR_REF (buckets
, k
));
477 SCM_SIMPLE_VECTOR_SET (buckets
, k
, new_bucket
);
478 if (!scm_is_eq (table
, buckets
))
480 /* Update element count and maybe rehash the table. The
481 table might have too few entries here since weak hash
482 tables used with the hashx_* functions can not be
485 SCM_HASHTABLE_INCREMENT (table
);
486 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
)
487 || SCM_HASHTABLE_N_ITEMS (table
) > SCM_HASHTABLE_UPPER (table
))
488 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
490 return SCM_CAR (new_bucket
);
497 scm_hash_fn_ref (SCM table
, SCM obj
, SCM dflt
, unsigned long (*hash_fn
)(),
498 SCM (*assoc_fn
)(), void * closure
)
500 SCM it
= scm_hash_fn_get_handle (table
, obj
, hash_fn
, assoc_fn
, closure
);
501 if (scm_is_pair (it
))
511 scm_hash_fn_set_x (SCM table
, SCM obj
, SCM val
, unsigned long (*hash_fn
)(),
512 SCM (*assoc_fn
)(), void * closure
)
516 it
= scm_hash_fn_create_handle_x (table
, obj
, SCM_BOOL_F
, hash_fn
, assoc_fn
, closure
);
517 SCM_SETCDR (it
, val
);
523 scm_hash_fn_remove_x (SCM table
, SCM obj
,
524 unsigned long (*hash_fn
)(),
531 if (SCM_HASHTABLE_P (table
))
532 buckets
= SCM_HASHTABLE_VECTOR (table
);
535 SCM_ASSERT (scm_is_simple_vector (table
), table
,
536 SCM_ARG1
, "hash_fn_remove_x");
539 if (SCM_SIMPLE_VECTOR_LENGTH (table
) == 0)
542 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
543 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
544 scm_out_of_range ("hash_fn_remove_x", scm_from_ulong (k
));
545 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
548 SCM_SIMPLE_VECTOR_SET
549 (buckets
, k
, scm_delq_x (h
, SCM_SIMPLE_VECTOR_REF (buckets
, k
)));
550 if (!scm_is_eq (table
, buckets
))
552 SCM_HASHTABLE_DECREMENT (table
);
553 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
554 scm_i_rehash (table
, hash_fn
, closure
, "scm_hash_fn_remove_x");
560 SCM_DEFINE (scm_hash_clear_x
, "hash-clear!", 1, 0, 0,
562 "Remove all items from @var{table} (without triggering a resize).")
563 #define FUNC_NAME s_scm_hash_clear_x
565 if (SCM_HASHTABLE_P (table
))
567 scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table
), SCM_EOL
);
568 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
571 scm_vector_fill_x (table
, SCM_EOL
);
572 return SCM_UNSPECIFIED
;
578 SCM_DEFINE (scm_hashq_get_handle
, "hashq-get-handle", 2, 0, 0,
579 (SCM table
, SCM key
),
580 "This procedure returns the @code{(key . value)} pair from the\n"
581 "hash table @var{table}. If @var{table} does not hold an\n"
582 "associated value for @var{key}, @code{#f} is returned.\n"
583 "Uses @code{eq?} for equality testing.")
584 #define FUNC_NAME s_scm_hashq_get_handle
586 return scm_hash_fn_get_handle (table
, key
, scm_ihashq
, scm_sloppy_assq
, 0);
591 SCM_DEFINE (scm_hashq_create_handle_x
, "hashq-create-handle!", 3, 0, 0,
592 (SCM table
, SCM key
, SCM init
),
593 "This function looks up @var{key} in @var{table} and returns its handle.\n"
594 "If @var{key} is not already present, a new handle is created which\n"
595 "associates @var{key} with @var{init}.")
596 #define FUNC_NAME s_scm_hashq_create_handle_x
598 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashq
, scm_sloppy_assq
, 0);
603 SCM_DEFINE (scm_hashq_ref
, "hashq-ref", 2, 1, 0,
604 (SCM table
, SCM key
, SCM dflt
),
605 "Look up @var{key} in the hash table @var{table}, and return the\n"
606 "value (if any) associated with it. If @var{key} is not found,\n"
607 "return @var{default} (or @code{#f} if no @var{default} argument\n"
608 "is supplied). Uses @code{eq?} for equality testing.")
609 #define FUNC_NAME s_scm_hashq_ref
611 if (SCM_UNBNDP (dflt
))
613 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashq
, scm_sloppy_assq
, 0);
619 SCM_DEFINE (scm_hashq_set_x
, "hashq-set!", 3, 0, 0,
620 (SCM table
, SCM key
, SCM val
),
621 "Find the entry in @var{table} associated with @var{key}, and\n"
622 "store @var{value} there. Uses @code{eq?} for equality testing.")
623 #define FUNC_NAME s_scm_hashq_set_x
625 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashq
, scm_sloppy_assq
, 0);
631 SCM_DEFINE (scm_hashq_remove_x
, "hashq-remove!", 2, 0, 0,
632 (SCM table
, SCM key
),
633 "Remove @var{key} (and any value associated with it) from\n"
634 "@var{table}. Uses @code{eq?} for equality tests.")
635 #define FUNC_NAME s_scm_hashq_remove_x
637 return scm_hash_fn_remove_x (table
, key
, scm_ihashq
, scm_sloppy_assq
, 0);
644 SCM_DEFINE (scm_hashv_get_handle
, "hashv-get-handle", 2, 0, 0,
645 (SCM table
, SCM key
),
646 "This procedure returns the @code{(key . value)} pair from the\n"
647 "hash table @var{table}. If @var{table} does not hold an\n"
648 "associated value for @var{key}, @code{#f} is returned.\n"
649 "Uses @code{eqv?} for equality testing.")
650 #define FUNC_NAME s_scm_hashv_get_handle
652 return scm_hash_fn_get_handle (table
, key
, scm_ihashv
, scm_sloppy_assv
, 0);
657 SCM_DEFINE (scm_hashv_create_handle_x
, "hashv-create-handle!", 3, 0, 0,
658 (SCM table
, SCM key
, SCM init
),
659 "This function looks up @var{key} in @var{table} and returns its handle.\n"
660 "If @var{key} is not already present, a new handle is created which\n"
661 "associates @var{key} with @var{init}.")
662 #define FUNC_NAME s_scm_hashv_create_handle_x
664 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashv
,
670 SCM_DEFINE (scm_hashv_ref
, "hashv-ref", 2, 1, 0,
671 (SCM table
, SCM key
, SCM dflt
),
672 "Look up @var{key} in the hash table @var{table}, and return the\n"
673 "value (if any) associated with it. If @var{key} is not found,\n"
674 "return @var{default} (or @code{#f} if no @var{default} argument\n"
675 "is supplied). Uses @code{eqv?} for equality testing.")
676 #define FUNC_NAME s_scm_hashv_ref
678 if (SCM_UNBNDP (dflt
))
680 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashv
, scm_sloppy_assv
, 0);
686 SCM_DEFINE (scm_hashv_set_x
, "hashv-set!", 3, 0, 0,
687 (SCM table
, SCM key
, SCM val
),
688 "Find the entry in @var{table} associated with @var{key}, and\n"
689 "store @var{value} there. Uses @code{eqv?} for equality testing.")
690 #define FUNC_NAME s_scm_hashv_set_x
692 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashv
, scm_sloppy_assv
, 0);
697 SCM_DEFINE (scm_hashv_remove_x
, "hashv-remove!", 2, 0, 0,
698 (SCM table
, SCM key
),
699 "Remove @var{key} (and any value associated with it) from\n"
700 "@var{table}. Uses @code{eqv?} for equality tests.")
701 #define FUNC_NAME s_scm_hashv_remove_x
703 return scm_hash_fn_remove_x (table
, key
, scm_ihashv
, scm_sloppy_assv
, 0);
709 SCM_DEFINE (scm_hash_get_handle
, "hash-get-handle", 2, 0, 0,
710 (SCM table
, SCM key
),
711 "This procedure returns the @code{(key . value)} pair from the\n"
712 "hash table @var{table}. If @var{table} does not hold an\n"
713 "associated value for @var{key}, @code{#f} is returned.\n"
714 "Uses @code{equal?} for equality testing.")
715 #define FUNC_NAME s_scm_hash_get_handle
717 return scm_hash_fn_get_handle (table
, key
, scm_ihash
, scm_sloppy_assoc
, 0);
722 SCM_DEFINE (scm_hash_create_handle_x
, "hash-create-handle!", 3, 0, 0,
723 (SCM table
, SCM key
, SCM init
),
724 "This function looks up @var{key} in @var{table} and returns its handle.\n"
725 "If @var{key} is not already present, a new handle is created which\n"
726 "associates @var{key} with @var{init}.")
727 #define FUNC_NAME s_scm_hash_create_handle_x
729 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihash
, scm_sloppy_assoc
, 0);
734 SCM_DEFINE (scm_hash_ref
, "hash-ref", 2, 1, 0,
735 (SCM table
, SCM key
, SCM dflt
),
736 "Look up @var{key} in the hash table @var{table}, and return the\n"
737 "value (if any) associated with it. If @var{key} is not found,\n"
738 "return @var{default} (or @code{#f} if no @var{default} argument\n"
739 "is supplied). Uses @code{equal?} for equality testing.")
740 #define FUNC_NAME s_scm_hash_ref
742 if (SCM_UNBNDP (dflt
))
744 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihash
, scm_sloppy_assoc
, 0);
750 SCM_DEFINE (scm_hash_set_x
, "hash-set!", 3, 0, 0,
751 (SCM table
, SCM key
, SCM val
),
752 "Find the entry in @var{table} associated with @var{key}, and\n"
753 "store @var{value} there. Uses @code{equal?} for equality\n"
755 #define FUNC_NAME s_scm_hash_set_x
757 return scm_hash_fn_set_x (table
, key
, val
, scm_ihash
, scm_sloppy_assoc
, 0);
763 SCM_DEFINE (scm_hash_remove_x
, "hash-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{equal?} for equality tests.")
767 #define FUNC_NAME s_scm_hash_remove_x
769 return scm_hash_fn_remove_x (table
, key
, scm_ihash
, scm_sloppy_assoc
, 0);
776 typedef struct scm_t_ihashx_closure
780 } scm_t_ihashx_closure
;
785 scm_ihashx (SCM obj
, unsigned long n
, scm_t_ihashx_closure
*closure
)
787 SCM answer
= scm_call_2 (closure
->hash
, obj
, scm_from_ulong (n
));
788 return scm_to_ulong (answer
);
794 scm_sloppy_assx (SCM obj
, SCM alist
, scm_t_ihashx_closure
*closure
)
796 return scm_call_2 (closure
->assoc
, obj
, alist
);
800 SCM_DEFINE (scm_hashx_get_handle
, "hashx-get-handle", 4, 0, 0,
801 (SCM hash
, SCM assoc
, SCM table
, SCM key
),
802 "This behaves the same way as the corresponding\n"
803 "@code{-get-handle} function, but uses @var{hash} as a hash\n"
804 "function and @var{assoc} to compare keys. @code{hash} must be\n"
805 "a function that takes two arguments, a key to be hashed and a\n"
806 "table size. @code{assoc} must be an associator function, like\n"
807 "@code{assoc}, @code{assq} or @code{assv}.")
808 #define FUNC_NAME s_scm_hashx_get_handle
810 scm_t_ihashx_closure closure
;
812 closure
.assoc
= assoc
;
813 return scm_hash_fn_get_handle (table
, key
, scm_ihashx
, scm_sloppy_assx
,
819 SCM_DEFINE (scm_hashx_create_handle_x
, "hashx-create-handle!", 5, 0, 0,
820 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM init
),
821 "This behaves the same way as the corresponding\n"
822 "@code{-create-handle} function, but uses @var{hash} as a hash\n"
823 "function and @var{assoc} to compare keys. @code{hash} must be\n"
824 "a function that takes two arguments, a key to be hashed and a\n"
825 "table size. @code{assoc} must be an associator function, like\n"
826 "@code{assoc}, @code{assq} or @code{assv}.")
827 #define FUNC_NAME s_scm_hashx_create_handle_x
829 scm_t_ihashx_closure closure
;
831 closure
.assoc
= assoc
;
832 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashx
,
833 scm_sloppy_assx
, (void *)&closure
);
839 SCM_DEFINE (scm_hashx_ref
, "hashx-ref", 4, 1, 0,
840 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM dflt
),
841 "This behaves the same way as the corresponding @code{ref}\n"
842 "function, but uses @var{hash} as a hash function and\n"
843 "@var{assoc} to compare keys. @code{hash} must be a function\n"
844 "that takes two arguments, a key to be hashed and a table size.\n"
845 "@code{assoc} must be an associator function, like @code{assoc},\n"
846 "@code{assq} or @code{assv}.\n"
848 "By way of illustration, @code{hashq-ref table key} is\n"
849 "equivalent to @code{hashx-ref hashq assq table key}.")
850 #define FUNC_NAME s_scm_hashx_ref
852 scm_t_ihashx_closure closure
;
853 if (SCM_UNBNDP (dflt
))
856 closure
.assoc
= assoc
;
857 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashx
, scm_sloppy_assx
,
865 SCM_DEFINE (scm_hashx_set_x
, "hashx-set!", 5, 0, 0,
866 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM val
),
867 "This behaves the same way as the corresponding @code{set!}\n"
868 "function, but uses @var{hash} as a hash function and\n"
869 "@var{assoc} to compare keys. @code{hash} must be a function\n"
870 "that takes two arguments, a key to be hashed and a table size.\n"
871 "@code{assoc} must be an associator function, like @code{assoc},\n"
872 "@code{assq} or @code{assv}.\n"
874 " By way of illustration, @code{hashq-set! table key} is\n"
875 "equivalent to @code{hashx-set! hashq assq table key}.")
876 #define FUNC_NAME s_scm_hashx_set_x
878 scm_t_ihashx_closure closure
;
880 closure
.assoc
= assoc
;
881 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashx
, scm_sloppy_assx
,
886 SCM_DEFINE (scm_hashx_remove_x
, "hashx-remove!", 4, 0, 0,
887 (SCM hash
, SCM assoc
, SCM table
, SCM obj
),
888 "This behaves the same way as the corresponding @code{remove!}\n"
889 "function, but uses @var{hash} as a hash function and\n"
890 "@var{assoc} to compare keys. @code{hash} must be a function\n"
891 "that takes two arguments, a key to be hashed and a table size.\n"
892 "@code{assoc} must be an associator function, like @code{assoc},\n"
893 "@code{assq} or @code{assv}.\n"
895 " By way of illustration, @code{hashq-remove! table key} is\n"
896 "equivalent to @code{hashx-remove! hashq assq #f table key}.")
897 #define FUNC_NAME s_scm_hashx_remove_x
899 scm_t_ihashx_closure closure
;
901 closure
.assoc
= assoc
;
902 return scm_hash_fn_remove_x (table
, obj
, scm_ihashx
, scm_sloppy_assx
,
907 /* Hash table iterators */
909 static const char s_scm_hash_fold
[];
912 scm_internal_hash_fold (SCM (*fn
) (), void *closure
, SCM init
, SCM table
)
915 SCM buckets
, result
= init
;
917 if (SCM_HASHTABLE_P (table
))
918 buckets
= SCM_HASHTABLE_VECTOR (table
);
922 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
923 for (i
= 0; i
< n
; ++i
)
925 SCM ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
), handle
;
926 while (!scm_is_null (ls
))
928 if (!scm_is_pair (ls
))
929 scm_wrong_type_arg (s_scm_hash_fold
, SCM_ARG3
, buckets
);
930 handle
= SCM_CAR (ls
);
931 if (!scm_is_pair (handle
))
932 scm_wrong_type_arg (s_scm_hash_fold
, SCM_ARG3
, buckets
);
933 result
= fn (closure
, SCM_CAR (handle
), SCM_CDR (handle
), result
);
941 /* The following redundant code is here in order to be able to support
942 hash-for-each-handle. An alternative would have been to replace
943 this code and scm_internal_hash_fold above with a single
944 scm_internal_hash_fold_handles, but we don't want to promote such
947 static const char s_scm_hash_for_each
[];
950 scm_internal_hash_for_each_handle (SCM (*fn
) (), void *closure
, SCM table
)
955 if (SCM_HASHTABLE_P (table
))
956 buckets
= SCM_HASHTABLE_VECTOR (table
);
960 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
961 for (i
= 0; i
< n
; ++i
)
963 SCM ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
), handle
;
964 while (!scm_is_null (ls
))
966 if (!scm_is_pair (ls
))
967 scm_wrong_type_arg (s_scm_hash_for_each
, SCM_ARG3
, buckets
);
968 handle
= SCM_CAR (ls
);
969 if (!scm_is_pair (handle
))
970 scm_wrong_type_arg (s_scm_hash_for_each
, SCM_ARG3
, buckets
);
971 fn (closure
, handle
);
977 SCM_DEFINE (scm_hash_fold
, "hash-fold", 3, 0, 0,
978 (SCM proc
, SCM init
, SCM table
),
979 "An iterator over hash-table elements.\n"
980 "Accumulates and returns a result by applying PROC successively.\n"
981 "The arguments to PROC are \"(key value prior-result)\" where key\n"
982 "and value are successive pairs from the hash table TABLE, and\n"
983 "prior-result is either INIT (for the first application of PROC)\n"
984 "or the return value of the previous application of PROC.\n"
985 "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
986 "table into an a-list of key-value pairs.")
987 #define FUNC_NAME s_scm_hash_fold
989 SCM_VALIDATE_PROC (1, proc
);
990 if (!SCM_HASHTABLE_P (table
))
991 SCM_VALIDATE_VECTOR (3, table
);
992 return scm_internal_hash_fold (scm_call_3
, (void *) SCM_UNPACK (proc
), init
, table
);
997 for_each_proc (void *proc
, SCM handle
)
999 return scm_call_2 (SCM_PACK (proc
), SCM_CAR (handle
), SCM_CDR (handle
));
1002 SCM_DEFINE (scm_hash_for_each
, "hash-for-each", 2, 0, 0,
1003 (SCM proc
, SCM table
),
1004 "An iterator over hash-table elements.\n"
1005 "Applies PROC successively on all hash table items.\n"
1006 "The arguments to PROC are \"(key value)\" where key\n"
1007 "and value are successive pairs from the hash table TABLE.")
1008 #define FUNC_NAME s_scm_hash_for_each
1010 SCM_VALIDATE_PROC (1, proc
);
1011 if (!SCM_HASHTABLE_P (table
))
1012 SCM_VALIDATE_VECTOR (2, table
);
1014 scm_internal_hash_for_each_handle (for_each_proc
,
1015 (void *) SCM_UNPACK (proc
),
1017 return SCM_UNSPECIFIED
;
1021 SCM_DEFINE (scm_hash_for_each_handle
, "hash-for-each-handle", 2, 0, 0,
1022 (SCM proc
, SCM table
),
1023 "An iterator over hash-table elements.\n"
1024 "Applies PROC successively on all hash table handles.")
1025 #define FUNC_NAME s_scm_hash_for_each_handle
1027 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
1028 SCM_ASSERT (call
, proc
, 1, FUNC_NAME
);
1029 if (!SCM_HASHTABLE_P (table
))
1030 SCM_VALIDATE_VECTOR (2, table
);
1032 scm_internal_hash_for_each_handle (call
,
1033 (void *) SCM_UNPACK (proc
),
1035 return SCM_UNSPECIFIED
;
1040 map_proc (void *proc
, SCM key
, SCM data
, SCM value
)
1042 return scm_cons (scm_call_2 (SCM_PACK (proc
), key
, data
), value
);
1045 SCM_DEFINE (scm_hash_map_to_list
, "hash-map->list", 2, 0, 0,
1046 (SCM proc
, SCM table
),
1047 "An iterator over hash-table elements.\n"
1048 "Accumulates and returns as a list the results of applying PROC successively.\n"
1049 "The arguments to PROC are \"(key value)\" where key\n"
1050 "and value are successive pairs from the hash table TABLE.")
1051 #define FUNC_NAME s_scm_hash_map_to_list
1053 SCM_VALIDATE_PROC (1, proc
);
1054 if (!SCM_HASHTABLE_P (table
))
1055 SCM_VALIDATE_VECTOR (2, table
);
1056 return scm_internal_hash_fold (map_proc
,
1057 (void *) SCM_UNPACK (proc
),
1067 scm_hashtab_prehistory ()
1069 scm_tc16_hashtable
= scm_make_smob_type (s_hashtable
, 0);
1070 scm_set_smob_mark (scm_tc16_hashtable
, scm_markcdr
);
1071 scm_set_smob_print (scm_tc16_hashtable
, hashtable_print
);
1072 scm_set_smob_free (scm_tc16_hashtable
, hashtable_free
);
1073 scm_c_hook_add (&scm_after_gc_c_hook
, rehash_after_gc
, 0, 0);
1079 #include "libguile/hashtab.x"