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, Qkey_or_value, Qkey_and_value;
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, Qkey_or_value_weak;
39 static Lisp_Object Qnon_weak, Q_type;
47 struct Lisp_Hash_Table
49 struct lcrecord_header header;
54 double rehash_threshold;
56 hash_table_hash_function_t hash_function;
57 hash_table_test_function_t test_function;
59 enum hash_table_weakness weakness;
60 Lisp_Object next_weak; /* Used to chain together all of the weak
61 hash tables. Don't mark through this. */
64 #define HENTRY_CLEAR_P(hentry) ((*(EMACS_UINT*)(&((hentry)->key))) == 0)
65 #define CLEAR_HENTRY(hentry) \
66 ((*(EMACS_UINT*)(&((hentry)->key))) = 0, \
67 (*(EMACS_UINT*)(&((hentry)->value))) = 0)
69 #define HASH_TABLE_DEFAULT_SIZE 16
70 #define HASH_TABLE_DEFAULT_REHASH_SIZE 1.3
71 #define HASH_TABLE_MIN_SIZE 10
73 #define HASH_CODE(key, ht) \
74 ((((ht)->hash_function ? (ht)->hash_function (key) : LISP_HASH (key)) \
75 * (ht)->golden_ratio) \
78 #define KEYS_EQUAL_P(key1, key2, testfun) \
79 (EQ (key1, key2) || ((testfun) && (testfun) (key1, key2)))
81 #define LINEAR_PROBING_LOOP(probe, entries, size) \
83 !HENTRY_CLEAR_P (probe) || \
84 (probe == entries + size ? \
85 (probe = entries, !HENTRY_CLEAR_P (probe)) : 0); \
88 #ifndef ERROR_CHECK_HASH_TABLE
89 # ifdef ERROR_CHECK_TYPECHECK
90 # define ERROR_CHECK_HASH_TABLE 1
92 # define ERROR_CHECK_HASH_TABLE 0
96 #if ERROR_CHECK_HASH_TABLE
98 check_hash_table_invariants (Lisp_Hash_Table *ht)
100 assert (ht->count < ht->size);
101 assert (ht->count <= ht->rehash_count);
102 assert (ht->rehash_count < ht->size);
103 assert ((double) ht->count * ht->rehash_threshold - 1 <= (double) ht->rehash_count);
104 assert (HENTRY_CLEAR_P (ht->hentries + ht->size));
107 #define check_hash_table_invariants(ht)
110 /* We use linear probing instead of double hashing, despite its lack
111 of blessing by Knuth and company, because, as a result of the
112 increasing discrepancy between CPU speeds and memory speeds, cache
113 behavior is becoming increasingly important, e.g:
115 For a trivial loop, the penalty for non-sequential access of an array is:
116 - a factor of 3-4 on Pentium Pro 200 Mhz
117 - a factor of 10 on Ultrasparc 300 Mhz */
119 /* Return a suitable size for a hash table, with at least SIZE slots. */
121 hash_table_size (size_t requested_size)
123 /* Return some prime near, but greater than or equal to, SIZE.
124 Decades from the time of writing, someone will have a system large
125 enough that the list below will be too short... */
126 static const size_t primes [] =
128 19, 29, 41, 59, 79, 107, 149, 197, 263, 347, 457, 599, 787, 1031,
129 1361, 1777, 2333, 3037, 3967, 5167, 6719, 8737, 11369, 14783,
130 19219, 24989, 32491, 42257, 54941, 71429, 92861, 120721, 156941,
131 204047, 265271, 344857, 448321, 582821, 757693, 985003, 1280519,
132 1664681, 2164111, 2813353, 3657361, 4754591, 6180989, 8035301,
133 10445899, 13579681, 17653589, 22949669, 29834603, 38784989,
134 50420551, 65546729, 85210757, 110774011, 144006217, 187208107,
135 243370577, 316381771, 411296309, 534685237, 695090819, 903618083,
136 1174703521, 1527114613, 1985248999, 2580823717UL, 3355070839UL
138 /* We've heard of binary search. */
140 for (low = 0, high = countof (primes) - 1; high - low > 1;)
142 /* Loop Invariant: size < primes [high] */
143 int mid = (low + high) / 2;
144 if (primes [mid] < requested_size)
149 return primes [high];
153 #if 0 /* I don't think these are needed any more.
154 If using the general lisp_object_equal_*() functions
155 causes efficiency problems, these can be resurrected. --ben */
156 /* equality and hash functions for Lisp strings */
158 lisp_string_equal (Lisp_Object str1, Lisp_Object str2)
160 /* This is wrong anyway. You can't use strcmp() on Lisp strings,
161 because they can contain zero characters. */
162 return !strcmp ((char *) XSTRING_DATA (str1), (char *) XSTRING_DATA (str2));
166 lisp_string_hash (Lisp_Object obj)
168 return hash_string (XSTRING_DATA (str), XSTRING_LENGTH (str));
174 lisp_object_eql_equal (Lisp_Object obj1, Lisp_Object obj2)
176 return EQ (obj1, obj2) || (FLOATP (obj1) && internal_equal (obj1, obj2, 0));
180 lisp_object_eql_hash (Lisp_Object obj)
182 return FLOATP (obj) ? internal_hash (obj, 0) : LISP_HASH (obj);
186 lisp_object_equal_equal (Lisp_Object obj1, Lisp_Object obj2)
188 return internal_equal (obj1, obj2, 0);
192 lisp_object_equal_hash (Lisp_Object obj)
194 return internal_hash (obj, 0);
199 mark_hash_table (Lisp_Object obj)
201 Lisp_Hash_Table *ht = XHASH_TABLE (obj);
203 /* If the hash table is weak, we don't want to mark the keys and
204 values (we scan over them after everything else has been marked,
205 and mark or remove them as necessary). */
206 if (ht->weakness == HASH_TABLE_NON_WEAK)
208 hentry *e, *sentinel;
210 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
211 if (!HENTRY_CLEAR_P (e))
213 mark_object (e->key);
214 mark_object (e->value);
220 /* Equality of hash tables. Two hash tables are equal when they are of
221 the same weakness and test function, they have the same number of
222 elements, and for each key in the hash table, the values are `equal'.
224 This is similar to Common Lisp `equalp' of hash tables, with the
225 difference that CL requires the keys to be compared with the test
226 function, which we don't do. Doing that would require consing, and
227 consing is a bad idea in `equal'. Anyway, our method should provide
228 the same result -- if the keys are not equal according to the test
229 function, then Fgethash() in hash_table_equal_mapper() will fail. */
231 hash_table_equal (Lisp_Object hash_table1, Lisp_Object hash_table2, int depth)
233 Lisp_Hash_Table *ht1 = XHASH_TABLE (hash_table1);
234 Lisp_Hash_Table *ht2 = XHASH_TABLE (hash_table2);
235 hentry *e, *sentinel;
237 if ((ht1->test_function != ht2->test_function) ||
238 (ht1->weakness != ht2->weakness) ||
239 (ht1->count != ht2->count))
244 for (e = ht1->hentries, sentinel = e + ht1->size; e < sentinel; e++)
245 if (!HENTRY_CLEAR_P (e))
246 /* Look up the key in the other hash table, and compare the values. */
248 Lisp_Object value_in_other = Fgethash (e->key, hash_table2, Qunbound);
249 if (UNBOUNDP (value_in_other) ||
250 !internal_equal (e->value, value_in_other, depth))
251 return 0; /* Give up */
257 /* This is not a great hash function, but it _is_ correct and fast.
258 Examining all entries is too expensive, and examining a random
259 subset does not yield a correct hash function. */
261 hash_table_hash (Lisp_Object hash_table, int depth)
263 return XHASH_TABLE (hash_table)->count;
267 /* Printing hash tables.
269 This is non-trivial, because we use a readable structure-style
270 syntax for hash tables. This means that a typical hash table will be
271 readably printed in the form of:
273 #s(hash-table size 2 data (key1 value1 key2 value2))
275 The supported hash table structure keywords and their values are:
276 `test' (eql (or nil), eq or equal)
277 `size' (a natnum or nil)
278 `rehash-size' (a float)
279 `rehash-threshold' (a float)
280 `weakness' (nil, key, value, key-and-value, or key-or-value)
283 If `print-readably' is nil, then a simpler syntax is used, for example
285 #<hash-table size 2/13 data (key1 value1 key2 value2) 0x874d>
287 The data is truncated to four pairs, and the rest is shown with
288 `...'. This printer does not cons. */
291 /* Print the data of the hash table. This maps through a Lisp
292 hash table and prints key/value pairs using PRINTCHARFUN. */
294 print_hash_table_data (Lisp_Hash_Table *ht, Lisp_Object printcharfun)
297 hentry *e, *sentinel;
299 write_c_string (" data (", printcharfun);
301 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
302 if (!HENTRY_CLEAR_P (e))
305 write_c_string (" ", printcharfun);
306 if (!print_readably && count > 3)
308 write_c_string ("...", printcharfun);
311 print_internal (e->key, printcharfun, 1);
312 write_c_string (" ", printcharfun);
313 print_internal (e->value, printcharfun, 1);
317 write_c_string (")", printcharfun);
321 print_hash_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
323 Lisp_Hash_Table *ht = XHASH_TABLE (obj);
326 write_c_string (print_readably ? "#s(hash-table" : "#<hash-table",
329 /* These checks have a kludgy look to them, but they are safe.
330 Due to nature of hashing, you cannot use arbitrary
331 test functions anyway. */
332 if (!ht->test_function)
333 write_c_string (" test eq", printcharfun);
334 else if (ht->test_function == lisp_object_equal_equal)
335 write_c_string (" test equal", printcharfun);
336 else if (ht->test_function == lisp_object_eql_equal)
341 if (ht->count || !print_readably)
344 sprintf (buf, " size %lu", (unsigned long) ht->count);
346 sprintf (buf, " size %lu/%lu",
347 (unsigned long) ht->count,
348 (unsigned long) ht->size);
349 write_c_string (buf, printcharfun);
352 if (ht->weakness != HASH_TABLE_NON_WEAK)
354 sprintf (buf, " weakness %s",
355 (ht->weakness == HASH_TABLE_WEAK ? "key-and-value" :
356 ht->weakness == HASH_TABLE_KEY_WEAK ? "key" :
357 ht->weakness == HASH_TABLE_VALUE_WEAK ? "value" :
358 ht->weakness == HASH_TABLE_KEY_VALUE_WEAK ? "key-or-value" :
359 "you-d-better-not-see-this"));
360 write_c_string (buf, printcharfun);
364 print_hash_table_data (ht, printcharfun);
367 write_c_string (")", printcharfun);
370 sprintf (buf, " 0x%x>", ht->header.uid);
371 write_c_string (buf, printcharfun);
376 finalize_hash_table (void *header, int for_disksave)
380 Lisp_Hash_Table *ht = (Lisp_Hash_Table *) header;
382 xfree (ht->hentries);
387 static const struct lrecord_description hentry_description_1[] = {
388 { XD_LISP_OBJECT, offsetof (hentry, key) },
389 { XD_LISP_OBJECT, offsetof (hentry, value) },
393 static const struct struct_description hentry_description = {
398 const struct lrecord_description hash_table_description[] = {
399 { XD_SIZE_T, offsetof (Lisp_Hash_Table, size) },
400 { XD_STRUCT_PTR, offsetof (Lisp_Hash_Table, hentries), XD_INDIRECT(0, 1), &hentry_description },
401 { XD_LO_LINK, offsetof (Lisp_Hash_Table, next_weak) },
405 DEFINE_LRECORD_IMPLEMENTATION ("hash-table", hash_table,
406 mark_hash_table, print_hash_table,
408 hash_table_equal, hash_table_hash,
409 hash_table_description,
412 static Lisp_Hash_Table *
413 xhash_table (Lisp_Object hash_table)
416 CHECK_HASH_TABLE (hash_table);
417 check_hash_table_invariants (XHASH_TABLE (hash_table));
418 return XHASH_TABLE (hash_table);
422 /************************************************************************/
423 /* Creation of Hash Tables */
424 /************************************************************************/
426 /* Creation of hash tables, without error-checking. */
428 compute_hash_table_derived_values (Lisp_Hash_Table *ht)
430 ht->rehash_count = (size_t)
431 ((double) ht->size * ht->rehash_threshold);
432 ht->golden_ratio = (size_t)
433 ((double) ht->size * (.6180339887 / (double) sizeof (Lisp_Object)));
437 make_general_lisp_hash_table (enum hash_table_test test,
440 double rehash_threshold,
441 enum hash_table_weakness weakness)
443 Lisp_Object hash_table;
444 Lisp_Hash_Table *ht = alloc_lcrecord_type (Lisp_Hash_Table, &lrecord_hash_table);
449 ht->test_function = 0;
450 ht->hash_function = 0;
454 ht->test_function = lisp_object_eql_equal;
455 ht->hash_function = lisp_object_eql_hash;
458 case HASH_TABLE_EQUAL:
459 ht->test_function = lisp_object_equal_equal;
460 ht->hash_function = lisp_object_equal_hash;
467 ht->weakness = weakness;
470 rehash_size > 1.0 ? rehash_size : HASH_TABLE_DEFAULT_REHASH_SIZE;
472 ht->rehash_threshold =
473 rehash_threshold > 0.0 ? rehash_threshold :
474 size > 4096 && !ht->test_function ? 0.7 : 0.6;
476 if (size < HASH_TABLE_MIN_SIZE)
477 size = HASH_TABLE_MIN_SIZE;
478 ht->size = hash_table_size ((size_t) (((double) size / ht->rehash_threshold)
482 compute_hash_table_derived_values (ht);
484 /* We leave room for one never-occupied sentinel hentry at the end. */
485 ht->hentries = xnew_array (hentry, ht->size + 1);
488 hentry *e, *sentinel;
489 for (e = ht->hentries, sentinel = e + ht->size; e <= sentinel; e++)
493 XSETHASH_TABLE (hash_table, ht);
495 if (weakness == HASH_TABLE_NON_WEAK)
496 ht->next_weak = Qunbound;
498 ht->next_weak = Vall_weak_hash_tables, Vall_weak_hash_tables = hash_table;
504 make_lisp_hash_table (size_t size,
505 enum hash_table_weakness weakness,
506 enum hash_table_test test)
508 return make_general_lisp_hash_table (test, size, -1.0, -1.0, weakness);
511 /* Pretty reading of hash tables.
513 Here we use the existing structures mechanism (which is,
514 unfortunately, pretty cumbersome) for validating and instantiating
515 the hash tables. The idea is that the side-effect of reading a
516 #s(hash-table PLIST) object is creation of a hash table with desired
517 properties, and that the hash table is returned. */
519 /* Validation functions: each keyword provides its own validation
520 function. The errors should maybe be continuable, but it is
521 unclear how this would cope with ERRB. */
523 hash_table_size_validate (Lisp_Object keyword, Lisp_Object value,
529 maybe_signal_error (Qwrong_type_argument, list2 (Qnatnump, value),
535 decode_hash_table_size (Lisp_Object obj)
537 return NILP (obj) ? HASH_TABLE_DEFAULT_SIZE : XINT (obj);
541 hash_table_weakness_validate (Lisp_Object keyword, Lisp_Object value,
544 if (EQ (value, Qnil)) return 1;
545 if (EQ (value, Qt)) return 1;
546 if (EQ (value, Qkey)) return 1;
547 if (EQ (value, Qkey_and_value)) return 1;
548 if (EQ (value, Qkey_or_value)) return 1;
549 if (EQ (value, Qvalue)) return 1;
551 /* Following values are obsolete as of 19990901 in xemacs-21.2 */
552 if (EQ (value, Qnon_weak)) return 1;
553 if (EQ (value, Qweak)) return 1;
554 if (EQ (value, Qkey_weak)) return 1;
555 if (EQ (value, Qkey_or_value_weak)) return 1;
556 if (EQ (value, Qvalue_weak)) return 1;
558 maybe_signal_simple_error ("Invalid hash table weakness",
559 value, Qhash_table, errb);
563 static enum hash_table_weakness
564 decode_hash_table_weakness (Lisp_Object obj)
566 if (EQ (obj, Qnil)) return HASH_TABLE_NON_WEAK;
567 if (EQ (obj, Qt)) return HASH_TABLE_WEAK;
568 if (EQ (obj, Qkey_and_value)) return HASH_TABLE_WEAK;
569 if (EQ (obj, Qkey)) return HASH_TABLE_KEY_WEAK;
570 if (EQ (obj, Qkey_or_value)) return HASH_TABLE_KEY_VALUE_WEAK;
571 if (EQ (obj, Qvalue)) return HASH_TABLE_VALUE_WEAK;
573 /* Following values are obsolete as of 19990901 in xemacs-21.2 */
574 if (EQ (obj, Qnon_weak)) return HASH_TABLE_NON_WEAK;
575 if (EQ (obj, Qweak)) return HASH_TABLE_WEAK;
576 if (EQ (obj, Qkey_weak)) return HASH_TABLE_KEY_WEAK;
577 if (EQ (obj, Qkey_or_value_weak)) return HASH_TABLE_KEY_VALUE_WEAK;
578 if (EQ (obj, Qvalue_weak)) return HASH_TABLE_VALUE_WEAK;
580 signal_simple_error ("Invalid hash table weakness", obj);
581 return HASH_TABLE_NON_WEAK; /* not reached */
585 hash_table_test_validate (Lisp_Object keyword, Lisp_Object value,
588 if (EQ (value, Qnil)) return 1;
589 if (EQ (value, Qeq)) return 1;
590 if (EQ (value, Qequal)) return 1;
591 if (EQ (value, Qeql)) return 1;
593 maybe_signal_simple_error ("Invalid hash table test",
594 value, Qhash_table, errb);
598 static enum hash_table_test
599 decode_hash_table_test (Lisp_Object obj)
601 if (EQ (obj, Qnil)) return HASH_TABLE_EQL;
602 if (EQ (obj, Qeq)) return HASH_TABLE_EQ;
603 if (EQ (obj, Qequal)) return HASH_TABLE_EQUAL;
604 if (EQ (obj, Qeql)) return HASH_TABLE_EQL;
606 signal_simple_error ("Invalid hash table test", obj);
607 return HASH_TABLE_EQ; /* not reached */
611 hash_table_rehash_size_validate (Lisp_Object keyword, Lisp_Object value,
616 maybe_signal_error (Qwrong_type_argument, list2 (Qfloatp, value),
622 double rehash_size = XFLOAT_DATA (value);
623 if (rehash_size <= 1.0)
625 maybe_signal_simple_error
626 ("Hash table rehash size must be greater than 1.0",
627 value, Qhash_table, errb);
636 decode_hash_table_rehash_size (Lisp_Object rehash_size)
638 return NILP (rehash_size) ? -1.0 : XFLOAT_DATA (rehash_size);
642 hash_table_rehash_threshold_validate (Lisp_Object keyword, Lisp_Object value,
647 maybe_signal_error (Qwrong_type_argument, list2 (Qfloatp, value),
653 double rehash_threshold = XFLOAT_DATA (value);
654 if (rehash_threshold <= 0.0 || rehash_threshold >= 1.0)
656 maybe_signal_simple_error
657 ("Hash table rehash threshold must be between 0.0 and 1.0",
658 value, Qhash_table, errb);
667 decode_hash_table_rehash_threshold (Lisp_Object rehash_threshold)
669 return NILP (rehash_threshold) ? -1.0 : XFLOAT_DATA (rehash_threshold);
673 hash_table_data_validate (Lisp_Object keyword, Lisp_Object value,
678 GET_EXTERNAL_LIST_LENGTH (value, len);
682 maybe_signal_simple_error
683 ("Hash table data must have alternating key/value pairs",
684 value, Qhash_table, errb);
690 /* The actual instantiation of a hash table. This does practically no
691 error checking, because it relies on the fact that the paranoid
692 functions above have error-checked everything to the last details.
693 If this assumption is wrong, we will get a crash immediately (with
694 error-checking compiled in), and we'll know if there is a bug in
695 the structure mechanism. So there. */
697 hash_table_instantiate (Lisp_Object plist)
699 Lisp_Object hash_table;
700 Lisp_Object test = Qnil;
701 Lisp_Object size = Qnil;
702 Lisp_Object rehash_size = Qnil;
703 Lisp_Object rehash_threshold = Qnil;
704 Lisp_Object weakness = Qnil;
705 Lisp_Object data = Qnil;
707 while (!NILP (plist))
709 Lisp_Object key, value;
710 key = XCAR (plist); plist = XCDR (plist);
711 value = XCAR (plist); plist = XCDR (plist);
713 if (EQ (key, Qtest)) test = value;
714 else if (EQ (key, Qsize)) size = value;
715 else if (EQ (key, Qrehash_size)) rehash_size = value;
716 else if (EQ (key, Qrehash_threshold)) rehash_threshold = value;
717 else if (EQ (key, Qweakness)) weakness = value;
718 else if (EQ (key, Qdata)) data = value;
719 else if (EQ (key, Qtype))/*obsolete*/ weakness = value;
724 /* Create the hash table. */
725 hash_table = make_general_lisp_hash_table
726 (decode_hash_table_test (test),
727 decode_hash_table_size (size),
728 decode_hash_table_rehash_size (rehash_size),
729 decode_hash_table_rehash_threshold (rehash_threshold),
730 decode_hash_table_weakness (weakness));
732 /* I'm not sure whether this can GC, but better safe than sorry. */
737 /* And fill it with data. */
740 Lisp_Object key, value;
741 key = XCAR (data); data = XCDR (data);
742 value = XCAR (data); data = XCDR (data);
743 Fputhash (key, value, hash_table);
752 structure_type_create_hash_table_structure_name (Lisp_Object structure_name)
754 struct structure_type *st;
756 st = define_structure_type (structure_name, 0, hash_table_instantiate);
757 define_structure_type_keyword (st, Qtest, hash_table_test_validate);
758 define_structure_type_keyword (st, Qsize, hash_table_size_validate);
759 define_structure_type_keyword (st, Qrehash_size, hash_table_rehash_size_validate);
760 define_structure_type_keyword (st, Qrehash_threshold, hash_table_rehash_threshold_validate);
761 define_structure_type_keyword (st, Qweakness, hash_table_weakness_validate);
762 define_structure_type_keyword (st, Qdata, hash_table_data_validate);
764 /* obsolete as of 19990901 in xemacs-21.2 */
765 define_structure_type_keyword (st, Qtype, hash_table_weakness_validate);
768 /* Create a built-in Lisp structure type named `hash-table'.
769 We make #s(hashtable ...) equivalent to #s(hash-table ...),
770 for backward compatibility.
771 This is called from emacs.c. */
773 structure_type_create_hash_table (void)
775 structure_type_create_hash_table_structure_name (Qhash_table);
776 structure_type_create_hash_table_structure_name (Qhashtable); /* compat */
780 /************************************************************************/
781 /* Definition of Lisp-visible methods */
782 /************************************************************************/
784 DEFUN ("hash-table-p", Fhash_table_p, 1, 1, 0, /*
785 Return t if OBJECT is a hash table, else nil.
789 return HASH_TABLEP (object) ? Qt : Qnil;
792 DEFUN ("make-hash-table", Fmake_hash_table, 0, MANY, 0, /*
793 Return a new empty hash table object.
794 Use Common Lisp style keywords to specify hash table properties.
795 (make-hash-table &key test size rehash-size rehash-threshold weakness)
797 Keyword :test can be `eq', `eql' (default) or `equal'.
798 Comparison between keys is done using this function.
799 If speed is important, consider using `eq'.
800 When storing strings in the hash table, you will likely need to use `equal'.
802 Keyword :size specifies the number of keys likely to be inserted.
803 This number of entries can be inserted without enlarging the hash table.
805 Keyword :rehash-size must be a float greater than 1.0, and specifies
806 the factor by which to increase the size of the hash table when enlarging.
808 Keyword :rehash-threshold must be a float between 0.0 and 1.0,
809 and specifies the load factor of the hash table which triggers enlarging.
811 Non-standard keyword :weakness can be `nil' (default), `t', `key-and-value',
812 `key', `value' or `key-or-value'. `t' is an alias for `key-and-value'.
814 A key-and-value-weak hash table, also known as a fully-weak or simply
815 as a weak hash table, is one whose pointers do not count as GC
816 referents: for any key-value pair in the hash table, if the only
817 remaining pointer to either the key or the value is in a weak hash
818 table, then the pair will be removed from the hash table, and the key
819 and value collected. A non-weak hash table (or any other pointer)
820 would prevent the object from being collected.
822 A key-weak hash table is similar to a fully-weak hash table except that
823 a key-value pair will be removed only if the key remains unmarked
824 outside of weak hash tables. The pair will remain in the hash table if
825 the key is pointed to by something other than a weak hash table, even
828 A value-weak hash table is similar to a fully-weak hash table except
829 that a key-value pair will be removed only if the value remains
830 unmarked outside of weak hash tables. The pair will remain in the
831 hash table if the value is pointed to by something other than a weak
832 hash table, even if the key is not.
834 A key-or-value-weak hash table is similar to a fully-weak hash table except
835 that a key-value pair will be removed only if the value and the key remain
836 unmarked outside of weak hash tables. The pair will remain in the
837 hash table if the value or key are pointed to by something other than a weak
838 hash table, even if the other is not.
840 (int nargs, Lisp_Object *args))
843 Lisp_Object test = Qnil;
844 Lisp_Object size = Qnil;
845 Lisp_Object rehash_size = Qnil;
846 Lisp_Object rehash_threshold = Qnil;
847 Lisp_Object weakness = Qnil;
849 while (i + 1 < nargs)
851 Lisp_Object keyword = args[i++];
852 Lisp_Object value = args[i++];
854 if (EQ (keyword, Q_test)) test = value;
855 else if (EQ (keyword, Q_size)) size = value;
856 else if (EQ (keyword, Q_rehash_size)) rehash_size = value;
857 else if (EQ (keyword, Q_rehash_threshold)) rehash_threshold = value;
858 else if (EQ (keyword, Q_weakness)) weakness = value;
859 else if (EQ (keyword, Q_type))/*obsolete*/ weakness = value;
860 else signal_simple_error ("Invalid hash table property keyword", keyword);
864 signal_simple_error ("Hash table property requires a value", args[i]);
866 #define VALIDATE_VAR(var) \
867 if (!NILP (var)) hash_table_##var##_validate (Q##var, var, ERROR_ME);
871 VALIDATE_VAR (rehash_size);
872 VALIDATE_VAR (rehash_threshold);
873 VALIDATE_VAR (weakness);
875 return make_general_lisp_hash_table
876 (decode_hash_table_test (test),
877 decode_hash_table_size (size),
878 decode_hash_table_rehash_size (rehash_size),
879 decode_hash_table_rehash_threshold (rehash_threshold),
880 decode_hash_table_weakness (weakness));
883 DEFUN ("copy-hash-table", Fcopy_hash_table, 1, 1, 0, /*
884 Return a new hash table containing the same keys and values as HASH-TABLE.
885 The keys and values will not themselves be copied.
889 const Lisp_Hash_Table *ht_old = xhash_table (hash_table);
890 Lisp_Hash_Table *ht = alloc_lcrecord_type (Lisp_Hash_Table, &lrecord_hash_table);
892 copy_lcrecord (ht, ht_old);
894 ht->hentries = xnew_array (hentry, ht_old->size + 1);
895 memcpy (ht->hentries, ht_old->hentries, (ht_old->size + 1) * sizeof (hentry));
897 XSETHASH_TABLE (hash_table, ht);
899 if (! EQ (ht->next_weak, Qunbound))
901 ht->next_weak = Vall_weak_hash_tables;
902 Vall_weak_hash_tables = hash_table;
909 resize_hash_table (Lisp_Hash_Table *ht, size_t new_size)
911 hentry *old_entries, *new_entries, *sentinel, *e;
917 old_entries = ht->hentries;
919 ht->hentries = xnew_array_and_zero (hentry, new_size + 1);
920 new_entries = ht->hentries;
922 compute_hash_table_derived_values (ht);
924 for (e = old_entries, sentinel = e + old_size; e < sentinel; e++)
925 if (!HENTRY_CLEAR_P (e))
927 hentry *probe = new_entries + HASH_CODE (e->key, ht);
928 LINEAR_PROBING_LOOP (probe, new_entries, new_size)
933 if (!DUMPEDP (old_entries))
937 /* After a hash table has been saved to disk and later restored by the
938 portable dumper, it contains the same objects, but their addresses
939 and thus their HASH_CODEs have changed. */
941 pdump_reorganize_hash_table (Lisp_Object hash_table)
943 const Lisp_Hash_Table *ht = xhash_table (hash_table);
944 hentry *new_entries = xnew_array_and_zero (hentry, ht->size + 1);
945 hentry *e, *sentinel;
947 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
948 if (!HENTRY_CLEAR_P (e))
950 hentry *probe = new_entries + HASH_CODE (e->key, ht);
951 LINEAR_PROBING_LOOP (probe, new_entries, ht->size)
956 memcpy (ht->hentries, new_entries, ht->size * sizeof (hentry));
962 enlarge_hash_table (Lisp_Hash_Table *ht)
965 hash_table_size ((size_t) ((double) ht->size * ht->rehash_size));
966 resize_hash_table (ht, new_size);
970 find_hentry (Lisp_Object key, const Lisp_Hash_Table *ht)
972 hash_table_test_function_t test_function = ht->test_function;
973 hentry *entries = ht->hentries;
974 hentry *probe = entries + HASH_CODE (key, ht);
976 LINEAR_PROBING_LOOP (probe, entries, ht->size)
977 if (KEYS_EQUAL_P (probe->key, key, test_function))
983 DEFUN ("gethash", Fgethash, 2, 3, 0, /*
984 Find hash value for KEY in HASH-TABLE.
985 If there is no corresponding value, return DEFAULT (which defaults to nil).
987 (key, hash_table, default_))
989 const Lisp_Hash_Table *ht = xhash_table (hash_table);
990 hentry *e = find_hentry (key, ht);
992 return HENTRY_CLEAR_P (e) ? default_ : e->value;
995 DEFUN ("puthash", Fputhash, 3, 3, 0, /*
996 Hash KEY to VALUE in HASH-TABLE.
998 (key, value, hash_table))
1000 Lisp_Hash_Table *ht = xhash_table (hash_table);
1001 hentry *e = find_hentry (key, ht);
1003 if (!HENTRY_CLEAR_P (e))
1004 return e->value = value;
1009 if (++ht->count >= ht->rehash_count)
1010 enlarge_hash_table (ht);
1015 /* Remove hentry pointed at by PROBE.
1016 Subsequent entries are removed and reinserted.
1017 We don't use tombstones - too wasteful. */
1019 remhash_1 (Lisp_Hash_Table *ht, hentry *entries, hentry *probe)
1021 size_t size = ht->size;
1022 CLEAR_HENTRY (probe);
1026 LINEAR_PROBING_LOOP (probe, entries, size)
1028 Lisp_Object key = probe->key;
1029 hentry *probe2 = entries + HASH_CODE (key, ht);
1030 LINEAR_PROBING_LOOP (probe2, entries, size)
1031 if (EQ (probe2->key, key))
1032 /* hentry at probe doesn't need to move. */
1033 goto continue_outer_loop;
1034 /* Move hentry from probe to new home at probe2. */
1036 CLEAR_HENTRY (probe);
1037 continue_outer_loop: continue;
1041 DEFUN ("remhash", Fremhash, 2, 2, 0, /*
1042 Remove the entry for KEY from HASH-TABLE.
1043 Do nothing if there is no entry for KEY in HASH-TABLE.
1047 Lisp_Hash_Table *ht = xhash_table (hash_table);
1048 hentry *e = find_hentry (key, ht);
1050 if (HENTRY_CLEAR_P (e))
1053 remhash_1 (ht, ht->hentries, e);
1057 DEFUN ("clrhash", Fclrhash, 1, 1, 0, /*
1058 Remove all entries from HASH-TABLE, leaving it empty.
1062 Lisp_Hash_Table *ht = xhash_table (hash_table);
1063 hentry *e, *sentinel;
1065 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1072 /************************************************************************/
1073 /* Accessor Functions */
1074 /************************************************************************/
1076 DEFUN ("hash-table-count", Fhash_table_count, 1, 1, 0, /*
1077 Return the number of entries in HASH-TABLE.
1081 return make_int (xhash_table (hash_table)->count);
1084 DEFUN ("hash-table-test", Fhash_table_test, 1, 1, 0, /*
1085 Return the test function of HASH-TABLE.
1086 This can be one of `eq', `eql' or `equal'.
1090 hash_table_test_function_t fun = xhash_table (hash_table)->test_function;
1092 return (fun == lisp_object_eql_equal ? Qeql :
1093 fun == lisp_object_equal_equal ? Qequal :
1097 DEFUN ("hash-table-size", Fhash_table_size, 1, 1, 0, /*
1098 Return the size of HASH-TABLE.
1099 This is the current number of slots in HASH-TABLE, whether occupied or not.
1103 return make_int (xhash_table (hash_table)->size);
1106 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size, 1, 1, 0, /*
1107 Return the current rehash size of HASH-TABLE.
1108 This is a float greater than 1.0; the factor by which HASH-TABLE
1109 is enlarged when the rehash threshold is exceeded.
1113 return make_float (xhash_table (hash_table)->rehash_size);
1116 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold, 1, 1, 0, /*
1117 Return the current rehash threshold of HASH-TABLE.
1118 This is a float between 0.0 and 1.0; the maximum `load factor' of HASH-TABLE,
1119 beyond which the HASH-TABLE is enlarged by rehashing.
1123 return make_float (xhash_table (hash_table)->rehash_threshold);
1126 DEFUN ("hash-table-weakness", Fhash_table_weakness, 1, 1, 0, /*
1127 Return the weakness of HASH-TABLE.
1128 This can be one of `nil', `key-and-value', `key-or-value', `key' or `value'.
1132 switch (xhash_table (hash_table)->weakness)
1134 case HASH_TABLE_WEAK: return Qkey_and_value;
1135 case HASH_TABLE_KEY_WEAK: return Qkey;
1136 case HASH_TABLE_KEY_VALUE_WEAK: return Qkey_or_value;
1137 case HASH_TABLE_VALUE_WEAK: return Qvalue;
1138 default: return Qnil;
1142 /* obsolete as of 19990901 in xemacs-21.2 */
1143 DEFUN ("hash-table-type", Fhash_table_type, 1, 1, 0, /*
1144 Return the type of HASH-TABLE.
1145 This can be one of `non-weak', `weak', `key-weak' or `value-weak'.
1149 switch (xhash_table (hash_table)->weakness)
1151 case HASH_TABLE_WEAK: return Qweak;
1152 case HASH_TABLE_KEY_WEAK: return Qkey_weak;
1153 case HASH_TABLE_KEY_VALUE_WEAK: return Qkey_or_value_weak;
1154 case HASH_TABLE_VALUE_WEAK: return Qvalue_weak;
1155 default: return Qnon_weak;
1159 /************************************************************************/
1160 /* Mapping Functions */
1161 /************************************************************************/
1162 DEFUN ("maphash", Fmaphash, 2, 2, 0, /*
1163 Map FUNCTION over entries in HASH-TABLE, calling it with two args,
1164 each key and value in HASH-TABLE.
1166 FUNCTION may not modify HASH-TABLE, with the one exception that FUNCTION
1167 may remhash or puthash the entry currently being processed by FUNCTION.
1169 (function, hash_table))
1171 const Lisp_Hash_Table *ht = xhash_table (hash_table);
1172 const hentry *e, *sentinel;
1174 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1175 if (!HENTRY_CLEAR_P (e))
1177 Lisp_Object args[3], key;
1183 Ffuncall (countof (args), args);
1184 /* Has FUNCTION done a remhash? */
1185 if (!EQ (key, e->key) && !HENTRY_CLEAR_P (e))
1192 /* Map *C* function FUNCTION over the elements of a lisp hash table. */
1194 elisp_maphash (maphash_function_t function,
1195 Lisp_Object hash_table, void *extra_arg)
1197 const Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1198 const hentry *e, *sentinel;
1200 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1201 if (!HENTRY_CLEAR_P (e))
1206 if (function (key, e->value, extra_arg))
1208 /* Has FUNCTION done a remhash? */
1209 if (!EQ (key, e->key) && !HENTRY_CLEAR_P (e))
1214 /* Remove all elements of a lisp hash table satisfying *C* predicate PREDICATE. */
1216 elisp_map_remhash (maphash_function_t predicate,
1217 Lisp_Object hash_table, void *extra_arg)
1219 Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1220 hentry *e, *entries, *sentinel;
1222 for (e = entries = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1223 if (!HENTRY_CLEAR_P (e))
1226 if (predicate (e->key, e->value, extra_arg))
1228 remhash_1 (ht, entries, e);
1229 if (!HENTRY_CLEAR_P (e))
1236 /************************************************************************/
1237 /* garbage collecting weak hash tables */
1238 /************************************************************************/
1239 #define MARK_OBJ(obj) do { \
1240 Lisp_Object mo_obj = (obj); \
1241 if (!marked_p (mo_obj)) \
1243 mark_object (mo_obj); \
1249 /* Complete the marking for semi-weak hash tables. */
1251 finish_marking_weak_hash_tables (void)
1253 Lisp_Object hash_table;
1256 for (hash_table = Vall_weak_hash_tables;
1258 hash_table = XHASH_TABLE (hash_table)->next_weak)
1260 const Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1261 const hentry *e = ht->hentries;
1262 const hentry *sentinel = e + ht->size;
1264 if (! marked_p (hash_table))
1265 /* The hash table is probably garbage. Ignore it. */
1268 /* Now, scan over all the pairs. For all pairs that are
1269 half-marked, we may need to mark the other half if we're
1270 keeping this pair. */
1271 switch (ht->weakness)
1273 case HASH_TABLE_KEY_WEAK:
1274 for (; e < sentinel; e++)
1275 if (!HENTRY_CLEAR_P (e))
1276 if (marked_p (e->key))
1277 MARK_OBJ (e->value);
1280 case HASH_TABLE_VALUE_WEAK:
1281 for (; e < sentinel; e++)
1282 if (!HENTRY_CLEAR_P (e))
1283 if (marked_p (e->value))
1287 case HASH_TABLE_KEY_VALUE_WEAK:
1288 for (; e < sentinel; e++)
1289 if (!HENTRY_CLEAR_P (e))
1291 if (marked_p (e->value))
1293 else if (marked_p (e->key))
1294 MARK_OBJ (e->value);
1298 case HASH_TABLE_KEY_CAR_WEAK:
1299 for (; e < sentinel; e++)
1300 if (!HENTRY_CLEAR_P (e))
1301 if (!CONSP (e->key) || marked_p (XCAR (e->key)))
1304 MARK_OBJ (e->value);
1308 case HASH_TABLE_VALUE_CAR_WEAK:
1309 for (; e < sentinel; e++)
1310 if (!HENTRY_CLEAR_P (e))
1311 if (!CONSP (e->value) || marked_p (XCAR (e->value)))
1314 MARK_OBJ (e->value);
1327 prune_weak_hash_tables (void)
1329 Lisp_Object hash_table, prev = Qnil;
1330 for (hash_table = Vall_weak_hash_tables;
1332 hash_table = XHASH_TABLE (hash_table)->next_weak)
1334 if (! marked_p (hash_table))
1336 /* This hash table itself is garbage. Remove it from the list. */
1338 Vall_weak_hash_tables = XHASH_TABLE (hash_table)->next_weak;
1340 XHASH_TABLE (prev)->next_weak = XHASH_TABLE (hash_table)->next_weak;
1344 /* Now, scan over all the pairs. Remove all of the pairs
1345 in which the key or value, or both, is unmarked
1346 (depending on the weakness of the hash table). */
1347 Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1348 hentry *entries = ht->hentries;
1349 hentry *sentinel = entries + ht->size;
1352 for (e = entries; e < sentinel; e++)
1353 if (!HENTRY_CLEAR_P (e))
1356 if (!marked_p (e->key) || !marked_p (e->value))
1358 remhash_1 (ht, entries, e);
1359 if (!HENTRY_CLEAR_P (e))
1369 /* Return a hash value for an array of Lisp_Objects of size SIZE. */
1372 internal_array_hash (Lisp_Object *arr, int size, int depth)
1375 hashcode_t hash = 0;
1380 for (i = 0; i < size; i++)
1381 hash = HASH2 (hash, internal_hash (arr[i], depth));
1385 /* just pick five elements scattered throughout the array.
1386 A slightly better approach would be to offset by some
1387 noise factor from the points chosen below. */
1388 for (i = 0; i < 5; i++)
1389 hash = HASH2 (hash, internal_hash (arr[i*size/5], depth));
1394 /* Return a hash value for a Lisp_Object. This is for use when hashing
1395 objects with the comparison being `equal' (for `eq', you can just
1396 use the Lisp_Object itself as the hash value). You need to make a
1397 tradeoff between the speed of the hash function and how good the
1398 hashing is. In particular, the hash function needs to be FAST,
1399 so you can't just traipse down the whole tree hashing everything
1400 together. Most of the time, objects will differ in the first
1401 few elements you hash. Thus, we only go to a short depth (5)
1402 and only hash at most 5 elements out of a vector. Theoretically
1403 we could still take 5^5 time (a big big number) to compute a
1404 hash, but practically this won't ever happen. */
1407 internal_hash (Lisp_Object obj, int depth)
1413 /* no point in worrying about tail recursion, since we're not
1415 return HASH2 (internal_hash (XCAR (obj), depth + 1),
1416 internal_hash (XCDR (obj), depth + 1));
1420 return hash_string (XSTRING_DATA (obj), XSTRING_LENGTH (obj));
1424 const struct lrecord_implementation
1425 *imp = XRECORD_LHEADER_IMPLEMENTATION (obj);
1427 return imp->hash (obj, depth);
1430 return LISP_HASH (obj);
1433 DEFUN ("sxhash", Fsxhash, 1, 1, 0, /*
1434 Return a hash value for OBJECT.
1435 \(equal obj1 obj2) implies (= (sxhash obj1) (sxhash obj2)).
1439 return make_int (internal_hash (object, 0));
1443 xxDEFUN ("internal-hash-value", Finternal_hash_value, 1, 1, 0, /*
1444 Hash value of OBJECT. For debugging.
1445 The value is returned as (HIGH . LOW).
1449 /* This function is pretty 32bit-centric. */
1450 hashcode_t hash = internal_hash (object, 0);
1451 return Fcons (hash >> 16, hash & 0xffff);
1456 /************************************************************************/
1457 /* initialization */
1458 /************************************************************************/
1461 syms_of_elhash (void)
1463 INIT_LRECORD_IMPLEMENTATION (hash_table);
1465 DEFSUBR (Fhash_table_p);
1466 DEFSUBR (Fmake_hash_table);
1467 DEFSUBR (Fcopy_hash_table);
1473 DEFSUBR (Fhash_table_count);
1474 DEFSUBR (Fhash_table_test);
1475 DEFSUBR (Fhash_table_size);
1476 DEFSUBR (Fhash_table_rehash_size);
1477 DEFSUBR (Fhash_table_rehash_threshold);
1478 DEFSUBR (Fhash_table_weakness);
1479 DEFSUBR (Fhash_table_type); /* obsolete */
1482 DEFSUBR (Finternal_hash_value);
1485 defsymbol (&Qhash_tablep, "hash-table-p");
1486 defsymbol (&Qhash_table, "hash-table");
1487 defsymbol (&Qhashtable, "hashtable");
1488 defsymbol (&Qweakness, "weakness");
1489 defsymbol (&Qvalue, "value");
1490 defsymbol (&Qkey_or_value, "key-or-value");
1491 defsymbol (&Qkey_and_value, "key-and-value");
1492 defsymbol (&Qrehash_size, "rehash-size");
1493 defsymbol (&Qrehash_threshold, "rehash-threshold");
1495 defsymbol (&Qweak, "weak"); /* obsolete */
1496 defsymbol (&Qkey_weak, "key-weak"); /* obsolete */
1497 defsymbol (&Qkey_or_value_weak, "key-or-value-weak"); /* obsolete */
1498 defsymbol (&Qvalue_weak, "value-weak"); /* obsolete */
1499 defsymbol (&Qnon_weak, "non-weak"); /* obsolete */
1501 defkeyword (&Q_test, ":test");
1502 defkeyword (&Q_size, ":size");
1503 defkeyword (&Q_rehash_size, ":rehash-size");
1504 defkeyword (&Q_rehash_threshold, ":rehash-threshold");
1505 defkeyword (&Q_weakness, ":weakness");
1506 defkeyword (&Q_type, ":type"); /* obsolete */
1510 vars_of_elhash (void)
1512 /* This must NOT be staticpro'd */
1513 Vall_weak_hash_tables = Qnil;
1514 pdump_wire_list (&Vall_weak_hash_tables);