1 /* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2003, 2004, 2006,
2 * 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
3 *
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.
8 *
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.
13 *
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
17 * 02110-1301 USA
18 */
19
20
21
22 #ifdef HAVE_CONFIG_H
23 # include <config.h>
24 #endif
25
26 #include <alloca.h>
27 #include <stdio.h>
28 #include <assert.h>
29
30 #include "libguile/_scm.h"
31 #include "libguile/alist.h"
32 #include "libguile/hash.h"
33 #include "libguile/eval.h"
34 #include "libguile/vectors.h"
35 #include "libguile/ports.h"
36 #include "libguile/bdw-gc.h"
37
38 #include "libguile/validate.h"
39 #include "libguile/hashtab.h"
40
41
42
43
44 /* A hash table is a cell containing a vector of association lists.
45 *
46 * Growing or shrinking, with following rehashing, is triggered when
47 * the load factor
48 *
49 * L = N / S (N: number of items in table, S: bucket vector length)
50 *
51 * passes an upper limit of 0.9 or a lower limit of 0.25.
52 *
53 * The implementation stores the upper and lower number of items which
54 * trigger a resize in the hashtable object.
55 *
56 * Possible hash table sizes (primes) are stored in the array
57 * hashtable_size.
58 */
59
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
68 #endif
69 };
70
71 #define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long))
72
73 static char *s_hashtable = "hashtable";
74
75 static SCM
make_hash_table(unsigned long k,const char * func_name)76 make_hash_table (unsigned long k, const char *func_name)
77 {
78 SCM vector;
79 scm_t_hashtable *t;
80 int i = 0, n = k ? k : 31;
81 while (i + 1 < HASHTABLE_SIZE_N && n > hashtable_size[i])
82 ++i;
83 n = hashtable_size[i];
84
85 vector = scm_c_make_vector (n, SCM_EOL);
86
87 t = scm_gc_malloc_pointerless (sizeof (*t), s_hashtable);
88 t->min_size_index = t->size_index = i;
89 t->n_items = 0;
90 t->lower = 0;
91 t->upper = 9 * n / 10;
92
93 /* FIXME: we just need two words of storage, not three */
94 return scm_double_cell (scm_tc7_hashtable, SCM_UNPACK (vector),
95 (scm_t_bits)t, 0);
96 }
97
98 void
scm_i_rehash(SCM table,scm_t_hash_fn hash_fn,void * closure,const char * func_name)99 scm_i_rehash (SCM table,
100 scm_t_hash_fn hash_fn,
101 void *closure,
102 const char* func_name)
103 {
104 SCM buckets, new_buckets;
105 int i;
106 unsigned long old_size;
107 unsigned long new_size;
108
109 if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table))
110 {
111 /* rehashing is not triggered when i <= min_size */
112 i = SCM_HASHTABLE (table)->size_index;
113 do
114 --i;
115 while (i > SCM_HASHTABLE (table)->min_size_index
116 && SCM_HASHTABLE_N_ITEMS (table) < hashtable_size[i] / 4);
117 }
118 else
119 {
120 i = SCM_HASHTABLE (table)->size_index + 1;
121 if (i >= HASHTABLE_SIZE_N)
122 /* don't rehash */
123 return;
124 }
125 SCM_HASHTABLE (table)->size_index = i;
126
127 new_size = hashtable_size[i];
128 if (i <= SCM_HASHTABLE (table)->min_size_index)
129 SCM_HASHTABLE (table)->lower = 0;
130 else
131 SCM_HASHTABLE (table)->lower = new_size / 4;
132 SCM_HASHTABLE (table)->upper = 9 * new_size / 10;
133 buckets = SCM_HASHTABLE_VECTOR (table);
134
135 new_buckets = scm_c_make_vector (new_size, SCM_EOL);
136
137 SCM_SET_HASHTABLE_VECTOR (table, new_buckets);
138 SCM_SET_HASHTABLE_N_ITEMS (table, 0);
139
140 old_size = SCM_SIMPLE_VECTOR_LENGTH (buckets);
141 for (i = 0; i < old_size; ++i)
142 {
143 SCM ls, cell, handle;
144
145 ls = SCM_SIMPLE_VECTOR_REF (buckets, i);
146 SCM_SIMPLE_VECTOR_SET (buckets, i, SCM_EOL);
147
148 while (scm_is_pair (ls))
149 {
150 unsigned long h;
151
152 cell = ls;
153 handle = SCM_CAR (cell);
154 ls = SCM_CDR (ls);
155
156 h = hash_fn (SCM_CAR (handle), new_size, closure);
157 if (h >= new_size)
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);
162 }
163 }
164 }
165
166
167 void
scm_i_hashtable_print(SCM exp,SCM port,scm_print_state * pstate)168 scm_i_hashtable_print (SCM exp, SCM port, scm_print_state *pstate)
169 {
170 scm_puts ("#<hash-table ", port);
171 scm_uintprint (SCM_UNPACK (exp), 16, port);
172 scm_putc (' ', port);
173 scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp), 10, port);
174 scm_putc ('/', port);
175 scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp)),
176 10, port);
177 scm_puts (">", port);
178 }
179
180
181 SCM
scm_c_make_hash_table(unsigned long k)182 scm_c_make_hash_table (unsigned long k)
183 {
184 return make_hash_table (k, "scm_c_make_hash_table");
185 }
186
187 SCM_DEFINE (scm_make_hash_table, "make-hash-table", 0, 1, 0,
188 (SCM n),
189 "Make a new abstract hash table object with minimum number of buckets @var{n}\n")
190 #define FUNC_NAME s_scm_make_hash_table
191 {
192 return make_hash_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n), FUNC_NAME);
193 }
194 #undef FUNC_NAME
195
196 #define SCM_WEAK_TABLE_P(x) (scm_is_true (scm_weak_table_p (x)))
197
198 SCM_DEFINE (scm_hash_table_p, "hash-table?", 1, 0, 0,
199 (SCM obj),
200 "Return @code{#t} if @var{obj} is an abstract hash table object.")
201 #define FUNC_NAME s_scm_hash_table_p
202 {
203 return scm_from_bool (SCM_HASHTABLE_P (obj) || SCM_WEAK_TABLE_P (obj));
204 }
205 #undef FUNC_NAME
206
207
208
209 /* Accessing hash table entries. */
210
211 SCM
scm_hash_fn_get_handle(SCM table,SCM obj,scm_t_hash_fn hash_fn,scm_t_assoc_fn assoc_fn,void * closure)212 scm_hash_fn_get_handle (SCM table, SCM obj,
213 scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
214 void * closure)
215 #define FUNC_NAME "scm_hash_fn_get_handle"
216 {
217 unsigned long k;
218 SCM buckets, h;
219
220 SCM_VALIDATE_HASHTABLE (SCM_ARG1, table);
221 buckets = SCM_HASHTABLE_VECTOR (table);
222
223 if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0)
224 return SCM_BOOL_F;
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));
228
229 h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
230
231 return h;
232 }
233 #undef FUNC_NAME
234
235
236 SCM
scm_hash_fn_create_handle_x(SCM table,SCM obj,SCM init,scm_t_hash_fn hash_fn,scm_t_assoc_fn assoc_fn,void * 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,
239 void * closure)
240 #define FUNC_NAME "scm_hash_fn_create_handle_x"
241 {
242 unsigned long k;
243 SCM buckets, it;
244
245 SCM_VALIDATE_HASHTABLE (SCM_ARG1, table);
246 buckets = SCM_HASHTABLE_VECTOR (table);
247
248 if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0)
249 SCM_MISC_ERROR ("void hashtable", SCM_EOL);
250
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));
254
255 it = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
256
257 if (scm_is_pair (it))
258 return it;
259 else if (scm_is_true (it))
260 scm_wrong_type_arg_msg (NULL, 0, it, "a pair");
261 else
262 {
263 SCM handle, new_bucket;
264
265 handle = scm_cons (obj, init);
266 new_bucket = scm_cons (handle, SCM_EOL);
267
268 if (!scm_is_eq (SCM_HASHTABLE_VECTOR (table), buckets))
269 {
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));
274 }
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);
278
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);
284 }
285 }
286 #undef FUNC_NAME
287
288
289 SCM
scm_hash_fn_ref(SCM table,SCM obj,SCM dflt,scm_t_hash_fn hash_fn,scm_t_assoc_fn assoc_fn,void * closure)290 scm_hash_fn_ref (SCM table, SCM obj, SCM dflt,
291 scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
292 void *closure)
293 {
294 SCM it = scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure);
295 if (scm_is_pair (it))
296 return SCM_CDR (it);
297 else
298 return dflt;
299 }
300
301 SCM
scm_hash_fn_set_x(SCM table,SCM obj,SCM val,scm_t_hash_fn hash_fn,scm_t_assoc_fn assoc_fn,void * closure)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,
304 void *closure)
305 {
306 SCM pair;
307
308 pair = scm_hash_fn_create_handle_x (table, obj, val,
309 hash_fn, assoc_fn, closure);
310
311 if (!scm_is_eq (SCM_CDR (pair), val))
312 SCM_SETCDR (pair, val);
313
314 return val;
315 }
316
317
318 SCM
scm_hash_fn_remove_x(SCM table,SCM obj,scm_t_hash_fn hash_fn,scm_t_assoc_fn assoc_fn,void * closure)319 scm_hash_fn_remove_x (SCM table, SCM obj,
320 scm_t_hash_fn hash_fn,
321 scm_t_assoc_fn assoc_fn,
322 void *closure)
323 #define FUNC_NAME "hash_fn_remove_x"
324 {
325 unsigned long k;
326 SCM buckets, h;
327
328 SCM_VALIDATE_HASHTABLE (SCM_ARG1, table);
329
330 buckets = SCM_HASHTABLE_VECTOR (table);
331
332 if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0)
333 return SCM_EOL;
334
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));
338
339 h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
340
341 if (scm_is_true (h))
342 {
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);
348 }
349 return h;
350 }
351 #undef FUNC_NAME
352
353 SCM_DEFINE (scm_hash_clear_x, "hash-clear!", 1, 0, 0,
354 (SCM table),
355 "Remove all items from @var{table} (without triggering a resize).")
356 #define FUNC_NAME s_scm_hash_clear_x
357 {
358 if (SCM_WEAK_TABLE_P (table))
359 {
360 scm_weak_table_clear_x (table);
361 return SCM_UNSPECIFIED;
362 }
363
364 SCM_VALIDATE_HASHTABLE (SCM_ARG1, table);
365
366 scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table), SCM_EOL);
367 SCM_SET_HASHTABLE_N_ITEMS (table, 0);
368
369 return SCM_UNSPECIFIED;
370 }
371 #undef FUNC_NAME
372
373
374
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
382 {
383 return scm_hash_fn_get_handle (table, key,
384 (scm_t_hash_fn) scm_ihashq,
385 (scm_t_assoc_fn) scm_sloppy_assq,
386 0);
387 }
388 #undef FUNC_NAME
389
390
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
397 {
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,
401 0);
402 }
403 #undef FUNC_NAME
404
405
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
413 {
414 if (SCM_UNBNDP (dflt))
415 dflt = SCM_BOOL_F;
416
417 if (SCM_WEAK_TABLE_P (table))
418 return scm_weak_table_refq (table, key, dflt);
419
420 return scm_hash_fn_ref (table, key, dflt,
421 (scm_t_hash_fn) scm_ihashq,
422 (scm_t_assoc_fn) scm_sloppy_assq,
423 0);
424 }
425 #undef FUNC_NAME
426
427
428
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
434 {
435 if (SCM_WEAK_TABLE_P (table))
436 {
437 scm_weak_table_putq_x (table, key, val);
438 return val;
439 }
440
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,
444 0);
445 }
446 #undef FUNC_NAME
447
448
449
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
455 {
456 if (SCM_WEAK_TABLE_P (table))
457 {
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. */
463 return SCM_BOOL_F;
464 }
465
466 return scm_hash_fn_remove_x (table, key,
467 (scm_t_hash_fn) scm_ihashq,
468 (scm_t_assoc_fn) scm_sloppy_assq,
469 0);
470 }
471 #undef FUNC_NAME
472
473
474
475
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
483 {
484 return scm_hash_fn_get_handle (table, key,
485 (scm_t_hash_fn) scm_ihashv,
486 (scm_t_assoc_fn) scm_sloppy_assv,
487 0);
488 }
489 #undef FUNC_NAME
490
491
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
498 {
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,
502 0);
503 }
504 #undef FUNC_NAME
505
506
507 static int
assv_predicate(SCM k,SCM v,void * closure)508 assv_predicate (SCM k, SCM v, void *closure)
509 {
510 return scm_is_true (scm_eqv_p (k, SCM_PACK_POINTER (closure)));
511 }
512
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
520 {
521 if (SCM_UNBNDP (dflt))
522 dflt = SCM_BOOL_F;
523
524 if (SCM_WEAK_TABLE_P (table))
525 return scm_c_weak_table_ref (table, scm_ihashv (key, -1),
526 assv_predicate,
527 (void *) SCM_UNPACK (key), dflt);
528
529 return scm_hash_fn_ref (table, key, dflt,
530 (scm_t_hash_fn) scm_ihashv,
531 (scm_t_assoc_fn) scm_sloppy_assv,
532 0);
533 }
534 #undef FUNC_NAME
535
536
537
538 SCM_DEFINE (scm_hashv_set_x, "hashv-set!", 3, 0, 0,
539 (SCM table, SCM key, SCM val),
540 "Find the entry in @var{table} associated with @var{key}, and\n"
541 "store @var{value} there. Uses @code{eqv?} for equality testing.")
542 #define FUNC_NAME s_scm_hashv_set_x
543 {
544 if (SCM_WEAK_TABLE_P (table))
545 {
546 scm_c_weak_table_put_x (table, scm_ihashv (key, -1),
547 assv_predicate, (void *) SCM_UNPACK (key),
548 key, val);
549 return val;
550 }
551
552 return scm_hash_fn_set_x (table, key, val,
553 (scm_t_hash_fn) scm_ihashv,
554 (scm_t_assoc_fn) scm_sloppy_assv,
555 0);
556 }
557 #undef FUNC_NAME
558
559
560 SCM_DEFINE (scm_hashv_remove_x, "hashv-remove!", 2, 0, 0,
561 (SCM table, SCM key),
562 "Remove @var{key} (and any value associated with it) from\n"
563 "@var{table}. Uses @code{eqv?} for equality tests.")
564 #define FUNC_NAME s_scm_hashv_remove_x
565 {
566 if (SCM_WEAK_TABLE_P (table))
567 {
568 scm_c_weak_table_remove_x (table, scm_ihashv (key, -1),
569 assv_predicate, (void *) SCM_UNPACK (key));
570 /* See note in hashq-remove!. */
571 return SCM_BOOL_F;
572 }
573
574 return scm_hash_fn_remove_x (table, key,
575 (scm_t_hash_fn) scm_ihashv,
576 (scm_t_assoc_fn) scm_sloppy_assv,
577 0);
578 }
579 #undef FUNC_NAME
580
581
582
583 SCM_DEFINE (scm_hash_get_handle, "hash-get-handle", 2, 0, 0,
584 (SCM table, SCM key),
585 "This procedure returns the @code{(key . value)} pair from the\n"
586 "hash table @var{table}. If @var{table} does not hold an\n"
587 "associated value for @var{key}, @code{#f} is returned.\n"
588 "Uses @code{equal?} for equality testing.")
589 #define FUNC_NAME s_scm_hash_get_handle
590 {
591 return scm_hash_fn_get_handle (table, key,
592 (scm_t_hash_fn) scm_ihash,
593 (scm_t_assoc_fn) scm_sloppy_assoc,
594 0);
595 }
596 #undef FUNC_NAME
597
598
599 SCM_DEFINE (scm_hash_create_handle_x, "hash-create-handle!", 3, 0, 0,
600 (SCM table, SCM key, SCM init),
601 "This function looks up @var{key} in @var{table} and returns its handle.\n"
602 "If @var{key} is not already present, a new handle is created which\n"
603 "associates @var{key} with @var{init}.")
604 #define FUNC_NAME s_scm_hash_create_handle_x
605 {
606 return scm_hash_fn_create_handle_x (table, key, init,
607 (scm_t_hash_fn) scm_ihash,
608 (scm_t_assoc_fn) scm_sloppy_assoc,
609 0);
610 }
611 #undef FUNC_NAME
612
613
614 static int
assoc_predicate(SCM k,SCM v,void * closure)615 assoc_predicate (SCM k, SCM v, void *closure)
616 {
617 return scm_is_true (scm_equal_p (k, SCM_PACK_POINTER (closure)));
618 }
619
620 SCM_DEFINE (scm_hash_ref, "hash-ref", 2, 1, 0,
621 (SCM table, SCM key, SCM dflt),
622 "Look up @var{key} in the hash table @var{table}, and return the\n"
623 "value (if any) associated with it. If @var{key} is not found,\n"
624 "return @var{dflt} (or @code{#f} if no @var{dflt} argument\n"
625 "is supplied). Uses @code{equal?} for equality testing.")
626 #define FUNC_NAME s_scm_hash_ref
627 {
628 if (SCM_UNBNDP (dflt))
629 dflt = SCM_BOOL_F;
630
631 if (SCM_WEAK_TABLE_P (table))
632 return scm_c_weak_table_ref (table, scm_ihash (key, -1),
633 assoc_predicate,
634 (void *) SCM_UNPACK (key), dflt);
635
636 return scm_hash_fn_ref (table, key, dflt,
637 (scm_t_hash_fn) scm_ihash,
638 (scm_t_assoc_fn) scm_sloppy_assoc,
639 0);
640 }
641 #undef FUNC_NAME
642
643
644
645 SCM_DEFINE (scm_hash_set_x, "hash-set!", 3, 0, 0,
646 (SCM table, SCM key, SCM val),
647 "Find the entry in @var{table} associated with @var{key}, and\n"
648 "store @var{val} there. Uses @code{equal?} for equality\n"
649 "testing.")
650 #define FUNC_NAME s_scm_hash_set_x
651 {
652 if (SCM_WEAK_TABLE_P (table))
653 {
654 scm_c_weak_table_put_x (table, scm_ihash (key, -1),
655 assoc_predicate, (void *) SCM_UNPACK (key),
656 key, val);
657 return val;
658 }
659
660 return scm_hash_fn_set_x (table, key, val,
661 (scm_t_hash_fn) scm_ihash,
662 (scm_t_assoc_fn) scm_sloppy_assoc,
663 0);
664 }
665 #undef FUNC_NAME
666
667
668
669 SCM_DEFINE (scm_hash_remove_x, "hash-remove!", 2, 0, 0,
670 (SCM table, SCM key),
671 "Remove @var{key} (and any value associated with it) from\n"
672 "@var{table}. Uses @code{equal?} for equality tests.")
673 #define FUNC_NAME s_scm_hash_remove_x
674 {
675 if (SCM_WEAK_TABLE_P (table))
676 {
677 scm_c_weak_table_remove_x (table, scm_ihash (key, -1),
678 assoc_predicate, (void *) SCM_UNPACK (key));
679 /* See note in hashq-remove!. */
680 return SCM_BOOL_F;
681 }
682
683 return scm_hash_fn_remove_x (table, key,
684 (scm_t_hash_fn) scm_ihash,
685 (scm_t_assoc_fn) scm_sloppy_assoc,
686 0);
687 }
688 #undef FUNC_NAME
689
690
691
692
693 typedef struct scm_t_ihashx_closure
694 {
695 SCM hash;
696 SCM assoc;
697 SCM key;
698 } scm_t_ihashx_closure;
699
700 static unsigned long
scm_ihashx(SCM obj,unsigned long n,void * arg)701 scm_ihashx (SCM obj, unsigned long n, void *arg)
702 {
703 SCM answer;
704 scm_t_ihashx_closure *closure = (scm_t_ihashx_closure *) arg;
705 answer = scm_call_2 (closure->hash, obj, scm_from_ulong (n));
706 return scm_to_ulong (answer);
707 }
708
709 static SCM
scm_sloppy_assx(SCM obj,SCM alist,void * arg)710 scm_sloppy_assx (SCM obj, SCM alist, void *arg)
711 {
712 scm_t_ihashx_closure *closure = (scm_t_ihashx_closure *) arg;
713 return scm_call_2 (closure->assoc, obj, alist);
714 }
715
716 static int
assx_predicate(SCM k,SCM v,void * closure)717 assx_predicate (SCM k, SCM v, void *closure)
718 {
719 scm_t_ihashx_closure *c = (scm_t_ihashx_closure *) closure;
720
721 /* FIXME: The hashx interface is crazy. Hash tables have nothing to
722 do with alists in principle. Instead of getting an assoc proc,
723 hashx functions should use an equality predicate. Perhaps we can
724 change this before 2.2, but until then, add a terrible, terrible
725 hack. */
726
727 return scm_is_true (scm_call_2 (c->assoc, c->key, scm_acons (k, v, SCM_EOL)));
728 }
729
730
731 SCM_DEFINE (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0,
732 (SCM hash, SCM assoc, SCM table, SCM key),
733 "This behaves the same way as the corresponding\n"
734 "@code{-get-handle} function, but uses @var{hash} as a hash\n"
735 "function and @var{assoc} to compare keys. @code{hash} must be\n"
736 "a function that takes two arguments, a key to be hashed and a\n"
737 "table size. @code{assoc} must be an associator function, like\n"
738 "@code{assoc}, @code{assq} or @code{assv}.")
739 #define FUNC_NAME s_scm_hashx_get_handle
740 {
741 scm_t_ihashx_closure closure;
742 closure.hash = hash;
743 closure.assoc = assoc;
744 closure.key = key;
745
746 return scm_hash_fn_get_handle (table, key, scm_ihashx, scm_sloppy_assx,
747 (void *) &closure);
748 }
749 #undef FUNC_NAME
750
751
752 SCM_DEFINE (scm_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0,
753 (SCM hash, SCM assoc, SCM table, SCM key, SCM init),
754 "This behaves the same way as the corresponding\n"
755 "@code{-create-handle} function, but uses @var{hash} as a hash\n"
756 "function and @var{assoc} to compare keys. @code{hash} must be\n"
757 "a function that takes two arguments, a key to be hashed and a\n"
758 "table size. @code{assoc} must be an associator function, like\n"
759 "@code{assoc}, @code{assq} or @code{assv}.")
760 #define FUNC_NAME s_scm_hashx_create_handle_x
761 {
762 scm_t_ihashx_closure closure;
763 closure.hash = hash;
764 closure.assoc = assoc;
765 closure.key = key;
766
767 return scm_hash_fn_create_handle_x (table, key, init, scm_ihashx,
768 scm_sloppy_assx, (void *)&closure);
769 }
770 #undef FUNC_NAME
771
772
773
774 SCM_DEFINE (scm_hashx_ref, "hashx-ref", 4, 1, 0,
775 (SCM hash, SCM assoc, SCM table, SCM key, SCM dflt),
776 "This behaves the same way as the corresponding @code{ref}\n"
777 "function, but uses @var{hash} as a hash function and\n"
778 "@var{assoc} to compare keys. @code{hash} must be a function\n"
779 "that takes two arguments, a key to be hashed and a table size.\n"
780 "@code{assoc} must be an associator function, like @code{assoc},\n"
781 "@code{assq} or @code{assv}.\n"
782 "\n"
783 "By way of illustration, @code{hashq-ref table key} is\n"
784 "equivalent to @code{hashx-ref hashq assq table key}.")
785 #define FUNC_NAME s_scm_hashx_ref
786 {
787 scm_t_ihashx_closure closure;
788 if (SCM_UNBNDP (dflt))
789 dflt = SCM_BOOL_F;
790 closure.hash = hash;
791 closure.assoc = assoc;
792 closure.key = key;
793
794 if (SCM_WEAK_TABLE_P (table))
795 {
796 unsigned long h = scm_to_ulong (scm_call_2 (hash, key,
797 scm_from_ulong (-1)));
798 return scm_c_weak_table_ref (table, h, assx_predicate, &closure, dflt);
799 }
800
801 return scm_hash_fn_ref (table, key, dflt, scm_ihashx, scm_sloppy_assx,
802 (void *)&closure);
803 }
804 #undef FUNC_NAME
805
806
807
808
809 SCM_DEFINE (scm_hashx_set_x, "hashx-set!", 5, 0, 0,
810 (SCM hash, SCM assoc, SCM table, SCM key, SCM val),
811 "This behaves the same way as the corresponding @code{set!}\n"
812 "function, but uses @var{hash} as a hash function and\n"
813 "@var{assoc} to compare keys. @code{hash} must be a function\n"
814 "that takes two arguments, a key to be hashed and a table size.\n"
815 "@code{assoc} must be an associator function, like @code{assoc},\n"
816 "@code{assq} or @code{assv}.\n"
817 "\n"
818 " By way of illustration, @code{hashq-set! table key} is\n"
819 "equivalent to @code{hashx-set! hashq assq table key}.")
820 #define FUNC_NAME s_scm_hashx_set_x
821 {
822 scm_t_ihashx_closure closure;
823 closure.hash = hash;
824 closure.assoc = assoc;
825 closure.key = key;
826
827 if (SCM_WEAK_TABLE_P (table))
828 {
829 unsigned long h = scm_to_ulong (scm_call_2 (hash, key,
830 scm_from_ulong (-1)));
831 scm_c_weak_table_put_x (table, h, assx_predicate, &closure, key, val);
832 return val;
833 }
834
835 return scm_hash_fn_set_x (table, key, val, scm_ihashx, scm_sloppy_assx,
836 (void *)&closure);
837 }
838 #undef FUNC_NAME
839
840 SCM_DEFINE (scm_hashx_remove_x, "hashx-remove!", 4, 0, 0,
841 (SCM hash, SCM assoc, SCM table, SCM obj),
842 "This behaves the same way as the corresponding @code{remove!}\n"
843 "function, but uses @var{hash} as a hash function and\n"
844 "@var{assoc} to compare keys. @code{hash} must be a function\n"
845 "that takes two arguments, a key to be hashed and a table size.\n"
846 "@code{assoc} must be an associator function, like @code{assoc},\n"
847 "@code{assq} or @code{assv}.\n"
848 "\n"
849 " By way of illustration, @code{hashq-remove! table key} is\n"
850 "equivalent to @code{hashx-remove! hashq assq #f table key}.")
851 #define FUNC_NAME s_scm_hashx_remove_x
852 {
853 scm_t_ihashx_closure closure;
854 closure.hash = hash;
855 closure.assoc = assoc;
856 closure.key = obj;
857
858 if (SCM_WEAK_TABLE_P (table))
859 {
860 unsigned long h = scm_to_ulong (scm_call_2 (hash, obj,
861 scm_from_ulong (-1)));
862 scm_c_weak_table_remove_x (table, h, assx_predicate, &closure);
863 /* See note in hashq-remove!. */
864 return SCM_BOOL_F;
865 }
866
867 return scm_hash_fn_remove_x (table, obj, scm_ihashx, scm_sloppy_assx,
868 (void *) &closure);
869 }
870 #undef FUNC_NAME
871
872 /* Hash table iterators */
873
874 SCM_DEFINE (scm_hash_fold, "hash-fold", 3, 0, 0,
875 (SCM proc, SCM init, SCM table),
876 "An iterator over hash-table elements.\n"
877 "Accumulates and returns a result by applying PROC successively.\n"
878 "The arguments to PROC are \"(key value prior-result)\" where key\n"
879 "and value are successive pairs from the hash table TABLE, and\n"
880 "prior-result is either INIT (for the first application of PROC)\n"
881 "or the return value of the previous application of PROC.\n"
882 "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
883 "table into an a-list of key-value pairs.")
884 #define FUNC_NAME s_scm_hash_fold
885 {
886 SCM_VALIDATE_PROC (1, proc);
887
888 if (SCM_WEAK_TABLE_P (table))
889 return scm_weak_table_fold (proc, init, table);
890
891 SCM_VALIDATE_HASHTABLE (3, table);
892 return scm_internal_hash_fold ((scm_t_hash_fold_fn) scm_call_3,
893 (void *) SCM_UNPACK (proc), init, table);
894 }
895 #undef FUNC_NAME
896
897 static SCM
for_each_proc(void * proc,SCM handle)898 for_each_proc (void *proc, SCM handle)
899 {
900 return scm_call_2 (SCM_PACK (proc), SCM_CAR (handle), SCM_CDR (handle));
901 }
902
903 SCM_DEFINE (scm_hash_for_each, "hash-for-each", 2, 0, 0,
904 (SCM proc, SCM table),
905 "An iterator over hash-table elements.\n"
906 "Applies PROC successively on all hash table items.\n"
907 "The arguments to PROC are \"(key value)\" where key\n"
908 "and value are successive pairs from the hash table TABLE.")
909 #define FUNC_NAME s_scm_hash_for_each
910 {
911 SCM_VALIDATE_PROC (1, proc);
912
913 if (SCM_WEAK_TABLE_P (table))
914 {
915 scm_weak_table_for_each (proc, table);
916 return SCM_UNSPECIFIED;
917 }
918
919 SCM_VALIDATE_HASHTABLE (2, table);
920
921 scm_internal_hash_for_each_handle (for_each_proc,
922 (void *) SCM_UNPACK (proc),
923 table);
924 return SCM_UNSPECIFIED;
925 }
926 #undef FUNC_NAME
927
928 SCM_DEFINE (scm_hash_for_each_handle, "hash-for-each-handle", 2, 0, 0,
929 (SCM proc, SCM table),
930 "An iterator over hash-table elements.\n"
931 "Applies PROC successively on all hash table handles.")
932 #define FUNC_NAME s_scm_hash_for_each_handle
933 {
934 SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, 1, FUNC_NAME);
935 SCM_VALIDATE_HASHTABLE (2, table);
936
937 scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn) scm_call_1,
938 (void *) SCM_UNPACK (proc),
939 table);
940 return SCM_UNSPECIFIED;
941 }
942 #undef FUNC_NAME
943
944 static SCM
map_proc(void * proc,SCM key,SCM data,SCM value)945 map_proc (void *proc, SCM key, SCM data, SCM value)
946 {
947 return scm_cons (scm_call_2 (SCM_PACK (proc), key, data), value);
948 }
949
950 SCM_DEFINE (scm_hash_map_to_list, "hash-map->list", 2, 0, 0,
951 (SCM proc, SCM table),
952 "An iterator over hash-table elements.\n"
953 "Accumulates and returns as a list the results of applying PROC successively.\n"
954 "The arguments to PROC are \"(key value)\" where key\n"
955 "and value are successive pairs from the hash table TABLE.")
956 #define FUNC_NAME s_scm_hash_map_to_list
957 {
958 SCM_VALIDATE_PROC (1, proc);
959
960 if (SCM_WEAK_TABLE_P (table))
961 return scm_weak_table_map_to_list (proc, table);
962
963 SCM_VALIDATE_HASHTABLE (2, table);
964 return scm_internal_hash_fold (map_proc,
965 (void *) SCM_UNPACK (proc),
966 SCM_EOL,
967 table);
968 }
969 #undef FUNC_NAME
970
971 static SCM
count_proc(void * pred,SCM key,SCM data,SCM value)972 count_proc (void *pred, SCM key, SCM data, SCM value)
973 {
974 if (scm_is_false (scm_call_2 (SCM_PACK (pred), key, data)))
975 return value;
976 else
977 return scm_oneplus(value);
978 }
979
980 SCM_DEFINE (scm_hash_count, "hash-count", 2, 0, 0,
981 (SCM pred, SCM table),
982 "Return the number of elements in the given hash TABLE that\n"
983 "cause `(PRED KEY VALUE)' to return true. To quickly determine\n"
984 "the total number of elements, use `(const #t)' for PRED.")
985 #define FUNC_NAME s_scm_hash_count
986 {
987 SCM init;
988
989 SCM_VALIDATE_PROC (1, pred);
990 SCM_VALIDATE_HASHTABLE (2, table);
991
992 init = scm_from_int (0);
993 return scm_internal_hash_fold ((scm_t_hash_fold_fn) count_proc,
994 (void *) SCM_UNPACK (pred), init, table);
995 }
996 #undef FUNC_NAME
997
998
999
1000 SCM
scm_internal_hash_fold(scm_t_hash_fold_fn fn,void * closure,SCM init,SCM table)1001 scm_internal_hash_fold (scm_t_hash_fold_fn fn, void *closure,
1002 SCM init, SCM table)
1003 #define FUNC_NAME s_scm_hash_fold
1004 {
1005 long i, n;
1006 SCM buckets, result = init;
1007
1008 if (SCM_WEAK_TABLE_P (table))
1009 return scm_c_weak_table_fold (fn, closure, init, table);
1010
1011 SCM_VALIDATE_HASHTABLE (0, table);
1012 buckets = SCM_HASHTABLE_VECTOR (table);
1013
1014 n = SCM_SIMPLE_VECTOR_LENGTH (buckets);
1015 for (i = 0; i < n; ++i)
1016 {
1017 SCM ls, handle;
1018
1019 for (ls = SCM_SIMPLE_VECTOR_REF (buckets, i); !scm_is_null (ls);
1020 ls = SCM_CDR (ls))
1021 {
1022 handle = SCM_CAR (ls);
1023 result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result);
1024 }
1025 }
1026
1027 return result;
1028 }
1029 #undef FUNC_NAME
1030
1031 /* The following redundant code is here in order to be able to support
1032 hash-for-each-handle. An alternative would have been to replace
1033 this code and scm_internal_hash_fold above with a single
1034 scm_internal_hash_fold_handles, but we don't want to promote such
1035 an API. */
1036
1037 void
scm_internal_hash_for_each_handle(scm_t_hash_handle_fn fn,void * closure,SCM table)1038 scm_internal_hash_for_each_handle (scm_t_hash_handle_fn fn, void *closure,
1039 SCM table)
1040 #define FUNC_NAME s_scm_hash_for_each
1041 {
1042 long i, n;
1043 SCM buckets;
1044
1045 SCM_VALIDATE_HASHTABLE (0, table);
1046 buckets = SCM_HASHTABLE_VECTOR (table);
1047 n = SCM_SIMPLE_VECTOR_LENGTH (buckets);
1048
1049 for (i = 0; i < n; ++i)
1050 {
1051 SCM ls = SCM_SIMPLE_VECTOR_REF (buckets, i), handle;
1052 while (!scm_is_null (ls))
1053 {
1054 if (!scm_is_pair (ls))
1055 SCM_WRONG_TYPE_ARG (SCM_ARG3, buckets);
1056 handle = SCM_CAR (ls);
1057 if (!scm_is_pair (handle))
1058 SCM_WRONG_TYPE_ARG (SCM_ARG3, buckets);
1059 fn (closure, handle);
1060 ls = SCM_CDR (ls);
1061 }
1062 }
1063 }
1064 #undef FUNC_NAME
1065
1066
1067
1068
1069 void
scm_init_hashtab()1070 scm_init_hashtab ()
1071 {
1072 #include "libguile/hashtab.x"
1073 }
1074
1075 /*
1076 Local Variables:
1077 c-file-style: "gnu"
1078 End:
1079 */
1080