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