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
21 #include "libguile/_scm.h"
22 #include "libguile/alist.h"
23 #include "libguile/hash.h"
24 #include "libguile/eval.h"
25 #include "libguile/root.h"
26 #include "libguile/vectors.h"
27 #include "libguile/ports.h"
29 #include "libguile/validate.h"
30 #include "libguile/hashtab.h"
35 * 1. The current hash table implementation uses weak alist vectors
36 * (implementation in weaks.c) internally, but we do the scanning
37 * ourselves (in scan_weak_hashtables) because we need to update the
38 * hash table structure when items are dropped during GC.
40 * 2. All hash table operations still work on alist vectors.
44 /* Hash tables are either vectors of association lists or smobs
45 * containing such vectors. Currently, the vector version represents
46 * constant size tables while those wrapped in a smob represents
49 * Growing or shrinking, with following rehashing, is triggered when
52 * L = N / S (N: number of items in table, S: bucket vector length)
54 * passes an upper limit of 0.9 or a lower limit of 0.25.
56 * The implementation stores the upper and lower number of items which
57 * trigger a resize in the hashtable object.
59 * Possible hash table sizes (primes) are stored in the array
63 scm_t_bits scm_tc16_hashtable
;
65 static unsigned long hashtable_size
[] = {
66 31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363,
67 224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041
69 /* vectors are currently restricted to 2^24-1 = 16777215 elements. */
70 28762081, 57524111, 115048217, 230096423, 460192829
71 /* larger values can't be represented as INUMs */
75 #define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long))
77 static char *s_hashtable
= "hashtable";
79 SCM weak_hashtables
= SCM_EOL
;
82 make_hash_table (int flags
, unsigned long k
, const char *func_name
)
86 int i
= 0, n
= k
? k
: 31;
87 while (i
< HASHTABLE_SIZE_N
&& n
> hashtable_size
[i
])
89 n
= hashtable_size
[i
];
91 /* The SCM_WVECTF_NOSCAN flag informs the weak vector code not to
92 perform the final scan for broken references. Instead we do
93 that ourselves in scan_weak_hashtables. */
94 vector
= scm_i_allocate_weak_vector (flags
| SCM_WVECTF_NOSCAN
,
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
)
163 scm_from_ulong (new_size
),
166 new_buckets
= scm_c_make_vector (new_size
, SCM_EOL
);
168 /* When this is a weak hashtable, running the GC might change it.
169 We need to cope with this while rehashing its elements. We do
170 this by first installing the new, empty bucket vector and turning
171 the old bucket vector into a regularily scanned weak vector.
172 Then we remove the elements from the old bucket vector and insert
173 them into the new one.
176 SCM_SET_HASHTABLE_VECTOR (table
, new_buckets
);
177 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
178 if (SCM_HASHTABLE_WEAK_P (table
))
179 SCM_I_SET_WVECT_TYPE (buckets
, (SCM_HASHTABLE_FLAGS (table
)));
181 old_size
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
182 for (i
= 0; i
< old_size
; ++i
)
184 SCM ls
, cell
, handle
;
186 ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
);
187 SCM_SIMPLE_VECTOR_SET (buckets
, i
, SCM_EOL
);
189 while (scm_is_pair (ls
))
193 handle
= SCM_CAR (cell
);
195 h
= hash_fn (SCM_CAR (handle
), new_size
, closure
);
197 scm_out_of_range (func_name
, scm_from_ulong (h
));
198 SCM_SETCDR (cell
, SCM_SIMPLE_VECTOR_REF (new_buckets
, h
));
199 SCM_SIMPLE_VECTOR_SET (new_buckets
, h
, cell
);
200 SCM_HASHTABLE_INCREMENT (table
);
207 hashtable_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
209 scm_t_hashtable
*t
= SCM_HASHTABLE (exp
);
210 scm_puts ("#<", port
);
211 if (SCM_HASHTABLE_WEAK_KEY_P (exp
))
212 scm_puts ("weak-key-", port
);
213 else if (SCM_HASHTABLE_WEAK_VALUE_P (exp
))
214 scm_puts ("weak-value-", port
);
215 else if (SCM_HASHTABLE_DOUBLY_WEAK_P (exp
))
216 scm_puts ("doubly-weak-", port
);
217 scm_puts ("hash-table ", port
);
218 scm_uintprint (t
->n_items
, 10, port
);
219 scm_putc ('/', port
);
220 scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp
)),
222 scm_puts (">", port
);
226 #define UNMARKED_CELL_P(x) (SCM_NIMP(x) && !SCM_GC_MARK_P (x))
228 /* keep track of hash tables that need to shrink after scan */
229 static SCM to_rehash
= SCM_EOL
;
231 /* scan hash tables for broken references, remove them, and update
232 hash tables item count */
234 scan_weak_hashtables (void *dummy1 SCM_UNUSED
,
235 void *dummy2 SCM_UNUSED
,
236 void *dummy3 SCM_UNUSED
)
238 SCM
*next
= &weak_hashtables
;
240 while (!scm_is_null (h
))
242 if (!SCM_GC_MARK_P (h
))
243 *next
= h
= SCM_HASHTABLE_NEXT (h
);
247 int i
, n
= SCM_HASHTABLE_N_BUCKETS (h
);
248 int weak_car
= SCM_HASHTABLE_FLAGS (h
) & SCM_HASHTABLEF_WEAK_CAR
;
249 int weak_cdr
= SCM_HASHTABLE_FLAGS (h
) & SCM_HASHTABLEF_WEAK_CDR
;
250 int check_size_p
= 0;
251 for (i
= 0; i
< n
; ++i
)
253 SCM
*next_spine
= NULL
;
254 alist
= SCM_HASHTABLE_BUCKET (h
, i
);
255 while (scm_is_pair (alist
))
257 if ((weak_car
&& UNMARKED_CELL_P (SCM_CAAR (alist
)))
258 || (weak_cdr
&& UNMARKED_CELL_P (SCM_CDAR (alist
))))
261 *next_spine
= SCM_CDR (alist
);
263 SCM_SET_HASHTABLE_BUCKET (h
, i
, SCM_CDR (alist
));
264 SCM_HASHTABLE_DECREMENT (h
);
268 next_spine
= SCM_CDRLOC (alist
);
269 alist
= SCM_CDR (alist
);
273 && SCM_HASHTABLE_N_ITEMS (h
) < SCM_HASHTABLE_LOWER (h
))
275 SCM tmp
= SCM_HASHTABLE_NEXT (h
);
276 /* temporarily move table from weak_hashtables to to_rehash */
277 SCM_SET_HASHTABLE_NEXT (h
, to_rehash
);
283 next
= SCM_HASHTABLE_NEXTLOC (h
);
284 h
= SCM_HASHTABLE_NEXT (h
);
292 rehash_after_gc (void *dummy1 SCM_UNUSED
,
293 void *dummy2 SCM_UNUSED
,
294 void *dummy3 SCM_UNUSED
)
296 if (!scm_is_null (to_rehash
))
298 SCM first
= to_rehash
, last
, h
;
299 /* important to clear to_rehash here so that we don't get stuck
300 in an infinite loop if scm_i_rehash causes GC */
305 /* Rehash only when we have a hash_fn.
307 if (SCM_HASHTABLE (h
)->hash_fn
)
308 scm_i_rehash (h
, SCM_HASHTABLE (h
)->hash_fn
, NULL
,
311 h
= SCM_HASHTABLE_NEXT (h
);
312 } while (!scm_is_null (h
));
313 /* move tables back to weak_hashtables */
314 SCM_SET_HASHTABLE_NEXT (last
, weak_hashtables
);
315 weak_hashtables
= first
;
321 hashtable_free (SCM obj
)
323 scm_gc_free (SCM_HASHTABLE (obj
), sizeof (scm_t_hashtable
), s_hashtable
);
329 scm_c_make_hash_table (unsigned long k
)
331 return make_hash_table (0, k
, "scm_c_make_hash_table");
334 SCM_DEFINE (scm_make_hash_table
, "make-hash-table", 0, 1, 0,
336 "Make a new abstract hash table object with minimum number of buckets @var{n}\n")
337 #define FUNC_NAME s_scm_make_hash_table
340 return make_hash_table (0, 0, FUNC_NAME
);
342 return make_hash_table (0, scm_to_ulong (n
), FUNC_NAME
);
346 SCM_DEFINE (scm_make_weak_key_hash_table
, "make-weak-key-hash-table", 0, 1, 0,
348 "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
349 "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n"
350 "Return a weak hash table with @var{size} buckets.\n"
352 "You can modify weak hash tables in exactly the same way you\n"
353 "would modify regular hash tables. (@pxref{Hash Tables})")
354 #define FUNC_NAME s_scm_make_weak_key_hash_table
357 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
, 0, FUNC_NAME
);
359 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
,
360 scm_to_ulong (n
), FUNC_NAME
);
365 SCM_DEFINE (scm_make_weak_value_hash_table
, "make-weak-value-hash-table", 0, 1, 0,
367 "Return a hash table with weak values with @var{size} buckets.\n"
368 "(@pxref{Hash Tables})")
369 #define FUNC_NAME s_scm_make_weak_value_hash_table
372 return make_hash_table (SCM_HASHTABLEF_WEAK_CDR
, 0, FUNC_NAME
);
375 return make_hash_table (SCM_HASHTABLEF_WEAK_CDR
,
376 scm_to_ulong (n
), FUNC_NAME
);
382 SCM_DEFINE (scm_make_doubly_weak_hash_table
, "make-doubly-weak-hash-table", 1, 0, 0,
384 "Return a hash table with weak keys and values with @var{size}\n"
385 "buckets. (@pxref{Hash Tables})")
386 #define FUNC_NAME s_scm_make_doubly_weak_hash_table
389 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
394 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
402 SCM_DEFINE (scm_hash_table_p
, "hash-table?", 1, 0, 0,
404 "Return @code{#t} if @var{obj} is an abstract hash table object.")
405 #define FUNC_NAME s_scm_hash_table_p
407 return scm_from_bool (SCM_HASHTABLE_P (obj
));
412 SCM_DEFINE (scm_weak_key_hash_table_p
, "weak-key-hash-table?", 1, 0, 0,
414 "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n"
415 "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n"
416 "Return @code{#t} if @var{obj} is the specified weak hash\n"
417 "table. Note that a doubly weak hash table is neither a weak key\n"
418 "nor a weak value hash table.")
419 #define FUNC_NAME s_scm_weak_key_hash_table_p
421 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_KEY_P (obj
));
426 SCM_DEFINE (scm_weak_value_hash_table_p
, "weak-value-hash-table?", 1, 0, 0,
428 "Return @code{#t} if @var{obj} is a weak value hash table.")
429 #define FUNC_NAME s_scm_weak_value_hash_table_p
431 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_VALUE_P (obj
));
436 SCM_DEFINE (scm_doubly_weak_hash_table_p
, "doubly-weak-hash-table?", 1, 0, 0,
438 "Return @code{#t} if @var{obj} is a doubly weak hash table.")
439 #define FUNC_NAME s_scm_doubly_weak_hash_table_p
441 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_DOUBLY_WEAK_P (obj
));
447 scm_hash_fn_get_handle (SCM table
, SCM obj
, unsigned long (*hash_fn
)(), SCM (*assoc_fn
)(), void * closure
)
448 #define FUNC_NAME "scm_hash_fn_get_handle"
453 if (SCM_HASHTABLE_P (table
))
454 table
= SCM_HASHTABLE_VECTOR (table
);
456 SCM_VALIDATE_VECTOR (1, table
);
457 if (SCM_SIMPLE_VECTOR_LENGTH (table
) == 0)
459 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (table
), closure
);
460 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (table
))
461 scm_out_of_range ("hash_fn_get_handle", scm_from_ulong (k
));
462 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (table
, k
), closure
);
469 scm_hash_fn_create_handle_x (SCM table
, SCM obj
, SCM init
, unsigned long (*hash_fn
)(),
470 SCM (*assoc_fn
)(), void * closure
)
471 #define FUNC_NAME "scm_hash_fn_create_handle_x"
476 if (SCM_HASHTABLE_P (table
))
477 buckets
= SCM_HASHTABLE_VECTOR (table
);
480 SCM_ASSERT (scm_is_simple_vector (table
),
481 table
, SCM_ARG1
, "hash_fn_create_handle_x");
484 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
485 SCM_MISC_ERROR ("void hashtable", SCM_EOL
);
487 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
488 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
489 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
490 it
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
491 if (scm_is_true (it
))
495 /* When this is a weak hashtable, running the GC can change it.
496 Thus, we must allocate the new cells first and can only then
497 access BUCKETS. Also, we need to fetch the bucket vector
498 again since the hashtable might have been rehashed. This
499 necessitates a new hash value as well.
501 SCM new_bucket
= scm_acons (obj
, init
, SCM_EOL
);
502 if (!scm_is_eq (table
, buckets
)
503 && !scm_is_eq (SCM_HASHTABLE_VECTOR (table
), buckets
))
505 buckets
= SCM_HASHTABLE_VECTOR (table
);
506 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
507 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
508 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
510 SCM_SETCDR (new_bucket
, SCM_SIMPLE_VECTOR_REF (buckets
, k
));
511 SCM_SIMPLE_VECTOR_SET (buckets
, k
, new_bucket
);
512 if (!scm_is_eq (table
, buckets
))
514 /* Update element count and maybe rehash the table. The
515 table might have too few entries here since weak hash
516 tables used with the hashx_* functions can not be
519 SCM_HASHTABLE_INCREMENT (table
);
520 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
)
521 || SCM_HASHTABLE_N_ITEMS (table
) > SCM_HASHTABLE_UPPER (table
))
522 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
524 return SCM_CAR (new_bucket
);
531 scm_hash_fn_ref (SCM table
, SCM obj
, SCM dflt
, unsigned long (*hash_fn
)(),
532 SCM (*assoc_fn
)(), void * closure
)
534 SCM it
= scm_hash_fn_get_handle (table
, obj
, hash_fn
, assoc_fn
, closure
);
535 if (scm_is_pair (it
))
545 scm_hash_fn_set_x (SCM table
, SCM obj
, SCM val
, unsigned long (*hash_fn
)(),
546 SCM (*assoc_fn
)(), void * closure
)
550 it
= scm_hash_fn_create_handle_x (table
, obj
, SCM_BOOL_F
, hash_fn
, assoc_fn
, closure
);
551 SCM_SETCDR (it
, val
);
557 scm_hash_fn_remove_x (SCM table
, SCM obj
,
558 unsigned long (*hash_fn
)(),
565 if (SCM_HASHTABLE_P (table
))
566 buckets
= SCM_HASHTABLE_VECTOR (table
);
569 SCM_ASSERT (scm_is_simple_vector (table
), table
,
570 SCM_ARG1
, "hash_fn_remove_x");
573 if (SCM_SIMPLE_VECTOR_LENGTH (table
) == 0)
576 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
577 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
578 scm_out_of_range ("hash_fn_remove_x", scm_from_ulong (k
));
579 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
582 SCM_SIMPLE_VECTOR_SET
583 (buckets
, k
, scm_delq_x (h
, SCM_SIMPLE_VECTOR_REF (buckets
, k
)));
584 if (!scm_is_eq (table
, buckets
))
586 SCM_HASHTABLE_DECREMENT (table
);
587 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
588 scm_i_rehash (table
, hash_fn
, closure
, "scm_hash_fn_remove_x");
594 SCM_DEFINE (scm_hash_clear_x
, "hash-clear!", 1, 0, 0,
596 "Remove all items from @var{table} (without triggering a resize).")
597 #define FUNC_NAME s_scm_hash_clear_x
599 if (SCM_HASHTABLE_P (table
))
601 scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table
), SCM_EOL
);
602 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
605 scm_vector_fill_x (table
, SCM_EOL
);
606 return SCM_UNSPECIFIED
;
612 SCM_DEFINE (scm_hashq_get_handle
, "hashq-get-handle", 2, 0, 0,
613 (SCM table
, SCM key
),
614 "This procedure returns the @code{(key . value)} pair from the\n"
615 "hash table @var{table}. If @var{table} does not hold an\n"
616 "associated value for @var{key}, @code{#f} is returned.\n"
617 "Uses @code{eq?} for equality testing.")
618 #define FUNC_NAME s_scm_hashq_get_handle
620 return scm_hash_fn_get_handle (table
, key
, scm_ihashq
, scm_sloppy_assq
, 0);
625 SCM_DEFINE (scm_hashq_create_handle_x
, "hashq-create-handle!", 3, 0, 0,
626 (SCM table
, SCM key
, SCM init
),
627 "This function looks up @var{key} in @var{table} and returns its handle.\n"
628 "If @var{key} is not already present, a new handle is created which\n"
629 "associates @var{key} with @var{init}.")
630 #define FUNC_NAME s_scm_hashq_create_handle_x
632 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashq
, scm_sloppy_assq
, 0);
637 SCM_DEFINE (scm_hashq_ref
, "hashq-ref", 2, 1, 0,
638 (SCM table
, SCM key
, SCM dflt
),
639 "Look up @var{key} in the hash table @var{table}, and return the\n"
640 "value (if any) associated with it. If @var{key} is not found,\n"
641 "return @var{default} (or @code{#f} if no @var{default} argument\n"
642 "is supplied). Uses @code{eq?} for equality testing.")
643 #define FUNC_NAME s_scm_hashq_ref
645 if (SCM_UNBNDP (dflt
))
647 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashq
, scm_sloppy_assq
, 0);
653 SCM_DEFINE (scm_hashq_set_x
, "hashq-set!", 3, 0, 0,
654 (SCM table
, SCM key
, SCM val
),
655 "Find the entry in @var{table} associated with @var{key}, and\n"
656 "store @var{value} there. Uses @code{eq?} for equality testing.")
657 #define FUNC_NAME s_scm_hashq_set_x
659 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashq
, scm_sloppy_assq
, 0);
665 SCM_DEFINE (scm_hashq_remove_x
, "hashq-remove!", 2, 0, 0,
666 (SCM table
, SCM key
),
667 "Remove @var{key} (and any value associated with it) from\n"
668 "@var{table}. Uses @code{eq?} for equality tests.")
669 #define FUNC_NAME s_scm_hashq_remove_x
671 return scm_hash_fn_remove_x (table
, key
, scm_ihashq
, scm_sloppy_assq
, 0);
678 SCM_DEFINE (scm_hashv_get_handle
, "hashv-get-handle", 2, 0, 0,
679 (SCM table
, SCM key
),
680 "This procedure returns the @code{(key . value)} pair from the\n"
681 "hash table @var{table}. If @var{table} does not hold an\n"
682 "associated value for @var{key}, @code{#f} is returned.\n"
683 "Uses @code{eqv?} for equality testing.")
684 #define FUNC_NAME s_scm_hashv_get_handle
686 return scm_hash_fn_get_handle (table
, key
, scm_ihashv
, scm_sloppy_assv
, 0);
691 SCM_DEFINE (scm_hashv_create_handle_x
, "hashv-create-handle!", 3, 0, 0,
692 (SCM table
, SCM key
, SCM init
),
693 "This function looks up @var{key} in @var{table} and returns its handle.\n"
694 "If @var{key} is not already present, a new handle is created which\n"
695 "associates @var{key} with @var{init}.")
696 #define FUNC_NAME s_scm_hashv_create_handle_x
698 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashv
,
704 SCM_DEFINE (scm_hashv_ref
, "hashv-ref", 2, 1, 0,
705 (SCM table
, SCM key
, SCM dflt
),
706 "Look up @var{key} in the hash table @var{table}, and return the\n"
707 "value (if any) associated with it. If @var{key} is not found,\n"
708 "return @var{default} (or @code{#f} if no @var{default} argument\n"
709 "is supplied). Uses @code{eqv?} for equality testing.")
710 #define FUNC_NAME s_scm_hashv_ref
712 if (SCM_UNBNDP (dflt
))
714 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashv
, scm_sloppy_assv
, 0);
720 SCM_DEFINE (scm_hashv_set_x
, "hashv-set!", 3, 0, 0,
721 (SCM table
, SCM key
, SCM val
),
722 "Find the entry in @var{table} associated with @var{key}, and\n"
723 "store @var{value} there. Uses @code{eqv?} for equality testing.")
724 #define FUNC_NAME s_scm_hashv_set_x
726 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashv
, scm_sloppy_assv
, 0);
731 SCM_DEFINE (scm_hashv_remove_x
, "hashv-remove!", 2, 0, 0,
732 (SCM table
, SCM key
),
733 "Remove @var{key} (and any value associated with it) from\n"
734 "@var{table}. Uses @code{eqv?} for equality tests.")
735 #define FUNC_NAME s_scm_hashv_remove_x
737 return scm_hash_fn_remove_x (table
, key
, scm_ihashv
, scm_sloppy_assv
, 0);
743 SCM_DEFINE (scm_hash_get_handle
, "hash-get-handle", 2, 0, 0,
744 (SCM table
, SCM key
),
745 "This procedure returns the @code{(key . value)} pair from the\n"
746 "hash table @var{table}. If @var{table} does not hold an\n"
747 "associated value for @var{key}, @code{#f} is returned.\n"
748 "Uses @code{equal?} for equality testing.")
749 #define FUNC_NAME s_scm_hash_get_handle
751 return scm_hash_fn_get_handle (table
, key
, scm_ihash
, scm_sloppy_assoc
, 0);
756 SCM_DEFINE (scm_hash_create_handle_x
, "hash-create-handle!", 3, 0, 0,
757 (SCM table
, SCM key
, SCM init
),
758 "This function looks up @var{key} in @var{table} and returns its handle.\n"
759 "If @var{key} is not already present, a new handle is created which\n"
760 "associates @var{key} with @var{init}.")
761 #define FUNC_NAME s_scm_hash_create_handle_x
763 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihash
, scm_sloppy_assoc
, 0);
768 SCM_DEFINE (scm_hash_ref
, "hash-ref", 2, 1, 0,
769 (SCM table
, SCM key
, SCM dflt
),
770 "Look up @var{key} in the hash table @var{table}, and return the\n"
771 "value (if any) associated with it. If @var{key} is not found,\n"
772 "return @var{default} (or @code{#f} if no @var{default} argument\n"
773 "is supplied). Uses @code{equal?} for equality testing.")
774 #define FUNC_NAME s_scm_hash_ref
776 if (SCM_UNBNDP (dflt
))
778 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihash
, scm_sloppy_assoc
, 0);
784 SCM_DEFINE (scm_hash_set_x
, "hash-set!", 3, 0, 0,
785 (SCM table
, SCM key
, SCM val
),
786 "Find the entry in @var{table} associated with @var{key}, and\n"
787 "store @var{value} there. Uses @code{equal?} for equality\n"
789 #define FUNC_NAME s_scm_hash_set_x
791 return scm_hash_fn_set_x (table
, key
, val
, scm_ihash
, scm_sloppy_assoc
, 0);
797 SCM_DEFINE (scm_hash_remove_x
, "hash-remove!", 2, 0, 0,
798 (SCM table
, SCM key
),
799 "Remove @var{key} (and any value associated with it) from\n"
800 "@var{table}. Uses @code{equal?} for equality tests.")
801 #define FUNC_NAME s_scm_hash_remove_x
803 return scm_hash_fn_remove_x (table
, key
, scm_ihash
, scm_sloppy_assoc
, 0);
810 typedef struct scm_t_ihashx_closure
814 } scm_t_ihashx_closure
;
819 scm_ihashx (SCM obj
, unsigned long n
, scm_t_ihashx_closure
*closure
)
821 SCM answer
= scm_call_2 (closure
->hash
, obj
, scm_from_ulong (n
));
822 return scm_to_ulong (answer
);
828 scm_sloppy_assx (SCM obj
, SCM alist
, scm_t_ihashx_closure
*closure
)
830 return scm_call_2 (closure
->assoc
, obj
, alist
);
834 SCM_DEFINE (scm_hashx_get_handle
, "hashx-get-handle", 4, 0, 0,
835 (SCM hash
, SCM assoc
, SCM table
, SCM key
),
836 "This behaves the same way as the corresponding\n"
837 "@code{-get-handle} function, but uses @var{hash} as a hash\n"
838 "function and @var{assoc} to compare keys. @code{hash} must be\n"
839 "a function that takes two arguments, a key to be hashed and a\n"
840 "table size. @code{assoc} must be an associator function, like\n"
841 "@code{assoc}, @code{assq} or @code{assv}.")
842 #define FUNC_NAME s_scm_hashx_get_handle
844 scm_t_ihashx_closure closure
;
846 closure
.assoc
= assoc
;
847 return scm_hash_fn_get_handle (table
, key
, scm_ihashx
, scm_sloppy_assx
,
853 SCM_DEFINE (scm_hashx_create_handle_x
, "hashx-create-handle!", 5, 0, 0,
854 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM init
),
855 "This behaves the same way as the corresponding\n"
856 "@code{-create-handle} function, but uses @var{hash} as a hash\n"
857 "function and @var{assoc} to compare keys. @code{hash} must be\n"
858 "a function that takes two arguments, a key to be hashed and a\n"
859 "table size. @code{assoc} must be an associator function, like\n"
860 "@code{assoc}, @code{assq} or @code{assv}.")
861 #define FUNC_NAME s_scm_hashx_create_handle_x
863 scm_t_ihashx_closure closure
;
865 closure
.assoc
= assoc
;
866 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashx
,
867 scm_sloppy_assx
, (void *)&closure
);
873 SCM_DEFINE (scm_hashx_ref
, "hashx-ref", 4, 1, 0,
874 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM dflt
),
875 "This behaves the same way as the corresponding @code{ref}\n"
876 "function, but uses @var{hash} as a hash function and\n"
877 "@var{assoc} to compare keys. @code{hash} must be a function\n"
878 "that takes two arguments, a key to be hashed and a table size.\n"
879 "@code{assoc} must be an associator function, like @code{assoc},\n"
880 "@code{assq} or @code{assv}.\n"
882 "By way of illustration, @code{hashq-ref table key} is\n"
883 "equivalent to @code{hashx-ref hashq assq table key}.")
884 #define FUNC_NAME s_scm_hashx_ref
886 scm_t_ihashx_closure closure
;
887 if (SCM_UNBNDP (dflt
))
890 closure
.assoc
= assoc
;
891 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashx
, scm_sloppy_assx
,
899 SCM_DEFINE (scm_hashx_set_x
, "hashx-set!", 5, 0, 0,
900 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM val
),
901 "This behaves the same way as the corresponding @code{set!}\n"
902 "function, but uses @var{hash} as a hash function and\n"
903 "@var{assoc} to compare keys. @code{hash} must be a function\n"
904 "that takes two arguments, a key to be hashed and a table size.\n"
905 "@code{assoc} must be an associator function, like @code{assoc},\n"
906 "@code{assq} or @code{assv}.\n"
908 " By way of illustration, @code{hashq-set! table key} is\n"
909 "equivalent to @code{hashx-set! hashq assq table key}.")
910 #define FUNC_NAME s_scm_hashx_set_x
912 scm_t_ihashx_closure closure
;
914 closure
.assoc
= assoc
;
915 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashx
, scm_sloppy_assx
,
920 SCM_DEFINE (scm_hashx_remove_x
, "hashx-remove!", 4, 0, 0,
921 (SCM hash
, SCM assoc
, SCM table
, SCM obj
),
922 "This behaves the same way as the corresponding @code{remove!}\n"
923 "function, but uses @var{hash} as a hash function and\n"
924 "@var{assoc} to compare keys. @code{hash} must be a function\n"
925 "that takes two arguments, a key to be hashed and a table size.\n"
926 "@code{assoc} must be an associator function, like @code{assoc},\n"
927 "@code{assq} or @code{assv}.\n"
929 " By way of illustration, @code{hashq-remove! table key} is\n"
930 "equivalent to @code{hashx-remove! hashq assq #f table key}.")
931 #define FUNC_NAME s_scm_hashx_remove_x
933 scm_t_ihashx_closure closure
;
935 closure
.assoc
= assoc
;
936 return scm_hash_fn_remove_x (table
, obj
, scm_ihashx
, scm_sloppy_assx
,
941 /* Hash table iterators */
943 static const char s_scm_hash_fold
[];
946 scm_internal_hash_fold (SCM (*fn
) (), void *closure
, SCM init
, SCM table
)
949 SCM buckets
, result
= init
;
951 if (SCM_HASHTABLE_P (table
))
952 buckets
= SCM_HASHTABLE_VECTOR (table
);
956 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
957 for (i
= 0; i
< n
; ++i
)
959 SCM ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
), handle
;
960 while (!scm_is_null (ls
))
962 if (!scm_is_pair (ls
))
963 scm_wrong_type_arg (s_scm_hash_fold
, SCM_ARG3
, buckets
);
964 handle
= SCM_CAR (ls
);
965 if (!scm_is_pair (handle
))
966 scm_wrong_type_arg (s_scm_hash_fold
, SCM_ARG3
, buckets
);
967 result
= fn (closure
, SCM_CAR (handle
), SCM_CDR (handle
), result
);
975 /* The following redundant code is here in order to be able to support
976 hash-for-each-handle. An alternative would have been to replace
977 this code and scm_internal_hash_fold above with a single
978 scm_internal_hash_fold_handles, but we don't want to promote such
981 static const char s_scm_hash_for_each
[];
984 scm_internal_hash_for_each_handle (SCM (*fn
) (), void *closure
, SCM table
)
989 if (SCM_HASHTABLE_P (table
))
990 buckets
= SCM_HASHTABLE_VECTOR (table
);
994 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
995 for (i
= 0; i
< n
; ++i
)
997 SCM ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
), handle
;
998 while (!scm_is_null (ls
))
1000 if (!scm_is_pair (ls
))
1001 scm_wrong_type_arg (s_scm_hash_for_each
, SCM_ARG3
, buckets
);
1002 handle
= SCM_CAR (ls
);
1003 if (!scm_is_pair (handle
))
1004 scm_wrong_type_arg (s_scm_hash_for_each
, SCM_ARG3
, buckets
);
1005 fn (closure
, handle
);
1011 SCM_DEFINE (scm_hash_fold
, "hash-fold", 3, 0, 0,
1012 (SCM proc
, SCM init
, SCM table
),
1013 "An iterator over hash-table elements.\n"
1014 "Accumulates and returns a result by applying PROC successively.\n"
1015 "The arguments to PROC are \"(key value prior-result)\" where key\n"
1016 "and value are successive pairs from the hash table TABLE, and\n"
1017 "prior-result is either INIT (for the first application of PROC)\n"
1018 "or the return value of the previous application of PROC.\n"
1019 "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
1020 "table into an a-list of key-value pairs.")
1021 #define FUNC_NAME s_scm_hash_fold
1023 SCM_VALIDATE_PROC (1, proc
);
1024 if (!SCM_HASHTABLE_P (table
))
1025 SCM_VALIDATE_VECTOR (3, table
);
1026 return scm_internal_hash_fold (scm_call_3
, (void *) SCM_UNPACK (proc
), init
, table
);
1031 for_each_proc (void *proc
, SCM handle
)
1033 return scm_call_2 (SCM_PACK (proc
), SCM_CAR (handle
), SCM_CDR (handle
));
1036 SCM_DEFINE (scm_hash_for_each
, "hash-for-each", 2, 0, 0,
1037 (SCM proc
, SCM table
),
1038 "An iterator over hash-table elements.\n"
1039 "Applies PROC successively on all hash table items.\n"
1040 "The arguments to PROC are \"(key value)\" where key\n"
1041 "and value are successive pairs from the hash table TABLE.")
1042 #define FUNC_NAME s_scm_hash_for_each
1044 SCM_VALIDATE_PROC (1, proc
);
1045 if (!SCM_HASHTABLE_P (table
))
1046 SCM_VALIDATE_VECTOR (2, table
);
1048 scm_internal_hash_for_each_handle (for_each_proc
,
1049 (void *) SCM_UNPACK (proc
),
1051 return SCM_UNSPECIFIED
;
1055 SCM_DEFINE (scm_hash_for_each_handle
, "hash-for-each-handle", 2, 0, 0,
1056 (SCM proc
, SCM table
),
1057 "An iterator over hash-table elements.\n"
1058 "Applies PROC successively on all hash table handles.")
1059 #define FUNC_NAME s_scm_hash_for_each_handle
1061 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
1062 SCM_ASSERT (call
, proc
, 1, FUNC_NAME
);
1063 if (!SCM_HASHTABLE_P (table
))
1064 SCM_VALIDATE_VECTOR (2, table
);
1066 scm_internal_hash_for_each_handle (call
,
1067 (void *) SCM_UNPACK (proc
),
1069 return SCM_UNSPECIFIED
;
1074 map_proc (void *proc
, SCM key
, SCM data
, SCM value
)
1076 return scm_cons (scm_call_2 (SCM_PACK (proc
), key
, data
), value
);
1079 SCM_DEFINE (scm_hash_map_to_list
, "hash-map->list", 2, 0, 0,
1080 (SCM proc
, SCM table
),
1081 "An iterator over hash-table elements.\n"
1082 "Accumulates and returns as a list the results of applying PROC successively.\n"
1083 "The arguments to PROC are \"(key value)\" where key\n"
1084 "and value are successive pairs from the hash table TABLE.")
1085 #define FUNC_NAME s_scm_hash_map_to_list
1087 SCM_VALIDATE_PROC (1, proc
);
1088 if (!SCM_HASHTABLE_P (table
))
1089 SCM_VALIDATE_VECTOR (2, table
);
1090 return scm_internal_hash_fold (map_proc
,
1091 (void *) SCM_UNPACK (proc
),
1101 scm_hashtab_prehistory ()
1103 scm_tc16_hashtable
= scm_make_smob_type (s_hashtable
, 0);
1104 scm_set_smob_mark (scm_tc16_hashtable
, scm_markcdr
);
1105 scm_set_smob_print (scm_tc16_hashtable
, hashtable_print
);
1106 scm_set_smob_free (scm_tc16_hashtable
, hashtable_free
);
1107 scm_c_hook_add (&scm_after_sweep_c_hook
, scan_weak_hashtables
, 0, 0);
1108 scm_c_hook_add (&scm_after_gc_c_hook
, rehash_after_gc
, 0, 0);
1114 #include "libguile/hashtab.x"