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
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_pair (it
))
459 else if (scm_is_true (it
))
460 scm_wrong_type_arg_msg (NULL
, 0, it
, "a pair");
463 /* When this is a weak hashtable, running the GC can change it.
464 Thus, we must allocate the new cells first and can only then
465 access BUCKETS. Also, we need to fetch the bucket vector
466 again since the hashtable might have been rehashed. This
467 necessitates a new hash value as well.
469 SCM new_bucket
= scm_acons (obj
, init
, SCM_EOL
);
470 if (!scm_is_eq (table
, buckets
)
471 && !scm_is_eq (SCM_HASHTABLE_VECTOR (table
), buckets
))
473 buckets
= SCM_HASHTABLE_VECTOR (table
);
474 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
475 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
476 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
478 SCM_SETCDR (new_bucket
, SCM_SIMPLE_VECTOR_REF (buckets
, k
));
479 SCM_SIMPLE_VECTOR_SET (buckets
, k
, new_bucket
);
480 if (!scm_is_eq (table
, buckets
))
482 /* Update element count and maybe rehash the table. The
483 table might have too few entries here since weak hash
484 tables used with the hashx_* functions can not be
487 SCM_HASHTABLE_INCREMENT (table
);
488 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
)
489 || SCM_HASHTABLE_N_ITEMS (table
) > SCM_HASHTABLE_UPPER (table
))
490 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
492 return SCM_CAR (new_bucket
);
499 scm_hash_fn_ref (SCM table
, SCM obj
, SCM dflt
, unsigned long (*hash_fn
)(),
500 SCM (*assoc_fn
)(), void * closure
)
502 SCM it
= scm_hash_fn_get_handle (table
, obj
, hash_fn
, assoc_fn
, closure
);
503 if (scm_is_pair (it
))
513 scm_hash_fn_set_x (SCM table
, SCM obj
, SCM val
, unsigned long (*hash_fn
)(),
514 SCM (*assoc_fn
)(), void * closure
)
518 it
= scm_hash_fn_create_handle_x (table
, obj
, SCM_BOOL_F
, hash_fn
, assoc_fn
, closure
);
519 SCM_SETCDR (it
, val
);
525 scm_hash_fn_remove_x (SCM table
, SCM obj
,
526 unsigned long (*hash_fn
)(),
533 if (SCM_HASHTABLE_P (table
))
534 buckets
= SCM_HASHTABLE_VECTOR (table
);
537 SCM_ASSERT (scm_is_simple_vector (table
), table
,
538 SCM_ARG1
, "hash_fn_remove_x");
541 if (SCM_SIMPLE_VECTOR_LENGTH (table
) == 0)
544 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
545 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
546 scm_out_of_range ("hash_fn_remove_x", scm_from_ulong (k
));
547 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
550 SCM_SIMPLE_VECTOR_SET
551 (buckets
, k
, scm_delq_x (h
, SCM_SIMPLE_VECTOR_REF (buckets
, k
)));
552 if (!scm_is_eq (table
, buckets
))
554 SCM_HASHTABLE_DECREMENT (table
);
555 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
556 scm_i_rehash (table
, hash_fn
, closure
, "scm_hash_fn_remove_x");
562 SCM_DEFINE (scm_hash_clear_x
, "hash-clear!", 1, 0, 0,
564 "Remove all items from @var{table} (without triggering a resize).")
565 #define FUNC_NAME s_scm_hash_clear_x
567 if (SCM_HASHTABLE_P (table
))
569 scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table
), SCM_EOL
);
570 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
573 scm_vector_fill_x (table
, SCM_EOL
);
574 return SCM_UNSPECIFIED
;
580 SCM_DEFINE (scm_hashq_get_handle
, "hashq-get-handle", 2, 0, 0,
581 (SCM table
, SCM key
),
582 "This procedure returns the @code{(key . value)} pair from the\n"
583 "hash table @var{table}. If @var{table} does not hold an\n"
584 "associated value for @var{key}, @code{#f} is returned.\n"
585 "Uses @code{eq?} for equality testing.")
586 #define FUNC_NAME s_scm_hashq_get_handle
588 return scm_hash_fn_get_handle (table
, key
, scm_ihashq
, scm_sloppy_assq
, 0);
593 SCM_DEFINE (scm_hashq_create_handle_x
, "hashq-create-handle!", 3, 0, 0,
594 (SCM table
, SCM key
, SCM init
),
595 "This function looks up @var{key} in @var{table} and returns its handle.\n"
596 "If @var{key} is not already present, a new handle is created which\n"
597 "associates @var{key} with @var{init}.")
598 #define FUNC_NAME s_scm_hashq_create_handle_x
600 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashq
, scm_sloppy_assq
, 0);
605 SCM_DEFINE (scm_hashq_ref
, "hashq-ref", 2, 1, 0,
606 (SCM table
, SCM key
, SCM dflt
),
607 "Look up @var{key} in the hash table @var{table}, and return the\n"
608 "value (if any) associated with it. If @var{key} is not found,\n"
609 "return @var{default} (or @code{#f} if no @var{default} argument\n"
610 "is supplied). Uses @code{eq?} for equality testing.")
611 #define FUNC_NAME s_scm_hashq_ref
613 if (SCM_UNBNDP (dflt
))
615 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashq
, scm_sloppy_assq
, 0);
621 SCM_DEFINE (scm_hashq_set_x
, "hashq-set!", 3, 0, 0,
622 (SCM table
, SCM key
, SCM val
),
623 "Find the entry in @var{table} associated with @var{key}, and\n"
624 "store @var{value} there. Uses @code{eq?} for equality testing.")
625 #define FUNC_NAME s_scm_hashq_set_x
627 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashq
, scm_sloppy_assq
, 0);
633 SCM_DEFINE (scm_hashq_remove_x
, "hashq-remove!", 2, 0, 0,
634 (SCM table
, SCM key
),
635 "Remove @var{key} (and any value associated with it) from\n"
636 "@var{table}. Uses @code{eq?} for equality tests.")
637 #define FUNC_NAME s_scm_hashq_remove_x
639 return scm_hash_fn_remove_x (table
, key
, scm_ihashq
, scm_sloppy_assq
, 0);
646 SCM_DEFINE (scm_hashv_get_handle
, "hashv-get-handle", 2, 0, 0,
647 (SCM table
, SCM key
),
648 "This procedure returns the @code{(key . value)} pair from the\n"
649 "hash table @var{table}. If @var{table} does not hold an\n"
650 "associated value for @var{key}, @code{#f} is returned.\n"
651 "Uses @code{eqv?} for equality testing.")
652 #define FUNC_NAME s_scm_hashv_get_handle
654 return scm_hash_fn_get_handle (table
, key
, scm_ihashv
, scm_sloppy_assv
, 0);
659 SCM_DEFINE (scm_hashv_create_handle_x
, "hashv-create-handle!", 3, 0, 0,
660 (SCM table
, SCM key
, SCM init
),
661 "This function looks up @var{key} in @var{table} and returns its handle.\n"
662 "If @var{key} is not already present, a new handle is created which\n"
663 "associates @var{key} with @var{init}.")
664 #define FUNC_NAME s_scm_hashv_create_handle_x
666 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashv
,
672 SCM_DEFINE (scm_hashv_ref
, "hashv-ref", 2, 1, 0,
673 (SCM table
, SCM key
, SCM dflt
),
674 "Look up @var{key} in the hash table @var{table}, and return the\n"
675 "value (if any) associated with it. If @var{key} is not found,\n"
676 "return @var{default} (or @code{#f} if no @var{default} argument\n"
677 "is supplied). Uses @code{eqv?} for equality testing.")
678 #define FUNC_NAME s_scm_hashv_ref
680 if (SCM_UNBNDP (dflt
))
682 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashv
, scm_sloppy_assv
, 0);
688 SCM_DEFINE (scm_hashv_set_x
, "hashv-set!", 3, 0, 0,
689 (SCM table
, SCM key
, SCM val
),
690 "Find the entry in @var{table} associated with @var{key}, and\n"
691 "store @var{value} there. Uses @code{eqv?} for equality testing.")
692 #define FUNC_NAME s_scm_hashv_set_x
694 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashv
, scm_sloppy_assv
, 0);
699 SCM_DEFINE (scm_hashv_remove_x
, "hashv-remove!", 2, 0, 0,
700 (SCM table
, SCM key
),
701 "Remove @var{key} (and any value associated with it) from\n"
702 "@var{table}. Uses @code{eqv?} for equality tests.")
703 #define FUNC_NAME s_scm_hashv_remove_x
705 return scm_hash_fn_remove_x (table
, key
, scm_ihashv
, scm_sloppy_assv
, 0);
711 SCM_DEFINE (scm_hash_get_handle
, "hash-get-handle", 2, 0, 0,
712 (SCM table
, SCM key
),
713 "This procedure returns the @code{(key . value)} pair from the\n"
714 "hash table @var{table}. If @var{table} does not hold an\n"
715 "associated value for @var{key}, @code{#f} is returned.\n"
716 "Uses @code{equal?} for equality testing.")
717 #define FUNC_NAME s_scm_hash_get_handle
719 return scm_hash_fn_get_handle (table
, key
, scm_ihash
, scm_sloppy_assoc
, 0);
724 SCM_DEFINE (scm_hash_create_handle_x
, "hash-create-handle!", 3, 0, 0,
725 (SCM table
, SCM key
, SCM init
),
726 "This function looks up @var{key} in @var{table} and returns its handle.\n"
727 "If @var{key} is not already present, a new handle is created which\n"
728 "associates @var{key} with @var{init}.")
729 #define FUNC_NAME s_scm_hash_create_handle_x
731 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihash
, scm_sloppy_assoc
, 0);
736 SCM_DEFINE (scm_hash_ref
, "hash-ref", 2, 1, 0,
737 (SCM table
, SCM key
, SCM dflt
),
738 "Look up @var{key} in the hash table @var{table}, and return the\n"
739 "value (if any) associated with it. If @var{key} is not found,\n"
740 "return @var{default} (or @code{#f} if no @var{default} argument\n"
741 "is supplied). Uses @code{equal?} for equality testing.")
742 #define FUNC_NAME s_scm_hash_ref
744 if (SCM_UNBNDP (dflt
))
746 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihash
, scm_sloppy_assoc
, 0);
752 SCM_DEFINE (scm_hash_set_x
, "hash-set!", 3, 0, 0,
753 (SCM table
, SCM key
, SCM val
),
754 "Find the entry in @var{table} associated with @var{key}, and\n"
755 "store @var{value} there. Uses @code{equal?} for equality\n"
757 #define FUNC_NAME s_scm_hash_set_x
759 return scm_hash_fn_set_x (table
, key
, val
, scm_ihash
, scm_sloppy_assoc
, 0);
765 SCM_DEFINE (scm_hash_remove_x
, "hash-remove!", 2, 0, 0,
766 (SCM table
, SCM key
),
767 "Remove @var{key} (and any value associated with it) from\n"
768 "@var{table}. Uses @code{equal?} for equality tests.")
769 #define FUNC_NAME s_scm_hash_remove_x
771 return scm_hash_fn_remove_x (table
, key
, scm_ihash
, scm_sloppy_assoc
, 0);
778 typedef struct scm_t_ihashx_closure
782 } scm_t_ihashx_closure
;
787 scm_ihashx (SCM obj
, unsigned long n
, scm_t_ihashx_closure
*closure
)
789 SCM answer
= scm_call_2 (closure
->hash
, obj
, scm_from_ulong (n
));
790 return scm_to_ulong (answer
);
796 scm_sloppy_assx (SCM obj
, SCM alist
, scm_t_ihashx_closure
*closure
)
798 return scm_call_2 (closure
->assoc
, obj
, alist
);
802 SCM_DEFINE (scm_hashx_get_handle
, "hashx-get-handle", 4, 0, 0,
803 (SCM hash
, SCM assoc
, SCM table
, SCM key
),
804 "This behaves the same way as the corresponding\n"
805 "@code{-get-handle} function, but uses @var{hash} as a hash\n"
806 "function and @var{assoc} to compare keys. @code{hash} must be\n"
807 "a function that takes two arguments, a key to be hashed and a\n"
808 "table size. @code{assoc} must be an associator function, like\n"
809 "@code{assoc}, @code{assq} or @code{assv}.")
810 #define FUNC_NAME s_scm_hashx_get_handle
812 scm_t_ihashx_closure closure
;
814 closure
.assoc
= assoc
;
815 return scm_hash_fn_get_handle (table
, key
, scm_ihashx
, scm_sloppy_assx
,
821 SCM_DEFINE (scm_hashx_create_handle_x
, "hashx-create-handle!", 5, 0, 0,
822 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM init
),
823 "This behaves the same way as the corresponding\n"
824 "@code{-create-handle} function, but uses @var{hash} as a hash\n"
825 "function and @var{assoc} to compare keys. @code{hash} must be\n"
826 "a function that takes two arguments, a key to be hashed and a\n"
827 "table size. @code{assoc} must be an associator function, like\n"
828 "@code{assoc}, @code{assq} or @code{assv}.")
829 #define FUNC_NAME s_scm_hashx_create_handle_x
831 scm_t_ihashx_closure closure
;
833 closure
.assoc
= assoc
;
834 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashx
,
835 scm_sloppy_assx
, (void *)&closure
);
841 SCM_DEFINE (scm_hashx_ref
, "hashx-ref", 4, 1, 0,
842 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM dflt
),
843 "This behaves the same way as the corresponding @code{ref}\n"
844 "function, but uses @var{hash} as a hash function and\n"
845 "@var{assoc} to compare keys. @code{hash} must be a function\n"
846 "that takes two arguments, a key to be hashed and a table size.\n"
847 "@code{assoc} must be an associator function, like @code{assoc},\n"
848 "@code{assq} or @code{assv}.\n"
850 "By way of illustration, @code{hashq-ref table key} is\n"
851 "equivalent to @code{hashx-ref hashq assq table key}.")
852 #define FUNC_NAME s_scm_hashx_ref
854 scm_t_ihashx_closure closure
;
855 if (SCM_UNBNDP (dflt
))
858 closure
.assoc
= assoc
;
859 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashx
, scm_sloppy_assx
,
867 SCM_DEFINE (scm_hashx_set_x
, "hashx-set!", 5, 0, 0,
868 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM val
),
869 "This behaves the same way as the corresponding @code{set!}\n"
870 "function, but uses @var{hash} as a hash function and\n"
871 "@var{assoc} to compare keys. @code{hash} must be a function\n"
872 "that takes two arguments, a key to be hashed and a table size.\n"
873 "@code{assoc} must be an associator function, like @code{assoc},\n"
874 "@code{assq} or @code{assv}.\n"
876 " By way of illustration, @code{hashq-set! table key} is\n"
877 "equivalent to @code{hashx-set! hashq assq table key}.")
878 #define FUNC_NAME s_scm_hashx_set_x
880 scm_t_ihashx_closure closure
;
882 closure
.assoc
= assoc
;
883 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashx
, scm_sloppy_assx
,
888 SCM_DEFINE (scm_hashx_remove_x
, "hashx-remove!", 4, 0, 0,
889 (SCM hash
, SCM assoc
, SCM table
, SCM obj
),
890 "This behaves the same way as the corresponding @code{remove!}\n"
891 "function, but uses @var{hash} as a hash function and\n"
892 "@var{assoc} to compare keys. @code{hash} must be a function\n"
893 "that takes two arguments, a key to be hashed and a table size.\n"
894 "@code{assoc} must be an associator function, like @code{assoc},\n"
895 "@code{assq} or @code{assv}.\n"
897 " By way of illustration, @code{hashq-remove! table key} is\n"
898 "equivalent to @code{hashx-remove! hashq assq #f table key}.")
899 #define FUNC_NAME s_scm_hashx_remove_x
901 scm_t_ihashx_closure closure
;
903 closure
.assoc
= assoc
;
904 return scm_hash_fn_remove_x (table
, obj
, scm_ihashx
, scm_sloppy_assx
,
909 /* Hash table iterators */
911 static const char s_scm_hash_fold
[];
914 scm_internal_hash_fold (SCM (*fn
) (), void *closure
, SCM init
, SCM table
)
917 SCM buckets
, result
= init
;
919 if (SCM_HASHTABLE_P (table
))
920 buckets
= SCM_HASHTABLE_VECTOR (table
);
924 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
925 for (i
= 0; i
< n
; ++i
)
927 SCM ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
), handle
;
928 while (!scm_is_null (ls
))
930 if (!scm_is_pair (ls
))
931 scm_wrong_type_arg (s_scm_hash_fold
, SCM_ARG3
, buckets
);
932 handle
= SCM_CAR (ls
);
933 if (!scm_is_pair (handle
))
934 scm_wrong_type_arg (s_scm_hash_fold
, SCM_ARG3
, buckets
);
935 result
= fn (closure
, SCM_CAR (handle
), SCM_CDR (handle
), result
);
943 /* The following redundant code is here in order to be able to support
944 hash-for-each-handle. An alternative would have been to replace
945 this code and scm_internal_hash_fold above with a single
946 scm_internal_hash_fold_handles, but we don't want to promote such
949 static const char s_scm_hash_for_each
[];
952 scm_internal_hash_for_each_handle (SCM (*fn
) (), void *closure
, SCM table
)
957 if (SCM_HASHTABLE_P (table
))
958 buckets
= SCM_HASHTABLE_VECTOR (table
);
962 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
963 for (i
= 0; i
< n
; ++i
)
965 SCM ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
), handle
;
966 while (!scm_is_null (ls
))
968 if (!scm_is_pair (ls
))
969 scm_wrong_type_arg (s_scm_hash_for_each
, SCM_ARG3
, buckets
);
970 handle
= SCM_CAR (ls
);
971 if (!scm_is_pair (handle
))
972 scm_wrong_type_arg (s_scm_hash_for_each
, SCM_ARG3
, buckets
);
973 fn (closure
, handle
);
979 SCM_DEFINE (scm_hash_fold
, "hash-fold", 3, 0, 0,
980 (SCM proc
, SCM init
, SCM table
),
981 "An iterator over hash-table elements.\n"
982 "Accumulates and returns a result by applying PROC successively.\n"
983 "The arguments to PROC are \"(key value prior-result)\" where key\n"
984 "and value are successive pairs from the hash table TABLE, and\n"
985 "prior-result is either INIT (for the first application of PROC)\n"
986 "or the return value of the previous application of PROC.\n"
987 "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
988 "table into an a-list of key-value pairs.")
989 #define FUNC_NAME s_scm_hash_fold
991 SCM_VALIDATE_PROC (1, proc
);
992 if (!SCM_HASHTABLE_P (table
))
993 SCM_VALIDATE_VECTOR (3, table
);
994 return scm_internal_hash_fold (scm_call_3
, (void *) SCM_UNPACK (proc
), init
, table
);
999 for_each_proc (void *proc
, SCM handle
)
1001 return scm_call_2 (SCM_PACK (proc
), SCM_CAR (handle
), SCM_CDR (handle
));
1004 SCM_DEFINE (scm_hash_for_each
, "hash-for-each", 2, 0, 0,
1005 (SCM proc
, SCM table
),
1006 "An iterator over hash-table elements.\n"
1007 "Applies PROC successively on all hash table items.\n"
1008 "The arguments to PROC are \"(key value)\" where key\n"
1009 "and value are successive pairs from the hash table TABLE.")
1010 #define FUNC_NAME s_scm_hash_for_each
1012 SCM_VALIDATE_PROC (1, proc
);
1013 if (!SCM_HASHTABLE_P (table
))
1014 SCM_VALIDATE_VECTOR (2, table
);
1016 scm_internal_hash_for_each_handle (for_each_proc
,
1017 (void *) SCM_UNPACK (proc
),
1019 return SCM_UNSPECIFIED
;
1023 SCM_DEFINE (scm_hash_for_each_handle
, "hash-for-each-handle", 2, 0, 0,
1024 (SCM proc
, SCM table
),
1025 "An iterator over hash-table elements.\n"
1026 "Applies PROC successively on all hash table handles.")
1027 #define FUNC_NAME s_scm_hash_for_each_handle
1029 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
1030 SCM_ASSERT (call
, proc
, 1, FUNC_NAME
);
1031 if (!SCM_HASHTABLE_P (table
))
1032 SCM_VALIDATE_VECTOR (2, table
);
1034 scm_internal_hash_for_each_handle (call
,
1035 (void *) SCM_UNPACK (proc
),
1037 return SCM_UNSPECIFIED
;
1042 map_proc (void *proc
, SCM key
, SCM data
, SCM value
)
1044 return scm_cons (scm_call_2 (SCM_PACK (proc
), key
, data
), value
);
1047 SCM_DEFINE (scm_hash_map_to_list
, "hash-map->list", 2, 0, 0,
1048 (SCM proc
, SCM table
),
1049 "An iterator over hash-table elements.\n"
1050 "Accumulates and returns as a list the results of applying PROC successively.\n"
1051 "The arguments to PROC are \"(key value)\" where key\n"
1052 "and value are successive pairs from the hash table TABLE.")
1053 #define FUNC_NAME s_scm_hash_map_to_list
1055 SCM_VALIDATE_PROC (1, proc
);
1056 if (!SCM_HASHTABLE_P (table
))
1057 SCM_VALIDATE_VECTOR (2, table
);
1058 return scm_internal_hash_fold (map_proc
,
1059 (void *) SCM_UNPACK (proc
),
1069 scm_hashtab_prehistory ()
1071 scm_tc16_hashtable
= scm_make_smob_type (s_hashtable
, 0);
1072 scm_set_smob_mark (scm_tc16_hashtable
, scm_markcdr
);
1073 scm_set_smob_print (scm_tc16_hashtable
, hashtable_print
);
1074 scm_set_smob_free (scm_tc16_hashtable
, hashtable_free
);
1075 scm_c_hook_add (&scm_after_gc_c_hook
, rehash_after_gc
, 0, 0);
1081 #include "libguile/hashtab.x"