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_from_ulong (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_from_ulong (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
);
315 return make_hash_table (0, scm_to_ulong (n
), FUNC_NAME
);
319 SCM_DEFINE (scm_make_weak_key_hash_table
, "make-weak-key-hash-table", 0, 1, 0,
321 "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
322 "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n"
323 "Return a weak hash table with @var{size} buckets. As with any\n"
324 "hash table, choosing a good size for the table requires some\n"
327 "You can modify weak hash tables in exactly the same way you\n"
328 "would modify regular hash tables. (@pxref{Hash Tables})")
329 #define FUNC_NAME s_scm_make_weak_key_hash_table
332 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
, 0, FUNC_NAME
);
334 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
,
335 scm_to_ulong (n
), FUNC_NAME
);
340 SCM_DEFINE (scm_make_weak_value_hash_table
, "make-weak-value-hash-table", 0, 1, 0,
342 "Return a hash table with weak values with @var{size} buckets.\n"
343 "(@pxref{Hash Tables})")
344 #define FUNC_NAME s_scm_make_weak_value_hash_table
347 return make_hash_table (SCM_HASHTABLEF_WEAK_CDR
, 0, FUNC_NAME
);
350 return make_hash_table (SCM_HASHTABLEF_WEAK_CDR
,
351 scm_to_ulong (n
), FUNC_NAME
);
357 SCM_DEFINE (scm_make_doubly_weak_hash_table
, "make-doubly-weak-hash-table", 1, 0, 0,
359 "Return a hash table with weak keys and values with @var{size}\n"
360 "buckets. (@pxref{Hash Tables})")
361 #define FUNC_NAME s_scm_make_doubly_weak_hash_table
364 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
369 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
377 SCM_DEFINE (scm_hash_table_p
, "hash-table?", 1, 0, 0,
379 "Return @code{#t} if @var{obj} is a hash table.")
380 #define FUNC_NAME s_scm_hash_table_p
382 return scm_from_bool (SCM_HASHTABLE_P (obj
));
387 SCM_DEFINE (scm_weak_key_hash_table_p
, "weak-key-hash-table?", 1, 0, 0,
389 "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n"
390 "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n"
391 "Return @code{#t} if @var{obj} is the specified weak hash\n"
392 "table. Note that a doubly weak hash table is neither a weak key\n"
393 "nor a weak value hash table.")
394 #define FUNC_NAME s_scm_weak_key_hash_table_p
396 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_KEY_P (obj
));
401 SCM_DEFINE (scm_weak_value_hash_table_p
, "weak-value-hash-table?", 1, 0, 0,
403 "Return @code{#t} if @var{obj} is a weak value hash table.")
404 #define FUNC_NAME s_scm_weak_value_hash_table_p
406 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_VALUE_P (obj
));
411 SCM_DEFINE (scm_doubly_weak_hash_table_p
, "doubly-weak-hash-table?", 1, 0, 0,
413 "Return @code{#t} if @var{obj} is a doubly weak hash table.")
414 #define FUNC_NAME s_scm_doubly_weak_hash_table_p
416 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_DOUBLY_WEAK_P (obj
));
422 scm_hash_fn_get_handle (SCM table
, SCM obj
, unsigned long (*hash_fn
)(), SCM (*assoc_fn
)(), void * closure
)
423 #define FUNC_NAME "scm_hash_fn_get_handle"
428 if (SCM_HASHTABLE_P (table
))
429 table
= SCM_HASHTABLE_VECTOR (table
);
431 SCM_VALIDATE_VECTOR (1, table
);
432 if (SCM_VECTOR_LENGTH (table
) == 0)
434 k
= hash_fn (obj
, SCM_VECTOR_LENGTH (table
), closure
);
435 if (k
>= SCM_VECTOR_LENGTH (table
))
436 scm_out_of_range ("hash_fn_get_handle", scm_from_ulong (k
));
437 h
= assoc_fn (obj
, SCM_VELTS (table
)[k
], closure
);
444 scm_hash_fn_create_handle_x (SCM table
, SCM obj
, SCM init
, unsigned long (*hash_fn
)(),
445 SCM (*assoc_fn
)(), void * closure
)
446 #define FUNC_NAME "scm_hash_fn_create_handle_x"
451 if (SCM_HASHTABLE_P (table
))
452 buckets
= SCM_HASHTABLE_VECTOR (table
);
455 SCM_ASSERT (SCM_VECTORP (table
),
456 table
, SCM_ARG1
, "hash_fn_create_handle_x");
459 if (SCM_VECTOR_LENGTH (buckets
) == 0)
460 SCM_MISC_ERROR ("void hashtable", SCM_EOL
);
462 k
= hash_fn (obj
, SCM_VECTOR_LENGTH (buckets
), closure
);
463 if (k
>= SCM_VECTOR_LENGTH (buckets
))
464 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
465 it
= assoc_fn (obj
, SCM_VELTS (buckets
)[k
], closure
);
466 if (scm_is_true (it
))
470 SCM old_bucket
= SCM_VELTS (buckets
)[k
];
471 SCM new_bucket
= scm_acons (obj
, init
, old_bucket
);
472 SCM_VECTOR_SET (buckets
, k
, new_bucket
);
473 if (table
!= buckets
)
475 SCM_HASHTABLE_INCREMENT (table
);
476 if (SCM_HASHTABLE_N_ITEMS (table
) > SCM_HASHTABLE_UPPER (table
))
477 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
479 return SCM_CAR (new_bucket
);
486 scm_hash_fn_ref (SCM table
, SCM obj
, SCM dflt
, unsigned long (*hash_fn
)(),
487 SCM (*assoc_fn
)(), void * closure
)
489 SCM it
= scm_hash_fn_get_handle (table
, obj
, hash_fn
, assoc_fn
, closure
);
500 scm_hash_fn_set_x (SCM table
, SCM obj
, SCM val
, unsigned long (*hash_fn
)(),
501 SCM (*assoc_fn
)(), void * closure
)
505 it
= scm_hash_fn_create_handle_x (table
, obj
, SCM_BOOL_F
, hash_fn
, assoc_fn
, closure
);
506 SCM_SETCDR (it
, val
);
515 scm_hash_fn_remove_x (SCM table
, SCM obj
, unsigned long (*hash_fn
)(), SCM (*assoc_fn
)(),
516 SCM (*delete_fn
)(), void * closure
)
521 if (SCM_HASHTABLE_P (table
))
522 buckets
= SCM_HASHTABLE_VECTOR (table
);
525 SCM_ASSERT (SCM_VECTORP (table
), table
, SCM_ARG1
, "hash_fn_remove_x");
528 if (SCM_VECTOR_LENGTH (table
) == 0)
531 k
= hash_fn (obj
, SCM_VECTOR_LENGTH (buckets
), closure
);
532 if (k
>= SCM_VECTOR_LENGTH (buckets
))
533 scm_out_of_range ("hash_fn_remove_x", scm_from_ulong (k
));
534 h
= assoc_fn (obj
, SCM_VELTS (buckets
)[k
], closure
);
537 SCM_VECTOR_SET (buckets
, k
, delete_fn (h
, SCM_VELTS (buckets
)[k
]));
538 if (table
!= buckets
)
540 SCM_HASHTABLE_DECREMENT (table
);
541 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
542 scm_i_rehash (table
, hash_fn
, closure
, "scm_hash_fn_remove_x");
548 SCM_DEFINE (scm_hash_clear_x
, "hash-clear!", 1, 0, 0,
550 "Remove all items from TABLE (without triggering a resize).")
551 #define FUNC_NAME s_scm_hash_clear_x
553 SCM_VALIDATE_HASHTABLE (1, table
);
554 scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table
), SCM_EOL
);
555 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
556 return SCM_UNSPECIFIED
;
562 SCM_DEFINE (scm_hashq_get_handle
, "hashq-get-handle", 2, 0, 0,
563 (SCM table
, SCM key
),
564 "This procedure returns the @code{(key . value)} pair from the\n"
565 "hash table @var{table}. If @var{table} does not hold an\n"
566 "associated value for @var{key}, @code{#f} is returned.\n"
567 "Uses @code{eq?} for equality testing.")
568 #define FUNC_NAME s_scm_hashq_get_handle
570 return scm_hash_fn_get_handle (table
, key
, scm_ihashq
, scm_sloppy_assq
, 0);
575 SCM_DEFINE (scm_hashq_create_handle_x
, "hashq-create-handle!", 3, 0, 0,
576 (SCM table
, SCM key
, SCM init
),
577 "This function looks up @var{key} in @var{table} and returns its handle.\n"
578 "If @var{key} is not already present, a new handle is created which\n"
579 "associates @var{key} with @var{init}.")
580 #define FUNC_NAME s_scm_hashq_create_handle_x
582 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashq
, scm_sloppy_assq
, 0);
587 SCM_DEFINE (scm_hashq_ref
, "hashq-ref", 2, 1, 0,
588 (SCM table
, SCM key
, SCM dflt
),
589 "Look up @var{key} in the hash table @var{table}, and return the\n"
590 "value (if any) associated with it. If @var{key} is not found,\n"
591 "return @var{default} (or @code{#f} if no @var{default} argument\n"
592 "is supplied). Uses @code{eq?} for equality testing.")
593 #define FUNC_NAME s_scm_hashq_ref
595 if (SCM_UNBNDP (dflt
))
597 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashq
, scm_sloppy_assq
, 0);
603 SCM_DEFINE (scm_hashq_set_x
, "hashq-set!", 3, 0, 0,
604 (SCM table
, SCM key
, SCM val
),
605 "Find the entry in @var{table} associated with @var{key}, and\n"
606 "store @var{value} there. Uses @code{eq?} for equality testing.")
607 #define FUNC_NAME s_scm_hashq_set_x
609 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashq
, scm_sloppy_assq
, 0);
615 SCM_DEFINE (scm_hashq_remove_x
, "hashq-remove!", 2, 0, 0,
616 (SCM table
, SCM key
),
617 "Remove @var{key} (and any value associated with it) from\n"
618 "@var{table}. Uses @code{eq?} for equality tests.")
619 #define FUNC_NAME s_scm_hashq_remove_x
621 return scm_hash_fn_remove_x (table
, key
, scm_ihashq
, scm_sloppy_assq
,
629 SCM_DEFINE (scm_hashv_get_handle
, "hashv-get-handle", 2, 0, 0,
630 (SCM table
, SCM key
),
631 "This procedure returns the @code{(key . value)} pair from the\n"
632 "hash table @var{table}. If @var{table} does not hold an\n"
633 "associated value for @var{key}, @code{#f} is returned.\n"
634 "Uses @code{eqv?} for equality testing.")
635 #define FUNC_NAME s_scm_hashv_get_handle
637 return scm_hash_fn_get_handle (table
, key
, scm_ihashv
, scm_sloppy_assv
, 0);
642 SCM_DEFINE (scm_hashv_create_handle_x
, "hashv-create-handle!", 3, 0, 0,
643 (SCM table
, SCM key
, SCM init
),
644 "This function looks up @var{key} in @var{table} and returns its handle.\n"
645 "If @var{key} is not already present, a new handle is created which\n"
646 "associates @var{key} with @var{init}.")
647 #define FUNC_NAME s_scm_hashv_create_handle_x
649 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashv
,
655 SCM_DEFINE (scm_hashv_ref
, "hashv-ref", 2, 1, 0,
656 (SCM table
, SCM key
, SCM dflt
),
657 "Look up @var{key} in the hash table @var{table}, and return the\n"
658 "value (if any) associated with it. If @var{key} is not found,\n"
659 "return @var{default} (or @code{#f} if no @var{default} argument\n"
660 "is supplied). Uses @code{eqv?} for equality testing.")
661 #define FUNC_NAME s_scm_hashv_ref
663 if (SCM_UNBNDP (dflt
))
665 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashv
, scm_sloppy_assv
, 0);
671 SCM_DEFINE (scm_hashv_set_x
, "hashv-set!", 3, 0, 0,
672 (SCM table
, SCM key
, SCM val
),
673 "Find the entry in @var{table} associated with @var{key}, and\n"
674 "store @var{value} there. Uses @code{eqv?} for equality testing.")
675 #define FUNC_NAME s_scm_hashv_set_x
677 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashv
, scm_sloppy_assv
, 0);
682 SCM_DEFINE (scm_hashv_remove_x
, "hashv-remove!", 2, 0, 0,
683 (SCM table
, SCM key
),
684 "Remove @var{key} (and any value associated with it) from\n"
685 "@var{table}. Uses @code{eqv?} for equality tests.")
686 #define FUNC_NAME s_scm_hashv_remove_x
688 return scm_hash_fn_remove_x (table
, key
, scm_ihashv
, scm_sloppy_assv
,
695 SCM_DEFINE (scm_hash_get_handle
, "hash-get-handle", 2, 0, 0,
696 (SCM table
, SCM key
),
697 "This procedure returns the @code{(key . value)} pair from the\n"
698 "hash table @var{table}. If @var{table} does not hold an\n"
699 "associated value for @var{key}, @code{#f} is returned.\n"
700 "Uses @code{equal?} for equality testing.")
701 #define FUNC_NAME s_scm_hash_get_handle
703 return scm_hash_fn_get_handle (table
, key
, scm_ihash
, scm_sloppy_assoc
, 0);
708 SCM_DEFINE (scm_hash_create_handle_x
, "hash-create-handle!", 3, 0, 0,
709 (SCM table
, SCM key
, SCM init
),
710 "This function looks up @var{key} in @var{table} and returns its handle.\n"
711 "If @var{key} is not already present, a new handle is created which\n"
712 "associates @var{key} with @var{init}.")
713 #define FUNC_NAME s_scm_hash_create_handle_x
715 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihash
, scm_sloppy_assoc
, 0);
720 SCM_DEFINE (scm_hash_ref
, "hash-ref", 2, 1, 0,
721 (SCM table
, SCM key
, SCM dflt
),
722 "Look up @var{key} in the hash table @var{table}, and return the\n"
723 "value (if any) associated with it. If @var{key} is not found,\n"
724 "return @var{default} (or @code{#f} if no @var{default} argument\n"
725 "is supplied). Uses @code{equal?} for equality testing.")
726 #define FUNC_NAME s_scm_hash_ref
728 if (SCM_UNBNDP (dflt
))
730 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihash
, scm_sloppy_assoc
, 0);
736 SCM_DEFINE (scm_hash_set_x
, "hash-set!", 3, 0, 0,
737 (SCM table
, SCM key
, SCM val
),
738 "Find the entry in @var{table} associated with @var{key}, and\n"
739 "store @var{value} there. Uses @code{equal?} for equality\n"
741 #define FUNC_NAME s_scm_hash_set_x
743 return scm_hash_fn_set_x (table
, key
, val
, scm_ihash
, scm_sloppy_assoc
, 0);
749 SCM_DEFINE (scm_hash_remove_x
, "hash-remove!", 2, 0, 0,
750 (SCM table
, SCM key
),
751 "Remove @var{key} (and any value associated with it) from\n"
752 "@var{table}. Uses @code{equal?} for equality tests.")
753 #define FUNC_NAME s_scm_hash_remove_x
755 return scm_hash_fn_remove_x (table
, key
, scm_ihash
, scm_sloppy_assoc
,
763 typedef struct scm_t_ihashx_closure
768 } scm_t_ihashx_closure
;
773 scm_ihashx (SCM obj
, unsigned long n
, scm_t_ihashx_closure
*closure
)
775 SCM answer
= scm_call_2 (closure
->hash
, obj
, scm_from_ulong (n
));
776 return scm_to_ulong (answer
);
782 scm_sloppy_assx (SCM obj
, SCM alist
, scm_t_ihashx_closure
*closure
)
784 return scm_call_2 (closure
->assoc
, obj
, alist
);
791 scm_delx_x (SCM obj
, SCM alist
, scm_t_ihashx_closure
*closure
)
793 return scm_call_2 (closure
->delete, obj
, alist
);
798 SCM_DEFINE (scm_hashx_get_handle
, "hashx-get-handle", 4, 0, 0,
799 (SCM hash
, SCM assoc
, SCM table
, SCM key
),
800 "This behaves the same way as the corresponding\n"
801 "@code{-get-handle} function, but uses @var{hash} as a hash\n"
802 "function and @var{assoc} to compare keys. @code{hash} must be\n"
803 "a function that takes two arguments, a key to be hashed and a\n"
804 "table size. @code{assoc} must be an associator function, like\n"
805 "@code{assoc}, @code{assq} or @code{assv}.")
806 #define FUNC_NAME s_scm_hashx_get_handle
808 scm_t_ihashx_closure closure
;
810 closure
.assoc
= assoc
;
811 return scm_hash_fn_get_handle (table
, key
, scm_ihashx
, scm_sloppy_assx
,
817 SCM_DEFINE (scm_hashx_create_handle_x
, "hashx-create-handle!", 5, 0, 0,
818 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM init
),
819 "This behaves the same way as the corresponding\n"
820 "@code{-create-handle} function, but uses @var{hash} as a hash\n"
821 "function and @var{assoc} to compare keys. @code{hash} must be\n"
822 "a function that takes two arguments, a key to be hashed and a\n"
823 "table size. @code{assoc} must be an associator function, like\n"
824 "@code{assoc}, @code{assq} or @code{assv}.")
825 #define FUNC_NAME s_scm_hashx_create_handle_x
827 scm_t_ihashx_closure closure
;
829 closure
.assoc
= assoc
;
830 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashx
,
831 scm_sloppy_assx
, (void *)&closure
);
837 SCM_DEFINE (scm_hashx_ref
, "hashx-ref", 4, 1, 0,
838 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM dflt
),
839 "This behaves the same way as the corresponding @code{ref}\n"
840 "function, but uses @var{hash} as a hash function and\n"
841 "@var{assoc} to compare keys. @code{hash} must be a function\n"
842 "that takes two arguments, a key to be hashed and a table size.\n"
843 "@code{assoc} must be an associator function, like @code{assoc},\n"
844 "@code{assq} or @code{assv}.\n"
846 "By way of illustration, @code{hashq-ref table key} is\n"
847 "equivalent to @code{hashx-ref hashq assq table key}.")
848 #define FUNC_NAME s_scm_hashx_ref
850 scm_t_ihashx_closure closure
;
851 if (SCM_UNBNDP (dflt
))
854 closure
.assoc
= assoc
;
855 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashx
, scm_sloppy_assx
,
863 SCM_DEFINE (scm_hashx_set_x
, "hashx-set!", 5, 0, 0,
864 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM val
),
865 "This behaves the same way as the corresponding @code{set!}\n"
866 "function, but uses @var{hash} as a hash function and\n"
867 "@var{assoc} to compare keys. @code{hash} must be a function\n"
868 "that takes two arguments, a key to be hashed and a table size.\n"
869 "@code{assoc} must be an associator function, like @code{assoc},\n"
870 "@code{assq} or @code{assv}.\n"
872 " By way of illustration, @code{hashq-set! table key} is\n"
873 "equivalent to @code{hashx-set! hashq assq table key}.")
874 #define FUNC_NAME s_scm_hashx_set_x
876 scm_t_ihashx_closure closure
;
878 closure
.assoc
= assoc
;
879 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashx
, scm_sloppy_assx
,
887 scm_hashx_remove_x (SCM hash
, SCM assoc
, SCM
delete, SCM table
, SCM obj
)
889 scm_t_ihashx_closure closure
;
891 closure
.assoc
= assoc
;
892 closure
.delete = delete;
893 return scm_hash_fn_remove_x (table
, obj
, scm_ihashx
, scm_sloppy_assx
, scm_delx_x
, 0);
896 /* Hash table iterators */
898 static const char s_scm_hash_fold
[];
901 scm_internal_hash_fold (SCM (*fn
) (), void *closure
, SCM init
, SCM table
)
904 SCM buckets
, result
= init
;
906 if (SCM_HASHTABLE_P (table
))
907 buckets
= SCM_HASHTABLE_VECTOR (table
);
911 n
= SCM_VECTOR_LENGTH (buckets
);
912 for (i
= 0; i
< n
; ++i
)
914 SCM ls
= SCM_VELTS (buckets
)[i
], handle
;
915 while (!SCM_NULLP (ls
))
918 scm_wrong_type_arg (s_scm_hash_fold
, SCM_ARG3
, buckets
);
919 handle
= SCM_CAR (ls
);
920 if (!SCM_CONSP (handle
))
921 scm_wrong_type_arg (s_scm_hash_fold
, SCM_ARG3
, buckets
);
922 result
= fn (closure
, SCM_CAR (handle
), SCM_CDR (handle
), result
);
930 /* The following redundant code is here in order to be able to support
931 hash-for-each-handle. An alternative would have been to replace
932 this code and scm_internal_hash_fold above with a single
933 scm_internal_hash_fold_handles, but we don't want to promote such
936 static const char s_scm_hash_for_each
[];
939 scm_internal_hash_for_each_handle (SCM (*fn
) (), void *closure
, SCM table
)
944 if (SCM_HASHTABLE_P (table
))
945 buckets
= SCM_HASHTABLE_VECTOR (table
);
949 n
= SCM_VECTOR_LENGTH (buckets
);
950 for (i
= 0; i
< n
; ++i
)
952 SCM ls
= SCM_VELTS (buckets
)[i
], handle
;
953 while (!SCM_NULLP (ls
))
956 scm_wrong_type_arg (s_scm_hash_for_each
, SCM_ARG3
, buckets
);
957 handle
= SCM_CAR (ls
);
958 if (!SCM_CONSP (handle
))
959 scm_wrong_type_arg (s_scm_hash_for_each
, SCM_ARG3
, buckets
);
960 fn (closure
, handle
);
966 SCM_DEFINE (scm_hash_fold
, "hash-fold", 3, 0, 0,
967 (SCM proc
, SCM init
, SCM table
),
968 "An iterator over hash-table elements.\n"
969 "Accumulates and returns a result by applying PROC successively.\n"
970 "The arguments to PROC are \"(key value prior-result)\" where key\n"
971 "and value are successive pairs from the hash table TABLE, and\n"
972 "prior-result is either INIT (for the first application of PROC)\n"
973 "or the return value of the previous application of PROC.\n"
974 "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
975 "table into an a-list of key-value pairs.")
976 #define FUNC_NAME s_scm_hash_fold
978 SCM_VALIDATE_PROC (1, proc
);
979 if (!SCM_HASHTABLE_P (table
))
980 SCM_VALIDATE_VECTOR (3, table
);
981 return scm_internal_hash_fold (scm_call_3
, (void *) SCM_UNPACK (proc
), init
, table
);
986 for_each_proc (void *proc
, SCM handle
)
988 return scm_call_2 (SCM_PACK (proc
), SCM_CAR (handle
), SCM_CDR (handle
));
991 SCM_DEFINE (scm_hash_for_each
, "hash-for-each", 2, 0, 0,
992 (SCM proc
, SCM table
),
993 "An iterator over hash-table elements.\n"
994 "Applies PROC successively on all hash table items.\n"
995 "The arguments to PROC are \"(key value)\" where key\n"
996 "and value are successive pairs from the hash table TABLE.")
997 #define FUNC_NAME s_scm_hash_for_each
999 SCM_VALIDATE_PROC (1, proc
);
1000 if (!SCM_HASHTABLE_P (table
))
1001 SCM_VALIDATE_VECTOR (2, table
);
1003 scm_internal_hash_for_each_handle (for_each_proc
,
1004 (void *) SCM_UNPACK (proc
),
1006 return SCM_UNSPECIFIED
;
1010 SCM_DEFINE (scm_hash_for_each_handle
, "hash-for-each-handle", 2, 0, 0,
1011 (SCM proc
, SCM table
),
1012 "An iterator over hash-table elements.\n"
1013 "Applies PROC successively on all hash table handles.")
1014 #define FUNC_NAME s_scm_hash_for_each_handle
1016 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
1017 SCM_ASSERT (call
, proc
, 1, FUNC_NAME
);
1018 if (!SCM_HASHTABLE_P (table
))
1019 SCM_VALIDATE_VECTOR (2, table
);
1021 scm_internal_hash_for_each_handle (call
,
1022 (void *) SCM_UNPACK (proc
),
1024 return SCM_UNSPECIFIED
;
1029 map_proc (void *proc
, SCM key
, SCM data
, SCM value
)
1031 return scm_cons (scm_call_2 (SCM_PACK (proc
), key
, data
), value
);
1034 SCM_DEFINE (scm_hash_map_to_list
, "hash-map->list", 2, 0, 0,
1035 (SCM proc
, SCM table
),
1036 "An iterator over hash-table elements.\n"
1037 "Accumulates and returns as a list the results of applying PROC successively.\n"
1038 "The arguments to PROC are \"(key value)\" where key\n"
1039 "and value are successive pairs from the hash table TABLE.")
1040 #define FUNC_NAME s_scm_hash_map_to_list
1042 SCM_VALIDATE_PROC (1, proc
);
1043 if (!SCM_HASHTABLE_P (table
))
1044 SCM_VALIDATE_VECTOR (2, table
);
1045 return scm_internal_hash_fold (map_proc
,
1046 (void *) SCM_UNPACK (proc
),
1056 scm_hashtab_prehistory ()
1058 scm_tc16_hashtable
= scm_make_smob_type (s_hashtable
, 0);
1059 scm_set_smob_mark (scm_tc16_hashtable
, scm_markcdr
);
1060 scm_set_smob_print (scm_tc16_hashtable
, hashtable_print
);
1061 scm_set_smob_free (scm_tc16_hashtable
, hashtable_free
);
1062 scm_c_hook_add (&scm_after_sweep_c_hook
, scan_weak_hashtables
, 0, 0);
1063 scm_c_hook_add (&scm_after_gc_c_hook
, rehash_after_gc
, 0, 0);
1069 #include "libguile/hashtab.x"