Back to index

plt-scheme  4.2.1
hash.c
Go to the documentation of this file.
00001 /*
00002   MzScheme
00003   Copyright (c) 2004-2009 PLT Scheme Inc.
00004   Copyright (c) 1995-2001 Matthew Flatt
00005 
00006     This library is free software; you can redistribute it and/or
00007     modify it under the terms of the GNU Library General Public
00008     License as published by the Free Software Foundation; either
00009     version 2 of the License, or (at your option) any later version.
00010 
00011     This library is distributed in the hope that it will be useful,
00012     but WITHOUT ANY WARRANTY; without even the implied warranty of
00013     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
00014     Library General Public License for more details.
00015 
00016     You should have received a copy of the GNU Library General Public
00017     License along with this library; if not, write to the Free
00018     Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
00019     Boston, MA 02110-1301 USA.
00020 
00021   libscheme
00022   Copyright (c) 1994 Brent Benson
00023   All rights reserved.
00024 */
00025 
00026 #include "schpriv.h"
00027 #include "schmach.h"
00028 #include <string.h>
00029 #include <ctype.h>
00030 #include <math.h>
00031 #include "../gc2/gc2_obj.h"
00032 
00033 long scheme_hash_request_count;
00034 long scheme_hash_iteration_count;
00035 
00036 #ifdef MZ_PRECISE_GC
00037 static void register_traversers(void);
00038 #endif
00039 
00040 #ifdef MZ_PRECISE_GC
00041 static long keygen;
00042 XFORM_NONGCING static MZ_INLINE
00043 long PTR_TO_LONG(Scheme_Object *o)
00044 {
00045   long bits;
00046   short v;
00047 
00048   if (SCHEME_INTP(o))
00049     return (long)o;
00050 
00051   v = o->keyex;
00052 
00053   if (!(v & 0xFFFC)) {
00054     v |= (short)keygen;
00055 #ifdef OBJHEAD_HAS_HASH_BITS
00056     /* In 3m mode, we only have 14 bits of hash code in the
00057        Scheme_Object header. But the GC-level object header has some
00058        leftover bits (currently 9, 11, 41, or 43, depending on the
00059        platform), so use those, too. That only works for GCable
00060        objects, so we use 1 of our 14 bits to indicate whether the
00061        other bit are present. */
00062     if (GC_is_allocated(o)) {
00063       OBJHEAD_HASH_BITS(o) = (keygen >> 16);
00064       v |= 0x4000;
00065     } else
00066       v &= ~0x4000;
00067 #endif
00068     if (!v) v = 0x1AD0;
00069     o->keyex = v;
00070     keygen += 4;
00071   }
00072 
00073 #ifdef OBJHEAD_HAS_HASH_BITS
00074   if (v & 0x4000)
00075     bits = OBJHEAD_HASH_BITS(o);
00076   else
00077 #endif
00078     bits = o->type;
00079 
00080   /* Note: low two bits will be ignored */
00081   return (bits << 16) | (v & 0xFFFF);
00082 }
00083 #else
00084 # define PTR_TO_LONG(p) ((long)(p))
00085 #endif
00086 
00087 #define FILL_FACTOR 1.4
00088 
00089 #define MIN_HTABLE_SIZE 8
00090 
00091 typedef int (*Hash_Compare_Proc)(void*, void*);
00092 
00093 typedef unsigned long hash_v_t;
00094 
00095 #define MAX_HASH_DEPTH 128
00096 
00097 /*========================================================================*/
00098 /*                         hashing functions                              */
00099 /*========================================================================*/
00100 
00101 static void string_hash_indices(void *_key, long *_h, long *_h2)
00102 {
00103   const char *key = (char *)_key;
00104   long i, h, h2;
00105 
00106   h2 = h = i = 0;
00107   while (key[i]) {
00108     int c = key[i++];
00109     h += (h << 5) + h + c;
00110     h2 += c;
00111   }
00112 
00113   if (_h)
00114     *_h = h;
00115   if (_h2)
00116     *_h2 = h2;
00117 }
00118 
00119 static void id_hash_indices(void *_key, long *_h, long *_h2)
00120 {
00121   Scheme_Object *key = (Scheme_Object *)_key;
00122   long lkey;
00123 
00124   if (SCHEME_STXP(key))
00125     key = SCHEME_STX_VAL(key);
00126     
00127   lkey = PTR_TO_LONG((Scheme_Object *)key);
00128   if (_h)
00129     *_h = (lkey >> 2);
00130   if (_h2)
00131     *_h2 = (lkey >> 3);
00132 }
00133 
00134 static int not_stx_bound_eq(char *a, char *b)
00135 {
00136   return !scheme_stx_bound_eq((Scheme_Object *)a, (Scheme_Object *)b, 0);
00137 }
00138 
00139 /*========================================================================*/
00140 /*                         normal hash table                              */
00141 /*========================================================================*/
00142 
00143 static Scheme_Object GONE[1];
00144 
00145 Scheme_Hash_Table *scheme_make_hash_table(int type)
00146 {
00147   Scheme_Hash_Table *table;
00148 
00149   table = MALLOC_ONE_TAGGED(Scheme_Hash_Table);
00150 
00151   table->size = 0;
00152     
00153   table->iso.so.type = scheme_hash_table_type;
00154 
00155   if (type == SCHEME_hash_string) {
00156     table->make_hash_indices = string_hash_indices;
00157     table->compare = (Hash_Compare_Proc)strcmp;
00158   }
00159   if (type == SCHEME_hash_bound_id) {
00160     table->make_hash_indices = id_hash_indices;
00161     table->compare = (Hash_Compare_Proc)not_stx_bound_eq;
00162   }
00163 
00164   return table;
00165 }
00166 
00167 static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int set, Scheme_Object *val)
00168 {
00169   Scheme_Object *tkey, **keys;
00170   hash_v_t h, h2, useme = 0;
00171   unsigned long mask;
00172 
00173  rehash_key:
00174 
00175   mask = table->size - 1;
00176 
00177   if (table->make_hash_indices) {
00178     GC_CAN_IGNORE hash_v_t *_h2;
00179     if (table->compare) {
00180       h2 = 0;
00181       _h2 = NULL;
00182     } else
00183       _h2 = &h2;
00184     table->make_hash_indices((void *)key, (long *)&h, (long *)_h2);
00185     h = h & mask;
00186     if (_h2) {
00187       h2 = (h2 & mask) | 1;
00188     }
00189   } else {
00190     unsigned long lkey;
00191     lkey = (unsigned long)PTR_TO_LONG((Scheme_Object *)key);
00192     h = (lkey >> 2) & mask;
00193     h2 = ((lkey >> 3) & mask) | 1;
00194   }
00195 
00196   keys = table->keys;
00197   
00198   if (table->compare) {
00199     scheme_hash_request_count++;
00200     while ((tkey = keys[h])) {
00201       if (SAME_PTR(tkey, GONE)) {
00202        if (set > 1) {
00203          useme = h;
00204          set = 1;
00205        }
00206       } else if (!table->compare(tkey, (char *)key)) {
00207        if (set) {
00208          table->vals[h] = val;
00209          if (!val) {
00210            keys[h] = GONE;
00211            --table->count;
00212          }
00213          return val;
00214        } else
00215          return table->vals[h];
00216       }
00217       scheme_hash_iteration_count++;
00218       if (!h2) {
00219         table->make_hash_indices((void *)key, NULL, (long *)&h2);
00220         h2 = (h2 & (table->size - 1)) | 1;
00221       }
00222       h = (h + h2) & mask;
00223     }
00224   } else {
00225     scheme_hash_request_count++;
00226     while ((tkey = keys[h])) {
00227       if (SAME_PTR(tkey, key)) {
00228        if (set) {
00229          table->vals[h] = val;
00230          if (!val) {
00231            keys[h] = GONE;
00232            --table->count;
00233          }
00234          return val;
00235        } else
00236          return table->vals[h];
00237       } else if (SAME_PTR(tkey, GONE)) {
00238        if (set > 1) {
00239          useme = h;
00240          set = 1;
00241        }
00242       } 
00243       scheme_hash_iteration_count++;
00244       h = (h + h2) & mask;
00245     }
00246   }
00247 
00248   if (!set || !val)
00249     return NULL;
00250 
00251   if (set == 1)
00252     h = useme;
00253   else if (table->mcount * FILL_FACTOR >= table->size) {
00254     /* Rehash */
00255     int i, oldsize = table->size, size;
00256     Scheme_Object **oldkeys = table->keys;
00257     Scheme_Object **oldvals = table->vals;
00258 
00259     size = oldsize << 1;
00260     table->size = size;
00261     
00262     {
00263       Scheme_Object **ba;
00264       ba = MALLOC_N(Scheme_Object *, size);
00265       table->vals = ba;
00266       ba = MALLOC_N(Scheme_Object *, size);
00267       table->keys = ba;
00268     }
00269 
00270     table->count = 0;
00271     table->mcount = 0;
00272     for (i = 0; i < oldsize; i++) {
00273       if (oldkeys[i] && !SAME_PTR(oldkeys[i], GONE))
00274        do_hash(table, oldkeys[i], 2, oldvals[i]);
00275     }
00276 
00277     goto rehash_key;
00278   } else {
00279     table->mcount++;
00280   }
00281 
00282   table->count++;
00283   table->keys[h] = key;
00284   table->vals[h] = val;
00285 
00286   return val;
00287 }
00288 
00289 static Scheme_Object *do_hash_set(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object *val)
00290 {
00291   Scheme_Object *tkey, **keys;
00292   hash_v_t h, h2, useme = 0;
00293   unsigned long mask;
00294   unsigned long lkey;
00295   int set = 2;
00296 
00297   mask = table->size - 1;
00298 
00299   lkey = (unsigned long)PTR_TO_LONG((Scheme_Object *)key);
00300   h = (lkey >> 2) & mask;
00301   h2 = (lkey >> 3) & mask;
00302 
00303   h2 |= 1;
00304 
00305   keys = table->keys;
00306   
00307   scheme_hash_request_count++;
00308   while ((tkey = keys[h])) {
00309     if (SAME_PTR(tkey, key)) {
00310       table->vals[h] = val;
00311       if (!val) {
00312        keys[h] = GONE;
00313        --table->count;
00314       }
00315       return val;
00316     } else if (SAME_PTR(tkey, GONE)) {
00317       if (set > 1) {
00318        useme = h;
00319        set = 1;
00320       }
00321     } 
00322     scheme_hash_iteration_count++;
00323     h = (h + h2) & mask;
00324   }
00325 
00326   if (!val)
00327     return NULL;
00328 
00329   if (set == 1)
00330     h = useme;
00331   else if (table->mcount * FILL_FACTOR >= table->size) {
00332     /* Use slow path to grow table: */
00333     return do_hash(table, key, 2, val);
00334   } else {
00335     table->mcount++;
00336   }
00337 
00338   table->count++;
00339   table->keys[h] = key;
00340   table->vals[h] = val;
00341 
00342   return val;
00343 }
00344 
00345 XFORM_NONGCING static Scheme_Object *do_hash_get(Scheme_Hash_Table *table, Scheme_Object *key)
00346 {
00347   Scheme_Object *tkey, **keys;
00348   hash_v_t h, h2;
00349   unsigned long mask;
00350   unsigned long lkey;
00351 
00352   mask = table->size - 1;
00353 
00354   lkey = (unsigned long)PTR_TO_LONG((Scheme_Object *)key);
00355   h = (lkey >> 2) & mask;
00356   h2 = (lkey >> 3) & mask;
00357 
00358   h2 |= 1;
00359 
00360   keys = table->keys;
00361   
00362   scheme_hash_request_count++;
00363   while ((tkey = keys[h])) {
00364     if (SAME_PTR(tkey, key)) {
00365       return table->vals[h];
00366     } 
00367     scheme_hash_iteration_count++;
00368     h = (h + h2) & mask;
00369   }
00370 
00371   return NULL;
00372 }
00373 
00374 void scheme_hash_set(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object *val)
00375 {
00376   if (!table->vals) {
00377     Scheme_Object **ba;
00378     
00379     table->size = 8;
00380     
00381     ba = MALLOC_N(Scheme_Object *, table->size);
00382     table->vals = ba;
00383     ba = MALLOC_N(Scheme_Object *, table->size);
00384     table->keys = ba;
00385   }
00386 
00387   if (table->make_hash_indices)
00388     do_hash(table, key, 2, val);
00389   else
00390     do_hash_set(table, key, val);
00391 }
00392 
00393 Scheme_Object *scheme_hash_get(Scheme_Hash_Table *table, Scheme_Object *key)
00394 {
00395   if (!table->vals)
00396     return NULL;
00397   else if (table->make_hash_indices)
00398     return do_hash(table, key, 0, NULL);
00399   else
00400     return do_hash_get(table, key);
00401 }
00402 
00403 Scheme_Object *scheme_eq_hash_get(Scheme_Hash_Table *table, Scheme_Object *key)
00404 /* Specialized to allow XFORM_NONGCING */
00405 {
00406   if (!table->vals)
00407     return NULL;
00408   else
00409     return do_hash_get(table, key);
00410 }
00411 
00412 Scheme_Object *scheme_hash_get_atomic(Scheme_Hash_Table *table, Scheme_Object *key)
00413 /* Mostly useful for acessing equal-based hash table when you don't want
00414    thread switches (such as in stx object manipulations). Simply grabbing the
00415    table's lock would be enough to make access to the table single-threaded,
00416    but sometimes you don't want any thread switches at all. */
00417 {
00418   Scheme_Object *r;
00419   scheme_start_atomic();
00420   r = scheme_hash_get(table, key);
00421   scheme_end_atomic_no_swap();
00422   return r;
00423 }
00424 
00425 void scheme_hash_set_atomic(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object *val)
00426 /* See rationale with scheme_hash_get_atomic. */
00427 {
00428   scheme_start_atomic();
00429   scheme_hash_set(table, key, val);
00430   scheme_end_atomic_no_swap();
00431 }
00432 
00433 int scheme_hash_table_equal_rec(Scheme_Hash_Table *t1, Scheme_Hash_Table *t2, void *eql)
00434 {
00435   Scheme_Object **vals, **keys, *v;
00436   int i;
00437 
00438   if ((t1->count != t2->count)
00439       || (t1->make_hash_indices != t2->make_hash_indices)
00440       || (t1->compare != t2->compare))
00441     return 0;
00442     
00443   keys = t1->keys;
00444   vals = t1->vals;
00445   for (i = t1->size; i--; ) {
00446     if (vals[i]) {
00447       v = scheme_hash_get(t2, keys[i]);
00448       if (!v)
00449        return 0;
00450       if (!scheme_recur_equal(vals[i], v, eql))
00451        return 0;
00452     }
00453   }
00454 
00455   return 1;
00456 }
00457 
00458 int scheme_hash_table_equal(Scheme_Hash_Table *t1, Scheme_Hash_Table *t2)
00459 {
00460   return scheme_equal((Scheme_Object *)t1, (Scheme_Object *)t2);
00461 }
00462 
00463 Scheme_Hash_Table *scheme_clone_hash_table(Scheme_Hash_Table *ht)
00464 {
00465   Scheme_Hash_Table *table;
00466   Scheme_Object **ba;
00467 
00468   table = MALLOC_ONE_TAGGED(Scheme_Hash_Table);
00469   memcpy(table, ht, sizeof(Scheme_Hash_Table));
00470   MZ_OPT_HASH_KEY(&(table->iso)) = 0;
00471 
00472   if (table->size) {
00473     ba = MALLOC_N(Scheme_Object *, table->size);
00474     memcpy(ba, table->vals, sizeof(Scheme_Object *) * table->size);
00475     table->vals = ba;
00476     ba = MALLOC_N(Scheme_Object *, table->size);
00477     memcpy(ba, table->keys, sizeof(Scheme_Object *) * table->size);
00478     table->keys = ba;
00479   }
00480 
00481   if (table->mutex) {
00482     Scheme_Object *sema;
00483     sema = scheme_make_sema(1);
00484     table->mutex = sema;
00485   }
00486 
00487   return table;
00488 }
00489 
00490 void scheme_reset_hash_table(Scheme_Hash_Table *table, int *history)
00491 {
00492   if ((table->size <= 8)
00493       || (table->count * FILL_FACTOR > (table->size >> 1))) {
00494     /* Keep same size */
00495   } else {
00496     /* Shrink by one step */
00497     Scheme_Object **ba;
00498     table->size >>= 1;
00499     ba = MALLOC_N(Scheme_Object *, table->size);
00500     table->vals = ba;
00501     ba = MALLOC_N(Scheme_Object *, table->size);
00502     table->keys = ba;
00503   }
00504   memset(table->vals, 0, sizeof(Scheme_Object *) * table->size);
00505   memset(table->keys, 0, sizeof(Scheme_Object *) * table->size);
00506   table->count = 0;
00507   table->mcount = 0;
00508 }
00509 
00510 /*========================================================================*/
00511 /*                  old-style hash table, with buckets                    */
00512 /*========================================================================*/
00513 
00514 Scheme_Bucket_Table *
00515 scheme_make_bucket_table (int size, int type)
00516 {
00517   Scheme_Bucket_Table *table;
00518   size_t asize;
00519 
00520   table = MALLOC_ONE_TAGGED(Scheme_Bucket_Table);
00521 
00522   table->size = 4;
00523   while (table->size < size) {
00524     table->size <<= 1;
00525   }
00526 
00527   table->count = 0;
00528 
00529   table->so.type = scheme_bucket_table_type;
00530 
00531   asize = (size_t)table->size * sizeof(Scheme_Bucket *);
00532   {
00533     Scheme_Bucket **ba;
00534     ba = (Scheme_Bucket **)scheme_malloc(asize);
00535     table->buckets = ba;
00536   }
00537 
00538   table->weak = (type == SCHEME_hash_weak_ptr);
00539   
00540   return table;
00541 }
00542 
00543 Scheme_Bucket_Table *scheme_clone_bucket_table(Scheme_Bucket_Table *bt)
00544 {
00545   Scheme_Bucket_Table *table;
00546   size_t asize;
00547 
00548   table = MALLOC_ONE_TAGGED(Scheme_Bucket_Table);
00549   table->so.type = scheme_bucket_table_type;
00550   table->size = bt->size;
00551   table->count = bt->count;
00552   table->weak = bt->weak;
00553   table->with_home = 0;
00554   table->make_hash_indices = bt->make_hash_indices;
00555   table->compare = bt->compare;
00556   if (bt->mutex) {
00557     Scheme_Object *sema;
00558     sema = scheme_make_sema(1);
00559     table->mutex = sema;
00560   }
00561   {
00562     Scheme_Bucket **ba;
00563     asize = (size_t)table->size * sizeof(Scheme_Bucket *);
00564     ba = (Scheme_Bucket **)scheme_malloc(asize);
00565     table->buckets = ba;
00566     memcpy(ba, bt->buckets, asize);
00567   }
00568 
00569   return table;
00570 }
00571 
00572 static Scheme_Bucket *
00573 get_bucket (Scheme_Bucket_Table *table, const char *key, int add, Scheme_Bucket *b)
00574 {
00575   hash_v_t h, h2;
00576   Scheme_Bucket *bucket;
00577   Compare_Proc compare = table->compare;
00578   unsigned long mask;
00579 
00580  rehash_key:
00581 
00582   mask = table->size - 1;
00583 
00584   if (table->make_hash_indices) {
00585     table->make_hash_indices((void *)key, (long *)&h, (long *)&h2);
00586     h = h & mask;
00587     h2 = h2 & mask;
00588   } else {
00589     unsigned long lkey;
00590     lkey = (unsigned long)PTR_TO_LONG((Scheme_Object *)key);
00591     h = (lkey >> 2) & mask;
00592     h2 = (lkey >> 3) & mask;
00593   }
00594 
00595   h2 |= 0x1;
00596 
00597   if (table->weak) {
00598     int reuse_bucket = 0;
00599     scheme_hash_request_count++;
00600     while ((bucket = table->buckets[h])) {
00601       if (bucket->key) {
00602        void *hk = (void *)HT_EXTRACT_WEAK(bucket->key);
00603        if (!hk) {
00604           if (!reuse_bucket)
00605             reuse_bucket = h + 1;
00606        } else if (SAME_PTR(hk, key))
00607          return bucket;
00608        else if (compare && !compare((void *)hk, (void *)key))
00609          return bucket;
00610       } else if (add)
00611        break;
00612       scheme_hash_iteration_count++;
00613       h = (h + h2) & mask;
00614     }
00615 
00616     if (reuse_bucket && add) {
00617       /* Re-use a bucket slot whose key is collected: */
00618       /* DON'T increment counter overall... */
00619       h = reuse_bucket - 1;
00620       --table->count;
00621     }
00622   } else {
00623     scheme_hash_request_count++;
00624     while ((bucket = table->buckets[h])) {
00625       if (SAME_PTR(bucket->key, key))
00626        return bucket;
00627       else if (compare && !compare((void *)bucket->key, (void *)key))
00628        return bucket;
00629       scheme_hash_iteration_count++;
00630       h = (h + h2) & mask;
00631     }
00632   }
00633 
00634   if (!add)
00635     return NULL;
00636 
00637   if (table->count * FILL_FACTOR >= table->size) {
00638     /* Rehash */
00639     int i, oldsize = table->size;
00640     size_t asize;
00641     Scheme_Bucket **old = table->buckets;
00642 
00643     if (table->weak && (table->size > 4096)) {
00644       int actual = 0;
00645 
00646       /* Forced GC: so that the new table is as small as possible. */
00647       scheme_collect_garbage();
00648 
00649       /* Check actual count: */
00650       for (i = 0; i < oldsize; i++) {
00651        if (old[i] && old[i]->key && HT_EXTRACT_WEAK(old[i]->key)) {
00652          actual++;
00653        }
00654       }
00655 
00656       if (actual * FILL_FACTOR < table->count) {
00657        /* Decrement size so that the table won't actually grow. */
00658        table->size >>= 1;
00659       }
00660     }
00661 
00662     table->size <<= 1;
00663     
00664     asize = (size_t)table->size * sizeof(Scheme_Bucket *);
00665     {
00666       Scheme_Bucket **ba;
00667       ba = (Scheme_Bucket **)scheme_malloc(asize);
00668       table->buckets = ba;
00669     }
00670 
00671     table->count = 0;
00672     if (table->weak) {
00673       for (i = 0; i < oldsize; i++) {
00674        if (old[i] && old[i]->key && HT_EXTRACT_WEAK(old[i]->key))
00675          get_bucket(table, (char *)HT_EXTRACT_WEAK(old[i]->key), 1, old[i]);
00676       }
00677     } else {
00678       for (i = 0; i < oldsize; i++) {
00679        if (old[i] && old[i]->key)
00680          get_bucket(table, old[i]->key, 1, old[i]);
00681       }
00682     }
00683 
00684     goto rehash_key;
00685   }
00686 
00687   if (b) {
00688     bucket = b;
00689   } else {
00690     size_t bsize;
00691     Scheme_Type type;
00692 
00693     if (table->with_home) {
00694       bsize = sizeof(Scheme_Bucket_With_Home);
00695       type = scheme_variable_type;
00696     } else  {
00697       bsize = sizeof(Scheme_Bucket);
00698       type = scheme_bucket_type;
00699     }
00700 
00701     bucket = (Scheme_Bucket *)scheme_malloc_tagged(bsize);
00702 
00703     bucket->so.type = type;
00704 
00705     if (type == scheme_variable_type)
00706       ((Scheme_Bucket_With_Flags *)bucket)->flags = GLOB_HAS_HOME_PTR;
00707 
00708     if (table->weak) {
00709 #ifdef MZ_PRECISE_GC
00710       void *kb;
00711       kb = GC_malloc_weak_box((void *)key, (void **)bucket, (void **)&bucket->val - (void **)bucket);
00712       bucket->key = (char *)kb;
00713 #else
00714       char *kb;
00715       kb = (char *)MALLOC_ONE_WEAK(void *);
00716       bucket->key = kb;
00717       *(void **)bucket->key = (void *)key;
00718       scheme_weak_reference_indirect((void **)bucket->key, (void *)key);
00719       scheme_weak_reference_indirect((void **)&bucket->val, (void *)key);
00720 #endif
00721     } else
00722       bucket->key = (char *)key;
00723     bucket->val = NULL;
00724   }
00725 
00726   table->buckets[h] = bucket;
00727 
00728   table->count++;
00729 
00730   return bucket;
00731 }
00732 
00733 Scheme_Bucket *
00734 scheme_bucket_or_null_from_table (Scheme_Bucket_Table *table, const char *key, int add)
00735 {
00736   Scheme_Bucket *b;
00737 
00738   b = get_bucket(table, key, add, NULL);
00739 
00740   return b;
00741 }
00742 
00743 Scheme_Bucket *
00744 scheme_bucket_from_table (Scheme_Bucket_Table *table, const char *key)
00745 {
00746   return scheme_bucket_or_null_from_table(table, key, 1);
00747 }
00748 
00749 void 
00750 scheme_add_to_table (Scheme_Bucket_Table *table, const char *key, void *val, 
00751                    int constant)
00752 {
00753   Scheme_Bucket *b;
00754 
00755   b = get_bucket(table, key, 1, NULL);
00756 
00757   if (val)
00758     b->val = val;
00759   if (constant && table->with_home)
00760     ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_CONST;
00761 }
00762 
00763 void scheme_add_bucket_to_table(Scheme_Bucket_Table *table, Scheme_Bucket *b)
00764 {
00765   get_bucket(table, table->weak ? (char *)HT_EXTRACT_WEAK(b->key) : b->key, 1, b);
00766 }
00767 
00768 void *
00769 scheme_lookup_in_table (Scheme_Bucket_Table *table, const char *key)
00770 {
00771   Scheme_Bucket *bucket;
00772 
00773   bucket = get_bucket(table, key, 0, NULL);
00774 
00775   if (bucket)
00776     return bucket->val;
00777   else
00778     return NULL;
00779 }
00780 
00781 void
00782 scheme_change_in_table (Scheme_Bucket_Table *table, const char *key, void *naya)
00783 {
00784   Scheme_Bucket *bucket;
00785 
00786   bucket = get_bucket(table, key, 0, NULL);
00787 
00788   if (bucket)
00789     bucket->val = naya;
00790 }
00791 
00792 int scheme_bucket_table_equal_rec(Scheme_Bucket_Table *t1, Scheme_Bucket_Table *t2, void *eql)
00793 {
00794   Scheme_Bucket **buckets, *bucket;
00795   void *v;
00796   const char *key;
00797   int i, weak, checked = 0;
00798 
00799   /* We can't compare the count values, because they're merely
00800      >= the number of mapped keys */
00801 
00802   if ((t1->weak != t2->weak)
00803       || (t1->make_hash_indices != t2->make_hash_indices)
00804       || (t1->compare != t2->compare))
00805     return 0;
00806   
00807   buckets = t1->buckets;
00808   weak = t1->weak;
00809 
00810   for (i = t1->size; i--; ) {
00811     bucket = buckets[i];
00812     if (bucket) {
00813       if (weak) {
00814        key = (const char *)HT_EXTRACT_WEAK(bucket->key);
00815       } else {
00816        key = bucket->key;
00817       }
00818       if (key) {
00819        checked++;
00820        v = scheme_lookup_in_table(t2, key);
00821        if (!v)
00822          return 0;
00823        if (!scheme_recur_equal((Scheme_Object *)bucket->val, (Scheme_Object *)v, eql))
00824          return 0;
00825       }
00826     }
00827   }
00828 
00829   /* If count is checked, then all buckets must be for mapped keys. */
00830   if (t2->count == checked)
00831     return 1;
00832 
00833   /* Need to see whether "t2" maps exactly "checked" keys */
00834   buckets = t2->buckets;
00835   weak = t2->weak;
00836   for (i = t2->size; i--; ) {
00837     bucket = buckets[i];
00838     if (bucket) {
00839       if (weak) {
00840        key = (const char *)HT_EXTRACT_WEAK(bucket->key);
00841       } else {
00842        key = bucket->key;
00843       }
00844       if (key) {
00845        if (!checked)
00846          return 0;
00847        --checked;
00848       }
00849     }
00850   }
00851 
00852   return !checked;
00853 }
00854 
00855 int scheme_bucket_table_equal(Scheme_Bucket_Table *t1, Scheme_Bucket_Table *t2)
00856 {
00857   return scheme_equal((Scheme_Object *)t1, (Scheme_Object *)t2);
00858 }
00859 
00860 /*========================================================================*/
00861 /*                         precise GC hashing                             */
00862 /*========================================================================*/
00863 
00864 #ifdef MZ_PRECISE_GC
00865 
00866 START_XFORM_SKIP;
00867 
00868 void scheme_init_hash_key_procs(void)
00869 {
00870   register_traversers();
00871 }
00872 
00873 long scheme_hash_key(Scheme_Object *o)
00874 {
00875   return PTR_TO_LONG(o) >> 2;
00876 }
00877 
00878 END_XFORM_SKIP;
00879 
00880 #endif
00881 
00882 /*========================================================================*/
00883 /*                           equal? hashing                               */
00884 /*========================================================================*/
00885 
00886 typedef struct Hash_Info {
00887   long depth; /* always odd */
00888   Scheme_Object *recur;
00889 } Hash_Info;
00890 
00891 static long equal_hash_key(Scheme_Object *o, long k, Hash_Info *hi);
00892 static long equal_hash_key2(Scheme_Object *o, Hash_Info *hi);
00893 
00894 static Scheme_Object *hash_recur(int argc, Scheme_Object **argv, Scheme_Object *prim)
00895 {
00896   long v;
00897   Hash_Info *hi;
00898 
00899   hi = (Hash_Info *)SCHEME_PRIM_CLOSURE_ELS(prim)[0];
00900   hi->depth += 2;
00901 
00902   v = equal_hash_key(argv[0], 0, hi);
00903   
00904   return scheme_make_integer(v);
00905 }
00906 
00907 static Scheme_Object *hash_k(void)
00908 {
00909   Scheme_Thread *p = scheme_current_thread;
00910   Scheme_Object *v = (Scheme_Object *)p->ku.k.p1;
00911   Hash_Info *hi = (Hash_Info *)p->ku.k.p2;
00912   long nv;
00913 
00914   p->ku.k.p1 = NULL;
00915   p->ku.k.p2 = NULL;
00916   
00917   nv = equal_hash_key(v, p->ku.k.i1, hi);
00918 
00919   return scheme_make_integer_value(nv);
00920 }
00921 
00922 /* Number of lists/vectors/structs/boxes to hash before
00923    paying for a stack check. */
00924 #define HASH_COUNT_START 20
00925 
00926 static long overflow_equal_hash_key(Scheme_Object *o, long k, Hash_Info *hi)
00927 {
00928   Scheme_Object *nv;
00929   long val;
00930   Hash_Info *hi2;
00931   Scheme_Thread *p = scheme_current_thread;
00932 
00933   hi2 = (Hash_Info *)scheme_malloc(sizeof(Hash_Info));
00934   memcpy(hi2, hi, sizeof(Hash_Info));
00935 
00936   p->ku.k.p1 = (void *)o;
00937   p->ku.k.p2 = (void *)hi2;
00938   p->ku.k.i1 = k;
00939 
00940   nv = scheme_handle_stack_overflow(hash_k);
00941   scheme_get_int_val(nv, &val);
00942 
00943   memcpy(hi, hi2, sizeof(Hash_Info));
00944 
00945   return val;
00946 }
00947 
00948 #define OVERFLOW_HASH() overflow_equal_hash_key(o, k - t, hi)
00949 
00950 /* Based on Bob Jenkins's one-at-a-time hash function at
00951    http://www.burtleburtle.net/bob/hash/doobs.html: */
00952 #define MZ_MIX(k) (k += (k << 10), k ^= (k >> 6))
00953 
00954 static long equal_hash_key(Scheme_Object *o, long k, Hash_Info *hi)
00955 {
00956   Scheme_Type t;
00957   static int hash_counter = HASH_COUNT_START;
00958 
00959  top:
00960   t = SCHEME_TYPE(o);
00961   k += t;
00962 
00963   if (hi->depth > (MAX_HASH_DEPTH << 1))
00964     return k;
00965   
00966   switch(t) {
00967   case scheme_integer_type:
00968     return k + SCHEME_INT_VAL(o);
00969 #ifdef MZ_USE_SINGLE_FLOATS
00970   case scheme_float_type:
00971 #endif
00972   case scheme_double_type:
00973     {
00974       double d;
00975       int e;
00976       d = SCHEME_DBL_VAL(o);
00977       if (MZ_IS_NAN(d)) {
00978        d = 0.0;
00979        e = 1000;
00980       } else if (MZ_IS_POS_INFINITY(d)) {
00981        d = 0.5;
00982        e = 1000;
00983       } else if (MZ_IS_NEG_INFINITY(d)) {
00984        d = -0.5;
00985        e = 1000;
00986       } else if (!d && scheme_minus_zero_p(d)) {
00987        d = 0;
00988        e = 1000;
00989       } else {
00990        /* frexp should not be used on inf or nan: */
00991        d = frexp(d, &e);
00992       }
00993       return k + ((long)(d * (1 << 30))) + e;
00994     }
00995   case scheme_bignum_type:
00996     {
00997       int i = SCHEME_BIGLEN(o);
00998       bigdig *d = SCHEME_BIGDIG(o), k2;
00999       
01000       k2 = k;
01001       while (i--) {
01002        k2 = (k2 << 3) + k2 + d[i];
01003       }
01004     
01005       return (long)k2;
01006     }
01007     break;
01008   case scheme_rational_type:
01009     {
01010       k += equal_hash_key(scheme_rational_numerator(o), 0, hi);
01011       o = scheme_rational_denominator(o);
01012       break;
01013     }
01014   case scheme_complex_type:
01015     {
01016       Scheme_Complex *c = (Scheme_Complex *)o;
01017       k += equal_hash_key(c->r, 0, hi);
01018       o = c->i;
01019       break;
01020     }
01021   case scheme_pair_type:
01022     {
01023 #     include "mzhashchk.inc"
01024       hi->depth += 2;
01025       k = (k << 3) + k;
01026       k += equal_hash_key(SCHEME_CAR(o), 0, hi);
01027       /* If it's a list, don't count cdr direction as depth: */
01028       if (scheme_is_list(o))
01029         hi->depth -= 2;
01030       o = SCHEME_CDR(o);
01031       break;
01032     }
01033   case scheme_mutable_pair_type:
01034     {
01035 #     include "mzhashchk.inc"
01036       hi->depth += 2;
01037       k = (k << 3) + k;
01038       k += equal_hash_key(SCHEME_CAR(o), 0, hi);
01039       o = SCHEME_CDR(o);
01040       break;
01041     }
01042   case scheme_vector_type:
01043   case scheme_wrap_chunk_type:
01044     {
01045       int len = SCHEME_VEC_SIZE(o), i, val;
01046 #     include "mzhashchk.inc"
01047 
01048       if (!len)
01049        return k + 1;
01050       
01051       hi->depth += 2;
01052       --len;
01053       for (i = 0; i < len; i++) {
01054        SCHEME_USE_FUEL(1);
01055        val = equal_hash_key(SCHEME_VEC_ELS(o)[i], 0, hi);
01056        k = (k << 5) + k + val;
01057       }
01058       
01059       o = SCHEME_VEC_ELS(o)[len];
01060       break;
01061     }
01062   case scheme_char_type:
01063     return k + SCHEME_CHAR_VAL(o);
01064   case scheme_byte_string_type:
01065   case scheme_unix_path_type:
01066   case scheme_windows_path_type:
01067     {
01068       int i = SCHEME_BYTE_STRLEN_VAL(o);
01069       char *s = SCHEME_BYTE_STR_VAL(o);
01070       
01071       while (i--) {
01072        k += s[i];
01073         MZ_MIX(k);
01074       }
01075       
01076       return k;
01077     }
01078   case scheme_char_string_type:
01079     {
01080       int i = SCHEME_CHAR_STRLEN_VAL(o);
01081       mzchar *s = SCHEME_CHAR_STR_VAL(o);
01082       
01083       while (i--) {
01084        k += s[i];
01085         MZ_MIX(k);
01086       }
01087       
01088       return k;
01089     }
01090   case scheme_structure_type:
01091   case scheme_proc_struct_type:
01092     {
01093       Scheme_Object *procs;
01094 
01095       procs = scheme_struct_type_property_ref(scheme_equal_property, o);
01096       if (procs) {
01097         Scheme_Object *a[2], *recur, *v;
01098         Hash_Info *hi2;
01099 
01100 #       include "mzhashchk.inc"
01101 
01102         /* Create/cache closure to use for recursive hashing: */
01103         if (hi->recur) {
01104           recur = hi->recur;
01105           hi2 = (Hash_Info *)SCHEME_PRIM_CLOSURE_ELS(recur)[0];
01106         } else {
01107           hi2 = (Hash_Info *)scheme_malloc(sizeof(Hash_Info));
01108           a[0] = (Scheme_Object *)hi2;
01109           recur = scheme_make_prim_closure_w_arity(hash_recur,
01110                                                    1, a,
01111                                                    "equal-hash-code/recur",
01112                                                    1, 1);
01113           hi->recur = recur;
01114         }
01115         memcpy(hi2, hi, sizeof(Hash_Info));
01116 
01117         a[0] = o;
01118         a[1] = recur;
01119         
01120         procs = SCHEME_VEC_ELS(procs)[2];
01121         
01122         v = _scheme_apply(procs, 2, a);
01123 
01124         if (SCHEME_INTP(v))
01125           return k + SCHEME_INT_VAL(v);
01126         else if (SCHEME_BIGNUMP(v)) {
01127           return k + (long)((Scheme_Bignum *)v)->digits[0];
01128         } else {
01129           scheme_arg_mismatch("equal-hash-code",
01130                               "hash procedure returned a value other than an exact integer: ",
01131                               v);
01132           return 0;
01133         }
01134       } else {
01135         Scheme_Object *insp;
01136         insp = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
01137         if (scheme_inspector_sees_part(o, insp, -2)) {
01138           int i;
01139           Scheme_Structure *s1 = (Scheme_Structure *)o;
01140        
01141 #         include "mzhashchk.inc"
01142        
01143           hi->depth += 2;
01144 
01145           for (i = SCHEME_STRUCT_NUM_SLOTS(s1); i--; ) {
01146             k += equal_hash_key(s1->slots[i], 0, hi);
01147             MZ_MIX(k);
01148           }
01149        
01150           return k;
01151         } else
01152           return k + (PTR_TO_LONG(o) >> 4);
01153       }
01154     }
01155   case scheme_box_type:
01156     {
01157       SCHEME_USE_FUEL(1);
01158       k += 1;
01159       o = SCHEME_BOX_VAL(o);
01160       hi->depth += 2;
01161       break;
01162     }
01163   case scheme_hash_table_type:
01164     {
01165       Scheme_Hash_Table *ht = (Scheme_Hash_Table *)o;
01166       Scheme_Object **vals, **keys;
01167       int i;
01168       long vk;
01169 
01170 #     include "mzhashchk.inc"
01171 
01172       k = (k << 1) + 3;
01173       hi->depth += 2;
01174       
01175       keys = ht->keys;
01176       vals = ht->vals;
01177       for (i = ht->size; i--; ) {
01178        if (vals[i]) {
01179           vk = equal_hash_key(keys[i], 0, hi);
01180           MZ_MIX(vk);
01181          vk += equal_hash_key(vals[i], 0, hi);
01182           MZ_MIX(vk);
01183           k += vk;  /* can't mix k, because the key order shouldn't matter */
01184        }
01185       }
01186       
01187       return k;
01188     }
01189   case scheme_hash_tree_type:
01190     {
01191       Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)o;
01192       Scheme_Object *ik, *iv;
01193       int i;
01194       long vk;
01195 
01196 #     include "mzhashchk.inc"
01197 
01198       k = (k << 1) + 3;
01199       hi->depth += 2;
01200       
01201       for (i = ht->count; i--; ) {
01202         scheme_hash_tree_index(ht, i, &ik, &iv);
01203         vk = equal_hash_key(ik, 0, hi);
01204         MZ_MIX(vk);
01205         vk += equal_hash_key(iv, 0, hi);
01206         MZ_MIX(vk);
01207         k += vk;  /* can't mix k, because the key order shouldn't matter */
01208       }
01209       
01210       return k;
01211     }
01212   case scheme_bucket_table_type:
01213     {
01214       Scheme_Bucket_Table *ht = (Scheme_Bucket_Table *)o;
01215       Scheme_Bucket **buckets, *bucket;
01216       const char *key;
01217       int i, weak;
01218       long vk;
01219   
01220 #    include "mzhashchk.inc"
01221 
01222       buckets = ht->buckets;
01223       weak = ht->weak;
01224       hi->depth += 2;
01225       
01226       k = (k << 1) + 7;
01227       
01228       for (i = ht->size; i--; ) {
01229        bucket = buckets[i];
01230        if (bucket) {
01231          if (weak) {
01232            key = (const char *)HT_EXTRACT_WEAK(bucket->key);
01233          } else {
01234            key = bucket->key;
01235          }
01236          if (key) {
01237            vk = equal_hash_key((Scheme_Object *)bucket->val, 0, hi);
01238             MZ_MIX(vk);
01239            vk += equal_hash_key((Scheme_Object *)key, 0, hi);
01240             MZ_MIX(vk);
01241             k += vk; /* can't mix k, because the key order shouldn't matter */
01242          }
01243        }
01244       }
01245       
01246       return k;
01247     }
01248 # ifndef MZ_PRECISE_GC
01249   case scheme_keyword_type:
01250   case scheme_symbol_type:
01251     {
01252       Scheme_Symbol *s = (Scheme_Symbol *)o;
01253       if (!(MZ_OPT_HASH_KEY(&s->iso) & 0x1)) {
01254        /* Interned. Make key depend only on the content. */
01255        if (!(MZ_OPT_HASH_KEY(&s->iso) & 0xFFFC)) {
01256          int i, h = 0;
01257          for (i = s->len; i--; ) {
01258            h += (h << 5) + h + s->s[i];
01259          }
01260          h += (h << 2);
01261          if (!(((short)h) & 0xFFFC))
01262            h = 0x10;
01263          MZ_OPT_HASH_KEY(&s->iso) |= (((short)h) & 0xFFFC);
01264        }
01265        
01266        return k + (MZ_OPT_HASH_KEY(&s->iso) & 0xFFFC);
01267       } else
01268        return k + (PTR_TO_LONG(o) >> 4);
01269     }
01270 # endif
01271   case scheme_resolved_module_path_type:
01272     /* Needed for interning */
01273     {
01274       k += 7;
01275       o = SCHEME_PTR_VAL(o);
01276     }
01277     break;
01278   default:    
01279     {
01280       Scheme_Primary_Hash_Proc h1 = scheme_type_hash1s[t];
01281       if (h1)
01282         return h1(o, k, hi);
01283       else
01284         return k + (PTR_TO_LONG(o) >> 4);
01285     }
01286   }
01287 
01288   MZ_MIX(k);
01289   goto top;
01290 }
01291 
01292 long scheme_equal_hash_key(Scheme_Object *o)
01293 {
01294   Hash_Info hi;
01295 
01296   hi.depth = 1;
01297   hi.recur = NULL;
01298 
01299   return equal_hash_key(o, 0, &hi);
01300 }
01301 
01302 long scheme_equal_hash_key2(Scheme_Object *o)
01303 {
01304   Hash_Info hi;
01305 
01306   hi.depth = 1;
01307   hi.recur = NULL;
01308 
01309   return equal_hash_key2(o, &hi);
01310 }
01311 
01312 long scheme_eqv_hash_key(Scheme_Object *o)
01313 {
01314   if (!SCHEME_INTP(o) && (SCHEME_NUMBERP(o) || SCHEME_CHARP(o)))
01315     return scheme_equal_hash_key(o);
01316   else
01317     return (PTR_TO_LONG(o) >> 2);
01318 }
01319 
01320 long scheme_eqv_hash_key2(Scheme_Object *o)
01321 {
01322   if (!SCHEME_INTP(o) && (SCHEME_NUMBERP(o) || SCHEME_CHARP(o)))
01323     return scheme_equal_hash_key2(o);
01324   else
01325     return (PTR_TO_LONG(o) >> 3);
01326 }
01327 
01328 static Scheme_Object *hash2_recur(int argc, Scheme_Object **argv, Scheme_Object *prim)
01329 {
01330   long v;
01331   Hash_Info *hi;
01332 
01333   hi = (Hash_Info *)SCHEME_PRIM_CLOSURE_ELS(prim)[0];
01334   hi->depth += 2;
01335 
01336   v = equal_hash_key2(argv[0], hi);
01337   
01338   return scheme_make_integer(v);
01339 }
01340 
01341 static Scheme_Object *hash2_k(void)
01342 {
01343   Scheme_Thread *p = scheme_current_thread;
01344   Scheme_Object *v = (Scheme_Object *)p->ku.k.p1;
01345   Hash_Info *hi = (Hash_Info *)p->ku.k.p2;
01346   long nv;
01347 
01348   p->ku.k.p1 = NULL;
01349   p->ku.k.p2 = NULL;
01350   
01351   nv = equal_hash_key2(v, hi);
01352 
01353   return scheme_make_integer(nv);
01354 }
01355 
01356 static long overflow_equal_hash_key2(Scheme_Object *o, Hash_Info *hi)
01357 {
01358   Scheme_Object *nv;
01359   long val;
01360   Hash_Info *hi2;
01361   Scheme_Thread *p = scheme_current_thread;
01362 
01363   hi2 = (Hash_Info *)scheme_malloc(sizeof(Hash_Info));
01364   memcpy(hi2, hi, sizeof(Hash_Info));
01365 
01366   p->ku.k.p1 = (void *)o;
01367   p->ku.k.p2 = (void *)hi2;
01368 
01369   nv = scheme_handle_stack_overflow(hash2_k);
01370   scheme_get_int_val(nv, &val);
01371 
01372   memcpy(hi, hi2, sizeof(Hash_Info));
01373 
01374   return val;
01375 }
01376 
01377 #undef OVERFLOW_HASH
01378 #define OVERFLOW_HASH() overflow_equal_hash_key2(o, hi)
01379 
01380 static long equal_hash_key2(Scheme_Object *o, Hash_Info *hi)
01381 {
01382   Scheme_Type t;
01383   static int hash_counter = HASH_COUNT_START;
01384 
01385  top:
01386   t = SCHEME_TYPE(o);
01387 
01388   if (hi->depth > (MAX_HASH_DEPTH << 1))
01389     return t;
01390   
01391   switch(t) {
01392   case scheme_integer_type:
01393     return t - SCHEME_INT_VAL(o);
01394 #ifdef MZ_USE_SINGLE_FLOATS
01395   case scheme_float_type:
01396 #endif
01397   case scheme_double_type:
01398     {
01399       double d;
01400       int e;
01401       d = SCHEME_FLOAT_VAL(o);
01402       if (MZ_IS_NAN(d)
01403          || MZ_IS_POS_INFINITY(d)
01404          || MZ_IS_NEG_INFINITY(d)) {
01405        e = 1;
01406       } else {
01407        /* frexp should not be used on inf or nan: */
01408        d = frexp(d, &e);
01409       }
01410       return e;
01411     }
01412   case scheme_bignum_type:
01413     return SCHEME_BIGDIG(o)[0];
01414   case scheme_rational_type:
01415     return equal_hash_key2(scheme_rational_numerator(o), hi);
01416   case scheme_complex_type:
01417     {
01418       long v1, v2;
01419       Scheme_Complex *c = (Scheme_Complex *)o;
01420       v1 = equal_hash_key2(c->r, hi);
01421       v2 = equal_hash_key2(c->i, hi);
01422       return v1 + v2;
01423     }
01424   case scheme_pair_type:
01425     {
01426       long v1, v2;
01427 #     include "mzhashchk.inc"
01428       hi->depth += 2;
01429       v1 = equal_hash_key2(SCHEME_CAR(o), hi);
01430       v2 = equal_hash_key2(SCHEME_CDR(o), hi);
01431       return v1 + v2;
01432     }
01433   case scheme_mutable_pair_type:
01434     {
01435       long v1, v2;
01436 #     include "mzhashchk.inc"
01437       hi->depth += 2;
01438       v1 = equal_hash_key2(SCHEME_CAR(o), hi);
01439       v2 = equal_hash_key2(SCHEME_CDR(o), hi);
01440       return v1 + v2;
01441     }
01442   case scheme_vector_type:
01443   case scheme_wrap_chunk_type:
01444     {
01445       int len = SCHEME_VEC_SIZE(o), i;
01446       long k = 0;
01447 
01448 #     include "mzhashchk.inc"
01449 
01450       hi->depth += 2;
01451 
01452       for (i = 0; i < len; i++) {
01453        SCHEME_USE_FUEL(1);
01454        k += equal_hash_key2(SCHEME_VEC_ELS(o)[i], hi);
01455       }
01456       
01457       return k;
01458     }
01459   case scheme_char_type:
01460     return t;
01461   case scheme_byte_string_type:
01462   case scheme_unix_path_type:
01463   case scheme_windows_path_type:
01464     {
01465       int k = 0, i = SCHEME_BYTE_STRLEN_VAL(o);
01466       char *s = SCHEME_BYTE_STR_VAL(o);
01467     
01468       while (i--) {
01469        k += s[i];
01470       }
01471     
01472       return k;
01473     }
01474   case scheme_char_string_type:
01475     {
01476       int k = 0, i = SCHEME_CHAR_STRLEN_VAL(o);
01477       mzchar *s = SCHEME_CHAR_STR_VAL(o);
01478     
01479       while (i--) {
01480        k += s[i];
01481       }
01482     
01483       return k;
01484     }
01485   case scheme_structure_type:
01486   case scheme_proc_struct_type:
01487     {
01488       Scheme_Object *procs;
01489 
01490       procs = scheme_struct_type_property_ref(scheme_equal_property, o);
01491       if (procs) {
01492         Scheme_Object *a[2], *v, *recur;
01493         Hash_Info *hi2;
01494 
01495 #       include "mzhashchk.inc"
01496 
01497         /* Create/cache closure to use for recursive hashing: */
01498         if (hi->recur) {
01499           recur = hi->recur;
01500           hi2 = (Hash_Info *)SCHEME_PRIM_CLOSURE_ELS(recur)[0];
01501         } else {
01502           hi2 = (Hash_Info *)scheme_malloc(sizeof(Hash_Info));
01503           a[0] = (Scheme_Object *)hi2;
01504           recur = scheme_make_prim_closure_w_arity(hash2_recur,
01505                                                    1, a,
01506                                                    "equal-secondary-hash-code/recur",
01507                                                    1, 1);
01508           hi->recur = recur;
01509         }
01510         memcpy(hi2, hi, sizeof(Hash_Info));
01511         
01512         a[0] = o;
01513         a[1] = recur;
01514         
01515         procs = SCHEME_VEC_ELS(procs)[3];
01516         
01517         v = _scheme_apply(procs, 2, a);
01518 
01519         if (SCHEME_INTP(v))
01520           return SCHEME_INT_VAL(v);
01521         else if (SCHEME_BIGNUMP(v)) {
01522           return (long)((Scheme_Bignum *)v)->digits[0];
01523         } else {
01524           scheme_arg_mismatch("equal-secondary-hash-code",
01525                               "hash procedure returned a value other than an exact integer: ",
01526                               v);
01527           return 0;
01528         }
01529       } else {
01530         Scheme_Object *insp;
01531         insp = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
01532         if (scheme_inspector_sees_part(o, insp, -2)) {
01533           int i;
01534           long k = 0;
01535           Scheme_Structure *s1 = (Scheme_Structure *)o;
01536           
01537 #         include "mzhashchk.inc"
01538        
01539           hi->depth += 2;
01540 
01541           for (i = SCHEME_STRUCT_NUM_SLOTS(s1); i--; ) {
01542             k += equal_hash_key2(s1->slots[i], hi);
01543           }
01544           
01545           return k;
01546         } else
01547           return t;
01548       }
01549     }
01550   case scheme_box_type:
01551     o = SCHEME_BOX_VAL(o);
01552     hi->depth += 2;
01553     goto top;
01554   case scheme_hash_table_type:
01555     {
01556       Scheme_Hash_Table *ht = (Scheme_Hash_Table *)o;
01557       Scheme_Object **vals, **keys;
01558       int i;
01559       long k = 0;
01560       
01561 #     include "mzhashchk.inc"
01562 
01563       hi->depth += 2;
01564 
01565       keys = ht->keys;
01566       vals = ht->vals;
01567       for (i = ht->size; i--; ) {
01568        if (vals[i]) {
01569          k += equal_hash_key2(keys[i], hi);
01570          k += equal_hash_key2(vals[i], hi);
01571        }
01572       }
01573       
01574       return k;
01575     }
01576   case scheme_hash_tree_type:
01577     {
01578       Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)o;
01579       Scheme_Object *iv, *ik;
01580       int i;
01581       long k = 0;
01582       
01583 #     include "mzhashchk.inc"
01584 
01585       hi->depth += 2;
01586 
01587       for (i = ht->count; i--; ) {
01588         scheme_hash_tree_index(ht, i, &ik, &iv);
01589         k += equal_hash_key2(ik, hi);
01590         k += equal_hash_key2(iv, hi);
01591       }
01592       
01593       return k;
01594     }
01595   case scheme_bucket_table_type:
01596     {
01597       Scheme_Bucket_Table *ht = (Scheme_Bucket_Table *)o;
01598       Scheme_Bucket **buckets, *bucket;
01599       const char *key;
01600       int i, weak;
01601       long k = 0;
01602 
01603 #     include "mzhashchk.inc"
01604   
01605       buckets = ht->buckets;
01606       weak = ht->weak;
01607       
01608       hi->depth += 2;
01609 
01610       for (i = ht->size; i--; ) {
01611        bucket = buckets[i];
01612        if (bucket) {
01613          if (weak) {
01614            key = (const char *)HT_EXTRACT_WEAK(bucket->key);
01615          } else {
01616            key = bucket->key;
01617          }
01618          if (key) {
01619            k += equal_hash_key2((Scheme_Object *)bucket->val, hi);
01620            k += equal_hash_key2((Scheme_Object *)key, hi);
01621          }
01622        }
01623       }
01624     
01625       return k;
01626     }
01627   case scheme_resolved_module_path_type:
01628     /* Needed for interning */
01629     o = SCHEME_PTR_VAL(o);
01630     goto top;
01631   default:
01632     {
01633       Scheme_Secondary_Hash_Proc h2 = scheme_type_hash2s[t];
01634       if (h2)
01635         return h2(o, hi);
01636       else
01637         return t;
01638     }
01639   }
01640 }
01641 
01642 long scheme_recur_equal_hash_key(Scheme_Object *o, void *cycle_data)
01643 {
01644   return equal_hash_key(o, 0, (Hash_Info *)cycle_data);
01645 }
01646 
01647 long scheme_recur_equal_hash_key2(Scheme_Object *o, void *cycle_data)
01648 {
01649   return equal_hash_key2(o, (Hash_Info *)cycle_data);
01650 }
01651 
01652 /*========================================================================*/
01653 /*                        functional hash tables                          */
01654 /*========================================================================*/
01655 
01656 /* Direct port of red-black trees in Jens Axel Soegaard's "galore" package,
01657    which implemented in Scheme (5th may 2006 version) and says:
01658    
01659    ; This is direct port of Jean-Christophe Filliatre's implementation
01660    ; of red-black trees in Ocaml. */
01661 
01662 typedef struct RBNode {
01663   Scheme_Inclhash_Object iso; /* 0x1 => red */
01664   unsigned long code;
01665   Scheme_Object *key; /* NULL => val is list of key-value pairs */
01666   Scheme_Object *val;
01667   struct RBNode *left, *right;
01668 } RBNode;
01669 
01670 #define RB_REDP(rb) (MZ_OPT_HASH_KEY(&(rb)->iso) & 0x1)
01671 
01672 #if 0
01673 # define RB_ASSERT(p) if (p) { } else { scheme_signal_error("hash-tree assert failure %d", __LINE__); }
01674 #else
01675 # define RB_ASSERT(p) /* empty */
01676 #endif
01677 
01678 static RBNode *make_rb(int red, 
01679                        RBNode *left,
01680                        unsigned long code, Scheme_Object *key, Scheme_Object *val,
01681                        RBNode *right)
01682 {
01683   RBNode *rb;
01684 
01685   rb = MALLOC_ONE_TAGGED(RBNode);
01686   SET_REQUIRED_TAG(rb->iso.so.type = scheme_rt_rb_node);
01687   if (red)
01688     MZ_OPT_HASH_KEY(&rb->iso) |= 0x1;
01689   rb->code = code;
01690   rb->key = key;
01691   rb->val = val;
01692   rb->left = left;
01693   rb->right = right;
01694 
01695   return rb;
01696 }
01697 
01698 static RBNode *recolor_rb(int red, RBNode *rb)
01699 {
01700   return make_rb(red, rb->left, 
01701                  rb->code, rb->key, rb->val,
01702                  rb->right);
01703 }
01704 
01705 static RBNode *rb_find(unsigned long code, RBNode *s)
01706 {
01707   while (1) {
01708     if (!s)
01709       return NULL;
01710     
01711     if (s->code == code)
01712       return s;
01713     else if (s->code > code)
01714       s = s->left;
01715     else
01716       s = s->right;
01717   }
01718 }
01719 
01720 static RBNode *RB_CHK(RBNode *rb, unsigned long code)
01721 {
01722   RB_ASSERT(rb_find(code, rb));
01723   return rb;
01724 }
01725   
01726 /*
01727   ;;; INVARIANTS
01728   
01729   ;  (* Invariants: (1) a red node has no red son, and (2) any path from the
01730   ;     root to a leaf has the same number of black nodes *)
01731 */
01732 
01733 static RBNode *lbalance(RBNode *x1, 
01734                         unsigned long code, Scheme_Object *key, Scheme_Object *val,
01735                         RBNode *d)
01736 {
01737   /*
01738   (define (lbalance x1 x2 x3)
01739     (let ([z x2] [d x3])
01740       (match x1
01741         [($ R ($ R a x b) y c)  (R- (B- a x b) y (B- c z d))]
01742         [($ R a x ($ R b y c))  (R- (B- a x b) y (B- c z d))]
01743         [_                      (B- x1 x2 x3)])))
01744   */
01745 
01746   if (x1 && RB_REDP(x1)) {
01747     RBNode *left = x1->left;
01748     if (left && RB_REDP(left)) {
01749       return make_rb(1, 
01750                      recolor_rb(0, left),
01751                      x1->code, x1->key, x1->val,
01752                      make_rb(0, x1->right,
01753                              code, key, val,
01754                              d));
01755                              
01756     } else {
01757       RBNode *right = x1->right;
01758       if (right && RB_REDP(right)) {
01759         return make_rb(1,
01760                        make_rb(0, x1->left,
01761                                x1->code, x1->key, x1->val,
01762                                right->left),
01763                        right->code, right->key, right->val,
01764                        make_rb(0,
01765                                right->right,
01766                                code, key, val,
01767                                d));
01768 
01769       }
01770     }
01771   }
01772 
01773   return make_rb(0, x1, code, key, val, d);
01774 }
01775 
01776 static RBNode *rbalance(RBNode *a, 
01777                         unsigned long code, Scheme_Object *key, Scheme_Object *val,
01778                         RBNode *x3)
01779 {
01780   /*
01781   (define (rbalance x1 x2 x3)
01782     (let ([a x1] [x x2])
01783       (match x3
01784         [($ R ($ R b y c) z d)  (R- (B- a x b) y (B- c z d))]
01785         [($ R b y ($ R c z d))  (R- (B- a x b) y (B- c z d))]
01786         [_                      (B- x1 x2 x3)])))
01787   */
01788 
01789   if (x3 && RB_REDP(x3)) {
01790     RBNode *left = x3->left;
01791     if (left && RB_REDP(left)) {
01792       return make_rb(1,
01793                      make_rb(0, a,
01794                              code, key, val,
01795                              left->left),
01796                      left->code, left->key, left->val, 
01797                      make_rb(0, left->right,
01798                              x3->code, x3->key, x3->val,
01799                              x3->right));
01800     } else {
01801       RBNode *right = x3->right;
01802       if (right && RB_REDP(right)) {
01803         return make_rb(1,
01804                        make_rb(0, a,
01805                                code, key, val,
01806                                x3->left),
01807                        x3->code, x3->key, x3->val,
01808                        recolor_rb(0, right));
01809       }
01810     }
01811   }
01812 
01813   return make_rb(0, a, code, key, val, x3);
01814 }
01815 
01816 static RBNode *ins(unsigned long code, Scheme_Object *key, Scheme_Object *val, RBNode *s)
01817 {
01818   /*
01819       (match s
01820         [()           (R- empty x empty)]
01821         [($ R a y b)  (if3 (cmp x y)
01822                            (R- (ins a) y b)
01823                            s
01824                            (R- a y (ins b)))]
01825         [($ B a y b)  (if3 (cmp x y)
01826                            (lbalance (ins a) y b)
01827                            s
01828                            (rbalance a y (ins b)))]))
01829   */
01830 
01831   if (!s) {
01832     s = RB_CHK(make_rb(1, NULL, code, key, val, NULL), code);
01833     return s;
01834   } else if (RB_REDP(s)) {
01835     if (code < s->code) {
01836       return RB_CHK(make_rb(1, ins(code, key, val, s->left),
01837                             s->code, s->key, s->val,
01838                             s->right),
01839                     code);
01840     } else if (s->code == code) {
01841       return RB_CHK(s, code);
01842     } else {
01843       return RB_CHK(make_rb(1, s->left,
01844                             s->code, s->key, s->val,
01845                             ins(code, key, val, s->right)),
01846                     code);
01847     }
01848   } else {
01849     if (code < s->code) {
01850       return RB_CHK(lbalance(ins(code, key, val, s->left),
01851                              s->code, s->key, s->val,
01852                              s->right),
01853                     code);
01854     } else if (s->code == code) {
01855       return RB_CHK(s, code);
01856     } else {
01857       RBNode *r;
01858       r = RB_CHK(ins(code, key, val, s->right), code);
01859       return RB_CHK(rbalance(s->left,
01860                              s->code, s->key, s->val,
01861                              r),
01862                     code);
01863     }
01864   }
01865 }
01866 
01867 static RBNode *rb_insert(unsigned long code, Scheme_Object *key, Scheme_Object *val,
01868                          RBNode *s)
01869 {
01870   RBNode *s1;
01871 
01872   s1 = ins(code, key, val, s);
01873 
01874   /* ; color the root black */
01875   if (RB_REDP(s1))
01876     return recolor_rb(0, s1);
01877   else
01878     return s1;
01879 }
01880 
01881 static RBNode *rb_replace(RBNode *s, RBNode *orig, RBNode *naya)
01882 {
01883   if (SAME_OBJ(s, orig))
01884     return naya;
01885   if (s->code > orig->code)
01886     return make_rb(RB_REDP(s),
01887                    rb_replace(s->left, orig, naya),
01888                    s->code, s->key, s->val,
01889                    s->right);
01890   else
01891     return make_rb(RB_REDP(s),
01892                    s->left,
01893                    s->code, s->key, s->val,
01894                    rb_replace(s->right, orig, naya));
01895 }
01896 
01897 static RBNode *unbalanced_left(RBNode *s, int *_bh_dec)
01898 {
01899   /*
01900   ;  (* [unbalanced_left] repares invariant (2) when the black height of the
01901   ;     left son exceeds (by 1) the black height of the right son *)
01902   ; [original spelling kept -- a quote is a quote ]
01903 
01904   (define (unbalanced-left s)
01905     (match s
01906       [($ R ($ B t1 x1 t2) x2 t3)              (values (lbalance (R- t1 x1 t2) x2 t3) #f)]
01907       [($ B ($ B t1 x1 t2) x2 t3)              (values (lbalance (R- t1 x1 t2) x2 t3) #t)]
01908       [($ B ($ R t1 x1 ($ B t2 x2 t3)) x3 t4)  (values (B- t1 x1 (lbalance (R- t2 x2 t3) x3 t4)) #f)]
01909       [_                                       (error 'unbalanced-left
01910                                                       (format "Black height of both sons were the same: ~a"
01911                                                               (->sexp s)))]))
01912   */
01913   RBNode *left = s->left;
01914   
01915   RB_ASSERT(left);
01916 
01917   if (!RB_REDP(left)) {
01918     *_bh_dec = !RB_REDP(s);
01919     return lbalance(recolor_rb(1, left),
01920                     s->code, s->key,s->val,
01921                     s->right);
01922   } else {
01923     RBNode *lr = left->right;
01924     *_bh_dec = 0;
01925     RB_ASSERT(RB_REDP(left));
01926     RB_ASSERT(lr && !RB_REDP(lr));
01927     return make_rb(0, left->left,
01928                    left->code, left->key, left->val, 
01929                    lbalance(recolor_rb(1, lr),
01930                             s->code, s->key,s->val,
01931                             s->right));
01932   }
01933 }
01934 
01935 static RBNode *unbalanced_right(RBNode *s, int *_bh_dec)
01936 {
01937   /*
01938   ;  (* [unbalanced_right] repares invariant (2) when the black height of the
01939   ;     right son exceeds (by 1) the black height of the left son *)
01940   
01941   (define (unbalanced-right s)
01942     (match s
01943       [($ R t1 x1 ($ B t2 x2 t3))             (values (rbalance t1 x1 (R- t2 x2 t3)) #f)]
01944       [($ B t1 x1 ($ B t2 x2 t3))             (values (rbalance t1 x1 (R- t2 x2 t3)) #t)]
01945       [($ B t1 x1 ($ R ($ B t2 x2 t3) x3 t4)) (values (B- (rbalance t1 x1 (R- t2 x2 t3)) x3 t4) #f)]
01946       [_                                      (error 'unbalanced-right 
01947                                                      (format "Black height of both sons were the same: ~a"
01948                                                              (->sexp s)))]))
01949   
01950   */
01951   RBNode *right = s->right;
01952   
01953   RB_ASSERT(right);
01954 
01955   if (!RB_REDP(right)) {
01956     *_bh_dec = !RB_REDP(s);
01957     return rbalance(s->left,
01958                     s->code, s->key,s->val,
01959                     recolor_rb(1, right));
01960   } else {
01961     RBNode *rl = right->left;
01962     *_bh_dec = 0;
01963     RB_ASSERT(RB_REDP(right));
01964     RB_ASSERT(rl && !RB_REDP(rl));
01965     return make_rb(0, rbalance(s->left,
01966                                s->code, s->key,s->val,
01967                                recolor_rb(1, rl)),
01968                    right->code, right->key, right->val, 
01969                    right->right);
01970   }
01971 }
01972  
01973 static RBNode *remove_min(RBNode *s, RBNode **_m, int *_bh_dec)
01974 {
01975   /*
01976   ;  (* [remove_min s = (s',m,b)] extracts the minimum [m] of [s], [s'] being the
01977   ;     resulting set, and indicates with [b] whether the black height has
01978   ;     decreased *)
01979   
01980   (define (remove-min s)
01981     (match s
01982       [()                         (error "remove-min: Called on empty set")]
01983       ;  minimum is reached
01984       [($ B () x ())           (values empty x #t)]
01985       [($ B () x ($ R l y r))  (values (B- l y r) x #f)]
01986       [($ B () _ ($ B _ _ _))  (error)]
01987       [($ R () x r)            (values r x #f)]
01988       ;  minimum is recursively extracted from [l]
01989       [($ B l x r)                (let-values ([(l1 m d) (remove-min l)])
01990                                     (let ([t (B- l1 x r)])
01991                                       (if d
01992                                           (let-values ([(t d1) (unbalanced-right t)])
01993                                             (values t m d1))
01994                                           (values t m #f))))]
01995       [($ R l x r)                (let-values ([(l1 m d) (remove-min l)])
01996                                     (let ([t (R- l1 x r)])
01997                                       (if d
01998                                           (let-values ([(t d1) (unbalanced-right t)])
01999                                             (values t m d1))
02000                                           (values t m #f))))]))
02001   */
02002 
02003   RB_ASSERT(s);
02004 
02005   if (!RB_REDP(s) && !s->left) {
02006     if (!s->right) {
02007       *_bh_dec = 1;
02008       *_m = s;
02009       return NULL;
02010     } else if (RB_REDP(s->right)) {
02011       *_bh_dec = 0;
02012       *_m = s;
02013       return recolor_rb(0, s->right);
02014     } else {
02015       RB_ASSERT(0);
02016       return NULL;
02017     }
02018   }
02019   if (RB_REDP(s) && !s->left) {
02020     *_bh_dec = 0;
02021     *_m = s;
02022     return s->right;
02023   }
02024   /* covers last two cases of Scheme code: */
02025   {
02026     int left_bh_dec;
02027     RBNode *l1, *t;
02028     l1 = remove_min(s->left, _m, &left_bh_dec);
02029     t = make_rb(RB_REDP(s), l1, s->code, s->key, s->val, s->right);
02030     if (left_bh_dec)
02031       return unbalanced_right(t, _bh_dec);
02032     else {
02033       *_bh_dec = 0;
02034       return t;
02035     }
02036   }
02037 }
02038 
02039 static RBNode *remove_aux(RBNode *s, unsigned long code, int *_bh_dec)
02040 {
02041   /*
02042     (define (remove-aux s)
02043       (match s
02044         [()           (values empty #f)]
02045         [($ B l y r)  (if3 (cmp x y)
02046                            (let-values ([(l1 d) (remove-aux l)])
02047                              (let ([t (B- l1 y r)]) ; [mm: R-]
02048                                (if d
02049                                    (unbalanced-right t)
02050                                    (values t #f))))
02051                            (match r
02052                              [()    (blackify l)] ; [mm: (values l #f)]
02053                              [_     (let-values ([(r1 m d) (remove-min r)])
02054                                       (let ([t (B- l m r1)]) ; [mm: R-]
02055                                         (if d
02056                                             (unbalanced-left t)
02057                                             (values t #f))))])
02058                            
02059                            (let-values ([(r1 d) (remove-aux r)])
02060                              (let ([t (B- l y r1)]) ; [mm: R-]
02061                                (if d
02062                                    (unbalanced-left t)
02063                                    (values t #f)))))]
02064         [($ R l y r)  ...])) ; the same, with "mm" changes
02065   */
02066 
02067   if (!s) {
02068     *_bh_dec = 0;
02069     return NULL;
02070   } else {
02071     if (code < s->code) {
02072       RBNode *l1, *t;
02073       int left_bh_dec;
02074       l1 = remove_aux(s->left, code, &left_bh_dec);
02075       t = make_rb(RB_REDP(s), l1,
02076                   s->code, s->key, s->val,
02077                   s->right);
02078       if (left_bh_dec)
02079         return unbalanced_right(t, _bh_dec);
02080       else {
02081         *_bh_dec = 0;
02082         return t;
02083       }
02084     } else if (code == s->code) {
02085       if (!s->right) {
02086         if (!RB_REDP(s)) {
02087           RBNode *l = s->left;
02088           /* (blackify l) */
02089           if (!l) {
02090             *_bh_dec = 1;
02091             return NULL;
02092           } else if (RB_REDP(l)) {
02093             *_bh_dec = 0;
02094             return recolor_rb(0, l);
02095           } else {
02096             *_bh_dec = 1;
02097             return l;
02098           }
02099         } else {
02100           *_bh_dec = 0;
02101           return s->left;
02102         }
02103       } else {
02104         RBNode *r1, *t, *m;
02105         int right_bh_dec;
02106         r1 = remove_min(s->right, &m, &right_bh_dec);
02107         t = make_rb(RB_REDP(s), s->left,
02108                     m->code, m->key, m->val,
02109                     r1);
02110         if (right_bh_dec)
02111           return unbalanced_left(t, _bh_dec);
02112         else {
02113           *_bh_dec = 0;
02114           return t;
02115         }
02116       }
02117     } else {
02118       RBNode *r1, *t;
02119       int right_bh_dec;
02120       r1 = remove_aux(s->right, code, &right_bh_dec);
02121       t = make_rb(RB_REDP(s), s->left,
02122                   s->code, s->key, s->val,
02123                   r1);
02124       if (right_bh_dec)
02125         return unbalanced_left(t, _bh_dec);
02126       else {
02127         *_bh_dec = 0;
02128         return t;
02129       }
02130     }
02131   }
02132 }
02133 
02134 static RBNode *rb_remove(RBNode *s, unsigned long code)
02135 {
02136   int bh_dec;
02137   return remove_aux(s, code, &bh_dec);
02138 }
02139 
02140 Scheme_Hash_Tree *scheme_make_hash_tree(int kind)
02141 {
02142   Scheme_Hash_Tree *tree;
02143 
02144   tree = MALLOC_ONE_TAGGED(Scheme_Hash_Tree);
02145 
02146   tree->count = 0;
02147   
02148   tree->iso.so.type = scheme_hash_tree_type;
02149   SCHEME_HASHTR_FLAGS(tree) |= (kind & 0x3);
02150 
02151   return tree;
02152 }
02153 
02154 Scheme_Hash_Tree *scheme_hash_tree_set(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val)
02155 {
02156   Scheme_Hash_Tree *tree2;
02157   unsigned long h;
02158   RBNode *root, *added;
02159   int delta;
02160 
02161   if (SCHEME_HASHTR_FLAGS(tree) & 0x3) {
02162     if (SCHEME_HASHTR_FLAGS(tree) & 0x1) {
02163       h = (unsigned long)scheme_equal_hash_key(key);
02164     } else {
02165       h = (unsigned long)scheme_eqv_hash_key(key);
02166     }
02167   } else {
02168     h = (unsigned long)PTR_TO_LONG((Scheme_Object *)key);
02169   }
02170 
02171   if (!val) {
02172     /* Removing ... */
02173     added = rb_find(h, tree->root);
02174     if (!added)
02175       return tree; /* nothing to remove */
02176     if (added->key) {
02177       int kind = (SCHEME_HASHTR_FLAGS(tree) & 0x3);
02178 
02179       if ((kind && ((kind == 1)
02180                     ? scheme_equal(added->key, key)
02181                     : scheme_eqv(added->key, key)))
02182           || (!kind && SAME_OBJ(added->key, key))) {
02183         /* remove single item */
02184         root = rb_remove(tree->root, h);
02185         
02186         tree2 = MALLOC_ONE_TAGGED(Scheme_Hash_Tree);
02187         memcpy(tree2, tree, sizeof(Scheme_Hash_Tree));
02188         tree2->elems_box = NULL;
02189         
02190         tree2->root = root;
02191         --tree2->count;
02192         
02193         return tree2;
02194       } else {
02195         /* Nothing to remove */
02196         return tree;
02197       }
02198     } else {
02199       /* multiple mappings; remove it below */
02200       root = tree->root;
02201     }
02202   } else {
02203     /* Adding/setting: */
02204     root = rb_insert(h, NULL, NULL, tree->root);
02205     added = rb_find(h, root);
02206   }
02207 
02208   delta = 0;
02209   
02210   if (added->val) {
02211     int kind = (SCHEME_HASHTR_FLAGS(tree) & 0x3);
02212 
02213     if (!added->key) {
02214       /* Have a list of keys and vals. In this case, val can be NULL
02215          to implement removal. */
02216       Scheme_Object *prs = added->val, *a;
02217       int cnt = 0;
02218       while (prs) {
02219         a = SCHEME_CAR(prs);
02220         if (kind) {
02221           if (kind == 1) {
02222             if (scheme_equal(SCHEME_CAR(a), key))
02223               break;
02224           } else {
02225             if (scheme_eqv(SCHEME_CAR(a), key))
02226               break;
02227           }
02228         } else {
02229           if (SAME_OBJ(SCHEME_CAR(a), key))
02230             break;
02231         }
02232         prs = SCHEME_CDR(prs);
02233         cnt++;
02234       }
02235       if (!prs) {
02236         /* Not mapped already: */
02237         if (!val) return tree; /* nothing to remove after all */
02238         val = scheme_make_raw_pair(scheme_make_raw_pair(key, val), added->val);
02239         key = NULL;
02240         delta = 1;
02241       } else {
02242         /* Mapped already: */
02243         prs = SCHEME_CDR(prs);
02244         for (a = added->val; cnt--; a = SCHEME_CDR(a)) {
02245           prs = scheme_make_raw_pair(SCHEME_CAR(a), prs);
02246         }
02247         if (val) {
02248           prs = scheme_make_raw_pair(scheme_make_raw_pair(key, val),
02249                                      prs);
02250         } else {
02251           delta = -1;
02252         }
02253         val = prs;
02254         key = NULL;
02255         if (!SCHEME_CDR(prs)) {
02256           /* Removal reduced to a single mapping: */
02257           a = SCHEME_CAR(prs);
02258           key = SCHEME_CAR(a);
02259           val = SCHEME_CDR(a);
02260         }
02261       }
02262     } else {
02263       /* Currently have one value for this hash code */
02264       int same;
02265       if (kind) {
02266         if (kind == 1)
02267           same = scheme_equal(key, added->key);
02268         else
02269           same = scheme_eqv(key, added->key);
02270       } else {
02271         same = SAME_OBJ(key, added->key);
02272       }
02273       if (!same) {
02274         val = scheme_make_raw_pair(scheme_make_raw_pair(key, val),
02275                                    scheme_make_raw_pair(scheme_make_raw_pair(added->key, added->val),
02276                                                         NULL));
02277         key = NULL;
02278         delta = 1;
02279       }
02280     }
02281     root = rb_replace(root,
02282                       added,
02283                       make_rb(RB_REDP(added),
02284                               added->left,
02285                               added->code, key, val,
02286                               added->right));
02287   } else {
02288     added->key = key;
02289     added->val = val;
02290     delta = 1;
02291   }
02292 
02293   tree2 = MALLOC_ONE_TAGGED(Scheme_Hash_Tree);
02294   memcpy(tree2, tree, sizeof(Scheme_Hash_Tree));
02295   tree2->elems_box = NULL;
02296 
02297   if (delta)
02298     tree2->count += delta;
02299   tree2->root = root;
02300 
02301   return tree2;
02302 }
02303 
02304 Scheme_Object *scheme_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key)
02305 {
02306   unsigned long h;
02307   RBNode *rb;
02308   int kind = (SCHEME_HASHTR_FLAGS(tree) & 0x3);
02309 
02310   if (kind) {
02311     if (kind == 1)
02312       h = (unsigned long)scheme_equal_hash_key(key);
02313     else
02314       h = (unsigned long)scheme_eqv_hash_key(key);
02315   } else {
02316     h = (unsigned long)PTR_TO_LONG((Scheme_Object *)key);
02317   }
02318 
02319   rb = rb_find(h, tree->root);
02320   if (rb) {
02321     if (!rb->key) {
02322       /* Have list of keys & vals: */
02323       Scheme_Object *prs = rb->val, *a;
02324       while (prs) {
02325         a = SCHEME_CAR(prs);
02326         if (kind) {
02327           if (kind == 1) {
02328             if (scheme_equal(SCHEME_CAR(a), key))
02329               return SCHEME_CDR(a);
02330           } else {
02331             if (scheme_eqv(SCHEME_CAR(a), key))
02332               return SCHEME_CDR(a);
02333           }
02334         } else {
02335           if (SAME_OBJ(SCHEME_CAR(a), key))
02336             return SCHEME_CDR(a);
02337         }
02338         prs = SCHEME_CDR(prs);
02339       }
02340     } else {
02341       if (kind) {
02342         if (kind == 1) {
02343           if (scheme_equal(key, rb->key))
02344             return rb->val;
02345         } else {
02346           if (scheme_eqv(key, rb->key))
02347             return rb->val;
02348         }
02349       } else if (SAME_OBJ(key, rb->key))
02350         return rb->val;
02351     }
02352   }
02353 
02354   return NULL;
02355 }
02356 
02357 long scheme_hash_tree_next(Scheme_Hash_Tree *tree, long pos)
02358 {
02359   if (pos >= tree->count)
02360     return -2;
02361   pos++;
02362   if (tree->count > pos)
02363     return pos;
02364   else
02365     return -1;
02366 }
02367 
02368 static int fill_elems(RBNode *rb, Scheme_Object *vec, long pos, long count)
02369 {
02370   if (!rb)
02371     return pos;
02372 
02373   if (rb->left)
02374     pos = fill_elems(rb->left, vec, pos, count);
02375 
02376   if (rb->key) {
02377     SCHEME_VEC_ELS(vec)[pos] = rb->val;
02378     SCHEME_VEC_ELS(vec)[pos + count] = rb->key;
02379     pos++;
02380   } else {
02381     Scheme_Object *prs = rb->val, *a;
02382     while (prs) {
02383       a = SCHEME_CAR(prs);
02384       SCHEME_VEC_ELS(vec)[pos] = SCHEME_CDR(a);
02385       SCHEME_VEC_ELS(vec)[pos + count] = SCHEME_CAR(a);
02386       pos++;
02387       prs = SCHEME_CDR(prs);
02388     }
02389   }
02390 
02391   if (rb->right)
02392     pos = fill_elems(rb->right, vec, pos, count);
02393 
02394   return pos;
02395 }
02396 
02397 int scheme_hash_tree_index(Scheme_Hash_Tree *tree, long pos, Scheme_Object **_key, Scheme_Object **_val)
02398 {
02399   Scheme_Object *elems, *elems_box;
02400 
02401   if ((pos < 0) || (pos >= tree->count))
02402     return 0;
02403 
02404   elems_box = tree->elems_box;
02405   if (elems_box)
02406     elems = SCHEME_WEAK_BOX_VAL(elems_box);
02407   else
02408     elems = NULL;
02409   if (!elems) {
02410     int total_pos;
02411     elems = scheme_make_vector(tree->count * 2, NULL);
02412     total_pos = fill_elems(tree->root, elems, 0, tree->count);
02413     RB_ASSERT(total_pos == tree->count);
02414     elems_box = scheme_make_weak_box(elems);
02415     tree->elems_box = elems_box;
02416   }
02417 
02418   *_val = SCHEME_VEC_ELS(elems)[pos];
02419   *_key = SCHEME_VEC_ELS(elems)[tree->count + pos];
02420 
02421   return 1;
02422 }
02423 
02424 int scheme_hash_tree_equal_rec(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2, void *eql)
02425 {
02426   Scheme_Object *k, *v, *v2;
02427   int i;
02428 
02429   if ((t1->count != t2->count)
02430       || ((SCHEME_HASHTR_FLAGS(t1) & 0x3) != (SCHEME_HASHTR_FLAGS(t2) & 0x3)))
02431     return 0;
02432     
02433   for (i = t1->count; i--; ) {
02434     scheme_hash_tree_index(t1, i, &k, &v);
02435     v2 = scheme_hash_tree_get(t2, k);
02436     if (!v2)
02437       return 0;
02438     if (!scheme_recur_equal(v, v2, eql))
02439       return 0;
02440   }
02441 
02442   return 1;
02443 }
02444 
02445 int scheme_hash_tree_equal(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2)
02446 {
02447   return scheme_equal((Scheme_Object *)t1, (Scheme_Object *)t2);
02448 }
02449 
02450 
02451 /*========================================================================*/
02452 /*                         precise GC traversers                          */
02453 /*========================================================================*/
02454 
02455 #ifdef MZ_PRECISE_GC
02456 
02457 START_XFORM_SKIP;
02458 
02459 #define MARKS_FOR_HASH_C
02460 #include "mzmark.c"
02461 
02462 static void register_traversers(void)
02463 {
02464   GC_REG_TRAV(scheme_hash_tree_type, hash_tree_val);
02465   GC_REG_TRAV(scheme_rt_rb_node, mark_rb_node);
02466 }
02467 
02468 END_XFORM_SKIP;
02469 
02470 #endif