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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 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 #define HASHTABLE_SIZE_N 25
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, 28762081,
70 57524111, 115048217, 230096423, 460192829 /* larger values can't be
71 represented as INUMs */
74 /* Turn an empty vector hash table into an opaque resizable one. */
76 static char *s_hashtable
= "hashtable";
78 SCM weak_hashtables
= SCM_EOL
;
81 make_hash_table (int flags
, unsigned long k
, const char *func_name
) {
84 int i
= 0, n
= k
? k
: 31;
85 while (i
< HASHTABLE_SIZE_N
&& n
> hashtable_size
[i
])
87 n
= hashtable_size
[i
];
89 /* The SCM_WVECTF_NOSCAN flag informs the weak vector code not to
90 perform the final scan for broken references. Instead we do
91 that ourselves in scan_weak_hashtables. */
92 vector
= scm_i_allocate_weak_vector (flags
| SCM_WVECTF_NOSCAN
,
97 vector
= scm_c_make_vector (n
, SCM_EOL
);
98 t
= scm_gc_malloc (sizeof (*t
), s_hashtable
);
99 t
->min_size_index
= t
->size_index
= i
;
102 t
->upper
= 9 * n
/ 10;
106 SCM_NEWSMOB3 (table
, scm_tc16_hashtable
, vector
, t
, weak_hashtables
);
107 weak_hashtables
= table
;
110 SCM_NEWSMOB3 (table
, scm_tc16_hashtable
, vector
, t
, SCM_EOL
);
116 scm_i_rehash (SCM table
,
117 unsigned long (*hash_fn
)(),
119 const char* func_name
)
121 SCM buckets
, new_buckets
;
123 unsigned long old_size
;
124 unsigned long new_size
;
126 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
128 /* rehashing is not triggered when i <= min_size */
129 i
= SCM_HASHTABLE (table
)->size_index
;
132 while (i
> SCM_HASHTABLE (table
)->min_size_index
133 && SCM_HASHTABLE_N_ITEMS (table
) < hashtable_size
[i
] / 4);
137 i
= SCM_HASHTABLE (table
)->size_index
+ 1;
138 if (i
>= HASHTABLE_SIZE_N
)
141 /* store for use in rehash_after_gc */
142 SCM_HASHTABLE (table
)->hash_fn
= hash_fn
;
143 SCM_HASHTABLE (table
)->closure
= closure
;
145 SCM_HASHTABLE (table
)->size_index
= i
;
147 new_size
= hashtable_size
[i
];
148 if (i
<= SCM_HASHTABLE (table
)->min_size_index
)
149 SCM_HASHTABLE (table
)->lower
= 0;
151 SCM_HASHTABLE (table
)->lower
= new_size
/ 4;
152 SCM_HASHTABLE (table
)->upper
= 9 * new_size
/ 10;
153 buckets
= SCM_HASHTABLE_VECTOR (table
);
155 if (SCM_HASHTABLE_WEAK_P (table
))
156 new_buckets
= scm_i_allocate_weak_vector (SCM_HASHTABLE_FLAGS (table
)
158 SCM_MAKINUM (new_size
),
162 new_buckets
= scm_c_make_vector (new_size
, SCM_EOL
);
164 old_size
= SCM_VECTOR_LENGTH (buckets
);
165 for (i
= 0; i
< old_size
; ++i
)
167 SCM ls
= SCM_VELTS (buckets
)[i
], handle
;
168 while (!SCM_NULLP (ls
))
171 handle
= SCM_CAR (ls
);
172 h
= hash_fn (SCM_CAR (handle
), new_size
, closure
);
174 scm_out_of_range (func_name
, scm_ulong2num (h
));
175 SCM_VECTOR_SET (new_buckets
, h
,
176 scm_cons (handle
, SCM_VELTS (new_buckets
)[h
]));
180 SCM_SET_HASHTABLE_VECTOR (table
, new_buckets
);
185 hashtable_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
187 scm_t_hashtable
*t
= SCM_HASHTABLE (exp
);
188 scm_puts ("#<", port
);
189 if (SCM_HASHTABLE_WEAK_KEY_P (exp
))
190 scm_puts ("weak-key-", port
);
191 else if (SCM_HASHTABLE_WEAK_VALUE_P (exp
))
192 scm_puts ("weak-value-", port
);
193 else if (SCM_HASHTABLE_DOUBLY_WEAK_P (exp
))
194 scm_puts ("doubly-weak-", port
);
195 scm_puts ("hash-table ", port
);
196 scm_intprint ((unsigned long) t
->n_items
, 10, port
);
197 scm_putc ('/', port
);
198 scm_intprint ((unsigned long) SCM_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp
)),
200 scm_puts (">", port
);
204 #define UNMARKED_CELL_P(x) (SCM_NIMP(x) && !SCM_GC_MARK_P (x))
206 /* keep track of hash tables that need to shrink after scan */
207 static SCM to_rehash
= SCM_EOL
;
209 /* scan hash tables for broken references, remove them, and update
210 hash tables item count */
212 scan_weak_hashtables (void *dummy1 SCM_UNUSED
,
213 void *dummy2 SCM_UNUSED
,
214 void *dummy3 SCM_UNUSED
)
216 SCM
*next
= &weak_hashtables
;
218 while (!SCM_NULLP (h
))
220 if (!SCM_GC_MARK_P (h
))
221 *next
= h
= SCM_HASHTABLE_NEXT (h
);
225 int i
, n
= SCM_HASHTABLE_N_BUCKETS (h
);
226 int weak_car
= SCM_HASHTABLE_FLAGS (h
) & SCM_HASHTABLEF_WEAK_CAR
;
227 int weak_cdr
= SCM_HASHTABLE_FLAGS (h
) & SCM_HASHTABLEF_WEAK_CDR
;
228 int check_size_p
= 0;
229 for (i
= 0; i
< n
; ++i
)
231 SCM
*next_spine
= (SCM
*) &SCM_HASHTABLE_BUCKETS (h
)[i
];
232 for (alist
= *next_spine
;
234 alist
= SCM_CDR (alist
))
235 if ((weak_car
&& UNMARKED_CELL_P (SCM_CAAR (alist
)))
236 || (weak_cdr
&& UNMARKED_CELL_P (SCM_CDAR (alist
))))
238 *next_spine
= SCM_CDR (alist
);
239 SCM_HASHTABLE_DECREMENT (h
);
243 next_spine
= SCM_CDRLOC (alist
);
246 && SCM_HASHTABLE_N_ITEMS (h
) < SCM_HASHTABLE_LOWER (h
))
248 SCM tmp
= SCM_HASHTABLE_NEXT (h
);
249 /* temporarily move table from weak_hashtables to to_rehash */
250 SCM_SET_HASHTABLE_NEXT (h
, to_rehash
);
256 next
= SCM_HASHTABLE_NEXTLOC (h
);
257 h
= SCM_HASHTABLE_NEXT (h
);
265 rehash_after_gc (void *dummy1 SCM_UNUSED
,
266 void *dummy2 SCM_UNUSED
,
267 void *dummy3 SCM_UNUSED
)
269 if (!SCM_NULLP (to_rehash
))
271 SCM first
= to_rehash
, last
, h
;
272 /* important to clear to_rehash here so that we don't get stuck
273 in an infinite loop if scm_i_rehash causes GC */
279 /* use same hash_fn and closure as last time */
280 SCM_HASHTABLE (h
)->hash_fn
,
281 SCM_HASHTABLE (h
)->closure
,
284 h
= SCM_HASHTABLE_NEXT (h
);
285 } while (!SCM_NULLP (h
));
286 /* move tables back to weak_hashtables */
287 SCM_SET_HASHTABLE_NEXT (last
, weak_hashtables
);
288 weak_hashtables
= first
;
294 hashtable_free (SCM obj
)
296 scm_gc_free (SCM_HASHTABLE (obj
), sizeof (scm_t_hashtable
), s_hashtable
);
302 scm_c_make_hash_table (unsigned long k
)
304 return make_hash_table (0, k
, "scm_c_make_hash_table");
307 SCM_DEFINE (scm_make_hash_table
, "make-hash-table", 0, 1, 0,
309 "Make a hash table with optional minimum number of buckets @var{n}\n")
310 #define FUNC_NAME s_scm_make_hash_table
313 return make_hash_table (0, 0, FUNC_NAME
);
317 SCM_VALIDATE_INUM_COPY (1, n
, k
);
318 return make_hash_table (0, k
, FUNC_NAME
);
323 SCM_DEFINE (scm_make_weak_key_hash_table
, "make-weak-key-hash-table", 0, 1, 0,
325 "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
326 "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n"
327 "Return a weak hash table with @var{size} buckets. As with any\n"
328 "hash table, choosing a good size for the table requires some\n"
331 "You can modify weak hash tables in exactly the same way you\n"
332 "would modify regular hash tables. (@pxref{Hash Tables})")
333 #define FUNC_NAME s_scm_make_weak_key_hash_table
336 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
, 0, FUNC_NAME
);
340 SCM_VALIDATE_INUM_COPY (1, n
, k
);
341 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
, k
, FUNC_NAME
);
347 SCM_DEFINE (scm_make_weak_value_hash_table
, "make-weak-value-hash-table", 0, 1, 0,
349 "Return a hash table with weak values with @var{size} buckets.\n"
350 "(@pxref{Hash Tables})")
351 #define FUNC_NAME s_scm_make_weak_value_hash_table
354 return make_hash_table (SCM_HASHTABLEF_WEAK_CDR
, 0, FUNC_NAME
);
358 SCM_VALIDATE_INUM_COPY (1, n
, k
);
359 return make_hash_table (SCM_HASHTABLEF_WEAK_CDR
, k
, FUNC_NAME
);
365 SCM_DEFINE (scm_make_doubly_weak_hash_table
, "make-doubly-weak-hash-table", 1, 0, 0,
367 "Return a hash table with weak keys and values with @var{size}\n"
368 "buckets. (@pxref{Hash Tables})")
369 #define FUNC_NAME s_scm_make_doubly_weak_hash_table
372 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
378 SCM_VALIDATE_INUM_COPY (1, n
, k
);
379 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
387 SCM_DEFINE (scm_hash_table_p
, "hash-table?", 1, 0, 0,
389 "Return @code{#t} if @var{obj} is a hash table.")
390 #define FUNC_NAME s_scm_hash_table_p
392 return SCM_BOOL (SCM_HASHTABLE_P (obj
));
397 SCM_DEFINE (scm_weak_key_hash_table_p
, "weak-key-hash-table?", 1, 0, 0,
399 "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n"
400 "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n"
401 "Return @code{#t} if @var{obj} is the specified weak hash\n"
402 "table. Note that a doubly weak hash table is neither a weak key\n"
403 "nor a weak value hash table.")
404 #define FUNC_NAME s_scm_weak_key_hash_table_p
406 return SCM_BOOL (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_KEY_P (obj
));
411 SCM_DEFINE (scm_weak_value_hash_table_p
, "weak-value-hash-table?", 1, 0, 0,
413 "Return @code{#t} if @var{obj} is a weak value hash table.")
414 #define FUNC_NAME s_scm_weak_value_hash_table_p
416 return SCM_BOOL (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_VALUE_P (obj
));
421 SCM_DEFINE (scm_doubly_weak_hash_table_p
, "doubly-weak-hash-table?", 1, 0, 0,
423 "Return @code{#t} if @var{obj} is a doubly weak hash table.")
424 #define FUNC_NAME s_scm_doubly_weak_hash_table_p
426 return SCM_BOOL (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_DOUBLY_WEAK_P (obj
));
432 scm_hash_fn_get_handle (SCM table
, SCM obj
, unsigned long (*hash_fn
)(), SCM (*assoc_fn
)(), void * closure
)
433 #define FUNC_NAME "scm_hash_fn_get_handle"
438 if (SCM_HASHTABLE_P (table
))
439 table
= SCM_HASHTABLE_VECTOR (table
);
441 SCM_VALIDATE_VECTOR (1, table
);
442 if (SCM_VECTOR_LENGTH (table
) == 0)
444 k
= hash_fn (obj
, SCM_VECTOR_LENGTH (table
), closure
);
445 if (k
>= SCM_VECTOR_LENGTH (table
))
446 scm_out_of_range ("hash_fn_get_handle", scm_ulong2num (k
));
447 h
= assoc_fn (obj
, SCM_VELTS (table
)[k
], closure
);
454 scm_hash_fn_create_handle_x (SCM table
, SCM obj
, SCM init
, unsigned long (*hash_fn
)(),
455 SCM (*assoc_fn
)(), void * closure
)
456 #define FUNC_NAME "scm_hash_fn_create_handle_x"
461 if (SCM_HASHTABLE_P (table
))
462 buckets
= SCM_HASHTABLE_VECTOR (table
);
465 SCM_ASSERT (SCM_VECTORP (table
),
466 table
, SCM_ARG1
, "hash_fn_create_handle_x");
469 if (SCM_VECTOR_LENGTH (buckets
) == 0)
470 SCM_MISC_ERROR ("void hashtable", SCM_EOL
);
472 k
= hash_fn (obj
, SCM_VECTOR_LENGTH (buckets
), closure
);
473 if (k
>= SCM_VECTOR_LENGTH (buckets
))
474 scm_out_of_range ("hash_fn_create_handle_x", scm_ulong2num (k
));
475 it
= assoc_fn (obj
, SCM_VELTS (buckets
)[k
], closure
);
476 if (!SCM_FALSEP (it
))
480 SCM old_bucket
= SCM_VELTS (buckets
)[k
];
481 SCM new_bucket
= scm_acons (obj
, init
, old_bucket
);
482 SCM_VECTOR_SET (buckets
, k
, new_bucket
);
483 if (table
!= buckets
)
485 SCM_HASHTABLE_INCREMENT (table
);
486 if (SCM_HASHTABLE_N_ITEMS (table
) > SCM_HASHTABLE_UPPER (table
))
487 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
489 return SCM_CAR (new_bucket
);
496 scm_hash_fn_ref (SCM table
, SCM obj
, SCM dflt
, unsigned long (*hash_fn
)(),
497 SCM (*assoc_fn
)(), void * closure
)
499 SCM it
= scm_hash_fn_get_handle (table
, obj
, hash_fn
, assoc_fn
, closure
);
510 scm_hash_fn_set_x (SCM table
, SCM obj
, SCM val
, unsigned long (*hash_fn
)(),
511 SCM (*assoc_fn
)(), void * closure
)
515 it
= scm_hash_fn_create_handle_x (table
, obj
, SCM_BOOL_F
, hash_fn
, assoc_fn
, closure
);
516 SCM_SETCDR (it
, val
);
525 scm_hash_fn_remove_x (SCM table
, SCM obj
, unsigned long (*hash_fn
)(), SCM (*assoc_fn
)(),
526 SCM (*delete_fn
)(), void * closure
)
531 if (SCM_HASHTABLE_P (table
))
532 buckets
= SCM_HASHTABLE_VECTOR (table
);
535 SCM_ASSERT (SCM_VECTORP (table
), table
, SCM_ARG1
, "hash_fn_remove_x");
538 if (SCM_VECTOR_LENGTH (table
) == 0)
541 k
= hash_fn (obj
, SCM_VECTOR_LENGTH (buckets
), closure
);
542 if (k
>= SCM_VECTOR_LENGTH (buckets
))
543 scm_out_of_range ("hash_fn_remove_x", scm_ulong2num (k
));
544 h
= assoc_fn (obj
, SCM_VELTS (buckets
)[k
], closure
);
547 SCM_VECTOR_SET (buckets
, k
, delete_fn (h
, SCM_VELTS (buckets
)[k
]));
548 if (table
!= buckets
)
550 SCM_HASHTABLE_DECREMENT (table
);
551 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
552 scm_i_rehash (table
, hash_fn
, closure
, "scm_hash_fn_remove_x");
558 SCM_DEFINE (scm_hash_clear_x
, "hash-clear!", 1, 0, 0,
560 "Remove all items from TABLE (without triggering a resize).")
561 #define FUNC_NAME s_scm_hash_clear_x
563 SCM_VALIDATE_HASHTABLE (1, table
);
564 scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table
), SCM_EOL
);
565 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
566 return SCM_UNSPECIFIED
;
572 SCM_DEFINE (scm_hashq_get_handle
, "hashq-get-handle", 2, 0, 0,
573 (SCM table
, SCM key
),
574 "This procedure returns the @code{(key . value)} pair from the\n"
575 "hash table @var{table}. If @var{table} does not hold an\n"
576 "associated value for @var{key}, @code{#f} is returned.\n"
577 "Uses @code{eq?} for equality testing.")
578 #define FUNC_NAME s_scm_hashq_get_handle
580 return scm_hash_fn_get_handle (table
, key
, scm_ihashq
, scm_sloppy_assq
, 0);
585 SCM_DEFINE (scm_hashq_create_handle_x
, "hashq-create-handle!", 3, 0, 0,
586 (SCM table
, SCM key
, SCM init
),
587 "This function looks up @var{key} in @var{table} and returns its handle.\n"
588 "If @var{key} is not already present, a new handle is created which\n"
589 "associates @var{key} with @var{init}.")
590 #define FUNC_NAME s_scm_hashq_create_handle_x
592 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashq
, scm_sloppy_assq
, 0);
597 SCM_DEFINE (scm_hashq_ref
, "hashq-ref", 2, 1, 0,
598 (SCM table
, SCM key
, SCM dflt
),
599 "Look up @var{key} in the hash table @var{table}, and return the\n"
600 "value (if any) associated with it. If @var{key} is not found,\n"
601 "return @var{default} (or @code{#f} if no @var{default} argument\n"
602 "is supplied). Uses @code{eq?} for equality testing.")
603 #define FUNC_NAME s_scm_hashq_ref
605 if (SCM_UNBNDP (dflt
))
607 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashq
, scm_sloppy_assq
, 0);
613 SCM_DEFINE (scm_hashq_set_x
, "hashq-set!", 3, 0, 0,
614 (SCM table
, SCM key
, SCM val
),
615 "Find the entry in @var{table} associated with @var{key}, and\n"
616 "store @var{value} there. Uses @code{eq?} for equality testing.")
617 #define FUNC_NAME s_scm_hashq_set_x
619 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashq
, scm_sloppy_assq
, 0);
625 SCM_DEFINE (scm_hashq_remove_x
, "hashq-remove!", 2, 0, 0,
626 (SCM table
, SCM key
),
627 "Remove @var{key} (and any value associated with it) from\n"
628 "@var{table}. Uses @code{eq?} for equality tests.")
629 #define FUNC_NAME s_scm_hashq_remove_x
631 return scm_hash_fn_remove_x (table
, key
, scm_ihashq
, scm_sloppy_assq
,
639 SCM_DEFINE (scm_hashv_get_handle
, "hashv-get-handle", 2, 0, 0,
640 (SCM table
, SCM key
),
641 "This procedure returns the @code{(key . value)} pair from the\n"
642 "hash table @var{table}. If @var{table} does not hold an\n"
643 "associated value for @var{key}, @code{#f} is returned.\n"
644 "Uses @code{eqv?} for equality testing.")
645 #define FUNC_NAME s_scm_hashv_get_handle
647 return scm_hash_fn_get_handle (table
, key
, scm_ihashv
, scm_sloppy_assv
, 0);
652 SCM_DEFINE (scm_hashv_create_handle_x
, "hashv-create-handle!", 3, 0, 0,
653 (SCM table
, SCM key
, SCM init
),
654 "This function looks up @var{key} in @var{table} and returns its handle.\n"
655 "If @var{key} is not already present, a new handle is created which\n"
656 "associates @var{key} with @var{init}.")
657 #define FUNC_NAME s_scm_hashv_create_handle_x
659 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashv
,
665 SCM_DEFINE (scm_hashv_ref
, "hashv-ref", 2, 1, 0,
666 (SCM table
, SCM key
, SCM dflt
),
667 "Look up @var{key} in the hash table @var{table}, and return the\n"
668 "value (if any) associated with it. If @var{key} is not found,\n"
669 "return @var{default} (or @code{#f} if no @var{default} argument\n"
670 "is supplied). Uses @code{eqv?} for equality testing.")
671 #define FUNC_NAME s_scm_hashv_ref
673 if (SCM_UNBNDP (dflt
))
675 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashv
, scm_sloppy_assv
, 0);
681 SCM_DEFINE (scm_hashv_set_x
, "hashv-set!", 3, 0, 0,
682 (SCM table
, SCM key
, SCM val
),
683 "Find the entry in @var{table} associated with @var{key}, and\n"
684 "store @var{value} there. Uses @code{eqv?} for equality testing.")
685 #define FUNC_NAME s_scm_hashv_set_x
687 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashv
, scm_sloppy_assv
, 0);
692 SCM_DEFINE (scm_hashv_remove_x
, "hashv-remove!", 2, 0, 0,
693 (SCM table
, SCM key
),
694 "Remove @var{key} (and any value associated with it) from\n"
695 "@var{table}. Uses @code{eqv?} for equality tests.")
696 #define FUNC_NAME s_scm_hashv_remove_x
698 return scm_hash_fn_remove_x (table
, key
, scm_ihashv
, scm_sloppy_assv
,
705 SCM_DEFINE (scm_hash_get_handle
, "hash-get-handle", 2, 0, 0,
706 (SCM table
, SCM key
),
707 "This procedure returns the @code{(key . value)} pair from the\n"
708 "hash table @var{table}. If @var{table} does not hold an\n"
709 "associated value for @var{key}, @code{#f} is returned.\n"
710 "Uses @code{equal?} for equality testing.")
711 #define FUNC_NAME s_scm_hash_get_handle
713 return scm_hash_fn_get_handle (table
, key
, scm_ihash
, scm_sloppy_assoc
, 0);
718 SCM_DEFINE (scm_hash_create_handle_x
, "hash-create-handle!", 3, 0, 0,
719 (SCM table
, SCM key
, SCM init
),
720 "This function looks up @var{key} in @var{table} and returns its handle.\n"
721 "If @var{key} is not already present, a new handle is created which\n"
722 "associates @var{key} with @var{init}.")
723 #define FUNC_NAME s_scm_hash_create_handle_x
725 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihash
, scm_sloppy_assoc
, 0);
730 SCM_DEFINE (scm_hash_ref
, "hash-ref", 2, 1, 0,
731 (SCM table
, SCM key
, SCM dflt
),
732 "Look up @var{key} in the hash table @var{table}, and return the\n"
733 "value (if any) associated with it. If @var{key} is not found,\n"
734 "return @var{default} (or @code{#f} if no @var{default} argument\n"
735 "is supplied). Uses @code{equal?} for equality testing.")
736 #define FUNC_NAME s_scm_hash_ref
738 if (SCM_UNBNDP (dflt
))
740 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihash
, scm_sloppy_assoc
, 0);
746 SCM_DEFINE (scm_hash_set_x
, "hash-set!", 3, 0, 0,
747 (SCM table
, SCM key
, SCM val
),
748 "Find the entry in @var{table} associated with @var{key}, and\n"
749 "store @var{value} there. Uses @code{equal?} for equality\n"
751 #define FUNC_NAME s_scm_hash_set_x
753 return scm_hash_fn_set_x (table
, key
, val
, scm_ihash
, scm_sloppy_assoc
, 0);
759 SCM_DEFINE (scm_hash_remove_x
, "hash-remove!", 2, 0, 0,
760 (SCM table
, SCM key
),
761 "Remove @var{key} (and any value associated with it) from\n"
762 "@var{table}. Uses @code{equal?} for equality tests.")
763 #define FUNC_NAME s_scm_hash_remove_x
765 return scm_hash_fn_remove_x (table
, key
, scm_ihash
, scm_sloppy_assoc
,
773 typedef struct scm_t_ihashx_closure
778 } scm_t_ihashx_closure
;
783 scm_ihashx (SCM obj
, unsigned long n
, scm_t_ihashx_closure
*closure
)
785 SCM answer
= scm_call_2 (closure
->hash
,
787 scm_ulong2num ((unsigned long) n
));
788 return SCM_INUM (answer
);
794 scm_sloppy_assx (SCM obj
, SCM alist
, scm_t_ihashx_closure
*closure
)
796 return scm_call_2 (closure
->assoc
, obj
, alist
);
803 scm_delx_x (SCM obj
, SCM alist
, scm_t_ihashx_closure
*closure
)
805 return scm_call_2 (closure
->delete, obj
, alist
);
810 SCM_DEFINE (scm_hashx_get_handle
, "hashx-get-handle", 4, 0, 0,
811 (SCM hash
, SCM assoc
, SCM table
, SCM key
),
812 "This behaves the same way as the corresponding\n"
813 "@code{-get-handle} function, but uses @var{hash} as a hash\n"
814 "function and @var{assoc} to compare keys. @code{hash} must be\n"
815 "a function that takes two arguments, a key to be hashed and a\n"
816 "table size. @code{assoc} must be an associator function, like\n"
817 "@code{assoc}, @code{assq} or @code{assv}.")
818 #define FUNC_NAME s_scm_hashx_get_handle
820 scm_t_ihashx_closure closure
;
822 closure
.assoc
= assoc
;
823 return scm_hash_fn_get_handle (table
, key
, scm_ihashx
, scm_sloppy_assx
,
829 SCM_DEFINE (scm_hashx_create_handle_x
, "hashx-create-handle!", 5, 0, 0,
830 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM init
),
831 "This behaves the same way as the corresponding\n"
832 "@code{-create-handle} function, but uses @var{hash} as a hash\n"
833 "function and @var{assoc} to compare keys. @code{hash} must be\n"
834 "a function that takes two arguments, a key to be hashed and a\n"
835 "table size. @code{assoc} must be an associator function, like\n"
836 "@code{assoc}, @code{assq} or @code{assv}.")
837 #define FUNC_NAME s_scm_hashx_create_handle_x
839 scm_t_ihashx_closure closure
;
841 closure
.assoc
= assoc
;
842 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashx
,
843 scm_sloppy_assx
, (void *)&closure
);
849 SCM_DEFINE (scm_hashx_ref
, "hashx-ref", 4, 1, 0,
850 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM dflt
),
851 "This behaves the same way as the corresponding @code{ref}\n"
852 "function, but uses @var{hash} as a hash function and\n"
853 "@var{assoc} to compare keys. @code{hash} must be a function\n"
854 "that takes two arguments, a key to be hashed and a table size.\n"
855 "@code{assoc} must be an associator function, like @code{assoc},\n"
856 "@code{assq} or @code{assv}.\n"
858 "By way of illustration, @code{hashq-ref table key} is\n"
859 "equivalent to @code{hashx-ref hashq assq table key}.")
860 #define FUNC_NAME s_scm_hashx_ref
862 scm_t_ihashx_closure closure
;
863 if (SCM_UNBNDP (dflt
))
866 closure
.assoc
= assoc
;
867 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashx
, scm_sloppy_assx
,
875 SCM_DEFINE (scm_hashx_set_x
, "hashx-set!", 5, 0, 0,
876 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM val
),
877 "This behaves the same way as the corresponding @code{set!}\n"
878 "function, but uses @var{hash} as a hash function and\n"
879 "@var{assoc} to compare keys. @code{hash} must be a function\n"
880 "that takes two arguments, a key to be hashed and a table size.\n"
881 "@code{assoc} must be an associator function, like @code{assoc},\n"
882 "@code{assq} or @code{assv}.\n"
884 " By way of illustration, @code{hashq-set! table key} is\n"
885 "equivalent to @code{hashx-set! hashq assq table key}.")
886 #define FUNC_NAME s_scm_hashx_set_x
888 scm_t_ihashx_closure closure
;
890 closure
.assoc
= assoc
;
891 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashx
, scm_sloppy_assx
,
899 scm_hashx_remove_x (SCM hash
, SCM assoc
, SCM
delete, SCM table
, SCM obj
)
901 scm_t_ihashx_closure closure
;
903 closure
.assoc
= assoc
;
904 closure
.delete = delete;
905 return scm_hash_fn_remove_x (table
, obj
, scm_ihashx
, scm_sloppy_assx
, scm_delx_x
, 0);
908 /* Hash table iterators */
910 static const char s_scm_hash_fold
[];
913 scm_internal_hash_fold (SCM (*fn
) (), void *closure
, SCM init
, SCM table
)
916 SCM buckets
, result
= init
;
918 if (SCM_HASHTABLE_P (table
))
919 buckets
= SCM_HASHTABLE_VECTOR (table
);
923 n
= SCM_VECTOR_LENGTH (buckets
);
924 for (i
= 0; i
< n
; ++i
)
926 SCM ls
= SCM_VELTS (buckets
)[i
], handle
;
927 while (!SCM_NULLP (ls
))
930 scm_wrong_type_arg (s_scm_hash_fold
, SCM_ARG3
, buckets
);
931 handle
= SCM_CAR (ls
);
932 if (!SCM_CONSP (handle
))
933 scm_wrong_type_arg (s_scm_hash_fold
, SCM_ARG3
, buckets
);
934 result
= fn (closure
, SCM_CAR (handle
), SCM_CDR (handle
), result
);
942 /* The following redundant code is here in order to be able to support
943 hash-for-each-handle. An alternative would have been to replace
944 this code and scm_internal_hash_fold above with a single
945 scm_internal_hash_fold_handles, but we don't want to promote such
948 static const char s_scm_hash_for_each
[];
951 scm_internal_hash_for_each_handle (SCM (*fn
) (), void *closure
, SCM table
)
956 if (SCM_HASHTABLE_P (table
))
957 buckets
= SCM_HASHTABLE_VECTOR (table
);
961 n
= SCM_VECTOR_LENGTH (buckets
);
962 for (i
= 0; i
< n
; ++i
)
964 SCM ls
= SCM_VELTS (buckets
)[i
], handle
;
965 while (!SCM_NULLP (ls
))
968 scm_wrong_type_arg (s_scm_hash_for_each
, SCM_ARG3
, buckets
);
969 handle
= SCM_CAR (ls
);
970 if (!SCM_CONSP (handle
))
971 scm_wrong_type_arg (s_scm_hash_for_each
, SCM_ARG3
, buckets
);
972 fn (closure
, handle
);
978 SCM_DEFINE (scm_hash_fold
, "hash-fold", 3, 0, 0,
979 (SCM proc
, SCM init
, SCM table
),
980 "An iterator over hash-table elements.\n"
981 "Accumulates and returns a result by applying PROC successively.\n"
982 "The arguments to PROC are \"(key value prior-result)\" where key\n"
983 "and value are successive pairs from the hash table TABLE, and\n"
984 "prior-result is either INIT (for the first application of PROC)\n"
985 "or the return value of the previous application of PROC.\n"
986 "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
987 "table into an a-list of key-value pairs.")
988 #define FUNC_NAME s_scm_hash_fold
990 SCM_VALIDATE_PROC (1, proc
);
991 if (!SCM_HASHTABLE_P (table
))
992 SCM_VALIDATE_VECTOR (3, table
);
993 return scm_internal_hash_fold (scm_call_3
, (void *) SCM_UNPACK (proc
), init
, table
);
998 for_each_proc (void *proc
, SCM handle
)
1000 return scm_call_2 (SCM_PACK (proc
), SCM_CAR (handle
), SCM_CDR (handle
));
1003 SCM_DEFINE (scm_hash_for_each
, "hash-for-each", 2, 0, 0,
1004 (SCM proc
, SCM table
),
1005 "An iterator over hash-table elements.\n"
1006 "Applies PROC successively on all hash table items.\n"
1007 "The arguments to PROC are \"(key value)\" where key\n"
1008 "and value are successive pairs from the hash table TABLE.")
1009 #define FUNC_NAME s_scm_hash_for_each
1011 SCM_VALIDATE_PROC (1, proc
);
1012 if (!SCM_HASHTABLE_P (table
))
1013 SCM_VALIDATE_VECTOR (2, table
);
1015 scm_internal_hash_for_each_handle (for_each_proc
,
1016 (void *) SCM_UNPACK (proc
),
1018 return SCM_UNSPECIFIED
;
1022 SCM_DEFINE (scm_hash_for_each_handle
, "hash-for-each-handle", 2, 0, 0,
1023 (SCM proc
, SCM table
),
1024 "An iterator over hash-table elements.\n"
1025 "Applies PROC successively on all hash table handles.")
1026 #define FUNC_NAME s_scm_hash_for_each_handle
1028 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
1029 SCM_ASSERT (call
, proc
, 1, FUNC_NAME
);
1030 if (!SCM_HASHTABLE_P (table
))
1031 SCM_VALIDATE_VECTOR (2, table
);
1033 scm_internal_hash_for_each_handle (call
,
1034 (void *) SCM_UNPACK (proc
),
1036 return SCM_UNSPECIFIED
;
1041 map_proc (void *proc
, SCM key
, SCM data
, SCM value
)
1043 return scm_cons (scm_call_2 (SCM_PACK (proc
), key
, data
), value
);
1046 SCM_DEFINE (scm_hash_map_to_list
, "hash-map->list", 2, 0, 0,
1047 (SCM proc
, SCM table
),
1048 "An iterator over hash-table elements.\n"
1049 "Accumulates and returns as a list the results of applying PROC successively.\n"
1050 "The arguments to PROC are \"(key value)\" where key\n"
1051 "and value are successive pairs from the hash table TABLE.")
1052 #define FUNC_NAME s_scm_hash_map_to_list
1054 SCM_VALIDATE_PROC (1, proc
);
1055 if (!SCM_HASHTABLE_P (table
))
1056 SCM_VALIDATE_VECTOR (2, table
);
1057 return scm_internal_hash_fold (map_proc
,
1058 (void *) SCM_UNPACK (proc
),
1068 scm_hashtab_prehistory ()
1070 scm_tc16_hashtable
= scm_make_smob_type (s_hashtable
, 0);
1071 scm_set_smob_mark (scm_tc16_hashtable
, scm_markcdr
);
1072 scm_set_smob_print (scm_tc16_hashtable
, hashtable_print
);
1073 scm_set_smob_free (scm_tc16_hashtable
, hashtable_free
);
1074 scm_c_hook_add (&scm_after_sweep_c_hook
, scan_weak_hashtables
, 0, 0);
1075 scm_c_hook_add (&scm_after_gc_c_hook
, rehash_after_gc
, 0, 0);
1081 #include "libguile/hashtab.x"