428
+ − 1 /* Implementation of the hash table lisp object type.
+ − 2 Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
+ − 3 Copyright (C) 1995, 1996 Ben Wing.
+ − 4 Copyright (C) 1997 Free Software Foundation, Inc.
+ − 5
+ − 6 This file is part of XEmacs.
+ − 7
+ − 8 XEmacs is free software; you can redistribute it and/or modify it
+ − 9 under the terms of the GNU General Public License as published by the
+ − 10 Free Software Foundation; either version 2, or (at your option) any
+ − 11 later version.
+ − 12
+ − 13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
+ − 14 ANY WARRANTY; without even the implied warranty of MERCNTABILITY or
+ − 15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ − 16 for more details.
+ − 17
+ − 18 You should have received a copy of the GNU General Public License
+ − 19 along with XEmacs; see the file COPYING. If not, write to
+ − 20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+ − 21 Boston, MA 02111-1307, USA. */
+ − 22
+ − 23 /* Synched up with: Not in FSF. */
+ − 24
489
+ − 25 /* This file implements the hash table lisp object type.
+ − 26
504
+ − 27 This implementation was mostly written by Martin Buchholz in 1997.
+ − 28
+ − 29 The Lisp-level API (derived from Common Lisp) is almost completely
+ − 30 compatible with GNU Emacs 21, even though the implementations are
+ − 31 totally independent.
+ − 32
489
+ − 33 The hash table technique used is "linear probing". Collisions are
+ − 34 resolved by putting the item in the next empty place in the array
+ − 35 following the collision. Finding a hash entry performs a linear
+ − 36 search in the cluster starting at the hash value.
+ − 37
+ − 38 On deletions from the hash table, the entries immediately following
+ − 39 the deleted entry are re-entered in the hash table. We do not have
+ − 40 a special way to mark deleted entries (known as "tombstones").
+ − 41
+ − 42 At the end of the hash entries ("hentries"), we leave room for an
+ − 43 entry that is always empty (the "sentinel").
+ − 44
+ − 45 The traditional literature on hash table implementation
+ − 46 (e.g. Knuth) suggests that too much "primary clustering" occurs
+ − 47 with linear probing. However, this literature was written when
+ − 48 locality of reference was not a factor. The discrepancy between
+ − 49 CPU speeds and memory speeds is increasing, and the speed of access
+ − 50 to memory is highly dependent on memory caches which work best when
+ − 51 there is high locality of data reference. Random access to memory
+ − 52 is up to 20 times as expensive as access to the nearest address
+ − 53 (and getting worse). So linear probing makes sense.
+ − 54
+ − 55 But the representation doesn't actually matter that much with the
+ − 56 current elisp engine. Funcall is sufficiently slow that the choice
+ − 57 of hash table implementation is noise. */
+ − 58
428
+ − 59 #include <config.h>
+ − 60 #include "lisp.h"
+ − 61 #include "bytecode.h"
+ − 62 #include "elhash.h"
489
+ − 63 #include "opaque.h"
428
+ − 64
+ − 65 Lisp_Object Qhash_tablep;
+ − 66 static Lisp_Object Qhashtable, Qhash_table;
442
+ − 67 static Lisp_Object Qweakness, Qvalue, Qkey_or_value, Qkey_and_value;
428
+ − 68 static Lisp_Object Vall_weak_hash_tables;
+ − 69 static Lisp_Object Qrehash_size, Qrehash_threshold;
+ − 70 static Lisp_Object Q_size, Q_test, Q_weakness, Q_rehash_size, Q_rehash_threshold;
+ − 71
+ − 72 /* obsolete as of 19990901 in xemacs-21.2 */
442
+ − 73 static Lisp_Object Qweak, Qkey_weak, Qvalue_weak, Qkey_or_value_weak;
+ − 74 static Lisp_Object Qnon_weak, Q_type;
428
+ − 75
+ − 76 typedef struct hentry
+ − 77 {
+ − 78 Lisp_Object key;
+ − 79 Lisp_Object value;
+ − 80 } hentry;
+ − 81
+ − 82 struct Lisp_Hash_Table
+ − 83 {
+ − 84 struct lcrecord_header header;
665
+ − 85 Elemcount size;
+ − 86 Elemcount count;
+ − 87 Elemcount rehash_count;
428
+ − 88 double rehash_size;
+ − 89 double rehash_threshold;
665
+ − 90 Elemcount golden_ratio;
428
+ − 91 hash_table_hash_function_t hash_function;
+ − 92 hash_table_test_function_t test_function;
+ − 93 hentry *hentries;
+ − 94 enum hash_table_weakness weakness;
+ − 95 Lisp_Object next_weak; /* Used to chain together all of the weak
+ − 96 hash tables. Don't mark through this. */
+ − 97 };
+ − 98
+ − 99 #define HENTRY_CLEAR_P(hentry) ((*(EMACS_UINT*)(&((hentry)->key))) == 0)
+ − 100 #define CLEAR_HENTRY(hentry) \
+ − 101 ((*(EMACS_UINT*)(&((hentry)->key))) = 0, \
+ − 102 (*(EMACS_UINT*)(&((hentry)->value))) = 0)
+ − 103
+ − 104 #define HASH_TABLE_DEFAULT_SIZE 16
+ − 105 #define HASH_TABLE_DEFAULT_REHASH_SIZE 1.3
+ − 106 #define HASH_TABLE_MIN_SIZE 10
+ − 107
665
+ − 108 #define HASHCODE(key, ht) \
444
+ − 109 ((((ht)->hash_function ? (ht)->hash_function (key) : LISP_HASH (key)) \
+ − 110 * (ht)->golden_ratio) \
+ − 111 % (ht)->size)
428
+ − 112
+ − 113 #define KEYS_EQUAL_P(key1, key2, testfun) \
434
+ − 114 (EQ (key1, key2) || ((testfun) && (testfun) (key1, key2)))
428
+ − 115
+ − 116 #define LINEAR_PROBING_LOOP(probe, entries, size) \
+ − 117 for (; \
+ − 118 !HENTRY_CLEAR_P (probe) || \
+ − 119 (probe == entries + size ? \
+ − 120 (probe = entries, !HENTRY_CLEAR_P (probe)) : 0); \
+ − 121 probe++)
+ − 122
+ − 123 #ifndef ERROR_CHECK_HASH_TABLE
+ − 124 # ifdef ERROR_CHECK_TYPECHECK
+ − 125 # define ERROR_CHECK_HASH_TABLE 1
+ − 126 # else
+ − 127 # define ERROR_CHECK_HASH_TABLE 0
+ − 128 # endif
+ − 129 #endif
+ − 130
+ − 131 #if ERROR_CHECK_HASH_TABLE
+ − 132 static void
+ − 133 check_hash_table_invariants (Lisp_Hash_Table *ht)
+ − 134 {
+ − 135 assert (ht->count < ht->size);
+ − 136 assert (ht->count <= ht->rehash_count);
+ − 137 assert (ht->rehash_count < ht->size);
+ − 138 assert ((double) ht->count * ht->rehash_threshold - 1 <= (double) ht->rehash_count);
+ − 139 assert (HENTRY_CLEAR_P (ht->hentries + ht->size));
+ − 140 }
+ − 141 #else
+ − 142 #define check_hash_table_invariants(ht)
+ − 143 #endif
+ − 144
+ − 145 /* Return a suitable size for a hash table, with at least SIZE slots. */
665
+ − 146 static Elemcount
+ − 147 hash_table_size (Elemcount requested_size)
428
+ − 148 {
+ − 149 /* Return some prime near, but greater than or equal to, SIZE.
+ − 150 Decades from the time of writing, someone will have a system large
+ − 151 enough that the list below will be too short... */
665
+ − 152 static const Elemcount primes [] =
428
+ − 153 {
+ − 154 19, 29, 41, 59, 79, 107, 149, 197, 263, 347, 457, 599, 787, 1031,
+ − 155 1361, 1777, 2333, 3037, 3967, 5167, 6719, 8737, 11369, 14783,
+ − 156 19219, 24989, 32491, 42257, 54941, 71429, 92861, 120721, 156941,
+ − 157 204047, 265271, 344857, 448321, 582821, 757693, 985003, 1280519,
+ − 158 1664681, 2164111, 2813353, 3657361, 4754591, 6180989, 8035301,
+ − 159 10445899, 13579681, 17653589, 22949669, 29834603, 38784989,
+ − 160 50420551, 65546729, 85210757, 110774011, 144006217, 187208107,
+ − 161 243370577, 316381771, 411296309, 534685237, 695090819, 903618083,
647
+ − 162 1174703521, 1527114613, 1985248999 /* , 2580823717UL, 3355070839UL */
428
+ − 163 };
+ − 164 /* We've heard of binary search. */
+ − 165 int low, high;
+ − 166 for (low = 0, high = countof (primes) - 1; high - low > 1;)
+ − 167 {
+ − 168 /* Loop Invariant: size < primes [high] */
+ − 169 int mid = (low + high) / 2;
+ − 170 if (primes [mid] < requested_size)
+ − 171 low = mid;
+ − 172 else
+ − 173 high = mid;
+ − 174 }
+ − 175 return primes [high];
+ − 176 }
+ − 177
+ − 178
+ − 179 #if 0 /* I don't think these are needed any more.
+ − 180 If using the general lisp_object_equal_*() functions
+ − 181 causes efficiency problems, these can be resurrected. --ben */
+ − 182 /* equality and hash functions for Lisp strings */
+ − 183 int
+ − 184 lisp_string_equal (Lisp_Object str1, Lisp_Object str2)
+ − 185 {
+ − 186 /* This is wrong anyway. You can't use strcmp() on Lisp strings,
+ − 187 because they can contain zero characters. */
+ − 188 return !strcmp ((char *) XSTRING_DATA (str1), (char *) XSTRING_DATA (str2));
+ − 189 }
+ − 190
665
+ − 191 static Hashcode
428
+ − 192 lisp_string_hash (Lisp_Object obj)
+ − 193 {
+ − 194 return hash_string (XSTRING_DATA (str), XSTRING_LENGTH (str));
+ − 195 }
+ − 196
+ − 197 #endif /* 0 */
+ − 198
+ − 199 static int
+ − 200 lisp_object_eql_equal (Lisp_Object obj1, Lisp_Object obj2)
+ − 201 {
+ − 202 return EQ (obj1, obj2) || (FLOATP (obj1) && internal_equal (obj1, obj2, 0));
+ − 203 }
+ − 204
665
+ − 205 static Hashcode
428
+ − 206 lisp_object_eql_hash (Lisp_Object obj)
+ − 207 {
+ − 208 return FLOATP (obj) ? internal_hash (obj, 0) : LISP_HASH (obj);
+ − 209 }
+ − 210
+ − 211 static int
+ − 212 lisp_object_equal_equal (Lisp_Object obj1, Lisp_Object obj2)
+ − 213 {
+ − 214 return internal_equal (obj1, obj2, 0);
+ − 215 }
+ − 216
665
+ − 217 static Hashcode
428
+ − 218 lisp_object_equal_hash (Lisp_Object obj)
+ − 219 {
+ − 220 return internal_hash (obj, 0);
+ − 221 }
+ − 222
+ − 223
+ − 224 static Lisp_Object
+ − 225 mark_hash_table (Lisp_Object obj)
+ − 226 {
+ − 227 Lisp_Hash_Table *ht = XHASH_TABLE (obj);
+ − 228
+ − 229 /* If the hash table is weak, we don't want to mark the keys and
+ − 230 values (we scan over them after everything else has been marked,
+ − 231 and mark or remove them as necessary). */
+ − 232 if (ht->weakness == HASH_TABLE_NON_WEAK)
+ − 233 {
+ − 234 hentry *e, *sentinel;
+ − 235
+ − 236 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
+ − 237 if (!HENTRY_CLEAR_P (e))
+ − 238 {
+ − 239 mark_object (e->key);
+ − 240 mark_object (e->value);
+ − 241 }
+ − 242 }
+ − 243 return Qnil;
+ − 244 }
+ − 245
+ − 246 /* Equality of hash tables. Two hash tables are equal when they are of
+ − 247 the same weakness and test function, they have the same number of
+ − 248 elements, and for each key in the hash table, the values are `equal'.
+ − 249
+ − 250 This is similar to Common Lisp `equalp' of hash tables, with the
+ − 251 difference that CL requires the keys to be compared with the test
+ − 252 function, which we don't do. Doing that would require consing, and
+ − 253 consing is a bad idea in `equal'. Anyway, our method should provide
+ − 254 the same result -- if the keys are not equal according to the test
+ − 255 function, then Fgethash() in hash_table_equal_mapper() will fail. */
+ − 256 static int
+ − 257 hash_table_equal (Lisp_Object hash_table1, Lisp_Object hash_table2, int depth)
+ − 258 {
+ − 259 Lisp_Hash_Table *ht1 = XHASH_TABLE (hash_table1);
+ − 260 Lisp_Hash_Table *ht2 = XHASH_TABLE (hash_table2);
+ − 261 hentry *e, *sentinel;
+ − 262
+ − 263 if ((ht1->test_function != ht2->test_function) ||
+ − 264 (ht1->weakness != ht2->weakness) ||
+ − 265 (ht1->count != ht2->count))
+ − 266 return 0;
+ − 267
+ − 268 depth++;
+ − 269
+ − 270 for (e = ht1->hentries, sentinel = e + ht1->size; e < sentinel; e++)
+ − 271 if (!HENTRY_CLEAR_P (e))
+ − 272 /* Look up the key in the other hash table, and compare the values. */
+ − 273 {
+ − 274 Lisp_Object value_in_other = Fgethash (e->key, hash_table2, Qunbound);
+ − 275 if (UNBOUNDP (value_in_other) ||
+ − 276 !internal_equal (e->value, value_in_other, depth))
+ − 277 return 0; /* Give up */
+ − 278 }
+ − 279
+ − 280 return 1;
+ − 281 }
442
+ − 282
+ − 283 /* This is not a great hash function, but it _is_ correct and fast.
+ − 284 Examining all entries is too expensive, and examining a random
+ − 285 subset does not yield a correct hash function. */
665
+ − 286 static Hashcode
442
+ − 287 hash_table_hash (Lisp_Object hash_table, int depth)
+ − 288 {
+ − 289 return XHASH_TABLE (hash_table)->count;
+ − 290 }
+ − 291
428
+ − 292
+ − 293 /* Printing hash tables.
+ − 294
+ − 295 This is non-trivial, because we use a readable structure-style
+ − 296 syntax for hash tables. This means that a typical hash table will be
+ − 297 readably printed in the form of:
+ − 298
+ − 299 #s(hash-table size 2 data (key1 value1 key2 value2))
+ − 300
+ − 301 The supported hash table structure keywords and their values are:
+ − 302 `test' (eql (or nil), eq or equal)
+ − 303 `size' (a natnum or nil)
+ − 304 `rehash-size' (a float)
+ − 305 `rehash-threshold' (a float)
442
+ − 306 `weakness' (nil, key, value, key-and-value, or key-or-value)
428
+ − 307 `data' (a list)
+ − 308
430
+ − 309 If `print-readably' is nil, then a simpler syntax is used, for example
428
+ − 310
+ − 311 #<hash-table size 2/13 data (key1 value1 key2 value2) 0x874d>
+ − 312
+ − 313 The data is truncated to four pairs, and the rest is shown with
+ − 314 `...'. This printer does not cons. */
+ − 315
+ − 316
+ − 317 /* Print the data of the hash table. This maps through a Lisp
+ − 318 hash table and prints key/value pairs using PRINTCHARFUN. */
+ − 319 static void
+ − 320 print_hash_table_data (Lisp_Hash_Table *ht, Lisp_Object printcharfun)
+ − 321 {
+ − 322 int count = 0;
+ − 323 hentry *e, *sentinel;
+ − 324
+ − 325 write_c_string (" data (", printcharfun);
+ − 326
+ − 327 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
+ − 328 if (!HENTRY_CLEAR_P (e))
+ − 329 {
+ − 330 if (count > 0)
+ − 331 write_c_string (" ", printcharfun);
+ − 332 if (!print_readably && count > 3)
+ − 333 {
+ − 334 write_c_string ("...", printcharfun);
+ − 335 break;
+ − 336 }
+ − 337 print_internal (e->key, printcharfun, 1);
+ − 338 write_c_string (" ", printcharfun);
+ − 339 print_internal (e->value, printcharfun, 1);
+ − 340 count++;
+ − 341 }
+ − 342
+ − 343 write_c_string (")", printcharfun);
+ − 344 }
+ − 345
+ − 346 static void
+ − 347 print_hash_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
+ − 348 {
+ − 349 Lisp_Hash_Table *ht = XHASH_TABLE (obj);
+ − 350 char buf[128];
+ − 351
+ − 352 write_c_string (print_readably ? "#s(hash-table" : "#<hash-table",
+ − 353 printcharfun);
+ − 354
+ − 355 /* These checks have a kludgy look to them, but they are safe.
+ − 356 Due to nature of hashing, you cannot use arbitrary
+ − 357 test functions anyway. */
+ − 358 if (!ht->test_function)
+ − 359 write_c_string (" test eq", printcharfun);
+ − 360 else if (ht->test_function == lisp_object_equal_equal)
+ − 361 write_c_string (" test equal", printcharfun);
+ − 362 else if (ht->test_function == lisp_object_eql_equal)
+ − 363 DO_NOTHING;
+ − 364 else
+ − 365 abort ();
+ − 366
+ − 367 if (ht->count || !print_readably)
+ − 368 {
+ − 369 if (print_readably)
647
+ − 370 sprintf (buf, " size %ld", (long) ht->count);
428
+ − 371 else
647
+ − 372 sprintf (buf, " size %ld/%ld", (long) ht->count, (long) ht->size);
428
+ − 373 write_c_string (buf, printcharfun);
+ − 374 }
+ − 375
+ − 376 if (ht->weakness != HASH_TABLE_NON_WEAK)
+ − 377 {
+ − 378 sprintf (buf, " weakness %s",
442
+ − 379 (ht->weakness == HASH_TABLE_WEAK ? "key-and-value" :
+ − 380 ht->weakness == HASH_TABLE_KEY_WEAK ? "key" :
+ − 381 ht->weakness == HASH_TABLE_VALUE_WEAK ? "value" :
+ − 382 ht->weakness == HASH_TABLE_KEY_VALUE_WEAK ? "key-or-value" :
428
+ − 383 "you-d-better-not-see-this"));
+ − 384 write_c_string (buf, printcharfun);
+ − 385 }
+ − 386
+ − 387 if (ht->count)
+ − 388 print_hash_table_data (ht, printcharfun);
+ − 389
+ − 390 if (print_readably)
+ − 391 write_c_string (")", printcharfun);
+ − 392 else
+ − 393 {
+ − 394 sprintf (buf, " 0x%x>", ht->header.uid);
+ − 395 write_c_string (buf, printcharfun);
+ − 396 }
+ − 397 }
+ − 398
+ − 399 static void
489
+ − 400 free_hentries (hentry *hentries, size_t size)
+ − 401 {
+ − 402 #if ERROR_CHECK_HASH_TABLE
+ − 403 /* Ensure a crash if other code uses the discarded entries afterwards. */
+ − 404 hentry *e, *sentinel;
+ − 405
+ − 406 for (e = hentries, sentinel = e + size; e < sentinel; e++)
+ − 407 * (unsigned long *) e = 0xdeadbeef;
+ − 408 #endif
+ − 409
+ − 410 if (!DUMPEDP (hentries))
+ − 411 xfree (hentries);
+ − 412 }
+ − 413
+ − 414 static void
428
+ − 415 finalize_hash_table (void *header, int for_disksave)
+ − 416 {
+ − 417 if (!for_disksave)
+ − 418 {
+ − 419 Lisp_Hash_Table *ht = (Lisp_Hash_Table *) header;
489
+ − 420 free_hentries (ht->hentries, ht->size);
428
+ − 421 ht->hentries = 0;
+ − 422 }
+ − 423 }
+ − 424
+ − 425 static const struct lrecord_description hentry_description_1[] = {
440
+ − 426 { XD_LISP_OBJECT, offsetof (hentry, key) },
+ − 427 { XD_LISP_OBJECT, offsetof (hentry, value) },
428
+ − 428 { XD_END }
+ − 429 };
+ − 430
+ − 431 static const struct struct_description hentry_description = {
440
+ − 432 sizeof (hentry),
428
+ − 433 hentry_description_1
+ − 434 };
+ − 435
+ − 436 const struct lrecord_description hash_table_description[] = {
665
+ − 437 { XD_ELEMCOUNT, offsetof (Lisp_Hash_Table, size) },
440
+ − 438 { XD_STRUCT_PTR, offsetof (Lisp_Hash_Table, hentries), XD_INDIRECT(0, 1), &hentry_description },
+ − 439 { XD_LO_LINK, offsetof (Lisp_Hash_Table, next_weak) },
428
+ − 440 { XD_END }
+ − 441 };
+ − 442
+ − 443 DEFINE_LRECORD_IMPLEMENTATION ("hash-table", hash_table,
+ − 444 mark_hash_table, print_hash_table,
+ − 445 finalize_hash_table,
442
+ − 446 hash_table_equal, hash_table_hash,
428
+ − 447 hash_table_description,
+ − 448 Lisp_Hash_Table);
+ − 449
+ − 450 static Lisp_Hash_Table *
+ − 451 xhash_table (Lisp_Object hash_table)
+ − 452 {
+ − 453 if (!gc_in_progress)
+ − 454 CHECK_HASH_TABLE (hash_table);
+ − 455 check_hash_table_invariants (XHASH_TABLE (hash_table));
+ − 456 return XHASH_TABLE (hash_table);
+ − 457 }
+ − 458
+ − 459
+ − 460 /************************************************************************/
+ − 461 /* Creation of Hash Tables */
+ − 462 /************************************************************************/
+ − 463
+ − 464 /* Creation of hash tables, without error-checking. */
+ − 465 static void
+ − 466 compute_hash_table_derived_values (Lisp_Hash_Table *ht)
+ − 467 {
665
+ − 468 ht->rehash_count = (Elemcount)
438
+ − 469 ((double) ht->size * ht->rehash_threshold);
665
+ − 470 ht->golden_ratio = (Elemcount)
428
+ − 471 ((double) ht->size * (.6180339887 / (double) sizeof (Lisp_Object)));
+ − 472 }
+ − 473
+ − 474 Lisp_Object
450
+ − 475 make_standard_lisp_hash_table (enum hash_table_test test,
665
+ − 476 Elemcount size,
450
+ − 477 double rehash_size,
+ − 478 double rehash_threshold,
+ − 479 enum hash_table_weakness weakness)
+ − 480 {
462
+ − 481 hash_table_hash_function_t hash_function = 0;
450
+ − 482 hash_table_test_function_t test_function = 0;
+ − 483
+ − 484 switch (test)
+ − 485 {
+ − 486 case HASH_TABLE_EQ:
+ − 487 test_function = 0;
+ − 488 hash_function = 0;
+ − 489 break;
+ − 490
+ − 491 case HASH_TABLE_EQL:
+ − 492 test_function = lisp_object_eql_equal;
+ − 493 hash_function = lisp_object_eql_hash;
+ − 494 break;
+ − 495
+ − 496 case HASH_TABLE_EQUAL:
+ − 497 test_function = lisp_object_equal_equal;
+ − 498 hash_function = lisp_object_equal_hash;
+ − 499 break;
+ − 500
+ − 501 default:
+ − 502 abort ();
+ − 503 }
+ − 504
+ − 505 return make_general_lisp_hash_table (hash_function, test_function,
+ − 506 size, rehash_size, rehash_threshold,
+ − 507 weakness);
+ − 508 }
+ − 509
+ − 510 Lisp_Object
+ − 511 make_general_lisp_hash_table (hash_table_hash_function_t hash_function,
+ − 512 hash_table_test_function_t test_function,
665
+ − 513 Elemcount size,
428
+ − 514 double rehash_size,
+ − 515 double rehash_threshold,
+ − 516 enum hash_table_weakness weakness)
+ − 517 {
+ − 518 Lisp_Object hash_table;
+ − 519 Lisp_Hash_Table *ht = alloc_lcrecord_type (Lisp_Hash_Table, &lrecord_hash_table);
+ − 520
450
+ − 521 ht->test_function = test_function;
+ − 522 ht->hash_function = hash_function;
438
+ − 523 ht->weakness = weakness;
+ − 524
+ − 525 ht->rehash_size =
+ − 526 rehash_size > 1.0 ? rehash_size : HASH_TABLE_DEFAULT_REHASH_SIZE;
+ − 527
+ − 528 ht->rehash_threshold =
+ − 529 rehash_threshold > 0.0 ? rehash_threshold :
+ − 530 size > 4096 && !ht->test_function ? 0.7 : 0.6;
+ − 531
428
+ − 532 if (size < HASH_TABLE_MIN_SIZE)
+ − 533 size = HASH_TABLE_MIN_SIZE;
665
+ − 534 ht->size = hash_table_size ((Elemcount) (((double) size / ht->rehash_threshold)
438
+ − 535 + 1.0));
428
+ − 536 ht->count = 0;
438
+ − 537
428
+ − 538 compute_hash_table_derived_values (ht);
+ − 539
+ − 540 /* We leave room for one never-occupied sentinel hentry at the end. */
458
+ − 541 ht->hentries = xnew_array_and_zero (hentry, ht->size + 1);
428
+ − 542
+ − 543 XSETHASH_TABLE (hash_table, ht);
+ − 544
+ − 545 if (weakness == HASH_TABLE_NON_WEAK)
+ − 546 ht->next_weak = Qunbound;
+ − 547 else
+ − 548 ht->next_weak = Vall_weak_hash_tables, Vall_weak_hash_tables = hash_table;
+ − 549
+ − 550 return hash_table;
+ − 551 }
+ − 552
+ − 553 Lisp_Object
665
+ − 554 make_lisp_hash_table (Elemcount size,
428
+ − 555 enum hash_table_weakness weakness,
+ − 556 enum hash_table_test test)
+ − 557 {
450
+ − 558 return make_standard_lisp_hash_table (test, size, -1.0, -1.0, weakness);
428
+ − 559 }
+ − 560
+ − 561 /* Pretty reading of hash tables.
+ − 562
+ − 563 Here we use the existing structures mechanism (which is,
+ − 564 unfortunately, pretty cumbersome) for validating and instantiating
+ − 565 the hash tables. The idea is that the side-effect of reading a
+ − 566 #s(hash-table PLIST) object is creation of a hash table with desired
+ − 567 properties, and that the hash table is returned. */
+ − 568
+ − 569 /* Validation functions: each keyword provides its own validation
+ − 570 function. The errors should maybe be continuable, but it is
+ − 571 unclear how this would cope with ERRB. */
+ − 572 static int
+ − 573 hash_table_size_validate (Lisp_Object keyword, Lisp_Object value,
578
+ − 574 Error_Behavior errb)
428
+ − 575 {
+ − 576 if (NATNUMP (value))
+ − 577 return 1;
+ − 578
563
+ − 579 maybe_signal_error_1 (Qwrong_type_argument, list2 (Qnatnump, value),
428
+ − 580 Qhash_table, errb);
+ − 581 return 0;
+ − 582 }
+ − 583
665
+ − 584 static Elemcount
428
+ − 585 decode_hash_table_size (Lisp_Object obj)
+ − 586 {
+ − 587 return NILP (obj) ? HASH_TABLE_DEFAULT_SIZE : XINT (obj);
+ − 588 }
+ − 589
+ − 590 static int
+ − 591 hash_table_weakness_validate (Lisp_Object keyword, Lisp_Object value,
578
+ − 592 Error_Behavior errb)
428
+ − 593 {
442
+ − 594 if (EQ (value, Qnil)) return 1;
+ − 595 if (EQ (value, Qt)) return 1;
+ − 596 if (EQ (value, Qkey)) return 1;
+ − 597 if (EQ (value, Qkey_and_value)) return 1;
+ − 598 if (EQ (value, Qkey_or_value)) return 1;
+ − 599 if (EQ (value, Qvalue)) return 1;
428
+ − 600
+ − 601 /* Following values are obsolete as of 19990901 in xemacs-21.2 */
442
+ − 602 if (EQ (value, Qnon_weak)) return 1;
+ − 603 if (EQ (value, Qweak)) return 1;
+ − 604 if (EQ (value, Qkey_weak)) return 1;
+ − 605 if (EQ (value, Qkey_or_value_weak)) return 1;
+ − 606 if (EQ (value, Qvalue_weak)) return 1;
428
+ − 607
563
+ − 608 maybe_invalid_constant ("Invalid hash table weakness",
428
+ − 609 value, Qhash_table, errb);
+ − 610 return 0;
+ − 611 }
+ − 612
+ − 613 static enum hash_table_weakness
+ − 614 decode_hash_table_weakness (Lisp_Object obj)
+ − 615 {
442
+ − 616 if (EQ (obj, Qnil)) return HASH_TABLE_NON_WEAK;
+ − 617 if (EQ (obj, Qt)) return HASH_TABLE_WEAK;
+ − 618 if (EQ (obj, Qkey_and_value)) return HASH_TABLE_WEAK;
+ − 619 if (EQ (obj, Qkey)) return HASH_TABLE_KEY_WEAK;
+ − 620 if (EQ (obj, Qkey_or_value)) return HASH_TABLE_KEY_VALUE_WEAK;
+ − 621 if (EQ (obj, Qvalue)) return HASH_TABLE_VALUE_WEAK;
428
+ − 622
+ − 623 /* Following values are obsolete as of 19990901 in xemacs-21.2 */
442
+ − 624 if (EQ (obj, Qnon_weak)) return HASH_TABLE_NON_WEAK;
+ − 625 if (EQ (obj, Qweak)) return HASH_TABLE_WEAK;
+ − 626 if (EQ (obj, Qkey_weak)) return HASH_TABLE_KEY_WEAK;
+ − 627 if (EQ (obj, Qkey_or_value_weak)) return HASH_TABLE_KEY_VALUE_WEAK;
+ − 628 if (EQ (obj, Qvalue_weak)) return HASH_TABLE_VALUE_WEAK;
428
+ − 629
563
+ − 630 invalid_constant ("Invalid hash table weakness", obj);
428
+ − 631 return HASH_TABLE_NON_WEAK; /* not reached */
+ − 632 }
+ − 633
+ − 634 static int
+ − 635 hash_table_test_validate (Lisp_Object keyword, Lisp_Object value,
578
+ − 636 Error_Behavior errb)
428
+ − 637 {
+ − 638 if (EQ (value, Qnil)) return 1;
+ − 639 if (EQ (value, Qeq)) return 1;
+ − 640 if (EQ (value, Qequal)) return 1;
+ − 641 if (EQ (value, Qeql)) return 1;
+ − 642
563
+ − 643 maybe_invalid_constant ("Invalid hash table test",
428
+ − 644 value, Qhash_table, errb);
+ − 645 return 0;
+ − 646 }
+ − 647
+ − 648 static enum hash_table_test
+ − 649 decode_hash_table_test (Lisp_Object obj)
+ − 650 {
+ − 651 if (EQ (obj, Qnil)) return HASH_TABLE_EQL;
+ − 652 if (EQ (obj, Qeq)) return HASH_TABLE_EQ;
+ − 653 if (EQ (obj, Qequal)) return HASH_TABLE_EQUAL;
+ − 654 if (EQ (obj, Qeql)) return HASH_TABLE_EQL;
+ − 655
563
+ − 656 invalid_constant ("Invalid hash table test", obj);
428
+ − 657 return HASH_TABLE_EQ; /* not reached */
+ − 658 }
+ − 659
+ − 660 static int
+ − 661 hash_table_rehash_size_validate (Lisp_Object keyword, Lisp_Object value,
578
+ − 662 Error_Behavior errb)
428
+ − 663 {
+ − 664 if (!FLOATP (value))
+ − 665 {
563
+ − 666 maybe_signal_error_1 (Qwrong_type_argument, list2 (Qfloatp, value),
428
+ − 667 Qhash_table, errb);
+ − 668 return 0;
+ − 669 }
+ − 670
+ − 671 {
+ − 672 double rehash_size = XFLOAT_DATA (value);
+ − 673 if (rehash_size <= 1.0)
+ − 674 {
563
+ − 675 maybe_invalid_argument
428
+ − 676 ("Hash table rehash size must be greater than 1.0",
+ − 677 value, Qhash_table, errb);
+ − 678 return 0;
+ − 679 }
+ − 680 }
+ − 681
+ − 682 return 1;
+ − 683 }
+ − 684
+ − 685 static double
+ − 686 decode_hash_table_rehash_size (Lisp_Object rehash_size)
+ − 687 {
+ − 688 return NILP (rehash_size) ? -1.0 : XFLOAT_DATA (rehash_size);
+ − 689 }
+ − 690
+ − 691 static int
+ − 692 hash_table_rehash_threshold_validate (Lisp_Object keyword, Lisp_Object value,
578
+ − 693 Error_Behavior errb)
428
+ − 694 {
+ − 695 if (!FLOATP (value))
+ − 696 {
563
+ − 697 maybe_signal_error_1 (Qwrong_type_argument, list2 (Qfloatp, value),
428
+ − 698 Qhash_table, errb);
+ − 699 return 0;
+ − 700 }
+ − 701
+ − 702 {
+ − 703 double rehash_threshold = XFLOAT_DATA (value);
+ − 704 if (rehash_threshold <= 0.0 || rehash_threshold >= 1.0)
+ − 705 {
563
+ − 706 maybe_invalid_argument
428
+ − 707 ("Hash table rehash threshold must be between 0.0 and 1.0",
+ − 708 value, Qhash_table, errb);
+ − 709 return 0;
+ − 710 }
+ − 711 }
+ − 712
+ − 713 return 1;
+ − 714 }
+ − 715
+ − 716 static double
+ − 717 decode_hash_table_rehash_threshold (Lisp_Object rehash_threshold)
+ − 718 {
+ − 719 return NILP (rehash_threshold) ? -1.0 : XFLOAT_DATA (rehash_threshold);
+ − 720 }
+ − 721
+ − 722 static int
+ − 723 hash_table_data_validate (Lisp_Object keyword, Lisp_Object value,
578
+ − 724 Error_Behavior errb)
428
+ − 725 {
+ − 726 int len;
+ − 727
+ − 728 GET_EXTERNAL_LIST_LENGTH (value, len);
+ − 729
+ − 730 if (len & 1)
+ − 731 {
563
+ − 732 maybe_sferror
428
+ − 733 ("Hash table data must have alternating key/value pairs",
+ − 734 value, Qhash_table, errb);
+ − 735 return 0;
+ − 736 }
+ − 737 return 1;
+ − 738 }
+ − 739
+ − 740 /* The actual instantiation of a hash table. This does practically no
+ − 741 error checking, because it relies on the fact that the paranoid
+ − 742 functions above have error-checked everything to the last details.
+ − 743 If this assumption is wrong, we will get a crash immediately (with
+ − 744 error-checking compiled in), and we'll know if there is a bug in
+ − 745 the structure mechanism. So there. */
+ − 746 static Lisp_Object
+ − 747 hash_table_instantiate (Lisp_Object plist)
+ − 748 {
+ − 749 Lisp_Object hash_table;
+ − 750 Lisp_Object test = Qnil;
+ − 751 Lisp_Object size = Qnil;
+ − 752 Lisp_Object rehash_size = Qnil;
+ − 753 Lisp_Object rehash_threshold = Qnil;
+ − 754 Lisp_Object weakness = Qnil;
+ − 755 Lisp_Object data = Qnil;
+ − 756
+ − 757 while (!NILP (plist))
+ − 758 {
+ − 759 Lisp_Object key, value;
+ − 760 key = XCAR (plist); plist = XCDR (plist);
+ − 761 value = XCAR (plist); plist = XCDR (plist);
+ − 762
+ − 763 if (EQ (key, Qtest)) test = value;
+ − 764 else if (EQ (key, Qsize)) size = value;
+ − 765 else if (EQ (key, Qrehash_size)) rehash_size = value;
+ − 766 else if (EQ (key, Qrehash_threshold)) rehash_threshold = value;
+ − 767 else if (EQ (key, Qweakness)) weakness = value;
+ − 768 else if (EQ (key, Qdata)) data = value;
+ − 769 else if (EQ (key, Qtype))/*obsolete*/ weakness = value;
+ − 770 else
+ − 771 abort ();
+ − 772 }
+ − 773
+ − 774 /* Create the hash table. */
450
+ − 775 hash_table = make_standard_lisp_hash_table
428
+ − 776 (decode_hash_table_test (test),
+ − 777 decode_hash_table_size (size),
+ − 778 decode_hash_table_rehash_size (rehash_size),
+ − 779 decode_hash_table_rehash_threshold (rehash_threshold),
+ − 780 decode_hash_table_weakness (weakness));
+ − 781
+ − 782 /* I'm not sure whether this can GC, but better safe than sorry. */
+ − 783 {
+ − 784 struct gcpro gcpro1;
+ − 785 GCPRO1 (hash_table);
+ − 786
+ − 787 /* And fill it with data. */
+ − 788 while (!NILP (data))
+ − 789 {
+ − 790 Lisp_Object key, value;
+ − 791 key = XCAR (data); data = XCDR (data);
+ − 792 value = XCAR (data); data = XCDR (data);
+ − 793 Fputhash (key, value, hash_table);
+ − 794 }
+ − 795 UNGCPRO;
+ − 796 }
+ − 797
+ − 798 return hash_table;
+ − 799 }
+ − 800
+ − 801 static void
+ − 802 structure_type_create_hash_table_structure_name (Lisp_Object structure_name)
+ − 803 {
+ − 804 struct structure_type *st;
+ − 805
+ − 806 st = define_structure_type (structure_name, 0, hash_table_instantiate);
+ − 807 define_structure_type_keyword (st, Qtest, hash_table_test_validate);
+ − 808 define_structure_type_keyword (st, Qsize, hash_table_size_validate);
+ − 809 define_structure_type_keyword (st, Qrehash_size, hash_table_rehash_size_validate);
+ − 810 define_structure_type_keyword (st, Qrehash_threshold, hash_table_rehash_threshold_validate);
+ − 811 define_structure_type_keyword (st, Qweakness, hash_table_weakness_validate);
+ − 812 define_structure_type_keyword (st, Qdata, hash_table_data_validate);
+ − 813
+ − 814 /* obsolete as of 19990901 in xemacs-21.2 */
+ − 815 define_structure_type_keyword (st, Qtype, hash_table_weakness_validate);
+ − 816 }
+ − 817
+ − 818 /* Create a built-in Lisp structure type named `hash-table'.
+ − 819 We make #s(hashtable ...) equivalent to #s(hash-table ...),
+ − 820 for backward compatibility.
+ − 821 This is called from emacs.c. */
+ − 822 void
+ − 823 structure_type_create_hash_table (void)
+ − 824 {
+ − 825 structure_type_create_hash_table_structure_name (Qhash_table);
+ − 826 structure_type_create_hash_table_structure_name (Qhashtable); /* compat */
+ − 827 }
+ − 828
+ − 829
+ − 830 /************************************************************************/
+ − 831 /* Definition of Lisp-visible methods */
+ − 832 /************************************************************************/
+ − 833
+ − 834 DEFUN ("hash-table-p", Fhash_table_p, 1, 1, 0, /*
+ − 835 Return t if OBJECT is a hash table, else nil.
+ − 836 */
+ − 837 (object))
+ − 838 {
+ − 839 return HASH_TABLEP (object) ? Qt : Qnil;
+ − 840 }
+ − 841
+ − 842 DEFUN ("make-hash-table", Fmake_hash_table, 0, MANY, 0, /*
+ − 843 Return a new empty hash table object.
+ − 844 Use Common Lisp style keywords to specify hash table properties.
+ − 845 (make-hash-table &key test size rehash-size rehash-threshold weakness)
+ − 846
+ − 847 Keyword :test can be `eq', `eql' (default) or `equal'.
+ − 848 Comparison between keys is done using this function.
+ − 849 If speed is important, consider using `eq'.
+ − 850 When storing strings in the hash table, you will likely need to use `equal'.
+ − 851
+ − 852 Keyword :size specifies the number of keys likely to be inserted.
+ − 853 This number of entries can be inserted without enlarging the hash table.
+ − 854
+ − 855 Keyword :rehash-size must be a float greater than 1.0, and specifies
+ − 856 the factor by which to increase the size of the hash table when enlarging.
+ − 857
+ − 858 Keyword :rehash-threshold must be a float between 0.0 and 1.0,
+ − 859 and specifies the load factor of the hash table which triggers enlarging.
+ − 860
442
+ − 861 Non-standard keyword :weakness can be `nil' (default), `t', `key-and-value',
+ − 862 `key', `value' or `key-or-value'. `t' is an alias for `key-and-value'.
428
+ − 863
442
+ − 864 A key-and-value-weak hash table, also known as a fully-weak or simply
+ − 865 as a weak hash table, is one whose pointers do not count as GC
+ − 866 referents: for any key-value pair in the hash table, if the only
+ − 867 remaining pointer to either the key or the value is in a weak hash
+ − 868 table, then the pair will be removed from the hash table, and the key
+ − 869 and value collected. A non-weak hash table (or any other pointer)
+ − 870 would prevent the object from being collected.
428
+ − 871
+ − 872 A key-weak hash table is similar to a fully-weak hash table except that
+ − 873 a key-value pair will be removed only if the key remains unmarked
+ − 874 outside of weak hash tables. The pair will remain in the hash table if
+ − 875 the key is pointed to by something other than a weak hash table, even
+ − 876 if the value is not.
+ − 877
+ − 878 A value-weak hash table is similar to a fully-weak hash table except
+ − 879 that a key-value pair will be removed only if the value remains
+ − 880 unmarked outside of weak hash tables. The pair will remain in the
+ − 881 hash table if the value is pointed to by something other than a weak
+ − 882 hash table, even if the key is not.
442
+ − 883
+ − 884 A key-or-value-weak hash table is similar to a fully-weak hash table except
+ − 885 that a key-value pair will be removed only if the value and the key remain
+ − 886 unmarked outside of weak hash tables. The pair will remain in the
+ − 887 hash table if the value or key are pointed to by something other than a weak
+ − 888 hash table, even if the other is not.
428
+ − 889 */
+ − 890 (int nargs, Lisp_Object *args))
+ − 891 {
+ − 892 int i = 0;
+ − 893 Lisp_Object test = Qnil;
+ − 894 Lisp_Object size = Qnil;
+ − 895 Lisp_Object rehash_size = Qnil;
+ − 896 Lisp_Object rehash_threshold = Qnil;
+ − 897 Lisp_Object weakness = Qnil;
+ − 898
+ − 899 while (i + 1 < nargs)
+ − 900 {
+ − 901 Lisp_Object keyword = args[i++];
+ − 902 Lisp_Object value = args[i++];
+ − 903
+ − 904 if (EQ (keyword, Q_test)) test = value;
+ − 905 else if (EQ (keyword, Q_size)) size = value;
+ − 906 else if (EQ (keyword, Q_rehash_size)) rehash_size = value;
+ − 907 else if (EQ (keyword, Q_rehash_threshold)) rehash_threshold = value;
+ − 908 else if (EQ (keyword, Q_weakness)) weakness = value;
+ − 909 else if (EQ (keyword, Q_type))/*obsolete*/ weakness = value;
563
+ − 910 else invalid_constant ("Invalid hash table property keyword", keyword);
428
+ − 911 }
+ − 912
+ − 913 if (i < nargs)
563
+ − 914 sferror ("Hash table property requires a value", args[i]);
428
+ − 915
+ − 916 #define VALIDATE_VAR(var) \
+ − 917 if (!NILP (var)) hash_table_##var##_validate (Q##var, var, ERROR_ME);
+ − 918
+ − 919 VALIDATE_VAR (test);
+ − 920 VALIDATE_VAR (size);
+ − 921 VALIDATE_VAR (rehash_size);
+ − 922 VALIDATE_VAR (rehash_threshold);
+ − 923 VALIDATE_VAR (weakness);
+ − 924
450
+ − 925 return make_standard_lisp_hash_table
428
+ − 926 (decode_hash_table_test (test),
+ − 927 decode_hash_table_size (size),
+ − 928 decode_hash_table_rehash_size (rehash_size),
+ − 929 decode_hash_table_rehash_threshold (rehash_threshold),
+ − 930 decode_hash_table_weakness (weakness));
+ − 931 }
+ − 932
+ − 933 DEFUN ("copy-hash-table", Fcopy_hash_table, 1, 1, 0, /*
+ − 934 Return a new hash table containing the same keys and values as HASH-TABLE.
+ − 935 The keys and values will not themselves be copied.
+ − 936 */
+ − 937 (hash_table))
+ − 938 {
442
+ − 939 const Lisp_Hash_Table *ht_old = xhash_table (hash_table);
428
+ − 940 Lisp_Hash_Table *ht = alloc_lcrecord_type (Lisp_Hash_Table, &lrecord_hash_table);
+ − 941
+ − 942 copy_lcrecord (ht, ht_old);
+ − 943
+ − 944 ht->hentries = xnew_array (hentry, ht_old->size + 1);
+ − 945 memcpy (ht->hentries, ht_old->hentries, (ht_old->size + 1) * sizeof (hentry));
+ − 946
+ − 947 XSETHASH_TABLE (hash_table, ht);
+ − 948
+ − 949 if (! EQ (ht->next_weak, Qunbound))
+ − 950 {
+ − 951 ht->next_weak = Vall_weak_hash_tables;
+ − 952 Vall_weak_hash_tables = hash_table;
+ − 953 }
+ − 954
+ − 955 return hash_table;
+ − 956 }
+ − 957
+ − 958 static void
665
+ − 959 resize_hash_table (Lisp_Hash_Table *ht, Elemcount new_size)
428
+ − 960 {
440
+ − 961 hentry *old_entries, *new_entries, *sentinel, *e;
665
+ − 962 Elemcount old_size;
428
+ − 963
+ − 964 old_size = ht->size;
+ − 965 ht->size = new_size;
+ − 966
+ − 967 old_entries = ht->hentries;
+ − 968
440
+ − 969 ht->hentries = xnew_array_and_zero (hentry, new_size + 1);
428
+ − 970 new_entries = ht->hentries;
+ − 971
+ − 972 compute_hash_table_derived_values (ht);
+ − 973
440
+ − 974 for (e = old_entries, sentinel = e + old_size; e < sentinel; e++)
428
+ − 975 if (!HENTRY_CLEAR_P (e))
+ − 976 {
665
+ − 977 hentry *probe = new_entries + HASHCODE (e->key, ht);
428
+ − 978 LINEAR_PROBING_LOOP (probe, new_entries, new_size)
+ − 979 ;
+ − 980 *probe = *e;
+ − 981 }
+ − 982
489
+ − 983 free_hentries (old_entries, old_size);
428
+ − 984 }
+ − 985
440
+ − 986 /* After a hash table has been saved to disk and later restored by the
+ − 987 portable dumper, it contains the same objects, but their addresses
665
+ − 988 and thus their HASHCODEs have changed. */
428
+ − 989 void
440
+ − 990 pdump_reorganize_hash_table (Lisp_Object hash_table)
428
+ − 991 {
442
+ − 992 const Lisp_Hash_Table *ht = xhash_table (hash_table);
440
+ − 993 hentry *new_entries = xnew_array_and_zero (hentry, ht->size + 1);
+ − 994 hentry *e, *sentinel;
+ − 995
+ − 996 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
+ − 997 if (!HENTRY_CLEAR_P (e))
+ − 998 {
665
+ − 999 hentry *probe = new_entries + HASHCODE (e->key, ht);
440
+ − 1000 LINEAR_PROBING_LOOP (probe, new_entries, ht->size)
+ − 1001 ;
+ − 1002 *probe = *e;
+ − 1003 }
+ − 1004
+ − 1005 memcpy (ht->hentries, new_entries, ht->size * sizeof (hentry));
+ − 1006
+ − 1007 xfree (new_entries);
428
+ − 1008 }
+ − 1009
+ − 1010 static void
+ − 1011 enlarge_hash_table (Lisp_Hash_Table *ht)
+ − 1012 {
665
+ − 1013 Elemcount new_size =
+ − 1014 hash_table_size ((Elemcount) ((double) ht->size * ht->rehash_size));
428
+ − 1015 resize_hash_table (ht, new_size);
+ − 1016 }
+ − 1017
+ − 1018 static hentry *
442
+ − 1019 find_hentry (Lisp_Object key, const Lisp_Hash_Table *ht)
428
+ − 1020 {
+ − 1021 hash_table_test_function_t test_function = ht->test_function;
+ − 1022 hentry *entries = ht->hentries;
665
+ − 1023 hentry *probe = entries + HASHCODE (key, ht);
428
+ − 1024
+ − 1025 LINEAR_PROBING_LOOP (probe, entries, ht->size)
+ − 1026 if (KEYS_EQUAL_P (probe->key, key, test_function))
+ − 1027 break;
+ − 1028
+ − 1029 return probe;
+ − 1030 }
+ − 1031
+ − 1032 DEFUN ("gethash", Fgethash, 2, 3, 0, /*
+ − 1033 Find hash value for KEY in HASH-TABLE.
+ − 1034 If there is no corresponding value, return DEFAULT (which defaults to nil).
+ − 1035 */
+ − 1036 (key, hash_table, default_))
+ − 1037 {
442
+ − 1038 const Lisp_Hash_Table *ht = xhash_table (hash_table);
428
+ − 1039 hentry *e = find_hentry (key, ht);
+ − 1040
+ − 1041 return HENTRY_CLEAR_P (e) ? default_ : e->value;
+ − 1042 }
+ − 1043
+ − 1044 DEFUN ("puthash", Fputhash, 3, 3, 0, /*
+ − 1045 Hash KEY to VALUE in HASH-TABLE.
+ − 1046 */
+ − 1047 (key, value, hash_table))
+ − 1048 {
+ − 1049 Lisp_Hash_Table *ht = xhash_table (hash_table);
+ − 1050 hentry *e = find_hentry (key, ht);
+ − 1051
+ − 1052 if (!HENTRY_CLEAR_P (e))
+ − 1053 return e->value = value;
+ − 1054
+ − 1055 e->key = key;
+ − 1056 e->value = value;
+ − 1057
+ − 1058 if (++ht->count >= ht->rehash_count)
+ − 1059 enlarge_hash_table (ht);
+ − 1060
+ − 1061 return value;
+ − 1062 }
+ − 1063
+ − 1064 /* Remove hentry pointed at by PROBE.
+ − 1065 Subsequent entries are removed and reinserted.
+ − 1066 We don't use tombstones - too wasteful. */
+ − 1067 static void
+ − 1068 remhash_1 (Lisp_Hash_Table *ht, hentry *entries, hentry *probe)
+ − 1069 {
665
+ − 1070 Elemcount size = ht->size;
428
+ − 1071 CLEAR_HENTRY (probe);
+ − 1072 probe++;
+ − 1073 ht->count--;
+ − 1074
+ − 1075 LINEAR_PROBING_LOOP (probe, entries, size)
+ − 1076 {
+ − 1077 Lisp_Object key = probe->key;
665
+ − 1078 hentry *probe2 = entries + HASHCODE (key, ht);
428
+ − 1079 LINEAR_PROBING_LOOP (probe2, entries, size)
+ − 1080 if (EQ (probe2->key, key))
+ − 1081 /* hentry at probe doesn't need to move. */
+ − 1082 goto continue_outer_loop;
+ − 1083 /* Move hentry from probe to new home at probe2. */
+ − 1084 *probe2 = *probe;
+ − 1085 CLEAR_HENTRY (probe);
+ − 1086 continue_outer_loop: continue;
+ − 1087 }
+ − 1088 }
+ − 1089
+ − 1090 DEFUN ("remhash", Fremhash, 2, 2, 0, /*
+ − 1091 Remove the entry for KEY from HASH-TABLE.
+ − 1092 Do nothing if there is no entry for KEY in HASH-TABLE.
617
+ − 1093 Return non-nil if an entry was removed.
428
+ − 1094 */
+ − 1095 (key, hash_table))
+ − 1096 {
+ − 1097 Lisp_Hash_Table *ht = xhash_table (hash_table);
+ − 1098 hentry *e = find_hentry (key, ht);
+ − 1099
+ − 1100 if (HENTRY_CLEAR_P (e))
+ − 1101 return Qnil;
+ − 1102
+ − 1103 remhash_1 (ht, ht->hentries, e);
+ − 1104 return Qt;
+ − 1105 }
+ − 1106
+ − 1107 DEFUN ("clrhash", Fclrhash, 1, 1, 0, /*
+ − 1108 Remove all entries from HASH-TABLE, leaving it empty.
+ − 1109 */
+ − 1110 (hash_table))
+ − 1111 {
+ − 1112 Lisp_Hash_Table *ht = xhash_table (hash_table);
+ − 1113 hentry *e, *sentinel;
+ − 1114
+ − 1115 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
+ − 1116 CLEAR_HENTRY (e);
+ − 1117 ht->count = 0;
+ − 1118
+ − 1119 return hash_table;
+ − 1120 }
+ − 1121
+ − 1122 /************************************************************************/
+ − 1123 /* Accessor Functions */
+ − 1124 /************************************************************************/
+ − 1125
+ − 1126 DEFUN ("hash-table-count", Fhash_table_count, 1, 1, 0, /*
+ − 1127 Return the number of entries in HASH-TABLE.
+ − 1128 */
+ − 1129 (hash_table))
+ − 1130 {
+ − 1131 return make_int (xhash_table (hash_table)->count);
+ − 1132 }
+ − 1133
+ − 1134 DEFUN ("hash-table-test", Fhash_table_test, 1, 1, 0, /*
+ − 1135 Return the test function of HASH-TABLE.
+ − 1136 This can be one of `eq', `eql' or `equal'.
+ − 1137 */
+ − 1138 (hash_table))
+ − 1139 {
+ − 1140 hash_table_test_function_t fun = xhash_table (hash_table)->test_function;
+ − 1141
+ − 1142 return (fun == lisp_object_eql_equal ? Qeql :
+ − 1143 fun == lisp_object_equal_equal ? Qequal :
+ − 1144 Qeq);
+ − 1145 }
+ − 1146
+ − 1147 DEFUN ("hash-table-size", Fhash_table_size, 1, 1, 0, /*
+ − 1148 Return the size of HASH-TABLE.
+ − 1149 This is the current number of slots in HASH-TABLE, whether occupied or not.
+ − 1150 */
+ − 1151 (hash_table))
+ − 1152 {
+ − 1153 return make_int (xhash_table (hash_table)->size);
+ − 1154 }
+ − 1155
+ − 1156 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size, 1, 1, 0, /*
+ − 1157 Return the current rehash size of HASH-TABLE.
+ − 1158 This is a float greater than 1.0; the factor by which HASH-TABLE
+ − 1159 is enlarged when the rehash threshold is exceeded.
+ − 1160 */
+ − 1161 (hash_table))
+ − 1162 {
+ − 1163 return make_float (xhash_table (hash_table)->rehash_size);
+ − 1164 }
+ − 1165
+ − 1166 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold, 1, 1, 0, /*
+ − 1167 Return the current rehash threshold of HASH-TABLE.
+ − 1168 This is a float between 0.0 and 1.0; the maximum `load factor' of HASH-TABLE,
+ − 1169 beyond which the HASH-TABLE is enlarged by rehashing.
+ − 1170 */
+ − 1171 (hash_table))
+ − 1172 {
438
+ − 1173 return make_float (xhash_table (hash_table)->rehash_threshold);
428
+ − 1174 }
+ − 1175
+ − 1176 DEFUN ("hash-table-weakness", Fhash_table_weakness, 1, 1, 0, /*
+ − 1177 Return the weakness of HASH-TABLE.
442
+ − 1178 This can be one of `nil', `key-and-value', `key-or-value', `key' or `value'.
428
+ − 1179 */
+ − 1180 (hash_table))
+ − 1181 {
+ − 1182 switch (xhash_table (hash_table)->weakness)
+ − 1183 {
442
+ − 1184 case HASH_TABLE_WEAK: return Qkey_and_value;
+ − 1185 case HASH_TABLE_KEY_WEAK: return Qkey;
+ − 1186 case HASH_TABLE_KEY_VALUE_WEAK: return Qkey_or_value;
+ − 1187 case HASH_TABLE_VALUE_WEAK: return Qvalue;
+ − 1188 default: return Qnil;
428
+ − 1189 }
+ − 1190 }
+ − 1191
+ − 1192 /* obsolete as of 19990901 in xemacs-21.2 */
+ − 1193 DEFUN ("hash-table-type", Fhash_table_type, 1, 1, 0, /*
+ − 1194 Return the type of HASH-TABLE.
+ − 1195 This can be one of `non-weak', `weak', `key-weak' or `value-weak'.
+ − 1196 */
+ − 1197 (hash_table))
+ − 1198 {
+ − 1199 switch (xhash_table (hash_table)->weakness)
+ − 1200 {
442
+ − 1201 case HASH_TABLE_WEAK: return Qweak;
+ − 1202 case HASH_TABLE_KEY_WEAK: return Qkey_weak;
+ − 1203 case HASH_TABLE_KEY_VALUE_WEAK: return Qkey_or_value_weak;
+ − 1204 case HASH_TABLE_VALUE_WEAK: return Qvalue_weak;
+ − 1205 default: return Qnon_weak;
428
+ − 1206 }
+ − 1207 }
+ − 1208
+ − 1209 /************************************************************************/
+ − 1210 /* Mapping Functions */
+ − 1211 /************************************************************************/
489
+ − 1212
+ − 1213 /* We need to be careful when mapping over hash tables because the
+ − 1214 hash table might be modified during the mapping operation:
+ − 1215 - by the mapping function
+ − 1216 - by gc (if the hash table is weak)
+ − 1217
+ − 1218 So we make a copy of the hentries at the beginning of the mapping
497
+ − 1219 operation, and iterate over the copy. Naturally, this is
+ − 1220 expensive, but not as expensive as you might think, because no
+ − 1221 actual memory has to be collected by our notoriously inefficient
+ − 1222 GC; we use an unwind-protect instead to free the memory directly.
+ − 1223
+ − 1224 We could avoid the copying by having the hash table modifiers
+ − 1225 puthash and remhash check for currently active mapping functions.
+ − 1226 Disadvantages: it's hard to get right, and IMO hash mapping
+ − 1227 functions are basically rare, and no extra space in the hash table
+ − 1228 object and no extra cpu in puthash or remhash should be wasted to
+ − 1229 make maphash 3% faster. From a design point of view, the basic
+ − 1230 functions gethash, puthash and remhash should be implementable
+ − 1231 without having to think about maphash.
+ − 1232
+ − 1233 Note: We don't (yet) have Common Lisp's with-hash-table-iterator.
+ − 1234 If you implement this naively, you cannot have more than one
+ − 1235 concurrently active iterator over the same hash table. The `each'
+ − 1236 function in perl has this limitation.
+ − 1237
+ − 1238 Note: We GCPRO memory on the heap, not on the stack. There is no
+ − 1239 obvious reason why this is bad, but as of this writing this is the
+ − 1240 only known occurrence of this technique in the code.
504
+ − 1241
+ − 1242 -- Martin
+ − 1243 */
+ − 1244
+ − 1245 /* Ben disagrees with the "copying hentries" design, and says:
+ − 1246
+ − 1247 Another solution is the same as I've already proposed -- when
+ − 1248 mapping, mark the table as "change-unsafe", and in this case, use a
+ − 1249 secondary table to maintain changes. this could be basically a
+ − 1250 standard hash table, but with entries only for added or deleted
+ − 1251 entries in the primary table, and a marker like Qunbound to
+ − 1252 indicate a deleted entry. puthash, gethash and remhash need a
+ − 1253 single extra check for this secondary table -- totally
+ − 1254 insignificant speedwise. if you really cared about making
+ − 1255 recursive maphashes completely correct, you'd have to do a bit of
+ − 1256 extra work here -- when maphashing, if the secondary table exists,
+ − 1257 make a copy of it, and use the copy in conjunction with the primary
+ − 1258 table when mapping. the advantages of this are
+ − 1259
+ − 1260 [a] easy to demonstrate correct, even with weak hashtables.
+ − 1261
+ − 1262 [b] no extra overhead in the general maphash case -- only when you
+ − 1263 modify the table while maphashing, and even then the overhead is
+ − 1264 very small.
497
+ − 1265 */
+ − 1266
489
+ − 1267 static Lisp_Object
+ − 1268 maphash_unwind (Lisp_Object unwind_obj)
+ − 1269 {
+ − 1270 void *ptr = (void *) get_opaque_ptr (unwind_obj);
+ − 1271 xfree (ptr);
+ − 1272 free_opaque_ptr (unwind_obj);
+ − 1273 return Qnil;
+ − 1274 }
+ − 1275
+ − 1276 /* Return a malloced array of alternating key/value pairs from HT. */
+ − 1277 static Lisp_Object *
+ − 1278 copy_compress_hentries (const Lisp_Hash_Table *ht)
+ − 1279 {
+ − 1280 Lisp_Object * const objs =
+ − 1281 /* If the hash table is empty, ht->count could be 0. */
+ − 1282 xnew_array (Lisp_Object, 2 * (ht->count > 0 ? ht->count : 1));
+ − 1283 const hentry *e, *sentinel;
+ − 1284 Lisp_Object *pobj;
+ − 1285
+ − 1286 for (e = ht->hentries, sentinel = e + ht->size, pobj = objs; e < sentinel; e++)
+ − 1287 if (!HENTRY_CLEAR_P (e))
+ − 1288 {
+ − 1289 *(pobj++) = e->key;
+ − 1290 *(pobj++) = e->value;
+ − 1291 }
+ − 1292
+ − 1293 type_checking_assert (pobj == objs + 2 * ht->count);
+ − 1294
+ − 1295 return objs;
+ − 1296 }
+ − 1297
428
+ − 1298 DEFUN ("maphash", Fmaphash, 2, 2, 0, /*
+ − 1299 Map FUNCTION over entries in HASH-TABLE, calling it with two args,
+ − 1300 each key and value in HASH-TABLE.
+ − 1301
489
+ − 1302 FUNCTION must not modify HASH-TABLE, with the one exception that FUNCTION
428
+ − 1303 may remhash or puthash the entry currently being processed by FUNCTION.
+ − 1304 */
+ − 1305 (function, hash_table))
+ − 1306 {
489
+ − 1307 const Lisp_Hash_Table * const ht = xhash_table (hash_table);
+ − 1308 Lisp_Object * const objs = copy_compress_hentries (ht);
+ − 1309 Lisp_Object args[3];
+ − 1310 const Lisp_Object *pobj, *end;
+ − 1311 int speccount = specpdl_depth ();
+ − 1312 struct gcpro gcpro1;
+ − 1313
+ − 1314 record_unwind_protect (maphash_unwind, make_opaque_ptr ((void *)objs));
+ − 1315 GCPRO1 (objs[0]);
+ − 1316 gcpro1.nvars = 2 * ht->count;
428
+ − 1317
489
+ − 1318 args[0] = function;
+ − 1319
+ − 1320 for (pobj = objs, end = pobj + 2 * ht->count; pobj < end; pobj += 2)
+ − 1321 {
+ − 1322 args[1] = pobj[0];
+ − 1323 args[2] = pobj[1];
+ − 1324 Ffuncall (countof (args), args);
+ − 1325 }
+ − 1326
+ − 1327 unbind_to (speccount, Qnil);
+ − 1328 UNGCPRO;
428
+ − 1329
+ − 1330 return Qnil;
+ − 1331 }
+ − 1332
489
+ − 1333 /* Map *C* function FUNCTION over the elements of a non-weak lisp hash table.
+ − 1334 FUNCTION must not modify HASH-TABLE, with the one exception that FUNCTION
+ − 1335 may puthash the entry currently being processed by FUNCTION.
+ − 1336 Mapping terminates if FUNCTION returns something other than 0. */
428
+ − 1337 void
489
+ − 1338 elisp_maphash_unsafe (maphash_function_t function,
428
+ − 1339 Lisp_Object hash_table, void *extra_arg)
+ − 1340 {
442
+ − 1341 const Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
+ − 1342 const hentry *e, *sentinel;
428
+ − 1343
+ − 1344 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
+ − 1345 if (!HENTRY_CLEAR_P (e))
489
+ − 1346 if (function (e->key, e->value, extra_arg))
+ − 1347 return;
428
+ − 1348 }
+ − 1349
489
+ − 1350 /* Map *C* function FUNCTION over the elements of a lisp hash table.
+ − 1351 It is safe for FUNCTION to modify HASH-TABLE.
+ − 1352 Mapping terminates if FUNCTION returns something other than 0. */
+ − 1353 void
+ − 1354 elisp_maphash (maphash_function_t function,
+ − 1355 Lisp_Object hash_table, void *extra_arg)
+ − 1356 {
+ − 1357 const Lisp_Hash_Table * const ht = xhash_table (hash_table);
+ − 1358 Lisp_Object * const objs = copy_compress_hentries (ht);
+ − 1359 const Lisp_Object *pobj, *end;
+ − 1360 int speccount = specpdl_depth ();
+ − 1361 struct gcpro gcpro1;
+ − 1362
+ − 1363 record_unwind_protect (maphash_unwind, make_opaque_ptr ((void *)objs));
+ − 1364 GCPRO1 (objs[0]);
+ − 1365 gcpro1.nvars = 2 * ht->count;
+ − 1366
+ − 1367 for (pobj = objs, end = pobj + 2 * ht->count; pobj < end; pobj += 2)
+ − 1368 if (function (pobj[0], pobj[1], extra_arg))
+ − 1369 break;
+ − 1370
+ − 1371 unbind_to (speccount, Qnil);
+ − 1372 UNGCPRO;
+ − 1373 }
+ − 1374
+ − 1375 /* Remove all elements of a lisp hash table satisfying *C* predicate PREDICATE.
+ − 1376 PREDICATE must not modify HASH-TABLE. */
428
+ − 1377 void
+ − 1378 elisp_map_remhash (maphash_function_t predicate,
+ − 1379 Lisp_Object hash_table, void *extra_arg)
+ − 1380 {
489
+ − 1381 const Lisp_Hash_Table * const ht = xhash_table (hash_table);
+ − 1382 Lisp_Object * const objs = copy_compress_hentries (ht);
+ − 1383 const Lisp_Object *pobj, *end;
+ − 1384 int speccount = specpdl_depth ();
+ − 1385 struct gcpro gcpro1;
428
+ − 1386
489
+ − 1387 record_unwind_protect (maphash_unwind, make_opaque_ptr ((void *)objs));
+ − 1388 GCPRO1 (objs[0]);
+ − 1389 gcpro1.nvars = 2 * ht->count;
+ − 1390
+ − 1391 for (pobj = objs, end = pobj + 2 * ht->count; pobj < end; pobj += 2)
+ − 1392 if (predicate (pobj[0], pobj[1], extra_arg))
+ − 1393 Fremhash (pobj[0], hash_table);
+ − 1394
+ − 1395 unbind_to (speccount, Qnil);
+ − 1396 UNGCPRO;
428
+ − 1397 }
+ − 1398
+ − 1399
+ − 1400 /************************************************************************/
+ − 1401 /* garbage collecting weak hash tables */
+ − 1402 /************************************************************************/
442
+ − 1403 #define MARK_OBJ(obj) do { \
+ − 1404 Lisp_Object mo_obj = (obj); \
+ − 1405 if (!marked_p (mo_obj)) \
+ − 1406 { \
+ − 1407 mark_object (mo_obj); \
+ − 1408 did_mark = 1; \
+ − 1409 } \
+ − 1410 } while (0)
+ − 1411
428
+ − 1412
+ − 1413 /* Complete the marking for semi-weak hash tables. */
+ − 1414 int
+ − 1415 finish_marking_weak_hash_tables (void)
+ − 1416 {
+ − 1417 Lisp_Object hash_table;
+ − 1418 int did_mark = 0;
+ − 1419
+ − 1420 for (hash_table = Vall_weak_hash_tables;
+ − 1421 !NILP (hash_table);
+ − 1422 hash_table = XHASH_TABLE (hash_table)->next_weak)
+ − 1423 {
442
+ − 1424 const Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
+ − 1425 const hentry *e = ht->hentries;
+ − 1426 const hentry *sentinel = e + ht->size;
428
+ − 1427
+ − 1428 if (! marked_p (hash_table))
+ − 1429 /* The hash table is probably garbage. Ignore it. */
+ − 1430 continue;
+ − 1431
+ − 1432 /* Now, scan over all the pairs. For all pairs that are
+ − 1433 half-marked, we may need to mark the other half if we're
+ − 1434 keeping this pair. */
+ − 1435 switch (ht->weakness)
+ − 1436 {
+ − 1437 case HASH_TABLE_KEY_WEAK:
+ − 1438 for (; e < sentinel; e++)
+ − 1439 if (!HENTRY_CLEAR_P (e))
+ − 1440 if (marked_p (e->key))
+ − 1441 MARK_OBJ (e->value);
+ − 1442 break;
+ − 1443
+ − 1444 case HASH_TABLE_VALUE_WEAK:
+ − 1445 for (; e < sentinel; e++)
+ − 1446 if (!HENTRY_CLEAR_P (e))
+ − 1447 if (marked_p (e->value))
+ − 1448 MARK_OBJ (e->key);
+ − 1449 break;
+ − 1450
442
+ − 1451 case HASH_TABLE_KEY_VALUE_WEAK:
+ − 1452 for (; e < sentinel; e++)
+ − 1453 if (!HENTRY_CLEAR_P (e))
+ − 1454 {
+ − 1455 if (marked_p (e->value))
+ − 1456 MARK_OBJ (e->key);
+ − 1457 else if (marked_p (e->key))
+ − 1458 MARK_OBJ (e->value);
+ − 1459 }
+ − 1460 break;
+ − 1461
428
+ − 1462 case HASH_TABLE_KEY_CAR_WEAK:
+ − 1463 for (; e < sentinel; e++)
+ − 1464 if (!HENTRY_CLEAR_P (e))
+ − 1465 if (!CONSP (e->key) || marked_p (XCAR (e->key)))
+ − 1466 {
+ − 1467 MARK_OBJ (e->key);
+ − 1468 MARK_OBJ (e->value);
+ − 1469 }
+ − 1470 break;
+ − 1471
450
+ − 1472 /* We seem to be sprouting new weakness types at an alarming
+ − 1473 rate. At least this is not externally visible - and in
+ − 1474 fact all of these KEY_CAR_* types are only used by the
+ − 1475 glyph code. */
+ − 1476 case HASH_TABLE_KEY_CAR_VALUE_WEAK:
+ − 1477 for (; e < sentinel; e++)
+ − 1478 if (!HENTRY_CLEAR_P (e))
+ − 1479 {
+ − 1480 if (!CONSP (e->key) || marked_p (XCAR (e->key)))
+ − 1481 {
+ − 1482 MARK_OBJ (e->key);
+ − 1483 MARK_OBJ (e->value);
+ − 1484 }
+ − 1485 else if (marked_p (e->value))
+ − 1486 MARK_OBJ (e->key);
+ − 1487 }
+ − 1488 break;
+ − 1489
428
+ − 1490 case HASH_TABLE_VALUE_CAR_WEAK:
+ − 1491 for (; e < sentinel; e++)
+ − 1492 if (!HENTRY_CLEAR_P (e))
+ − 1493 if (!CONSP (e->value) || marked_p (XCAR (e->value)))
+ − 1494 {
+ − 1495 MARK_OBJ (e->key);
+ − 1496 MARK_OBJ (e->value);
+ − 1497 }
+ − 1498 break;
+ − 1499
+ − 1500 default:
+ − 1501 break;
+ − 1502 }
+ − 1503 }
+ − 1504
+ − 1505 return did_mark;
+ − 1506 }
+ − 1507
+ − 1508 void
+ − 1509 prune_weak_hash_tables (void)
+ − 1510 {
+ − 1511 Lisp_Object hash_table, prev = Qnil;
+ − 1512 for (hash_table = Vall_weak_hash_tables;
+ − 1513 !NILP (hash_table);
+ − 1514 hash_table = XHASH_TABLE (hash_table)->next_weak)
+ − 1515 {
+ − 1516 if (! marked_p (hash_table))
+ − 1517 {
+ − 1518 /* This hash table itself is garbage. Remove it from the list. */
+ − 1519 if (NILP (prev))
+ − 1520 Vall_weak_hash_tables = XHASH_TABLE (hash_table)->next_weak;
+ − 1521 else
+ − 1522 XHASH_TABLE (prev)->next_weak = XHASH_TABLE (hash_table)->next_weak;
+ − 1523 }
+ − 1524 else
+ − 1525 {
+ − 1526 /* Now, scan over all the pairs. Remove all of the pairs
+ − 1527 in which the key or value, or both, is unmarked
+ − 1528 (depending on the weakness of the hash table). */
+ − 1529 Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
+ − 1530 hentry *entries = ht->hentries;
+ − 1531 hentry *sentinel = entries + ht->size;
+ − 1532 hentry *e;
+ − 1533
+ − 1534 for (e = entries; e < sentinel; e++)
+ − 1535 if (!HENTRY_CLEAR_P (e))
+ − 1536 {
+ − 1537 again:
+ − 1538 if (!marked_p (e->key) || !marked_p (e->value))
+ − 1539 {
+ − 1540 remhash_1 (ht, entries, e);
+ − 1541 if (!HENTRY_CLEAR_P (e))
+ − 1542 goto again;
+ − 1543 }
+ − 1544 }
+ − 1545
+ − 1546 prev = hash_table;
+ − 1547 }
+ − 1548 }
+ − 1549 }
+ − 1550
+ − 1551 /* Return a hash value for an array of Lisp_Objects of size SIZE. */
+ − 1552
665
+ − 1553 Hashcode
428
+ − 1554 internal_array_hash (Lisp_Object *arr, int size, int depth)
+ − 1555 {
+ − 1556 int i;
665
+ − 1557 Hashcode hash = 0;
442
+ − 1558 depth++;
428
+ − 1559
+ − 1560 if (size <= 5)
+ − 1561 {
+ − 1562 for (i = 0; i < size; i++)
442
+ − 1563 hash = HASH2 (hash, internal_hash (arr[i], depth));
428
+ − 1564 return hash;
+ − 1565 }
+ − 1566
+ − 1567 /* just pick five elements scattered throughout the array.
+ − 1568 A slightly better approach would be to offset by some
+ − 1569 noise factor from the points chosen below. */
+ − 1570 for (i = 0; i < 5; i++)
442
+ − 1571 hash = HASH2 (hash, internal_hash (arr[i*size/5], depth));
428
+ − 1572
+ − 1573 return hash;
+ − 1574 }
+ − 1575
+ − 1576 /* Return a hash value for a Lisp_Object. This is for use when hashing
+ − 1577 objects with the comparison being `equal' (for `eq', you can just
+ − 1578 use the Lisp_Object itself as the hash value). You need to make a
+ − 1579 tradeoff between the speed of the hash function and how good the
+ − 1580 hashing is. In particular, the hash function needs to be FAST,
+ − 1581 so you can't just traipse down the whole tree hashing everything
+ − 1582 together. Most of the time, objects will differ in the first
+ − 1583 few elements you hash. Thus, we only go to a short depth (5)
+ − 1584 and only hash at most 5 elements out of a vector. Theoretically
+ − 1585 we could still take 5^5 time (a big big number) to compute a
+ − 1586 hash, but practically this won't ever happen. */
+ − 1587
665
+ − 1588 Hashcode
428
+ − 1589 internal_hash (Lisp_Object obj, int depth)
+ − 1590 {
+ − 1591 if (depth > 5)
+ − 1592 return 0;
+ − 1593 if (CONSP (obj))
+ − 1594 {
+ − 1595 /* no point in worrying about tail recursion, since we're not
+ − 1596 going very deep */
+ − 1597 return HASH2 (internal_hash (XCAR (obj), depth + 1),
+ − 1598 internal_hash (XCDR (obj), depth + 1));
+ − 1599 }
+ − 1600 if (STRINGP (obj))
+ − 1601 {
+ − 1602 return hash_string (XSTRING_DATA (obj), XSTRING_LENGTH (obj));
+ − 1603 }
+ − 1604 if (LRECORDP (obj))
+ − 1605 {
442
+ − 1606 const struct lrecord_implementation
428
+ − 1607 *imp = XRECORD_LHEADER_IMPLEMENTATION (obj);
+ − 1608 if (imp->hash)
+ − 1609 return imp->hash (obj, depth);
+ − 1610 }
+ − 1611
+ − 1612 return LISP_HASH (obj);
+ − 1613 }
+ − 1614
+ − 1615 DEFUN ("sxhash", Fsxhash, 1, 1, 0, /*
+ − 1616 Return a hash value for OBJECT.
444
+ − 1617 \(equal obj1 obj2) implies (= (sxhash obj1) (sxhash obj2)).
428
+ − 1618 */
+ − 1619 (object))
+ − 1620 {
+ − 1621 return make_int (internal_hash (object, 0));
+ − 1622 }
+ − 1623
+ − 1624 #if 0
+ − 1625 xxDEFUN ("internal-hash-value", Finternal_hash_value, 1, 1, 0, /*
+ − 1626 Hash value of OBJECT. For debugging.
+ − 1627 The value is returned as (HIGH . LOW).
+ − 1628 */
+ − 1629 (object))
+ − 1630 {
+ − 1631 /* This function is pretty 32bit-centric. */
665
+ − 1632 Hashcode hash = internal_hash (object, 0);
428
+ − 1633 return Fcons (hash >> 16, hash & 0xffff);
+ − 1634 }
+ − 1635 #endif
+ − 1636
+ − 1637
+ − 1638 /************************************************************************/
+ − 1639 /* initialization */
+ − 1640 /************************************************************************/
+ − 1641
+ − 1642 void
+ − 1643 syms_of_elhash (void)
+ − 1644 {
442
+ − 1645 INIT_LRECORD_IMPLEMENTATION (hash_table);
+ − 1646
428
+ − 1647 DEFSUBR (Fhash_table_p);
+ − 1648 DEFSUBR (Fmake_hash_table);
+ − 1649 DEFSUBR (Fcopy_hash_table);
+ − 1650 DEFSUBR (Fgethash);
+ − 1651 DEFSUBR (Fremhash);
+ − 1652 DEFSUBR (Fputhash);
+ − 1653 DEFSUBR (Fclrhash);
+ − 1654 DEFSUBR (Fmaphash);
+ − 1655 DEFSUBR (Fhash_table_count);
+ − 1656 DEFSUBR (Fhash_table_test);
+ − 1657 DEFSUBR (Fhash_table_size);
+ − 1658 DEFSUBR (Fhash_table_rehash_size);
+ − 1659 DEFSUBR (Fhash_table_rehash_threshold);
+ − 1660 DEFSUBR (Fhash_table_weakness);
+ − 1661 DEFSUBR (Fhash_table_type); /* obsolete */
+ − 1662 DEFSUBR (Fsxhash);
+ − 1663 #if 0
+ − 1664 DEFSUBR (Finternal_hash_value);
+ − 1665 #endif
+ − 1666
563
+ − 1667 DEFSYMBOL_MULTIWORD_PREDICATE (Qhash_tablep);
+ − 1668 DEFSYMBOL (Qhash_table);
+ − 1669 DEFSYMBOL (Qhashtable);
+ − 1670 DEFSYMBOL (Qweakness);
+ − 1671 DEFSYMBOL (Qvalue);
+ − 1672 DEFSYMBOL (Qkey_or_value);
+ − 1673 DEFSYMBOL (Qkey_and_value);
+ − 1674 DEFSYMBOL (Qrehash_size);
+ − 1675 DEFSYMBOL (Qrehash_threshold);
428
+ − 1676
563
+ − 1677 DEFSYMBOL (Qweak); /* obsolete */
+ − 1678 DEFSYMBOL (Qkey_weak); /* obsolete */
+ − 1679 DEFSYMBOL (Qkey_or_value_weak); /* obsolete */
+ − 1680 DEFSYMBOL (Qvalue_weak); /* obsolete */
+ − 1681 DEFSYMBOL (Qnon_weak); /* obsolete */
428
+ − 1682
563
+ − 1683 DEFKEYWORD (Q_test);
+ − 1684 DEFKEYWORD (Q_size);
+ − 1685 DEFKEYWORD (Q_rehash_size);
+ − 1686 DEFKEYWORD (Q_rehash_threshold);
+ − 1687 DEFKEYWORD (Q_weakness);
+ − 1688 DEFKEYWORD (Q_type); /* obsolete */
428
+ − 1689 }
+ − 1690
+ − 1691 void
+ − 1692 vars_of_elhash (void)
+ − 1693 {
+ − 1694 /* This must NOT be staticpro'd */
+ − 1695 Vall_weak_hash_tables = Qnil;
452
+ − 1696 dump_add_weak_object_chain (&Vall_weak_hash_tables);
428
+ − 1697 }