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
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
+ − 377 abort ();
+ − 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
+ − 405 {
800
+ − 406 write_fmt_string (printcharfun, " 0x%x>", ht->header.uid);
428
+ − 407 }
+ − 408 }
+ − 409
+ − 410 static void
2333
+ − 411 free_hentries (htentry *hentries,
+ − 412 #ifdef ERROR_CHECK_STRUCTURES
+ − 413 size_t size
+ − 414 #else
+ − 415 size_t UNUSED (size)
+ − 416 #endif
+ − 417 )
489
+ − 418 {
800
+ − 419 #ifdef ERROR_CHECK_STRUCTURES
489
+ − 420 /* Ensure a crash if other code uses the discarded entries afterwards. */
1204
+ − 421 htentry *e, *sentinel;
489
+ − 422
+ − 423 for (e = hentries, sentinel = e + size; e < sentinel; e++)
1204
+ − 424 * (unsigned long *) e = 0xdeadbeef; /* -559038737 base 10 */
489
+ − 425 #endif
+ − 426
+ − 427 if (!DUMPEDP (hentries))
1726
+ − 428 xfree (hentries, htentry *);
489
+ − 429 }
+ − 430
+ − 431 static void
428
+ − 432 finalize_hash_table (void *header, int for_disksave)
+ − 433 {
+ − 434 if (!for_disksave)
+ − 435 {
+ − 436 Lisp_Hash_Table *ht = (Lisp_Hash_Table *) header;
489
+ − 437 free_hentries (ht->hentries, ht->size);
428
+ − 438 ht->hentries = 0;
+ − 439 }
+ − 440 }
+ − 441
1204
+ − 442 static const struct memory_description htentry_description_1[] = {
+ − 443 { XD_LISP_OBJECT, offsetof (htentry, key) },
+ − 444 { XD_LISP_OBJECT, offsetof (htentry, value) },
428
+ − 445 { XD_END }
+ − 446 };
+ − 447
1204
+ − 448 static const struct sized_memory_description htentry_description = {
+ − 449 sizeof (htentry),
+ − 450 htentry_description_1
428
+ − 451 };
+ − 452
1204
+ − 453 static const struct memory_description htentry_union_description_1[] = {
+ − 454 /* Note: XD_INDIRECT in this table refers to the surrounding table,
+ − 455 and so this will work. */
2367
+ − 456 { XD_BLOCK_PTR, HASH_TABLE_NON_WEAK, XD_INDIRECT (0, 1),
1204
+ − 457 &htentry_description },
2367
+ − 458 { XD_BLOCK_PTR, 0, XD_INDIRECT (0, 1), &htentry_description,
1204
+ − 459 XD_FLAG_UNION_DEFAULT_ENTRY | XD_FLAG_NO_KKCC },
+ − 460 { XD_END }
+ − 461 };
+ − 462
+ − 463 static const struct sized_memory_description htentry_union_description = {
+ − 464 sizeof (htentry *),
+ − 465 htentry_union_description_1
+ − 466 };
+ − 467
+ − 468 const struct memory_description hash_table_description[] = {
+ − 469 { XD_ELEMCOUNT, offsetof (Lisp_Hash_Table, size) },
+ − 470 { XD_INT, offsetof (Lisp_Hash_Table, weakness) },
+ − 471 { XD_UNION, offsetof (Lisp_Hash_Table, hentries), XD_INDIRECT (1, 0),
+ − 472 &htentry_union_description },
440
+ − 473 { XD_LO_LINK, offsetof (Lisp_Hash_Table, next_weak) },
428
+ − 474 { XD_END }
+ − 475 };
+ − 476
934
+ − 477 DEFINE_LRECORD_IMPLEMENTATION ("hash-table", hash_table,
+ − 478 1, /*dumpable-flag*/
+ − 479 mark_hash_table, print_hash_table,
+ − 480 finalize_hash_table,
+ − 481 hash_table_equal, hash_table_hash,
+ − 482 hash_table_description,
+ − 483 Lisp_Hash_Table);
428
+ − 484
+ − 485 static Lisp_Hash_Table *
+ − 486 xhash_table (Lisp_Object hash_table)
+ − 487 {
1123
+ − 488 /* #### What's going on here? Why the gc_in_progress check? */
428
+ − 489 if (!gc_in_progress)
+ − 490 CHECK_HASH_TABLE (hash_table);
+ − 491 check_hash_table_invariants (XHASH_TABLE (hash_table));
+ − 492 return XHASH_TABLE (hash_table);
+ − 493 }
+ − 494
+ − 495
+ − 496 /************************************************************************/
+ − 497 /* Creation of Hash Tables */
+ − 498 /************************************************************************/
+ − 499
+ − 500 /* Creation of hash tables, without error-checking. */
+ − 501 static void
+ − 502 compute_hash_table_derived_values (Lisp_Hash_Table *ht)
+ − 503 {
665
+ − 504 ht->rehash_count = (Elemcount)
438
+ − 505 ((double) ht->size * ht->rehash_threshold);
665
+ − 506 ht->golden_ratio = (Elemcount)
428
+ − 507 ((double) ht->size * (.6180339887 / (double) sizeof (Lisp_Object)));
+ − 508 }
+ − 509
+ − 510 Lisp_Object
450
+ − 511 make_standard_lisp_hash_table (enum hash_table_test test,
665
+ − 512 Elemcount size,
450
+ − 513 double rehash_size,
+ − 514 double rehash_threshold,
+ − 515 enum hash_table_weakness weakness)
+ − 516 {
462
+ − 517 hash_table_hash_function_t hash_function = 0;
450
+ − 518 hash_table_test_function_t test_function = 0;
+ − 519
+ − 520 switch (test)
+ − 521 {
+ − 522 case HASH_TABLE_EQ:
+ − 523 test_function = 0;
+ − 524 hash_function = 0;
+ − 525 break;
+ − 526
+ − 527 case HASH_TABLE_EQL:
+ − 528 test_function = lisp_object_eql_equal;
+ − 529 hash_function = lisp_object_eql_hash;
+ − 530 break;
+ − 531
+ − 532 case HASH_TABLE_EQUAL:
+ − 533 test_function = lisp_object_equal_equal;
+ − 534 hash_function = lisp_object_equal_hash;
+ − 535 break;
+ − 536
+ − 537 default:
+ − 538 abort ();
+ − 539 }
+ − 540
+ − 541 return make_general_lisp_hash_table (hash_function, test_function,
+ − 542 size, rehash_size, rehash_threshold,
+ − 543 weakness);
+ − 544 }
+ − 545
+ − 546 Lisp_Object
+ − 547 make_general_lisp_hash_table (hash_table_hash_function_t hash_function,
+ − 548 hash_table_test_function_t test_function,
665
+ − 549 Elemcount size,
428
+ − 550 double rehash_size,
+ − 551 double rehash_threshold,
+ − 552 enum hash_table_weakness weakness)
+ − 553 {
+ − 554 Lisp_Object hash_table;
+ − 555 Lisp_Hash_Table *ht = alloc_lcrecord_type (Lisp_Hash_Table, &lrecord_hash_table);
+ − 556
450
+ − 557 ht->test_function = test_function;
+ − 558 ht->hash_function = hash_function;
438
+ − 559 ht->weakness = weakness;
+ − 560
+ − 561 ht->rehash_size =
+ − 562 rehash_size > 1.0 ? rehash_size : HASH_TABLE_DEFAULT_REHASH_SIZE;
+ − 563
+ − 564 ht->rehash_threshold =
+ − 565 rehash_threshold > 0.0 ? rehash_threshold :
+ − 566 size > 4096 && !ht->test_function ? 0.7 : 0.6;
+ − 567
428
+ − 568 if (size < HASH_TABLE_MIN_SIZE)
+ − 569 size = HASH_TABLE_MIN_SIZE;
665
+ − 570 ht->size = hash_table_size ((Elemcount) (((double) size / ht->rehash_threshold)
438
+ − 571 + 1.0));
428
+ − 572 ht->count = 0;
438
+ − 573
428
+ − 574 compute_hash_table_derived_values (ht);
+ − 575
1204
+ − 576 /* We leave room for one never-occupied sentinel htentry at the end. */
+ − 577 ht->hentries = xnew_array_and_zero (htentry, ht->size + 1);
428
+ − 578
793
+ − 579 hash_table = wrap_hash_table (ht);
428
+ − 580
+ − 581 if (weakness == HASH_TABLE_NON_WEAK)
+ − 582 ht->next_weak = Qunbound;
+ − 583 else
+ − 584 ht->next_weak = Vall_weak_hash_tables, Vall_weak_hash_tables = hash_table;
+ − 585
+ − 586 return hash_table;
+ − 587 }
+ − 588
+ − 589 Lisp_Object
665
+ − 590 make_lisp_hash_table (Elemcount size,
428
+ − 591 enum hash_table_weakness weakness,
+ − 592 enum hash_table_test test)
+ − 593 {
450
+ − 594 return make_standard_lisp_hash_table (test, size, -1.0, -1.0, weakness);
428
+ − 595 }
+ − 596
+ − 597 /* Pretty reading of hash tables.
+ − 598
+ − 599 Here we use the existing structures mechanism (which is,
+ − 600 unfortunately, pretty cumbersome) for validating and instantiating
+ − 601 the hash tables. The idea is that the side-effect of reading a
+ − 602 #s(hash-table PLIST) object is creation of a hash table with desired
+ − 603 properties, and that the hash table is returned. */
+ − 604
+ − 605 /* Validation functions: each keyword provides its own validation
+ − 606 function. The errors should maybe be continuable, but it is
+ − 607 unclear how this would cope with ERRB. */
+ − 608 static int
2286
+ − 609 hash_table_size_validate (Lisp_Object UNUSED (keyword), Lisp_Object value,
+ − 610 Error_Behavior errb)
428
+ − 611 {
+ − 612 if (NATNUMP (value))
+ − 613 return 1;
+ − 614
563
+ − 615 maybe_signal_error_1 (Qwrong_type_argument, list2 (Qnatnump, value),
2286
+ − 616 Qhash_table, errb);
428
+ − 617 return 0;
+ − 618 }
+ − 619
665
+ − 620 static Elemcount
428
+ − 621 decode_hash_table_size (Lisp_Object obj)
+ − 622 {
+ − 623 return NILP (obj) ? HASH_TABLE_DEFAULT_SIZE : XINT (obj);
+ − 624 }
+ − 625
+ − 626 static int
2286
+ − 627 hash_table_weakness_validate (Lisp_Object UNUSED (keyword), Lisp_Object value,
578
+ − 628 Error_Behavior errb)
428
+ − 629 {
442
+ − 630 if (EQ (value, Qnil)) return 1;
+ − 631 if (EQ (value, Qt)) return 1;
+ − 632 if (EQ (value, Qkey)) return 1;
+ − 633 if (EQ (value, Qkey_and_value)) return 1;
+ − 634 if (EQ (value, Qkey_or_value)) return 1;
+ − 635 if (EQ (value, Qvalue)) return 1;
428
+ − 636
+ − 637 /* Following values are obsolete as of 19990901 in xemacs-21.2 */
442
+ − 638 if (EQ (value, Qnon_weak)) return 1;
+ − 639 if (EQ (value, Qweak)) return 1;
+ − 640 if (EQ (value, Qkey_weak)) return 1;
+ − 641 if (EQ (value, Qkey_or_value_weak)) return 1;
+ − 642 if (EQ (value, Qvalue_weak)) return 1;
428
+ − 643
563
+ − 644 maybe_invalid_constant ("Invalid hash table weakness",
428
+ − 645 value, Qhash_table, errb);
+ − 646 return 0;
+ − 647 }
+ − 648
+ − 649 static enum hash_table_weakness
+ − 650 decode_hash_table_weakness (Lisp_Object obj)
+ − 651 {
442
+ − 652 if (EQ (obj, Qnil)) return HASH_TABLE_NON_WEAK;
+ − 653 if (EQ (obj, Qt)) return HASH_TABLE_WEAK;
+ − 654 if (EQ (obj, Qkey_and_value)) return HASH_TABLE_WEAK;
+ − 655 if (EQ (obj, Qkey)) return HASH_TABLE_KEY_WEAK;
+ − 656 if (EQ (obj, Qkey_or_value)) return HASH_TABLE_KEY_VALUE_WEAK;
+ − 657 if (EQ (obj, Qvalue)) return HASH_TABLE_VALUE_WEAK;
428
+ − 658
+ − 659 /* Following values are obsolete as of 19990901 in xemacs-21.2 */
442
+ − 660 if (EQ (obj, Qnon_weak)) return HASH_TABLE_NON_WEAK;
+ − 661 if (EQ (obj, Qweak)) return HASH_TABLE_WEAK;
+ − 662 if (EQ (obj, Qkey_weak)) return HASH_TABLE_KEY_WEAK;
+ − 663 if (EQ (obj, Qkey_or_value_weak)) return HASH_TABLE_KEY_VALUE_WEAK;
+ − 664 if (EQ (obj, Qvalue_weak)) return HASH_TABLE_VALUE_WEAK;
428
+ − 665
563
+ − 666 invalid_constant ("Invalid hash table weakness", obj);
1204
+ − 667 RETURN_NOT_REACHED (HASH_TABLE_NON_WEAK);
428
+ − 668 }
+ − 669
+ − 670 static int
2286
+ − 671 hash_table_test_validate (Lisp_Object UNUSED (keyword), Lisp_Object value,
+ − 672 Error_Behavior errb)
428
+ − 673 {
+ − 674 if (EQ (value, Qnil)) return 1;
+ − 675 if (EQ (value, Qeq)) return 1;
+ − 676 if (EQ (value, Qequal)) return 1;
+ − 677 if (EQ (value, Qeql)) return 1;
+ − 678
563
+ − 679 maybe_invalid_constant ("Invalid hash table test",
2286
+ − 680 value, Qhash_table, errb);
428
+ − 681 return 0;
+ − 682 }
+ − 683
+ − 684 static enum hash_table_test
+ − 685 decode_hash_table_test (Lisp_Object obj)
+ − 686 {
+ − 687 if (EQ (obj, Qnil)) return HASH_TABLE_EQL;
+ − 688 if (EQ (obj, Qeq)) return HASH_TABLE_EQ;
+ − 689 if (EQ (obj, Qequal)) return HASH_TABLE_EQUAL;
+ − 690 if (EQ (obj, Qeql)) return HASH_TABLE_EQL;
+ − 691
563
+ − 692 invalid_constant ("Invalid hash table test", obj);
1204
+ − 693 RETURN_NOT_REACHED (HASH_TABLE_EQ);
428
+ − 694 }
+ − 695
+ − 696 static int
2286
+ − 697 hash_table_rehash_size_validate (Lisp_Object UNUSED (keyword),
+ − 698 Lisp_Object value, Error_Behavior errb)
428
+ − 699 {
+ − 700 if (!FLOATP (value))
+ − 701 {
563
+ − 702 maybe_signal_error_1 (Qwrong_type_argument, list2 (Qfloatp, value),
428
+ − 703 Qhash_table, errb);
+ − 704 return 0;
+ − 705 }
+ − 706
+ − 707 {
+ − 708 double rehash_size = XFLOAT_DATA (value);
+ − 709 if (rehash_size <= 1.0)
+ − 710 {
563
+ − 711 maybe_invalid_argument
428
+ − 712 ("Hash table rehash size must be greater than 1.0",
+ − 713 value, Qhash_table, errb);
+ − 714 return 0;
+ − 715 }
+ − 716 }
+ − 717
+ − 718 return 1;
+ − 719 }
+ − 720
+ − 721 static double
+ − 722 decode_hash_table_rehash_size (Lisp_Object rehash_size)
+ − 723 {
+ − 724 return NILP (rehash_size) ? -1.0 : XFLOAT_DATA (rehash_size);
+ − 725 }
+ − 726
+ − 727 static int
2286
+ − 728 hash_table_rehash_threshold_validate (Lisp_Object UNUSED (keyword),
+ − 729 Lisp_Object value, Error_Behavior errb)
428
+ − 730 {
+ − 731 if (!FLOATP (value))
+ − 732 {
563
+ − 733 maybe_signal_error_1 (Qwrong_type_argument, list2 (Qfloatp, value),
428
+ − 734 Qhash_table, errb);
+ − 735 return 0;
+ − 736 }
+ − 737
+ − 738 {
+ − 739 double rehash_threshold = XFLOAT_DATA (value);
+ − 740 if (rehash_threshold <= 0.0 || rehash_threshold >= 1.0)
+ − 741 {
563
+ − 742 maybe_invalid_argument
428
+ − 743 ("Hash table rehash threshold must be between 0.0 and 1.0",
+ − 744 value, Qhash_table, errb);
+ − 745 return 0;
+ − 746 }
+ − 747 }
+ − 748
+ − 749 return 1;
+ − 750 }
+ − 751
+ − 752 static double
+ − 753 decode_hash_table_rehash_threshold (Lisp_Object rehash_threshold)
+ − 754 {
+ − 755 return NILP (rehash_threshold) ? -1.0 : XFLOAT_DATA (rehash_threshold);
+ − 756 }
+ − 757
+ − 758 static int
2286
+ − 759 hash_table_data_validate (Lisp_Object UNUSED (keyword), Lisp_Object value,
+ − 760 Error_Behavior errb)
428
+ − 761 {
+ − 762 int len;
+ − 763
+ − 764 GET_EXTERNAL_LIST_LENGTH (value, len);
+ − 765
+ − 766 if (len & 1)
+ − 767 {
563
+ − 768 maybe_sferror
428
+ − 769 ("Hash table data must have alternating key/value pairs",
+ − 770 value, Qhash_table, errb);
+ − 771 return 0;
+ − 772 }
+ − 773 return 1;
+ − 774 }
+ − 775
+ − 776 /* The actual instantiation of a hash table. This does practically no
+ − 777 error checking, because it relies on the fact that the paranoid
+ − 778 functions above have error-checked everything to the last details.
+ − 779 If this assumption is wrong, we will get a crash immediately (with
+ − 780 error-checking compiled in), and we'll know if there is a bug in
+ − 781 the structure mechanism. So there. */
+ − 782 static Lisp_Object
+ − 783 hash_table_instantiate (Lisp_Object plist)
+ − 784 {
+ − 785 Lisp_Object hash_table;
+ − 786 Lisp_Object test = Qnil;
+ − 787 Lisp_Object size = Qnil;
+ − 788 Lisp_Object rehash_size = Qnil;
+ − 789 Lisp_Object rehash_threshold = Qnil;
+ − 790 Lisp_Object weakness = Qnil;
+ − 791 Lisp_Object data = Qnil;
+ − 792
+ − 793 while (!NILP (plist))
+ − 794 {
+ − 795 Lisp_Object key, value;
+ − 796 key = XCAR (plist); plist = XCDR (plist);
+ − 797 value = XCAR (plist); plist = XCDR (plist);
+ − 798
+ − 799 if (EQ (key, Qtest)) test = value;
+ − 800 else if (EQ (key, Qsize)) size = value;
+ − 801 else if (EQ (key, Qrehash_size)) rehash_size = value;
+ − 802 else if (EQ (key, Qrehash_threshold)) rehash_threshold = value;
+ − 803 else if (EQ (key, Qweakness)) weakness = value;
+ − 804 else if (EQ (key, Qdata)) data = value;
+ − 805 else if (EQ (key, Qtype))/*obsolete*/ weakness = value;
+ − 806 else
+ − 807 abort ();
+ − 808 }
+ − 809
+ − 810 /* Create the hash table. */
450
+ − 811 hash_table = make_standard_lisp_hash_table
428
+ − 812 (decode_hash_table_test (test),
+ − 813 decode_hash_table_size (size),
+ − 814 decode_hash_table_rehash_size (rehash_size),
+ − 815 decode_hash_table_rehash_threshold (rehash_threshold),
+ − 816 decode_hash_table_weakness (weakness));
+ − 817
+ − 818 /* I'm not sure whether this can GC, but better safe than sorry. */
+ − 819 {
+ − 820 struct gcpro gcpro1;
+ − 821 GCPRO1 (hash_table);
+ − 822
+ − 823 /* And fill it with data. */
+ − 824 while (!NILP (data))
+ − 825 {
+ − 826 Lisp_Object key, value;
+ − 827 key = XCAR (data); data = XCDR (data);
+ − 828 value = XCAR (data); data = XCDR (data);
+ − 829 Fputhash (key, value, hash_table);
+ − 830 }
+ − 831 UNGCPRO;
+ − 832 }
+ − 833
+ − 834 return hash_table;
+ − 835 }
+ − 836
+ − 837 static void
+ − 838 structure_type_create_hash_table_structure_name (Lisp_Object structure_name)
+ − 839 {
+ − 840 struct structure_type *st;
+ − 841
+ − 842 st = define_structure_type (structure_name, 0, hash_table_instantiate);
+ − 843 define_structure_type_keyword (st, Qtest, hash_table_test_validate);
+ − 844 define_structure_type_keyword (st, Qsize, hash_table_size_validate);
+ − 845 define_structure_type_keyword (st, Qrehash_size, hash_table_rehash_size_validate);
+ − 846 define_structure_type_keyword (st, Qrehash_threshold, hash_table_rehash_threshold_validate);
+ − 847 define_structure_type_keyword (st, Qweakness, hash_table_weakness_validate);
+ − 848 define_structure_type_keyword (st, Qdata, hash_table_data_validate);
+ − 849
+ − 850 /* obsolete as of 19990901 in xemacs-21.2 */
+ − 851 define_structure_type_keyword (st, Qtype, hash_table_weakness_validate);
+ − 852 }
+ − 853
+ − 854 /* Create a built-in Lisp structure type named `hash-table'.
+ − 855 We make #s(hashtable ...) equivalent to #s(hash-table ...),
+ − 856 for backward compatibility.
+ − 857 This is called from emacs.c. */
+ − 858 void
+ − 859 structure_type_create_hash_table (void)
+ − 860 {
+ − 861 structure_type_create_hash_table_structure_name (Qhash_table);
+ − 862 structure_type_create_hash_table_structure_name (Qhashtable); /* compat */
+ − 863 }
+ − 864
+ − 865
+ − 866 /************************************************************************/
+ − 867 /* Definition of Lisp-visible methods */
+ − 868 /************************************************************************/
+ − 869
+ − 870 DEFUN ("hash-table-p", Fhash_table_p, 1, 1, 0, /*
+ − 871 Return t if OBJECT is a hash table, else nil.
+ − 872 */
+ − 873 (object))
+ − 874 {
+ − 875 return HASH_TABLEP (object) ? Qt : Qnil;
+ − 876 }
+ − 877
+ − 878 DEFUN ("make-hash-table", Fmake_hash_table, 0, MANY, 0, /*
+ − 879 Return a new empty hash table object.
+ − 880 Use Common Lisp style keywords to specify hash table properties.
+ − 881 (make-hash-table &key test size rehash-size rehash-threshold weakness)
+ − 882
+ − 883 Keyword :test can be `eq', `eql' (default) or `equal'.
+ − 884 Comparison between keys is done using this function.
+ − 885 If speed is important, consider using `eq'.
+ − 886 When storing strings in the hash table, you will likely need to use `equal'.
+ − 887
+ − 888 Keyword :size specifies the number of keys likely to be inserted.
+ − 889 This number of entries can be inserted without enlarging the hash table.
+ − 890
+ − 891 Keyword :rehash-size must be a float greater than 1.0, and specifies
+ − 892 the factor by which to increase the size of the hash table when enlarging.
+ − 893
+ − 894 Keyword :rehash-threshold must be a float between 0.0 and 1.0,
+ − 895 and specifies the load factor of the hash table which triggers enlarging.
+ − 896
442
+ − 897 Non-standard keyword :weakness can be `nil' (default), `t', `key-and-value',
+ − 898 `key', `value' or `key-or-value'. `t' is an alias for `key-and-value'.
428
+ − 899
442
+ − 900 A key-and-value-weak hash table, also known as a fully-weak or simply
+ − 901 as a weak hash table, is one whose pointers do not count as GC
+ − 902 referents: for any key-value pair in the hash table, if the only
+ − 903 remaining pointer to either the key or the value is in a weak hash
+ − 904 table, then the pair will be removed from the hash table, and the key
+ − 905 and value collected. A non-weak hash table (or any other pointer)
+ − 906 would prevent the object from being collected.
428
+ − 907
+ − 908 A key-weak hash table is similar to a fully-weak hash table except that
+ − 909 a key-value pair will be removed only if the key remains unmarked
+ − 910 outside of weak hash tables. The pair will remain in the hash table if
+ − 911 the key is pointed to by something other than a weak hash table, even
+ − 912 if the value is not.
+ − 913
+ − 914 A 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 remains
+ − 916 unmarked outside of weak hash tables. The pair will remain in the
+ − 917 hash table if the value is pointed to by something other than a weak
+ − 918 hash table, even if the key is not.
442
+ − 919
+ − 920 A key-or-value-weak hash table is similar to a fully-weak hash table except
+ − 921 that a key-value pair will be removed only if the value and the key remain
+ − 922 unmarked outside of weak hash tables. The pair will remain in the
+ − 923 hash table if the value or key are pointed to by something other than a weak
+ − 924 hash table, even if the other is not.
428
+ − 925 */
+ − 926 (int nargs, Lisp_Object *args))
+ − 927 {
+ − 928 int i = 0;
+ − 929 Lisp_Object test = Qnil;
+ − 930 Lisp_Object size = Qnil;
+ − 931 Lisp_Object rehash_size = Qnil;
+ − 932 Lisp_Object rehash_threshold = Qnil;
+ − 933 Lisp_Object weakness = Qnil;
+ − 934
+ − 935 while (i + 1 < nargs)
+ − 936 {
+ − 937 Lisp_Object keyword = args[i++];
+ − 938 Lisp_Object value = args[i++];
+ − 939
+ − 940 if (EQ (keyword, Q_test)) test = value;
+ − 941 else if (EQ (keyword, Q_size)) size = value;
+ − 942 else if (EQ (keyword, Q_rehash_size)) rehash_size = value;
+ − 943 else if (EQ (keyword, Q_rehash_threshold)) rehash_threshold = value;
+ − 944 else if (EQ (keyword, Q_weakness)) weakness = value;
+ − 945 else if (EQ (keyword, Q_type))/*obsolete*/ weakness = value;
563
+ − 946 else invalid_constant ("Invalid hash table property keyword", keyword);
428
+ − 947 }
+ − 948
+ − 949 if (i < nargs)
563
+ − 950 sferror ("Hash table property requires a value", args[i]);
428
+ − 951
+ − 952 #define VALIDATE_VAR(var) \
+ − 953 if (!NILP (var)) hash_table_##var##_validate (Q##var, var, ERROR_ME);
+ − 954
+ − 955 VALIDATE_VAR (test);
+ − 956 VALIDATE_VAR (size);
+ − 957 VALIDATE_VAR (rehash_size);
+ − 958 VALIDATE_VAR (rehash_threshold);
+ − 959 VALIDATE_VAR (weakness);
+ − 960
450
+ − 961 return make_standard_lisp_hash_table
428
+ − 962 (decode_hash_table_test (test),
+ − 963 decode_hash_table_size (size),
+ − 964 decode_hash_table_rehash_size (rehash_size),
+ − 965 decode_hash_table_rehash_threshold (rehash_threshold),
+ − 966 decode_hash_table_weakness (weakness));
+ − 967 }
+ − 968
+ − 969 DEFUN ("copy-hash-table", Fcopy_hash_table, 1, 1, 0, /*
+ − 970 Return a new hash table containing the same keys and values as HASH-TABLE.
+ − 971 The keys and values will not themselves be copied.
+ − 972 */
+ − 973 (hash_table))
+ − 974 {
442
+ − 975 const Lisp_Hash_Table *ht_old = xhash_table (hash_table);
428
+ − 976 Lisp_Hash_Table *ht = alloc_lcrecord_type (Lisp_Hash_Table, &lrecord_hash_table);
+ − 977
+ − 978 copy_lcrecord (ht, ht_old);
+ − 979
1204
+ − 980 ht->hentries = xnew_array (htentry, ht_old->size + 1);
+ − 981 memcpy (ht->hentries, ht_old->hentries, (ht_old->size + 1) * sizeof (htentry));
428
+ − 982
793
+ − 983 hash_table = wrap_hash_table (ht);
428
+ − 984
+ − 985 if (! EQ (ht->next_weak, Qunbound))
+ − 986 {
+ − 987 ht->next_weak = Vall_weak_hash_tables;
+ − 988 Vall_weak_hash_tables = hash_table;
+ − 989 }
+ − 990
+ − 991 return hash_table;
+ − 992 }
+ − 993
+ − 994 static void
665
+ − 995 resize_hash_table (Lisp_Hash_Table *ht, Elemcount new_size)
428
+ − 996 {
1204
+ − 997 htentry *old_entries, *new_entries, *sentinel, *e;
665
+ − 998 Elemcount old_size;
428
+ − 999
+ − 1000 old_size = ht->size;
+ − 1001 ht->size = new_size;
+ − 1002
+ − 1003 old_entries = ht->hentries;
+ − 1004
1204
+ − 1005 ht->hentries = xnew_array_and_zero (htentry, new_size + 1);
428
+ − 1006 new_entries = ht->hentries;
+ − 1007
+ − 1008 compute_hash_table_derived_values (ht);
+ − 1009
440
+ − 1010 for (e = old_entries, sentinel = e + old_size; e < sentinel; e++)
1204
+ − 1011 if (!HTENTRY_CLEAR_P (e))
428
+ − 1012 {
1204
+ − 1013 htentry *probe = new_entries + HASHCODE (e->key, ht);
428
+ − 1014 LINEAR_PROBING_LOOP (probe, new_entries, new_size)
+ − 1015 ;
+ − 1016 *probe = *e;
+ − 1017 }
+ − 1018
489
+ − 1019 free_hentries (old_entries, old_size);
428
+ − 1020 }
+ − 1021
440
+ − 1022 /* After a hash table has been saved to disk and later restored by the
+ − 1023 portable dumper, it contains the same objects, but their addresses
665
+ − 1024 and thus their HASHCODEs have changed. */
428
+ − 1025 void
440
+ − 1026 pdump_reorganize_hash_table (Lisp_Object hash_table)
428
+ − 1027 {
442
+ − 1028 const Lisp_Hash_Table *ht = xhash_table (hash_table);
1204
+ − 1029 htentry *new_entries = xnew_array_and_zero (htentry, ht->size + 1);
+ − 1030 htentry *e, *sentinel;
440
+ − 1031
+ − 1032 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1204
+ − 1033 if (!HTENTRY_CLEAR_P (e))
440
+ − 1034 {
1204
+ − 1035 htentry *probe = new_entries + HASHCODE (e->key, ht);
440
+ − 1036 LINEAR_PROBING_LOOP (probe, new_entries, ht->size)
+ − 1037 ;
+ − 1038 *probe = *e;
+ − 1039 }
+ − 1040
1204
+ − 1041 memcpy (ht->hentries, new_entries, ht->size * sizeof (htentry));
440
+ − 1042
1726
+ − 1043 xfree (new_entries, htentry *);
428
+ − 1044 }
+ − 1045
+ − 1046 static void
+ − 1047 enlarge_hash_table (Lisp_Hash_Table *ht)
+ − 1048 {
665
+ − 1049 Elemcount new_size =
+ − 1050 hash_table_size ((Elemcount) ((double) ht->size * ht->rehash_size));
428
+ − 1051 resize_hash_table (ht, new_size);
+ − 1052 }
+ − 1053
1204
+ − 1054 static htentry *
+ − 1055 find_htentry (Lisp_Object key, const Lisp_Hash_Table *ht)
428
+ − 1056 {
+ − 1057 hash_table_test_function_t test_function = ht->test_function;
1204
+ − 1058 htentry *entries = ht->hentries;
+ − 1059 htentry *probe = entries + HASHCODE (key, ht);
428
+ − 1060
+ − 1061 LINEAR_PROBING_LOOP (probe, entries, ht->size)
+ − 1062 if (KEYS_EQUAL_P (probe->key, key, test_function))
+ − 1063 break;
+ − 1064
+ − 1065 return probe;
+ − 1066 }
+ − 1067
+ − 1068 DEFUN ("gethash", Fgethash, 2, 3, 0, /*
+ − 1069 Find hash value for KEY in HASH-TABLE.
+ − 1070 If there is no corresponding value, return DEFAULT (which defaults to nil).
+ − 1071 */
+ − 1072 (key, hash_table, default_))
+ − 1073 {
442
+ − 1074 const Lisp_Hash_Table *ht = xhash_table (hash_table);
1204
+ − 1075 htentry *e = find_htentry (key, ht);
428
+ − 1076
1204
+ − 1077 return HTENTRY_CLEAR_P (e) ? default_ : e->value;
428
+ − 1078 }
+ − 1079
+ − 1080 DEFUN ("puthash", Fputhash, 3, 3, 0, /*
+ − 1081 Hash KEY to VALUE in HASH-TABLE.
+ − 1082 */
+ − 1083 (key, value, hash_table))
+ − 1084 {
+ − 1085 Lisp_Hash_Table *ht = xhash_table (hash_table);
1204
+ − 1086 htentry *e = find_htentry (key, ht);
428
+ − 1087
1204
+ − 1088 if (!HTENTRY_CLEAR_P (e))
428
+ − 1089 return e->value = value;
+ − 1090
+ − 1091 e->key = key;
+ − 1092 e->value = value;
+ − 1093
+ − 1094 if (++ht->count >= ht->rehash_count)
+ − 1095 enlarge_hash_table (ht);
+ − 1096
+ − 1097 return value;
+ − 1098 }
+ − 1099
1204
+ − 1100 /* Remove htentry pointed at by PROBE.
428
+ − 1101 Subsequent entries are removed and reinserted.
+ − 1102 We don't use tombstones - too wasteful. */
+ − 1103 static void
1204
+ − 1104 remhash_1 (Lisp_Hash_Table *ht, htentry *entries, htentry *probe)
428
+ − 1105 {
665
+ − 1106 Elemcount size = ht->size;
1204
+ − 1107 CLEAR_HTENTRY (probe);
428
+ − 1108 probe++;
+ − 1109 ht->count--;
+ − 1110
+ − 1111 LINEAR_PROBING_LOOP (probe, entries, size)
+ − 1112 {
+ − 1113 Lisp_Object key = probe->key;
1204
+ − 1114 htentry *probe2 = entries + HASHCODE (key, ht);
428
+ − 1115 LINEAR_PROBING_LOOP (probe2, entries, size)
+ − 1116 if (EQ (probe2->key, key))
1204
+ − 1117 /* htentry at probe doesn't need to move. */
428
+ − 1118 goto continue_outer_loop;
1204
+ − 1119 /* Move htentry from probe to new home at probe2. */
428
+ − 1120 *probe2 = *probe;
1204
+ − 1121 CLEAR_HTENTRY (probe);
428
+ − 1122 continue_outer_loop: continue;
+ − 1123 }
+ − 1124 }
+ − 1125
+ − 1126 DEFUN ("remhash", Fremhash, 2, 2, 0, /*
+ − 1127 Remove the entry for KEY from HASH-TABLE.
+ − 1128 Do nothing if there is no entry for KEY in HASH-TABLE.
617
+ − 1129 Return non-nil if an entry was removed.
428
+ − 1130 */
+ − 1131 (key, hash_table))
+ − 1132 {
+ − 1133 Lisp_Hash_Table *ht = xhash_table (hash_table);
1204
+ − 1134 htentry *e = find_htentry (key, ht);
428
+ − 1135
1204
+ − 1136 if (HTENTRY_CLEAR_P (e))
428
+ − 1137 return Qnil;
+ − 1138
+ − 1139 remhash_1 (ht, ht->hentries, e);
+ − 1140 return Qt;
+ − 1141 }
+ − 1142
+ − 1143 DEFUN ("clrhash", Fclrhash, 1, 1, 0, /*
+ − 1144 Remove all entries from HASH-TABLE, leaving it empty.
+ − 1145 */
+ − 1146 (hash_table))
+ − 1147 {
+ − 1148 Lisp_Hash_Table *ht = xhash_table (hash_table);
1204
+ − 1149 htentry *e, *sentinel;
428
+ − 1150
+ − 1151 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1204
+ − 1152 CLEAR_HTENTRY (e);
428
+ − 1153 ht->count = 0;
+ − 1154
+ − 1155 return hash_table;
+ − 1156 }
+ − 1157
+ − 1158 /************************************************************************/
+ − 1159 /* Accessor Functions */
+ − 1160 /************************************************************************/
+ − 1161
+ − 1162 DEFUN ("hash-table-count", Fhash_table_count, 1, 1, 0, /*
+ − 1163 Return the number of entries in HASH-TABLE.
+ − 1164 */
+ − 1165 (hash_table))
+ − 1166 {
+ − 1167 return make_int (xhash_table (hash_table)->count);
+ − 1168 }
+ − 1169
+ − 1170 DEFUN ("hash-table-test", Fhash_table_test, 1, 1, 0, /*
+ − 1171 Return the test function of HASH-TABLE.
+ − 1172 This can be one of `eq', `eql' or `equal'.
+ − 1173 */
+ − 1174 (hash_table))
+ − 1175 {
+ − 1176 hash_table_test_function_t fun = xhash_table (hash_table)->test_function;
+ − 1177
+ − 1178 return (fun == lisp_object_eql_equal ? Qeql :
+ − 1179 fun == lisp_object_equal_equal ? Qequal :
+ − 1180 Qeq);
+ − 1181 }
+ − 1182
+ − 1183 DEFUN ("hash-table-size", Fhash_table_size, 1, 1, 0, /*
+ − 1184 Return the size of HASH-TABLE.
+ − 1185 This is the current number of slots in HASH-TABLE, whether occupied or not.
+ − 1186 */
+ − 1187 (hash_table))
+ − 1188 {
+ − 1189 return make_int (xhash_table (hash_table)->size);
+ − 1190 }
+ − 1191
+ − 1192 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size, 1, 1, 0, /*
+ − 1193 Return the current rehash size of HASH-TABLE.
+ − 1194 This is a float greater than 1.0; the factor by which HASH-TABLE
+ − 1195 is enlarged when the rehash threshold is exceeded.
+ − 1196 */
+ − 1197 (hash_table))
+ − 1198 {
+ − 1199 return make_float (xhash_table (hash_table)->rehash_size);
+ − 1200 }
+ − 1201
+ − 1202 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold, 1, 1, 0, /*
+ − 1203 Return the current rehash threshold of HASH-TABLE.
+ − 1204 This is a float between 0.0 and 1.0; the maximum `load factor' of HASH-TABLE,
+ − 1205 beyond which the HASH-TABLE is enlarged by rehashing.
+ − 1206 */
+ − 1207 (hash_table))
+ − 1208 {
438
+ − 1209 return make_float (xhash_table (hash_table)->rehash_threshold);
428
+ − 1210 }
+ − 1211
+ − 1212 DEFUN ("hash-table-weakness", Fhash_table_weakness, 1, 1, 0, /*
+ − 1213 Return the weakness of HASH-TABLE.
442
+ − 1214 This can be one of `nil', `key-and-value', `key-or-value', `key' or `value'.
428
+ − 1215 */
+ − 1216 (hash_table))
+ − 1217 {
+ − 1218 switch (xhash_table (hash_table)->weakness)
+ − 1219 {
442
+ − 1220 case HASH_TABLE_WEAK: return Qkey_and_value;
+ − 1221 case HASH_TABLE_KEY_WEAK: return Qkey;
+ − 1222 case HASH_TABLE_KEY_VALUE_WEAK: return Qkey_or_value;
+ − 1223 case HASH_TABLE_VALUE_WEAK: return Qvalue;
+ − 1224 default: return Qnil;
428
+ − 1225 }
+ − 1226 }
+ − 1227
+ − 1228 /* obsolete as of 19990901 in xemacs-21.2 */
+ − 1229 DEFUN ("hash-table-type", Fhash_table_type, 1, 1, 0, /*
+ − 1230 Return the type of HASH-TABLE.
+ − 1231 This can be one of `non-weak', `weak', `key-weak' or `value-weak'.
+ − 1232 */
+ − 1233 (hash_table))
+ − 1234 {
+ − 1235 switch (xhash_table (hash_table)->weakness)
+ − 1236 {
442
+ − 1237 case HASH_TABLE_WEAK: return Qweak;
+ − 1238 case HASH_TABLE_KEY_WEAK: return Qkey_weak;
+ − 1239 case HASH_TABLE_KEY_VALUE_WEAK: return Qkey_or_value_weak;
+ − 1240 case HASH_TABLE_VALUE_WEAK: return Qvalue_weak;
+ − 1241 default: return Qnon_weak;
428
+ − 1242 }
+ − 1243 }
+ − 1244
+ − 1245 /************************************************************************/
+ − 1246 /* Mapping Functions */
+ − 1247 /************************************************************************/
489
+ − 1248
+ − 1249 /* We need to be careful when mapping over hash tables because the
+ − 1250 hash table might be modified during the mapping operation:
+ − 1251 - by the mapping function
+ − 1252 - by gc (if the hash table is weak)
+ − 1253
+ − 1254 So we make a copy of the hentries at the beginning of the mapping
497
+ − 1255 operation, and iterate over the copy. Naturally, this is
+ − 1256 expensive, but not as expensive as you might think, because no
+ − 1257 actual memory has to be collected by our notoriously inefficient
+ − 1258 GC; we use an unwind-protect instead to free the memory directly.
+ − 1259
+ − 1260 We could avoid the copying by having the hash table modifiers
+ − 1261 puthash and remhash check for currently active mapping functions.
+ − 1262 Disadvantages: it's hard to get right, and IMO hash mapping
+ − 1263 functions are basically rare, and no extra space in the hash table
+ − 1264 object and no extra cpu in puthash or remhash should be wasted to
+ − 1265 make maphash 3% faster. From a design point of view, the basic
+ − 1266 functions gethash, puthash and remhash should be implementable
+ − 1267 without having to think about maphash.
+ − 1268
+ − 1269 Note: We don't (yet) have Common Lisp's with-hash-table-iterator.
+ − 1270 If you implement this naively, you cannot have more than one
+ − 1271 concurrently active iterator over the same hash table. The `each'
+ − 1272 function in perl has this limitation.
+ − 1273
+ − 1274 Note: We GCPRO memory on the heap, not on the stack. There is no
+ − 1275 obvious reason why this is bad, but as of this writing this is the
+ − 1276 only known occurrence of this technique in the code.
504
+ − 1277
+ − 1278 -- Martin
+ − 1279 */
+ − 1280
+ − 1281 /* Ben disagrees with the "copying hentries" design, and says:
+ − 1282
+ − 1283 Another solution is the same as I've already proposed -- when
+ − 1284 mapping, mark the table as "change-unsafe", and in this case, use a
+ − 1285 secondary table to maintain changes. this could be basically a
+ − 1286 standard hash table, but with entries only for added or deleted
+ − 1287 entries in the primary table, and a marker like Qunbound to
+ − 1288 indicate a deleted entry. puthash, gethash and remhash need a
+ − 1289 single extra check for this secondary table -- totally
+ − 1290 insignificant speedwise. if you really cared about making
+ − 1291 recursive maphashes completely correct, you'd have to do a bit of
+ − 1292 extra work here -- when maphashing, if the secondary table exists,
+ − 1293 make a copy of it, and use the copy in conjunction with the primary
+ − 1294 table when mapping. the advantages of this are
+ − 1295
+ − 1296 [a] easy to demonstrate correct, even with weak hashtables.
+ − 1297
+ − 1298 [b] no extra overhead in the general maphash case -- only when you
+ − 1299 modify the table while maphashing, and even then the overhead is
+ − 1300 very small.
497
+ − 1301 */
+ − 1302
489
+ − 1303 static Lisp_Object
+ − 1304 maphash_unwind (Lisp_Object unwind_obj)
+ − 1305 {
+ − 1306 void *ptr = (void *) get_opaque_ptr (unwind_obj);
1726
+ − 1307 xfree (ptr, void *);
489
+ − 1308 free_opaque_ptr (unwind_obj);
+ − 1309 return Qnil;
+ − 1310 }
+ − 1311
+ − 1312 /* Return a malloced array of alternating key/value pairs from HT. */
+ − 1313 static Lisp_Object *
+ − 1314 copy_compress_hentries (const Lisp_Hash_Table *ht)
+ − 1315 {
+ − 1316 Lisp_Object * const objs =
+ − 1317 /* If the hash table is empty, ht->count could be 0. */
+ − 1318 xnew_array (Lisp_Object, 2 * (ht->count > 0 ? ht->count : 1));
1204
+ − 1319 const htentry *e, *sentinel;
489
+ − 1320 Lisp_Object *pobj;
+ − 1321
+ − 1322 for (e = ht->hentries, sentinel = e + ht->size, pobj = objs; e < sentinel; e++)
1204
+ − 1323 if (!HTENTRY_CLEAR_P (e))
489
+ − 1324 {
+ − 1325 *(pobj++) = e->key;
+ − 1326 *(pobj++) = e->value;
+ − 1327 }
+ − 1328
+ − 1329 type_checking_assert (pobj == objs + 2 * ht->count);
+ − 1330
+ − 1331 return objs;
+ − 1332 }
+ − 1333
428
+ − 1334 DEFUN ("maphash", Fmaphash, 2, 2, 0, /*
+ − 1335 Map FUNCTION over entries in HASH-TABLE, calling it with two args,
+ − 1336 each key and value in HASH-TABLE.
+ − 1337
489
+ − 1338 FUNCTION must not modify HASH-TABLE, with the one exception that FUNCTION
428
+ − 1339 may remhash or puthash the entry currently being processed by FUNCTION.
+ − 1340 */
+ − 1341 (function, hash_table))
+ − 1342 {
489
+ − 1343 const Lisp_Hash_Table * const ht = xhash_table (hash_table);
+ − 1344 Lisp_Object * const objs = copy_compress_hentries (ht);
+ − 1345 Lisp_Object args[3];
+ − 1346 const Lisp_Object *pobj, *end;
+ − 1347 int speccount = specpdl_depth ();
+ − 1348 struct gcpro gcpro1;
+ − 1349
+ − 1350 record_unwind_protect (maphash_unwind, make_opaque_ptr ((void *)objs));
+ − 1351 GCPRO1 (objs[0]);
+ − 1352 gcpro1.nvars = 2 * ht->count;
428
+ − 1353
489
+ − 1354 args[0] = function;
+ − 1355
+ − 1356 for (pobj = objs, end = pobj + 2 * ht->count; pobj < end; pobj += 2)
+ − 1357 {
+ − 1358 args[1] = pobj[0];
+ − 1359 args[2] = pobj[1];
+ − 1360 Ffuncall (countof (args), args);
+ − 1361 }
+ − 1362
771
+ − 1363 unbind_to (speccount);
489
+ − 1364 UNGCPRO;
428
+ − 1365
+ − 1366 return Qnil;
+ − 1367 }
+ − 1368
489
+ − 1369 /* Map *C* function FUNCTION over the elements of a non-weak lisp hash table.
+ − 1370 FUNCTION must not modify HASH-TABLE, with the one exception that FUNCTION
+ − 1371 may puthash the entry currently being processed by FUNCTION.
+ − 1372 Mapping terminates if FUNCTION returns something other than 0. */
428
+ − 1373 void
489
+ − 1374 elisp_maphash_unsafe (maphash_function_t function,
428
+ − 1375 Lisp_Object hash_table, void *extra_arg)
+ − 1376 {
442
+ − 1377 const Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1204
+ − 1378 const htentry *e, *sentinel;
428
+ − 1379
+ − 1380 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1204
+ − 1381 if (!HTENTRY_CLEAR_P (e))
489
+ − 1382 if (function (e->key, e->value, extra_arg))
+ − 1383 return;
428
+ − 1384 }
+ − 1385
489
+ − 1386 /* Map *C* function FUNCTION over the elements of a lisp hash table.
+ − 1387 It is safe for FUNCTION to modify HASH-TABLE.
+ − 1388 Mapping terminates if FUNCTION returns something other than 0. */
+ − 1389 void
+ − 1390 elisp_maphash (maphash_function_t function,
+ − 1391 Lisp_Object hash_table, void *extra_arg)
+ − 1392 {
+ − 1393 const Lisp_Hash_Table * const ht = xhash_table (hash_table);
+ − 1394 Lisp_Object * const objs = copy_compress_hentries (ht);
+ − 1395 const Lisp_Object *pobj, *end;
+ − 1396 int speccount = specpdl_depth ();
+ − 1397 struct gcpro gcpro1;
+ − 1398
+ − 1399 record_unwind_protect (maphash_unwind, make_opaque_ptr ((void *)objs));
+ − 1400 GCPRO1 (objs[0]);
+ − 1401 gcpro1.nvars = 2 * ht->count;
+ − 1402
+ − 1403 for (pobj = objs, end = pobj + 2 * ht->count; pobj < end; pobj += 2)
+ − 1404 if (function (pobj[0], pobj[1], extra_arg))
+ − 1405 break;
+ − 1406
771
+ − 1407 unbind_to (speccount);
489
+ − 1408 UNGCPRO;
+ − 1409 }
+ − 1410
+ − 1411 /* Remove all elements of a lisp hash table satisfying *C* predicate PREDICATE.
+ − 1412 PREDICATE must not modify HASH-TABLE. */
428
+ − 1413 void
+ − 1414 elisp_map_remhash (maphash_function_t predicate,
+ − 1415 Lisp_Object hash_table, void *extra_arg)
+ − 1416 {
489
+ − 1417 const Lisp_Hash_Table * const ht = xhash_table (hash_table);
+ − 1418 Lisp_Object * const objs = copy_compress_hentries (ht);
+ − 1419 const Lisp_Object *pobj, *end;
+ − 1420 int speccount = specpdl_depth ();
+ − 1421 struct gcpro gcpro1;
428
+ − 1422
489
+ − 1423 record_unwind_protect (maphash_unwind, make_opaque_ptr ((void *)objs));
+ − 1424 GCPRO1 (objs[0]);
+ − 1425 gcpro1.nvars = 2 * ht->count;
+ − 1426
+ − 1427 for (pobj = objs, end = pobj + 2 * ht->count; pobj < end; pobj += 2)
+ − 1428 if (predicate (pobj[0], pobj[1], extra_arg))
+ − 1429 Fremhash (pobj[0], hash_table);
+ − 1430
771
+ − 1431 unbind_to (speccount);
489
+ − 1432 UNGCPRO;
428
+ − 1433 }
+ − 1434
+ − 1435
+ − 1436 /************************************************************************/
+ − 1437 /* garbage collecting weak hash tables */
+ − 1438 /************************************************************************/
1598
+ − 1439 #ifdef USE_KKCC
+ − 1440 #define MARK_OBJ(obj) do { \
+ − 1441 Lisp_Object mo_obj = (obj); \
+ − 1442 if (!marked_p (mo_obj)) \
+ − 1443 { \
+ − 1444 kkcc_gc_stack_push_lisp_object (mo_obj); \
+ − 1445 did_mark = 1; \
+ − 1446 } \
+ − 1447 } while (0)
+ − 1448
+ − 1449 #else /* NO USE_KKCC */
+ − 1450
442
+ − 1451 #define MARK_OBJ(obj) do { \
+ − 1452 Lisp_Object mo_obj = (obj); \
+ − 1453 if (!marked_p (mo_obj)) \
+ − 1454 { \
+ − 1455 mark_object (mo_obj); \
+ − 1456 did_mark = 1; \
+ − 1457 } \
+ − 1458 } while (0)
1598
+ − 1459 #endif /*NO USE_KKCC */
442
+ − 1460
428
+ − 1461
+ − 1462 /* Complete the marking for semi-weak hash tables. */
+ − 1463 int
+ − 1464 finish_marking_weak_hash_tables (void)
+ − 1465 {
+ − 1466 Lisp_Object hash_table;
+ − 1467 int did_mark = 0;
+ − 1468
+ − 1469 for (hash_table = Vall_weak_hash_tables;
+ − 1470 !NILP (hash_table);
+ − 1471 hash_table = XHASH_TABLE (hash_table)->next_weak)
+ − 1472 {
442
+ − 1473 const Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1204
+ − 1474 const htentry *e = ht->hentries;
+ − 1475 const htentry *sentinel = e + ht->size;
428
+ − 1476
+ − 1477 if (! marked_p (hash_table))
+ − 1478 /* The hash table is probably garbage. Ignore it. */
+ − 1479 continue;
+ − 1480
+ − 1481 /* Now, scan over all the pairs. For all pairs that are
+ − 1482 half-marked, we may need to mark the other half if we're
+ − 1483 keeping this pair. */
+ − 1484 switch (ht->weakness)
+ − 1485 {
+ − 1486 case HASH_TABLE_KEY_WEAK:
+ − 1487 for (; e < sentinel; e++)
1204
+ − 1488 if (!HTENTRY_CLEAR_P (e))
428
+ − 1489 if (marked_p (e->key))
+ − 1490 MARK_OBJ (e->value);
+ − 1491 break;
+ − 1492
+ − 1493 case HASH_TABLE_VALUE_WEAK:
+ − 1494 for (; e < sentinel; e++)
1204
+ − 1495 if (!HTENTRY_CLEAR_P (e))
428
+ − 1496 if (marked_p (e->value))
+ − 1497 MARK_OBJ (e->key);
+ − 1498 break;
+ − 1499
442
+ − 1500 case HASH_TABLE_KEY_VALUE_WEAK:
+ − 1501 for (; e < sentinel; e++)
1204
+ − 1502 if (!HTENTRY_CLEAR_P (e))
442
+ − 1503 {
+ − 1504 if (marked_p (e->value))
+ − 1505 MARK_OBJ (e->key);
+ − 1506 else if (marked_p (e->key))
+ − 1507 MARK_OBJ (e->value);
+ − 1508 }
+ − 1509 break;
+ − 1510
428
+ − 1511 case HASH_TABLE_KEY_CAR_WEAK:
+ − 1512 for (; e < sentinel; e++)
1204
+ − 1513 if (!HTENTRY_CLEAR_P (e))
428
+ − 1514 if (!CONSP (e->key) || marked_p (XCAR (e->key)))
+ − 1515 {
+ − 1516 MARK_OBJ (e->key);
+ − 1517 MARK_OBJ (e->value);
+ − 1518 }
+ − 1519 break;
+ − 1520
450
+ − 1521 /* We seem to be sprouting new weakness types at an alarming
+ − 1522 rate. At least this is not externally visible - and in
+ − 1523 fact all of these KEY_CAR_* types are only used by the
+ − 1524 glyph code. */
+ − 1525 case HASH_TABLE_KEY_CAR_VALUE_WEAK:
+ − 1526 for (; e < sentinel; e++)
1204
+ − 1527 if (!HTENTRY_CLEAR_P (e))
450
+ − 1528 {
+ − 1529 if (!CONSP (e->key) || marked_p (XCAR (e->key)))
+ − 1530 {
+ − 1531 MARK_OBJ (e->key);
+ − 1532 MARK_OBJ (e->value);
+ − 1533 }
+ − 1534 else if (marked_p (e->value))
+ − 1535 MARK_OBJ (e->key);
+ − 1536 }
+ − 1537 break;
+ − 1538
428
+ − 1539 case HASH_TABLE_VALUE_CAR_WEAK:
+ − 1540 for (; e < sentinel; e++)
1204
+ − 1541 if (!HTENTRY_CLEAR_P (e))
428
+ − 1542 if (!CONSP (e->value) || marked_p (XCAR (e->value)))
+ − 1543 {
+ − 1544 MARK_OBJ (e->key);
+ − 1545 MARK_OBJ (e->value);
+ − 1546 }
+ − 1547 break;
+ − 1548
+ − 1549 default:
+ − 1550 break;
+ − 1551 }
+ − 1552 }
+ − 1553
+ − 1554 return did_mark;
+ − 1555 }
+ − 1556
+ − 1557 void
+ − 1558 prune_weak_hash_tables (void)
+ − 1559 {
+ − 1560 Lisp_Object hash_table, prev = Qnil;
+ − 1561 for (hash_table = Vall_weak_hash_tables;
+ − 1562 !NILP (hash_table);
+ − 1563 hash_table = XHASH_TABLE (hash_table)->next_weak)
+ − 1564 {
+ − 1565 if (! marked_p (hash_table))
+ − 1566 {
+ − 1567 /* This hash table itself is garbage. Remove it from the list. */
+ − 1568 if (NILP (prev))
+ − 1569 Vall_weak_hash_tables = XHASH_TABLE (hash_table)->next_weak;
+ − 1570 else
+ − 1571 XHASH_TABLE (prev)->next_weak = XHASH_TABLE (hash_table)->next_weak;
+ − 1572 }
+ − 1573 else
+ − 1574 {
+ − 1575 /* Now, scan over all the pairs. Remove all of the pairs
+ − 1576 in which the key or value, or both, is unmarked
+ − 1577 (depending on the weakness of the hash table). */
+ − 1578 Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1204
+ − 1579 htentry *entries = ht->hentries;
+ − 1580 htentry *sentinel = entries + ht->size;
+ − 1581 htentry *e;
428
+ − 1582
+ − 1583 for (e = entries; e < sentinel; e++)
1204
+ − 1584 if (!HTENTRY_CLEAR_P (e))
428
+ − 1585 {
+ − 1586 again:
+ − 1587 if (!marked_p (e->key) || !marked_p (e->value))
+ − 1588 {
+ − 1589 remhash_1 (ht, entries, e);
1204
+ − 1590 if (!HTENTRY_CLEAR_P (e))
428
+ − 1591 goto again;
+ − 1592 }
+ − 1593 }
+ − 1594
+ − 1595 prev = hash_table;
+ − 1596 }
+ − 1597 }
+ − 1598 }
+ − 1599
+ − 1600 /* Return a hash value for an array of Lisp_Objects of size SIZE. */
+ − 1601
665
+ − 1602 Hashcode
428
+ − 1603 internal_array_hash (Lisp_Object *arr, int size, int depth)
+ − 1604 {
+ − 1605 int i;
665
+ − 1606 Hashcode hash = 0;
442
+ − 1607 depth++;
428
+ − 1608
+ − 1609 if (size <= 5)
+ − 1610 {
+ − 1611 for (i = 0; i < size; i++)
442
+ − 1612 hash = HASH2 (hash, internal_hash (arr[i], depth));
428
+ − 1613 return hash;
+ − 1614 }
+ − 1615
+ − 1616 /* just pick five elements scattered throughout the array.
+ − 1617 A slightly better approach would be to offset by some
+ − 1618 noise factor from the points chosen below. */
+ − 1619 for (i = 0; i < 5; i++)
442
+ − 1620 hash = HASH2 (hash, internal_hash (arr[i*size/5], depth));
428
+ − 1621
+ − 1622 return hash;
+ − 1623 }
+ − 1624
+ − 1625 /* Return a hash value for a Lisp_Object. This is for use when hashing
+ − 1626 objects with the comparison being `equal' (for `eq', you can just
+ − 1627 use the Lisp_Object itself as the hash value). You need to make a
+ − 1628 tradeoff between the speed of the hash function and how good the
+ − 1629 hashing is. In particular, the hash function needs to be FAST,
+ − 1630 so you can't just traipse down the whole tree hashing everything
+ − 1631 together. Most of the time, objects will differ in the first
+ − 1632 few elements you hash. Thus, we only go to a short depth (5)
+ − 1633 and only hash at most 5 elements out of a vector. Theoretically
+ − 1634 we could still take 5^5 time (a big big number) to compute a
+ − 1635 hash, but practically this won't ever happen. */
+ − 1636
665
+ − 1637 Hashcode
428
+ − 1638 internal_hash (Lisp_Object obj, int depth)
+ − 1639 {
+ − 1640 if (depth > 5)
+ − 1641 return 0;
+ − 1642 if (CONSP (obj))
+ − 1643 {
+ − 1644 /* no point in worrying about tail recursion, since we're not
+ − 1645 going very deep */
+ − 1646 return HASH2 (internal_hash (XCAR (obj), depth + 1),
+ − 1647 internal_hash (XCDR (obj), depth + 1));
+ − 1648 }
+ − 1649 if (STRINGP (obj))
+ − 1650 {
+ − 1651 return hash_string (XSTRING_DATA (obj), XSTRING_LENGTH (obj));
+ − 1652 }
+ − 1653 if (LRECORDP (obj))
+ − 1654 {
442
+ − 1655 const struct lrecord_implementation
428
+ − 1656 *imp = XRECORD_LHEADER_IMPLEMENTATION (obj);
+ − 1657 if (imp->hash)
+ − 1658 return imp->hash (obj, depth);
+ − 1659 }
+ − 1660
+ − 1661 return LISP_HASH (obj);
+ − 1662 }
+ − 1663
+ − 1664 DEFUN ("sxhash", Fsxhash, 1, 1, 0, /*
+ − 1665 Return a hash value for OBJECT.
444
+ − 1666 \(equal obj1 obj2) implies (= (sxhash obj1) (sxhash obj2)).
428
+ − 1667 */
+ − 1668 (object))
+ − 1669 {
+ − 1670 return make_int (internal_hash (object, 0));
+ − 1671 }
+ − 1672
+ − 1673 #if 0
826
+ − 1674 DEFUN ("internal-hash-value", Finternal_hash_value, 1, 1, 0, /*
428
+ − 1675 Hash value of OBJECT. For debugging.
+ − 1676 The value is returned as (HIGH . LOW).
+ − 1677 */
+ − 1678 (object))
+ − 1679 {
+ − 1680 /* This function is pretty 32bit-centric. */
665
+ − 1681 Hashcode hash = internal_hash (object, 0);
428
+ − 1682 return Fcons (hash >> 16, hash & 0xffff);
+ − 1683 }
+ − 1684 #endif
+ − 1685
+ − 1686
+ − 1687 /************************************************************************/
+ − 1688 /* initialization */
+ − 1689 /************************************************************************/
+ − 1690
+ − 1691 void
+ − 1692 syms_of_elhash (void)
+ − 1693 {
+ − 1694 DEFSUBR (Fhash_table_p);
+ − 1695 DEFSUBR (Fmake_hash_table);
+ − 1696 DEFSUBR (Fcopy_hash_table);
+ − 1697 DEFSUBR (Fgethash);
+ − 1698 DEFSUBR (Fremhash);
+ − 1699 DEFSUBR (Fputhash);
+ − 1700 DEFSUBR (Fclrhash);
+ − 1701 DEFSUBR (Fmaphash);
+ − 1702 DEFSUBR (Fhash_table_count);
+ − 1703 DEFSUBR (Fhash_table_test);
+ − 1704 DEFSUBR (Fhash_table_size);
+ − 1705 DEFSUBR (Fhash_table_rehash_size);
+ − 1706 DEFSUBR (Fhash_table_rehash_threshold);
+ − 1707 DEFSUBR (Fhash_table_weakness);
+ − 1708 DEFSUBR (Fhash_table_type); /* obsolete */
+ − 1709 DEFSUBR (Fsxhash);
+ − 1710 #if 0
+ − 1711 DEFSUBR (Finternal_hash_value);
+ − 1712 #endif
+ − 1713
563
+ − 1714 DEFSYMBOL_MULTIWORD_PREDICATE (Qhash_tablep);
+ − 1715 DEFSYMBOL (Qhash_table);
+ − 1716 DEFSYMBOL (Qhashtable);
+ − 1717 DEFSYMBOL (Qweakness);
+ − 1718 DEFSYMBOL (Qvalue);
+ − 1719 DEFSYMBOL (Qkey_or_value);
+ − 1720 DEFSYMBOL (Qkey_and_value);
+ − 1721 DEFSYMBOL (Qrehash_size);
+ − 1722 DEFSYMBOL (Qrehash_threshold);
428
+ − 1723
563
+ − 1724 DEFSYMBOL (Qweak); /* obsolete */
+ − 1725 DEFSYMBOL (Qkey_weak); /* obsolete */
+ − 1726 DEFSYMBOL (Qkey_or_value_weak); /* obsolete */
+ − 1727 DEFSYMBOL (Qvalue_weak); /* obsolete */
+ − 1728 DEFSYMBOL (Qnon_weak); /* obsolete */
428
+ − 1729
563
+ − 1730 DEFKEYWORD (Q_test);
+ − 1731 DEFKEYWORD (Q_size);
+ − 1732 DEFKEYWORD (Q_rehash_size);
+ − 1733 DEFKEYWORD (Q_rehash_threshold);
+ − 1734 DEFKEYWORD (Q_weakness);
+ − 1735 DEFKEYWORD (Q_type); /* obsolete */
428
+ − 1736 }
+ − 1737
+ − 1738 void
771
+ − 1739 init_elhash_once_early (void)
428
+ − 1740 {
771
+ − 1741 INIT_LRECORD_IMPLEMENTATION (hash_table);
+ − 1742
428
+ − 1743 /* This must NOT be staticpro'd */
+ − 1744 Vall_weak_hash_tables = Qnil;
452
+ − 1745 dump_add_weak_object_chain (&Vall_weak_hash_tables);
428
+ − 1746 }
