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
26 #include "libguile/_scm.h"
27 #include "libguile/alist.h"
28 #include "libguile/hash.h"
29 #include "libguile/eval.h"
30 #include "libguile/root.h"
31 #include "libguile/vectors.h"
32 #include "libguile/ports.h"
34 #include "libguile/validate.h"
35 #include "libguile/hashtab.h"
40 * 1. The current hash table implementation uses weak alist vectors
41 * (implementation in weaks.c) internally, but we do the scanning
42 * ourselves (in scan_weak_hashtables) because we need to update the
43 * hash table structure when items are dropped during GC.
45 * 2. All hash table operations still work on alist vectors.
49 /* Hash tables are either vectors of association lists or smobs
50 * containing such vectors. Currently, the vector version represents
51 * constant size tables while those wrapped in a smob represents
54 * Growing or shrinking, with following rehashing, is triggered when
57 * L = N / S (N: number of items in table, S: bucket vector length)
59 * passes an upper limit of 0.9 or a lower limit of 0.25.
61 * The implementation stores the upper and lower number of items which
62 * trigger a resize in the hashtable object.
64 * Possible hash table sizes (primes) are stored in the array
68 scm_t_bits scm_tc16_hashtable
;
70 static unsigned long hashtable_size
[] = {
71 31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363,
72 224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041
74 /* vectors are currently restricted to 2^24-1 = 16777215 elements. */
75 28762081, 57524111, 115048217, 230096423, 460192829
76 /* larger values can't be represented as INUMs */
80 #define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long))
82 static char *s_hashtable
= "hashtable";
84 SCM weak_hashtables
= SCM_EOL
;
87 make_hash_table (int flags
, unsigned long k
, const char *func_name
)
91 int i
= 0, n
= k
? k
: 31;
92 while (i
< HASHTABLE_SIZE_N
&& n
> hashtable_size
[i
])
94 n
= hashtable_size
[i
];
96 vector
= scm_i_allocate_weak_vector (flags
, scm_from_int (n
), SCM_EOL
);
98 vector
= scm_c_make_vector (n
, SCM_EOL
);
99 t
= scm_gc_malloc (sizeof (*t
), s_hashtable
);
100 t
->min_size_index
= t
->size_index
= i
;
103 t
->upper
= 9 * n
/ 10;
108 SCM_NEWSMOB3 (table
, scm_tc16_hashtable
, vector
, t
, weak_hashtables
);
109 weak_hashtables
= table
;
112 SCM_NEWSMOB3 (table
, scm_tc16_hashtable
, vector
, t
, SCM_EOL
);
117 scm_i_rehash (SCM table
,
118 unsigned long (*hash_fn
)(),
120 const char* func_name
)
122 SCM buckets
, new_buckets
;
124 unsigned long old_size
;
125 unsigned long new_size
;
127 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
129 /* rehashing is not triggered when i <= min_size */
130 i
= SCM_HASHTABLE (table
)->size_index
;
133 while (i
> SCM_HASHTABLE (table
)->min_size_index
134 && SCM_HASHTABLE_N_ITEMS (table
) < hashtable_size
[i
] / 4);
138 i
= SCM_HASHTABLE (table
)->size_index
+ 1;
139 if (i
>= HASHTABLE_SIZE_N
)
143 /* Remember HASH_FN for rehash_after_gc, but only when CLOSURE
144 is not needed since CLOSURE can not be guaranteed to be valid
145 after this function returns.
148 SCM_HASHTABLE (table
)->hash_fn
= hash_fn
;
150 SCM_HASHTABLE (table
)->size_index
= i
;
152 new_size
= hashtable_size
[i
];
153 if (i
<= SCM_HASHTABLE (table
)->min_size_index
)
154 SCM_HASHTABLE (table
)->lower
= 0;
156 SCM_HASHTABLE (table
)->lower
= new_size
/ 4;
157 SCM_HASHTABLE (table
)->upper
= 9 * new_size
/ 10;
158 buckets
= SCM_HASHTABLE_VECTOR (table
);
160 if (SCM_HASHTABLE_WEAK_P (table
))
161 new_buckets
= scm_i_allocate_weak_vector (SCM_HASHTABLE_FLAGS (table
),
162 scm_from_ulong (new_size
),
165 new_buckets
= scm_c_make_vector (new_size
, SCM_EOL
);
167 /* When this is a weak hashtable, running the GC might change it.
168 We need to cope with this while rehashing its elements. We do
169 this by first installing the new, empty bucket vector. Then we
170 remove the elements from the old bucket vector and insert them
174 SCM_SET_HASHTABLE_VECTOR (table
, new_buckets
);
175 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
177 old_size
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
178 for (i
= 0; i
< old_size
; ++i
)
180 SCM ls
, cell
, handle
;
182 ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
);
183 SCM_SIMPLE_VECTOR_SET (buckets
, i
, SCM_EOL
);
185 while (scm_is_pair (ls
))
189 handle
= SCM_CAR (cell
);
191 h
= hash_fn (SCM_CAR (handle
), new_size
, closure
);
193 scm_out_of_range (func_name
, scm_from_ulong (h
));
194 SCM_SETCDR (cell
, SCM_SIMPLE_VECTOR_REF (new_buckets
, h
));
195 SCM_SIMPLE_VECTOR_SET (new_buckets
, h
, cell
);
196 SCM_HASHTABLE_INCREMENT (table
);
203 hashtable_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
205 scm_puts ("#<", port
);
206 if (SCM_HASHTABLE_WEAK_KEY_P (exp
))
207 scm_puts ("weak-key-", port
);
208 else if (SCM_HASHTABLE_WEAK_VALUE_P (exp
))
209 scm_puts ("weak-value-", port
);
210 else if (SCM_HASHTABLE_DOUBLY_WEAK_P (exp
))
211 scm_puts ("doubly-weak-", port
);
212 scm_puts ("hash-table ", port
);
213 scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp
), 10, port
);
214 scm_putc ('/', port
);
215 scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp
)),
217 scm_puts (">", port
);
221 /* keep track of hash tables that need to shrink after scan */
222 static SCM to_rehash
= SCM_EOL
;
224 /* scan hash tables and update hash tables item count */
226 scm_i_scan_weak_hashtables ()
228 SCM
*next
= &weak_hashtables
;
230 while (!scm_is_null (h
))
232 if (!SCM_GC_MARK_P (h
))
233 *next
= h
= SCM_HASHTABLE_NEXT (h
);
236 SCM vec
= SCM_HASHTABLE_VECTOR (h
);
237 size_t delta
= SCM_I_WVECT_DELTA (vec
);
238 SCM_I_SET_WVECT_DELTA (vec
, 0);
239 SCM_SET_HASHTABLE_N_ITEMS (h
, SCM_HASHTABLE_N_ITEMS (h
) - delta
);
241 if (SCM_HASHTABLE_N_ITEMS (h
) < SCM_HASHTABLE_LOWER (h
))
243 SCM tmp
= SCM_HASHTABLE_NEXT (h
);
244 /* temporarily move table from weak_hashtables to to_rehash */
245 SCM_SET_HASHTABLE_NEXT (h
, to_rehash
);
251 next
= SCM_HASHTABLE_NEXTLOC (h
);
252 h
= SCM_HASHTABLE_NEXT (h
);
259 rehash_after_gc (void *dummy1 SCM_UNUSED
,
260 void *dummy2 SCM_UNUSED
,
261 void *dummy3 SCM_UNUSED
)
263 if (!scm_is_null (to_rehash
))
265 SCM first
= to_rehash
, last
, h
;
266 /* important to clear to_rehash here so that we don't get stuck
267 in an infinite loop if scm_i_rehash causes GC */
272 /* Rehash only when we have a hash_fn.
274 if (SCM_HASHTABLE (h
)->hash_fn
)
275 scm_i_rehash (h
, SCM_HASHTABLE (h
)->hash_fn
, NULL
,
278 h
= SCM_HASHTABLE_NEXT (h
);
279 } while (!scm_is_null (h
));
280 /* move tables back to weak_hashtables */
281 SCM_SET_HASHTABLE_NEXT (last
, weak_hashtables
);
282 weak_hashtables
= first
;
288 hashtable_free (SCM obj
)
290 scm_gc_free (SCM_HASHTABLE (obj
), sizeof (scm_t_hashtable
), s_hashtable
);
296 scm_c_make_hash_table (unsigned long k
)
298 return make_hash_table (0, k
, "scm_c_make_hash_table");
301 SCM_DEFINE (scm_make_hash_table
, "make-hash-table", 0, 1, 0,
303 "Make a new abstract hash table object with minimum number of buckets @var{n}\n")
304 #define FUNC_NAME s_scm_make_hash_table
307 return make_hash_table (0, 0, FUNC_NAME
);
309 return make_hash_table (0, scm_to_ulong (n
), FUNC_NAME
);
313 SCM_DEFINE (scm_make_weak_key_hash_table
, "make-weak-key-hash-table", 0, 1, 0,
315 "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
316 "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n"
317 "Return a weak hash table with @var{size} buckets.\n"
319 "You can modify weak hash tables in exactly the same way you\n"
320 "would modify regular hash tables. (@pxref{Hash Tables})")
321 #define FUNC_NAME s_scm_make_weak_key_hash_table
324 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
, 0, FUNC_NAME
);
326 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
,
327 scm_to_ulong (n
), FUNC_NAME
);
332 SCM_DEFINE (scm_make_weak_value_hash_table
, "make-weak-value-hash-table", 0, 1, 0,
334 "Return a hash table with weak values with @var{size} buckets.\n"
335 "(@pxref{Hash Tables})")
336 #define FUNC_NAME s_scm_make_weak_value_hash_table
339 return make_hash_table (SCM_HASHTABLEF_WEAK_CDR
, 0, FUNC_NAME
);
342 return make_hash_table (SCM_HASHTABLEF_WEAK_CDR
,
343 scm_to_ulong (n
), FUNC_NAME
);
349 SCM_DEFINE (scm_make_doubly_weak_hash_table
, "make-doubly-weak-hash-table", 1, 0, 0,
351 "Return a hash table with weak keys and values with @var{size}\n"
352 "buckets. (@pxref{Hash Tables})")
353 #define FUNC_NAME s_scm_make_doubly_weak_hash_table
356 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
361 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
369 SCM_DEFINE (scm_hash_table_p
, "hash-table?", 1, 0, 0,
371 "Return @code{#t} if @var{obj} is an abstract hash table object.")
372 #define FUNC_NAME s_scm_hash_table_p
374 return scm_from_bool (SCM_HASHTABLE_P (obj
));
379 SCM_DEFINE (scm_weak_key_hash_table_p
, "weak-key-hash-table?", 1, 0, 0,
381 "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n"
382 "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n"
383 "Return @code{#t} if @var{obj} is the specified weak hash\n"
384 "table. Note that a doubly weak hash table is neither a weak key\n"
385 "nor a weak value hash table.")
386 #define FUNC_NAME s_scm_weak_key_hash_table_p
388 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_KEY_P (obj
));
393 SCM_DEFINE (scm_weak_value_hash_table_p
, "weak-value-hash-table?", 1, 0, 0,
395 "Return @code{#t} if @var{obj} is a weak value hash table.")
396 #define FUNC_NAME s_scm_weak_value_hash_table_p
398 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_VALUE_P (obj
));
403 SCM_DEFINE (scm_doubly_weak_hash_table_p
, "doubly-weak-hash-table?", 1, 0, 0,
405 "Return @code{#t} if @var{obj} is a doubly weak hash table.")
406 #define FUNC_NAME s_scm_doubly_weak_hash_table_p
408 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_DOUBLY_WEAK_P (obj
));
414 scm_hash_fn_get_handle (SCM table
, SCM obj
, unsigned long (*hash_fn
)(), SCM (*assoc_fn
)(), void * closure
)
415 #define FUNC_NAME "scm_hash_fn_get_handle"
420 if (SCM_HASHTABLE_P (table
))
421 table
= SCM_HASHTABLE_VECTOR (table
);
423 SCM_VALIDATE_VECTOR (1, table
);
424 if (SCM_SIMPLE_VECTOR_LENGTH (table
) == 0)
426 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (table
), closure
);
427 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (table
))
428 scm_out_of_range ("hash_fn_get_handle", scm_from_ulong (k
));
429 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (table
, k
), closure
);
436 scm_hash_fn_create_handle_x (SCM table
, SCM obj
, SCM init
, unsigned long (*hash_fn
)(),
437 SCM (*assoc_fn
)(), void * closure
)
438 #define FUNC_NAME "scm_hash_fn_create_handle_x"
443 if (SCM_HASHTABLE_P (table
))
444 buckets
= SCM_HASHTABLE_VECTOR (table
);
447 SCM_ASSERT (scm_is_simple_vector (table
),
448 table
, SCM_ARG1
, "hash_fn_create_handle_x");
451 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
452 SCM_MISC_ERROR ("void hashtable", SCM_EOL
);
454 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
455 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
456 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
457 it
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
458 if (scm_is_pair (it
))
460 else if (scm_is_true (it
))
461 scm_wrong_type_arg_msg (NULL
, 0, it
, "a pair");
464 /* When this is a weak hashtable, running the GC can change it.
465 Thus, we must allocate the new cells first and can only then
466 access BUCKETS. Also, we need to fetch the bucket vector
467 again since the hashtable might have been rehashed. This
468 necessitates a new hash value as well.
470 SCM new_bucket
= scm_acons (obj
, init
, SCM_EOL
);
471 if (!scm_is_eq (table
, buckets
)
472 && !scm_is_eq (SCM_HASHTABLE_VECTOR (table
), buckets
))
474 buckets
= SCM_HASHTABLE_VECTOR (table
);
475 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
476 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
477 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
479 SCM_SETCDR (new_bucket
, SCM_SIMPLE_VECTOR_REF (buckets
, k
));
480 SCM_SIMPLE_VECTOR_SET (buckets
, k
, new_bucket
);
481 if (!scm_is_eq (table
, buckets
))
483 /* Update element count and maybe rehash the table. The
484 table might have too few entries here since weak hash
485 tables used with the hashx_* functions can not be
488 SCM_HASHTABLE_INCREMENT (table
);
489 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
)
490 || SCM_HASHTABLE_N_ITEMS (table
) > SCM_HASHTABLE_UPPER (table
))
491 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
493 return SCM_CAR (new_bucket
);
500 scm_hash_fn_ref (SCM table
, SCM obj
, SCM dflt
, unsigned long (*hash_fn
)(),
501 SCM (*assoc_fn
)(), void * closure
)
503 SCM it
= scm_hash_fn_get_handle (table
, obj
, hash_fn
, assoc_fn
, closure
);
504 if (scm_is_pair (it
))
514 scm_hash_fn_set_x (SCM table
, SCM obj
, SCM val
, unsigned long (*hash_fn
)(),
515 SCM (*assoc_fn
)(), void * closure
)
519 it
= scm_hash_fn_create_handle_x (table
, obj
, SCM_BOOL_F
, hash_fn
, assoc_fn
, closure
);
520 SCM_SETCDR (it
, val
);
526 scm_hash_fn_remove_x (SCM table
, SCM obj
,
527 unsigned long (*hash_fn
)(),
534 if (SCM_HASHTABLE_P (table
))
535 buckets
= SCM_HASHTABLE_VECTOR (table
);
538 SCM_ASSERT (scm_is_simple_vector (table
), table
,
539 SCM_ARG1
, "hash_fn_remove_x");
542 if (SCM_SIMPLE_VECTOR_LENGTH (table
) == 0)
545 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
546 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
547 scm_out_of_range ("hash_fn_remove_x", scm_from_ulong (k
));
548 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
551 SCM_SIMPLE_VECTOR_SET
552 (buckets
, k
, scm_delq_x (h
, SCM_SIMPLE_VECTOR_REF (buckets
, k
)));
553 if (!scm_is_eq (table
, buckets
))
555 SCM_HASHTABLE_DECREMENT (table
);
556 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
557 scm_i_rehash (table
, hash_fn
, closure
, "scm_hash_fn_remove_x");
563 SCM_DEFINE (scm_hash_clear_x
, "hash-clear!", 1, 0, 0,
565 "Remove all items from @var{table} (without triggering a resize).")
566 #define FUNC_NAME s_scm_hash_clear_x
568 if (SCM_HASHTABLE_P (table
))
570 scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table
), SCM_EOL
);
571 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
574 scm_vector_fill_x (table
, SCM_EOL
);
575 return SCM_UNSPECIFIED
;
581 SCM_DEFINE (scm_hashq_get_handle
, "hashq-get-handle", 2, 0, 0,
582 (SCM table
, SCM key
),
583 "This procedure returns the @code{(key . value)} pair from the\n"
584 "hash table @var{table}. If @var{table} does not hold an\n"
585 "associated value for @var{key}, @code{#f} is returned.\n"
586 "Uses @code{eq?} for equality testing.")
587 #define FUNC_NAME s_scm_hashq_get_handle
589 return scm_hash_fn_get_handle (table
, key
, scm_ihashq
, scm_sloppy_assq
, 0);
594 SCM_DEFINE (scm_hashq_create_handle_x
, "hashq-create-handle!", 3, 0, 0,
595 (SCM table
, SCM key
, SCM init
),
596 "This function looks up @var{key} in @var{table} and returns its handle.\n"
597 "If @var{key} is not already present, a new handle is created which\n"
598 "associates @var{key} with @var{init}.")
599 #define FUNC_NAME s_scm_hashq_create_handle_x
601 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashq
, scm_sloppy_assq
, 0);
606 SCM_DEFINE (scm_hashq_ref
, "hashq-ref", 2, 1, 0,
607 (SCM table
, SCM key
, SCM dflt
),
608 "Look up @var{key} in the hash table @var{table}, and return the\n"
609 "value (if any) associated with it. If @var{key} is not found,\n"
610 "return @var{default} (or @code{#f} if no @var{default} argument\n"
611 "is supplied). Uses @code{eq?} for equality testing.")
612 #define FUNC_NAME s_scm_hashq_ref
614 if (SCM_UNBNDP (dflt
))
616 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashq
, scm_sloppy_assq
, 0);
622 SCM_DEFINE (scm_hashq_set_x
, "hashq-set!", 3, 0, 0,
623 (SCM table
, SCM key
, SCM val
),
624 "Find the entry in @var{table} associated with @var{key}, and\n"
625 "store @var{value} there. Uses @code{eq?} for equality testing.")
626 #define FUNC_NAME s_scm_hashq_set_x
628 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashq
, scm_sloppy_assq
, 0);
634 SCM_DEFINE (scm_hashq_remove_x
, "hashq-remove!", 2, 0, 0,
635 (SCM table
, SCM key
),
636 "Remove @var{key} (and any value associated with it) from\n"
637 "@var{table}. Uses @code{eq?} for equality tests.")
638 #define FUNC_NAME s_scm_hashq_remove_x
640 return scm_hash_fn_remove_x (table
, key
, scm_ihashq
, scm_sloppy_assq
, 0);
647 SCM_DEFINE (scm_hashv_get_handle
, "hashv-get-handle", 2, 0, 0,
648 (SCM table
, SCM key
),
649 "This procedure returns the @code{(key . value)} pair from the\n"
650 "hash table @var{table}. If @var{table} does not hold an\n"
651 "associated value for @var{key}, @code{#f} is returned.\n"
652 "Uses @code{eqv?} for equality testing.")
653 #define FUNC_NAME s_scm_hashv_get_handle
655 return scm_hash_fn_get_handle (table
, key
, scm_ihashv
, scm_sloppy_assv
, 0);
660 SCM_DEFINE (scm_hashv_create_handle_x
, "hashv-create-handle!", 3, 0, 0,
661 (SCM table
, SCM key
, SCM init
),
662 "This function looks up @var{key} in @var{table} and returns its handle.\n"
663 "If @var{key} is not already present, a new handle is created which\n"
664 "associates @var{key} with @var{init}.")
665 #define FUNC_NAME s_scm_hashv_create_handle_x
667 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashv
,
673 SCM_DEFINE (scm_hashv_ref
, "hashv-ref", 2, 1, 0,
674 (SCM table
, SCM key
, SCM dflt
),
675 "Look up @var{key} in the hash table @var{table}, and return the\n"
676 "value (if any) associated with it. If @var{key} is not found,\n"
677 "return @var{default} (or @code{#f} if no @var{default} argument\n"
678 "is supplied). Uses @code{eqv?} for equality testing.")
679 #define FUNC_NAME s_scm_hashv_ref
681 if (SCM_UNBNDP (dflt
))
683 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashv
, scm_sloppy_assv
, 0);
689 SCM_DEFINE (scm_hashv_set_x
, "hashv-set!", 3, 0, 0,
690 (SCM table
, SCM key
, SCM val
),
691 "Find the entry in @var{table} associated with @var{key}, and\n"
692 "store @var{value} there. Uses @code{eqv?} for equality testing.")
693 #define FUNC_NAME s_scm_hashv_set_x
695 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashv
, scm_sloppy_assv
, 0);
700 SCM_DEFINE (scm_hashv_remove_x
, "hashv-remove!", 2, 0, 0,
701 (SCM table
, SCM key
),
702 "Remove @var{key} (and any value associated with it) from\n"
703 "@var{table}. Uses @code{eqv?} for equality tests.")
704 #define FUNC_NAME s_scm_hashv_remove_x
706 return scm_hash_fn_remove_x (table
, key
, scm_ihashv
, scm_sloppy_assv
, 0);
712 SCM_DEFINE (scm_hash_get_handle
, "hash-get-handle", 2, 0, 0,
713 (SCM table
, SCM key
),
714 "This procedure returns the @code{(key . value)} pair from the\n"
715 "hash table @var{table}. If @var{table} does not hold an\n"
716 "associated value for @var{key}, @code{#f} is returned.\n"
717 "Uses @code{equal?} for equality testing.")
718 #define FUNC_NAME s_scm_hash_get_handle
720 return scm_hash_fn_get_handle (table
, key
, scm_ihash
, scm_sloppy_assoc
, 0);
725 SCM_DEFINE (scm_hash_create_handle_x
, "hash-create-handle!", 3, 0, 0,
726 (SCM table
, SCM key
, SCM init
),
727 "This function looks up @var{key} in @var{table} and returns its handle.\n"
728 "If @var{key} is not already present, a new handle is created which\n"
729 "associates @var{key} with @var{init}.")
730 #define FUNC_NAME s_scm_hash_create_handle_x
732 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihash
, scm_sloppy_assoc
, 0);
737 SCM_DEFINE (scm_hash_ref
, "hash-ref", 2, 1, 0,
738 (SCM table
, SCM key
, SCM dflt
),
739 "Look up @var{key} in the hash table @var{table}, and return the\n"
740 "value (if any) associated with it. If @var{key} is not found,\n"
741 "return @var{default} (or @code{#f} if no @var{default} argument\n"
742 "is supplied). Uses @code{equal?} for equality testing.")
743 #define FUNC_NAME s_scm_hash_ref
745 if (SCM_UNBNDP (dflt
))
747 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihash
, scm_sloppy_assoc
, 0);
753 SCM_DEFINE (scm_hash_set_x
, "hash-set!", 3, 0, 0,
754 (SCM table
, SCM key
, SCM val
),
755 "Find the entry in @var{table} associated with @var{key}, and\n"
756 "store @var{value} there. Uses @code{equal?} for equality\n"
758 #define FUNC_NAME s_scm_hash_set_x
760 return scm_hash_fn_set_x (table
, key
, val
, scm_ihash
, scm_sloppy_assoc
, 0);
766 SCM_DEFINE (scm_hash_remove_x
, "hash-remove!", 2, 0, 0,
767 (SCM table
, SCM key
),
768 "Remove @var{key} (and any value associated with it) from\n"
769 "@var{table}. Uses @code{equal?} for equality tests.")
770 #define FUNC_NAME s_scm_hash_remove_x
772 return scm_hash_fn_remove_x (table
, key
, scm_ihash
, scm_sloppy_assoc
, 0);
779 typedef struct scm_t_ihashx_closure
783 } scm_t_ihashx_closure
;
788 scm_ihashx (SCM obj
, unsigned long n
, scm_t_ihashx_closure
*closure
)
790 SCM answer
= scm_call_2 (closure
->hash
, obj
, scm_from_ulong (n
));
791 return scm_to_ulong (answer
);
797 scm_sloppy_assx (SCM obj
, SCM alist
, scm_t_ihashx_closure
*closure
)
799 return scm_call_2 (closure
->assoc
, obj
, alist
);
803 SCM_DEFINE (scm_hashx_get_handle
, "hashx-get-handle", 4, 0, 0,
804 (SCM hash
, SCM assoc
, SCM table
, SCM key
),
805 "This behaves the same way as the corresponding\n"
806 "@code{-get-handle} function, but uses @var{hash} as a hash\n"
807 "function and @var{assoc} to compare keys. @code{hash} must be\n"
808 "a function that takes two arguments, a key to be hashed and a\n"
809 "table size. @code{assoc} must be an associator function, like\n"
810 "@code{assoc}, @code{assq} or @code{assv}.")
811 #define FUNC_NAME s_scm_hashx_get_handle
813 scm_t_ihashx_closure closure
;
815 closure
.assoc
= assoc
;
816 return scm_hash_fn_get_handle (table
, key
, scm_ihashx
, scm_sloppy_assx
,
822 SCM_DEFINE (scm_hashx_create_handle_x
, "hashx-create-handle!", 5, 0, 0,
823 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM init
),
824 "This behaves the same way as the corresponding\n"
825 "@code{-create-handle} function, but uses @var{hash} as a hash\n"
826 "function and @var{assoc} to compare keys. @code{hash} must be\n"
827 "a function that takes two arguments, a key to be hashed and a\n"
828 "table size. @code{assoc} must be an associator function, like\n"
829 "@code{assoc}, @code{assq} or @code{assv}.")
830 #define FUNC_NAME s_scm_hashx_create_handle_x
832 scm_t_ihashx_closure closure
;
834 closure
.assoc
= assoc
;
835 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashx
,
836 scm_sloppy_assx
, (void *)&closure
);
842 SCM_DEFINE (scm_hashx_ref
, "hashx-ref", 4, 1, 0,
843 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM dflt
),
844 "This behaves the same way as the corresponding @code{ref}\n"
845 "function, but uses @var{hash} as a hash function and\n"
846 "@var{assoc} to compare keys. @code{hash} must be a function\n"
847 "that takes two arguments, a key to be hashed and a table size.\n"
848 "@code{assoc} must be an associator function, like @code{assoc},\n"
849 "@code{assq} or @code{assv}.\n"
851 "By way of illustration, @code{hashq-ref table key} is\n"
852 "equivalent to @code{hashx-ref hashq assq table key}.")
853 #define FUNC_NAME s_scm_hashx_ref
855 scm_t_ihashx_closure closure
;
856 if (SCM_UNBNDP (dflt
))
859 closure
.assoc
= assoc
;
860 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashx
, scm_sloppy_assx
,
868 SCM_DEFINE (scm_hashx_set_x
, "hashx-set!", 5, 0, 0,
869 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM val
),
870 "This behaves the same way as the corresponding @code{set!}\n"
871 "function, but uses @var{hash} as a hash function and\n"
872 "@var{assoc} to compare keys. @code{hash} must be a function\n"
873 "that takes two arguments, a key to be hashed and a table size.\n"
874 "@code{assoc} must be an associator function, like @code{assoc},\n"
875 "@code{assq} or @code{assv}.\n"
877 " By way of illustration, @code{hashq-set! table key} is\n"
878 "equivalent to @code{hashx-set! hashq assq table key}.")
879 #define FUNC_NAME s_scm_hashx_set_x
881 scm_t_ihashx_closure closure
;
883 closure
.assoc
= assoc
;
884 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashx
, scm_sloppy_assx
,
889 SCM_DEFINE (scm_hashx_remove_x
, "hashx-remove!", 4, 0, 0,
890 (SCM hash
, SCM assoc
, SCM table
, SCM obj
),
891 "This behaves the same way as the corresponding @code{remove!}\n"
892 "function, but uses @var{hash} as a hash function and\n"
893 "@var{assoc} to compare keys. @code{hash} must be a function\n"
894 "that takes two arguments, a key to be hashed and a table size.\n"
895 "@code{assoc} must be an associator function, like @code{assoc},\n"
896 "@code{assq} or @code{assv}.\n"
898 " By way of illustration, @code{hashq-remove! table key} is\n"
899 "equivalent to @code{hashx-remove! hashq assq #f table key}.")
900 #define FUNC_NAME s_scm_hashx_remove_x
902 scm_t_ihashx_closure closure
;
904 closure
.assoc
= assoc
;
905 return scm_hash_fn_remove_x (table
, obj
, scm_ihashx
, scm_sloppy_assx
,
910 /* Hash table iterators */
912 static const char s_scm_hash_fold
[];
915 scm_internal_hash_fold (SCM (*fn
) (), void *closure
, SCM init
, SCM table
)
918 SCM buckets
, result
= init
;
920 if (SCM_HASHTABLE_P (table
))
921 buckets
= SCM_HASHTABLE_VECTOR (table
);
925 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
926 for (i
= 0; i
< n
; ++i
)
928 SCM ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
), handle
;
929 while (!scm_is_null (ls
))
931 if (!scm_is_pair (ls
))
932 scm_wrong_type_arg (s_scm_hash_fold
, SCM_ARG3
, buckets
);
933 handle
= SCM_CAR (ls
);
934 if (!scm_is_pair (handle
))
935 scm_wrong_type_arg (s_scm_hash_fold
, SCM_ARG3
, buckets
);
936 result
= fn (closure
, SCM_CAR (handle
), SCM_CDR (handle
), result
);
944 /* The following redundant code is here in order to be able to support
945 hash-for-each-handle. An alternative would have been to replace
946 this code and scm_internal_hash_fold above with a single
947 scm_internal_hash_fold_handles, but we don't want to promote such
950 static const char s_scm_hash_for_each
[];
953 scm_internal_hash_for_each_handle (SCM (*fn
) (), void *closure
, SCM table
)
958 if (SCM_HASHTABLE_P (table
))
959 buckets
= SCM_HASHTABLE_VECTOR (table
);
963 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
964 for (i
= 0; i
< n
; ++i
)
966 SCM ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
), handle
;
967 while (!scm_is_null (ls
))
969 if (!scm_is_pair (ls
))
970 scm_wrong_type_arg (s_scm_hash_for_each
, SCM_ARG3
, buckets
);
971 handle
= SCM_CAR (ls
);
972 if (!scm_is_pair (handle
))
973 scm_wrong_type_arg (s_scm_hash_for_each
, SCM_ARG3
, buckets
);
974 fn (closure
, handle
);
980 SCM_DEFINE (scm_hash_fold
, "hash-fold", 3, 0, 0,
981 (SCM proc
, SCM init
, SCM table
),
982 "An iterator over hash-table elements.\n"
983 "Accumulates and returns a result by applying PROC successively.\n"
984 "The arguments to PROC are \"(key value prior-result)\" where key\n"
985 "and value are successive pairs from the hash table TABLE, and\n"
986 "prior-result is either INIT (for the first application of PROC)\n"
987 "or the return value of the previous application of PROC.\n"
988 "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
989 "table into an a-list of key-value pairs.")
990 #define FUNC_NAME s_scm_hash_fold
992 SCM_VALIDATE_PROC (1, proc
);
993 if (!SCM_HASHTABLE_P (table
))
994 SCM_VALIDATE_VECTOR (3, table
);
995 return scm_internal_hash_fold (scm_call_3
, (void *) SCM_UNPACK (proc
), init
, table
);
1000 for_each_proc (void *proc
, SCM handle
)
1002 return scm_call_2 (SCM_PACK (proc
), SCM_CAR (handle
), SCM_CDR (handle
));
1005 SCM_DEFINE (scm_hash_for_each
, "hash-for-each", 2, 0, 0,
1006 (SCM proc
, SCM table
),
1007 "An iterator over hash-table elements.\n"
1008 "Applies PROC successively on all hash table items.\n"
1009 "The arguments to PROC are \"(key value)\" where key\n"
1010 "and value are successive pairs from the hash table TABLE.")
1011 #define FUNC_NAME s_scm_hash_for_each
1013 SCM_VALIDATE_PROC (1, proc
);
1014 if (!SCM_HASHTABLE_P (table
))
1015 SCM_VALIDATE_VECTOR (2, table
);
1017 scm_internal_hash_for_each_handle (for_each_proc
,
1018 (void *) SCM_UNPACK (proc
),
1020 return SCM_UNSPECIFIED
;
1024 SCM_DEFINE (scm_hash_for_each_handle
, "hash-for-each-handle", 2, 0, 0,
1025 (SCM proc
, SCM table
),
1026 "An iterator over hash-table elements.\n"
1027 "Applies PROC successively on all hash table handles.")
1028 #define FUNC_NAME s_scm_hash_for_each_handle
1030 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
1031 SCM_ASSERT (call
, proc
, 1, FUNC_NAME
);
1032 if (!SCM_HASHTABLE_P (table
))
1033 SCM_VALIDATE_VECTOR (2, table
);
1035 scm_internal_hash_for_each_handle (call
,
1036 (void *) SCM_UNPACK (proc
),
1038 return SCM_UNSPECIFIED
;
1043 map_proc (void *proc
, SCM key
, SCM data
, SCM value
)
1045 return scm_cons (scm_call_2 (SCM_PACK (proc
), key
, data
), value
);
1048 SCM_DEFINE (scm_hash_map_to_list
, "hash-map->list", 2, 0, 0,
1049 (SCM proc
, SCM table
),
1050 "An iterator over hash-table elements.\n"
1051 "Accumulates and returns as a list the results of applying PROC successively.\n"
1052 "The arguments to PROC are \"(key value)\" where key\n"
1053 "and value are successive pairs from the hash table TABLE.")
1054 #define FUNC_NAME s_scm_hash_map_to_list
1056 SCM_VALIDATE_PROC (1, proc
);
1057 if (!SCM_HASHTABLE_P (table
))
1058 SCM_VALIDATE_VECTOR (2, table
);
1059 return scm_internal_hash_fold (map_proc
,
1060 (void *) SCM_UNPACK (proc
),
1070 scm_hashtab_prehistory ()
1072 scm_tc16_hashtable
= scm_make_smob_type (s_hashtable
, 0);
1073 scm_set_smob_mark (scm_tc16_hashtable
, scm_markcdr
);
1074 scm_set_smob_print (scm_tc16_hashtable
, hashtable_print
);
1075 scm_set_smob_free (scm_tc16_hashtable
, hashtable_free
);
1076 scm_c_hook_add (&scm_after_gc_c_hook
, rehash_after_gc
, 0, 0);
1082 #include "libguile/hashtab.x"