1 /* Implementation of the hash table lisp object type.
2 Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
3 Copyright (C) 1995, 1996 Ben Wing.
4 Copyright (C) 1997 Free Software Foundation, Inc.
6 This file is part of XEmacs.
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
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
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. */
23 /* Synched up with: Not in FSF. */
30 Lisp_Object Qhash_tablep;
31 static Lisp_Object Qhashtable, Qhash_table;
32 static Lisp_Object Qweakness, Qvalue;
33 static Lisp_Object Vall_weak_hash_tables;
34 static Lisp_Object Qrehash_size, Qrehash_threshold;
35 static Lisp_Object Q_size, Q_test, Q_weakness, Q_rehash_size, Q_rehash_threshold;
37 /* obsolete as of 19990901 in xemacs-21.2 */
38 static Lisp_Object Qweak, Qkey_weak, Qvalue_weak, Qnon_weak, Q_type;
46 struct Lisp_Hash_Table
48 struct lcrecord_header header;
53 double rehash_threshold;
55 hash_table_hash_function_t hash_function;
56 hash_table_test_function_t test_function;
58 enum hash_table_weakness weakness;
59 Lisp_Object next_weak; /* Used to chain together all of the weak
60 hash tables. Don't mark through this. */
63 #define HENTRY_CLEAR_P(hentry) ((*(EMACS_UINT*)(&((hentry)->key))) == 0)
64 #define CLEAR_HENTRY(hentry) \
65 ((*(EMACS_UINT*)(&((hentry)->key))) = 0, \
66 (*(EMACS_UINT*)(&((hentry)->value))) = 0)
68 #define HASH_TABLE_DEFAULT_SIZE 16
69 #define HASH_TABLE_DEFAULT_REHASH_SIZE 1.3
70 #define HASH_TABLE_MIN_SIZE 10
72 #define HASH_CODE(key, ht) \
73 ((((ht)->hash_function ? (ht)->hash_function (key) : LISP_HASH (key)) \
74 * (ht)->golden_ratio) \
77 #define KEYS_EQUAL_P(key1, key2, testfun) \
78 (EQ (key1, key2) || ((testfun) && (testfun) (key1, key2)))
80 #define LINEAR_PROBING_LOOP(probe, entries, size) \
82 !HENTRY_CLEAR_P (probe) || \
83 (probe == entries + size ? \
84 (probe = entries, !HENTRY_CLEAR_P (probe)) : 0); \
87 #ifndef ERROR_CHECK_HASH_TABLE
88 # ifdef ERROR_CHECK_TYPECHECK
89 # define ERROR_CHECK_HASH_TABLE 1
91 # define ERROR_CHECK_HASH_TABLE 0
95 #if ERROR_CHECK_HASH_TABLE
97 check_hash_table_invariants (Lisp_Hash_Table *ht)
99 assert (ht->count < ht->size);
100 assert (ht->count <= ht->rehash_count);
101 assert (ht->rehash_count < ht->size);
102 assert ((double) ht->count * ht->rehash_threshold - 1 <= (double) ht->rehash_count);
103 assert (HENTRY_CLEAR_P (ht->hentries + ht->size));
106 #define check_hash_table_invariants(ht)
109 /* We use linear probing instead of double hashing, despite its lack
110 of blessing by Knuth and company, because, as a result of the
111 increasing discrepancy between CPU speeds and memory speeds, cache
112 behavior is becoming increasingly important, e.g:
114 For a trivial loop, the penalty for non-sequential access of an array is:
115 - a factor of 3-4 on Pentium Pro 200 Mhz
116 - a factor of 10 on Ultrasparc 300 Mhz */
118 /* Return a suitable size for a hash table, with at least SIZE slots. */
120 hash_table_size (size_t requested_size)
122 /* Return some prime near, but greater than or equal to, SIZE.
123 Decades from the time of writing, someone will have a system large
124 enough that the list below will be too short... */
125 static CONST size_t primes [] =
127 19, 29, 41, 59, 79, 107, 149, 197, 263, 347, 457, 599, 787, 1031,
128 1361, 1777, 2333, 3037, 3967, 5167, 6719, 8737, 11369, 14783,
129 19219, 24989, 32491, 42257, 54941, 71429, 92861, 120721, 156941,
130 204047, 265271, 344857, 448321, 582821, 757693, 985003, 1280519,
131 1664681, 2164111, 2813353, 3657361, 4754591, 6180989, 8035301,
132 10445899, 13579681, 17653589, 22949669, 29834603, 38784989,
133 50420551, 65546729, 85210757, 110774011, 144006217, 187208107,
134 243370577, 316381771, 411296309, 534685237, 695090819, 903618083,
135 1174703521, 1527114613, 1985248999, 2580823717UL, 3355070839UL
137 /* We've heard of binary search. */
139 for (low = 0, high = countof (primes) - 1; high - low > 1;)
141 /* Loop Invariant: size < primes [high] */
142 int mid = (low + high) / 2;
143 if (primes [mid] < requested_size)
148 return primes [high];
152 #if 0 /* I don't think these are needed any more.
153 If using the general lisp_object_equal_*() functions
154 causes efficiency problems, these can be resurrected. --ben */
155 /* equality and hash functions for Lisp strings */
157 lisp_string_equal (Lisp_Object str1, Lisp_Object str2)
159 /* This is wrong anyway. You can't use strcmp() on Lisp strings,
160 because they can contain zero characters. */
161 return !strcmp ((char *) XSTRING_DATA (str1), (char *) XSTRING_DATA (str2));
165 lisp_string_hash (Lisp_Object obj)
167 return hash_string (XSTRING_DATA (str), XSTRING_LENGTH (str));
173 lisp_object_eql_equal (Lisp_Object obj1, Lisp_Object obj2)
175 return EQ (obj1, obj2) || (FLOATP (obj1) && internal_equal (obj1, obj2, 0));
179 lisp_object_eql_hash (Lisp_Object obj)
181 return FLOATP (obj) ? internal_hash (obj, 0) : LISP_HASH (obj);
185 lisp_object_equal_equal (Lisp_Object obj1, Lisp_Object obj2)
187 return internal_equal (obj1, obj2, 0);
191 lisp_object_equal_hash (Lisp_Object obj)
193 return internal_hash (obj, 0);
198 mark_hash_table (Lisp_Object obj)
200 Lisp_Hash_Table *ht = XHASH_TABLE (obj);
202 /* If the hash table is weak, we don't want to mark the keys and
203 values (we scan over them after everything else has been marked,
204 and mark or remove them as necessary). */
205 if (ht->weakness == HASH_TABLE_NON_WEAK)
207 hentry *e, *sentinel;
209 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
210 if (!HENTRY_CLEAR_P (e))
212 mark_object (e->key);
213 mark_object (e->value);
219 /* Equality of hash tables. Two hash tables are equal when they are of
220 the same weakness and test function, they have the same number of
221 elements, and for each key in the hash table, the values are `equal'.
223 This is similar to Common Lisp `equalp' of hash tables, with the
224 difference that CL requires the keys to be compared with the test
225 function, which we don't do. Doing that would require consing, and
226 consing is a bad idea in `equal'. Anyway, our method should provide
227 the same result -- if the keys are not equal according to the test
228 function, then Fgethash() in hash_table_equal_mapper() will fail. */
230 hash_table_equal (Lisp_Object hash_table1, Lisp_Object hash_table2, int depth)
232 Lisp_Hash_Table *ht1 = XHASH_TABLE (hash_table1);
233 Lisp_Hash_Table *ht2 = XHASH_TABLE (hash_table2);
234 hentry *e, *sentinel;
236 if ((ht1->test_function != ht2->test_function) ||
237 (ht1->weakness != ht2->weakness) ||
238 (ht1->count != ht2->count))
243 for (e = ht1->hentries, sentinel = e + ht1->size; e < sentinel; e++)
244 if (!HENTRY_CLEAR_P (e))
245 /* Look up the key in the other hash table, and compare the values. */
247 Lisp_Object value_in_other = Fgethash (e->key, hash_table2, Qunbound);
248 if (UNBOUNDP (value_in_other) ||
249 !internal_equal (e->value, value_in_other, depth))
250 return 0; /* Give up */
256 /* Printing hash tables.
258 This is non-trivial, because we use a readable structure-style
259 syntax for hash tables. This means that a typical hash table will be
260 readably printed in the form of:
262 #s(hash-table size 2 data (key1 value1 key2 value2))
264 The supported hash table structure keywords and their values are:
265 `test' (eql (or nil), eq or equal)
266 `size' (a natnum or nil)
267 `rehash-size' (a float)
268 `rehash-threshold' (a float)
269 `weakness' (nil, t, key or value)
272 If `print-readably' is nil, then a simpler syntax is used, for example
274 #<hash-table size 2/13 data (key1 value1 key2 value2) 0x874d>
276 The data is truncated to four pairs, and the rest is shown with
277 `...'. This printer does not cons. */
280 /* Print the data of the hash table. This maps through a Lisp
281 hash table and prints key/value pairs using PRINTCHARFUN. */
283 print_hash_table_data (Lisp_Hash_Table *ht, Lisp_Object printcharfun)
286 hentry *e, *sentinel;
288 write_c_string (" data (", printcharfun);
290 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
291 if (!HENTRY_CLEAR_P (e))
294 write_c_string (" ", printcharfun);
295 if (!print_readably && count > 3)
297 write_c_string ("...", printcharfun);
300 print_internal (e->key, printcharfun, 1);
301 write_c_string (" ", printcharfun);
302 print_internal (e->value, printcharfun, 1);
306 write_c_string (")", printcharfun);
310 print_hash_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
312 Lisp_Hash_Table *ht = XHASH_TABLE (obj);
315 write_c_string (print_readably ? "#s(hash-table" : "#<hash-table",
318 /* These checks have a kludgy look to them, but they are safe.
319 Due to nature of hashing, you cannot use arbitrary
320 test functions anyway. */
321 if (!ht->test_function)
322 write_c_string (" test eq", printcharfun);
323 else if (ht->test_function == lisp_object_equal_equal)
324 write_c_string (" test equal", printcharfun);
325 else if (ht->test_function == lisp_object_eql_equal)
330 if (ht->count || !print_readably)
333 sprintf (buf, " size %lu", (unsigned long) ht->count);
335 sprintf (buf, " size %lu/%lu",
336 (unsigned long) ht->count,
337 (unsigned long) ht->size);
338 write_c_string (buf, printcharfun);
341 if (ht->weakness != HASH_TABLE_NON_WEAK)
343 sprintf (buf, " weakness %s",
344 (ht->weakness == HASH_TABLE_WEAK ? "t" :
345 ht->weakness == HASH_TABLE_KEY_WEAK ? "key" :
346 ht->weakness == HASH_TABLE_VALUE_WEAK ? "value" :
347 "you-d-better-not-see-this"));
348 write_c_string (buf, printcharfun);
352 print_hash_table_data (ht, printcharfun);
355 write_c_string (")", printcharfun);
358 sprintf (buf, " 0x%x>", ht->header.uid);
359 write_c_string (buf, printcharfun);
364 finalize_hash_table (void *header, int for_disksave)
368 Lisp_Hash_Table *ht = (Lisp_Hash_Table *) header;
370 xfree (ht->hentries);
375 static const struct lrecord_description hentry_description_1[] = {
376 { XD_LISP_OBJECT, offsetof (hentry, key) },
377 { XD_LISP_OBJECT, offsetof (hentry, value) },
381 static const struct struct_description hentry_description = {
386 const struct lrecord_description hash_table_description[] = {
387 { XD_SIZE_T, offsetof (Lisp_Hash_Table, size) },
388 { XD_STRUCT_PTR, offsetof (Lisp_Hash_Table, hentries), XD_INDIRECT(0, 1), &hentry_description },
389 { XD_LO_LINK, offsetof (Lisp_Hash_Table, next_weak) },
393 DEFINE_LRECORD_IMPLEMENTATION ("hash-table", hash_table,
394 mark_hash_table, print_hash_table,
396 /* #### Implement hash_table_hash()! */
398 hash_table_description,
401 static Lisp_Hash_Table *
402 xhash_table (Lisp_Object hash_table)
405 CHECK_HASH_TABLE (hash_table);
406 check_hash_table_invariants (XHASH_TABLE (hash_table));
407 return XHASH_TABLE (hash_table);
411 /************************************************************************/
412 /* Creation of Hash Tables */
413 /************************************************************************/
415 /* Creation of hash tables, without error-checking. */
417 compute_hash_table_derived_values (Lisp_Hash_Table *ht)
419 ht->rehash_count = (size_t)
420 ((double) ht->size * ht->rehash_threshold);
421 ht->golden_ratio = (size_t)
422 ((double) ht->size * (.6180339887 / (double) sizeof (Lisp_Object)));
426 make_general_lisp_hash_table (enum hash_table_test test,
429 double rehash_threshold,
430 enum hash_table_weakness weakness)
432 Lisp_Object hash_table;
433 Lisp_Hash_Table *ht = alloc_lcrecord_type (Lisp_Hash_Table, &lrecord_hash_table);
438 ht->test_function = 0;
439 ht->hash_function = 0;
443 ht->test_function = lisp_object_eql_equal;
444 ht->hash_function = lisp_object_eql_hash;
447 case HASH_TABLE_EQUAL:
448 ht->test_function = lisp_object_equal_equal;
449 ht->hash_function = lisp_object_equal_hash;
456 ht->weakness = weakness;
459 rehash_size > 1.0 ? rehash_size : HASH_TABLE_DEFAULT_REHASH_SIZE;
461 ht->rehash_threshold =
462 rehash_threshold > 0.0 ? rehash_threshold :
463 size > 4096 && !ht->test_function ? 0.7 : 0.6;
465 if (size < HASH_TABLE_MIN_SIZE)
466 size = HASH_TABLE_MIN_SIZE;
467 ht->size = hash_table_size ((size_t) (((double) size / ht->rehash_threshold)
471 compute_hash_table_derived_values (ht);
473 /* We leave room for one never-occupied sentinel hentry at the end. */
474 ht->hentries = xnew_array (hentry, ht->size + 1);
477 hentry *e, *sentinel;
478 for (e = ht->hentries, sentinel = e + ht->size; e <= sentinel; e++)
482 XSETHASH_TABLE (hash_table, ht);
484 if (weakness == HASH_TABLE_NON_WEAK)
485 ht->next_weak = Qunbound;
487 ht->next_weak = Vall_weak_hash_tables, Vall_weak_hash_tables = hash_table;
493 make_lisp_hash_table (size_t size,
494 enum hash_table_weakness weakness,
495 enum hash_table_test test)
497 return make_general_lisp_hash_table (test, size, -1.0, -1.0, weakness);
500 /* Pretty reading of hash tables.
502 Here we use the existing structures mechanism (which is,
503 unfortunately, pretty cumbersome) for validating and instantiating
504 the hash tables. The idea is that the side-effect of reading a
505 #s(hash-table PLIST) object is creation of a hash table with desired
506 properties, and that the hash table is returned. */
508 /* Validation functions: each keyword provides its own validation
509 function. The errors should maybe be continuable, but it is
510 unclear how this would cope with ERRB. */
512 hash_table_size_validate (Lisp_Object keyword, Lisp_Object value,
518 maybe_signal_error (Qwrong_type_argument, list2 (Qnatnump, value),
524 decode_hash_table_size (Lisp_Object obj)
526 return NILP (obj) ? HASH_TABLE_DEFAULT_SIZE : XINT (obj);
530 hash_table_weakness_validate (Lisp_Object keyword, Lisp_Object value,
533 if (EQ (value, Qnil)) return 1;
534 if (EQ (value, Qt)) return 1;
535 if (EQ (value, Qkey)) return 1;
536 if (EQ (value, Qvalue)) return 1;
538 /* Following values are obsolete as of 19990901 in xemacs-21.2 */
539 if (EQ (value, Qnon_weak)) return 1;
540 if (EQ (value, Qweak)) return 1;
541 if (EQ (value, Qkey_weak)) return 1;
542 if (EQ (value, Qvalue_weak)) return 1;
544 maybe_signal_simple_error ("Invalid hash table weakness",
545 value, Qhash_table, errb);
549 static enum hash_table_weakness
550 decode_hash_table_weakness (Lisp_Object obj)
552 if (EQ (obj, Qnil)) return HASH_TABLE_NON_WEAK;
553 if (EQ (obj, Qt)) return HASH_TABLE_WEAK;
554 if (EQ (obj, Qkey)) return HASH_TABLE_KEY_WEAK;
555 if (EQ (obj, Qvalue)) return HASH_TABLE_VALUE_WEAK;
557 /* Following values are obsolete as of 19990901 in xemacs-21.2 */
558 if (EQ (obj, Qnon_weak)) return HASH_TABLE_NON_WEAK;
559 if (EQ (obj, Qweak)) return HASH_TABLE_WEAK;
560 if (EQ (obj, Qkey_weak)) return HASH_TABLE_KEY_WEAK;
561 if (EQ (obj, Qvalue_weak)) return HASH_TABLE_VALUE_WEAK;
563 signal_simple_error ("Invalid hash table weakness", obj);
564 return HASH_TABLE_NON_WEAK; /* not reached */
568 hash_table_test_validate (Lisp_Object keyword, Lisp_Object value,
571 if (EQ (value, Qnil)) return 1;
572 if (EQ (value, Qeq)) return 1;
573 if (EQ (value, Qequal)) return 1;
574 if (EQ (value, Qeql)) return 1;
576 maybe_signal_simple_error ("Invalid hash table test",
577 value, Qhash_table, errb);
581 static enum hash_table_test
582 decode_hash_table_test (Lisp_Object obj)
584 if (EQ (obj, Qnil)) return HASH_TABLE_EQL;
585 if (EQ (obj, Qeq)) return HASH_TABLE_EQ;
586 if (EQ (obj, Qequal)) return HASH_TABLE_EQUAL;
587 if (EQ (obj, Qeql)) return HASH_TABLE_EQL;
589 signal_simple_error ("Invalid hash table test", obj);
590 return HASH_TABLE_EQ; /* not reached */
594 hash_table_rehash_size_validate (Lisp_Object keyword, Lisp_Object value,
599 maybe_signal_error (Qwrong_type_argument, list2 (Qfloatp, value),
605 double rehash_size = XFLOAT_DATA (value);
606 if (rehash_size <= 1.0)
608 maybe_signal_simple_error
609 ("Hash table rehash size must be greater than 1.0",
610 value, Qhash_table, errb);
619 decode_hash_table_rehash_size (Lisp_Object rehash_size)
621 return NILP (rehash_size) ? -1.0 : XFLOAT_DATA (rehash_size);
625 hash_table_rehash_threshold_validate (Lisp_Object keyword, Lisp_Object value,
630 maybe_signal_error (Qwrong_type_argument, list2 (Qfloatp, value),
636 double rehash_threshold = XFLOAT_DATA (value);
637 if (rehash_threshold <= 0.0 || rehash_threshold >= 1.0)
639 maybe_signal_simple_error
640 ("Hash table rehash threshold must be between 0.0 and 1.0",
641 value, Qhash_table, errb);
650 decode_hash_table_rehash_threshold (Lisp_Object rehash_threshold)
652 return NILP (rehash_threshold) ? -1.0 : XFLOAT_DATA (rehash_threshold);
656 hash_table_data_validate (Lisp_Object keyword, Lisp_Object value,
661 GET_EXTERNAL_LIST_LENGTH (value, len);
665 maybe_signal_simple_error
666 ("Hash table data must have alternating key/value pairs",
667 value, Qhash_table, errb);
673 /* The actual instantiation of a hash table. This does practically no
674 error checking, because it relies on the fact that the paranoid
675 functions above have error-checked everything to the last details.
676 If this assumption is wrong, we will get a crash immediately (with
677 error-checking compiled in), and we'll know if there is a bug in
678 the structure mechanism. So there. */
680 hash_table_instantiate (Lisp_Object plist)
682 Lisp_Object hash_table;
683 Lisp_Object test = Qnil;
684 Lisp_Object size = Qnil;
685 Lisp_Object rehash_size = Qnil;
686 Lisp_Object rehash_threshold = Qnil;
687 Lisp_Object weakness = Qnil;
688 Lisp_Object data = Qnil;
690 while (!NILP (plist))
692 Lisp_Object key, value;
693 key = XCAR (plist); plist = XCDR (plist);
694 value = XCAR (plist); plist = XCDR (plist);
696 if (EQ (key, Qtest)) test = value;
697 else if (EQ (key, Qsize)) size = value;
698 else if (EQ (key, Qrehash_size)) rehash_size = value;
699 else if (EQ (key, Qrehash_threshold)) rehash_threshold = value;
700 else if (EQ (key, Qweakness)) weakness = value;
701 else if (EQ (key, Qdata)) data = value;
702 else if (EQ (key, Qtype))/*obsolete*/ weakness = value;
707 /* Create the hash table. */
708 hash_table = make_general_lisp_hash_table
709 (decode_hash_table_test (test),
710 decode_hash_table_size (size),
711 decode_hash_table_rehash_size (rehash_size),
712 decode_hash_table_rehash_threshold (rehash_threshold),
713 decode_hash_table_weakness (weakness));
715 /* I'm not sure whether this can GC, but better safe than sorry. */
720 /* And fill it with data. */
723 Lisp_Object key, value;
724 key = XCAR (data); data = XCDR (data);
725 value = XCAR (data); data = XCDR (data);
726 Fputhash (key, value, hash_table);
735 structure_type_create_hash_table_structure_name (Lisp_Object structure_name)
737 struct structure_type *st;
739 st = define_structure_type (structure_name, 0, hash_table_instantiate);
740 define_structure_type_keyword (st, Qtest, hash_table_test_validate);
741 define_structure_type_keyword (st, Qsize, hash_table_size_validate);
742 define_structure_type_keyword (st, Qrehash_size, hash_table_rehash_size_validate);
743 define_structure_type_keyword (st, Qrehash_threshold, hash_table_rehash_threshold_validate);
744 define_structure_type_keyword (st, Qweakness, hash_table_weakness_validate);
745 define_structure_type_keyword (st, Qdata, hash_table_data_validate);
747 /* obsolete as of 19990901 in xemacs-21.2 */
748 define_structure_type_keyword (st, Qtype, hash_table_weakness_validate);
751 /* Create a built-in Lisp structure type named `hash-table'.
752 We make #s(hashtable ...) equivalent to #s(hash-table ...),
753 for backward compatibility.
754 This is called from emacs.c. */
756 structure_type_create_hash_table (void)
758 structure_type_create_hash_table_structure_name (Qhash_table);
759 structure_type_create_hash_table_structure_name (Qhashtable); /* compat */
763 /************************************************************************/
764 /* Definition of Lisp-visible methods */
765 /************************************************************************/
767 DEFUN ("hash-table-p", Fhash_table_p, 1, 1, 0, /*
768 Return t if OBJECT is a hash table, else nil.
772 return HASH_TABLEP (object) ? Qt : Qnil;
775 DEFUN ("make-hash-table", Fmake_hash_table, 0, MANY, 0, /*
776 Return a new empty hash table object.
777 Use Common Lisp style keywords to specify hash table properties.
778 (make-hash-table &key test size rehash-size rehash-threshold weakness)
780 Keyword :test can be `eq', `eql' (default) or `equal'.
781 Comparison between keys is done using this function.
782 If speed is important, consider using `eq'.
783 When storing strings in the hash table, you will likely need to use `equal'.
785 Keyword :size specifies the number of keys likely to be inserted.
786 This number of entries can be inserted without enlarging the hash table.
788 Keyword :rehash-size must be a float greater than 1.0, and specifies
789 the factor by which to increase the size of the hash table when enlarging.
791 Keyword :rehash-threshold must be a float between 0.0 and 1.0,
792 and specifies the load factor of the hash table which triggers enlarging.
794 Non-standard keyword :weakness can be `nil' (default), `t', `key' or `value'.
796 A weak hash table is one whose pointers do not count as GC referents:
797 for any key-value pair in the hash table, if the only remaining pointer
798 to either the key or the value is in a weak hash table, then the pair
799 will be removed from the hash table, and the key and value collected.
800 A non-weak hash table (or any other pointer) would prevent the object
801 from being collected.
803 A key-weak hash table is similar to a fully-weak hash table except that
804 a key-value pair will be removed only if the key remains unmarked
805 outside of weak hash tables. The pair will remain in the hash table if
806 the key is pointed to by something other than a weak hash table, even
809 A value-weak hash table is similar to a fully-weak hash table except
810 that a key-value pair will be removed only if the value remains
811 unmarked outside of weak hash tables. The pair will remain in the
812 hash table if the value is pointed to by something other than a weak
813 hash table, even if the key is not.
815 (int nargs, Lisp_Object *args))
818 Lisp_Object test = Qnil;
819 Lisp_Object size = Qnil;
820 Lisp_Object rehash_size = Qnil;
821 Lisp_Object rehash_threshold = Qnil;
822 Lisp_Object weakness = Qnil;
824 while (i + 1 < nargs)
826 Lisp_Object keyword = args[i++];
827 Lisp_Object value = args[i++];
829 if (EQ (keyword, Q_test)) test = value;
830 else if (EQ (keyword, Q_size)) size = value;
831 else if (EQ (keyword, Q_rehash_size)) rehash_size = value;
832 else if (EQ (keyword, Q_rehash_threshold)) rehash_threshold = value;
833 else if (EQ (keyword, Q_weakness)) weakness = value;
834 else if (EQ (keyword, Q_type))/*obsolete*/ weakness = value;
835 else signal_simple_error ("Invalid hash table property keyword", keyword);
839 signal_simple_error ("Hash table property requires a value", args[i]);
841 #define VALIDATE_VAR(var) \
842 if (!NILP (var)) hash_table_##var##_validate (Q##var, var, ERROR_ME);
846 VALIDATE_VAR (rehash_size);
847 VALIDATE_VAR (rehash_threshold);
848 VALIDATE_VAR (weakness);
850 return make_general_lisp_hash_table
851 (decode_hash_table_test (test),
852 decode_hash_table_size (size),
853 decode_hash_table_rehash_size (rehash_size),
854 decode_hash_table_rehash_threshold (rehash_threshold),
855 decode_hash_table_weakness (weakness));
858 DEFUN ("copy-hash-table", Fcopy_hash_table, 1, 1, 0, /*
859 Return a new hash table containing the same keys and values as HASH-TABLE.
860 The keys and values will not themselves be copied.
864 CONST Lisp_Hash_Table *ht_old = xhash_table (hash_table);
865 Lisp_Hash_Table *ht = alloc_lcrecord_type (Lisp_Hash_Table, &lrecord_hash_table);
867 copy_lcrecord (ht, ht_old);
869 ht->hentries = xnew_array (hentry, ht_old->size + 1);
870 memcpy (ht->hentries, ht_old->hentries, (ht_old->size + 1) * sizeof (hentry));
872 XSETHASH_TABLE (hash_table, ht);
874 if (! EQ (ht->next_weak, Qunbound))
876 ht->next_weak = Vall_weak_hash_tables;
877 Vall_weak_hash_tables = hash_table;
884 resize_hash_table (Lisp_Hash_Table *ht, size_t new_size)
886 hentry *old_entries, *new_entries, *sentinel, *e;
892 old_entries = ht->hentries;
894 ht->hentries = xnew_array_and_zero (hentry, new_size + 1);
895 new_entries = ht->hentries;
897 compute_hash_table_derived_values (ht);
899 for (e = old_entries, sentinel = e + old_size; e < sentinel; e++)
900 if (!HENTRY_CLEAR_P (e))
902 hentry *probe = new_entries + HASH_CODE (e->key, ht);
903 LINEAR_PROBING_LOOP (probe, new_entries, new_size)
908 if (!DUMPEDP (old_entries))
912 /* After a hash table has been saved to disk and later restored by the
913 portable dumper, it contains the same objects, but their addresses
914 and thus their HASH_CODEs have changed. */
916 pdump_reorganize_hash_table (Lisp_Object hash_table)
918 CONST Lisp_Hash_Table *ht = xhash_table (hash_table);
919 hentry *new_entries = xnew_array_and_zero (hentry, ht->size + 1);
920 hentry *e, *sentinel;
922 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
923 if (!HENTRY_CLEAR_P (e))
925 hentry *probe = new_entries + HASH_CODE (e->key, ht);
926 LINEAR_PROBING_LOOP (probe, new_entries, ht->size)
931 memcpy (ht->hentries, new_entries, ht->size * sizeof (hentry));
937 enlarge_hash_table (Lisp_Hash_Table *ht)
940 hash_table_size ((size_t) ((double) ht->size * ht->rehash_size));
941 resize_hash_table (ht, new_size);
945 find_hentry (Lisp_Object key, CONST Lisp_Hash_Table *ht)
947 hash_table_test_function_t test_function = ht->test_function;
948 hentry *entries = ht->hentries;
949 hentry *probe = entries + HASH_CODE (key, ht);
951 LINEAR_PROBING_LOOP (probe, entries, ht->size)
952 if (KEYS_EQUAL_P (probe->key, key, test_function))
958 DEFUN ("gethash", Fgethash, 2, 3, 0, /*
959 Find hash value for KEY in HASH-TABLE.
960 If there is no corresponding value, return DEFAULT (which defaults to nil).
962 (key, hash_table, default_))
964 CONST Lisp_Hash_Table *ht = xhash_table (hash_table);
965 hentry *e = find_hentry (key, ht);
967 return HENTRY_CLEAR_P (e) ? default_ : e->value;
970 DEFUN ("puthash", Fputhash, 3, 3, 0, /*
971 Hash KEY to VALUE in HASH-TABLE.
973 (key, value, hash_table))
975 Lisp_Hash_Table *ht = xhash_table (hash_table);
976 hentry *e = find_hentry (key, ht);
978 if (!HENTRY_CLEAR_P (e))
979 return e->value = value;
984 if (++ht->count >= ht->rehash_count)
985 enlarge_hash_table (ht);
990 /* Remove hentry pointed at by PROBE.
991 Subsequent entries are removed and reinserted.
992 We don't use tombstones - too wasteful. */
994 remhash_1 (Lisp_Hash_Table *ht, hentry *entries, hentry *probe)
996 size_t size = ht->size;
997 CLEAR_HENTRY (probe);
1001 LINEAR_PROBING_LOOP (probe, entries, size)
1003 Lisp_Object key = probe->key;
1004 hentry *probe2 = entries + HASH_CODE (key, ht);
1005 LINEAR_PROBING_LOOP (probe2, entries, size)
1006 if (EQ (probe2->key, key))
1007 /* hentry at probe doesn't need to move. */
1008 goto continue_outer_loop;
1009 /* Move hentry from probe to new home at probe2. */
1011 CLEAR_HENTRY (probe);
1012 continue_outer_loop: continue;
1016 DEFUN ("remhash", Fremhash, 2, 2, 0, /*
1017 Remove the entry for KEY from HASH-TABLE.
1018 Do nothing if there is no entry for KEY in HASH-TABLE.
1022 Lisp_Hash_Table *ht = xhash_table (hash_table);
1023 hentry *e = find_hentry (key, ht);
1025 if (HENTRY_CLEAR_P (e))
1028 remhash_1 (ht, ht->hentries, e);
1032 DEFUN ("clrhash", Fclrhash, 1, 1, 0, /*
1033 Remove all entries from HASH-TABLE, leaving it empty.
1037 Lisp_Hash_Table *ht = xhash_table (hash_table);
1038 hentry *e, *sentinel;
1040 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1047 /************************************************************************/
1048 /* Accessor Functions */
1049 /************************************************************************/
1051 DEFUN ("hash-table-count", Fhash_table_count, 1, 1, 0, /*
1052 Return the number of entries in HASH-TABLE.
1056 return make_int (xhash_table (hash_table)->count);
1059 DEFUN ("hash-table-test", Fhash_table_test, 1, 1, 0, /*
1060 Return the test function of HASH-TABLE.
1061 This can be one of `eq', `eql' or `equal'.
1065 hash_table_test_function_t fun = xhash_table (hash_table)->test_function;
1067 return (fun == lisp_object_eql_equal ? Qeql :
1068 fun == lisp_object_equal_equal ? Qequal :
1072 DEFUN ("hash-table-size", Fhash_table_size, 1, 1, 0, /*
1073 Return the size of HASH-TABLE.
1074 This is the current number of slots in HASH-TABLE, whether occupied or not.
1078 return make_int (xhash_table (hash_table)->size);
1081 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size, 1, 1, 0, /*
1082 Return the current rehash size of HASH-TABLE.
1083 This is a float greater than 1.0; the factor by which HASH-TABLE
1084 is enlarged when the rehash threshold is exceeded.
1088 return make_float (xhash_table (hash_table)->rehash_size);
1091 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold, 1, 1, 0, /*
1092 Return the current rehash threshold of HASH-TABLE.
1093 This is a float between 0.0 and 1.0; the maximum `load factor' of HASH-TABLE,
1094 beyond which the HASH-TABLE is enlarged by rehashing.
1098 return make_float (xhash_table (hash_table)->rehash_threshold);
1101 DEFUN ("hash-table-weakness", Fhash_table_weakness, 1, 1, 0, /*
1102 Return the weakness of HASH-TABLE.
1103 This can be one of `nil', `t', `key' or `value'.
1107 switch (xhash_table (hash_table)->weakness)
1109 case HASH_TABLE_WEAK: return Qt;
1110 case HASH_TABLE_KEY_WEAK: return Qkey;
1111 case HASH_TABLE_VALUE_WEAK: return Qvalue;
1112 default: return Qnil;
1116 /* obsolete as of 19990901 in xemacs-21.2 */
1117 DEFUN ("hash-table-type", Fhash_table_type, 1, 1, 0, /*
1118 Return the type of HASH-TABLE.
1119 This can be one of `non-weak', `weak', `key-weak' or `value-weak'.
1123 switch (xhash_table (hash_table)->weakness)
1125 case HASH_TABLE_WEAK: return Qweak;
1126 case HASH_TABLE_KEY_WEAK: return Qkey_weak;
1127 case HASH_TABLE_VALUE_WEAK: return Qvalue_weak;
1128 default: return Qnon_weak;
1132 /************************************************************************/
1133 /* Mapping Functions */
1134 /************************************************************************/
1135 DEFUN ("maphash", Fmaphash, 2, 2, 0, /*
1136 Map FUNCTION over entries in HASH-TABLE, calling it with two args,
1137 each key and value in HASH-TABLE.
1139 FUNCTION may not modify HASH-TABLE, with the one exception that FUNCTION
1140 may remhash or puthash the entry currently being processed by FUNCTION.
1142 (function, hash_table))
1144 CONST Lisp_Hash_Table *ht = xhash_table (hash_table);
1145 CONST hentry *e, *sentinel;
1147 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1148 if (!HENTRY_CLEAR_P (e))
1150 Lisp_Object args[3], key;
1156 Ffuncall (countof (args), args);
1157 /* Has FUNCTION done a remhash? */
1158 if (!EQ (key, e->key) && !HENTRY_CLEAR_P (e))
1165 /* Map *C* function FUNCTION over the elements of a lisp hash table. */
1167 elisp_maphash (maphash_function_t function,
1168 Lisp_Object hash_table, void *extra_arg)
1170 CONST Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1171 CONST hentry *e, *sentinel;
1173 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1174 if (!HENTRY_CLEAR_P (e))
1179 if (function (key, e->value, extra_arg))
1181 /* Has FUNCTION done a remhash? */
1182 if (!EQ (key, e->key) && !HENTRY_CLEAR_P (e))
1187 /* Remove all elements of a lisp hash table satisfying *C* predicate PREDICATE. */
1189 elisp_map_remhash (maphash_function_t predicate,
1190 Lisp_Object hash_table, void *extra_arg)
1192 Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1193 hentry *e, *entries, *sentinel;
1195 for (e = entries = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1196 if (!HENTRY_CLEAR_P (e))
1199 if (predicate (e->key, e->value, extra_arg))
1201 remhash_1 (ht, entries, e);
1202 if (!HENTRY_CLEAR_P (e))
1209 /************************************************************************/
1210 /* garbage collecting weak hash tables */
1211 /************************************************************************/
1213 /* Complete the marking for semi-weak hash tables. */
1215 finish_marking_weak_hash_tables (void)
1217 Lisp_Object hash_table;
1220 for (hash_table = Vall_weak_hash_tables;
1222 hash_table = XHASH_TABLE (hash_table)->next_weak)
1224 CONST Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1225 CONST hentry *e = ht->hentries;
1226 CONST hentry *sentinel = e + ht->size;
1228 if (! marked_p (hash_table))
1229 /* The hash table is probably garbage. Ignore it. */
1232 /* Now, scan over all the pairs. For all pairs that are
1233 half-marked, we may need to mark the other half if we're
1234 keeping this pair. */
1235 #define MARK_OBJ(obj) \
1236 do { if (!marked_p (obj)) mark_object (obj), did_mark = 1; } while (0)
1238 switch (ht->weakness)
1240 case HASH_TABLE_KEY_WEAK:
1241 for (; e < sentinel; e++)
1242 if (!HENTRY_CLEAR_P (e))
1243 if (marked_p (e->key))
1244 MARK_OBJ (e->value);
1247 case HASH_TABLE_VALUE_WEAK:
1248 for (; e < sentinel; e++)
1249 if (!HENTRY_CLEAR_P (e))
1250 if (marked_p (e->value))
1254 case HASH_TABLE_KEY_CAR_WEAK:
1255 for (; e < sentinel; e++)
1256 if (!HENTRY_CLEAR_P (e))
1257 if (!CONSP (e->key) || marked_p (XCAR (e->key)))
1260 MARK_OBJ (e->value);
1264 case HASH_TABLE_VALUE_CAR_WEAK:
1265 for (; e < sentinel; e++)
1266 if (!HENTRY_CLEAR_P (e))
1267 if (!CONSP (e->value) || marked_p (XCAR (e->value)))
1270 MARK_OBJ (e->value);
1283 prune_weak_hash_tables (void)
1285 Lisp_Object hash_table, prev = Qnil;
1286 for (hash_table = Vall_weak_hash_tables;
1288 hash_table = XHASH_TABLE (hash_table)->next_weak)
1290 if (! marked_p (hash_table))
1292 /* This hash table itself is garbage. Remove it from the list. */
1294 Vall_weak_hash_tables = XHASH_TABLE (hash_table)->next_weak;
1296 XHASH_TABLE (prev)->next_weak = XHASH_TABLE (hash_table)->next_weak;
1300 /* Now, scan over all the pairs. Remove all of the pairs
1301 in which the key or value, or both, is unmarked
1302 (depending on the weakness of the hash table). */
1303 Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1304 hentry *entries = ht->hentries;
1305 hentry *sentinel = entries + ht->size;
1308 for (e = entries; e < sentinel; e++)
1309 if (!HENTRY_CLEAR_P (e))
1312 if (!marked_p (e->key) || !marked_p (e->value))
1314 remhash_1 (ht, entries, e);
1315 if (!HENTRY_CLEAR_P (e))
1325 /* Return a hash value for an array of Lisp_Objects of size SIZE. */
1328 internal_array_hash (Lisp_Object *arr, int size, int depth)
1331 unsigned long hash = 0;
1335 for (i = 0; i < size; i++)
1336 hash = HASH2 (hash, internal_hash (arr[i], depth + 1));
1340 /* just pick five elements scattered throughout the array.
1341 A slightly better approach would be to offset by some
1342 noise factor from the points chosen below. */
1343 for (i = 0; i < 5; i++)
1344 hash = HASH2 (hash, internal_hash (arr[i*size/5], depth + 1));
1349 /* Return a hash value for a Lisp_Object. This is for use when hashing
1350 objects with the comparison being `equal' (for `eq', you can just
1351 use the Lisp_Object itself as the hash value). You need to make a
1352 tradeoff between the speed of the hash function and how good the
1353 hashing is. In particular, the hash function needs to be FAST,
1354 so you can't just traipse down the whole tree hashing everything
1355 together. Most of the time, objects will differ in the first
1356 few elements you hash. Thus, we only go to a short depth (5)
1357 and only hash at most 5 elements out of a vector. Theoretically
1358 we could still take 5^5 time (a big big number) to compute a
1359 hash, but practically this won't ever happen. */
1362 internal_hash (Lisp_Object obj, int depth)
1368 /* no point in worrying about tail recursion, since we're not
1370 return HASH2 (internal_hash (XCAR (obj), depth + 1),
1371 internal_hash (XCDR (obj), depth + 1));
1375 return hash_string (XSTRING_DATA (obj), XSTRING_LENGTH (obj));
1379 return HASH2 (XVECTOR_LENGTH (obj),
1380 internal_array_hash (XVECTOR_DATA (obj),
1381 XVECTOR_LENGTH (obj),
1386 CONST struct lrecord_implementation
1387 *imp = XRECORD_LHEADER_IMPLEMENTATION (obj);
1389 return imp->hash (obj, depth);
1392 return LISP_HASH (obj);
1395 DEFUN ("sxhash", Fsxhash, 1, 1, 0, /*
1396 Return a hash value for OBJECT.
1397 (equal obj1 obj2) implies (= (sxhash obj1) (sxhash obj2)).
1401 return make_int (internal_hash (object, 0));
1405 xxDEFUN ("internal-hash-value", Finternal_hash_value, 1, 1, 0, /*
1406 Hash value of OBJECT. For debugging.
1407 The value is returned as (HIGH . LOW).
1411 /* This function is pretty 32bit-centric. */
1412 unsigned long hash = internal_hash (object, 0);
1413 return Fcons (hash >> 16, hash & 0xffff);
1418 /************************************************************************/
1419 /* initialization */
1420 /************************************************************************/
1423 syms_of_elhash (void)
1425 DEFSUBR (Fhash_table_p);
1426 DEFSUBR (Fmake_hash_table);
1427 DEFSUBR (Fcopy_hash_table);
1433 DEFSUBR (Fhash_table_count);
1434 DEFSUBR (Fhash_table_test);
1435 DEFSUBR (Fhash_table_size);
1436 DEFSUBR (Fhash_table_rehash_size);
1437 DEFSUBR (Fhash_table_rehash_threshold);
1438 DEFSUBR (Fhash_table_weakness);
1439 DEFSUBR (Fhash_table_type); /* obsolete */
1442 DEFSUBR (Finternal_hash_value);
1445 defsymbol (&Qhash_tablep, "hash-table-p");
1446 defsymbol (&Qhash_table, "hash-table");
1447 defsymbol (&Qhashtable, "hashtable");
1448 defsymbol (&Qweakness, "weakness");
1449 defsymbol (&Qvalue, "value");
1450 defsymbol (&Qrehash_size, "rehash-size");
1451 defsymbol (&Qrehash_threshold, "rehash-threshold");
1453 defsymbol (&Qweak, "weak"); /* obsolete */
1454 defsymbol (&Qkey_weak, "key-weak"); /* obsolete */
1455 defsymbol (&Qvalue_weak, "value-weak"); /* obsolete */
1456 defsymbol (&Qnon_weak, "non-weak"); /* obsolete */
1458 defkeyword (&Q_test, ":test");
1459 defkeyword (&Q_size, ":size");
1460 defkeyword (&Q_rehash_size, ":rehash-size");
1461 defkeyword (&Q_rehash_threshold, ":rehash-threshold");
1462 defkeyword (&Q_weakness, ":weakness");
1463 defkeyword (&Q_type, ":type"); /* obsolete */
1467 vars_of_elhash (void)
1469 /* This must NOT be staticpro'd */
1470 Vall_weak_hash_tables = Qnil;
1471 pdump_wire_list (&Vall_weak_hash_tables);