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, Qhashtable, Qhash_table;
31 Lisp_Object Qweak, Qkey_weak, Qvalue_weak, Qnon_weak;
32 static Lisp_Object Vall_weak_hash_tables;
33 static Lisp_Object Qrehash_size, Qrehash_threshold;
34 static Lisp_Object Q_size, Q_test, Q_type, Q_rehash_size, Q_rehash_threshold;
42 struct Lisp_Hash_Table
44 struct lcrecord_header header;
49 double rehash_threshold;
51 hash_table_hash_function_t hash_function;
52 hash_table_test_function_t test_function;
54 enum hash_table_type type; /* whether and how this hash table is weak */
55 Lisp_Object next_weak; /* Used to chain together all of the weak
56 hash tables. Don't mark through this. */
58 typedef struct Lisp_Hash_Table Lisp_Hash_Table;
60 #define HENTRY_CLEAR_P(hentry) ((*(EMACS_UINT*)(&((hentry)->key))) == 0)
61 #define CLEAR_HENTRY(hentry) ((*(EMACS_UINT*)(&((hentry)->key))) = 0)
63 #define HASH_TABLE_DEFAULT_SIZE 16
64 #define HASH_TABLE_DEFAULT_REHASH_SIZE 1.3
65 #define HASH_TABLE_MIN_SIZE 10
67 #define HASH_CODE(key, ht) \
68 (((((ht)->hash_function ? (ht)->hash_function (key) : LISP_HASH (key)) \
69 * (ht)->golden_ratio) \
72 #define KEYS_EQUAL_P(key1, key2, testfun) \
73 (EQ ((key1), (key2)) || ((testfun) && (testfun) ((key1), (key2))))
75 #define LINEAR_PROBING_LOOP(probe, entries, size) \
77 !HENTRY_CLEAR_P (probe) || \
78 (probe == entries + size ? \
79 (probe = entries, !HENTRY_CLEAR_P (probe)) : 0); \
82 #ifndef ERROR_CHECK_HASH_TABLE
83 # ifdef ERROR_CHECK_TYPECHECK
84 # define ERROR_CHECK_HASH_TABLE 1
86 # define ERROR_CHECK_HASH_TABLE 0
90 #if ERROR_CHECK_HASH_TABLE
92 check_hash_table_invariants (Lisp_Hash_Table *ht)
94 assert (ht->count < ht->size);
95 assert (ht->count <= ht->rehash_count);
96 assert (ht->rehash_count < ht->size);
97 assert ((double) ht->count * ht->rehash_threshold - 1 <= (double) ht->rehash_count);
98 assert (HENTRY_CLEAR_P (ht->hentries + ht->size));
101 #define check_hash_table_invariants(ht)
104 /* We use linear probing instead of double hashing, despite its lack
105 of blessing by Knuth and company, because, as a result of the
106 increasing discrepancy between CPU speeds and memory speeds, cache
107 behavior is becoming increasingly important, e.g:
109 For a trivial loop, the penalty for non-sequential access of an array is:
110 - a factor of 3-4 on Pentium Pro 200 Mhz
111 - a factor of 10 on Ultrasparc 300 Mhz */
113 /* Return a suitable size for a hash table, with at least SIZE slots. */
115 hash_table_size (size_t requested_size)
117 /* Return some prime near, but greater than or equal to, SIZE.
118 Decades from the time of writing, someone will have a system large
119 enough that the list below will be too short... */
120 static CONST size_t primes [] =
122 19, 29, 41, 59, 79, 107, 149, 197, 263, 347, 457, 599, 787, 1031,
123 1361, 1777, 2333, 3037, 3967, 5167, 6719, 8737, 11369, 14783,
124 19219, 24989, 32491, 42257, 54941, 71429, 92861, 120721, 156941,
125 204047, 265271, 344857, 448321, 582821, 757693, 985003, 1280519,
126 1664681, 2164111, 2813353, 3657361, 4754591, 6180989, 8035301,
127 10445899, 13579681, 17653589, 22949669, 29834603, 38784989,
128 50420551, 65546729, 85210757, 110774011, 144006217, 187208107,
129 243370577, 316381771, 411296309, 534685237, 695090819, 903618083,
130 1174703521, 1527114613, 1985248999, 2580823717UL, 3355070839UL
132 /* We've heard of binary search. */
134 for (low = 0, high = countof (primes) - 1; high - low > 1;)
136 /* Loop Invariant: size < primes [high] */
137 int mid = (low + high) / 2;
138 if (primes [mid] < requested_size)
143 return primes [high];
147 #if 0 /* I don't think these are needed any more.
148 If using the general lisp_object_equal_*() functions
149 causes efficiency problems, these can be resurrected. --ben */
150 /* equality and hash functions for Lisp strings */
152 lisp_string_equal (Lisp_Object str1, Lisp_Object str2)
154 /* This is wrong anyway. You can't use strcmp() on Lisp strings,
155 because they can contain zero characters. */
156 return !strcmp ((char *) XSTRING_DATA (str1), (char *) XSTRING_DATA (str2));
160 lisp_string_hash (Lisp_Object obj)
162 return hash_string (XSTRING_DATA (str), XSTRING_LENGTH (str));
168 lisp_object_eql_equal (Lisp_Object obj1, Lisp_Object obj2)
170 return EQ (obj1, obj2) || (FLOATP (obj1) && internal_equal (obj1, obj2, 0));
174 lisp_object_eql_hash (Lisp_Object obj)
176 return FLOATP (obj) ? internal_hash (obj, 0) : LISP_HASH (obj);
180 lisp_object_equal_equal (Lisp_Object obj1, Lisp_Object obj2)
182 return internal_equal (obj1, obj2, 0);
186 lisp_object_equal_hash (Lisp_Object obj)
188 return internal_hash (obj, 0);
193 mark_hash_table (Lisp_Object obj, void (*markobj) (Lisp_Object))
195 Lisp_Hash_Table *ht = XHASH_TABLE (obj);
197 /* If the hash table is weak, we don't want to mark the keys and
198 values (we scan over them after everything else has been marked,
199 and mark or remove them as necessary). */
200 if (ht->type == HASH_TABLE_NON_WEAK)
202 hentry *e, *sentinel;
204 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
205 if (!HENTRY_CLEAR_P (e))
214 /* Equality of hash tables. Two hash tables are equal when they are of
215 the same type and test function, they have the same number of
216 elements, and for each key in the hash table, the values are `equal'.
218 This is similar to Common Lisp `equalp' of hash tables, with the
219 difference that CL requires the keys to be compared with the test
220 function, which we don't do. Doing that would require consing, and
221 consing is a bad idea in `equal'. Anyway, our method should provide
222 the same result -- if the keys are not equal according to the test
223 function, then Fgethash() in hash_table_equal_mapper() will fail. */
225 hash_table_equal (Lisp_Object hash_table1, Lisp_Object hash_table2, int depth)
227 Lisp_Hash_Table *ht1 = XHASH_TABLE (hash_table1);
228 Lisp_Hash_Table *ht2 = XHASH_TABLE (hash_table2);
229 hentry *e, *sentinel;
231 if ((ht1->test_function != ht2->test_function) ||
232 (ht1->type != ht2->type) ||
233 (ht1->count != ht2->count))
238 for (e = ht1->hentries, sentinel = e + ht1->size; e < sentinel; e++)
239 if (!HENTRY_CLEAR_P (e))
240 /* Look up the key in the other hash table, and compare the values. */
242 Lisp_Object value_in_other = Fgethash (e->key, hash_table2, Qunbound);
243 if (UNBOUNDP (value_in_other) ||
244 !internal_equal (e->value, value_in_other, depth))
245 return 0; /* Give up */
251 /* Printing hash tables.
253 This is non-trivial, because we use a readable structure-style
254 syntax for hash tables. This means that a typical hash table will be
255 readably printed in the form of:
257 #s(hash-table size 2 data (key1 value1 key2 value2))
259 The supported keywords are `type' (non-weak (or nil), weak,
260 key-weak and value-weak), `test' (eql (or nil), eq or equal),
261 `size' (a natnum or nil) and `data' (a list).
263 If `print-readably' is non-nil, then a simpler syntax is used; for
266 #<hash-table size 2/13 data (key1 value1 key2 value2) 0x874d>
268 The data is truncated to four pairs, and the rest is shown with
269 `...'. This printer does not cons. */
272 /* Print the data of the hash table. This maps through a Lisp
273 hash table and prints key/value pairs using PRINTCHARFUN. */
275 print_hash_table_data (Lisp_Hash_Table *ht, Lisp_Object printcharfun)
278 hentry *e, *sentinel;
280 write_c_string (" data (", printcharfun);
282 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
283 if (!HENTRY_CLEAR_P (e))
286 write_c_string (" ", printcharfun);
287 if (!print_readably && count > 3)
289 write_c_string ("...", printcharfun);
292 print_internal (e->key, printcharfun, 1);
293 write_c_string (" ", printcharfun);
294 print_internal (e->value, printcharfun, 1);
298 write_c_string (")", printcharfun);
302 print_hash_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
304 Lisp_Hash_Table *ht = XHASH_TABLE (obj);
307 write_c_string (print_readably ? "#s(hash-table" : "#<hash-table",
310 if (ht->type != HASH_TABLE_NON_WEAK)
312 sprintf (buf, " type %s",
313 (ht->type == HASH_TABLE_WEAK ? "weak" :
314 ht->type == HASH_TABLE_KEY_WEAK ? "key-weak" :
315 ht->type == HASH_TABLE_VALUE_WEAK ? "value-weak" :
316 "you-d-better-not-see-this"));
317 write_c_string (buf, printcharfun);
320 /* These checks have a kludgy look to them, but they are safe.
321 Due to nature of hashing, you cannot use arbitrary
322 test functions anyway. */
323 if (!ht->test_function)
324 write_c_string (" test eq", printcharfun);
325 else if (ht->test_function == lisp_object_equal_equal)
326 write_c_string (" test equal", printcharfun);
327 else if (ht->test_function == lisp_object_eql_equal)
332 if (ht->count || !print_readably)
335 sprintf (buf, " size %lu", (unsigned long) ht->count);
337 sprintf (buf, " size %lu/%lu",
338 (unsigned long) ht->count,
339 (unsigned long) ht->size);
340 write_c_string (buf, printcharfun);
344 print_hash_table_data (ht, printcharfun);
347 write_c_string (")", printcharfun);
350 sprintf (buf, " 0x%x>", ht->header.uid);
351 write_c_string (buf, printcharfun);
356 finalize_hash_table (void *header, int for_disksave)
360 Lisp_Hash_Table *ht = (Lisp_Hash_Table *) header;
362 xfree (ht->hentries);
367 static const struct lrecord_description hentry_description_1[] = {
368 { XD_LISP_OBJECT, offsetof(hentry, key), 2 },
372 static const struct struct_description hentry_description = {
377 static const struct lrecord_description hash_table_description[] = {
378 { XD_SIZE_T, offsetof(Lisp_Hash_Table, size) },
379 { XD_STRUCT_PTR, offsetof(Lisp_Hash_Table, hentries), XD_INDIRECT(0), &hentry_description },
383 DEFINE_LRECORD_IMPLEMENTATION ("hash-table", hash_table,
384 mark_hash_table, print_hash_table,
386 /* #### Implement hash_table_hash()! */
388 hash_table_description,
391 static Lisp_Hash_Table *
392 xhash_table (Lisp_Object hash_table)
395 CHECK_HASH_TABLE (hash_table);
396 check_hash_table_invariants (XHASH_TABLE (hash_table));
397 return XHASH_TABLE (hash_table);
401 /************************************************************************/
402 /* Creation of Hash Tables */
403 /************************************************************************/
405 /* Creation of hash tables, without error-checking. */
407 hash_table_rehash_threshold (Lisp_Hash_Table *ht)
410 ht->rehash_threshold > 0.0 ? ht->rehash_threshold :
411 ht->size > 4096 && !ht->test_function ? 0.7 : 0.6;
415 compute_hash_table_derived_values (Lisp_Hash_Table *ht)
417 ht->rehash_count = (size_t)
418 ((double) ht->size * hash_table_rehash_threshold (ht));
419 ht->golden_ratio = (size_t)
420 ((double) ht->size * (.6180339887 / (double) sizeof (Lisp_Object)));
424 make_general_lisp_hash_table (size_t size,
425 enum hash_table_type type,
426 enum hash_table_test test,
428 double rehash_threshold)
430 Lisp_Object hash_table;
431 Lisp_Hash_Table *ht = alloc_lcrecord_type (Lisp_Hash_Table, &lrecord_hash_table);
434 ht->rehash_size = rehash_size;
435 ht->rehash_threshold = rehash_threshold;
440 ht->test_function = 0;
441 ht->hash_function = 0;
445 ht->test_function = lisp_object_eql_equal;
446 ht->hash_function = lisp_object_eql_hash;
449 case HASH_TABLE_EQUAL:
450 ht->test_function = lisp_object_equal_equal;
451 ht->hash_function = lisp_object_equal_hash;
458 if (ht->rehash_size <= 0.0)
459 ht->rehash_size = HASH_TABLE_DEFAULT_REHASH_SIZE;
460 if (size < HASH_TABLE_MIN_SIZE)
461 size = HASH_TABLE_MIN_SIZE;
462 if (rehash_threshold < 0.0)
463 rehash_threshold = 0.75;
465 hash_table_size ((size_t) ((double) size / hash_table_rehash_threshold (ht)) + 1);
467 compute_hash_table_derived_values (ht);
469 /* We leave room for one never-occupied sentinel hentry at the end. */
470 ht->hentries = xnew_array (hentry, ht->size + 1);
473 hentry *e, *sentinel;
474 for (e = ht->hentries, sentinel = e + ht->size; e <= sentinel; e++)
478 XSETHASH_TABLE (hash_table, ht);
480 if (type == HASH_TABLE_NON_WEAK)
481 ht->next_weak = Qunbound;
483 ht->next_weak = Vall_weak_hash_tables, Vall_weak_hash_tables = hash_table;
489 make_lisp_hash_table (size_t size,
490 enum hash_table_type type,
491 enum hash_table_test test)
493 return make_general_lisp_hash_table (size, type, test,
494 HASH_TABLE_DEFAULT_REHASH_SIZE, -1.0);
497 /* Pretty reading of hash tables.
499 Here we use the existing structures mechanism (which is,
500 unfortunately, pretty cumbersome) for validating and instantiating
501 the hash tables. The idea is that the side-effect of reading a
502 #s(hash-table PLIST) object is creation of a hash table with desired
503 properties, and that the hash table is returned. */
505 /* Validation functions: each keyword provides its own validation
506 function. The errors should maybe be continuable, but it is
507 unclear how this would cope with ERRB. */
509 hash_table_size_validate (Lisp_Object keyword, Lisp_Object value,
515 maybe_signal_error (Qwrong_type_argument, list2 (Qnatnump, value),
521 decode_hash_table_size (Lisp_Object obj)
523 return NILP (obj) ? HASH_TABLE_DEFAULT_SIZE : XINT (obj);
527 hash_table_type_validate (Lisp_Object keyword, Lisp_Object value,
530 if (EQ (value, Qnil)) return 1;
531 if (EQ (value, Qnon_weak)) return 1;
532 if (EQ (value, Qweak)) return 1;
533 if (EQ (value, Qkey_weak)) return 1;
534 if (EQ (value, Qvalue_weak)) return 1;
536 maybe_signal_simple_error ("Invalid hash table type",
537 value, Qhash_table, errb);
541 static enum hash_table_type
542 decode_hash_table_type (Lisp_Object obj)
544 if (EQ (obj, Qnil)) return HASH_TABLE_NON_WEAK;
545 if (EQ (obj, Qnon_weak)) return HASH_TABLE_NON_WEAK;
546 if (EQ (obj, Qweak)) return HASH_TABLE_WEAK;
547 if (EQ (obj, Qkey_weak)) return HASH_TABLE_KEY_WEAK;
548 if (EQ (obj, Qvalue_weak)) return HASH_TABLE_VALUE_WEAK;
550 signal_simple_error ("Invalid hash table type", obj);
551 return HASH_TABLE_NON_WEAK; /* not reached */
555 hash_table_test_validate (Lisp_Object keyword, Lisp_Object value,
558 if (EQ (value, Qnil)) return 1;
559 if (EQ (value, Qeq)) return 1;
560 if (EQ (value, Qequal)) return 1;
561 if (EQ (value, Qeql)) return 1;
563 maybe_signal_simple_error ("Invalid hash table test",
564 value, Qhash_table, errb);
568 static enum hash_table_test
569 decode_hash_table_test (Lisp_Object obj)
571 if (EQ (obj, Qnil)) return HASH_TABLE_EQL;
572 if (EQ (obj, Qeq)) return HASH_TABLE_EQ;
573 if (EQ (obj, Qequal)) return HASH_TABLE_EQUAL;
574 if (EQ (obj, Qeql)) return HASH_TABLE_EQL;
576 signal_simple_error ("Invalid hash table test", obj);
577 return HASH_TABLE_EQ; /* not reached */
581 hash_table_rehash_size_validate (Lisp_Object keyword, Lisp_Object value,
586 maybe_signal_error (Qwrong_type_argument, list2 (Qfloatp, value),
592 double rehash_size = XFLOAT_DATA (value);
593 if (rehash_size <= 1.0)
595 maybe_signal_simple_error
596 ("Hash table rehash size must be greater than 1.0",
597 value, Qhash_table, errb);
606 decode_hash_table_rehash_size (Lisp_Object rehash_size)
608 return NILP (rehash_size) ? -1.0 : XFLOAT_DATA (rehash_size);
612 hash_table_rehash_threshold_validate (Lisp_Object keyword, Lisp_Object value,
617 maybe_signal_error (Qwrong_type_argument, list2 (Qfloatp, value),
623 double rehash_threshold = XFLOAT_DATA (value);
624 if (rehash_threshold <= 0.0 || rehash_threshold >= 1.0)
626 maybe_signal_simple_error
627 ("Hash table rehash threshold must be between 0.0 and 1.0",
628 value, Qhash_table, errb);
637 decode_hash_table_rehash_threshold (Lisp_Object rehash_threshold)
639 return NILP (rehash_threshold) ? -1.0 : XFLOAT_DATA (rehash_threshold);
643 hash_table_data_validate (Lisp_Object keyword, Lisp_Object value,
648 GET_EXTERNAL_LIST_LENGTH (value, len);
652 maybe_signal_simple_error
653 ("Hash table data must have alternating key/value pairs",
654 value, Qhash_table, errb);
660 /* The actual instantiation of a hash table. This does practically no
661 error checking, because it relies on the fact that the paranoid
662 functions above have error-checked everything to the last details.
663 If this assumption is wrong, we will get a crash immediately (with
664 error-checking compiled in), and we'll know if there is a bug in
665 the structure mechanism. So there. */
667 hash_table_instantiate (Lisp_Object plist)
669 Lisp_Object hash_table;
670 Lisp_Object test = Qnil;
671 Lisp_Object type = Qnil;
672 Lisp_Object size = Qnil;
673 Lisp_Object data = Qnil;
674 Lisp_Object rehash_size = Qnil;
675 Lisp_Object rehash_threshold = Qnil;
677 while (!NILP (plist))
679 Lisp_Object key, value;
680 key = XCAR (plist); plist = XCDR (plist);
681 value = XCAR (plist); plist = XCDR (plist);
683 if (EQ (key, Qtest)) test = value;
684 else if (EQ (key, Qtype)) type = value;
685 else if (EQ (key, Qsize)) size = value;
686 else if (EQ (key, Qdata)) data = value;
687 else if (EQ (key, Qrehash_size)) rehash_size = value;
688 else if (EQ (key, Qrehash_threshold)) rehash_threshold = value;
693 /* Create the hash table. */
694 hash_table = make_general_lisp_hash_table
695 (decode_hash_table_size (size),
696 decode_hash_table_type (type),
697 decode_hash_table_test (test),
698 decode_hash_table_rehash_size (rehash_size),
699 decode_hash_table_rehash_threshold (rehash_threshold));
701 /* I'm not sure whether this can GC, but better safe than sorry. */
706 /* And fill it with data. */
709 Lisp_Object key, value;
710 key = XCAR (data); data = XCDR (data);
711 value = XCAR (data); data = XCDR (data);
712 Fputhash (key, value, hash_table);
721 structure_type_create_hash_table_structure_name (Lisp_Object structure_name)
723 struct structure_type *st;
725 st = define_structure_type (structure_name, 0, hash_table_instantiate);
726 define_structure_type_keyword (st, Qsize, hash_table_size_validate);
727 define_structure_type_keyword (st, Qtest, hash_table_test_validate);
728 define_structure_type_keyword (st, Qtype, hash_table_type_validate);
729 define_structure_type_keyword (st, Qdata, hash_table_data_validate);
730 define_structure_type_keyword (st, Qrehash_size, hash_table_rehash_size_validate);
731 define_structure_type_keyword (st, Qrehash_threshold, hash_table_rehash_threshold_validate);
734 /* Create a built-in Lisp structure type named `hash-table'.
735 We make #s(hashtable ...) equivalent to #s(hash-table ...),
736 for backward comptabibility.
737 This is called from emacs.c. */
739 structure_type_create_hash_table (void)
741 structure_type_create_hash_table_structure_name (Qhash_table);
742 structure_type_create_hash_table_structure_name (Qhashtable); /* compat */
746 /************************************************************************/
747 /* Definition of Lisp-visible methods */
748 /************************************************************************/
750 DEFUN ("hash-table-p", Fhash_table_p, 1, 1, 0, /*
751 Return t if OBJECT is a hash table, else nil.
755 return HASH_TABLEP (object) ? Qt : Qnil;
758 DEFUN ("make-hash-table", Fmake_hash_table, 0, MANY, 0, /*
759 Return a new empty hash table object.
760 Use Common Lisp style keywords to specify hash table properties.
761 (make-hash-table &key :size :test :type :rehash-size :rehash-threshold)
763 Keyword :size specifies the number of keys likely to be inserted.
764 This number of entries can be inserted without enlarging the hash table.
766 Keyword :test can be `eq', `eql' (default) or `equal'.
767 Comparison between keys is done using this function.
768 If speed is important, consider using `eq'.
769 When storing strings in the hash table, you will likely need to use `equal'.
771 Keyword :type can be `non-weak' (default), `weak', `key-weak' or `value-weak'.
773 A weak hash table is one whose pointers do not count as GC referents:
774 for any key-value pair in the hash table, if the only remaining pointer
775 to either the key or the value is in a weak hash table, then the pair
776 will be removed from the hash table, and the key and value collected.
777 A non-weak hash table (or any other pointer) would prevent the object
778 from being collected.
780 A key-weak hash table is similar to a fully-weak hash table except that
781 a key-value pair will be removed only if the key remains unmarked
782 outside of weak hash tables. The pair will remain in the hash table if
783 the key is pointed to by something other than a weak hash table, even
786 A value-weak hash table is similar to a fully-weak hash table except
787 that a key-value pair will be removed only if the value remains
788 unmarked outside of weak hash tables. The pair will remain in the
789 hash table if the value is pointed to by something other than a weak
790 hash table, even if the key is not.
792 Keyword :rehash-size must be a float greater than 1.0, and specifies
793 the factor by which to increase the size of the hash table when enlarging.
795 Keyword :rehash-threshold must be a float between 0.0 and 1.0,
796 and specifies the load factor of the hash table which triggers enlarging.
799 (int nargs, Lisp_Object *args))
802 Lisp_Object size = Qnil;
803 Lisp_Object type = Qnil;
804 Lisp_Object test = Qnil;
805 Lisp_Object rehash_size = Qnil;
806 Lisp_Object rehash_threshold = Qnil;
810 Lisp_Object keyword, value;
813 if (!KEYWORDP (keyword))
814 signal_simple_error ("Invalid hash table property keyword", keyword);
816 signal_simple_error ("Hash table property requires a value", keyword);
820 if (EQ (keyword, Q_size)) size = value;
821 else if (EQ (keyword, Q_type)) type = value;
822 else if (EQ (keyword, Q_test)) test = value;
823 else if (EQ (keyword, Q_rehash_size)) rehash_size = value;
824 else if (EQ (keyword, Q_rehash_threshold)) rehash_threshold = value;
825 else signal_simple_error ("Invalid hash table property keyword", keyword);
828 #define VALIDATE_VAR(var) \
829 if (!NILP (var)) hash_table_##var##_validate (Q##var, var, ERROR_ME);
834 VALIDATE_VAR (rehash_size);
835 VALIDATE_VAR (rehash_threshold);
837 return make_general_lisp_hash_table
838 (decode_hash_table_size (size),
839 decode_hash_table_type (type),
840 decode_hash_table_test (test),
841 decode_hash_table_rehash_size (rehash_size),
842 decode_hash_table_rehash_threshold (rehash_threshold));
845 DEFUN ("copy-hash-table", Fcopy_hash_table, 1, 1, 0, /*
846 Return a new hash table containing the same keys and values as HASH-TABLE.
847 The keys and values will not themselves be copied.
851 CONST Lisp_Hash_Table *ht_old = xhash_table (hash_table);
852 Lisp_Hash_Table *ht = alloc_lcrecord_type (Lisp_Hash_Table, &lrecord_hash_table);
854 copy_lcrecord (ht, ht_old);
856 ht->hentries = xnew_array (hentry, ht_old->size + 1);
857 memcpy (ht->hentries, ht_old->hentries, (ht_old->size + 1) * sizeof (hentry));
859 XSETHASH_TABLE (hash_table, ht);
861 if (! EQ (ht->next_weak, Qunbound))
863 ht->next_weak = Vall_weak_hash_tables;
864 Vall_weak_hash_tables = hash_table;
871 enlarge_hash_table (Lisp_Hash_Table *ht)
873 hentry *old_entries, *new_entries, *old_sentinel, *new_sentinel, *e;
874 size_t old_size, new_size;
877 new_size = ht->size =
878 hash_table_size ((size_t) ((double) old_size * ht->rehash_size));
880 old_entries = ht->hentries;
882 ht->hentries = xnew_array (hentry, new_size + 1);
883 new_entries = ht->hentries;
885 old_sentinel = old_entries + old_size;
886 new_sentinel = new_entries + new_size;
888 for (e = new_entries; e <= new_sentinel; e++)
891 compute_hash_table_derived_values (ht);
893 for (e = old_entries; e < old_sentinel; e++)
894 if (!HENTRY_CLEAR_P (e))
896 hentry *probe = new_entries + HASH_CODE (e->key, ht);
897 LINEAR_PROBING_LOOP (probe, new_entries, new_size)
906 find_hentry (Lisp_Object key, CONST Lisp_Hash_Table *ht)
908 hash_table_test_function_t test_function = ht->test_function;
909 hentry *entries = ht->hentries;
910 hentry *probe = entries + HASH_CODE (key, ht);
912 LINEAR_PROBING_LOOP (probe, entries, ht->size)
913 if (KEYS_EQUAL_P (probe->key, key, test_function))
919 DEFUN ("gethash", Fgethash, 2, 3, 0, /*
920 Find hash value for KEY in HASH-TABLE.
921 If there is no corresponding value, return DEFAULT (which defaults to nil).
923 (key, hash_table, default_))
925 CONST Lisp_Hash_Table *ht = xhash_table (hash_table);
926 hentry *e = find_hentry (key, ht);
928 return HENTRY_CLEAR_P (e) ? default_ : e->value;
931 DEFUN ("puthash", Fputhash, 3, 3, 0, /*
932 Hash KEY to VALUE in HASH-TABLE.
934 (key, value, hash_table))
936 Lisp_Hash_Table *ht = xhash_table (hash_table);
937 hentry *e = find_hentry (key, ht);
939 if (!HENTRY_CLEAR_P (e))
940 return e->value = value;
945 if (++ht->count >= ht->rehash_count)
946 enlarge_hash_table (ht);
951 /* Remove hentry pointed at by PROBE.
952 Subsequent entries are removed and reinserted.
953 We don't use tombstones - too wasteful. */
955 remhash_1 (Lisp_Hash_Table *ht, hentry *entries, hentry *probe)
957 size_t size = ht->size;
958 CLEAR_HENTRY (probe++);
961 LINEAR_PROBING_LOOP (probe, entries, size)
963 Lisp_Object key = probe->key;
964 hentry *probe2 = entries + HASH_CODE (key, ht);
965 LINEAR_PROBING_LOOP (probe2, entries, size)
966 if (EQ (probe2->key, key))
967 /* hentry at probe doesn't need to move. */
968 goto continue_outer_loop;
969 /* Move hentry from probe to new home at probe2. */
971 CLEAR_HENTRY (probe);
972 continue_outer_loop: continue;
976 DEFUN ("remhash", Fremhash, 2, 2, 0, /*
977 Remove the entry for KEY from HASH-TABLE.
978 Do nothing if there is no entry for KEY in HASH-TABLE.
982 Lisp_Hash_Table *ht = xhash_table (hash_table);
983 hentry *e = find_hentry (key, ht);
985 if (HENTRY_CLEAR_P (e))
988 remhash_1 (ht, ht->hentries, e);
992 DEFUN ("clrhash", Fclrhash, 1, 1, 0, /*
993 Remove all entries from HASH-TABLE, leaving it empty.
997 Lisp_Hash_Table *ht = xhash_table (hash_table);
998 hentry *e, *sentinel;
1000 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1007 /************************************************************************/
1008 /* Accessor Functions */
1009 /************************************************************************/
1011 DEFUN ("hash-table-count", Fhash_table_count, 1, 1, 0, /*
1012 Return the number of entries in HASH-TABLE.
1016 return make_int (xhash_table (hash_table)->count);
1019 DEFUN ("hash-table-size", Fhash_table_size, 1, 1, 0, /*
1020 Return the size of HASH-TABLE.
1021 This is the current number of slots in HASH-TABLE, whether occupied or not.
1025 return make_int (xhash_table (hash_table)->size);
1028 DEFUN ("hash-table-type", Fhash_table_type, 1, 1, 0, /*
1029 Return the type of HASH-TABLE.
1030 This can be one of `non-weak', `weak', `key-weak' or `value-weak'.
1034 switch (xhash_table (hash_table)->type)
1036 case HASH_TABLE_WEAK: return Qweak;
1037 case HASH_TABLE_KEY_WEAK: return Qkey_weak;
1038 case HASH_TABLE_VALUE_WEAK: return Qvalue_weak;
1039 default: return Qnon_weak;
1043 DEFUN ("hash-table-test", Fhash_table_test, 1, 1, 0, /*
1044 Return the test function of HASH-TABLE.
1045 This can be one of `eq', `eql' or `equal'.
1049 hash_table_test_function_t fun = xhash_table (hash_table)->test_function;
1051 return (fun == lisp_object_eql_equal ? Qeql :
1052 fun == lisp_object_equal_equal ? Qequal :
1056 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size, 1, 1, 0, /*
1057 Return the current rehash size of HASH-TABLE.
1058 This is a float greater than 1.0; the factor by which HASH-TABLE
1059 is enlarged when the rehash threshold is exceeded.
1063 return make_float (xhash_table (hash_table)->rehash_size);
1066 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold, 1, 1, 0, /*
1067 Return the current rehash threshold of HASH-TABLE.
1068 This is a float between 0.0 and 1.0; the maximum `load factor' of HASH-TABLE,
1069 beyond which the HASH-TABLE is enlarged by rehashing.
1073 return make_float (hash_table_rehash_threshold (xhash_table (hash_table)));
1076 /************************************************************************/
1077 /* Mapping Functions */
1078 /************************************************************************/
1079 DEFUN ("maphash", Fmaphash, 2, 2, 0, /*
1080 Map FUNCTION over entries in HASH-TABLE, calling it with two args,
1081 each key and value in HASH-TABLE.
1083 FUNCTION may not modify HASH-TABLE, with the one exception that FUNCTION
1084 may remhash or puthash the entry currently being processed by FUNCTION.
1086 (function, hash_table))
1088 CONST Lisp_Hash_Table *ht = xhash_table (hash_table);
1089 CONST hentry *e, *sentinel;
1091 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1092 if (!HENTRY_CLEAR_P (e))
1094 Lisp_Object args[3], key;
1100 Ffuncall (countof (args), args);
1101 /* Has FUNCTION done a remhash? */
1102 if (!EQ (key, e->key) && !HENTRY_CLEAR_P (e))
1109 /* Map *C* function FUNCTION over the elements of a lisp hash table. */
1111 elisp_maphash (maphash_function_t function,
1112 Lisp_Object hash_table, void *extra_arg)
1114 CONST Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1115 CONST hentry *e, *sentinel;
1117 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1118 if (!HENTRY_CLEAR_P (e))
1123 if (function (key, e->value, extra_arg))
1125 /* Has FUNCTION done a remhash? */
1126 if (!EQ (key, e->key) && !HENTRY_CLEAR_P (e))
1131 /* Remove all elements of a lisp hash table satisfying *C* predicate PREDICATE. */
1133 elisp_map_remhash (maphash_function_t predicate,
1134 Lisp_Object hash_table, void *extra_arg)
1136 Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1137 hentry *e, *entries, *sentinel;
1139 for (e = entries = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1140 if (!HENTRY_CLEAR_P (e))
1143 if (predicate (e->key, e->value, extra_arg))
1145 remhash_1 (ht, entries, e);
1146 if (!HENTRY_CLEAR_P (e))
1153 /************************************************************************/
1154 /* garbage collecting weak hash tables */
1155 /************************************************************************/
1157 /* Complete the marking for semi-weak hash tables. */
1159 finish_marking_weak_hash_tables (int (*obj_marked_p) (Lisp_Object),
1160 void (*markobj) (Lisp_Object))
1162 Lisp_Object hash_table;
1165 for (hash_table = Vall_weak_hash_tables;
1166 !GC_NILP (hash_table);
1167 hash_table = XHASH_TABLE (hash_table)->next_weak)
1169 CONST Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1170 CONST hentry *e = ht->hentries;
1171 CONST hentry *sentinel = e + ht->size;
1173 if (! obj_marked_p (hash_table))
1174 /* The hash table is probably garbage. Ignore it. */
1177 /* Now, scan over all the pairs. For all pairs that are
1178 half-marked, we may need to mark the other half if we're
1179 keeping this pair. */
1180 #define MARK_OBJ(obj) \
1181 do { if (!obj_marked_p (obj)) markobj (obj), did_mark = 1; } while (0)
1185 case HASH_TABLE_KEY_WEAK:
1186 for (; e < sentinel; e++)
1187 if (!HENTRY_CLEAR_P (e))
1188 if (obj_marked_p (e->key))
1189 MARK_OBJ (e->value);
1192 case HASH_TABLE_VALUE_WEAK:
1193 for (; e < sentinel; e++)
1194 if (!HENTRY_CLEAR_P (e))
1195 if (obj_marked_p (e->value))
1199 case HASH_TABLE_KEY_CAR_WEAK:
1200 for (; e < sentinel; e++)
1201 if (!HENTRY_CLEAR_P (e))
1202 if (!CONSP (e->key) || obj_marked_p (XCAR (e->key)))
1205 MARK_OBJ (e->value);
1209 case HASH_TABLE_VALUE_CAR_WEAK:
1210 for (; e < sentinel; e++)
1211 if (!HENTRY_CLEAR_P (e))
1212 if (!CONSP (e->value) || obj_marked_p (XCAR (e->value)))
1215 MARK_OBJ (e->value);
1228 prune_weak_hash_tables (int (*obj_marked_p) (Lisp_Object))
1230 Lisp_Object hash_table, prev = Qnil;
1231 for (hash_table = Vall_weak_hash_tables;
1232 !GC_NILP (hash_table);
1233 hash_table = XHASH_TABLE (hash_table)->next_weak)
1235 if (! obj_marked_p (hash_table))
1237 /* This hash table itself is garbage. Remove it from the list. */
1239 Vall_weak_hash_tables = XHASH_TABLE (hash_table)->next_weak;
1241 XHASH_TABLE (prev)->next_weak = XHASH_TABLE (hash_table)->next_weak;
1245 /* Now, scan over all the pairs. Remove all of the pairs
1246 in which the key or value, or both, is unmarked
1247 (depending on the type of weak hash table). */
1248 Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1249 hentry *entries = ht->hentries;
1250 hentry *sentinel = entries + ht->size;
1253 for (e = entries; e < sentinel; e++)
1254 if (!HENTRY_CLEAR_P (e))
1257 if (!obj_marked_p (e->key) || !obj_marked_p (e->value))
1259 remhash_1 (ht, entries, e);
1260 if (!HENTRY_CLEAR_P (e))
1270 /* Return a hash value for an array of Lisp_Objects of size SIZE. */
1273 internal_array_hash (Lisp_Object *arr, int size, int depth)
1276 unsigned long hash = 0;
1280 for (i = 0; i < size; i++)
1281 hash = HASH2 (hash, internal_hash (arr[i], depth + 1));
1285 /* just pick five elements scattered throughout the array.
1286 A slightly better approach would be to offset by some
1287 noise factor from the points chosen below. */
1288 for (i = 0; i < 5; i++)
1289 hash = HASH2 (hash, internal_hash (arr[i*size/5], depth + 1));
1294 /* Return a hash value for a Lisp_Object. This is for use when hashing
1295 objects with the comparison being `equal' (for `eq', you can just
1296 use the Lisp_Object itself as the hash value). You need to make a
1297 tradeoff between the speed of the hash function and how good the
1298 hashing is. In particular, the hash function needs to be FAST,
1299 so you can't just traipse down the whole tree hashing everything
1300 together. Most of the time, objects will differ in the first
1301 few elements you hash. Thus, we only go to a short depth (5)
1302 and only hash at most 5 elements out of a vector. Theoretically
1303 we could still take 5^5 time (a big big number) to compute a
1304 hash, but practically this won't ever happen. */
1307 internal_hash (Lisp_Object obj, int depth)
1313 /* no point in worrying about tail recursion, since we're not
1315 return HASH2 (internal_hash (XCAR (obj), depth + 1),
1316 internal_hash (XCDR (obj), depth + 1));
1320 return hash_string (XSTRING_DATA (obj), XSTRING_LENGTH (obj));
1324 return HASH2 (XVECTOR_LENGTH (obj),
1325 internal_array_hash (XVECTOR_DATA (obj),
1326 XVECTOR_LENGTH (obj),
1331 CONST struct lrecord_implementation
1332 *imp = XRECORD_LHEADER_IMPLEMENTATION (obj);
1334 return imp->hash (obj, depth);
1337 return LISP_HASH (obj);
1341 xxDEFUN ("internal-hash-value", Finternal_hash_value, 1, 1, 0, /*
1342 Hash value of OBJECT. For debugging.
1343 The value is returned as (HIGH . LOW).
1347 /* This function is pretty 32bit-centric. */
1348 unsigned long hash = internal_hash (object, 0);
1349 return Fcons (hash >> 16, hash & 0xffff);
1354 /************************************************************************/
1355 /* initialization */
1356 /************************************************************************/
1359 syms_of_elhash (void)
1361 DEFSUBR (Fhash_table_p);
1362 DEFSUBR (Fmake_hash_table);
1363 DEFSUBR (Fcopy_hash_table);
1369 DEFSUBR (Fhash_table_count);
1370 DEFSUBR (Fhash_table_size);
1371 DEFSUBR (Fhash_table_rehash_size);
1372 DEFSUBR (Fhash_table_rehash_threshold);
1373 DEFSUBR (Fhash_table_type);
1374 DEFSUBR (Fhash_table_test);
1376 DEFSUBR (Finternal_hash_value);
1379 defsymbol (&Qhash_tablep, "hash-table-p");
1380 defsymbol (&Qhash_table, "hash-table");
1381 defsymbol (&Qhashtable, "hashtable");
1382 defsymbol (&Qweak, "weak");
1383 defsymbol (&Qkey_weak, "key-weak");
1384 defsymbol (&Qvalue_weak, "value-weak");
1385 defsymbol (&Qnon_weak, "non-weak");
1386 defsymbol (&Qrehash_size, "rehash-size");
1387 defsymbol (&Qrehash_threshold, "rehash-threshold");
1389 defkeyword (&Q_size, ":size");
1390 defkeyword (&Q_test, ":test");
1391 defkeyword (&Q_type, ":type");
1392 defkeyword (&Q_rehash_size, ":rehash-size");
1393 defkeyword (&Q_rehash_threshold, ":rehash-threshold");
1397 vars_of_elhash (void)
1399 /* This must NOT be staticpro'd */
1400 Vall_weak_hash_tables = Qnil;