/* [<][>][^][v][top][bottom][index][help] */
DEFINITIONS
This source file includes following definitions.
- round2up
- check_scm_hashtable
- Scm_EqHash
- Scm_EqvHash
- Scm_Hash
- Scm_HashString
- insert_entry
- delete_entry
- address_access
- address_hash
- eqv_hash
- eqv_cmp
- equal_hash
- equal_cmp
- string_access
- string_hash
- multiword_hash
- multiword_access
- general_access
- make_hash_table
- Scm_MakeHashTableSimple
- Scm_MakeHashTableMultiWord
- Scm_MakeHashTableFull
- Scm_MakeHashTable
- Scm_HashIterInitRaw
- Scm_HashIterInit
- Scm_HashIterNext
- Scm_HashTableGetRaw
- Scm_HashTableAddRaw
- Scm_HashTablePutRaw
- Scm_HashTableDeleteRaw
- Scm_HashTableGet
- Scm_HashTableAdd
- Scm_HashTablePut
- Scm_HashTableDelete
- Scm_HashTableKeys
- Scm_HashTableValues
- Scm_HashTableStat
- hash_print
1 /*
2 * hash.c - hash table implementation
3 *
4 * Copyright (c) 2000-2005 Shiro Kawai, All rights reserved.
5 *
6 * Redistribution and use in source and binary forms, with or without
7 * modification, are permitted provided that the following conditions
8 * are met:
9 *
10 * 1. Redistributions of source code must retain the above copyright
11 * notice, this list of conditions and the following disclaimer.
12 *
13 * 2. Redistributions in binary form must reproduce the above copyright
14 * notice, this list of conditions and the following disclaimer in the
15 * documentation and/or other materials provided with the distribution.
16 *
17 * 3. Neither the name of the authors nor the names of its contributors
18 * may be used to endorse or promote products derived from this
19 * software without specific prior written permission.
20 *
21 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32 *
33 * $Id: hash.c,v 1.41 2005/10/13 08:14:13 shirok Exp $
34 */
35
36 #define LIBGAUCHE_BODY
37 #include "gauche.h"
38 #include "gauche/class.h"
39
40 /*-------------------------------------------------------------
41 * Some macros & utilities
42 */
43
44 /* Usually, "shift+add" scheme for string hasing works well. But
45 * I found that it works well if you take the lower bits.
46 * Unfortunately, we need to take higher bits for multiplicative
47 * hashing of integers and addresses. So, in HASH2INDEX function,
48 * I take both lower bits and higher bits.
49 */
50
51 #define STRING_HASH(hv, chars, size) \
52 do { \
53 int i_ = (size); \
54 (hv) = 0; \
55 while (i_-- > 0) { \
56 (hv) = ((hv)<<5) - (hv) + ((unsigned char)*chars++); \
57 } \
58 } while (0)
59
60 /* Integer and address hash is a variation of "multiplicative hashing"
61 scheme described in Knuth, TAOCP, section 6.4. The final shifting
62 is done by HASH2INDEX macro */
63
64 #define SMALL_INT_HASH(result, val) \
65 ((result) = (val)*2654435761UL)
66
67 #define ADDRESS_HASH(result, val) \
68 ((result) = (SCM_WORD(val) >> 3) * 2654435761UL)
69
70 #define DEFAULT_NUM_BUCKETS 4
71 #define MAX_AVG_CHAIN_LIMITS 3
72 #define EXTEND_BITS 2
73
74 /* NB: we fix the word length to 32bits, since the multiplication
75 constant above is fixed. */
76 #define HASH2INDEX(tabsiz, bits, hashval) \
77 (((hashval)+((hashval)>>(32-(bits)))) & ((tabsiz) - 1))
78
79 /* Combining two hash values. We need better one. */
80 #define COMBINE(hv1, hv2) ((hv1)*5+(hv2))
81
82 static unsigned int round2up(unsigned int val)
83 {
84 unsigned int n = 1;
85 while (n < val) {
86 n <<= 1;
87 SCM_ASSERT(n > 1); /* check overflow */
88 }
89 return n;
90 }
91
92 /* In C-level, hash table can be used to contain arbitrary C data.
93 There are some pre-wired hashtables that can restrict the data
94 it holds to ScmObj. We call such type "ScmObj hashtables", while
95 the other ones "raw hashtables".
96
97 Naturally, raw hashtables are only accessible from C-world; even
98 if it leak out to the Scheme world, you can't access it.
99
100 For the convenience, hash-table accessor API comes in pairs; those
101 who has 'Raw' in the name can access any hashtables, while another
102 one checks whether the given hashtable is an ScmObj hashtable,
103 and rejects if not. */
104
105 /* internal utility to reject non-ScmObj hashtables. */
106 static void check_scm_hashtable(ScmHashTable *table)
107 {
108 if (SCM_HASH_TABLE_RAW_P(table)) {
109 Scm_Error("you can't access the raw hash table %S from Scheme",
110 table);
111 }
112 }
113
114 /*------------------------------------------------------------
115 * Hash functions
116 */
117
118 unsigned long Scm_EqHash(ScmObj obj)
119 {
120 unsigned long hashval;
121 ADDRESS_HASH(hashval, obj);
122 return hashval;
123 }
124
125 unsigned long Scm_EqvHash(ScmObj obj)
126 {
127 unsigned long hashval;
128 if (SCM_NUMBERP(obj)) {
129 if (SCM_INTP(obj)) {
130 SMALL_INT_HASH(hashval, SCM_INT_VALUE(obj));
131 } else if (SCM_BIGNUMP(obj)) {
132 int i;
133 unsigned long u = 0;
134 for (i=0; i<SCM_BIGNUM_SIZE(obj); i++) {
135 u += SCM_BIGNUM(obj)->values[i];
136 }
137 SMALL_INT_HASH(hashval, u);
138 } else if (SCM_FLONUMP(obj)) {
139 /* TODO: I'm not sure this is a good hash. */
140 hashval = (unsigned long)(SCM_FLONUM_VALUE(obj)*2654435761UL);
141 } else {
142 /* TODO: I'm not sure this is a good hash. */
143 hashval = (unsigned long)((SCM_COMPLEX_REAL(obj)+SCM_COMPLEX_IMAG(obj))*2654435761UL);
144 }
145 } else {
146 ADDRESS_HASH(hashval, obj);
147 }
148 return hashval;
149 }
150
151 /* General hash function */
152 unsigned long Scm_Hash(ScmObj obj)
153 {
154 unsigned long hashval;
155 if (!SCM_PTRP(obj)) {
156 SMALL_INT_HASH(hashval, (unsigned long)obj);
157 return hashval;
158 } else if (SCM_NUMBERP(obj)) {
159 return Scm_EqvHash(obj);
160 } else if (SCM_STRINGP(obj)) {
161 goto string_hash;
162 } else if (SCM_PAIRP(obj)) {
163 unsigned long h = 0, h2;
164 ScmObj cp;
165 SCM_FOR_EACH(cp, obj) {
166 h2 = Scm_Hash(SCM_CAR(cp));
167 h = COMBINE(h, h2);
168 }
169 h2 = Scm_Hash(cp);
170 h = COMBINE(h, h2);
171 return h;
172 } else if (SCM_VECTORP(obj)) {
173 int i;
174 unsigned long h = 0, h2;
175 ScmObj elt;
176 SCM_VECTOR_FOR_EACH(i, elt, obj) {
177 h2 = Scm_Hash(elt);
178 h = COMBINE(h, h2);
179 }
180 return h;
181 } else if (SCM_SYMBOLP(obj)) {
182 obj = SCM_OBJ(SCM_SYMBOL_NAME(obj));
183 goto string_hash;
184 } else if (SCM_KEYWORDP(obj)) {
185 obj = SCM_OBJ(SCM_KEYWORD_NAME(obj));
186 goto string_hash;
187 } else {
188 /* Call specialized object-hash method */
189 ScmObj r = Scm_Apply(SCM_OBJ(&Scm_GenericObjectHash),
190 SCM_LIST1(obj));
191 if (SCM_INTP(r)) {
192 return (unsigned long)SCM_INT_VALUE(r);
193 }
194 if (SCM_BIGNUMP(r)) {
195 /* NB: Scm_GetUInteger clamps the result to [0, ULONG_MAX],
196 but taking the LSW would give better distribution. */
197 return SCM_BIGNUM(r)->values[0];
198 }
199 Scm_Error("object-hash returned non-integer: %S", r);
200 return 0; /* dummy */
201 }
202 string_hash:
203 {
204 const char *p;
205 const ScmStringBody *b = SCM_STRING_BODY(obj);
206 p = SCM_STRING_BODY_START(b);
207 STRING_HASH(hashval, p, SCM_STRING_BODY_SIZE(b));
208 return hashval;
209 }
210 }
211
212 unsigned long Scm_HashString(ScmString *str, unsigned long modulo)
213 {
214 unsigned long hashval;
215 const char *p;
216 const ScmStringBody *b = SCM_STRING_BODY(str);
217 p = SCM_STRING_BODY_START(b);
218 STRING_HASH(hashval, p, SCM_STRING_BODY_SIZE(b));
219 return (hashval % modulo);
220 }
221
222 /*------------------------------------------------------------
223 * Parameterization
224 *
225 * Conceptually hash tables are parameterized by hash function and
226 * compare function. However, if they are trivial functions, calling
227 * them via function pointers incur overhead. So we layered the
228 * parameterization.
229 *
230 * For the pre-defined simple hash tables, the calls to the hash and
231 * compare functions are inlined in a single "access" function.
232 * (In this case hashfn is only used for rehashing, and cmpfn is
233 * never used).
234 * For the generic hash tables, the general_access function uses
235 * the info in hashfn and cmpfn fields.
236 *
237 * The accessor function takes four arguments.
238 *
239 * ScmHashTable *table : hash table
240 * void *key : key
241 * void *value : value, if the request involves modification.
242 * int mode : mode of operation; one of those three:
243 * HASH_FIND - just try to find the entry
244 * with key. If no entry is found,
245 * returns NULL.
246 * HASH_ADD - if the entry is found, return
247 * it without modification.
248 * otherwise, add an entry with
249 * the given value.
250 * HASH_UPDATE - if the entry is found, update
251 * the entry. Otherwise, add a
252 * new entry with the given value.
253 * HASH_DELETE - delete the found entry.
254 */
255
256 /* NOTE: eq?, eqv?, and string=? hash tables are guaranteed not to
257 * throw an error during hash table access (except the case that string=?
258 * hash table gets non-string key). So the caller doesn't need to
259 * set unwind handler in case it needs cleanup (like unlocking mutex).
260 * However, equal? hash may call back to Scheme method, so it can
261 * throw Scheme error. Be aware of that.
262 */
263
264 enum {
265 HASH_FIND, /* returns NULL if not found */
266 HASH_ADD, /* add entry iff the key is not in the table */
267 HASH_UPDATE, /* modify entry if key exists; add otherwise */
268 HASH_DELETE /* remove matched entry */
269 };
270
271 /*
272 * Common function called when the accessor function needs to add an entry.
273 */
274 static ScmHashEntry *insert_entry(ScmHashTable *table,
275 ScmObj key,
276 ScmObj value,
277 int index)
278 {
279 ScmHashEntry *e = SCM_NEW(ScmHashEntry);
280 e->key = key;
281 e->value = value;
282 e->next = table->buckets[index];
283 table->buckets[index] = e;
284 table->numEntries++;
285
286 if (table->numEntries > table->numBuckets*MAX_AVG_CHAIN_LIMITS) {
287 /* Extend the table */
288 ScmHashEntry **newb, *f;
289 ScmHashIter iter;
290 int i, newsize = (table->numBuckets << EXTEND_BITS);
291 int newbits = table->numBucketsLog2 + EXTEND_BITS;
292
293 newb = SCM_NEW_ARRAY(ScmHashEntry*, newsize);
294 for (i=0; i<newsize; i++) newb[i] = NULL;
295
296 Scm_HashIterInitRaw(table, &iter);
297 while ((f = Scm_HashIterNext(&iter)) != NULL) {
298 unsigned long hashval = table->hashfn(table, f->key);
299 index = HASH2INDEX(newsize, newbits, hashval);
300 f->next = newb[index];
301 newb[index] = f;
302 }
303 table->numBuckets = newsize;
304 table->numBucketsLog2 = newbits;
305 table->buckets = newb;
306 }
307 return e;
308 }
309
310 static ScmHashEntry *delete_entry(ScmHashTable *table,
311 ScmHashEntry *entry, ScmHashEntry *prev,
312 int index)
313 {
314 if (prev) prev->next = entry->next;
315 else table->buckets[index] = entry->next;
316 table->numEntries--;
317 SCM_ASSERT(table->numEntries >= 0);
318 return entry;
319 }
320
321 /*
322 * Accessor function for address. Used for EQ-type hash.
323 */
324 static ScmHashEntry *address_access(ScmHashTable *table,
325 void *key, int mode, void *value)
326 {
327 unsigned long hashval, index;
328 ScmHashEntry *e, *p;
329
330 ADDRESS_HASH(hashval, key);
331 index = HASH2INDEX(table->numBuckets, table->numBucketsLog2, hashval);
332
333 for (e = table->buckets[index], p = NULL; e; p = e, e = e->next) {
334 if (e->key == key) {
335 if (mode == HASH_FIND || mode == HASH_ADD) return e;
336 if (mode == HASH_DELETE) return delete_entry(table, e, p, index);
337 else {
338 e->value = value;
339 return e;
340 }
341 }
342 }
343
344 if (mode == HASH_FIND || mode == HASH_DELETE) return NULL;
345 else return insert_entry(table, key, value, index);
346 }
347
348 static unsigned long address_hash(ScmHashTable *ht, void *obj)
349 {
350 unsigned long hashval;
351 ADDRESS_HASH(hashval, obj);
352 return hashval;
353 }
354
355 /*
356 * Accessor function for equal and eqv-hash
357 */
358 static unsigned long eqv_hash(ScmHashTable *table, void *key)
359 {
360 return Scm_EqvHash(SCM_OBJ(key));
361 }
362
363 static int eqv_cmp(ScmHashTable *table, void *key, ScmHashEntry *e)
364 {
365 return Scm_EqvP(SCM_OBJ(key), e->key);
366 }
367
368 static unsigned long equal_hash(ScmHashTable *table, void *key)
369 {
370 return Scm_Hash(SCM_OBJ(key));
371 }
372
373 static int equal_cmp(ScmHashTable *table, void *key, ScmHashEntry *e)
374 {
375 return Scm_EqualP(SCM_OBJ(key), SCM_OBJ(e->key));
376 }
377
378
379 /*
380 * Accessor function for string type.
381 */
382 static ScmHashEntry *string_access(ScmHashTable *table, void *k,
383 int mode, void *v)
384 {
385 unsigned long hashval, index;
386 int size;
387 const char *s;
388 ScmObj key = SCM_OBJ(k), value = SCM_OBJ(v);
389 ScmHashEntry *e, *p;
390 const ScmStringBody *keyb;
391
392 if (!SCM_STRINGP(key)) {
393 Scm_Error("Got non-string key %S to the string hashtable %S",
394 key, table);
395 }
396 keyb = SCM_STRING_BODY(key);
397 s = SCM_STRING_BODY_START(keyb);
398 size = SCM_STRING_BODY_SIZE(keyb);
399 STRING_HASH(hashval, s, size);
400 index = HASH2INDEX(table->numBuckets, table->numBucketsLog2, hashval);
401
402 for (e = table->buckets[index], p = NULL; e; p = e, e = e->next) {
403 ScmObj ee = SCM_OBJ(e->key);
404 const ScmStringBody *eeb = SCM_STRING_BODY(ee);
405 int eesize = SCM_STRING_BODY_SIZE(eeb);
406 if (size == eesize
407 && memcmp(SCM_STRING_BODY_START(keyb),
408 SCM_STRING_BODY_START(eeb), eesize) == 0){
409 if (mode == HASH_FIND || mode == HASH_ADD) return e;
410 if (mode == HASH_DELETE) return delete_entry(table, e, p, index);
411 else {
412 e->value = value;
413 return e;
414 }
415 }
416 }
417
418 if (mode == HASH_FIND || mode == HASH_DELETE) return NULL;
419 else return insert_entry(table, key, value, index);
420 }
421
422 static unsigned long string_hash(ScmHashTable *table, void *key)
423 {
424 unsigned long hashval;
425 const char *p;
426 const ScmStringBody *b = SCM_STRING_BODY(key);
427 p = SCM_STRING_BODY_START(b);
428 STRING_HASH(hashval, p, SCM_STRING_BODY_SIZE(b));
429 return hashval;
430 }
431
432 /*
433 * Accessor function for multiword raw hashtable.
434 * Key points to an array of N words.
435 */
436 static unsigned long multiword_hash(ScmHashTable *table, void *key)
437 {
438 ScmWord keysize = (ScmWord)table->data;
439 ScmWord *keyarray = (ScmWord*)key;
440 unsigned long h = 0, h1;
441 int i;
442 for (i=0; i<keysize; i++) {
443 ADDRESS_HASH(h1, keyarray[i]);
444 h = COMBINE(h, h1);
445 }
446 return h;
447 }
448
449 static ScmHashEntry *multiword_access(ScmHashTable *table, void *k,
450 int mode, void *v)
451 {
452 unsigned long hashval, index;
453 ScmWord keysize = (ScmWord)table->data;
454 ScmHashEntry *e, *p;
455
456 hashval = multiword_hash(table, k);
457 index = HASH2INDEX(table->numBuckets, table->numBucketsLog2, hashval);
458
459 for (e = table->buckets[index], p = NULL; e; p = e, e = e->next) {
460 if (memcmp(k, e->key, keysize*sizeof(ScmWord)) == 0) {
461 if (mode == HASH_FIND || mode == HASH_ADD) return e;
462 if (mode == HASH_DELETE) return delete_entry(table, e, p, index);
463 else {
464 e->value = v;
465 return e;
466 }
467 }
468 }
469
470 if (mode == HASH_FIND || mode == HASH_DELETE) return NULL;
471 else return insert_entry(table, k, v, index);
472 }
473
474
475 /*
476 * Accessor function for general case
477 * (hashfn and cmpfn are given by user)
478 */
479 static ScmHashEntry *general_access(ScmHashTable *table, void *key,
480 int mode, void *value)
481 {
482 unsigned long hashval, index;
483 ScmHashEntry *e, *p;
484
485 hashval = table->hashfn(table, key);
486 index = HASH2INDEX(table->numBuckets, table->numBucketsLog2, hashval);
487
488 for (e = table->buckets[index], p = NULL; e; p = e, e = e->next) {
489 if (table->cmpfn(table, key, e)) {
490 if (mode == HASH_FIND || mode == HASH_ADD) return e;
491 if (mode == HASH_DELETE) return delete_entry(table, e, p, index);
492 else {
493 e->value = value;
494 return e;
495 }
496 }
497 }
498
499 if (mode == HASH_FIND || mode == HASH_DELETE) return NULL;
500 else return insert_entry(table, key, value, index);
501 }
502
503 /*---------------------------------------------------------
504 * Constructor
505 */
506
507 static void hash_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx);
508
509 SCM_DEFINE_BUILTIN_CLASS(Scm_HashTableClass, hash_print, NULL, NULL, NULL,
510 SCM_CLASS_COLLECTION_CPL);
511
512 static ScmObj make_hash_table(ScmClass *klass,
513 int type,
514 ScmHashAccessProc accessfn,
515 ScmHashProc hashfn,
516 ScmHashCmpProc cmpfn,
517 unsigned int initSize,
518 void *data)
519 {
520 ScmHashTable *z;
521 ScmHashEntry **b;
522 int i;
523
524 if (initSize != 0) initSize = round2up(initSize);
525 else initSize = DEFAULT_NUM_BUCKETS;
526
527 b = SCM_NEW_ARRAY(ScmHashEntry*, initSize);
528 z = SCM_NEW(ScmHashTable);
529 SCM_SET_CLASS(z, klass);
530 z->buckets = b;
531 z->numBuckets = initSize;
532 z->numEntries = 0;
533 z->type = type;
534 z->accessfn = accessfn;
535 z->hashfn = hashfn;
536 z->cmpfn = cmpfn;
537 z->data = data;
538 for (i=initSize, z->numBucketsLog2=0; i > 1; i /= 2) {
539 z->numBucketsLog2++;
540 }
541 for (i=0; i<initSize; i++) z->buckets[i] = NULL;
542 return SCM_OBJ(z);
543 }
544
545 ScmObj Scm_MakeHashTableSimple(int type, int initSize)
546 {
547 switch (type) {
548 case SCM_HASH_EQ:
549 return make_hash_table(SCM_CLASS_HASH_TABLE, SCM_HASH_EQ,
550 address_access, address_hash,
551 NULL, initSize, NULL);
552 case SCM_HASH_EQV:
553 return make_hash_table(SCM_CLASS_HASH_TABLE, SCM_HASH_EQV,
554 general_access, eqv_hash,
555 eqv_cmp, initSize, NULL);
556 case SCM_HASH_EQUAL:
557 return make_hash_table(SCM_CLASS_HASH_TABLE, SCM_HASH_EQUAL,
558 general_access, equal_hash,
559 equal_cmp, initSize, NULL);
560 case SCM_HASH_STRING:
561 return make_hash_table(SCM_CLASS_HASH_TABLE, SCM_HASH_STRING,
562 string_access, string_hash,
563 NULL, initSize, NULL);
564 case SCM_HASH_WORD:
565 return make_hash_table(SCM_CLASS_HASH_TABLE, SCM_HASH_WORD,
566 address_access, address_hash,
567 NULL, initSize, NULL);
568 default:
569 Scm_Error("[internal error]: wrong TYPE argument passed to Scm_MakeHashTableSimple: %d", type);
570 return SCM_UNDEFINED; /* dummy */
571 }
572 }
573
574 ScmObj Scm_MakeHashTableMultiWord(int keysize, int initsize)
575 {
576 return make_hash_table(SCM_CLASS_HASH_TABLE, SCM_HASH_MULTIWORD,
577 multiword_access, multiword_hash,
578 NULL, initsize, (void*)SCM_WORD(keysize));
579 }
580
581 ScmObj Scm_MakeHashTableFull(ScmClass *klass, int type, ScmHashProc hashfn,
582 ScmHashCmpProc cmpfn, int initSize, void *data)
583 {
584 if (!SCM_EQ(klass, SCM_CLASS_HASH_TABLE)) {
585 if (!Scm_SubtypeP(klass, SCM_CLASS_HASH_TABLE)) {
586 Scm_Error("[internal error]: non-hash-table class is given to Scm_MakeHashTableFull: %S", klass);
587 }
588 }
589
590 switch (type) {
591 case SCM_HASH_GENERAL:;
592 case SCM_HASH_RAW:
593 return make_hash_table(klass, type, general_access, hashfn,
594 cmpfn, initSize, data);
595 default:
596 Scm_Error("[internal error]: wrong TYPE argument passed to Scm_MakeHashTableFull: %d", type);
597 return SCM_UNDEFINED; /* dummy */
598 }
599 }
600
601 /* Legacy constructor. DEPRECATED. Will go away soon. */
602 ScmObj Scm_MakeHashTable(ScmHashProc hashfn,
603 ScmHashCmpProc cmpfn,
604 unsigned int initSize)
605 {
606 if (hashfn == (ScmHashProc)SCM_HASH_EQ) {
607 return Scm_MakeHashTableSimple(SCM_HASH_EQ, initSize);
608 } else if (hashfn == (ScmHashProc)SCM_HASH_EQV) {
609 return Scm_MakeHashTableSimple(SCM_HASH_EQV, initSize);
610 } else if (hashfn == (ScmHashProc)SCM_HASH_EQUAL) {
611 return Scm_MakeHashTableSimple(SCM_HASH_EQUAL, initSize);
612 } else if (hashfn == (ScmHashProc)SCM_HASH_STRING) {
613 return Scm_MakeHashTableSimple(SCM_HASH_STRING, initSize);
614 } else {
615 return Scm_MakeHashTableFull(SCM_CLASS_HASH_TABLE, SCM_HASH_GENERAL,
616 hashfn, cmpfn, initSize, NULL);
617 }
618 }
619
620 /*
621 * iteration
622 */
623
624 void Scm_HashIterInitRaw(ScmHashTable *table, ScmHashIter *iter)
625 {
626 int i;
627 iter->table = table;
628 for (i=0; i<table->numBuckets; i++) {
629 if (table->buckets[i]) {
630 iter->currentBucket = i;
631 iter->currentEntry = table->buckets[i];
632 return;
633 }
634 }
635 iter->currentEntry = NULL;
636 }
637
638 void Scm_HashIterInit(ScmHashTable *table, ScmHashIter *iter)
639 {
640 check_scm_hashtable(table);
641 Scm_HashIterInitRaw(table, iter);
642 }
643
644 ScmHashEntry *Scm_HashIterNext(ScmHashIter *iter)
645 {
646 ScmHashEntry *e = iter->currentEntry;
647 if (e != NULL) {
648 if (e->next) iter->currentEntry = e->next;
649 else {
650 int i = iter->currentBucket + 1;
651 for (; i < iter->table->numBuckets; i++) {
652 if (iter->table->buckets[i]) {
653 iter->currentBucket = i;
654 iter->currentEntry = iter->table->buckets[i];
655 return e;
656 }
657 }
658 iter->currentEntry = NULL;
659 }
660 }
661 return e;
662 }
663
664 /*
665 * Search
666 */
667
668 ScmHashEntry *Scm_HashTableGetRaw(ScmHashTable *table, void *key)
669 {
670 return table->accessfn(table, key, HASH_FIND, SCM_FALSE);
671 }
672
673 ScmHashEntry *Scm_HashTableAddRaw(ScmHashTable *table, void *key, void *value)
674 {
675 return table->accessfn(table, key, HASH_ADD, value);
676 }
677
678 ScmHashEntry *Scm_HashTablePutRaw(ScmHashTable *table, void *key, void *value)
679 {
680 return table->accessfn(table, key, HASH_UPDATE, value);
681 }
682
683 ScmHashEntry *Scm_HashTableDeleteRaw(ScmHashTable *table, void *key)
684 {
685 return table->accessfn(table, key, HASH_DELETE, SCM_FALSE);
686 }
687
688 ScmHashEntry *Scm_HashTableGet(ScmHashTable *table, ScmObj key)
689 {
690 check_scm_hashtable(table);
691 return table->accessfn(table, key, HASH_FIND, SCM_FALSE);
692 }
693
694 ScmHashEntry *Scm_HashTableAdd(ScmHashTable *table, ScmObj key, ScmObj value)
695 {
696 check_scm_hashtable(table);
697 return table->accessfn(table, key, HASH_ADD, value);
698 }
699
700 ScmHashEntry *Scm_HashTablePut(ScmHashTable *table, ScmObj key, ScmObj value)
701 {
702 check_scm_hashtable(table);
703 return table->accessfn(table, key, HASH_UPDATE, value);
704 }
705
706 ScmHashEntry *Scm_HashTableDelete(ScmHashTable *table, ScmObj key)
707 {
708 check_scm_hashtable(table);
709 return table->accessfn(table, key, HASH_DELETE, SCM_FALSE);
710 }
711
712 /*
713 * Utilities
714 */
715
716 ScmObj Scm_HashTableKeys(ScmHashTable *table)
717 {
718 ScmHashIter iter;
719 ScmHashEntry *e;
720 ScmObj h = SCM_NIL, t = SCM_NIL;
721 check_scm_hashtable(table);
722 Scm_HashIterInit(table, &iter);
723 while ((e = Scm_HashIterNext(&iter)) != NULL) {
724 SCM_APPEND1(h, t, e->key);
725 }
726 return h;
727 }
728
729 ScmObj Scm_HashTableValues(ScmHashTable *table)
730 {
731 ScmHashIter iter;
732 ScmHashEntry *e;
733 ScmObj h = SCM_NIL, t = SCM_NIL;
734 check_scm_hashtable(table);
735 Scm_HashIterInit(table, &iter);
736 while ((e = Scm_HashIterNext(&iter)) != NULL) {
737 SCM_APPEND1(h, t, e->value);
738 }
739 return h;
740 }
741
742 ScmObj Scm_HashTableStat(ScmHashTable *table)
743 {
744 ScmObj h = SCM_NIL, t;
745 ScmVector *v = SCM_VECTOR(Scm_MakeVector(table->numBuckets, SCM_NIL));
746 ScmObj *vp;
747 int i;
748
749 SCM_APPEND1(h, t, SCM_MAKE_KEYWORD("num-entries"));
750 SCM_APPEND1(h, t, Scm_MakeInteger(table->numEntries));
751 SCM_APPEND1(h, t, SCM_MAKE_KEYWORD("num-buckets"));
752 SCM_APPEND1(h, t, Scm_MakeInteger(table->numBuckets));
753 SCM_APPEND1(h, t, SCM_MAKE_KEYWORD("num-buckets-log2"));
754 SCM_APPEND1(h, t, Scm_MakeInteger(table->numBucketsLog2));
755 for (vp = SCM_VECTOR_ELEMENTS(v), i = 0; i<table->numBuckets; i++, vp++) {
756 ScmHashEntry *e = table->buckets[i];
757 for (; e; e = e->next) {
758 *vp = Scm_Acons(e->key, e->value, *vp);
759 }
760 }
761 SCM_APPEND1(h, t, SCM_MAKE_KEYWORD("contents"));
762 SCM_APPEND1(h, t, SCM_OBJ(v));
763 return h;
764 }
765
766 /*
767 * Printer
768 */
769
770 static void hash_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
771 {
772 ScmHashTable *ht = (ScmHashTable*)obj;
773 char *str;
774
775 switch (ht->type) {
776 case SCM_HASH_EQ: str = "eq?"; break;
777 case SCM_HASH_EQV: str = "eqv?"; break;
778 case SCM_HASH_EQUAL: str = "equal?"; break;
779 case SCM_HASH_STRING: str = "string=?"; break;
780 case SCM_HASH_GENERAL: str = "general"; break;
781
782 case SCM_HASH_WORD: str = "raw word"; break;
783 case SCM_HASH_MULTIWORD: str = "raw multi-word"; break;
784 case SCM_HASH_RAW: str = "raw general"; break;
785
786 default: Scm_Panic("something wrong with a hash table");
787 }
788
789 #if 0
790 /* Use read-time constructor so that table can be read back
791 --- is it necessary? I'm not sure yet. */
792 Scm_Printf(port, "#,(<hash-table> %s", str);
793 if (ht->numEntries > 0) {
794 Scm_HashIterInit(ht, &iter);
795 while ((e = Scm_HashIterNext(&iter)) != NULL) {
796 Scm_Printf(port, " %S %S", e->key, e->value);
797 }
798 }
799 SCM_PUTZ(")", -1, port);
800 #else
801 Scm_Printf(port, "#<hash-table %s %p>", str, ht);
802 #endif
803 }
804