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