1 /* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2003, 2004, 2006,
2 * 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
30 #include "libguile/_scm.h"
31 #include "libguile/alist.h"
32 #include "libguile/hash.h"
33 #include "libguile/eval.h"
34 #include "libguile/root.h"
35 #include "libguile/vectors.h"
36 #include "libguile/ports.h"
37 #include "libguile/bdw-gc.h"
39 #include "libguile/validate.h"
40 #include "libguile/hashtab.h"
45 /* A hash table is a cell containing a vector of association lists.
47 * Growing or shrinking, with following rehashing, is triggered when
50 * L = N / S (N: number of items in table, S: bucket vector length)
52 * passes an upper limit of 0.9 or a lower limit of 0.25.
54 * The implementation stores the upper and lower number of items which
55 * trigger a resize in the hashtable object.
57 * Possible hash table sizes (primes) are stored in the array
61 static unsigned long hashtable_size
[] = {
62 31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363,
63 224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041
64 #if SIZEOF_SCM_T_BITS > 4
65 /* vector lengths are stored in the first word of vectors, shifted by
66 8 bits for the tc8, so for 32-bit we only get 2^24-1 = 16777215
67 elements. But we allow a few more sizes for 64-bit. */
68 , 28762081, 57524111, 115048217, 230096423, 460192829
72 #define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long))
74 static char *s_hashtable
= "hashtable";
77 make_hash_table (unsigned long k
, const char *func_name
)
81 int i
= 0, n
= k
? k
: 31;
82 while (i
+ 1 < HASHTABLE_SIZE_N
&& n
> hashtable_size
[i
])
84 n
= hashtable_size
[i
];
86 vector
= scm_c_make_vector (n
, SCM_EOL
);
88 t
= scm_gc_malloc_pointerless (sizeof (*t
), s_hashtable
);
89 t
->min_size_index
= t
->size_index
= i
;
92 t
->upper
= 9 * n
/ 10;
94 /* FIXME: we just need two words of storage, not three */
95 return scm_double_cell (scm_tc7_hashtable
, SCM_UNPACK (vector
),
100 scm_i_rehash (SCM table
,
101 scm_t_hash_fn hash_fn
,
103 const char* func_name
)
105 SCM buckets
, new_buckets
;
107 unsigned long old_size
;
108 unsigned long new_size
;
110 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
112 /* rehashing is not triggered when i <= min_size */
113 i
= SCM_HASHTABLE (table
)->size_index
;
116 while (i
> SCM_HASHTABLE (table
)->min_size_index
117 && SCM_HASHTABLE_N_ITEMS (table
) < hashtable_size
[i
] / 4);
121 i
= SCM_HASHTABLE (table
)->size_index
+ 1;
122 if (i
>= HASHTABLE_SIZE_N
)
126 SCM_HASHTABLE (table
)->size_index
= i
;
128 new_size
= hashtable_size
[i
];
129 if (i
<= SCM_HASHTABLE (table
)->min_size_index
)
130 SCM_HASHTABLE (table
)->lower
= 0;
132 SCM_HASHTABLE (table
)->lower
= new_size
/ 4;
133 SCM_HASHTABLE (table
)->upper
= 9 * new_size
/ 10;
134 buckets
= SCM_HASHTABLE_VECTOR (table
);
136 new_buckets
= scm_c_make_vector (new_size
, SCM_EOL
);
138 SCM_SET_HASHTABLE_VECTOR (table
, new_buckets
);
139 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
141 old_size
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
142 for (i
= 0; i
< old_size
; ++i
)
144 SCM ls
, cell
, handle
;
146 ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
);
147 SCM_SIMPLE_VECTOR_SET (buckets
, i
, SCM_EOL
);
149 while (scm_is_pair (ls
))
154 handle
= SCM_CAR (cell
);
157 h
= hash_fn (SCM_CAR (handle
), new_size
, closure
);
159 scm_out_of_range (func_name
, scm_from_ulong (h
));
160 SCM_SETCDR (cell
, SCM_SIMPLE_VECTOR_REF (new_buckets
, h
));
161 SCM_SIMPLE_VECTOR_SET (new_buckets
, h
, cell
);
162 SCM_HASHTABLE_INCREMENT (table
);
169 scm_i_hashtable_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
171 scm_puts_unlocked ("#<hash-table ", port
);
172 scm_uintprint (SCM_UNPACK (exp
), 16, port
);
173 scm_putc (' ', port
);
174 scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp
), 10, port
);
175 scm_putc_unlocked ('/', port
);
176 scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp
)),
178 scm_puts_unlocked (">", port
);
183 scm_c_make_hash_table (unsigned long k
)
185 return make_hash_table (k
, "scm_c_make_hash_table");
188 SCM_DEFINE (scm_make_hash_table
, "make-hash-table", 0, 1, 0,
190 "Make a new abstract hash table object with minimum number of buckets @var{n}\n")
191 #define FUNC_NAME s_scm_make_hash_table
193 return make_hash_table (SCM_UNBNDP (n
) ? 0 : scm_to_ulong (n
), FUNC_NAME
);
197 #define SCM_WEAK_TABLE_P(x) (scm_is_true (scm_weak_table_p (x)))
199 SCM_DEFINE (scm_hash_table_p
, "hash-table?", 1, 0, 0,
201 "Return @code{#t} if @var{obj} is an abstract hash table object.")
202 #define FUNC_NAME s_scm_hash_table_p
204 return scm_from_bool (SCM_HASHTABLE_P (obj
) || SCM_WEAK_TABLE_P (obj
));
209 /* Accessing hash table entries. */
212 scm_hash_fn_get_handle (SCM table
, SCM obj
,
213 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
215 #define FUNC_NAME "scm_hash_fn_get_handle"
220 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
221 buckets
= SCM_HASHTABLE_VECTOR (table
);
223 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
225 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
226 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
227 scm_out_of_range (FUNC_NAME
, scm_from_ulong (k
));
229 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
237 scm_hash_fn_create_handle_x (SCM table
, SCM obj
, SCM init
,
238 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
240 #define FUNC_NAME "scm_hash_fn_create_handle_x"
245 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
246 buckets
= SCM_HASHTABLE_VECTOR (table
);
248 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
249 SCM_MISC_ERROR ("void hashtable", SCM_EOL
);
251 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
252 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
253 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
255 it
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
257 if (scm_is_pair (it
))
259 else if (scm_is_true (it
))
260 scm_wrong_type_arg_msg (NULL
, 0, it
, "a pair");
263 SCM handle
, new_bucket
;
265 handle
= scm_cons (obj
, init
);
266 new_bucket
= scm_cons (handle
, SCM_EOL
);
268 if (!scm_is_eq (SCM_HASHTABLE_VECTOR (table
), buckets
))
270 buckets
= SCM_HASHTABLE_VECTOR (table
);
271 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
272 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
273 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
275 SCM_SETCDR (new_bucket
, SCM_SIMPLE_VECTOR_REF (buckets
, k
));
276 SCM_SIMPLE_VECTOR_SET (buckets
, k
, new_bucket
);
277 SCM_HASHTABLE_INCREMENT (table
);
279 /* Maybe rehash the table. */
280 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
)
281 || SCM_HASHTABLE_N_ITEMS (table
) > SCM_HASHTABLE_UPPER (table
))
282 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
283 return SCM_CAR (new_bucket
);
290 scm_hash_fn_ref (SCM table
, SCM obj
, SCM dflt
,
291 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
294 SCM it
= scm_hash_fn_get_handle (table
, obj
, hash_fn
, assoc_fn
, closure
);
295 if (scm_is_pair (it
))
302 scm_hash_fn_set_x (SCM table
, SCM obj
, SCM val
,
303 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
308 pair
= scm_hash_fn_create_handle_x (table
, obj
, val
,
309 hash_fn
, assoc_fn
, closure
);
311 if (!scm_is_eq (SCM_CDR (pair
), val
))
312 SCM_SETCDR (pair
, val
);
319 scm_hash_fn_remove_x (SCM table
, SCM obj
,
320 scm_t_hash_fn hash_fn
,
321 scm_t_assoc_fn assoc_fn
,
323 #define FUNC_NAME "hash_fn_remove_x"
328 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
330 buckets
= SCM_HASHTABLE_VECTOR (table
);
332 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
335 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
336 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
337 scm_out_of_range (FUNC_NAME
, scm_from_ulong (k
));
339 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
343 SCM_SIMPLE_VECTOR_SET
344 (buckets
, k
, scm_delq_x (h
, SCM_SIMPLE_VECTOR_REF (buckets
, k
)));
345 SCM_HASHTABLE_DECREMENT (table
);
346 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
347 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
353 SCM_DEFINE (scm_hash_clear_x
, "hash-clear!", 1, 0, 0,
355 "Remove all items from @var{table} (without triggering a resize).")
356 #define FUNC_NAME s_scm_hash_clear_x
358 if (SCM_WEAK_TABLE_P (table
))
360 scm_weak_table_clear_x (table
);
361 return SCM_UNSPECIFIED
;
364 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
366 scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table
), SCM_EOL
);
367 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
369 return SCM_UNSPECIFIED
;
375 SCM_DEFINE (scm_hashq_get_handle
, "hashq-get-handle", 2, 0, 0,
376 (SCM table
, SCM key
),
377 "This procedure returns the @code{(key . value)} pair from the\n"
378 "hash table @var{table}. If @var{table} does not hold an\n"
379 "associated value for @var{key}, @code{#f} is returned.\n"
380 "Uses @code{eq?} for equality testing.")
381 #define FUNC_NAME s_scm_hashq_get_handle
383 return scm_hash_fn_get_handle (table
, key
,
384 (scm_t_hash_fn
) scm_ihashq
,
385 (scm_t_assoc_fn
) scm_sloppy_assq
,
391 SCM_DEFINE (scm_hashq_create_handle_x
, "hashq-create-handle!", 3, 0, 0,
392 (SCM table
, SCM key
, SCM init
),
393 "This function looks up @var{key} in @var{table} and returns its handle.\n"
394 "If @var{key} is not already present, a new handle is created which\n"
395 "associates @var{key} with @var{init}.")
396 #define FUNC_NAME s_scm_hashq_create_handle_x
398 return scm_hash_fn_create_handle_x (table
, key
, init
,
399 (scm_t_hash_fn
) scm_ihashq
,
400 (scm_t_assoc_fn
) scm_sloppy_assq
,
406 SCM_DEFINE (scm_hashq_ref
, "hashq-ref", 2, 1, 0,
407 (SCM table
, SCM key
, SCM dflt
),
408 "Look up @var{key} in the hash table @var{table}, and return the\n"
409 "value (if any) associated with it. If @var{key} is not found,\n"
410 "return @var{dflt} (or @code{#f} if no @var{dflt} argument\n"
411 "is supplied). Uses @code{eq?} for equality testing.")
412 #define FUNC_NAME s_scm_hashq_ref
414 if (SCM_UNBNDP (dflt
))
417 if (SCM_WEAK_TABLE_P (table
))
418 return scm_weak_table_refq (table
, key
, dflt
);
420 return scm_hash_fn_ref (table
, key
, dflt
,
421 (scm_t_hash_fn
) scm_ihashq
,
422 (scm_t_assoc_fn
) scm_sloppy_assq
,
429 SCM_DEFINE (scm_hashq_set_x
, "hashq-set!", 3, 0, 0,
430 (SCM table
, SCM key
, SCM val
),
431 "Find the entry in @var{table} associated with @var{key}, and\n"
432 "store @var{val} there. Uses @code{eq?} for equality testing.")
433 #define FUNC_NAME s_scm_hashq_set_x
435 if (SCM_WEAK_TABLE_P (table
))
437 scm_weak_table_putq_x (table
, key
, val
);
441 return scm_hash_fn_set_x (table
, key
, val
,
442 (scm_t_hash_fn
) scm_ihashq
,
443 (scm_t_assoc_fn
) scm_sloppy_assq
,
450 SCM_DEFINE (scm_hashq_remove_x
, "hashq-remove!", 2, 0, 0,
451 (SCM table
, SCM key
),
452 "Remove @var{key} (and any value associated with it) from\n"
453 "@var{table}. Uses @code{eq?} for equality tests.")
454 #define FUNC_NAME s_scm_hashq_remove_x
456 if (SCM_WEAK_TABLE_P (table
))
458 scm_weak_table_remq_x (table
, key
);
459 /* This return value is for historical compatibility with
460 hash-remove!, which returns either the "handle" corresponding
461 to the entry, or #f. Since weak tables don't have handles, we
462 have to return #f. */
466 return scm_hash_fn_remove_x (table
, key
,
467 (scm_t_hash_fn
) scm_ihashq
,
468 (scm_t_assoc_fn
) scm_sloppy_assq
,
476 SCM_DEFINE (scm_hashv_get_handle
, "hashv-get-handle", 2, 0, 0,
477 (SCM table
, SCM key
),
478 "This procedure returns the @code{(key . value)} pair from the\n"
479 "hash table @var{table}. If @var{table} does not hold an\n"
480 "associated value for @var{key}, @code{#f} is returned.\n"
481 "Uses @code{eqv?} for equality testing.")
482 #define FUNC_NAME s_scm_hashv_get_handle
484 return scm_hash_fn_get_handle (table
, key
,
485 (scm_t_hash_fn
) scm_ihashv
,
486 (scm_t_assoc_fn
) scm_sloppy_assv
,
492 SCM_DEFINE (scm_hashv_create_handle_x
, "hashv-create-handle!", 3, 0, 0,
493 (SCM table
, SCM key
, SCM init
),
494 "This function looks up @var{key} in @var{table} and returns its handle.\n"
495 "If @var{key} is not already present, a new handle is created which\n"
496 "associates @var{key} with @var{init}.")
497 #define FUNC_NAME s_scm_hashv_create_handle_x
499 return scm_hash_fn_create_handle_x (table
, key
, init
,
500 (scm_t_hash_fn
) scm_ihashv
,
501 (scm_t_assoc_fn
) scm_sloppy_assv
,
508 assv_predicate (SCM k
, SCM v
, void *closure
)
510 return scm_is_true (scm_eqv_p (k
, SCM_PACK_POINTER (closure
)));
513 SCM_DEFINE (scm_hashv_ref
, "hashv-ref", 2, 1, 0,
514 (SCM table
, SCM key
, SCM dflt
),
515 "Look up @var{key} in the hash table @var{table}, and return the\n"
516 "value (if any) associated with it. If @var{key} is not found,\n"
517 "return @var{dflt} (or @code{#f} if no @var{dflt} argument\n"
518 "is supplied). Uses @code{eqv?} for equality testing.")
519 #define FUNC_NAME s_scm_hashv_ref
521 if (SCM_UNBNDP (dflt
))
524 if (SCM_WEAK_TABLE_P (table
))
525 return scm_c_weak_table_ref (table
, scm_ihashv (key
, -1),
526 assv_predicate
, SCM_PACK (key
), dflt
);
528 return scm_hash_fn_ref (table
, key
, dflt
,
529 (scm_t_hash_fn
) scm_ihashv
,
530 (scm_t_assoc_fn
) scm_sloppy_assv
,
537 SCM_DEFINE (scm_hashv_set_x
, "hashv-set!", 3, 0, 0,
538 (SCM table
, SCM key
, SCM val
),
539 "Find the entry in @var{table} associated with @var{key}, and\n"
540 "store @var{value} there. Uses @code{eqv?} for equality testing.")
541 #define FUNC_NAME s_scm_hashv_set_x
543 if (SCM_WEAK_TABLE_P (table
))
545 scm_c_weak_table_put_x (table
, scm_ihashv (key
, -1),
546 assv_predicate
, SCM_PACK (key
),
551 return scm_hash_fn_set_x (table
, key
, val
,
552 (scm_t_hash_fn
) scm_ihashv
,
553 (scm_t_assoc_fn
) scm_sloppy_assv
,
559 SCM_DEFINE (scm_hashv_remove_x
, "hashv-remove!", 2, 0, 0,
560 (SCM table
, SCM key
),
561 "Remove @var{key} (and any value associated with it) from\n"
562 "@var{table}. Uses @code{eqv?} for equality tests.")
563 #define FUNC_NAME s_scm_hashv_remove_x
565 if (SCM_WEAK_TABLE_P (table
))
567 scm_c_weak_table_remove_x (table
, scm_ihashv (key
, -1),
568 assv_predicate
, SCM_PACK (key
));
569 /* See note in hashq-remove!. */
573 return scm_hash_fn_remove_x (table
, key
,
574 (scm_t_hash_fn
) scm_ihashv
,
575 (scm_t_assoc_fn
) scm_sloppy_assv
,
582 SCM_DEFINE (scm_hash_get_handle
, "hash-get-handle", 2, 0, 0,
583 (SCM table
, SCM key
),
584 "This procedure returns the @code{(key . value)} pair from the\n"
585 "hash table @var{table}. If @var{table} does not hold an\n"
586 "associated value for @var{key}, @code{#f} is returned.\n"
587 "Uses @code{equal?} for equality testing.")
588 #define FUNC_NAME s_scm_hash_get_handle
590 return scm_hash_fn_get_handle (table
, key
,
591 (scm_t_hash_fn
) scm_ihash
,
592 (scm_t_assoc_fn
) scm_sloppy_assoc
,
598 SCM_DEFINE (scm_hash_create_handle_x
, "hash-create-handle!", 3, 0, 0,
599 (SCM table
, SCM key
, SCM init
),
600 "This function looks up @var{key} in @var{table} and returns its handle.\n"
601 "If @var{key} is not already present, a new handle is created which\n"
602 "associates @var{key} with @var{init}.")
603 #define FUNC_NAME s_scm_hash_create_handle_x
605 return scm_hash_fn_create_handle_x (table
, key
, init
,
606 (scm_t_hash_fn
) scm_ihash
,
607 (scm_t_assoc_fn
) scm_sloppy_assoc
,
614 assoc_predicate (SCM k
, SCM v
, void *closure
)
616 return scm_is_true (scm_equal_p (k
, SCM_PACK_POINTER (closure
)));
619 SCM_DEFINE (scm_hash_ref
, "hash-ref", 2, 1, 0,
620 (SCM table
, SCM key
, SCM dflt
),
621 "Look up @var{key} in the hash table @var{table}, and return the\n"
622 "value (if any) associated with it. If @var{key} is not found,\n"
623 "return @var{dflt} (or @code{#f} if no @var{dflt} argument\n"
624 "is supplied). Uses @code{equal?} for equality testing.")
625 #define FUNC_NAME s_scm_hash_ref
627 if (SCM_UNBNDP (dflt
))
630 if (SCM_WEAK_TABLE_P (table
))
631 return scm_c_weak_table_ref (table
, scm_ihash (key
, -1),
632 assoc_predicate
, SCM_PACK (key
), dflt
);
634 return scm_hash_fn_ref (table
, key
, dflt
,
635 (scm_t_hash_fn
) scm_ihash
,
636 (scm_t_assoc_fn
) scm_sloppy_assoc
,
643 SCM_DEFINE (scm_hash_set_x
, "hash-set!", 3, 0, 0,
644 (SCM table
, SCM key
, SCM val
),
645 "Find the entry in @var{table} associated with @var{key}, and\n"
646 "store @var{val} there. Uses @code{equal?} for equality\n"
648 #define FUNC_NAME s_scm_hash_set_x
650 if (SCM_WEAK_TABLE_P (table
))
652 scm_c_weak_table_put_x (table
, scm_ihash (key
, -1),
653 assoc_predicate
, SCM_PACK (key
),
658 return scm_hash_fn_set_x (table
, key
, val
,
659 (scm_t_hash_fn
) scm_ihash
,
660 (scm_t_assoc_fn
) scm_sloppy_assoc
,
667 SCM_DEFINE (scm_hash_remove_x
, "hash-remove!", 2, 0, 0,
668 (SCM table
, SCM key
),
669 "Remove @var{key} (and any value associated with it) from\n"
670 "@var{table}. Uses @code{equal?} for equality tests.")
671 #define FUNC_NAME s_scm_hash_remove_x
673 if (SCM_WEAK_TABLE_P (table
))
675 scm_c_weak_table_remove_x (table
, scm_ihash (key
, -1),
676 assoc_predicate
, SCM_PACK (key
));
677 /* See note in hashq-remove!. */
681 return scm_hash_fn_remove_x (table
, key
,
682 (scm_t_hash_fn
) scm_ihash
,
683 (scm_t_assoc_fn
) scm_sloppy_assoc
,
691 typedef struct scm_t_ihashx_closure
696 } scm_t_ihashx_closure
;
699 scm_ihashx (SCM obj
, unsigned long n
, void *arg
)
702 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
703 answer
= scm_call_2 (closure
->hash
, obj
, scm_from_ulong (n
));
704 return scm_to_ulong (answer
);
708 scm_sloppy_assx (SCM obj
, SCM alist
, void *arg
)
710 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
711 return scm_call_2 (closure
->assoc
, obj
, alist
);
715 assx_predicate (SCM k
, SCM v
, void *closure
)
717 scm_t_ihashx_closure
*c
= (scm_t_ihashx_closure
*) closure
;
719 /* FIXME: The hashx interface is crazy. Hash tables have nothing to
720 do with alists in principle. Instead of getting an assoc proc,
721 hashx functions should use an equality predicate. Perhaps we can
722 change this before 2.2, but until then, add a terrible, terrible
725 return scm_is_true (scm_call_2 (c
->assoc
, c
->key
, scm_acons (k
, v
, SCM_EOL
)));
729 SCM_DEFINE (scm_hashx_get_handle
, "hashx-get-handle", 4, 0, 0,
730 (SCM hash
, SCM assoc
, SCM table
, SCM key
),
731 "This behaves the same way as the corresponding\n"
732 "@code{-get-handle} function, but uses @var{hash} as a hash\n"
733 "function and @var{assoc} to compare keys. @code{hash} must be\n"
734 "a function that takes two arguments, a key to be hashed and a\n"
735 "table size. @code{assoc} must be an associator function, like\n"
736 "@code{assoc}, @code{assq} or @code{assv}.")
737 #define FUNC_NAME s_scm_hashx_get_handle
739 scm_t_ihashx_closure closure
;
741 closure
.assoc
= assoc
;
744 return scm_hash_fn_get_handle (table
, key
, scm_ihashx
, scm_sloppy_assx
,
750 SCM_DEFINE (scm_hashx_create_handle_x
, "hashx-create-handle!", 5, 0, 0,
751 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM init
),
752 "This behaves the same way as the corresponding\n"
753 "@code{-create-handle} function, but uses @var{hash} as a hash\n"
754 "function and @var{assoc} to compare keys. @code{hash} must be\n"
755 "a function that takes two arguments, a key to be hashed and a\n"
756 "table size. @code{assoc} must be an associator function, like\n"
757 "@code{assoc}, @code{assq} or @code{assv}.")
758 #define FUNC_NAME s_scm_hashx_create_handle_x
760 scm_t_ihashx_closure closure
;
762 closure
.assoc
= assoc
;
765 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashx
,
766 scm_sloppy_assx
, (void *)&closure
);
772 SCM_DEFINE (scm_hashx_ref
, "hashx-ref", 4, 1, 0,
773 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM dflt
),
774 "This behaves the same way as the corresponding @code{ref}\n"
775 "function, but uses @var{hash} as a hash function and\n"
776 "@var{assoc} to compare keys. @code{hash} must be a function\n"
777 "that takes two arguments, a key to be hashed and a table size.\n"
778 "@code{assoc} must be an associator function, like @code{assoc},\n"
779 "@code{assq} or @code{assv}.\n"
781 "By way of illustration, @code{hashq-ref table key} is\n"
782 "equivalent to @code{hashx-ref hashq assq table key}.")
783 #define FUNC_NAME s_scm_hashx_ref
785 scm_t_ihashx_closure closure
;
786 if (SCM_UNBNDP (dflt
))
789 closure
.assoc
= assoc
;
792 if (SCM_WEAK_TABLE_P (table
))
794 unsigned long h
= scm_to_ulong (scm_call_2 (hash
, key
,
795 scm_from_ulong (-1)));
796 return scm_c_weak_table_ref (table
, h
, assx_predicate
, &closure
, dflt
);
799 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashx
, scm_sloppy_assx
,
807 SCM_DEFINE (scm_hashx_set_x
, "hashx-set!", 5, 0, 0,
808 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM val
),
809 "This behaves the same way as the corresponding @code{set!}\n"
810 "function, but uses @var{hash} as a hash function and\n"
811 "@var{assoc} to compare keys. @code{hash} must be a function\n"
812 "that takes two arguments, a key to be hashed and a table size.\n"
813 "@code{assoc} must be an associator function, like @code{assoc},\n"
814 "@code{assq} or @code{assv}.\n"
816 " By way of illustration, @code{hashq-set! table key} is\n"
817 "equivalent to @code{hashx-set! hashq assq table key}.")
818 #define FUNC_NAME s_scm_hashx_set_x
820 scm_t_ihashx_closure closure
;
822 closure
.assoc
= assoc
;
825 if (SCM_WEAK_TABLE_P (table
))
827 unsigned long h
= scm_to_ulong (scm_call_2 (hash
, key
,
828 scm_from_ulong (-1)));
829 scm_c_weak_table_put_x (table
, h
, assx_predicate
, &closure
, key
, val
);
833 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashx
, scm_sloppy_assx
,
838 SCM_DEFINE (scm_hashx_remove_x
, "hashx-remove!", 4, 0, 0,
839 (SCM hash
, SCM assoc
, SCM table
, SCM obj
),
840 "This behaves the same way as the corresponding @code{remove!}\n"
841 "function, but uses @var{hash} as a hash function and\n"
842 "@var{assoc} to compare keys. @code{hash} must be a function\n"
843 "that takes two arguments, a key to be hashed and a table size.\n"
844 "@code{assoc} must be an associator function, like @code{assoc},\n"
845 "@code{assq} or @code{assv}.\n"
847 " By way of illustration, @code{hashq-remove! table key} is\n"
848 "equivalent to @code{hashx-remove! hashq assq #f table key}.")
849 #define FUNC_NAME s_scm_hashx_remove_x
851 scm_t_ihashx_closure closure
;
853 closure
.assoc
= assoc
;
856 if (SCM_WEAK_TABLE_P (table
))
858 unsigned long h
= scm_to_ulong (scm_call_2 (hash
, obj
,
859 scm_from_ulong (-1)));
860 scm_c_weak_table_remove_x (table
, h
, assx_predicate
, &closure
);
861 /* See note in hashq-remove!. */
865 return scm_hash_fn_remove_x (table
, obj
, scm_ihashx
, scm_sloppy_assx
,
870 /* Hash table iterators */
872 SCM_DEFINE (scm_hash_fold
, "hash-fold", 3, 0, 0,
873 (SCM proc
, SCM init
, SCM table
),
874 "An iterator over hash-table elements.\n"
875 "Accumulates and returns a result by applying PROC successively.\n"
876 "The arguments to PROC are \"(key value prior-result)\" where key\n"
877 "and value are successive pairs from the hash table TABLE, and\n"
878 "prior-result is either INIT (for the first application of PROC)\n"
879 "or the return value of the previous application of PROC.\n"
880 "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
881 "table into an a-list of key-value pairs.")
882 #define FUNC_NAME s_scm_hash_fold
884 SCM_VALIDATE_PROC (1, proc
);
886 if (SCM_WEAK_TABLE_P (table
))
887 return scm_weak_table_fold (proc
, init
, table
);
889 SCM_VALIDATE_HASHTABLE (3, table
);
890 return scm_internal_hash_fold ((scm_t_hash_fold_fn
) scm_call_3
,
891 (void *) SCM_UNPACK (proc
), init
, table
);
896 for_each_proc (void *proc
, SCM handle
)
898 return scm_call_2 (SCM_PACK (proc
), SCM_CAR (handle
), SCM_CDR (handle
));
901 SCM_DEFINE (scm_hash_for_each
, "hash-for-each", 2, 0, 0,
902 (SCM proc
, SCM table
),
903 "An iterator over hash-table elements.\n"
904 "Applies PROC successively on all hash table items.\n"
905 "The arguments to PROC are \"(key value)\" where key\n"
906 "and value are successive pairs from the hash table TABLE.")
907 #define FUNC_NAME s_scm_hash_for_each
909 SCM_VALIDATE_PROC (1, proc
);
911 if (SCM_WEAK_TABLE_P (table
))
913 scm_weak_table_for_each (proc
, table
);
914 return SCM_UNSPECIFIED
;
917 SCM_VALIDATE_HASHTABLE (2, table
);
919 scm_internal_hash_for_each_handle (for_each_proc
,
920 (void *) SCM_UNPACK (proc
),
922 return SCM_UNSPECIFIED
;
926 SCM_DEFINE (scm_hash_for_each_handle
, "hash-for-each-handle", 2, 0, 0,
927 (SCM proc
, SCM table
),
928 "An iterator over hash-table elements.\n"
929 "Applies PROC successively on all hash table handles.")
930 #define FUNC_NAME s_scm_hash_for_each_handle
932 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)), proc
, 1, FUNC_NAME
);
933 SCM_VALIDATE_HASHTABLE (2, table
);
935 scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn
) scm_call_1
,
936 (void *) SCM_UNPACK (proc
),
938 return SCM_UNSPECIFIED
;
943 map_proc (void *proc
, SCM key
, SCM data
, SCM value
)
945 return scm_cons (scm_call_2 (SCM_PACK (proc
), key
, data
), value
);
948 SCM_DEFINE (scm_hash_map_to_list
, "hash-map->list", 2, 0, 0,
949 (SCM proc
, SCM table
),
950 "An iterator over hash-table elements.\n"
951 "Accumulates and returns as a list the results of applying PROC successively.\n"
952 "The arguments to PROC are \"(key value)\" where key\n"
953 "and value are successive pairs from the hash table TABLE.")
954 #define FUNC_NAME s_scm_hash_map_to_list
956 SCM_VALIDATE_PROC (1, proc
);
958 if (SCM_WEAK_TABLE_P (table
))
959 return scm_weak_table_map_to_list (proc
, table
);
961 SCM_VALIDATE_HASHTABLE (2, table
);
962 return scm_internal_hash_fold (map_proc
,
963 (void *) SCM_UNPACK (proc
),
972 scm_internal_hash_fold (scm_t_hash_fold_fn fn
, void *closure
,
974 #define FUNC_NAME s_scm_hash_fold
977 SCM buckets
, result
= init
;
979 if (SCM_WEAK_TABLE_P (table
))
980 return scm_c_weak_table_fold (fn
, closure
, init
, table
);
982 SCM_VALIDATE_HASHTABLE (0, table
);
983 buckets
= SCM_HASHTABLE_VECTOR (table
);
985 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
986 for (i
= 0; i
< n
; ++i
)
990 for (ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
); !scm_is_null (ls
);
993 handle
= SCM_CAR (ls
);
994 result
= fn (closure
, SCM_CAR (handle
), SCM_CDR (handle
), result
);
1002 /* The following redundant code is here in order to be able to support
1003 hash-for-each-handle. An alternative would have been to replace
1004 this code and scm_internal_hash_fold above with a single
1005 scm_internal_hash_fold_handles, but we don't want to promote such
1009 scm_internal_hash_for_each_handle (scm_t_hash_handle_fn fn
, void *closure
,
1011 #define FUNC_NAME s_scm_hash_for_each
1016 SCM_VALIDATE_HASHTABLE (0, table
);
1017 buckets
= SCM_HASHTABLE_VECTOR (table
);
1018 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1020 for (i
= 0; i
< n
; ++i
)
1022 SCM ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
), handle
;
1023 while (!scm_is_null (ls
))
1025 if (!scm_is_pair (ls
))
1026 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1027 handle
= SCM_CAR (ls
);
1028 if (!scm_is_pair (handle
))
1029 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1030 fn (closure
, handle
);
1043 #include "libguile/hashtab.x"