1 /* Implementation of the hash table lisp object type.
2 Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
3 Copyright (C) 1995, 1996 Ben Wing.
4 Copyright (C) 1997 Free Software Foundation, Inc.
6 This file is part of XEmacs.
8 XEmacs is free software; you can redistribute it and/or modify it
9 under the terms of the GNU General Public License as published by the
10 Free Software Foundation; either version 2, or (at your option) any
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
14 ANY WARRANTY; without even the implied warranty of MERCNTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with XEmacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA. */
23 /* Synched up with: Not in FSF. */
30 Lisp_Object Qhash_tablep;
31 static Lisp_Object Qhashtable, Qhash_table;
32 static Lisp_Object Qweakness, Qvalue;
33 static Lisp_Object Vall_weak_hash_tables;
34 static Lisp_Object Qrehash_size, Qrehash_threshold;
35 static Lisp_Object Q_size, Q_test, Q_weakness, Q_rehash_size, Q_rehash_threshold;
37 /* obsolete as of 19990901 in xemacs-21.2 */
38 static Lisp_Object Qweak, Qkey_weak, Qvalue_weak, Qnon_weak, Q_type;
46 struct Lisp_Hash_Table
48 struct lcrecord_header header;
53 double rehash_threshold;
55 hash_table_hash_function_t hash_function;
56 hash_table_test_function_t test_function;
58 enum hash_table_weakness weakness;
59 Lisp_Object next_weak; /* Used to chain together all of the weak
60 hash tables. Don't mark through this. */
62 typedef struct Lisp_Hash_Table Lisp_Hash_Table;
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 /* Printing hash tables.
259 This is non-trivial, because we use a readable structure-style
260 syntax for hash tables. This means that a typical hash table will be
261 readably printed in the form of:
263 #s(hash-table size 2 data (key1 value1 key2 value2))
265 The supported hash table structure keywords and their values are:
266 `test' (eql (or nil), eq or equal)
267 `size' (a natnum or nil)
268 `rehash-size' (a float)
269 `rehash-threshold' (a float)
270 `weakness' (nil, t, key or value)
273 If `print-readably' is nil, then a simpler syntax is used, for example
275 #<hash-table size 2/13 data (key1 value1 key2 value2) 0x874d>
277 The data is truncated to four pairs, and the rest is shown with
278 `...'. This printer does not cons. */
281 /* Print the data of the hash table. This maps through a Lisp
282 hash table and prints key/value pairs using PRINTCHARFUN. */
284 print_hash_table_data (Lisp_Hash_Table *ht, Lisp_Object printcharfun)
287 hentry *e, *sentinel;
289 write_c_string (" data (", printcharfun);
291 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
292 if (!HENTRY_CLEAR_P (e))
295 write_c_string (" ", printcharfun);
296 if (!print_readably && count > 3)
298 write_c_string ("...", printcharfun);
301 print_internal (e->key, printcharfun, 1);
302 write_c_string (" ", printcharfun);
303 print_internal (e->value, printcharfun, 1);
307 write_c_string (")", printcharfun);
311 print_hash_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
313 Lisp_Hash_Table *ht = XHASH_TABLE (obj);
316 write_c_string (print_readably ? "#s(hash-table" : "#<hash-table",
319 /* These checks have a kludgy look to them, but they are safe.
320 Due to nature of hashing, you cannot use arbitrary
321 test functions anyway. */
322 if (!ht->test_function)
323 write_c_string (" test eq", printcharfun);
324 else if (ht->test_function == lisp_object_equal_equal)
325 write_c_string (" test equal", printcharfun);
326 else if (ht->test_function == lisp_object_eql_equal)
331 if (ht->count || !print_readably)
334 sprintf (buf, " size %lu", (unsigned long) ht->count);
336 sprintf (buf, " size %lu/%lu",
337 (unsigned long) ht->count,
338 (unsigned long) ht->size);
339 write_c_string (buf, printcharfun);
342 if (ht->weakness != HASH_TABLE_NON_WEAK)
344 sprintf (buf, " weakness %s",
345 (ht->weakness == HASH_TABLE_WEAK ? "t" :
346 ht->weakness == HASH_TABLE_KEY_WEAK ? "key" :
347 ht->weakness == HASH_TABLE_VALUE_WEAK ? "value" :
348 "you-d-better-not-see-this"));
349 write_c_string (buf, printcharfun);
353 print_hash_table_data (ht, printcharfun);
356 write_c_string (")", printcharfun);
359 sprintf (buf, " 0x%x>", ht->header.uid);
360 write_c_string (buf, printcharfun);
365 finalize_hash_table (void *header, int for_disksave)
369 Lisp_Hash_Table *ht = (Lisp_Hash_Table *) header;
371 xfree (ht->hentries);
376 static const struct lrecord_description hentry_description_1[] = {
377 { XD_LISP_OBJECT, offsetof(hentry, key), 2 },
381 static const struct struct_description hentry_description = {
386 const struct lrecord_description hash_table_description[] = {
387 { XD_SIZE_T, offsetof(Lisp_Hash_Table, size) },
388 { XD_STRUCT_PTR, offsetof(Lisp_Hash_Table, hentries), XD_INDIRECT(0, 1), &hentry_description },
389 { XD_LO_LINK, offsetof(Lisp_Hash_Table, next_weak) },
393 DEFINE_LRECORD_IMPLEMENTATION ("hash-table", hash_table,
394 mark_hash_table, print_hash_table,
396 /* #### Implement hash_table_hash()! */
398 hash_table_description,
401 static Lisp_Hash_Table *
402 xhash_table (Lisp_Object hash_table)
405 CHECK_HASH_TABLE (hash_table);
406 check_hash_table_invariants (XHASH_TABLE (hash_table));
407 return XHASH_TABLE (hash_table);
411 /************************************************************************/
412 /* Creation of Hash Tables */
413 /************************************************************************/
415 /* Creation of hash tables, without error-checking. */
417 hash_table_rehash_threshold (Lisp_Hash_Table *ht)
420 ht->rehash_threshold > 0.0 ? ht->rehash_threshold :
421 ht->size > 4096 && !ht->test_function ? 0.7 : 0.6;
425 compute_hash_table_derived_values (Lisp_Hash_Table *ht)
427 ht->rehash_count = (size_t)
428 ((double) ht->size * hash_table_rehash_threshold (ht));
429 ht->golden_ratio = (size_t)
430 ((double) ht->size * (.6180339887 / (double) sizeof (Lisp_Object)));
434 make_general_lisp_hash_table (enum hash_table_test test,
437 double rehash_threshold,
438 enum hash_table_weakness weakness)
440 Lisp_Object hash_table;
441 Lisp_Hash_Table *ht = alloc_lcrecord_type (Lisp_Hash_Table, &lrecord_hash_table);
443 ht->rehash_size = rehash_size;
444 ht->rehash_threshold = rehash_threshold;
445 ht->weakness = weakness;
450 ht->test_function = 0;
451 ht->hash_function = 0;
455 ht->test_function = lisp_object_eql_equal;
456 ht->hash_function = lisp_object_eql_hash;
459 case HASH_TABLE_EQUAL:
460 ht->test_function = lisp_object_equal_equal;
461 ht->hash_function = lisp_object_equal_hash;
468 if (ht->rehash_size <= 0.0)
469 ht->rehash_size = HASH_TABLE_DEFAULT_REHASH_SIZE;
470 if (size < HASH_TABLE_MIN_SIZE)
471 size = HASH_TABLE_MIN_SIZE;
472 if (rehash_threshold < 0.0)
473 rehash_threshold = 0.75;
475 hash_table_size ((size_t) ((double) size / hash_table_rehash_threshold (ht)) + 1);
477 compute_hash_table_derived_values (ht);
479 /* We leave room for one never-occupied sentinel hentry at the end. */
480 ht->hentries = xnew_array (hentry, ht->size + 1);
483 hentry *e, *sentinel;
484 for (e = ht->hentries, sentinel = e + ht->size; e <= sentinel; e++)
488 XSETHASH_TABLE (hash_table, ht);
490 if (weakness == HASH_TABLE_NON_WEAK)
491 ht->next_weak = Qunbound;
493 ht->next_weak = Vall_weak_hash_tables, Vall_weak_hash_tables = hash_table;
499 make_lisp_hash_table (size_t size,
500 enum hash_table_weakness weakness,
501 enum hash_table_test test)
503 return make_general_lisp_hash_table
504 (test, size, HASH_TABLE_DEFAULT_REHASH_SIZE, -1.0, weakness);
507 /* Pretty reading of hash tables.
509 Here we use the existing structures mechanism (which is,
510 unfortunately, pretty cumbersome) for validating and instantiating
511 the hash tables. The idea is that the side-effect of reading a
512 #s(hash-table PLIST) object is creation of a hash table with desired
513 properties, and that the hash table is returned. */
515 /* Validation functions: each keyword provides its own validation
516 function. The errors should maybe be continuable, but it is
517 unclear how this would cope with ERRB. */
519 hash_table_size_validate (Lisp_Object keyword, Lisp_Object value,
525 maybe_signal_error (Qwrong_type_argument, list2 (Qnatnump, value),
531 decode_hash_table_size (Lisp_Object obj)
533 return NILP (obj) ? HASH_TABLE_DEFAULT_SIZE : XINT (obj);
537 hash_table_weakness_validate (Lisp_Object keyword, Lisp_Object value,
540 if (EQ (value, Qnil)) return 1;
541 if (EQ (value, Qt)) return 1;
542 if (EQ (value, Qkey)) return 1;
543 if (EQ (value, Qvalue)) return 1;
545 /* Following values are obsolete as of 19990901 in xemacs-21.2 */
546 if (EQ (value, Qnon_weak)) return 1;
547 if (EQ (value, Qweak)) return 1;
548 if (EQ (value, Qkey_weak)) return 1;
549 if (EQ (value, Qvalue_weak)) return 1;
551 maybe_signal_simple_error ("Invalid hash table weakness",
552 value, Qhash_table, errb);
556 static enum hash_table_weakness
557 decode_hash_table_weakness (Lisp_Object obj)
559 if (EQ (obj, Qnil)) return HASH_TABLE_NON_WEAK;
560 if (EQ (obj, Qt)) return HASH_TABLE_WEAK;
561 if (EQ (obj, Qkey)) return HASH_TABLE_KEY_WEAK;
562 if (EQ (obj, Qvalue)) return HASH_TABLE_VALUE_WEAK;
564 /* Following values are obsolete as of 19990901 in xemacs-21.2 */
565 if (EQ (obj, Qnon_weak)) return HASH_TABLE_NON_WEAK;
566 if (EQ (obj, Qweak)) return HASH_TABLE_WEAK;
567 if (EQ (obj, Qkey_weak)) return HASH_TABLE_KEY_WEAK;
568 if (EQ (obj, Qvalue_weak)) return HASH_TABLE_VALUE_WEAK;
570 signal_simple_error ("Invalid hash table weakness", obj);
571 return HASH_TABLE_NON_WEAK; /* not reached */
575 hash_table_test_validate (Lisp_Object keyword, Lisp_Object value,
578 if (EQ (value, Qnil)) return 1;
579 if (EQ (value, Qeq)) return 1;
580 if (EQ (value, Qequal)) return 1;
581 if (EQ (value, Qeql)) return 1;
583 maybe_signal_simple_error ("Invalid hash table test",
584 value, Qhash_table, errb);
588 static enum hash_table_test
589 decode_hash_table_test (Lisp_Object obj)
591 if (EQ (obj, Qnil)) return HASH_TABLE_EQL;
592 if (EQ (obj, Qeq)) return HASH_TABLE_EQ;
593 if (EQ (obj, Qequal)) return HASH_TABLE_EQUAL;
594 if (EQ (obj, Qeql)) return HASH_TABLE_EQL;
596 signal_simple_error ("Invalid hash table test", obj);
597 return HASH_TABLE_EQ; /* not reached */
601 hash_table_rehash_size_validate (Lisp_Object keyword, Lisp_Object value,
606 maybe_signal_error (Qwrong_type_argument, list2 (Qfloatp, value),
612 double rehash_size = XFLOAT_DATA (value);
613 if (rehash_size <= 1.0)
615 maybe_signal_simple_error
616 ("Hash table rehash size must be greater than 1.0",
617 value, Qhash_table, errb);
626 decode_hash_table_rehash_size (Lisp_Object rehash_size)
628 return NILP (rehash_size) ? -1.0 : XFLOAT_DATA (rehash_size);
632 hash_table_rehash_threshold_validate (Lisp_Object keyword, Lisp_Object value,
637 maybe_signal_error (Qwrong_type_argument, list2 (Qfloatp, value),
643 double rehash_threshold = XFLOAT_DATA (value);
644 if (rehash_threshold <= 0.0 || rehash_threshold >= 1.0)
646 maybe_signal_simple_error
647 ("Hash table rehash threshold must be between 0.0 and 1.0",
648 value, Qhash_table, errb);
657 decode_hash_table_rehash_threshold (Lisp_Object rehash_threshold)
659 return NILP (rehash_threshold) ? -1.0 : XFLOAT_DATA (rehash_threshold);
663 hash_table_data_validate (Lisp_Object keyword, Lisp_Object value,
668 GET_EXTERNAL_LIST_LENGTH (value, len);
672 maybe_signal_simple_error
673 ("Hash table data must have alternating key/value pairs",
674 value, Qhash_table, errb);
680 /* The actual instantiation of a hash table. This does practically no
681 error checking, because it relies on the fact that the paranoid
682 functions above have error-checked everything to the last details.
683 If this assumption is wrong, we will get a crash immediately (with
684 error-checking compiled in), and we'll know if there is a bug in
685 the structure mechanism. So there. */
687 hash_table_instantiate (Lisp_Object plist)
689 Lisp_Object hash_table;
690 Lisp_Object test = Qnil;
691 Lisp_Object size = Qnil;
692 Lisp_Object rehash_size = Qnil;
693 Lisp_Object rehash_threshold = Qnil;
694 Lisp_Object weakness = Qnil;
695 Lisp_Object data = Qnil;
697 while (!NILP (plist))
699 Lisp_Object key, value;
700 key = XCAR (plist); plist = XCDR (plist);
701 value = XCAR (plist); plist = XCDR (plist);
703 if (EQ (key, Qtest)) test = value;
704 else if (EQ (key, Qsize)) size = value;
705 else if (EQ (key, Qrehash_size)) rehash_size = value;
706 else if (EQ (key, Qrehash_threshold)) rehash_threshold = value;
707 else if (EQ (key, Qweakness)) weakness = value;
708 else if (EQ (key, Qdata)) data = value;
709 else if (EQ (key, Qtype))/*obsolete*/ weakness = value;
714 /* Create the hash table. */
715 hash_table = make_general_lisp_hash_table
716 (decode_hash_table_test (test),
717 decode_hash_table_size (size),
718 decode_hash_table_rehash_size (rehash_size),
719 decode_hash_table_rehash_threshold (rehash_threshold),
720 decode_hash_table_weakness (weakness));
722 /* I'm not sure whether this can GC, but better safe than sorry. */
727 /* And fill it with data. */
730 Lisp_Object key, value;
731 key = XCAR (data); data = XCDR (data);
732 value = XCAR (data); data = XCDR (data);
733 Fputhash (key, value, hash_table);
742 structure_type_create_hash_table_structure_name (Lisp_Object structure_name)
744 struct structure_type *st;
746 st = define_structure_type (structure_name, 0, hash_table_instantiate);
747 define_structure_type_keyword (st, Qtest, hash_table_test_validate);
748 define_structure_type_keyword (st, Qsize, hash_table_size_validate);
749 define_structure_type_keyword (st, Qrehash_size, hash_table_rehash_size_validate);
750 define_structure_type_keyword (st, Qrehash_threshold, hash_table_rehash_threshold_validate);
751 define_structure_type_keyword (st, Qweakness, hash_table_weakness_validate);
752 define_structure_type_keyword (st, Qdata, hash_table_data_validate);
754 /* obsolete as of 19990901 in xemacs-21.2 */
755 define_structure_type_keyword (st, Qtype, hash_table_weakness_validate);
758 /* Create a built-in Lisp structure type named `hash-table'.
759 We make #s(hashtable ...) equivalent to #s(hash-table ...),
760 for backward compatibility.
761 This is called from emacs.c. */
763 structure_type_create_hash_table (void)
765 structure_type_create_hash_table_structure_name (Qhash_table);
766 structure_type_create_hash_table_structure_name (Qhashtable); /* compat */
770 /************************************************************************/
771 /* Definition of Lisp-visible methods */
772 /************************************************************************/
774 DEFUN ("hash-table-p", Fhash_table_p, 1, 1, 0, /*
775 Return t if OBJECT is a hash table, else nil.
779 return HASH_TABLEP (object) ? Qt : Qnil;
782 DEFUN ("make-hash-table", Fmake_hash_table, 0, MANY, 0, /*
783 Return a new empty hash table object.
784 Use Common Lisp style keywords to specify hash table properties.
785 (make-hash-table &key test size rehash-size rehash-threshold weakness)
787 Keyword :test can be `eq', `eql' (default) or `equal'.
788 Comparison between keys is done using this function.
789 If speed is important, consider using `eq'.
790 When storing strings in the hash table, you will likely need to use `equal'.
792 Keyword :size specifies the number of keys likely to be inserted.
793 This number of entries can be inserted without enlarging the hash table.
795 Keyword :rehash-size must be a float greater than 1.0, and specifies
796 the factor by which to increase the size of the hash table when enlarging.
798 Keyword :rehash-threshold must be a float between 0.0 and 1.0,
799 and specifies the load factor of the hash table which triggers enlarging.
801 Non-standard keyword :weakness can be `nil' (default), `t', `key' or `value'.
803 A weak hash table is one whose pointers do not count as GC referents:
804 for any key-value pair in the hash table, if the only remaining pointer
805 to either the key or the value is in a weak hash table, then the pair
806 will be removed from the hash table, and the key and value collected.
807 A non-weak hash table (or any other pointer) would prevent the object
808 from being collected.
810 A key-weak hash table is similar to a fully-weak hash table except that
811 a key-value pair will be removed only if the key remains unmarked
812 outside of weak hash tables. The pair will remain in the hash table if
813 the key is pointed to by something other than a weak hash table, even
816 A value-weak hash table is similar to a fully-weak hash table except
817 that a key-value pair will be removed only if the value remains
818 unmarked outside of weak hash tables. The pair will remain in the
819 hash table if the value is pointed to by something other than a weak
820 hash table, even if the key is not.
822 (int nargs, Lisp_Object *args))
825 Lisp_Object test = Qnil;
826 Lisp_Object size = Qnil;
827 Lisp_Object rehash_size = Qnil;
828 Lisp_Object rehash_threshold = Qnil;
829 Lisp_Object weakness = Qnil;
831 while (i + 1 < nargs)
833 Lisp_Object keyword = args[i++];
834 Lisp_Object value = args[i++];
836 if (EQ (keyword, Q_test)) test = value;
837 else if (EQ (keyword, Q_size)) size = value;
838 else if (EQ (keyword, Q_rehash_size)) rehash_size = value;
839 else if (EQ (keyword, Q_rehash_threshold)) rehash_threshold = value;
840 else if (EQ (keyword, Q_weakness)) weakness = value;
841 else if (EQ (keyword, Q_type))/*obsolete*/ weakness = value;
842 else signal_simple_error ("Invalid hash table property keyword", keyword);
846 signal_simple_error ("Hash table property requires a value", args[i]);
848 #define VALIDATE_VAR(var) \
849 if (!NILP (var)) hash_table_##var##_validate (Q##var, var, ERROR_ME);
853 VALIDATE_VAR (rehash_size);
854 VALIDATE_VAR (rehash_threshold);
855 VALIDATE_VAR (weakness);
857 return make_general_lisp_hash_table
858 (decode_hash_table_test (test),
859 decode_hash_table_size (size),
860 decode_hash_table_rehash_size (rehash_size),
861 decode_hash_table_rehash_threshold (rehash_threshold),
862 decode_hash_table_weakness (weakness));
865 DEFUN ("copy-hash-table", Fcopy_hash_table, 1, 1, 0, /*
866 Return a new hash table containing the same keys and values as HASH-TABLE.
867 The keys and values will not themselves be copied.
871 CONST Lisp_Hash_Table *ht_old = xhash_table (hash_table);
872 Lisp_Hash_Table *ht = alloc_lcrecord_type (Lisp_Hash_Table, &lrecord_hash_table);
874 copy_lcrecord (ht, ht_old);
876 ht->hentries = xnew_array (hentry, ht_old->size + 1);
877 memcpy (ht->hentries, ht_old->hentries, (ht_old->size + 1) * sizeof (hentry));
879 XSETHASH_TABLE (hash_table, ht);
881 if (! EQ (ht->next_weak, Qunbound))
883 ht->next_weak = Vall_weak_hash_tables;
884 Vall_weak_hash_tables = hash_table;
891 resize_hash_table (Lisp_Hash_Table *ht, size_t new_size)
893 hentry *old_entries, *new_entries, *old_sentinel, *new_sentinel, *e;
899 old_entries = ht->hentries;
901 ht->hentries = xnew_array (hentry, new_size + 1);
902 new_entries = ht->hentries;
904 old_sentinel = old_entries + old_size;
905 new_sentinel = new_entries + new_size;
907 for (e = new_entries; e <= new_sentinel; e++)
910 compute_hash_table_derived_values (ht);
912 for (e = old_entries; e < old_sentinel; e++)
913 if (!HENTRY_CLEAR_P (e))
915 hentry *probe = new_entries + HASH_CODE (e->key, ht);
916 LINEAR_PROBING_LOOP (probe, new_entries, new_size)
921 if (!DUMPEDP (old_entries))
926 reorganize_hash_table (Lisp_Hash_Table *ht)
928 resize_hash_table (ht, ht->size);
932 enlarge_hash_table (Lisp_Hash_Table *ht)
935 hash_table_size ((size_t) ((double) ht->size * ht->rehash_size));
936 resize_hash_table (ht, new_size);
940 find_hentry (Lisp_Object key, CONST Lisp_Hash_Table *ht)
942 hash_table_test_function_t test_function = ht->test_function;
943 hentry *entries = ht->hentries;
944 hentry *probe = entries + HASH_CODE (key, ht);
946 LINEAR_PROBING_LOOP (probe, entries, ht->size)
947 if (KEYS_EQUAL_P (probe->key, key, test_function))
953 DEFUN ("gethash", Fgethash, 2, 3, 0, /*
954 Find hash value for KEY in HASH-TABLE.
955 If there is no corresponding value, return DEFAULT (which defaults to nil).
957 (key, hash_table, default_))
959 CONST Lisp_Hash_Table *ht = xhash_table (hash_table);
960 hentry *e = find_hentry (key, ht);
962 return HENTRY_CLEAR_P (e) ? default_ : e->value;
965 DEFUN ("puthash", Fputhash, 3, 3, 0, /*
966 Hash KEY to VALUE in HASH-TABLE.
968 (key, value, hash_table))
970 Lisp_Hash_Table *ht = xhash_table (hash_table);
971 hentry *e = find_hentry (key, ht);
973 if (!HENTRY_CLEAR_P (e))
974 return e->value = value;
979 if (++ht->count >= ht->rehash_count)
980 enlarge_hash_table (ht);
985 /* Remove hentry pointed at by PROBE.
986 Subsequent entries are removed and reinserted.
987 We don't use tombstones - too wasteful. */
989 remhash_1 (Lisp_Hash_Table *ht, hentry *entries, hentry *probe)
991 size_t size = ht->size;
992 CLEAR_HENTRY (probe);
996 LINEAR_PROBING_LOOP (probe, entries, size)
998 Lisp_Object key = probe->key;
999 hentry *probe2 = entries + HASH_CODE (key, ht);
1000 LINEAR_PROBING_LOOP (probe2, entries, size)
1001 if (EQ (probe2->key, key))
1002 /* hentry at probe doesn't need to move. */
1003 goto continue_outer_loop;
1004 /* Move hentry from probe to new home at probe2. */
1006 CLEAR_HENTRY (probe);
1007 continue_outer_loop: continue;
1011 DEFUN ("remhash", Fremhash, 2, 2, 0, /*
1012 Remove the entry for KEY from HASH-TABLE.
1013 Do nothing if there is no entry for KEY in HASH-TABLE.
1017 Lisp_Hash_Table *ht = xhash_table (hash_table);
1018 hentry *e = find_hentry (key, ht);
1020 if (HENTRY_CLEAR_P (e))
1023 remhash_1 (ht, ht->hentries, e);
1027 DEFUN ("clrhash", Fclrhash, 1, 1, 0, /*
1028 Remove all entries from HASH-TABLE, leaving it empty.
1032 Lisp_Hash_Table *ht = xhash_table (hash_table);
1033 hentry *e, *sentinel;
1035 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1042 /************************************************************************/
1043 /* Accessor Functions */
1044 /************************************************************************/
1046 DEFUN ("hash-table-count", Fhash_table_count, 1, 1, 0, /*
1047 Return the number of entries in HASH-TABLE.
1051 return make_int (xhash_table (hash_table)->count);
1054 DEFUN ("hash-table-test", Fhash_table_test, 1, 1, 0, /*
1055 Return the test function of HASH-TABLE.
1056 This can be one of `eq', `eql' or `equal'.
1060 hash_table_test_function_t fun = xhash_table (hash_table)->test_function;
1062 return (fun == lisp_object_eql_equal ? Qeql :
1063 fun == lisp_object_equal_equal ? Qequal :
1067 DEFUN ("hash-table-size", Fhash_table_size, 1, 1, 0, /*
1068 Return the size of HASH-TABLE.
1069 This is the current number of slots in HASH-TABLE, whether occupied or not.
1073 return make_int (xhash_table (hash_table)->size);
1076 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size, 1, 1, 0, /*
1077 Return the current rehash size of HASH-TABLE.
1078 This is a float greater than 1.0; the factor by which HASH-TABLE
1079 is enlarged when the rehash threshold is exceeded.
1083 return make_float (xhash_table (hash_table)->rehash_size);
1086 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold, 1, 1, 0, /*
1087 Return the current rehash threshold of HASH-TABLE.
1088 This is a float between 0.0 and 1.0; the maximum `load factor' of HASH-TABLE,
1089 beyond which the HASH-TABLE is enlarged by rehashing.
1093 return make_float (hash_table_rehash_threshold (xhash_table (hash_table)));
1096 DEFUN ("hash-table-weakness", Fhash_table_weakness, 1, 1, 0, /*
1097 Return the weakness of HASH-TABLE.
1098 This can be one of `nil', `t', `key' or `value'.
1102 switch (xhash_table (hash_table)->weakness)
1104 case HASH_TABLE_WEAK: return Qt;
1105 case HASH_TABLE_KEY_WEAK: return Qkey;
1106 case HASH_TABLE_VALUE_WEAK: return Qvalue;
1107 default: return Qnil;
1111 /* obsolete as of 19990901 in xemacs-21.2 */
1112 DEFUN ("hash-table-type", Fhash_table_type, 1, 1, 0, /*
1113 Return the type of HASH-TABLE.
1114 This can be one of `non-weak', `weak', `key-weak' or `value-weak'.
1118 switch (xhash_table (hash_table)->weakness)
1120 case HASH_TABLE_WEAK: return Qweak;
1121 case HASH_TABLE_KEY_WEAK: return Qkey_weak;
1122 case HASH_TABLE_VALUE_WEAK: return Qvalue_weak;
1123 default: return Qnon_weak;
1127 /************************************************************************/
1128 /* Mapping Functions */
1129 /************************************************************************/
1130 DEFUN ("maphash", Fmaphash, 2, 2, 0, /*
1131 Map FUNCTION over entries in HASH-TABLE, calling it with two args,
1132 each key and value in HASH-TABLE.
1134 FUNCTION may not modify HASH-TABLE, with the one exception that FUNCTION
1135 may remhash or puthash the entry currently being processed by FUNCTION.
1137 (function, hash_table))
1139 CONST Lisp_Hash_Table *ht = xhash_table (hash_table);
1140 CONST hentry *e, *sentinel;
1142 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1143 if (!HENTRY_CLEAR_P (e))
1145 Lisp_Object args[3], key;
1151 Ffuncall (countof (args), args);
1152 /* Has FUNCTION done a remhash? */
1153 if (!EQ (key, e->key) && !HENTRY_CLEAR_P (e))
1160 /* Map *C* function FUNCTION over the elements of a lisp hash table. */
1162 elisp_maphash (maphash_function_t function,
1163 Lisp_Object hash_table, void *extra_arg)
1165 CONST Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1166 CONST hentry *e, *sentinel;
1168 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1169 if (!HENTRY_CLEAR_P (e))
1174 if (function (key, e->value, extra_arg))
1176 /* Has FUNCTION done a remhash? */
1177 if (!EQ (key, e->key) && !HENTRY_CLEAR_P (e))
1182 /* Remove all elements of a lisp hash table satisfying *C* predicate PREDICATE. */
1184 elisp_map_remhash (maphash_function_t predicate,
1185 Lisp_Object hash_table, void *extra_arg)
1187 Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1188 hentry *e, *entries, *sentinel;
1190 for (e = entries = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1191 if (!HENTRY_CLEAR_P (e))
1194 if (predicate (e->key, e->value, extra_arg))
1196 remhash_1 (ht, entries, e);
1197 if (!HENTRY_CLEAR_P (e))
1204 /************************************************************************/
1205 /* garbage collecting weak hash tables */
1206 /************************************************************************/
1208 /* Complete the marking for semi-weak hash tables. */
1210 finish_marking_weak_hash_tables (void)
1212 Lisp_Object hash_table;
1215 for (hash_table = Vall_weak_hash_tables;
1217 hash_table = XHASH_TABLE (hash_table)->next_weak)
1219 CONST Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1220 CONST hentry *e = ht->hentries;
1221 CONST hentry *sentinel = e + ht->size;
1223 if (! marked_p (hash_table))
1224 /* The hash table is probably garbage. Ignore it. */
1227 /* Now, scan over all the pairs. For all pairs that are
1228 half-marked, we may need to mark the other half if we're
1229 keeping this pair. */
1230 #define MARK_OBJ(obj) \
1231 do { if (!marked_p (obj)) mark_object (obj), did_mark = 1; } while (0)
1233 switch (ht->weakness)
1235 case HASH_TABLE_KEY_WEAK:
1236 for (; e < sentinel; e++)
1237 if (!HENTRY_CLEAR_P (e))
1238 if (marked_p (e->key))
1239 MARK_OBJ (e->value);
1242 case HASH_TABLE_VALUE_WEAK:
1243 for (; e < sentinel; e++)
1244 if (!HENTRY_CLEAR_P (e))
1245 if (marked_p (e->value))
1249 case HASH_TABLE_KEY_CAR_WEAK:
1250 for (; e < sentinel; e++)
1251 if (!HENTRY_CLEAR_P (e))
1252 if (!CONSP (e->key) || marked_p (XCAR (e->key)))
1255 MARK_OBJ (e->value);
1259 case HASH_TABLE_VALUE_CAR_WEAK:
1260 for (; e < sentinel; e++)
1261 if (!HENTRY_CLEAR_P (e))
1262 if (!CONSP (e->value) || marked_p (XCAR (e->value)))
1265 MARK_OBJ (e->value);
1278 prune_weak_hash_tables (void)
1280 Lisp_Object hash_table, prev = Qnil;
1281 for (hash_table = Vall_weak_hash_tables;
1283 hash_table = XHASH_TABLE (hash_table)->next_weak)
1285 if (! marked_p (hash_table))
1287 /* This hash table itself is garbage. Remove it from the list. */
1289 Vall_weak_hash_tables = XHASH_TABLE (hash_table)->next_weak;
1291 XHASH_TABLE (prev)->next_weak = XHASH_TABLE (hash_table)->next_weak;
1295 /* Now, scan over all the pairs. Remove all of the pairs
1296 in which the key or value, or both, is unmarked
1297 (depending on the weakness of the hash table). */
1298 Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1299 hentry *entries = ht->hentries;
1300 hentry *sentinel = entries + ht->size;
1303 for (e = entries; e < sentinel; e++)
1304 if (!HENTRY_CLEAR_P (e))
1307 if (!marked_p (e->key) || !marked_p (e->value))
1309 remhash_1 (ht, entries, e);
1310 if (!HENTRY_CLEAR_P (e))
1320 /* Return a hash value for an array of Lisp_Objects of size SIZE. */
1323 internal_array_hash (Lisp_Object *arr, int size, int depth)
1326 unsigned long hash = 0;
1330 for (i = 0; i < size; i++)
1331 hash = HASH2 (hash, internal_hash (arr[i], depth + 1));
1335 /* just pick five elements scattered throughout the array.
1336 A slightly better approach would be to offset by some
1337 noise factor from the points chosen below. */
1338 for (i = 0; i < 5; i++)
1339 hash = HASH2 (hash, internal_hash (arr[i*size/5], depth + 1));
1344 /* Return a hash value for a Lisp_Object. This is for use when hashing
1345 objects with the comparison being `equal' (for `eq', you can just
1346 use the Lisp_Object itself as the hash value). You need to make a
1347 tradeoff between the speed of the hash function and how good the
1348 hashing is. In particular, the hash function needs to be FAST,
1349 so you can't just traipse down the whole tree hashing everything
1350 together. Most of the time, objects will differ in the first
1351 few elements you hash. Thus, we only go to a short depth (5)
1352 and only hash at most 5 elements out of a vector. Theoretically
1353 we could still take 5^5 time (a big big number) to compute a
1354 hash, but practically this won't ever happen. */
1357 internal_hash (Lisp_Object obj, int depth)
1363 /* no point in worrying about tail recursion, since we're not
1365 return HASH2 (internal_hash (XCAR (obj), depth + 1),
1366 internal_hash (XCDR (obj), depth + 1));
1370 return hash_string (XSTRING_DATA (obj), XSTRING_LENGTH (obj));
1374 return HASH2 (XVECTOR_LENGTH (obj),
1375 internal_array_hash (XVECTOR_DATA (obj),
1376 XVECTOR_LENGTH (obj),
1381 CONST struct lrecord_implementation
1382 *imp = XRECORD_LHEADER_IMPLEMENTATION (obj);
1384 return imp->hash (obj, depth);
1387 return LISP_HASH (obj);
1390 DEFUN ("sxhash", Fsxhash, 1, 1, 0, /*
1391 Return a hash value for OBJECT.
1392 (equal obj1 obj2) implies (= (sxhash obj1) (sxhash obj2)).
1396 return make_int (internal_hash (object, 0));
1400 xxDEFUN ("internal-hash-value", Finternal_hash_value, 1, 1, 0, /*
1401 Hash value of OBJECT. For debugging.
1402 The value is returned as (HIGH . LOW).
1406 /* This function is pretty 32bit-centric. */
1407 unsigned long hash = internal_hash (object, 0);
1408 return Fcons (hash >> 16, hash & 0xffff);
1413 /************************************************************************/
1414 /* initialization */
1415 /************************************************************************/
1418 syms_of_elhash (void)
1420 DEFSUBR (Fhash_table_p);
1421 DEFSUBR (Fmake_hash_table);
1422 DEFSUBR (Fcopy_hash_table);
1428 DEFSUBR (Fhash_table_count);
1429 DEFSUBR (Fhash_table_test);
1430 DEFSUBR (Fhash_table_size);
1431 DEFSUBR (Fhash_table_rehash_size);
1432 DEFSUBR (Fhash_table_rehash_threshold);
1433 DEFSUBR (Fhash_table_weakness);
1434 DEFSUBR (Fhash_table_type); /* obsolete */
1437 DEFSUBR (Finternal_hash_value);
1440 defsymbol (&Qhash_tablep, "hash-table-p");
1441 defsymbol (&Qhash_table, "hash-table");
1442 defsymbol (&Qhashtable, "hashtable");
1443 defsymbol (&Qweakness, "weakness");
1444 defsymbol (&Qvalue, "value");
1445 defsymbol (&Qrehash_size, "rehash-size");
1446 defsymbol (&Qrehash_threshold, "rehash-threshold");
1448 defsymbol (&Qweak, "weak"); /* obsolete */
1449 defsymbol (&Qkey_weak, "key-weak"); /* obsolete */
1450 defsymbol (&Qvalue_weak, "value-weak"); /* obsolete */
1451 defsymbol (&Qnon_weak, "non-weak"); /* obsolete */
1453 defkeyword (&Q_test, ":test");
1454 defkeyword (&Q_size, ":size");
1455 defkeyword (&Q_rehash_size, ":rehash-size");
1456 defkeyword (&Q_rehash_threshold, ":rehash-threshold");
1457 defkeyword (&Q_weakness, ":weakness");
1458 defkeyword (&Q_type, ":type"); /* obsolete */
1462 vars_of_elhash (void)
1464 /* This must NOT be staticpro'd */
1465 Vall_weak_hash_tables = Qnil;
1466 pdump_wire_list (&Vall_weak_hash_tables);