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
))
359 return scm_weak_table_clear_x (table
);
361 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
363 scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table
), SCM_EOL
);
364 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
366 return SCM_UNSPECIFIED
;
372 SCM_DEFINE (scm_hashq_get_handle
, "hashq-get-handle", 2, 0, 0,
373 (SCM table
, SCM key
),
374 "This procedure returns the @code{(key . value)} pair from the\n"
375 "hash table @var{table}. If @var{table} does not hold an\n"
376 "associated value for @var{key}, @code{#f} is returned.\n"
377 "Uses @code{eq?} for equality testing.")
378 #define FUNC_NAME s_scm_hashq_get_handle
380 return scm_hash_fn_get_handle (table
, key
,
381 (scm_t_hash_fn
) scm_ihashq
,
382 (scm_t_assoc_fn
) scm_sloppy_assq
,
388 SCM_DEFINE (scm_hashq_create_handle_x
, "hashq-create-handle!", 3, 0, 0,
389 (SCM table
, SCM key
, SCM init
),
390 "This function looks up @var{key} in @var{table} and returns its handle.\n"
391 "If @var{key} is not already present, a new handle is created which\n"
392 "associates @var{key} with @var{init}.")
393 #define FUNC_NAME s_scm_hashq_create_handle_x
395 return scm_hash_fn_create_handle_x (table
, key
, init
,
396 (scm_t_hash_fn
) scm_ihashq
,
397 (scm_t_assoc_fn
) scm_sloppy_assq
,
403 SCM_DEFINE (scm_hashq_ref
, "hashq-ref", 2, 1, 0,
404 (SCM table
, SCM key
, SCM dflt
),
405 "Look up @var{key} in the hash table @var{table}, and return the\n"
406 "value (if any) associated with it. If @var{key} is not found,\n"
407 "return @var{dflt} (or @code{#f} if no @var{dflt} argument\n"
408 "is supplied). Uses @code{eq?} for equality testing.")
409 #define FUNC_NAME s_scm_hashq_ref
411 if (SCM_UNBNDP (dflt
))
414 if (SCM_WEAK_TABLE_P (table
))
415 return scm_weak_table_refq (table
, key
, dflt
);
417 return scm_hash_fn_ref (table
, key
, dflt
,
418 (scm_t_hash_fn
) scm_ihashq
,
419 (scm_t_assoc_fn
) scm_sloppy_assq
,
426 SCM_DEFINE (scm_hashq_set_x
, "hashq-set!", 3, 0, 0,
427 (SCM table
, SCM key
, SCM val
),
428 "Find the entry in @var{table} associated with @var{key}, and\n"
429 "store @var{val} there. Uses @code{eq?} for equality testing.")
430 #define FUNC_NAME s_scm_hashq_set_x
432 if (SCM_WEAK_TABLE_P (table
))
433 return scm_weak_table_putq_x (table
, key
, val
);
435 return scm_hash_fn_set_x (table
, key
, val
,
436 (scm_t_hash_fn
) scm_ihashq
,
437 (scm_t_assoc_fn
) scm_sloppy_assq
,
444 SCM_DEFINE (scm_hashq_remove_x
, "hashq-remove!", 2, 0, 0,
445 (SCM table
, SCM key
),
446 "Remove @var{key} (and any value associated with it) from\n"
447 "@var{table}. Uses @code{eq?} for equality tests.")
448 #define FUNC_NAME s_scm_hashq_remove_x
450 if (SCM_WEAK_TABLE_P (table
))
451 return scm_weak_table_remq_x (table
, key
);
453 return scm_hash_fn_remove_x (table
, key
,
454 (scm_t_hash_fn
) scm_ihashq
,
455 (scm_t_assoc_fn
) scm_sloppy_assq
,
463 SCM_DEFINE (scm_hashv_get_handle
, "hashv-get-handle", 2, 0, 0,
464 (SCM table
, SCM key
),
465 "This procedure returns the @code{(key . value)} pair from the\n"
466 "hash table @var{table}. If @var{table} does not hold an\n"
467 "associated value for @var{key}, @code{#f} is returned.\n"
468 "Uses @code{eqv?} for equality testing.")
469 #define FUNC_NAME s_scm_hashv_get_handle
471 return scm_hash_fn_get_handle (table
, key
,
472 (scm_t_hash_fn
) scm_ihashv
,
473 (scm_t_assoc_fn
) scm_sloppy_assv
,
479 SCM_DEFINE (scm_hashv_create_handle_x
, "hashv-create-handle!", 3, 0, 0,
480 (SCM table
, SCM key
, SCM init
),
481 "This function looks up @var{key} in @var{table} and returns its handle.\n"
482 "If @var{key} is not already present, a new handle is created which\n"
483 "associates @var{key} with @var{init}.")
484 #define FUNC_NAME s_scm_hashv_create_handle_x
486 return scm_hash_fn_create_handle_x (table
, key
, init
,
487 (scm_t_hash_fn
) scm_ihashv
,
488 (scm_t_assoc_fn
) scm_sloppy_assv
,
495 assv_predicate (SCM k
, SCM v
, void *closure
)
497 return scm_is_true (scm_eqv_p (k
, SCM_PACK_POINTER (closure
)));
500 SCM_DEFINE (scm_hashv_ref
, "hashv-ref", 2, 1, 0,
501 (SCM table
, SCM key
, SCM dflt
),
502 "Look up @var{key} in the hash table @var{table}, and return the\n"
503 "value (if any) associated with it. If @var{key} is not found,\n"
504 "return @var{dflt} (or @code{#f} if no @var{dflt} argument\n"
505 "is supplied). Uses @code{eqv?} for equality testing.")
506 #define FUNC_NAME s_scm_hashv_ref
508 if (SCM_UNBNDP (dflt
))
511 if (SCM_WEAK_TABLE_P (table
))
512 return scm_c_weak_table_ref (table
, scm_ihashv (key
, -1),
513 assv_predicate
, SCM_PACK (key
), dflt
);
515 return scm_hash_fn_ref (table
, key
, dflt
,
516 (scm_t_hash_fn
) scm_ihashv
,
517 (scm_t_assoc_fn
) scm_sloppy_assv
,
524 SCM_DEFINE (scm_hashv_set_x
, "hashv-set!", 3, 0, 0,
525 (SCM table
, SCM key
, SCM val
),
526 "Find the entry in @var{table} associated with @var{key}, and\n"
527 "store @var{value} there. Uses @code{eqv?} for equality testing.")
528 #define FUNC_NAME s_scm_hashv_set_x
530 if (SCM_WEAK_TABLE_P (table
))
532 scm_c_weak_table_put_x (table
, scm_ihashv (key
, -1),
533 assv_predicate
, SCM_PACK (key
),
535 return SCM_UNSPECIFIED
;
538 return scm_hash_fn_set_x (table
, key
, val
,
539 (scm_t_hash_fn
) scm_ihashv
,
540 (scm_t_assoc_fn
) scm_sloppy_assv
,
546 SCM_DEFINE (scm_hashv_remove_x
, "hashv-remove!", 2, 0, 0,
547 (SCM table
, SCM key
),
548 "Remove @var{key} (and any value associated with it) from\n"
549 "@var{table}. Uses @code{eqv?} for equality tests.")
550 #define FUNC_NAME s_scm_hashv_remove_x
552 if (SCM_WEAK_TABLE_P (table
))
554 scm_c_weak_table_remove_x (table
, scm_ihashv (key
, -1),
555 assv_predicate
, SCM_PACK (key
));
556 return SCM_UNSPECIFIED
;
559 return scm_hash_fn_remove_x (table
, key
,
560 (scm_t_hash_fn
) scm_ihashv
,
561 (scm_t_assoc_fn
) scm_sloppy_assv
,
568 SCM_DEFINE (scm_hash_get_handle
, "hash-get-handle", 2, 0, 0,
569 (SCM table
, SCM key
),
570 "This procedure returns the @code{(key . value)} pair from the\n"
571 "hash table @var{table}. If @var{table} does not hold an\n"
572 "associated value for @var{key}, @code{#f} is returned.\n"
573 "Uses @code{equal?} for equality testing.")
574 #define FUNC_NAME s_scm_hash_get_handle
576 return scm_hash_fn_get_handle (table
, key
,
577 (scm_t_hash_fn
) scm_ihash
,
578 (scm_t_assoc_fn
) scm_sloppy_assoc
,
584 SCM_DEFINE (scm_hash_create_handle_x
, "hash-create-handle!", 3, 0, 0,
585 (SCM table
, SCM key
, SCM init
),
586 "This function looks up @var{key} in @var{table} and returns its handle.\n"
587 "If @var{key} is not already present, a new handle is created which\n"
588 "associates @var{key} with @var{init}.")
589 #define FUNC_NAME s_scm_hash_create_handle_x
591 return scm_hash_fn_create_handle_x (table
, key
, init
,
592 (scm_t_hash_fn
) scm_ihash
,
593 (scm_t_assoc_fn
) scm_sloppy_assoc
,
600 assoc_predicate (SCM k
, SCM v
, void *closure
)
602 return scm_is_true (scm_equal_p (k
, SCM_PACK_POINTER (closure
)));
605 SCM_DEFINE (scm_hash_ref
, "hash-ref", 2, 1, 0,
606 (SCM table
, SCM key
, SCM dflt
),
607 "Look up @var{key} in the hash table @var{table}, and return the\n"
608 "value (if any) associated with it. If @var{key} is not found,\n"
609 "return @var{dflt} (or @code{#f} if no @var{dflt} argument\n"
610 "is supplied). Uses @code{equal?} for equality testing.")
611 #define FUNC_NAME s_scm_hash_ref
613 if (SCM_UNBNDP (dflt
))
616 if (SCM_WEAK_TABLE_P (table
))
617 return scm_c_weak_table_ref (table
, scm_ihash (key
, -1),
618 assoc_predicate
, SCM_PACK (key
), dflt
);
620 return scm_hash_fn_ref (table
, key
, dflt
,
621 (scm_t_hash_fn
) scm_ihash
,
622 (scm_t_assoc_fn
) scm_sloppy_assoc
,
629 SCM_DEFINE (scm_hash_set_x
, "hash-set!", 3, 0, 0,
630 (SCM table
, SCM key
, SCM val
),
631 "Find the entry in @var{table} associated with @var{key}, and\n"
632 "store @var{val} there. Uses @code{equal?} for equality\n"
634 #define FUNC_NAME s_scm_hash_set_x
636 if (SCM_WEAK_TABLE_P (table
))
638 scm_c_weak_table_put_x (table
, scm_ihash (key
, -1),
639 assoc_predicate
, SCM_PACK (key
),
641 return SCM_UNSPECIFIED
;
644 return scm_hash_fn_set_x (table
, key
, val
,
645 (scm_t_hash_fn
) scm_ihash
,
646 (scm_t_assoc_fn
) scm_sloppy_assoc
,
653 SCM_DEFINE (scm_hash_remove_x
, "hash-remove!", 2, 0, 0,
654 (SCM table
, SCM key
),
655 "Remove @var{key} (and any value associated with it) from\n"
656 "@var{table}. Uses @code{equal?} for equality tests.")
657 #define FUNC_NAME s_scm_hash_remove_x
659 if (SCM_WEAK_TABLE_P (table
))
661 scm_c_weak_table_remove_x (table
, scm_ihash (key
, -1),
662 assoc_predicate
, SCM_PACK (key
));
663 return SCM_UNSPECIFIED
;
666 return scm_hash_fn_remove_x (table
, key
,
667 (scm_t_hash_fn
) scm_ihash
,
668 (scm_t_assoc_fn
) scm_sloppy_assoc
,
676 typedef struct scm_t_ihashx_closure
681 } scm_t_ihashx_closure
;
684 scm_ihashx (SCM obj
, unsigned long n
, void *arg
)
687 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
688 answer
= scm_call_2 (closure
->hash
, obj
, scm_from_ulong (n
));
689 return scm_to_ulong (answer
);
693 scm_sloppy_assx (SCM obj
, SCM alist
, void *arg
)
695 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
696 return scm_call_2 (closure
->assoc
, obj
, alist
);
700 assx_predicate (SCM k
, SCM v
, void *closure
)
702 scm_t_ihashx_closure
*c
= (scm_t_ihashx_closure
*) closure
;
704 /* FIXME: The hashx interface is crazy. Hash tables have nothing to
705 do with alists in principle. Instead of getting an assoc proc,
706 hashx functions should use an equality predicate. Perhaps we can
707 change this before 2.2, but until then, add a terrible, terrible
710 return scm_is_true (scm_call_2 (c
->assoc
, c
->key
, scm_acons (k
, v
, SCM_EOL
)));
714 SCM_DEFINE (scm_hashx_get_handle
, "hashx-get-handle", 4, 0, 0,
715 (SCM hash
, SCM assoc
, SCM table
, SCM key
),
716 "This behaves the same way as the corresponding\n"
717 "@code{-get-handle} function, but uses @var{hash} as a hash\n"
718 "function and @var{assoc} to compare keys. @code{hash} must be\n"
719 "a function that takes two arguments, a key to be hashed and a\n"
720 "table size. @code{assoc} must be an associator function, like\n"
721 "@code{assoc}, @code{assq} or @code{assv}.")
722 #define FUNC_NAME s_scm_hashx_get_handle
724 scm_t_ihashx_closure closure
;
726 closure
.assoc
= assoc
;
729 return scm_hash_fn_get_handle (table
, key
, scm_ihashx
, scm_sloppy_assx
,
735 SCM_DEFINE (scm_hashx_create_handle_x
, "hashx-create-handle!", 5, 0, 0,
736 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM init
),
737 "This behaves the same way as the corresponding\n"
738 "@code{-create-handle} function, but uses @var{hash} as a hash\n"
739 "function and @var{assoc} to compare keys. @code{hash} must be\n"
740 "a function that takes two arguments, a key to be hashed and a\n"
741 "table size. @code{assoc} must be an associator function, like\n"
742 "@code{assoc}, @code{assq} or @code{assv}.")
743 #define FUNC_NAME s_scm_hashx_create_handle_x
745 scm_t_ihashx_closure closure
;
747 closure
.assoc
= assoc
;
750 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashx
,
751 scm_sloppy_assx
, (void *)&closure
);
757 SCM_DEFINE (scm_hashx_ref
, "hashx-ref", 4, 1, 0,
758 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM dflt
),
759 "This behaves the same way as the corresponding @code{ref}\n"
760 "function, but uses @var{hash} as a hash function and\n"
761 "@var{assoc} to compare keys. @code{hash} must be a function\n"
762 "that takes two arguments, a key to be hashed and a table size.\n"
763 "@code{assoc} must be an associator function, like @code{assoc},\n"
764 "@code{assq} or @code{assv}.\n"
766 "By way of illustration, @code{hashq-ref table key} is\n"
767 "equivalent to @code{hashx-ref hashq assq table key}.")
768 #define FUNC_NAME s_scm_hashx_ref
770 scm_t_ihashx_closure closure
;
771 if (SCM_UNBNDP (dflt
))
774 closure
.assoc
= assoc
;
777 if (SCM_WEAK_TABLE_P (table
))
779 unsigned long h
= scm_to_ulong (scm_call_2 (hash
, key
,
780 scm_from_ulong (-1)));
781 return scm_c_weak_table_ref (table
, h
, assx_predicate
, &closure
, dflt
);
784 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashx
, scm_sloppy_assx
,
792 SCM_DEFINE (scm_hashx_set_x
, "hashx-set!", 5, 0, 0,
793 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM val
),
794 "This behaves the same way as the corresponding @code{set!}\n"
795 "function, but uses @var{hash} as a hash function and\n"
796 "@var{assoc} to compare keys. @code{hash} must be a function\n"
797 "that takes two arguments, a key to be hashed and a table size.\n"
798 "@code{assoc} must be an associator function, like @code{assoc},\n"
799 "@code{assq} or @code{assv}.\n"
801 " By way of illustration, @code{hashq-set! table key} is\n"
802 "equivalent to @code{hashx-set! hashq assq table key}.")
803 #define FUNC_NAME s_scm_hashx_set_x
805 scm_t_ihashx_closure closure
;
807 closure
.assoc
= assoc
;
810 if (SCM_WEAK_TABLE_P (table
))
812 unsigned long h
= scm_to_ulong (scm_call_2 (hash
, key
,
813 scm_from_ulong (-1)));
814 scm_c_weak_table_put_x (table
, h
, assx_predicate
, &closure
, key
, val
);
815 return SCM_UNSPECIFIED
;
818 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashx
, scm_sloppy_assx
,
823 SCM_DEFINE (scm_hashx_remove_x
, "hashx-remove!", 4, 0, 0,
824 (SCM hash
, SCM assoc
, SCM table
, SCM obj
),
825 "This behaves the same way as the corresponding @code{remove!}\n"
826 "function, but uses @var{hash} as a hash function and\n"
827 "@var{assoc} to compare keys. @code{hash} must be a function\n"
828 "that takes two arguments, a key to be hashed and a table size.\n"
829 "@code{assoc} must be an associator function, like @code{assoc},\n"
830 "@code{assq} or @code{assv}.\n"
832 " By way of illustration, @code{hashq-remove! table key} is\n"
833 "equivalent to @code{hashx-remove! hashq assq #f table key}.")
834 #define FUNC_NAME s_scm_hashx_remove_x
836 scm_t_ihashx_closure closure
;
838 closure
.assoc
= assoc
;
841 if (SCM_WEAK_TABLE_P (table
))
843 unsigned long h
= scm_to_ulong (scm_call_2 (hash
, obj
,
844 scm_from_ulong (-1)));
845 scm_c_weak_table_remove_x (table
, h
, assx_predicate
, &closure
);
846 return SCM_UNSPECIFIED
;
849 return scm_hash_fn_remove_x (table
, obj
, scm_ihashx
, scm_sloppy_assx
,
854 /* Hash table iterators */
856 SCM_DEFINE (scm_hash_fold
, "hash-fold", 3, 0, 0,
857 (SCM proc
, SCM init
, SCM table
),
858 "An iterator over hash-table elements.\n"
859 "Accumulates and returns a result by applying PROC successively.\n"
860 "The arguments to PROC are \"(key value prior-result)\" where key\n"
861 "and value are successive pairs from the hash table TABLE, and\n"
862 "prior-result is either INIT (for the first application of PROC)\n"
863 "or the return value of the previous application of PROC.\n"
864 "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
865 "table into an a-list of key-value pairs.")
866 #define FUNC_NAME s_scm_hash_fold
868 SCM_VALIDATE_PROC (1, proc
);
870 if (SCM_WEAK_TABLE_P (table
))
871 return scm_weak_table_fold (proc
, init
, table
);
873 SCM_VALIDATE_HASHTABLE (3, table
);
874 return scm_internal_hash_fold ((scm_t_hash_fold_fn
) scm_call_3
,
875 (void *) SCM_UNPACK (proc
), init
, table
);
880 for_each_proc (void *proc
, SCM handle
)
882 return scm_call_2 (SCM_PACK (proc
), SCM_CAR (handle
), SCM_CDR (handle
));
885 SCM_DEFINE (scm_hash_for_each
, "hash-for-each", 2, 0, 0,
886 (SCM proc
, SCM table
),
887 "An iterator over hash-table elements.\n"
888 "Applies PROC successively on all hash table items.\n"
889 "The arguments to PROC are \"(key value)\" where key\n"
890 "and value are successive pairs from the hash table TABLE.")
891 #define FUNC_NAME s_scm_hash_for_each
893 SCM_VALIDATE_PROC (1, proc
);
895 if (SCM_WEAK_TABLE_P (table
))
896 return scm_weak_table_for_each (proc
, table
);
898 SCM_VALIDATE_HASHTABLE (2, table
);
900 scm_internal_hash_for_each_handle (for_each_proc
,
901 (void *) SCM_UNPACK (proc
),
903 return SCM_UNSPECIFIED
;
907 SCM_DEFINE (scm_hash_for_each_handle
, "hash-for-each-handle", 2, 0, 0,
908 (SCM proc
, SCM table
),
909 "An iterator over hash-table elements.\n"
910 "Applies PROC successively on all hash table handles.")
911 #define FUNC_NAME s_scm_hash_for_each_handle
913 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)), proc
, 1, FUNC_NAME
);
914 SCM_VALIDATE_HASHTABLE (2, table
);
916 scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn
) scm_call_1
,
917 (void *) SCM_UNPACK (proc
),
919 return SCM_UNSPECIFIED
;
924 map_proc (void *proc
, SCM key
, SCM data
, SCM value
)
926 return scm_cons (scm_call_2 (SCM_PACK (proc
), key
, data
), value
);
929 SCM_DEFINE (scm_hash_map_to_list
, "hash-map->list", 2, 0, 0,
930 (SCM proc
, SCM table
),
931 "An iterator over hash-table elements.\n"
932 "Accumulates and returns as a list the results of applying PROC successively.\n"
933 "The arguments to PROC are \"(key value)\" where key\n"
934 "and value are successive pairs from the hash table TABLE.")
935 #define FUNC_NAME s_scm_hash_map_to_list
937 SCM_VALIDATE_PROC (1, proc
);
939 if (SCM_WEAK_TABLE_P (table
))
940 return scm_weak_table_map_to_list (proc
, table
);
942 SCM_VALIDATE_HASHTABLE (2, table
);
943 return scm_internal_hash_fold (map_proc
,
944 (void *) SCM_UNPACK (proc
),
953 scm_internal_hash_fold (scm_t_hash_fold_fn fn
, void *closure
,
955 #define FUNC_NAME s_scm_hash_fold
958 SCM buckets
, result
= init
;
960 if (SCM_WEAK_TABLE_P (table
))
961 return scm_c_weak_table_fold (fn
, closure
, init
, table
);
963 SCM_VALIDATE_HASHTABLE (0, table
);
964 buckets
= SCM_HASHTABLE_VECTOR (table
);
966 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
967 for (i
= 0; i
< n
; ++i
)
971 for (ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
); !scm_is_null (ls
);
974 handle
= SCM_CAR (ls
);
975 result
= fn (closure
, SCM_CAR (handle
), SCM_CDR (handle
), result
);
983 /* The following redundant code is here in order to be able to support
984 hash-for-each-handle. An alternative would have been to replace
985 this code and scm_internal_hash_fold above with a single
986 scm_internal_hash_fold_handles, but we don't want to promote such
990 scm_internal_hash_for_each_handle (scm_t_hash_handle_fn fn
, void *closure
,
992 #define FUNC_NAME s_scm_hash_for_each
997 SCM_VALIDATE_HASHTABLE (0, table
);
998 buckets
= SCM_HASHTABLE_VECTOR (table
);
999 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1001 for (i
= 0; i
< n
; ++i
)
1003 SCM ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
), handle
;
1004 while (!scm_is_null (ls
))
1006 if (!scm_is_pair (ls
))
1007 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1008 handle
= SCM_CAR (ls
);
1009 if (!scm_is_pair (handle
))
1010 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1011 fn (closure
, handle
);
1024 #include "libguile/hashtab.x"