1 /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010, 2011 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 License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
29 #include "libguile/_scm.h"
30 #include "libguile/alist.h"
31 #include "libguile/hash.h"
32 #include "libguile/eval.h"
33 #include "libguile/root.h"
34 #include "libguile/vectors.h"
35 #include "libguile/ports.h"
36 #include "libguile/bdw-gc.h"
38 #include "libguile/validate.h"
39 #include "libguile/hashtab.h"
44 /* A hash table is a cell containing a vector of association lists.
46 * Growing or shrinking, with following rehashing, is triggered when
49 * L = N / S (N: number of items in table, S: bucket vector length)
51 * passes an upper limit of 0.9 or a lower limit of 0.25.
53 * The implementation stores the upper and lower number of items which
54 * trigger a resize in the hashtable object.
56 * Possible hash table sizes (primes) are stored in the array
60 static unsigned long hashtable_size
[] = {
61 31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363,
62 224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041
63 #if SIZEOF_SCM_T_BITS > 4
64 /* vector lengths are stored in the first word of vectors, shifted by
65 8 bits for the tc8, so for 32-bit we only get 2^24-1 = 16777215
66 elements. But we allow a few more sizes for 64-bit. */
67 , 28762081, 57524111, 115048217, 230096423, 460192829
71 #define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long))
73 static char *s_hashtable
= "hashtable";
76 make_hash_table (unsigned long k
, const char *func_name
)
80 int i
= 0, n
= k
? k
: 31;
81 while (i
+ 1 < HASHTABLE_SIZE_N
&& n
> hashtable_size
[i
])
83 n
= hashtable_size
[i
];
85 vector
= scm_c_make_vector (n
, SCM_EOL
);
87 t
= scm_gc_malloc_pointerless (sizeof (*t
), s_hashtable
);
88 t
->min_size_index
= t
->size_index
= i
;
91 t
->upper
= 9 * n
/ 10;
93 /* FIXME: we just need two words of storage, not three */
94 return scm_double_cell (scm_tc7_hashtable
, SCM_UNPACK (vector
),
99 scm_i_rehash (SCM table
,
100 scm_t_hash_fn hash_fn
,
102 const char* func_name
)
104 SCM buckets
, new_buckets
;
106 unsigned long old_size
;
107 unsigned long new_size
;
109 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
111 /* rehashing is not triggered when i <= min_size */
112 i
= SCM_HASHTABLE (table
)->size_index
;
115 while (i
> SCM_HASHTABLE (table
)->min_size_index
116 && SCM_HASHTABLE_N_ITEMS (table
) < hashtable_size
[i
] / 4);
120 i
= SCM_HASHTABLE (table
)->size_index
+ 1;
121 if (i
>= HASHTABLE_SIZE_N
)
125 SCM_HASHTABLE (table
)->size_index
= i
;
127 new_size
= hashtable_size
[i
];
128 if (i
<= SCM_HASHTABLE (table
)->min_size_index
)
129 SCM_HASHTABLE (table
)->lower
= 0;
131 SCM_HASHTABLE (table
)->lower
= new_size
/ 4;
132 SCM_HASHTABLE (table
)->upper
= 9 * new_size
/ 10;
133 buckets
= SCM_HASHTABLE_VECTOR (table
);
135 new_buckets
= scm_c_make_vector (new_size
, SCM_EOL
);
137 SCM_SET_HASHTABLE_VECTOR (table
, new_buckets
);
138 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
140 old_size
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
141 for (i
= 0; i
< old_size
; ++i
)
143 SCM ls
, cell
, handle
;
145 ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
);
146 SCM_SIMPLE_VECTOR_SET (buckets
, i
, SCM_EOL
);
148 while (scm_is_pair (ls
))
153 handle
= SCM_CAR (cell
);
156 h
= hash_fn (SCM_CAR (handle
), new_size
, closure
);
158 scm_out_of_range (func_name
, scm_from_ulong (h
));
159 SCM_SETCDR (cell
, SCM_SIMPLE_VECTOR_REF (new_buckets
, h
));
160 SCM_SIMPLE_VECTOR_SET (new_buckets
, h
, cell
);
161 SCM_HASHTABLE_INCREMENT (table
);
168 scm_i_hashtable_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
170 scm_puts ("#<hash-table ", port
);
171 scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp
), 10, port
);
172 scm_putc ('/', port
);
173 scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp
)),
175 scm_puts (">", port
);
180 scm_c_make_hash_table (unsigned long k
)
182 return make_hash_table (k
, "scm_c_make_hash_table");
185 SCM_DEFINE (scm_make_hash_table
, "make-hash-table", 0, 1, 0,
187 "Make a new abstract hash table object with minimum number of buckets @var{n}\n")
188 #define FUNC_NAME s_scm_make_hash_table
190 return make_hash_table (SCM_UNBNDP (n
) ? 0 : scm_to_ulong (n
), FUNC_NAME
);
194 #define SCM_WEAK_TABLE_P(x) (scm_is_true (scm_weak_table_p (x)))
196 SCM_DEFINE (scm_hash_table_p
, "hash-table?", 1, 0, 0,
198 "Return @code{#t} if @var{obj} is an abstract hash table object.")
199 #define FUNC_NAME s_scm_hash_table_p
201 return scm_from_bool (SCM_HASHTABLE_P (obj
) || SCM_WEAK_TABLE_P (obj
));
206 /* Accessing hash table entries. */
209 scm_hash_fn_get_handle (SCM table
, SCM obj
,
210 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
212 #define FUNC_NAME "scm_hash_fn_get_handle"
217 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
218 buckets
= SCM_HASHTABLE_VECTOR (table
);
220 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
222 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
223 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
224 scm_out_of_range (FUNC_NAME
, scm_from_ulong (k
));
226 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
234 scm_hash_fn_create_handle_x (SCM table
, SCM obj
, SCM init
,
235 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
237 #define FUNC_NAME "scm_hash_fn_create_handle_x"
242 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
243 buckets
= SCM_HASHTABLE_VECTOR (table
);
245 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
246 SCM_MISC_ERROR ("void hashtable", SCM_EOL
);
248 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
249 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
250 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
252 it
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
254 if (scm_is_pair (it
))
256 else if (scm_is_true (it
))
257 scm_wrong_type_arg_msg (NULL
, 0, it
, "a pair");
260 SCM handle
, new_bucket
;
262 handle
= scm_cons (obj
, init
);
263 new_bucket
= scm_cons (handle
, SCM_EOL
);
265 if (!scm_is_eq (SCM_HASHTABLE_VECTOR (table
), buckets
))
267 buckets
= SCM_HASHTABLE_VECTOR (table
);
268 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
269 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
270 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
272 SCM_SETCDR (new_bucket
, SCM_SIMPLE_VECTOR_REF (buckets
, k
));
273 SCM_SIMPLE_VECTOR_SET (buckets
, k
, new_bucket
);
274 SCM_HASHTABLE_INCREMENT (table
);
276 /* Maybe rehash the table. */
277 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
)
278 || SCM_HASHTABLE_N_ITEMS (table
) > SCM_HASHTABLE_UPPER (table
))
279 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
280 return SCM_CAR (new_bucket
);
287 scm_hash_fn_ref (SCM table
, SCM obj
, SCM dflt
,
288 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
291 SCM it
= scm_hash_fn_get_handle (table
, obj
, hash_fn
, assoc_fn
, closure
);
292 if (scm_is_pair (it
))
299 scm_hash_fn_set_x (SCM table
, SCM obj
, SCM val
,
300 scm_t_hash_fn hash_fn
, scm_t_assoc_fn assoc_fn
,
305 pair
= scm_hash_fn_create_handle_x (table
, obj
, val
,
306 hash_fn
, assoc_fn
, closure
);
308 if (!scm_is_eq (SCM_CDR (pair
), val
))
309 SCM_SETCDR (pair
, val
);
316 scm_hash_fn_remove_x (SCM table
, SCM obj
,
317 scm_t_hash_fn hash_fn
,
318 scm_t_assoc_fn assoc_fn
,
320 #define FUNC_NAME "hash_fn_remove_x"
325 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
327 buckets
= SCM_HASHTABLE_VECTOR (table
);
329 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
332 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
333 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
334 scm_out_of_range (FUNC_NAME
, scm_from_ulong (k
));
336 h
= assoc_fn (obj
, SCM_SIMPLE_VECTOR_REF (buckets
, k
), closure
);
340 SCM_SIMPLE_VECTOR_SET
341 (buckets
, k
, scm_delq_x (h
, SCM_SIMPLE_VECTOR_REF (buckets
, k
)));
342 SCM_HASHTABLE_DECREMENT (table
);
343 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
344 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
350 SCM_DEFINE (scm_hash_clear_x
, "hash-clear!", 1, 0, 0,
352 "Remove all items from @var{table} (without triggering a resize).")
353 #define FUNC_NAME s_scm_hash_clear_x
355 if (SCM_WEAK_TABLE_P (table
))
356 return scm_weak_table_clear_x (table
);
358 SCM_VALIDATE_HASHTABLE (SCM_ARG1
, table
);
360 scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table
), SCM_EOL
);
361 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
363 return SCM_UNSPECIFIED
;
369 SCM_DEFINE (scm_hashq_get_handle
, "hashq-get-handle", 2, 0, 0,
370 (SCM table
, SCM key
),
371 "This procedure returns the @code{(key . value)} pair from the\n"
372 "hash table @var{table}. If @var{table} does not hold an\n"
373 "associated value for @var{key}, @code{#f} is returned.\n"
374 "Uses @code{eq?} for equality testing.")
375 #define FUNC_NAME s_scm_hashq_get_handle
377 return scm_hash_fn_get_handle (table
, key
,
378 (scm_t_hash_fn
) scm_ihashq
,
379 (scm_t_assoc_fn
) scm_sloppy_assq
,
385 SCM_DEFINE (scm_hashq_create_handle_x
, "hashq-create-handle!", 3, 0, 0,
386 (SCM table
, SCM key
, SCM init
),
387 "This function looks up @var{key} in @var{table} and returns its handle.\n"
388 "If @var{key} is not already present, a new handle is created which\n"
389 "associates @var{key} with @var{init}.")
390 #define FUNC_NAME s_scm_hashq_create_handle_x
392 return scm_hash_fn_create_handle_x (table
, key
, init
,
393 (scm_t_hash_fn
) scm_ihashq
,
394 (scm_t_assoc_fn
) scm_sloppy_assq
,
400 SCM_DEFINE (scm_hashq_ref
, "hashq-ref", 2, 1, 0,
401 (SCM table
, SCM key
, SCM dflt
),
402 "Look up @var{key} in the hash table @var{table}, and return the\n"
403 "value (if any) associated with it. If @var{key} is not found,\n"
404 "return @var{default} (or @code{#f} if no @var{default} argument\n"
405 "is supplied). Uses @code{eq?} for equality testing.")
406 #define FUNC_NAME s_scm_hashq_ref
408 if (SCM_UNBNDP (dflt
))
411 if (SCM_WEAK_TABLE_P (table
))
412 return scm_weak_table_refq (table
, key
, dflt
);
414 return scm_hash_fn_ref (table
, key
, dflt
,
415 (scm_t_hash_fn
) scm_ihashq
,
416 (scm_t_assoc_fn
) scm_sloppy_assq
,
423 SCM_DEFINE (scm_hashq_set_x
, "hashq-set!", 3, 0, 0,
424 (SCM table
, SCM key
, SCM val
),
425 "Find the entry in @var{table} associated with @var{key}, and\n"
426 "store @var{value} there. Uses @code{eq?} for equality testing.")
427 #define FUNC_NAME s_scm_hashq_set_x
429 if (SCM_WEAK_TABLE_P (table
))
430 return scm_weak_table_putq_x (table
, key
, val
);
432 return scm_hash_fn_set_x (table
, key
, val
,
433 (scm_t_hash_fn
) scm_ihashq
,
434 (scm_t_assoc_fn
) scm_sloppy_assq
,
441 SCM_DEFINE (scm_hashq_remove_x
, "hashq-remove!", 2, 0, 0,
442 (SCM table
, SCM key
),
443 "Remove @var{key} (and any value associated with it) from\n"
444 "@var{table}. Uses @code{eq?} for equality tests.")
445 #define FUNC_NAME s_scm_hashq_remove_x
447 if (SCM_WEAK_TABLE_P (table
))
448 return scm_weak_table_remq_x (table
, key
);
450 return scm_hash_fn_remove_x (table
, key
,
451 (scm_t_hash_fn
) scm_ihashq
,
452 (scm_t_assoc_fn
) scm_sloppy_assq
,
460 SCM_DEFINE (scm_hashv_get_handle
, "hashv-get-handle", 2, 0, 0,
461 (SCM table
, SCM key
),
462 "This procedure returns the @code{(key . value)} pair from the\n"
463 "hash table @var{table}. If @var{table} does not hold an\n"
464 "associated value for @var{key}, @code{#f} is returned.\n"
465 "Uses @code{eqv?} for equality testing.")
466 #define FUNC_NAME s_scm_hashv_get_handle
468 return scm_hash_fn_get_handle (table
, key
,
469 (scm_t_hash_fn
) scm_ihashv
,
470 (scm_t_assoc_fn
) scm_sloppy_assv
,
476 SCM_DEFINE (scm_hashv_create_handle_x
, "hashv-create-handle!", 3, 0, 0,
477 (SCM table
, SCM key
, SCM init
),
478 "This function looks up @var{key} in @var{table} and returns its handle.\n"
479 "If @var{key} is not already present, a new handle is created which\n"
480 "associates @var{key} with @var{init}.")
481 #define FUNC_NAME s_scm_hashv_create_handle_x
483 return scm_hash_fn_create_handle_x (table
, key
, init
,
484 (scm_t_hash_fn
) scm_ihashv
,
485 (scm_t_assoc_fn
) scm_sloppy_assv
,
492 assv_predicate (SCM k
, SCM v
, void *closure
)
494 return scm_is_true (scm_eqv_p (k
, PTR2SCM (closure
)));
497 SCM_DEFINE (scm_hashv_ref
, "hashv-ref", 2, 1, 0,
498 (SCM table
, SCM key
, SCM dflt
),
499 "Look up @var{key} in the hash table @var{table}, and return the\n"
500 "value (if any) associated with it. If @var{key} is not found,\n"
501 "return @var{default} (or @code{#f} if no @var{default} argument\n"
502 "is supplied). Uses @code{eqv?} for equality testing.")
503 #define FUNC_NAME s_scm_hashv_ref
505 if (SCM_UNBNDP (dflt
))
508 if (SCM_WEAK_TABLE_P (table
))
509 return scm_c_weak_table_ref (table
, scm_ihashv (key
, -1),
510 assv_predicate
, SCM_PACK (key
), dflt
);
512 return scm_hash_fn_ref (table
, key
, dflt
,
513 (scm_t_hash_fn
) scm_ihashv
,
514 (scm_t_assoc_fn
) scm_sloppy_assv
,
521 SCM_DEFINE (scm_hashv_set_x
, "hashv-set!", 3, 0, 0,
522 (SCM table
, SCM key
, SCM val
),
523 "Find the entry in @var{table} associated with @var{key}, and\n"
524 "store @var{value} there. Uses @code{eqv?} for equality testing.")
525 #define FUNC_NAME s_scm_hashv_set_x
527 if (SCM_WEAK_TABLE_P (table
))
529 scm_c_weak_table_put_x (table
, scm_ihashv (key
, -1),
530 assv_predicate
, SCM_PACK (key
),
532 return SCM_UNSPECIFIED
;
535 return scm_hash_fn_set_x (table
, key
, val
,
536 (scm_t_hash_fn
) scm_ihashv
,
537 (scm_t_assoc_fn
) scm_sloppy_assv
,
543 SCM_DEFINE (scm_hashv_remove_x
, "hashv-remove!", 2, 0, 0,
544 (SCM table
, SCM key
),
545 "Remove @var{key} (and any value associated with it) from\n"
546 "@var{table}. Uses @code{eqv?} for equality tests.")
547 #define FUNC_NAME s_scm_hashv_remove_x
549 if (SCM_WEAK_TABLE_P (table
))
551 scm_c_weak_table_remove_x (table
, scm_ihashv (key
, -1),
552 assv_predicate
, SCM_PACK (key
));
553 return SCM_UNSPECIFIED
;
556 return scm_hash_fn_remove_x (table
, key
,
557 (scm_t_hash_fn
) scm_ihashv
,
558 (scm_t_assoc_fn
) scm_sloppy_assv
,
565 SCM_DEFINE (scm_hash_get_handle
, "hash-get-handle", 2, 0, 0,
566 (SCM table
, SCM key
),
567 "This procedure returns the @code{(key . value)} pair from the\n"
568 "hash table @var{table}. If @var{table} does not hold an\n"
569 "associated value for @var{key}, @code{#f} is returned.\n"
570 "Uses @code{equal?} for equality testing.")
571 #define FUNC_NAME s_scm_hash_get_handle
573 return scm_hash_fn_get_handle (table
, key
,
574 (scm_t_hash_fn
) scm_ihash
,
575 (scm_t_assoc_fn
) scm_sloppy_assoc
,
581 SCM_DEFINE (scm_hash_create_handle_x
, "hash-create-handle!", 3, 0, 0,
582 (SCM table
, SCM key
, SCM init
),
583 "This function looks up @var{key} in @var{table} and returns its handle.\n"
584 "If @var{key} is not already present, a new handle is created which\n"
585 "associates @var{key} with @var{init}.")
586 #define FUNC_NAME s_scm_hash_create_handle_x
588 return scm_hash_fn_create_handle_x (table
, key
, init
,
589 (scm_t_hash_fn
) scm_ihash
,
590 (scm_t_assoc_fn
) scm_sloppy_assoc
,
597 assoc_predicate (SCM k
, SCM v
, void *closure
)
599 return scm_is_true (scm_equal_p (k
, PTR2SCM (closure
)));
602 SCM_DEFINE (scm_hash_ref
, "hash-ref", 2, 1, 0,
603 (SCM table
, SCM key
, SCM dflt
),
604 "Look up @var{key} in the hash table @var{table}, and return the\n"
605 "value (if any) associated with it. If @var{key} is not found,\n"
606 "return @var{default} (or @code{#f} if no @var{default} argument\n"
607 "is supplied). Uses @code{equal?} for equality testing.")
608 #define FUNC_NAME s_scm_hash_ref
610 if (SCM_UNBNDP (dflt
))
613 if (SCM_WEAK_TABLE_P (table
))
614 return scm_c_weak_table_ref (table
, scm_ihash (key
, -1),
615 assoc_predicate
, SCM_PACK (key
), dflt
);
617 return scm_hash_fn_ref (table
, key
, dflt
,
618 (scm_t_hash_fn
) scm_ihash
,
619 (scm_t_assoc_fn
) scm_sloppy_assoc
,
626 SCM_DEFINE (scm_hash_set_x
, "hash-set!", 3, 0, 0,
627 (SCM table
, SCM key
, SCM val
),
628 "Find the entry in @var{table} associated with @var{key}, and\n"
629 "store @var{value} there. Uses @code{equal?} for equality\n"
631 #define FUNC_NAME s_scm_hash_set_x
633 if (SCM_WEAK_TABLE_P (table
))
635 scm_c_weak_table_put_x (table
, scm_ihash (key
, -1),
636 assoc_predicate
, SCM_PACK (key
),
638 return SCM_UNSPECIFIED
;
641 return scm_hash_fn_set_x (table
, key
, val
,
642 (scm_t_hash_fn
) scm_ihash
,
643 (scm_t_assoc_fn
) scm_sloppy_assoc
,
650 SCM_DEFINE (scm_hash_remove_x
, "hash-remove!", 2, 0, 0,
651 (SCM table
, SCM key
),
652 "Remove @var{key} (and any value associated with it) from\n"
653 "@var{table}. Uses @code{equal?} for equality tests.")
654 #define FUNC_NAME s_scm_hash_remove_x
656 if (SCM_WEAK_TABLE_P (table
))
658 scm_c_weak_table_remove_x (table
, scm_ihash (key
, -1),
659 assoc_predicate
, SCM_PACK (key
));
660 return SCM_UNSPECIFIED
;
663 return scm_hash_fn_remove_x (table
, key
,
664 (scm_t_hash_fn
) scm_ihash
,
665 (scm_t_assoc_fn
) scm_sloppy_assoc
,
673 typedef struct scm_t_ihashx_closure
678 } scm_t_ihashx_closure
;
681 scm_ihashx (SCM obj
, unsigned long n
, void *arg
)
684 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
685 answer
= scm_call_2 (closure
->hash
, obj
, scm_from_ulong (n
));
686 return scm_to_ulong (answer
);
690 scm_sloppy_assx (SCM obj
, SCM alist
, void *arg
)
692 scm_t_ihashx_closure
*closure
= (scm_t_ihashx_closure
*) arg
;
693 return scm_call_2 (closure
->assoc
, obj
, alist
);
697 assx_predicate (SCM k
, SCM v
, void *closure
)
699 scm_t_ihashx_closure
*c
= (scm_t_ihashx_closure
*) closure
;
701 /* FIXME: The hashx interface is crazy. Hash tables have nothing to
702 do with alists in principle. Instead of getting an assoc proc,
703 hashx functions should use an equality predicate. Perhaps we can
704 change this before 2.2, but until then, add a terrible, terrible
707 return scm_is_true (scm_call_2 (c
->assoc
, c
->key
, scm_acons (k
, v
, SCM_EOL
)));
711 SCM_DEFINE (scm_hashx_get_handle
, "hashx-get-handle", 4, 0, 0,
712 (SCM hash
, SCM assoc
, SCM table
, SCM key
),
713 "This behaves the same way as the corresponding\n"
714 "@code{-get-handle} function, but uses @var{hash} as a hash\n"
715 "function and @var{assoc} to compare keys. @code{hash} must be\n"
716 "a function that takes two arguments, a key to be hashed and a\n"
717 "table size. @code{assoc} must be an associator function, like\n"
718 "@code{assoc}, @code{assq} or @code{assv}.")
719 #define FUNC_NAME s_scm_hashx_get_handle
721 scm_t_ihashx_closure closure
;
723 closure
.assoc
= assoc
;
726 return scm_hash_fn_get_handle (table
, key
, scm_ihashx
, scm_sloppy_assx
,
732 SCM_DEFINE (scm_hashx_create_handle_x
, "hashx-create-handle!", 5, 0, 0,
733 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM init
),
734 "This behaves the same way as the corresponding\n"
735 "@code{-create-handle} function, but uses @var{hash} as a hash\n"
736 "function and @var{assoc} to compare keys. @code{hash} must be\n"
737 "a function that takes two arguments, a key to be hashed and a\n"
738 "table size. @code{assoc} must be an associator function, like\n"
739 "@code{assoc}, @code{assq} or @code{assv}.")
740 #define FUNC_NAME s_scm_hashx_create_handle_x
742 scm_t_ihashx_closure closure
;
744 closure
.assoc
= assoc
;
747 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashx
,
748 scm_sloppy_assx
, (void *)&closure
);
754 SCM_DEFINE (scm_hashx_ref
, "hashx-ref", 4, 1, 0,
755 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM dflt
),
756 "This behaves the same way as the corresponding @code{ref}\n"
757 "function, but uses @var{hash} as a hash function and\n"
758 "@var{assoc} to compare keys. @code{hash} must be a function\n"
759 "that takes two arguments, a key to be hashed and a table size.\n"
760 "@code{assoc} must be an associator function, like @code{assoc},\n"
761 "@code{assq} or @code{assv}.\n"
763 "By way of illustration, @code{hashq-ref table key} is\n"
764 "equivalent to @code{hashx-ref hashq assq table key}.")
765 #define FUNC_NAME s_scm_hashx_ref
767 scm_t_ihashx_closure closure
;
768 if (SCM_UNBNDP (dflt
))
771 closure
.assoc
= assoc
;
774 if (SCM_WEAK_TABLE_P (table
))
776 unsigned long h
= scm_to_ulong (scm_call_2 (hash
, key
,
777 scm_from_ulong (-1)));
778 return scm_c_weak_table_ref (table
, h
, assx_predicate
, &closure
, dflt
);
781 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashx
, scm_sloppy_assx
,
789 SCM_DEFINE (scm_hashx_set_x
, "hashx-set!", 5, 0, 0,
790 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM val
),
791 "This behaves the same way as the corresponding @code{set!}\n"
792 "function, but uses @var{hash} as a hash function and\n"
793 "@var{assoc} to compare keys. @code{hash} must be a function\n"
794 "that takes two arguments, a key to be hashed and a table size.\n"
795 "@code{assoc} must be an associator function, like @code{assoc},\n"
796 "@code{assq} or @code{assv}.\n"
798 " By way of illustration, @code{hashq-set! table key} is\n"
799 "equivalent to @code{hashx-set! hashq assq table key}.")
800 #define FUNC_NAME s_scm_hashx_set_x
802 scm_t_ihashx_closure closure
;
804 closure
.assoc
= assoc
;
807 if (SCM_WEAK_TABLE_P (table
))
809 unsigned long h
= scm_to_ulong (scm_call_2 (hash
, key
,
810 scm_from_ulong (-1)));
811 scm_c_weak_table_put_x (table
, h
, assx_predicate
, &closure
, key
, val
);
812 return SCM_UNSPECIFIED
;
815 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashx
, scm_sloppy_assx
,
820 SCM_DEFINE (scm_hashx_remove_x
, "hashx-remove!", 4, 0, 0,
821 (SCM hash
, SCM assoc
, SCM table
, SCM obj
),
822 "This behaves the same way as the corresponding @code{remove!}\n"
823 "function, but uses @var{hash} as a hash function and\n"
824 "@var{assoc} to compare keys. @code{hash} must be a function\n"
825 "that takes two arguments, a key to be hashed and a table size.\n"
826 "@code{assoc} must be an associator function, like @code{assoc},\n"
827 "@code{assq} or @code{assv}.\n"
829 " By way of illustration, @code{hashq-remove! table key} is\n"
830 "equivalent to @code{hashx-remove! hashq assq #f table key}.")
831 #define FUNC_NAME s_scm_hashx_remove_x
833 scm_t_ihashx_closure closure
;
835 closure
.assoc
= assoc
;
838 if (SCM_WEAK_TABLE_P (table
))
840 unsigned long h
= scm_to_ulong (scm_call_2 (hash
, obj
,
841 scm_from_ulong (-1)));
842 scm_c_weak_table_remove_x (table
, h
, assx_predicate
, &closure
);
843 return SCM_UNSPECIFIED
;
846 return scm_hash_fn_remove_x (table
, obj
, scm_ihashx
, scm_sloppy_assx
,
851 /* Hash table iterators */
853 SCM_DEFINE (scm_hash_fold
, "hash-fold", 3, 0, 0,
854 (SCM proc
, SCM init
, SCM table
),
855 "An iterator over hash-table elements.\n"
856 "Accumulates and returns a result by applying PROC successively.\n"
857 "The arguments to PROC are \"(key value prior-result)\" where key\n"
858 "and value are successive pairs from the hash table TABLE, and\n"
859 "prior-result is either INIT (for the first application of PROC)\n"
860 "or the return value of the previous application of PROC.\n"
861 "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
862 "table into an a-list of key-value pairs.")
863 #define FUNC_NAME s_scm_hash_fold
865 SCM_VALIDATE_PROC (1, proc
);
867 if (SCM_WEAK_TABLE_P (table
))
868 return scm_weak_table_fold (proc
, init
, table
);
870 SCM_VALIDATE_HASHTABLE (3, table
);
871 return scm_internal_hash_fold ((scm_t_hash_fold_fn
) scm_call_3
,
872 (void *) SCM_UNPACK (proc
), init
, table
);
877 for_each_proc (void *proc
, SCM handle
)
879 return scm_call_2 (SCM_PACK (proc
), SCM_CAR (handle
), SCM_CDR (handle
));
882 SCM_DEFINE (scm_hash_for_each
, "hash-for-each", 2, 0, 0,
883 (SCM proc
, SCM table
),
884 "An iterator over hash-table elements.\n"
885 "Applies PROC successively on all hash table items.\n"
886 "The arguments to PROC are \"(key value)\" where key\n"
887 "and value are successive pairs from the hash table TABLE.")
888 #define FUNC_NAME s_scm_hash_for_each
890 SCM_VALIDATE_PROC (1, proc
);
892 if (SCM_WEAK_TABLE_P (table
))
893 return scm_weak_table_for_each (proc
, table
);
895 SCM_VALIDATE_HASHTABLE (2, table
);
897 scm_internal_hash_for_each_handle (for_each_proc
,
898 (void *) SCM_UNPACK (proc
),
900 return SCM_UNSPECIFIED
;
904 SCM_DEFINE (scm_hash_for_each_handle
, "hash-for-each-handle", 2, 0, 0,
905 (SCM proc
, SCM table
),
906 "An iterator over hash-table elements.\n"
907 "Applies PROC successively on all hash table handles.")
908 #define FUNC_NAME s_scm_hash_for_each_handle
910 SCM_ASSERT (scm_is_true (scm_procedure_p (proc
)), proc
, 1, FUNC_NAME
);
911 SCM_VALIDATE_HASHTABLE (2, table
);
913 scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn
) scm_call_1
,
914 (void *) SCM_UNPACK (proc
),
916 return SCM_UNSPECIFIED
;
921 map_proc (void *proc
, SCM key
, SCM data
, SCM value
)
923 return scm_cons (scm_call_2 (SCM_PACK (proc
), key
, data
), value
);
926 SCM_DEFINE (scm_hash_map_to_list
, "hash-map->list", 2, 0, 0,
927 (SCM proc
, SCM table
),
928 "An iterator over hash-table elements.\n"
929 "Accumulates and returns as a list the results of applying PROC successively.\n"
930 "The arguments to PROC are \"(key value)\" where key\n"
931 "and value are successive pairs from the hash table TABLE.")
932 #define FUNC_NAME s_scm_hash_map_to_list
934 SCM_VALIDATE_PROC (1, proc
);
936 if (SCM_WEAK_TABLE_P (table
))
937 return scm_weak_table_map_to_list (proc
, table
);
939 SCM_VALIDATE_HASHTABLE (2, table
);
940 return scm_internal_hash_fold (map_proc
,
941 (void *) SCM_UNPACK (proc
),
950 scm_internal_hash_fold (scm_t_hash_fold_fn fn
, void *closure
,
952 #define FUNC_NAME s_scm_hash_fold
955 SCM buckets
, result
= init
;
957 if (SCM_WEAK_TABLE_P (table
))
958 return scm_c_weak_table_fold (fn
, closure
, init
, table
);
960 SCM_VALIDATE_HASHTABLE (0, table
);
961 buckets
= SCM_HASHTABLE_VECTOR (table
);
963 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
964 for (i
= 0; i
< n
; ++i
)
968 for (ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
); !scm_is_null (ls
);
971 handle
= SCM_CAR (ls
);
972 result
= fn (closure
, SCM_CAR (handle
), SCM_CDR (handle
), result
);
980 /* The following redundant code is here in order to be able to support
981 hash-for-each-handle. An alternative would have been to replace
982 this code and scm_internal_hash_fold above with a single
983 scm_internal_hash_fold_handles, but we don't want to promote such
987 scm_internal_hash_for_each_handle (scm_t_hash_handle_fn fn
, void *closure
,
989 #define FUNC_NAME s_scm_hash_for_each
994 SCM_VALIDATE_HASHTABLE (0, table
);
995 buckets
= SCM_HASHTABLE_VECTOR (table
);
996 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
998 for (i
= 0; i
< n
; ++i
)
1000 SCM ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
), handle
;
1001 while (!scm_is_null (ls
))
1003 if (!scm_is_pair (ls
))
1004 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1005 handle
= SCM_CAR (ls
);
1006 if (!scm_is_pair (handle
))
1007 SCM_WRONG_TYPE_ARG (SCM_ARG3
, buckets
);
1008 fn (closure
, handle
);
1021 #include "libguile/hashtab.x"