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_standard_lisp_hash_table (enum hash_table_test test,
440 double rehash_threshold,
441 enum hash_table_weakness weakness)
443 hash_table_hash_function_t hash_function = 0;
444 hash_table_test_function_t test_function = 0;
454 test_function = lisp_object_eql_equal;
455 hash_function = lisp_object_eql_hash;
458 case HASH_TABLE_EQUAL:
459 test_function = lisp_object_equal_equal;
460 hash_function = lisp_object_equal_hash;
467 return make_general_lisp_hash_table (hash_function, test_function,
468 size, rehash_size, rehash_threshold,
473 make_general_lisp_hash_table (hash_table_hash_function_t hash_function,
474 hash_table_test_function_t test_function,
477 double rehash_threshold,
478 enum hash_table_weakness weakness)
480 Lisp_Object hash_table;
481 Lisp_Hash_Table *ht = alloc_lcrecord_type (Lisp_Hash_Table, &lrecord_hash_table);
483 ht->test_function = test_function;
484 ht->hash_function = hash_function;
485 ht->weakness = weakness;
488 rehash_size > 1.0 ? rehash_size : HASH_TABLE_DEFAULT_REHASH_SIZE;
490 ht->rehash_threshold =
491 rehash_threshold > 0.0 ? rehash_threshold :
492 size > 4096 && !ht->test_function ? 0.7 : 0.6;
494 if (size < HASH_TABLE_MIN_SIZE)
495 size = HASH_TABLE_MIN_SIZE;
496 ht->size = hash_table_size ((size_t) (((double) size / ht->rehash_threshold)
500 compute_hash_table_derived_values (ht);
502 /* We leave room for one never-occupied sentinel hentry at the end. */
503 ht->hentries = xnew_array_and_zero (hentry, ht->size + 1);
505 XSETHASH_TABLE (hash_table, ht);
507 if (weakness == HASH_TABLE_NON_WEAK)
508 ht->next_weak = Qunbound;
510 ht->next_weak = Vall_weak_hash_tables, Vall_weak_hash_tables = hash_table;
516 make_lisp_hash_table (size_t size,
517 enum hash_table_weakness weakness,
518 enum hash_table_test test)
520 return make_standard_lisp_hash_table (test, size, -1.0, -1.0, weakness);
523 /* Pretty reading of hash tables.
525 Here we use the existing structures mechanism (which is,
526 unfortunately, pretty cumbersome) for validating and instantiating
527 the hash tables. The idea is that the side-effect of reading a
528 #s(hash-table PLIST) object is creation of a hash table with desired
529 properties, and that the hash table is returned. */
531 /* Validation functions: each keyword provides its own validation
532 function. The errors should maybe be continuable, but it is
533 unclear how this would cope with ERRB. */
535 hash_table_size_validate (Lisp_Object keyword, Lisp_Object value,
541 maybe_signal_error (Qwrong_type_argument, list2 (Qnatnump, value),
547 decode_hash_table_size (Lisp_Object obj)
549 return NILP (obj) ? HASH_TABLE_DEFAULT_SIZE : XINT (obj);
553 hash_table_weakness_validate (Lisp_Object keyword, Lisp_Object value,
556 if (EQ (value, Qnil)) return 1;
557 if (EQ (value, Qt)) return 1;
558 if (EQ (value, Qkey)) return 1;
559 if (EQ (value, Qkey_and_value)) return 1;
560 if (EQ (value, Qkey_or_value)) return 1;
561 if (EQ (value, Qvalue)) return 1;
563 /* Following values are obsolete as of 19990901 in xemacs-21.2 */
564 if (EQ (value, Qnon_weak)) return 1;
565 if (EQ (value, Qweak)) return 1;
566 if (EQ (value, Qkey_weak)) return 1;
567 if (EQ (value, Qkey_or_value_weak)) return 1;
568 if (EQ (value, Qvalue_weak)) return 1;
570 maybe_signal_simple_error ("Invalid hash table weakness",
571 value, Qhash_table, errb);
575 static enum hash_table_weakness
576 decode_hash_table_weakness (Lisp_Object obj)
578 if (EQ (obj, Qnil)) return HASH_TABLE_NON_WEAK;
579 if (EQ (obj, Qt)) return HASH_TABLE_WEAK;
580 if (EQ (obj, Qkey_and_value)) return HASH_TABLE_WEAK;
581 if (EQ (obj, Qkey)) return HASH_TABLE_KEY_WEAK;
582 if (EQ (obj, Qkey_or_value)) return HASH_TABLE_KEY_VALUE_WEAK;
583 if (EQ (obj, Qvalue)) return HASH_TABLE_VALUE_WEAK;
585 /* Following values are obsolete as of 19990901 in xemacs-21.2 */
586 if (EQ (obj, Qnon_weak)) return HASH_TABLE_NON_WEAK;
587 if (EQ (obj, Qweak)) return HASH_TABLE_WEAK;
588 if (EQ (obj, Qkey_weak)) return HASH_TABLE_KEY_WEAK;
589 if (EQ (obj, Qkey_or_value_weak)) return HASH_TABLE_KEY_VALUE_WEAK;
590 if (EQ (obj, Qvalue_weak)) return HASH_TABLE_VALUE_WEAK;
592 signal_simple_error ("Invalid hash table weakness", obj);
593 return HASH_TABLE_NON_WEAK; /* not reached */
597 hash_table_test_validate (Lisp_Object keyword, Lisp_Object value,
600 if (EQ (value, Qnil)) return 1;
601 if (EQ (value, Qeq)) return 1;
602 if (EQ (value, Qequal)) return 1;
603 if (EQ (value, Qeql)) return 1;
605 maybe_signal_simple_error ("Invalid hash table test",
606 value, Qhash_table, errb);
610 static enum hash_table_test
611 decode_hash_table_test (Lisp_Object obj)
613 if (EQ (obj, Qnil)) return HASH_TABLE_EQL;
614 if (EQ (obj, Qeq)) return HASH_TABLE_EQ;
615 if (EQ (obj, Qequal)) return HASH_TABLE_EQUAL;
616 if (EQ (obj, Qeql)) return HASH_TABLE_EQL;
618 signal_simple_error ("Invalid hash table test", obj);
619 return HASH_TABLE_EQ; /* not reached */
623 hash_table_rehash_size_validate (Lisp_Object keyword, Lisp_Object value,
628 maybe_signal_error (Qwrong_type_argument, list2 (Qfloatp, value),
634 double rehash_size = XFLOAT_DATA (value);
635 if (rehash_size <= 1.0)
637 maybe_signal_simple_error
638 ("Hash table rehash size must be greater than 1.0",
639 value, Qhash_table, errb);
648 decode_hash_table_rehash_size (Lisp_Object rehash_size)
650 return NILP (rehash_size) ? -1.0 : XFLOAT_DATA (rehash_size);
654 hash_table_rehash_threshold_validate (Lisp_Object keyword, Lisp_Object value,
659 maybe_signal_error (Qwrong_type_argument, list2 (Qfloatp, value),
665 double rehash_threshold = XFLOAT_DATA (value);
666 if (rehash_threshold <= 0.0 || rehash_threshold >= 1.0)
668 maybe_signal_simple_error
669 ("Hash table rehash threshold must be between 0.0 and 1.0",
670 value, Qhash_table, errb);
679 decode_hash_table_rehash_threshold (Lisp_Object rehash_threshold)
681 return NILP (rehash_threshold) ? -1.0 : XFLOAT_DATA (rehash_threshold);
685 hash_table_data_validate (Lisp_Object keyword, Lisp_Object value,
690 GET_EXTERNAL_LIST_LENGTH (value, len);
694 maybe_signal_simple_error
695 ("Hash table data must have alternating key/value pairs",
696 value, Qhash_table, errb);
702 /* The actual instantiation of a hash table. This does practically no
703 error checking, because it relies on the fact that the paranoid
704 functions above have error-checked everything to the last details.
705 If this assumption is wrong, we will get a crash immediately (with
706 error-checking compiled in), and we'll know if there is a bug in
707 the structure mechanism. So there. */
709 hash_table_instantiate (Lisp_Object plist)
711 Lisp_Object hash_table;
712 Lisp_Object test = Qnil;
713 Lisp_Object size = Qnil;
714 Lisp_Object rehash_size = Qnil;
715 Lisp_Object rehash_threshold = Qnil;
716 Lisp_Object weakness = Qnil;
717 Lisp_Object data = Qnil;
719 while (!NILP (plist))
721 Lisp_Object key, value;
722 key = XCAR (plist); plist = XCDR (plist);
723 value = XCAR (plist); plist = XCDR (plist);
725 if (EQ (key, Qtest)) test = value;
726 else if (EQ (key, Qsize)) size = value;
727 else if (EQ (key, Qrehash_size)) rehash_size = value;
728 else if (EQ (key, Qrehash_threshold)) rehash_threshold = value;
729 else if (EQ (key, Qweakness)) weakness = value;
730 else if (EQ (key, Qdata)) data = value;
731 else if (EQ (key, Qtype))/*obsolete*/ weakness = value;
736 /* Create the hash table. */
737 hash_table = make_standard_lisp_hash_table
738 (decode_hash_table_test (test),
739 decode_hash_table_size (size),
740 decode_hash_table_rehash_size (rehash_size),
741 decode_hash_table_rehash_threshold (rehash_threshold),
742 decode_hash_table_weakness (weakness));
744 /* I'm not sure whether this can GC, but better safe than sorry. */
749 /* And fill it with data. */
752 Lisp_Object key, value;
753 key = XCAR (data); data = XCDR (data);
754 value = XCAR (data); data = XCDR (data);
755 Fputhash (key, value, hash_table);
764 structure_type_create_hash_table_structure_name (Lisp_Object structure_name)
766 struct structure_type *st;
768 st = define_structure_type (structure_name, 0, hash_table_instantiate);
769 define_structure_type_keyword (st, Qtest, hash_table_test_validate);
770 define_structure_type_keyword (st, Qsize, hash_table_size_validate);
771 define_structure_type_keyword (st, Qrehash_size, hash_table_rehash_size_validate);
772 define_structure_type_keyword (st, Qrehash_threshold, hash_table_rehash_threshold_validate);
773 define_structure_type_keyword (st, Qweakness, hash_table_weakness_validate);
774 define_structure_type_keyword (st, Qdata, hash_table_data_validate);
776 /* obsolete as of 19990901 in xemacs-21.2 */
777 define_structure_type_keyword (st, Qtype, hash_table_weakness_validate);
780 /* Create a built-in Lisp structure type named `hash-table'.
781 We make #s(hashtable ...) equivalent to #s(hash-table ...),
782 for backward compatibility.
783 This is called from emacs.c. */
785 structure_type_create_hash_table (void)
787 structure_type_create_hash_table_structure_name (Qhash_table);
788 structure_type_create_hash_table_structure_name (Qhashtable); /* compat */
792 /************************************************************************/
793 /* Definition of Lisp-visible methods */
794 /************************************************************************/
796 DEFUN ("hash-table-p", Fhash_table_p, 1, 1, 0, /*
797 Return t if OBJECT is a hash table, else nil.
801 return HASH_TABLEP (object) ? Qt : Qnil;
804 DEFUN ("make-hash-table", Fmake_hash_table, 0, MANY, 0, /*
805 Return a new empty hash table object.
806 Use Common Lisp style keywords to specify hash table properties.
807 (make-hash-table &key test size rehash-size rehash-threshold weakness)
809 Keyword :test can be `eq', `eql' (default) or `equal'.
810 Comparison between keys is done using this function.
811 If speed is important, consider using `eq'.
812 When storing strings in the hash table, you will likely need to use `equal'.
814 Keyword :size specifies the number of keys likely to be inserted.
815 This number of entries can be inserted without enlarging the hash table.
817 Keyword :rehash-size must be a float greater than 1.0, and specifies
818 the factor by which to increase the size of the hash table when enlarging.
820 Keyword :rehash-threshold must be a float between 0.0 and 1.0,
821 and specifies the load factor of the hash table which triggers enlarging.
823 Non-standard keyword :weakness can be `nil' (default), `t', `key-and-value',
824 `key', `value' or `key-or-value'. `t' is an alias for `key-and-value'.
826 A key-and-value-weak hash table, also known as a fully-weak or simply
827 as a weak hash table, is one whose pointers do not count as GC
828 referents: for any key-value pair in the hash table, if the only
829 remaining pointer to either the key or the value is in a weak hash
830 table, then the pair will be removed from the hash table, and the key
831 and value collected. A non-weak hash table (or any other pointer)
832 would prevent the object from being collected.
834 A key-weak hash table is similar to a fully-weak hash table except that
835 a key-value pair will be removed only if the key remains unmarked
836 outside of weak hash tables. The pair will remain in the hash table if
837 the key is pointed to by something other than a weak hash table, even
840 A value-weak hash table is similar to a fully-weak hash table except
841 that a key-value pair will be removed only if the value remains
842 unmarked outside of weak hash tables. The pair will remain in the
843 hash table if the value is pointed to by something other than a weak
844 hash table, even if the key is not.
846 A key-or-value-weak hash table is similar to a fully-weak hash table except
847 that a key-value pair will be removed only if the value and the key remain
848 unmarked outside of weak hash tables. The pair will remain in the
849 hash table if the value or key are pointed to by something other than a weak
850 hash table, even if the other is not.
852 (int nargs, Lisp_Object *args))
855 Lisp_Object test = Qnil;
856 Lisp_Object size = Qnil;
857 Lisp_Object rehash_size = Qnil;
858 Lisp_Object rehash_threshold = Qnil;
859 Lisp_Object weakness = Qnil;
861 while (i + 1 < nargs)
863 Lisp_Object keyword = args[i++];
864 Lisp_Object value = args[i++];
866 if (EQ (keyword, Q_test)) test = value;
867 else if (EQ (keyword, Q_size)) size = value;
868 else if (EQ (keyword, Q_rehash_size)) rehash_size = value;
869 else if (EQ (keyword, Q_rehash_threshold)) rehash_threshold = value;
870 else if (EQ (keyword, Q_weakness)) weakness = value;
871 else if (EQ (keyword, Q_type))/*obsolete*/ weakness = value;
872 else signal_simple_error ("Invalid hash table property keyword", keyword);
876 signal_simple_error ("Hash table property requires a value", args[i]);
878 #define VALIDATE_VAR(var) \
879 if (!NILP (var)) hash_table_##var##_validate (Q##var, var, ERROR_ME);
883 VALIDATE_VAR (rehash_size);
884 VALIDATE_VAR (rehash_threshold);
885 VALIDATE_VAR (weakness);
887 return make_standard_lisp_hash_table
888 (decode_hash_table_test (test),
889 decode_hash_table_size (size),
890 decode_hash_table_rehash_size (rehash_size),
891 decode_hash_table_rehash_threshold (rehash_threshold),
892 decode_hash_table_weakness (weakness));
895 DEFUN ("copy-hash-table", Fcopy_hash_table, 1, 1, 0, /*
896 Return a new hash table containing the same keys and values as HASH-TABLE.
897 The keys and values will not themselves be copied.
901 const Lisp_Hash_Table *ht_old = xhash_table (hash_table);
902 Lisp_Hash_Table *ht = alloc_lcrecord_type (Lisp_Hash_Table, &lrecord_hash_table);
904 copy_lcrecord (ht, ht_old);
906 ht->hentries = xnew_array (hentry, ht_old->size + 1);
907 memcpy (ht->hentries, ht_old->hentries, (ht_old->size + 1) * sizeof (hentry));
909 XSETHASH_TABLE (hash_table, ht);
911 if (! EQ (ht->next_weak, Qunbound))
913 ht->next_weak = Vall_weak_hash_tables;
914 Vall_weak_hash_tables = hash_table;
921 resize_hash_table (Lisp_Hash_Table *ht, size_t new_size)
923 hentry *old_entries, *new_entries, *sentinel, *e;
929 old_entries = ht->hentries;
931 ht->hentries = xnew_array_and_zero (hentry, new_size + 1);
932 new_entries = ht->hentries;
934 compute_hash_table_derived_values (ht);
936 for (e = old_entries, sentinel = e + old_size; e < sentinel; e++)
937 if (!HENTRY_CLEAR_P (e))
939 hentry *probe = new_entries + HASH_CODE (e->key, ht);
940 LINEAR_PROBING_LOOP (probe, new_entries, new_size)
945 if (!DUMPEDP (old_entries))
949 /* After a hash table has been saved to disk and later restored by the
950 portable dumper, it contains the same objects, but their addresses
951 and thus their HASH_CODEs have changed. */
953 pdump_reorganize_hash_table (Lisp_Object hash_table)
955 const Lisp_Hash_Table *ht = xhash_table (hash_table);
956 hentry *new_entries = xnew_array_and_zero (hentry, ht->size + 1);
957 hentry *e, *sentinel;
959 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
960 if (!HENTRY_CLEAR_P (e))
962 hentry *probe = new_entries + HASH_CODE (e->key, ht);
963 LINEAR_PROBING_LOOP (probe, new_entries, ht->size)
968 memcpy (ht->hentries, new_entries, ht->size * sizeof (hentry));
974 enlarge_hash_table (Lisp_Hash_Table *ht)
977 hash_table_size ((size_t) ((double) ht->size * ht->rehash_size));
978 resize_hash_table (ht, new_size);
982 find_hentry (Lisp_Object key, const Lisp_Hash_Table *ht)
984 hash_table_test_function_t test_function = ht->test_function;
985 hentry *entries = ht->hentries;
986 hentry *probe = entries + HASH_CODE (key, ht);
988 LINEAR_PROBING_LOOP (probe, entries, ht->size)
989 if (KEYS_EQUAL_P (probe->key, key, test_function))
995 DEFUN ("gethash", Fgethash, 2, 3, 0, /*
996 Find hash value for KEY in HASH-TABLE.
997 If there is no corresponding value, return DEFAULT (which defaults to nil).
999 (key, hash_table, default_))
1001 const Lisp_Hash_Table *ht = xhash_table (hash_table);
1002 hentry *e = find_hentry (key, ht);
1004 return HENTRY_CLEAR_P (e) ? default_ : e->value;
1007 DEFUN ("puthash", Fputhash, 3, 3, 0, /*
1008 Hash KEY to VALUE in HASH-TABLE.
1010 (key, value, hash_table))
1012 Lisp_Hash_Table *ht = xhash_table (hash_table);
1013 hentry *e = find_hentry (key, ht);
1015 if (!HENTRY_CLEAR_P (e))
1016 return e->value = value;
1021 if (++ht->count >= ht->rehash_count)
1022 enlarge_hash_table (ht);
1027 /* Remove hentry pointed at by PROBE.
1028 Subsequent entries are removed and reinserted.
1029 We don't use tombstones - too wasteful. */
1031 remhash_1 (Lisp_Hash_Table *ht, hentry *entries, hentry *probe)
1033 size_t size = ht->size;
1034 CLEAR_HENTRY (probe);
1038 LINEAR_PROBING_LOOP (probe, entries, size)
1040 Lisp_Object key = probe->key;
1041 hentry *probe2 = entries + HASH_CODE (key, ht);
1042 LINEAR_PROBING_LOOP (probe2, entries, size)
1043 if (EQ (probe2->key, key))
1044 /* hentry at probe doesn't need to move. */
1045 goto continue_outer_loop;
1046 /* Move hentry from probe to new home at probe2. */
1048 CLEAR_HENTRY (probe);
1049 continue_outer_loop: continue;
1053 DEFUN ("remhash", Fremhash, 2, 2, 0, /*
1054 Remove the entry for KEY from HASH-TABLE.
1055 Do nothing if there is no entry for KEY in HASH-TABLE.
1059 Lisp_Hash_Table *ht = xhash_table (hash_table);
1060 hentry *e = find_hentry (key, ht);
1062 if (HENTRY_CLEAR_P (e))
1065 remhash_1 (ht, ht->hentries, e);
1069 DEFUN ("clrhash", Fclrhash, 1, 1, 0, /*
1070 Remove all entries from HASH-TABLE, leaving it empty.
1074 Lisp_Hash_Table *ht = xhash_table (hash_table);
1075 hentry *e, *sentinel;
1077 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1084 /************************************************************************/
1085 /* Accessor Functions */
1086 /************************************************************************/
1088 DEFUN ("hash-table-count", Fhash_table_count, 1, 1, 0, /*
1089 Return the number of entries in HASH-TABLE.
1093 return make_int (xhash_table (hash_table)->count);
1096 DEFUN ("hash-table-test", Fhash_table_test, 1, 1, 0, /*
1097 Return the test function of HASH-TABLE.
1098 This can be one of `eq', `eql' or `equal'.
1102 hash_table_test_function_t fun = xhash_table (hash_table)->test_function;
1104 return (fun == lisp_object_eql_equal ? Qeql :
1105 fun == lisp_object_equal_equal ? Qequal :
1109 DEFUN ("hash-table-size", Fhash_table_size, 1, 1, 0, /*
1110 Return the size of HASH-TABLE.
1111 This is the current number of slots in HASH-TABLE, whether occupied or not.
1115 return make_int (xhash_table (hash_table)->size);
1118 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size, 1, 1, 0, /*
1119 Return the current rehash size of HASH-TABLE.
1120 This is a float greater than 1.0; the factor by which HASH-TABLE
1121 is enlarged when the rehash threshold is exceeded.
1125 return make_float (xhash_table (hash_table)->rehash_size);
1128 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold, 1, 1, 0, /*
1129 Return the current rehash threshold of HASH-TABLE.
1130 This is a float between 0.0 and 1.0; the maximum `load factor' of HASH-TABLE,
1131 beyond which the HASH-TABLE is enlarged by rehashing.
1135 return make_float (xhash_table (hash_table)->rehash_threshold);
1138 DEFUN ("hash-table-weakness", Fhash_table_weakness, 1, 1, 0, /*
1139 Return the weakness of HASH-TABLE.
1140 This can be one of `nil', `key-and-value', `key-or-value', `key' or `value'.
1144 switch (xhash_table (hash_table)->weakness)
1146 case HASH_TABLE_WEAK: return Qkey_and_value;
1147 case HASH_TABLE_KEY_WEAK: return Qkey;
1148 case HASH_TABLE_KEY_VALUE_WEAK: return Qkey_or_value;
1149 case HASH_TABLE_VALUE_WEAK: return Qvalue;
1150 default: return Qnil;
1154 /* obsolete as of 19990901 in xemacs-21.2 */
1155 DEFUN ("hash-table-type", Fhash_table_type, 1, 1, 0, /*
1156 Return the type of HASH-TABLE.
1157 This can be one of `non-weak', `weak', `key-weak' or `value-weak'.
1161 switch (xhash_table (hash_table)->weakness)
1163 case HASH_TABLE_WEAK: return Qweak;
1164 case HASH_TABLE_KEY_WEAK: return Qkey_weak;
1165 case HASH_TABLE_KEY_VALUE_WEAK: return Qkey_or_value_weak;
1166 case HASH_TABLE_VALUE_WEAK: return Qvalue_weak;
1167 default: return Qnon_weak;
1171 /************************************************************************/
1172 /* Mapping Functions */
1173 /************************************************************************/
1174 DEFUN ("maphash", Fmaphash, 2, 2, 0, /*
1175 Map FUNCTION over entries in HASH-TABLE, calling it with two args,
1176 each key and value in HASH-TABLE.
1178 FUNCTION may not modify HASH-TABLE, with the one exception that FUNCTION
1179 may remhash or puthash the entry currently being processed by FUNCTION.
1181 (function, hash_table))
1183 const Lisp_Hash_Table *ht = xhash_table (hash_table);
1184 const hentry *e, *sentinel;
1186 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1187 if (!HENTRY_CLEAR_P (e))
1189 Lisp_Object args[3], key;
1195 Ffuncall (countof (args), args);
1196 /* Has FUNCTION done a remhash? */
1197 if (!EQ (key, e->key) && !HENTRY_CLEAR_P (e))
1204 /* #### If the Lisp function being called does a puthash and this
1205 #### causes the hash table to be resized, the results will be quite
1206 #### random and we will likely crash. To fix this, either set a
1207 #### flag in the hash table while we're mapping and signal an error
1208 #### when new entries are added, or fix things to make this
1209 #### operation work properly, like this: Store two hash tables in
1210 #### each hash table object -- the second one is written to when
1211 #### you do a puthash inside of a mapping operation, and the
1212 #### various operations need to check both hash tables for entries.
1213 #### As soon as the last maphash over a particular hash table
1214 #### object terminates, the entries in the second table are added
1215 #### to the first (using an unwind-protect). --ben */
1217 /* Map *C* function FUNCTION over the elements of a lisp hash table. */
1219 elisp_maphash (maphash_function_t function,
1220 Lisp_Object hash_table, void *extra_arg)
1222 const Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1223 const hentry *e, *sentinel;
1225 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1226 if (!HENTRY_CLEAR_P (e))
1231 if (function (key, e->value, extra_arg))
1233 /* Has FUNCTION done a remhash? */
1234 if (!EQ (key, e->key) && !HENTRY_CLEAR_P (e))
1239 /* Remove all elements of a lisp hash table satisfying *C* predicate PREDICATE. */
1241 elisp_map_remhash (maphash_function_t predicate,
1242 Lisp_Object hash_table, void *extra_arg)
1244 Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1245 hentry *e, *entries, *sentinel;
1247 for (e = entries = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1248 if (!HENTRY_CLEAR_P (e))
1251 if (predicate (e->key, e->value, extra_arg))
1253 remhash_1 (ht, entries, e);
1254 if (!HENTRY_CLEAR_P (e))
1261 /************************************************************************/
1262 /* garbage collecting weak hash tables */
1263 /************************************************************************/
1264 #define MARK_OBJ(obj) do { \
1265 Lisp_Object mo_obj = (obj); \
1266 if (!marked_p (mo_obj)) \
1268 mark_object (mo_obj); \
1274 /* Complete the marking for semi-weak hash tables. */
1276 finish_marking_weak_hash_tables (void)
1278 Lisp_Object hash_table;
1281 for (hash_table = Vall_weak_hash_tables;
1283 hash_table = XHASH_TABLE (hash_table)->next_weak)
1285 const Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1286 const hentry *e = ht->hentries;
1287 const hentry *sentinel = e + ht->size;
1289 if (! marked_p (hash_table))
1290 /* The hash table is probably garbage. Ignore it. */
1293 /* Now, scan over all the pairs. For all pairs that are
1294 half-marked, we may need to mark the other half if we're
1295 keeping this pair. */
1296 switch (ht->weakness)
1298 case HASH_TABLE_KEY_WEAK:
1299 for (; e < sentinel; e++)
1300 if (!HENTRY_CLEAR_P (e))
1301 if (marked_p (e->key))
1302 MARK_OBJ (e->value);
1305 case HASH_TABLE_VALUE_WEAK:
1306 for (; e < sentinel; e++)
1307 if (!HENTRY_CLEAR_P (e))
1308 if (marked_p (e->value))
1312 case HASH_TABLE_KEY_VALUE_WEAK:
1313 for (; e < sentinel; e++)
1314 if (!HENTRY_CLEAR_P (e))
1316 if (marked_p (e->value))
1318 else if (marked_p (e->key))
1319 MARK_OBJ (e->value);
1323 case HASH_TABLE_KEY_CAR_WEAK:
1324 for (; e < sentinel; e++)
1325 if (!HENTRY_CLEAR_P (e))
1326 if (!CONSP (e->key) || marked_p (XCAR (e->key)))
1329 MARK_OBJ (e->value);
1333 /* We seem to be sprouting new weakness types at an alarming
1334 rate. At least this is not externally visible - and in
1335 fact all of these KEY_CAR_* types are only used by the
1337 case HASH_TABLE_KEY_CAR_VALUE_WEAK:
1338 for (; e < sentinel; e++)
1339 if (!HENTRY_CLEAR_P (e))
1341 if (!CONSP (e->key) || marked_p (XCAR (e->key)))
1344 MARK_OBJ (e->value);
1346 else if (marked_p (e->value))
1351 case HASH_TABLE_VALUE_CAR_WEAK:
1352 for (; e < sentinel; e++)
1353 if (!HENTRY_CLEAR_P (e))
1354 if (!CONSP (e->value) || marked_p (XCAR (e->value)))
1357 MARK_OBJ (e->value);
1370 prune_weak_hash_tables (void)
1372 Lisp_Object hash_table, prev = Qnil;
1373 for (hash_table = Vall_weak_hash_tables;
1375 hash_table = XHASH_TABLE (hash_table)->next_weak)
1377 if (! marked_p (hash_table))
1379 /* This hash table itself is garbage. Remove it from the list. */
1381 Vall_weak_hash_tables = XHASH_TABLE (hash_table)->next_weak;
1383 XHASH_TABLE (prev)->next_weak = XHASH_TABLE (hash_table)->next_weak;
1387 /* Now, scan over all the pairs. Remove all of the pairs
1388 in which the key or value, or both, is unmarked
1389 (depending on the weakness of the hash table). */
1390 Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1391 hentry *entries = ht->hentries;
1392 hentry *sentinel = entries + ht->size;
1395 for (e = entries; e < sentinel; e++)
1396 if (!HENTRY_CLEAR_P (e))
1399 if (!marked_p (e->key) || !marked_p (e->value))
1401 remhash_1 (ht, entries, e);
1402 if (!HENTRY_CLEAR_P (e))
1412 /* Return a hash value for an array of Lisp_Objects of size SIZE. */
1415 internal_array_hash (Lisp_Object *arr, int size, int depth)
1418 hashcode_t hash = 0;
1423 for (i = 0; i < size; i++)
1424 hash = HASH2 (hash, internal_hash (arr[i], depth));
1428 /* just pick five elements scattered throughout the array.
1429 A slightly better approach would be to offset by some
1430 noise factor from the points chosen below. */
1431 for (i = 0; i < 5; i++)
1432 hash = HASH2 (hash, internal_hash (arr[i*size/5], depth));
1437 /* Return a hash value for a Lisp_Object. This is for use when hashing
1438 objects with the comparison being `equal' (for `eq', you can just
1439 use the Lisp_Object itself as the hash value). You need to make a
1440 tradeoff between the speed of the hash function and how good the
1441 hashing is. In particular, the hash function needs to be FAST,
1442 so you can't just traipse down the whole tree hashing everything
1443 together. Most of the time, objects will differ in the first
1444 few elements you hash. Thus, we only go to a short depth (5)
1445 and only hash at most 5 elements out of a vector. Theoretically
1446 we could still take 5^5 time (a big big number) to compute a
1447 hash, but practically this won't ever happen. */
1450 internal_hash (Lisp_Object obj, int depth)
1456 /* no point in worrying about tail recursion, since we're not
1458 return HASH2 (internal_hash (XCAR (obj), depth + 1),
1459 internal_hash (XCDR (obj), depth + 1));
1463 return hash_string (XSTRING_DATA (obj), XSTRING_LENGTH (obj));
1467 const struct lrecord_implementation
1468 *imp = XRECORD_LHEADER_IMPLEMENTATION (obj);
1470 return imp->hash (obj, depth);
1473 return LISP_HASH (obj);
1476 DEFUN ("sxhash", Fsxhash, 1, 1, 0, /*
1477 Return a hash value for OBJECT.
1478 \(equal obj1 obj2) implies (= (sxhash obj1) (sxhash obj2)).
1482 return make_int (internal_hash (object, 0));
1486 xxDEFUN ("internal-hash-value", Finternal_hash_value, 1, 1, 0, /*
1487 Hash value of OBJECT. For debugging.
1488 The value is returned as (HIGH . LOW).
1492 /* This function is pretty 32bit-centric. */
1493 hashcode_t hash = internal_hash (object, 0);
1494 return Fcons (hash >> 16, hash & 0xffff);
1499 /************************************************************************/
1500 /* initialization */
1501 /************************************************************************/
1504 syms_of_elhash (void)
1506 INIT_LRECORD_IMPLEMENTATION (hash_table);
1508 DEFSUBR (Fhash_table_p);
1509 DEFSUBR (Fmake_hash_table);
1510 DEFSUBR (Fcopy_hash_table);
1516 DEFSUBR (Fhash_table_count);
1517 DEFSUBR (Fhash_table_test);
1518 DEFSUBR (Fhash_table_size);
1519 DEFSUBR (Fhash_table_rehash_size);
1520 DEFSUBR (Fhash_table_rehash_threshold);
1521 DEFSUBR (Fhash_table_weakness);
1522 DEFSUBR (Fhash_table_type); /* obsolete */
1525 DEFSUBR (Finternal_hash_value);
1528 defsymbol (&Qhash_tablep, "hash-table-p");
1529 defsymbol (&Qhash_table, "hash-table");
1530 defsymbol (&Qhashtable, "hashtable");
1531 defsymbol (&Qweakness, "weakness");
1532 defsymbol (&Qvalue, "value");
1533 defsymbol (&Qkey_or_value, "key-or-value");
1534 defsymbol (&Qkey_and_value, "key-and-value");
1535 defsymbol (&Qrehash_size, "rehash-size");
1536 defsymbol (&Qrehash_threshold, "rehash-threshold");
1538 defsymbol (&Qweak, "weak"); /* obsolete */
1539 defsymbol (&Qkey_weak, "key-weak"); /* obsolete */
1540 defsymbol (&Qkey_or_value_weak, "key-or-value-weak"); /* obsolete */
1541 defsymbol (&Qvalue_weak, "value-weak"); /* obsolete */
1542 defsymbol (&Qnon_weak, "non-weak"); /* obsolete */
1544 defkeyword (&Q_test, ":test");
1545 defkeyword (&Q_size, ":size");
1546 defkeyword (&Q_rehash_size, ":rehash-size");
1547 defkeyword (&Q_rehash_threshold, ":rehash-threshold");
1548 defkeyword (&Q_weakness, ":weakness");
1549 defkeyword (&Q_type, ":type"); /* obsolete */
1553 vars_of_elhash (void)
1555 /* This must NOT be staticpro'd */
1556 Vall_weak_hash_tables = Qnil;
1557 dump_add_weak_object_chain (&Vall_weak_hash_tables);