guile18/libguile/hashtab.c

   1 /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2010 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16  */
  17
  18
  19 \f
  20 #ifdef HAVE_CONFIG_H
  21 # include <config.h>
  22 #endif
  23
  24 #include <stdio.h>
  25
  26 #include "libguile/_scm.h"
  27 #include "libguile/alist.h"
  28 #include "libguile/hash.h"
  29 #include "libguile/eval.h"
  30 #include "libguile/root.h"
  31 #include "libguile/vectors.h"
  32 #include "libguile/ports.h"
  33
  34 #include "libguile/validate.h"
  35 #include "libguile/hashtab.h"
  36 \f
  37
  38 /* NOTES
  39  *
  40  * 1. The current hash table implementation uses weak alist vectors
  41  *    (implementation in weaks.c) internally, but we do the scanning
  42  *    ourselves (in scan_weak_hashtables) because we need to update the
  43  *    hash table structure when items are dropped during GC.
  44  *
  45  * 2. All hash table operations still work on alist vectors.
  46  *
  47  */
  48
  49 /* Hash tables are either vectors of association lists or smobs
  50  * containing such vectors.  Currently, the vector version represents
  51  * constant size tables while those wrapped in a smob represents
  52  * resizing tables.
  53  *
  54  * Growing or shrinking, with following rehashing, is triggered when
  55  * the load factor
  56  *
  57  *   L = N / S    (N: number of items in table, S: bucket vector length)
  58  *
  59  * passes an upper limit of 0.9 or a lower limit of 0.25.
  60  *
  61  * The implementation stores the upper and lower number of items which
  62  * trigger a resize in the hashtable object.
  63  *
  64  * Possible hash table sizes (primes) are stored in the array
  65  * hashtable_size.
  66  */
  67
  68 scm_t_bits scm_tc16_hashtable;
  69
  70 static unsigned long hashtable_size[] = {
  71   31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363,
  72   224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041
  73 #if 0
  74   /* vectors are currently restricted to 2^24-1 = 16777215 elements. */
  75   28762081, 57524111, 115048217, 230096423, 460192829
  76   /* larger values can't be represented as INUMs */
  77 #endif
  78 };
  79
  80 #define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long))
  81
  82 static char *s_hashtable = "hashtable";
  83
  84 SCM weak_hashtables = SCM_EOL;
  85
  86 static SCM
  87 make_hash_table (int flags, unsigned long k, const char *func_name)
  88 {
  89   SCM table, vector;
  90   scm_t_hashtable *t;
  91   int i = 0, n = k ? k : 31;
  92   while (i < HASHTABLE_SIZE_N && n > hashtable_size[i])
  93     ++i;
  94   n = hashtable_size[i];
  95   if (flags)
  96     vector = scm_i_allocate_weak_vector (flags, scm_from_int (n), SCM_EOL);
  97   else
  98     vector = scm_c_make_vector (n, SCM_EOL);
  99   t = scm_gc_malloc (sizeof (*t), s_hashtable);
 100   t->min_size_index = t->size_index = i;
 101   t->n_items = 0;
 102   t->lower = 0;
 103   t->upper = 9 * n / 10;
 104   t->flags = flags;
 105   t->hash_fn = NULL;
 106   if (flags)
 107     {
 108       SCM_NEWSMOB3 (table, scm_tc16_hashtable, vector, t, weak_hashtables);
 109       weak_hashtables = table;
 110     }
 111   else
 112     SCM_NEWSMOB3 (table, scm_tc16_hashtable, vector, t, SCM_EOL);
 113   return table;
 114 }
 115
 116 void
 117 scm_i_rehash (SCM table,
 118               unsigned long (*hash_fn)(),
 119               void *closure,
 120               const char* func_name)
 121 {
 122   SCM buckets, new_buckets;
 123   int i;
 124   unsigned long old_size;
 125   unsigned long new_size;
 126
 127   if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table))
 128     {
 129       /* rehashing is not triggered when i <= min_size */
 130       i = SCM_HASHTABLE (table)->size_index;
 131       do
 132         --i;
 133       while (i > SCM_HASHTABLE (table)->min_size_index
 134              && SCM_HASHTABLE_N_ITEMS (table) < hashtable_size[i] / 4);
 135     }
 136   else
 137     {
 138       i = SCM_HASHTABLE (table)->size_index + 1;
 139       if (i >= HASHTABLE_SIZE_N)
 140         /* don't rehash */
 141         return;
 142
 143       /* Remember HASH_FN for rehash_after_gc, but only when CLOSURE
 144          is not needed since CLOSURE can not be guaranteed to be valid
 145          after this function returns.
 146       */
 147       if (closure == NULL)
 148         SCM_HASHTABLE (table)->hash_fn = hash_fn;
 149     }
 150   SCM_HASHTABLE (table)->size_index = i;
 151
 152   new_size = hashtable_size[i];
 153   if (i <= SCM_HASHTABLE (table)->min_size_index)
 154     SCM_HASHTABLE (table)->lower = 0;
 155   else
 156     SCM_HASHTABLE (table)->lower = new_size / 4;
 157   SCM_HASHTABLE (table)->upper = 9 * new_size / 10;
 158   buckets = SCM_HASHTABLE_VECTOR (table);
 159
 160   if (SCM_HASHTABLE_WEAK_P (table))
 161     new_buckets = scm_i_allocate_weak_vector (SCM_HASHTABLE_FLAGS (table),
 162                                               scm_from_ulong (new_size),
 163                                               SCM_EOL);
 164   else
 165     new_buckets = scm_c_make_vector (new_size, SCM_EOL);
 166
 167   /* When this is a weak hashtable, running the GC might change it.
 168      We need to cope with this while rehashing its elements.  We do
 169      this by first installing the new, empty bucket vector.  Then we
 170      remove the elements from the old bucket vector and insert them
 171      into the new one.
 172   */
 173
 174   SCM_SET_HASHTABLE_VECTOR (table, new_buckets);
 175   SCM_SET_HASHTABLE_N_ITEMS (table, 0);
 176
 177   old_size = SCM_SIMPLE_VECTOR_LENGTH (buckets);
 178   for (i = 0; i < old_size; ++i)
 179     {
 180       SCM ls, cell, handle;
 181
 182       ls = SCM_SIMPLE_VECTOR_REF (buckets, i);
 183       SCM_SIMPLE_VECTOR_SET (buckets, i, SCM_EOL);
 184
 185       while (scm_is_pair (ls))
 186         {
 187           unsigned long h;
 188           cell = ls;
 189           handle = SCM_CAR (cell);
 190           ls = SCM_CDR (ls);
 191           h = hash_fn (SCM_CAR (handle), new_size, closure);
 192           if (h >= new_size)
 193             scm_out_of_range (func_name, scm_from_ulong (h));
 194           SCM_SETCDR (cell, SCM_SIMPLE_VECTOR_REF (new_buckets, h));
 195           SCM_SIMPLE_VECTOR_SET (new_buckets, h, cell);
 196           SCM_HASHTABLE_INCREMENT (table);
 197         }
 198     }
 199 }
 200
 201
 202 static int
 203 hashtable_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
 204 {
 205   scm_puts ("#<", port);
 206   if (SCM_HASHTABLE_WEAK_KEY_P (exp))
 207     scm_puts ("weak-key-", port);
 208   else if (SCM_HASHTABLE_WEAK_VALUE_P (exp))
 209     scm_puts ("weak-value-", port);
 210   else if (SCM_HASHTABLE_DOUBLY_WEAK_P (exp))
 211     scm_puts ("doubly-weak-", port);
 212   scm_puts ("hash-table ", port);
 213   scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp), 10, port);
 214   scm_putc ('/', port);
 215   scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp)),
 216                  10, port);
 217   scm_puts (">", port);
 218   return 1;
 219 }
 220
 221 #define UNMARKED_CELL_P(x) (SCM_NIMP(x) && !SCM_GC_MARK_P (x))
 222
 223 /* keep track of hash tables that need to shrink after scan */
 224 static SCM to_rehash = SCM_EOL;
 225
 226 /* scan hash tables and update hash tables item count */
 227 void
 228 scm_i_scan_weak_hashtables ()
 229 {
 230   SCM *next = &weak_hashtables;
 231   SCM h = *next;
 232   while (!scm_is_null (h))
 233     {
 234       if (!SCM_GC_MARK_P (h))
 235         *next = h = SCM_HASHTABLE_NEXT (h);
 236       else
 237         {
 238           SCM vec = SCM_HASHTABLE_VECTOR (h);
 239           size_t delta = SCM_I_WVECT_DELTA (vec);
 240           SCM_I_SET_WVECT_DELTA (vec, 0);
 241           SCM_SET_HASHTABLE_N_ITEMS (h, SCM_HASHTABLE_N_ITEMS (h) - delta);
 242
 243           if (SCM_HASHTABLE_N_ITEMS (h) < SCM_HASHTABLE_LOWER (h))
 244             {
 245               SCM tmp = SCM_HASHTABLE_NEXT (h);
 246               /* temporarily move table from weak_hashtables to to_rehash */
 247               SCM_SET_HASHTABLE_NEXT (h, to_rehash);
 248               to_rehash = h;
 249               *next = h = tmp;
 250             }
 251           else
 252             {
 253               next = SCM_HASHTABLE_NEXTLOC (h);
 254               h = SCM_HASHTABLE_NEXT (h);
 255             }
 256         }
 257     }
 258 }
 259
 260 static void *
 261 rehash_after_gc (void *dummy1 SCM_UNUSED,
 262                  void *dummy2 SCM_UNUSED,
 263                  void *dummy3 SCM_UNUSED)
 264 {
 265   if (!scm_is_null (to_rehash))
 266     {
 267       SCM first = to_rehash, last, h;
 268       /* important to clear to_rehash here so that we don't get stuck
 269          in an infinite loop if scm_i_rehash causes GC */
 270       to_rehash = SCM_EOL;
 271       h = first;
 272       do
 273         {
 274           /* Rehash only when we have a hash_fn.
 275            */
 276           if (SCM_HASHTABLE (h)->hash_fn)
 277             scm_i_rehash (h, SCM_HASHTABLE (h)->hash_fn, NULL,
 278                           "rehash_after_gc");
 279           last = h;
 280           h = SCM_HASHTABLE_NEXT (h);
 281         } while (!scm_is_null (h));
 282       /* move tables back to weak_hashtables */
 283       SCM_SET_HASHTABLE_NEXT (last, weak_hashtables);
 284       weak_hashtables = first;
 285     }
 286   return 0;
 287 }
 288
 289 static size_t
 290 hashtable_free (SCM obj)
 291 {
 292   scm_gc_free (SCM_HASHTABLE (obj), sizeof (scm_t_hashtable), s_hashtable);
 293   return 0;
 294 }
 295
 296
 297 SCM
 298 scm_c_make_hash_table (unsigned long k)
 299 {
 300   return make_hash_table (0, k, "scm_c_make_hash_table");
 301 }
 302
 303 SCM_DEFINE (scm_make_hash_table, "make-hash-table", 0, 1, 0,
 304             (SCM n),
 305             "Make a new abstract hash table object with minimum number of buckets @var{n}\n")
 306 #define FUNC_NAME s_scm_make_hash_table
 307 {
 308   if (SCM_UNBNDP (n))
 309     return make_hash_table (0, 0, FUNC_NAME);
 310   else
 311     return make_hash_table (0, scm_to_ulong (n), FUNC_NAME);
 312 }
 313 #undef FUNC_NAME
 314
 315 SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 0, 1, 0,
 316             (SCM n),
 317             "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
 318             "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n"
 319             "Return a weak hash table with @var{size} buckets.\n"
 320             "\n"
 321             "You can modify weak hash tables in exactly the same way you\n"
 322             "would modify regular hash tables. (@pxref{Hash Tables})")
 323 #define FUNC_NAME s_scm_make_weak_key_hash_table
 324 {
 325   if (SCM_UNBNDP (n))
 326     return make_hash_table (SCM_HASHTABLEF_WEAK_CAR, 0, FUNC_NAME);
 327   else
 328     return make_hash_table (SCM_HASHTABLEF_WEAK_CAR,
 329                             scm_to_ulong (n), FUNC_NAME);
 330 }
 331 #undef FUNC_NAME
 332
 333
 334 SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 0, 1, 0,
 335             (SCM n),
 336             "Return a hash table with weak values with @var{size} buckets.\n"
 337             "(@pxref{Hash Tables})")
 338 #define FUNC_NAME s_scm_make_weak_value_hash_table
 339 {
 340   if (SCM_UNBNDP (n))
 341     return make_hash_table (SCM_HASHTABLEF_WEAK_CDR, 0, FUNC_NAME);
 342   else
 343     {
 344       return make_hash_table (SCM_HASHTABLEF_WEAK_CDR,
 345                               scm_to_ulong (n), FUNC_NAME);
 346     }
 347 }
 348 #undef FUNC_NAME
 349
 350
 351 SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0, 0,
 352             (SCM n),
 353             "Return a hash table with weak keys and values with @var{size}\n"
 354             "buckets.  (@pxref{Hash Tables})")
 355 #define FUNC_NAME s_scm_make_doubly_weak_hash_table
 356 {
 357   if (SCM_UNBNDP (n))
 358     return make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR,
 359                             0,
 360                             FUNC_NAME);
 361   else
 362     {
 363       return make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR,
 364                               scm_to_ulong (n),
 365                               FUNC_NAME);
 366     }
 367 }
 368 #undef FUNC_NAME
 369
 370
 371 SCM_DEFINE (scm_hash_table_p, "hash-table?", 1, 0, 0,
 372             (SCM obj),
 373             "Return @code{#t} if @var{obj} is an abstract hash table object.")
 374 #define FUNC_NAME s_scm_hash_table_p
 375 {
 376   return scm_from_bool (SCM_HASHTABLE_P (obj));
 377 }
 378 #undef FUNC_NAME
 379
 380
 381 SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0,
 382            (SCM obj),
 383             "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n"
 384             "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n"
 385             "Return @code{#t} if @var{obj} is the specified weak hash\n"
 386             "table. Note that a doubly weak hash table is neither a weak key\n"
 387             "nor a weak value hash table.")
 388 #define FUNC_NAME s_scm_weak_key_hash_table_p
 389 {
 390   return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_WEAK_KEY_P (obj));
 391 }
 392 #undef FUNC_NAME
 393
 394
 395 SCM_DEFINE (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0,
 396             (SCM obj),
 397             "Return @code{#t} if @var{obj} is a weak value hash table.")
 398 #define FUNC_NAME s_scm_weak_value_hash_table_p
 399 {
 400   return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_WEAK_VALUE_P (obj));
 401 }
 402 #undef FUNC_NAME
 403
 404
 405 SCM_DEFINE (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0,
 406             (SCM obj),
 407             "Return @code{#t} if @var{obj} is a doubly weak hash table.")
 408 #define FUNC_NAME s_scm_doubly_weak_hash_table_p
 409 {
 410   return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_DOUBLY_WEAK_P (obj));
 411 }
 412 #undef FUNC_NAME
 413
 414
 415 SCM
 416 scm_hash_fn_get_handle (SCM table, SCM obj, unsigned long (*hash_fn)(), SCM (*assoc_fn)(), void * closure)
 417 #define FUNC_NAME "scm_hash_fn_get_handle"
 418 {
 419   unsigned long k;
 420   SCM h;
 421
 422   if (SCM_HASHTABLE_P (table))
 423     table = SCM_HASHTABLE_VECTOR (table);
 424   else
 425     SCM_VALIDATE_VECTOR (1, table);
 426   if (SCM_SIMPLE_VECTOR_LENGTH (table) == 0)
 427     return SCM_BOOL_F;
 428   k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (table), closure);
 429   if (k >= SCM_SIMPLE_VECTOR_LENGTH (table))
 430     scm_out_of_range ("hash_fn_get_handle", scm_from_ulong (k));
 431   h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (table, k), closure);
 432   return h;
 433 }
 434 #undef FUNC_NAME
 435
 436
 437 SCM
 438 scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned long (*hash_fn)(),
 439                              SCM (*assoc_fn)(), void * closure)
 440 #define FUNC_NAME "scm_hash_fn_create_handle_x"
 441 {
 442   unsigned long k;
 443   SCM buckets, it;
 444
 445   if (SCM_HASHTABLE_P (table))
 446     buckets = SCM_HASHTABLE_VECTOR (table);
 447   else
 448     {
 449       SCM_ASSERT (scm_is_simple_vector (table),
 450                   table, SCM_ARG1, "hash_fn_create_handle_x");
 451       buckets = table;
 452     }
 453   if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0)
 454     SCM_MISC_ERROR ("void hashtable", SCM_EOL);
 455
 456   k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure);
 457   if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
 458     scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k));
 459   it = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
 460   if (scm_is_pair (it))
 461     return it;
 462   else if (scm_is_true (it))
 463     scm_wrong_type_arg_msg (NULL, 0, it, "a pair");
 464   else
 465     {
 466       /* When this is a weak hashtable, running the GC can change it.
 467          Thus, we must allocate the new cells first and can only then
 468          access BUCKETS.  Also, we need to fetch the bucket vector
 469          again since the hashtable might have been rehashed.  This
 470          necessitates a new hash value as well.
 471       */
 472       SCM new_bucket = scm_acons (obj, init, SCM_EOL);
 473       if (!scm_is_eq (table, buckets)
 474           && !scm_is_eq (SCM_HASHTABLE_VECTOR (table), buckets))
 475         {
 476           buckets = SCM_HASHTABLE_VECTOR (table);
 477           k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure);
 478           if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
 479             scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k));
 480         }
 481       SCM_SETCDR (new_bucket, SCM_SIMPLE_VECTOR_REF (buckets, k));
 482       SCM_SIMPLE_VECTOR_SET (buckets, k, new_bucket);
 483       if (!scm_is_eq (table, buckets))
 484         {
 485           /* Update element count and maybe rehash the table.  The
 486              table might have too few entries here since weak hash
 487              tables used with the hashx_* functions can not be
 488              rehashed after GC.
 489           */
 490           SCM_HASHTABLE_INCREMENT (table);
 491           if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table)
 492               || SCM_HASHTABLE_N_ITEMS (table) > SCM_HASHTABLE_UPPER (table))
 493             scm_i_rehash (table, hash_fn, closure, FUNC_NAME);
 494         }
 495       return SCM_CAR (new_bucket);
 496     }
 497 }
 498 #undef FUNC_NAME
 499
 500
 501 SCM
 502 scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, unsigned long (*hash_fn)(),
 503                  SCM (*assoc_fn)(), void * closure)
 504 {
 505   SCM it = scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure);
 506   if (scm_is_pair (it))
 507     return SCM_CDR (it);
 508   else
 509     return dflt;
 510 }
 511
 512
 513
 514
 515 SCM
 516 scm_hash_fn_set_x (SCM table, SCM obj, SCM val, unsigned long (*hash_fn)(),
 517                    SCM (*assoc_fn)(), void * closure)
 518 {
 519   SCM it;
 520
 521   it = scm_hash_fn_create_handle_x (table, obj, SCM_BOOL_F, hash_fn, assoc_fn, closure);
 522   SCM_SETCDR (it, val);
 523   return val;
 524 }
 525
 526
 527 SCM
 528 scm_hash_fn_remove_x (SCM table, SCM obj,
 529                       unsigned long (*hash_fn)(),
 530                       SCM (*assoc_fn)(),
 531                       void *closure)
 532 {
 533   unsigned long k;
 534   SCM buckets, h;
 535
 536   if (SCM_HASHTABLE_P (table))
 537     buckets = SCM_HASHTABLE_VECTOR (table);
 538   else
 539     {
 540       SCM_ASSERT (scm_is_simple_vector (table), table,
 541                   SCM_ARG1, "hash_fn_remove_x");
 542       buckets = table;
 543     }
 544   if (SCM_SIMPLE_VECTOR_LENGTH (table) == 0)
 545     return SCM_EOL;
 546
 547   k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure);
 548   if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
 549     scm_out_of_range ("hash_fn_remove_x", scm_from_ulong (k));
 550   h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
 551   if (scm_is_true (h))
 552     {
 553       SCM_SIMPLE_VECTOR_SET
 554         (buckets, k, scm_delq_x (h, SCM_SIMPLE_VECTOR_REF (buckets, k)));
 555       if (!scm_is_eq (table, buckets))
 556         {
 557           SCM_HASHTABLE_DECREMENT (table);
 558           if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table))
 559             scm_i_rehash (table, hash_fn, closure, "scm_hash_fn_remove_x");
 560         }
 561     }
 562   return h;
 563 }
 564
 565 SCM_DEFINE (scm_hash_clear_x, "hash-clear!", 1, 0, 0,
 566             (SCM table),
 567             "Remove all items from @var{table} (without triggering a resize).")
 568 #define FUNC_NAME s_scm_hash_clear_x
 569 {
 570   if (SCM_HASHTABLE_P (table))
 571     {
 572       scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table), SCM_EOL);
 573       SCM_SET_HASHTABLE_N_ITEMS (table, 0);
 574     }
 575   else
 576     scm_vector_fill_x (table, SCM_EOL);
 577   return SCM_UNSPECIFIED;
 578 }
 579 #undef FUNC_NAME
 580
 581 \f
 582
 583 SCM_DEFINE (scm_hashq_get_handle, "hashq-get-handle", 2, 0, 0,
 584             (SCM table, SCM key),
 585             "This procedure returns the @code{(key . value)} pair from the\n"
 586             "hash table @var{table}.  If @var{table} does not hold an\n"
 587             "associated value for @var{key}, @code{#f} is returned.\n"
 588             "Uses @code{eq?} for equality testing.")
 589 #define FUNC_NAME s_scm_hashq_get_handle
 590 {
 591   return scm_hash_fn_get_handle (table, key, scm_ihashq, scm_sloppy_assq, 0);
 592 }
 593 #undef FUNC_NAME
 594
 595
 596 SCM_DEFINE (scm_hashq_create_handle_x, "hashq-create-handle!", 3, 0, 0,
 597             (SCM table, SCM key, SCM init),
 598             "This function looks up @var{key} in @var{table} and returns its handle.\n"
 599             "If @var{key} is not already present, a new handle is created which\n"
 600             "associates @var{key} with @var{init}.")
 601 #define FUNC_NAME s_scm_hashq_create_handle_x
 602 {
 603   return scm_hash_fn_create_handle_x (table, key, init, scm_ihashq, scm_sloppy_assq, 0);
 604 }
 605 #undef FUNC_NAME
 606
 607
 608 SCM_DEFINE (scm_hashq_ref, "hashq-ref", 2, 1, 0,
 609             (SCM table, SCM key, SCM dflt),
 610             "Look up @var{key} in the hash table @var{table}, and return the\n"
 611             "value (if any) associated with it.  If @var{key} is not found,\n"
 612             "return @var{default} (or @code{#f} if no @var{default} argument\n"
 613             "is supplied).  Uses @code{eq?} for equality testing.")
 614 #define FUNC_NAME s_scm_hashq_ref
 615 {
 616   if (SCM_UNBNDP (dflt))
 617     dflt = SCM_BOOL_F;
 618   return scm_hash_fn_ref (table, key, dflt, scm_ihashq, scm_sloppy_assq, 0);
 619 }
 620 #undef FUNC_NAME
 621
 622
 623
 624 SCM_DEFINE (scm_hashq_set_x, "hashq-set!", 3, 0, 0,
 625             (SCM table, SCM key, SCM val),
 626             "Find the entry in @var{table} associated with @var{key}, and\n"
 627             "store @var{value} there. Uses @code{eq?} for equality testing.")
 628 #define FUNC_NAME s_scm_hashq_set_x
 629 {
 630   return scm_hash_fn_set_x (table, key, val, scm_ihashq, scm_sloppy_assq, 0);
 631 }
 632 #undef FUNC_NAME
 633
 634
 635
 636 SCM_DEFINE (scm_hashq_remove_x, "hashq-remove!", 2, 0, 0,
 637             (SCM table, SCM key),
 638             "Remove @var{key} (and any value associated with it) from\n"
 639             "@var{table}.  Uses @code{eq?} for equality tests.")
 640 #define FUNC_NAME s_scm_hashq_remove_x
 641 {
 642   return scm_hash_fn_remove_x (table, key, scm_ihashq, scm_sloppy_assq, 0);
 643 }
 644 #undef FUNC_NAME
 645
 646
 647 \f
 648
 649 SCM_DEFINE (scm_hashv_get_handle, "hashv-get-handle", 2, 0, 0,
 650             (SCM table, SCM key),
 651             "This procedure returns the @code{(key . value)} pair from the\n"
 652             "hash table @var{table}.  If @var{table} does not hold an\n"
 653             "associated value for @var{key}, @code{#f} is returned.\n"
 654             "Uses @code{eqv?} for equality testing.")
 655 #define FUNC_NAME s_scm_hashv_get_handle
 656 {
 657   return scm_hash_fn_get_handle (table, key, scm_ihashv, scm_sloppy_assv, 0);
 658 }
 659 #undef FUNC_NAME
 660
 661
 662 SCM_DEFINE (scm_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0,
 663             (SCM table, SCM key, SCM init),
 664             "This function looks up @var{key} in @var{table} and returns its handle.\n"
 665             "If @var{key} is not already present, a new handle is created which\n"
 666             "associates @var{key} with @var{init}.")
 667 #define FUNC_NAME s_scm_hashv_create_handle_x
 668 {
 669   return scm_hash_fn_create_handle_x (table, key, init, scm_ihashv,
 670                                       scm_sloppy_assv, 0);
 671 }
 672 #undef FUNC_NAME
 673
 674
 675 SCM_DEFINE (scm_hashv_ref, "hashv-ref", 2, 1, 0,
 676             (SCM table, SCM key, SCM dflt),
 677             "Look up @var{key} in the hash table @var{table}, and return the\n"
 678             "value (if any) associated with it.  If @var{key} is not found,\n"
 679             "return @var{default} (or @code{#f} if no @var{default} argument\n"
 680             "is supplied).  Uses @code{eqv?} for equality testing.")
 681 #define FUNC_NAME s_scm_hashv_ref
 682 {
 683   if (SCM_UNBNDP (dflt))
 684     dflt = SCM_BOOL_F;
 685   return scm_hash_fn_ref (table, key, dflt, scm_ihashv, scm_sloppy_assv, 0);
 686 }
 687 #undef FUNC_NAME
 688
 689
 690
 691 SCM_DEFINE (scm_hashv_set_x, "hashv-set!", 3, 0, 0,
 692             (SCM table, SCM key, SCM val),
 693             "Find the entry in @var{table} associated with @var{key}, and\n"
 694             "store @var{value} there. Uses @code{eqv?} for equality testing.")
 695 #define FUNC_NAME s_scm_hashv_set_x
 696 {
 697   return scm_hash_fn_set_x (table, key, val, scm_ihashv, scm_sloppy_assv, 0);
 698 }
 699 #undef FUNC_NAME
 700
 701
 702 SCM_DEFINE (scm_hashv_remove_x, "hashv-remove!", 2, 0, 0,
 703             (SCM table, SCM key),
 704             "Remove @var{key} (and any value associated with it) from\n"
 705             "@var{table}.  Uses @code{eqv?} for equality tests.")
 706 #define FUNC_NAME s_scm_hashv_remove_x
 707 {
 708   return scm_hash_fn_remove_x (table, key, scm_ihashv, scm_sloppy_assv, 0);
 709 }
 710 #undef FUNC_NAME
 711
 712 \f
 713
 714 SCM_DEFINE (scm_hash_get_handle, "hash-get-handle", 2, 0, 0,
 715             (SCM table, SCM key),
 716             "This procedure returns the @code{(key . value)} pair from the\n"
 717             "hash table @var{table}.  If @var{table} does not hold an\n"
 718             "associated value for @var{key}, @code{#f} is returned.\n"
 719             "Uses @code{equal?} for equality testing.")
 720 #define FUNC_NAME s_scm_hash_get_handle
 721 {
 722   return scm_hash_fn_get_handle (table, key, scm_ihash, scm_sloppy_assoc, 0);
 723 }
 724 #undef FUNC_NAME
 725
 726
 727 SCM_DEFINE (scm_hash_create_handle_x, "hash-create-handle!", 3, 0, 0,
 728             (SCM table, SCM key, SCM init),
 729             "This function looks up @var{key} in @var{table} and returns its handle.\n"
 730             "If @var{key} is not already present, a new handle is created which\n"
 731             "associates @var{key} with @var{init}.")
 732 #define FUNC_NAME s_scm_hash_create_handle_x
 733 {
 734   return scm_hash_fn_create_handle_x (table, key, init, scm_ihash, scm_sloppy_assoc, 0);
 735 }
 736 #undef FUNC_NAME
 737
 738
 739 SCM_DEFINE (scm_hash_ref, "hash-ref", 2, 1, 0,
 740             (SCM table, SCM key, SCM dflt),
 741             "Look up @var{key} in the hash table @var{table}, and return the\n"
 742             "value (if any) associated with it.  If @var{key} is not found,\n"
 743             "return @var{default} (or @code{#f} if no @var{default} argument\n"
 744             "is supplied).  Uses @code{equal?} for equality testing.")
 745 #define FUNC_NAME s_scm_hash_ref
 746 {
 747   if (SCM_UNBNDP (dflt))
 748     dflt = SCM_BOOL_F;
 749   return scm_hash_fn_ref (table, key, dflt, scm_ihash, scm_sloppy_assoc, 0);
 750 }
 751 #undef FUNC_NAME
 752
 753
 754
 755 SCM_DEFINE (scm_hash_set_x, "hash-set!", 3, 0, 0,
 756             (SCM table, SCM key, SCM val),
 757             "Find the entry in @var{table} associated with @var{key}, and\n"
 758             "store @var{value} there. Uses @code{equal?} for equality\n"
 759             "testing.")
 760 #define FUNC_NAME s_scm_hash_set_x
 761 {
 762   return scm_hash_fn_set_x (table, key, val, scm_ihash, scm_sloppy_assoc, 0);
 763 }
 764 #undef FUNC_NAME
 765
 766
 767
 768 SCM_DEFINE (scm_hash_remove_x, "hash-remove!", 2, 0, 0,
 769             (SCM table, SCM key),
 770             "Remove @var{key} (and any value associated with it) from\n"
 771             "@var{table}.  Uses @code{equal?} for equality tests.")
 772 #define FUNC_NAME s_scm_hash_remove_x
 773 {
 774   return scm_hash_fn_remove_x (table, key, scm_ihash, scm_sloppy_assoc, 0);
 775 }
 776 #undef FUNC_NAME
 777
 778 \f
 779
 780
 781 typedef struct scm_t_ihashx_closure
 782 {
 783   SCM hash;
 784   SCM assoc;
 785 } scm_t_ihashx_closure;
 786
 787
 788
 789 static unsigned long
 790 scm_ihashx (SCM obj, unsigned long n, scm_t_ihashx_closure *closure)
 791 {
 792   SCM answer = scm_call_2 (closure->hash, obj, scm_from_ulong (n));
 793   return scm_to_ulong (answer);
 794 }
 795
 796
 797
 798 static SCM
 799 scm_sloppy_assx (SCM obj, SCM alist, scm_t_ihashx_closure *closure)
 800 {
 801   return scm_call_2 (closure->assoc, obj, alist);
 802 }
 803
 804
 805 SCM_DEFINE (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0,
 806             (SCM hash, SCM assoc, SCM table, SCM key),
 807             "This behaves the same way as the corresponding\n"
 808             "@code{-get-handle} function, but uses @var{hash} as a hash\n"
 809             "function and @var{assoc} to compare keys.  @code{hash} must be\n"
 810             "a function that takes two arguments, a key to be hashed and a\n"
 811             "table size.  @code{assoc} must be an associator function, like\n"
 812             "@code{assoc}, @code{assq} or @code{assv}.")
 813 #define FUNC_NAME s_scm_hashx_get_handle
 814 {
 815   scm_t_ihashx_closure closure;
 816   closure.hash = hash;
 817   closure.assoc = assoc;
 818   return scm_hash_fn_get_handle (table, key, scm_ihashx, scm_sloppy_assx,
 819                                  (void *) &closure);
 820 }
 821 #undef FUNC_NAME
 822
 823
 824 SCM_DEFINE (scm_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0,
 825             (SCM hash, SCM assoc, SCM table, SCM key, SCM init),
 826             "This behaves the same way as the corresponding\n"
 827             "@code{-create-handle} function, but uses @var{hash} as a hash\n"
 828             "function and @var{assoc} to compare keys.  @code{hash} must be\n"
 829             "a function that takes two arguments, a key to be hashed and a\n"
 830             "table size.  @code{assoc} must be an associator function, like\n"
 831             "@code{assoc}, @code{assq} or @code{assv}.")
 832 #define FUNC_NAME s_scm_hashx_create_handle_x
 833 {
 834   scm_t_ihashx_closure closure;
 835   closure.hash = hash;
 836   closure.assoc = assoc;
 837   return scm_hash_fn_create_handle_x (table, key, init, scm_ihashx,
 838                                       scm_sloppy_assx, (void *)&closure);
 839 }
 840 #undef FUNC_NAME
 841
 842
 843
 844 SCM_DEFINE (scm_hashx_ref, "hashx-ref", 4, 1, 0,
 845             (SCM hash, SCM assoc, SCM table, SCM key, SCM dflt),
 846             "This behaves the same way as the corresponding @code{ref}\n"
 847             "function, but uses @var{hash} as a hash function and\n"
 848             "@var{assoc} to compare keys.  @code{hash} must be a function\n"
 849             "that takes two arguments, a key to be hashed and a table size.\n"
 850             "@code{assoc} must be an associator function, like @code{assoc},\n"
 851             "@code{assq} or @code{assv}.\n"
 852             "\n"
 853             "By way of illustration, @code{hashq-ref table key} is\n"
 854             "equivalent to @code{hashx-ref hashq assq table key}.")
 855 #define FUNC_NAME s_scm_hashx_ref
 856 {
 857   scm_t_ihashx_closure closure;
 858   if (SCM_UNBNDP (dflt))
 859     dflt = SCM_BOOL_F;
 860   closure.hash = hash;
 861   closure.assoc = assoc;
 862   return scm_hash_fn_ref (table, key, dflt, scm_ihashx, scm_sloppy_assx,
 863                           (void *)&closure);
 864 }
 865 #undef FUNC_NAME
 866
 867
 868
 869
 870 SCM_DEFINE (scm_hashx_set_x, "hashx-set!", 5, 0, 0,
 871             (SCM hash, SCM assoc, SCM table, SCM key, SCM val),
 872             "This behaves the same way as the corresponding @code{set!}\n"
 873             "function, but uses @var{hash} as a hash function and\n"
 874             "@var{assoc} to compare keys.  @code{hash} must be a function\n"
 875             "that takes two arguments, a key to be hashed and a table size.\n"
 876             "@code{assoc} must be an associator function, like @code{assoc},\n"
 877             "@code{assq} or @code{assv}.\n"
 878             "\n"
 879             " By way of illustration, @code{hashq-set! table key} is\n"
 880             "equivalent to @code{hashx-set!  hashq assq table key}.")
 881 #define FUNC_NAME s_scm_hashx_set_x
 882 {
 883   scm_t_ihashx_closure closure;
 884   closure.hash = hash;
 885   closure.assoc = assoc;
 886   return scm_hash_fn_set_x (table, key, val, scm_ihashx, scm_sloppy_assx,
 887                             (void *)&closure);
 888 }
 889 #undef FUNC_NAME
 890
 891 SCM_DEFINE (scm_hashx_remove_x, "hashx-remove!", 4, 0, 0,
 892             (SCM hash, SCM assoc, SCM table, SCM obj),
 893             "This behaves the same way as the corresponding @code{remove!}\n"
 894             "function, but uses @var{hash} as a hash function and\n"
 895             "@var{assoc} to compare keys.  @code{hash} must be a function\n"
 896             "that takes two arguments, a key to be hashed and a table size.\n"
 897             "@code{assoc} must be an associator function, like @code{assoc},\n"
 898             "@code{assq} or @code{assv}.\n"
 899             "\n"
 900             " By way of illustration, @code{hashq-remove! table key} is\n"
 901             "equivalent to @code{hashx-remove!  hashq assq #f table key}.")
 902 #define FUNC_NAME s_scm_hashx_remove_x
 903 {
 904   scm_t_ihashx_closure closure;
 905   closure.hash = hash;
 906   closure.assoc = assoc;
 907   return scm_hash_fn_remove_x (table, obj, scm_ihashx, scm_sloppy_assx,
 908                                (void *) &closure);
 909 }
 910 #undef FUNC_NAME
 911
 912 /* Hash table iterators */
 913
 914 SCM_DEFINE (scm_hash_fold, "hash-fold", 3, 0, 0,
 915             (SCM proc, SCM init, SCM table),
 916             "An iterator over hash-table elements.\n"
 917             "Accumulates and returns a result by applying PROC successively.\n"
 918             "The arguments to PROC are \"(key value prior-result)\" where key\n"
 919             "and value are successive pairs from the hash table TABLE, and\n"
 920             "prior-result is either INIT (for the first application of PROC)\n"
 921             "or the return value of the previous application of PROC.\n"
 922             "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
 923             "table into an a-list of key-value pairs.")
 924 #define FUNC_NAME s_scm_hash_fold
 925 {
 926   SCM_VALIDATE_PROC (1, proc);
 927   if (!SCM_HASHTABLE_P (table))
 928     SCM_VALIDATE_VECTOR (3, table);
 929   return scm_internal_hash_fold (scm_call_3, (void *) SCM_UNPACK (proc), init, table);
 930 }
 931 #undef FUNC_NAME
 932
 933 static SCM
 934 for_each_proc (void *proc, SCM handle)
 935 {
 936   return scm_call_2 (SCM_PACK (proc), SCM_CAR (handle), SCM_CDR (handle));
 937 }
 938
 939 SCM_DEFINE (scm_hash_for_each, "hash-for-each", 2, 0, 0,
 940             (SCM proc, SCM table),
 941             "An iterator over hash-table elements.\n"
 942             "Applies PROC successively on all hash table items.\n"
 943             "The arguments to PROC are \"(key value)\" where key\n"
 944             "and value are successive pairs from the hash table TABLE.")
 945 #define FUNC_NAME s_scm_hash_for_each
 946 {
 947   SCM_VALIDATE_PROC (1, proc);
 948   if (!SCM_HASHTABLE_P (table))
 949     SCM_VALIDATE_VECTOR (2, table);
 950
 951   scm_internal_hash_for_each_handle (for_each_proc,
 952                                      (void *) SCM_UNPACK (proc),
 953                                      table);
 954   return SCM_UNSPECIFIED;
 955 }
 956 #undef FUNC_NAME
 957
 958 SCM_DEFINE (scm_hash_for_each_handle, "hash-for-each-handle", 2, 0, 0,
 959             (SCM proc, SCM table),
 960             "An iterator over hash-table elements.\n"
 961             "Applies PROC successively on all hash table handles.")
 962 #define FUNC_NAME s_scm_hash_for_each_handle
 963 {
 964   scm_t_trampoline_1 call = scm_trampoline_1 (proc);
 965   SCM_ASSERT (call, proc, 1, FUNC_NAME);
 966   if (!SCM_HASHTABLE_P (table))
 967     SCM_VALIDATE_VECTOR (2, table);
 968
 969   scm_internal_hash_for_each_handle (call,
 970                                      (void *) SCM_UNPACK (proc),
 971                                      table);
 972   return SCM_UNSPECIFIED;
 973 }
 974 #undef FUNC_NAME
 975
 976 static SCM
 977 map_proc (void *proc, SCM key, SCM data, SCM value)
 978 {
 979   return scm_cons (scm_call_2 (SCM_PACK (proc), key, data), value);
 980 }
 981
 982 SCM_DEFINE (scm_hash_map_to_list, "hash-map->list", 2, 0, 0,
 983             (SCM proc, SCM table),
 984             "An iterator over hash-table elements.\n"
 985             "Accumulates and returns as a list the results of applying PROC successively.\n"
 986             "The arguments to PROC are \"(key value)\" where key\n"
 987             "and value are successive pairs from the hash table TABLE.")
 988 #define FUNC_NAME s_scm_hash_map_to_list
 989 {
 990   SCM_VALIDATE_PROC (1, proc);
 991   if (!SCM_HASHTABLE_P (table))
 992     SCM_VALIDATE_VECTOR (2, table);
 993   return scm_internal_hash_fold (map_proc,
 994                                  (void *) SCM_UNPACK (proc),
 995                                  SCM_EOL,
 996                                  table);
 997 }
 998 #undef FUNC_NAME
 999
1000 \f
1001
1002 SCM
1003 scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table)
1004 {
1005   long i, n;
1006   SCM buckets, result = init;
1007
1008   if (SCM_HASHTABLE_P (table))
1009     buckets = SCM_HASHTABLE_VECTOR (table);
1010   else
1011     buckets = table;
1012
1013   n = SCM_SIMPLE_VECTOR_LENGTH (buckets);
1014   for (i = 0; i < n; ++i)
1015     {
1016       SCM ls = SCM_SIMPLE_VECTOR_REF (buckets, i), handle;
1017       while (!scm_is_null (ls))
1018         {
1019           if (!scm_is_pair (ls))
1020             scm_wrong_type_arg (s_scm_hash_fold, SCM_ARG3, buckets);
1021           handle = SCM_CAR (ls);
1022           if (!scm_is_pair (handle))
1023             scm_wrong_type_arg (s_scm_hash_fold, SCM_ARG3, buckets);
1024           result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result);
1025           ls = SCM_CDR (ls);
1026         }
1027     }
1028
1029   return result;
1030 }
1031
1032 /* The following redundant code is here in order to be able to support
1033    hash-for-each-handle.  An alternative would have been to replace
1034    this code and scm_internal_hash_fold above with a single
1035    scm_internal_hash_fold_handles, but we don't want to promote such
1036    an API. */
1037
1038 void
1039 scm_internal_hash_for_each_handle (SCM (*fn) (), void *closure, SCM table)
1040 {
1041   long i, n;
1042   SCM buckets;
1043
1044   if (SCM_HASHTABLE_P (table))
1045     buckets = SCM_HASHTABLE_VECTOR (table);
1046   else
1047     buckets = table;
1048
1049   n = SCM_SIMPLE_VECTOR_LENGTH (buckets);
1050   for (i = 0; i < n; ++i)
1051     {
1052       SCM ls = SCM_SIMPLE_VECTOR_REF (buckets, i), handle;
1053       while (!scm_is_null (ls))
1054         {
1055           if (!scm_is_pair (ls))
1056             scm_wrong_type_arg (s_scm_hash_for_each, SCM_ARG3, buckets);
1057           handle = SCM_CAR (ls);
1058           if (!scm_is_pair (handle))
1059             scm_wrong_type_arg (s_scm_hash_for_each, SCM_ARG3, buckets);
1060           fn (closure, handle);
1061           ls = SCM_CDR (ls);
1062         }
1063     }
1064 }
1065
1066 \f
1067
1068
1069 void
1070 scm_hashtab_prehistory ()
1071 {
1072   scm_tc16_hashtable = scm_make_smob_type (s_hashtable, 0);
1073   scm_set_smob_mark (scm_tc16_hashtable, scm_markcdr);
1074   scm_set_smob_print (scm_tc16_hashtable, hashtable_print);
1075   scm_set_smob_free (scm_tc16_hashtable, hashtable_free);
1076   scm_c_hook_add (&scm_after_gc_c_hook, rehash_after_gc, 0, 0);
1077 }
1078
1079 void
1080 scm_init_hashtab ()
1081 {
1082 #include "libguile/hashtab.x"
1083 }
1084
1085 /*
1086   Local Variables:
1087   c-file-style: "gnu"
1088   End:
1089 */