root/src/hash.c

/* [<][>][^][v][top][bottom][index][help] */

DEFINITIONS

This source file includes following definitions.
  1. round2up
  2. check_scm_hashtable
  3. Scm_EqHash
  4. Scm_EqvHash
  5. Scm_Hash
  6. Scm_HashString
  7. insert_entry
  8. delete_entry
  9. address_access
  10. address_hash
  11. eqv_hash
  12. eqv_cmp
  13. equal_hash
  14. equal_cmp
  15. string_access
  16. string_hash
  17. multiword_hash
  18. multiword_access
  19. general_access
  20. make_hash_table
  21. Scm_MakeHashTableSimple
  22. Scm_MakeHashTableMultiWord
  23. Scm_MakeHashTableFull
  24. Scm_MakeHashTable
  25. Scm_HashIterInitRaw
  26. Scm_HashIterInit
  27. Scm_HashIterNext
  28. Scm_HashTableGetRaw
  29. Scm_HashTableAddRaw
  30. Scm_HashTablePutRaw
  31. Scm_HashTableDeleteRaw
  32. Scm_HashTableGet
  33. Scm_HashTableAdd
  34. Scm_HashTablePut
  35. Scm_HashTableDelete
  36. Scm_HashTableKeys
  37. Scm_HashTableValues
  38. Scm_HashTableStat
  39. 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 

/* [<][>][^][v][top][bottom][index][help] */