1 /* Implementation of the hash table lisp object type.
2 Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
3 Copyright (C) 1995, 1996 Ben Wing.
4 Copyright (C) 1997 Free Software Foundation, Inc.
6 This file is part of XEmacs.
8 XEmacs is free software; you can redistribute it and/or modify it
9 under the terms of the GNU General Public License as published by the
10 Free Software Foundation; either version 2, or (at your option) any
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
14 ANY WARRANTY; without even the implied warranty of MERCNTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with XEmacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA. */
23 /* Synched up with: Not in FSF. */
30 Lisp_Object Qhash_tablep;
31 static Lisp_Object Qhashtable, Qhash_table;
32 static Lisp_Object Qweakness, Qvalue;
33 static Lisp_Object Vall_weak_hash_tables;
34 static Lisp_Object Qrehash_size, Qrehash_threshold;
35 static Lisp_Object Q_size, Q_test, Q_weakness, Q_rehash_size, Q_rehash_threshold;
37 /* obsolete as of 19990901 in xemacs-21.2 */
38 static Lisp_Object Qweak, Qkey_weak, Qvalue_weak, Qnon_weak, Q_type;
46 struct Lisp_Hash_Table
48 struct lcrecord_header header;
53 double rehash_threshold;
55 hash_table_hash_function_t hash_function;
56 hash_table_test_function_t test_function;
58 enum hash_table_weakness weakness;
59 Lisp_Object next_weak; /* Used to chain together all of the weak
60 hash tables. Don't mark through this. */
63 #define HENTRY_CLEAR_P(hentry) ((*(EMACS_UINT*)(&((hentry)->key))) == 0)
64 #define CLEAR_HENTRY(hentry) \
65 ((*(EMACS_UINT*)(&((hentry)->key))) = 0, \
66 (*(EMACS_UINT*)(&((hentry)->value))) = 0)
68 #define HASH_TABLE_DEFAULT_SIZE 16
69 #define HASH_TABLE_DEFAULT_REHASH_SIZE 1.3
70 #define HASH_TABLE_MIN_SIZE 10
72 #define HASH_CODE(key, ht) \
73 ((((ht)->hash_function ? (ht)->hash_function (key) : LISP_HASH (key)) \
74 * (ht)->golden_ratio) \
77 #define KEYS_EQUAL_P(key1, key2, testfun) \
78 (EQ (key1, key2) || ((testfun) && (testfun) (key1, key2)))
80 #define LINEAR_PROBING_LOOP(probe, entries, size) \
82 !HENTRY_CLEAR_P (probe) || \
83 (probe == entries + size ? \
84 (probe = entries, !HENTRY_CLEAR_P (probe)) : 0); \
87 #ifndef ERROR_CHECK_HASH_TABLE
88 # ifdef ERROR_CHECK_TYPECHECK
89 # define ERROR_CHECK_HASH_TABLE 1
91 # define ERROR_CHECK_HASH_TABLE 0
95 #if ERROR_CHECK_HASH_TABLE
97 check_hash_table_invariants (Lisp_Hash_Table *ht)
99 assert (ht->count < ht->size);
100 assert (ht->count <= ht->rehash_count);
101 assert (ht->rehash_count < ht->size);
102 assert ((double) ht->count * ht->rehash_threshold - 1 <= (double) ht->rehash_count);
103 assert (HENTRY_CLEAR_P (ht->hentries + ht->size));
106 #define check_hash_table_invariants(ht)
109 /* We use linear probing instead of double hashing, despite its lack
110 of blessing by Knuth and company, because, as a result of the
111 increasing discrepancy between CPU speeds and memory speeds, cache
112 behavior is becoming increasingly important, e.g:
114 For a trivial loop, the penalty for non-sequential access of an array is:
115 - a factor of 3-4 on Pentium Pro 200 Mhz
116 - a factor of 10 on Ultrasparc 300 Mhz */
118 /* Return a suitable size for a hash table, with at least SIZE slots. */
120 hash_table_size (size_t requested_size)
122 /* Return some prime near, but greater than or equal to, SIZE.
123 Decades from the time of writing, someone will have a system large
124 enough that the list below will be too short... */
125 static const size_t primes [] =
127 19, 29, 41, 59, 79, 107, 149, 197, 263, 347, 457, 599, 787, 1031,
128 1361, 1777, 2333, 3037, 3967, 5167, 6719, 8737, 11369, 14783,
129 19219, 24989, 32491, 42257, 54941, 71429, 92861, 120721, 156941,
130 204047, 265271, 344857, 448321, 582821, 757693, 985003, 1280519,
131 1664681, 2164111, 2813353, 3657361, 4754591, 6180989, 8035301,
132 10445899, 13579681, 17653589, 22949669, 29834603, 38784989,
133 50420551, 65546729, 85210757, 110774011, 144006217, 187208107,
134 243370577, 316381771, 411296309, 534685237, 695090819, 903618083,
135 1174703521, 1527114613, 1985248999, 2580823717UL, 3355070839UL
137 /* We've heard of binary search. */
139 for (low = 0, high = countof (primes) - 1; high - low > 1;)
141 /* Loop Invariant: size < primes [high] */
142 int mid = (low + high) / 2;
143 if (primes [mid] < requested_size)
148 return primes [high];
152 #if 0 /* I don't think these are needed any more.
153 If using the general lisp_object_equal_*() functions
154 causes efficiency problems, these can be resurrected. --ben */
155 /* equality and hash functions for Lisp strings */
157 lisp_string_equal (Lisp_Object str1, Lisp_Object str2)
159 /* This is wrong anyway. You can't use strcmp() on Lisp strings,
160 because they can contain zero characters. */
161 return !strcmp ((char *) XSTRING_DATA (str1), (char *) XSTRING_DATA (str2));
165 lisp_string_hash (Lisp_Object obj)
167 return hash_string (XSTRING_DATA (str), XSTRING_LENGTH (str));
173 lisp_object_eql_equal (Lisp_Object obj1, Lisp_Object obj2)
175 return EQ (obj1, obj2) || (FLOATP (obj1) && internal_equal (obj1, obj2, 0));
179 lisp_object_eql_hash (Lisp_Object obj)
181 return FLOATP (obj) ? internal_hash (obj, 0) : LISP_HASH (obj);
185 lisp_object_equal_equal (Lisp_Object obj1, Lisp_Object obj2)
187 return internal_equal (obj1, obj2, 0);
191 lisp_object_equal_hash (Lisp_Object obj)
193 return internal_hash (obj, 0);
198 mark_hash_table (Lisp_Object obj)
200 Lisp_Hash_Table *ht = XHASH_TABLE (obj);
202 /* If the hash table is weak, we don't want to mark the keys and
203 values (we scan over them after everything else has been marked,
204 and mark or remove them as necessary). */
205 if (ht->weakness == HASH_TABLE_NON_WEAK)
207 hentry *e, *sentinel;
209 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
210 if (!HENTRY_CLEAR_P (e))
212 mark_object (e->key);
213 mark_object (e->value);
219 /* Equality of hash tables. Two hash tables are equal when they are of
220 the same weakness and test function, they have the same number of
221 elements, and for each key in the hash table, the values are `equal'.
223 This is similar to Common Lisp `equalp' of hash tables, with the
224 difference that CL requires the keys to be compared with the test
225 function, which we don't do. Doing that would require consing, and
226 consing is a bad idea in `equal'. Anyway, our method should provide
227 the same result -- if the keys are not equal according to the test
228 function, then Fgethash() in hash_table_equal_mapper() will fail. */
230 hash_table_equal (Lisp_Object hash_table1, Lisp_Object hash_table2, int depth)
232 Lisp_Hash_Table *ht1 = XHASH_TABLE (hash_table1);
233 Lisp_Hash_Table *ht2 = XHASH_TABLE (hash_table2);
234 hentry *e, *sentinel;
236 if ((ht1->test_function != ht2->test_function) ||
237 (ht1->weakness != ht2->weakness) ||
238 (ht1->count != ht2->count))
243 for (e = ht1->hentries, sentinel = e + ht1->size; e < sentinel; e++)
244 if (!HENTRY_CLEAR_P (e))
245 /* Look up the key in the other hash table, and compare the values. */
247 Lisp_Object value_in_other = Fgethash (e->key, hash_table2, Qunbound);
248 if (UNBOUNDP (value_in_other) ||
249 !internal_equal (e->value, value_in_other, depth))
250 return 0; /* Give up */
256 /* This is not a great hash function, but it _is_ correct and fast.
257 Examining all entries is too expensive, and examining a random
258 subset does not yield a correct hash function. */
260 hash_table_hash (Lisp_Object hash_table, int depth)
262 return XHASH_TABLE (hash_table)->count;
266 /* Printing hash tables.
268 This is non-trivial, because we use a readable structure-style
269 syntax for hash tables. This means that a typical hash table will be
270 readably printed in the form of:
272 #s(hash-table size 2 data (key1 value1 key2 value2))
274 The supported hash table structure keywords and their values are:
275 `test' (eql (or nil), eq or equal)
276 `size' (a natnum or nil)
277 `rehash-size' (a float)
278 `rehash-threshold' (a float)
279 `weakness' (nil, t, key or value)
282 If `print-readably' is nil, then a simpler syntax is used, for example
284 #<hash-table size 2/13 data (key1 value1 key2 value2) 0x874d>
286 The data is truncated to four pairs, and the rest is shown with
287 `...'. This printer does not cons. */
290 /* Print the data of the hash table. This maps through a Lisp
291 hash table and prints key/value pairs using PRINTCHARFUN. */
293 print_hash_table_data (Lisp_Hash_Table *ht, Lisp_Object printcharfun)
296 hentry *e, *sentinel;
298 write_c_string (" data (", printcharfun);
300 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
301 if (!HENTRY_CLEAR_P (e))
304 write_c_string (" ", printcharfun);
305 if (!print_readably && count > 3)
307 write_c_string ("...", printcharfun);
310 print_internal (e->key, printcharfun, 1);
311 write_c_string (" ", printcharfun);
312 print_internal (e->value, printcharfun, 1);
316 write_c_string (")", printcharfun);
320 print_hash_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
322 Lisp_Hash_Table *ht = XHASH_TABLE (obj);
325 write_c_string (print_readably ? "#s(hash-table" : "#<hash-table",
328 /* These checks have a kludgy look to them, but they are safe.
329 Due to nature of hashing, you cannot use arbitrary
330 test functions anyway. */
331 if (!ht->test_function)
332 write_c_string (" test eq", printcharfun);
333 else if (ht->test_function == lisp_object_equal_equal)
334 write_c_string (" test equal", printcharfun);
335 else if (ht->test_function == lisp_object_eql_equal)
340 if (ht->count || !print_readably)
343 sprintf (buf, " size %lu", (unsigned long) ht->count);
345 sprintf (buf, " size %lu/%lu",
346 (unsigned long) ht->count,
347 (unsigned long) ht->size);
348 write_c_string (buf, printcharfun);
351 if (ht->weakness != HASH_TABLE_NON_WEAK)
353 sprintf (buf, " weakness %s",
354 (ht->weakness == HASH_TABLE_WEAK ? "t" :
355 ht->weakness == HASH_TABLE_KEY_WEAK ? "key" :
356 ht->weakness == HASH_TABLE_VALUE_WEAK ? "value" :
357 "you-d-better-not-see-this"));
358 write_c_string (buf, printcharfun);
362 print_hash_table_data (ht, printcharfun);
365 write_c_string (")", printcharfun);
368 sprintf (buf, " 0x%x>", ht->header.uid);
369 write_c_string (buf, printcharfun);
374 finalize_hash_table (void *header, int for_disksave)
378 Lisp_Hash_Table *ht = (Lisp_Hash_Table *) header;
380 xfree (ht->hentries);
385 static const struct lrecord_description hentry_description_1[] = {
386 { XD_LISP_OBJECT, offsetof (hentry, key) },
387 { XD_LISP_OBJECT, offsetof (hentry, value) },
391 static const struct struct_description hentry_description = {
396 const struct lrecord_description hash_table_description[] = {
397 { XD_SIZE_T, offsetof (Lisp_Hash_Table, size) },
398 { XD_STRUCT_PTR, offsetof (Lisp_Hash_Table, hentries), XD_INDIRECT(0, 1), &hentry_description },
399 { XD_LO_LINK, offsetof (Lisp_Hash_Table, next_weak) },
403 DEFINE_LRECORD_IMPLEMENTATION ("hash-table", hash_table,
404 mark_hash_table, print_hash_table,
406 hash_table_equal, hash_table_hash,
407 hash_table_description,
410 static Lisp_Hash_Table *
411 xhash_table (Lisp_Object hash_table)
414 CHECK_HASH_TABLE (hash_table);
415 check_hash_table_invariants (XHASH_TABLE (hash_table));
416 return XHASH_TABLE (hash_table);
420 /************************************************************************/
421 /* Creation of Hash Tables */
422 /************************************************************************/
424 /* Creation of hash tables, without error-checking. */
426 compute_hash_table_derived_values (Lisp_Hash_Table *ht)
428 ht->rehash_count = (size_t)
429 ((double) ht->size * ht->rehash_threshold);
430 ht->golden_ratio = (size_t)
431 ((double) ht->size * (.6180339887 / (double) sizeof (Lisp_Object)));
435 make_general_lisp_hash_table (enum hash_table_test test,
438 double rehash_threshold,
439 enum hash_table_weakness weakness)
441 Lisp_Object hash_table;
442 Lisp_Hash_Table *ht = alloc_lcrecord_type (Lisp_Hash_Table, &lrecord_hash_table);
447 ht->test_function = 0;
448 ht->hash_function = 0;
452 ht->test_function = lisp_object_eql_equal;
453 ht->hash_function = lisp_object_eql_hash;
456 case HASH_TABLE_EQUAL:
457 ht->test_function = lisp_object_equal_equal;
458 ht->hash_function = lisp_object_equal_hash;
465 ht->weakness = weakness;
468 rehash_size > 1.0 ? rehash_size : HASH_TABLE_DEFAULT_REHASH_SIZE;
470 ht->rehash_threshold =
471 rehash_threshold > 0.0 ? rehash_threshold :
472 size > 4096 && !ht->test_function ? 0.7 : 0.6;
474 if (size < HASH_TABLE_MIN_SIZE)
475 size = HASH_TABLE_MIN_SIZE;
476 ht->size = hash_table_size ((size_t) (((double) size / ht->rehash_threshold)
480 compute_hash_table_derived_values (ht);
482 /* We leave room for one never-occupied sentinel hentry at the end. */
483 ht->hentries = xnew_array (hentry, ht->size + 1);
486 hentry *e, *sentinel;
487 for (e = ht->hentries, sentinel = e + ht->size; e <= sentinel; e++)
491 XSETHASH_TABLE (hash_table, ht);
493 if (weakness == HASH_TABLE_NON_WEAK)
494 ht->next_weak = Qunbound;
496 ht->next_weak = Vall_weak_hash_tables, Vall_weak_hash_tables = hash_table;
502 make_lisp_hash_table (size_t size,
503 enum hash_table_weakness weakness,
504 enum hash_table_test test)
506 return make_general_lisp_hash_table (test, size, -1.0, -1.0, weakness);
509 /* Pretty reading of hash tables.
511 Here we use the existing structures mechanism (which is,
512 unfortunately, pretty cumbersome) for validating and instantiating
513 the hash tables. The idea is that the side-effect of reading a
514 #s(hash-table PLIST) object is creation of a hash table with desired
515 properties, and that the hash table is returned. */
517 /* Validation functions: each keyword provides its own validation
518 function. The errors should maybe be continuable, but it is
519 unclear how this would cope with ERRB. */
521 hash_table_size_validate (Lisp_Object keyword, Lisp_Object value,
527 maybe_signal_error (Qwrong_type_argument, list2 (Qnatnump, value),
533 decode_hash_table_size (Lisp_Object obj)
535 return NILP (obj) ? HASH_TABLE_DEFAULT_SIZE : XINT (obj);
539 hash_table_weakness_validate (Lisp_Object keyword, Lisp_Object value,
542 if (EQ (value, Qnil)) return 1;
543 if (EQ (value, Qt)) return 1;
544 if (EQ (value, Qkey)) return 1;
545 if (EQ (value, Qvalue)) return 1;
547 /* Following values are obsolete as of 19990901 in xemacs-21.2 */
548 if (EQ (value, Qnon_weak)) return 1;
549 if (EQ (value, Qweak)) return 1;
550 if (EQ (value, Qkey_weak)) return 1;
551 if (EQ (value, Qvalue_weak)) return 1;
553 maybe_signal_simple_error ("Invalid hash table weakness",
554 value, Qhash_table, errb);
558 static enum hash_table_weakness
559 decode_hash_table_weakness (Lisp_Object obj)
561 if (EQ (obj, Qnil)) return HASH_TABLE_NON_WEAK;
562 if (EQ (obj, Qt)) return HASH_TABLE_WEAK;
563 if (EQ (obj, Qkey)) return HASH_TABLE_KEY_WEAK;
564 if (EQ (obj, Qvalue)) return HASH_TABLE_VALUE_WEAK;
566 /* Following values are obsolete as of 19990901 in xemacs-21.2 */
567 if (EQ (obj, Qnon_weak)) return HASH_TABLE_NON_WEAK;
568 if (EQ (obj, Qweak)) return HASH_TABLE_WEAK;
569 if (EQ (obj, Qkey_weak)) return HASH_TABLE_KEY_WEAK;
570 if (EQ (obj, Qvalue_weak)) return HASH_TABLE_VALUE_WEAK;
572 signal_simple_error ("Invalid hash table weakness", obj);
573 return HASH_TABLE_NON_WEAK; /* not reached */
577 hash_table_test_validate (Lisp_Object keyword, Lisp_Object value,
580 if (EQ (value, Qnil)) return 1;
581 if (EQ (value, Qeq)) return 1;
582 if (EQ (value, Qequal)) return 1;
583 if (EQ (value, Qeql)) return 1;
585 maybe_signal_simple_error ("Invalid hash table test",
586 value, Qhash_table, errb);
590 static enum hash_table_test
591 decode_hash_table_test (Lisp_Object obj)
593 if (EQ (obj, Qnil)) return HASH_TABLE_EQL;
594 if (EQ (obj, Qeq)) return HASH_TABLE_EQ;
595 if (EQ (obj, Qequal)) return HASH_TABLE_EQUAL;
596 if (EQ (obj, Qeql)) return HASH_TABLE_EQL;
598 signal_simple_error ("Invalid hash table test", obj);
599 return HASH_TABLE_EQ; /* not reached */
603 hash_table_rehash_size_validate (Lisp_Object keyword, Lisp_Object value,
608 maybe_signal_error (Qwrong_type_argument, list2 (Qfloatp, value),
614 double rehash_size = XFLOAT_DATA (value);
615 if (rehash_size <= 1.0)
617 maybe_signal_simple_error
618 ("Hash table rehash size must be greater than 1.0",
619 value, Qhash_table, errb);
628 decode_hash_table_rehash_size (Lisp_Object rehash_size)
630 return NILP (rehash_size) ? -1.0 : XFLOAT_DATA (rehash_size);
634 hash_table_rehash_threshold_validate (Lisp_Object keyword, Lisp_Object value,
639 maybe_signal_error (Qwrong_type_argument, list2 (Qfloatp, value),
645 double rehash_threshold = XFLOAT_DATA (value);
646 if (rehash_threshold <= 0.0 || rehash_threshold >= 1.0)
648 maybe_signal_simple_error
649 ("Hash table rehash threshold must be between 0.0 and 1.0",
650 value, Qhash_table, errb);
659 decode_hash_table_rehash_threshold (Lisp_Object rehash_threshold)
661 return NILP (rehash_threshold) ? -1.0 : XFLOAT_DATA (rehash_threshold);
665 hash_table_data_validate (Lisp_Object keyword, Lisp_Object value,
670 GET_EXTERNAL_LIST_LENGTH (value, len);
674 maybe_signal_simple_error
675 ("Hash table data must have alternating key/value pairs",
676 value, Qhash_table, errb);
682 /* The actual instantiation of a hash table. This does practically no
683 error checking, because it relies on the fact that the paranoid
684 functions above have error-checked everything to the last details.
685 If this assumption is wrong, we will get a crash immediately (with
686 error-checking compiled in), and we'll know if there is a bug in
687 the structure mechanism. So there. */
689 hash_table_instantiate (Lisp_Object plist)
691 Lisp_Object hash_table;
692 Lisp_Object test = Qnil;
693 Lisp_Object size = Qnil;
694 Lisp_Object rehash_size = Qnil;
695 Lisp_Object rehash_threshold = Qnil;
696 Lisp_Object weakness = Qnil;
697 Lisp_Object data = Qnil;
699 while (!NILP (plist))
701 Lisp_Object key, value;
702 key = XCAR (plist); plist = XCDR (plist);
703 value = XCAR (plist); plist = XCDR (plist);
705 if (EQ (key, Qtest)) test = value;
706 else if (EQ (key, Qsize)) size = value;
707 else if (EQ (key, Qrehash_size)) rehash_size = value;
708 else if (EQ (key, Qrehash_threshold)) rehash_threshold = value;
709 else if (EQ (key, Qweakness)) weakness = value;
710 else if (EQ (key, Qdata)) data = value;
711 else if (EQ (key, Qtype))/*obsolete*/ weakness = value;
716 /* Create the hash table. */
717 hash_table = make_general_lisp_hash_table
718 (decode_hash_table_test (test),
719 decode_hash_table_size (size),
720 decode_hash_table_rehash_size (rehash_size),
721 decode_hash_table_rehash_threshold (rehash_threshold),
722 decode_hash_table_weakness (weakness));
724 /* I'm not sure whether this can GC, but better safe than sorry. */
729 /* And fill it with data. */
732 Lisp_Object key, value;
733 key = XCAR (data); data = XCDR (data);
734 value = XCAR (data); data = XCDR (data);
735 Fputhash (key, value, hash_table);
744 structure_type_create_hash_table_structure_name (Lisp_Object structure_name)
746 struct structure_type *st;
748 st = define_structure_type (structure_name, 0, hash_table_instantiate);
749 define_structure_type_keyword (st, Qtest, hash_table_test_validate);
750 define_structure_type_keyword (st, Qsize, hash_table_size_validate);
751 define_structure_type_keyword (st, Qrehash_size, hash_table_rehash_size_validate);
752 define_structure_type_keyword (st, Qrehash_threshold, hash_table_rehash_threshold_validate);
753 define_structure_type_keyword (st, Qweakness, hash_table_weakness_validate);
754 define_structure_type_keyword (st, Qdata, hash_table_data_validate);
756 /* obsolete as of 19990901 in xemacs-21.2 */
757 define_structure_type_keyword (st, Qtype, hash_table_weakness_validate);
760 /* Create a built-in Lisp structure type named `hash-table'.
761 We make #s(hashtable ...) equivalent to #s(hash-table ...),
762 for backward compatibility.
763 This is called from emacs.c. */
765 structure_type_create_hash_table (void)
767 structure_type_create_hash_table_structure_name (Qhash_table);
768 structure_type_create_hash_table_structure_name (Qhashtable); /* compat */
772 /************************************************************************/
773 /* Definition of Lisp-visible methods */
774 /************************************************************************/
776 DEFUN ("hash-table-p", Fhash_table_p, 1, 1, 0, /*
777 Return t if OBJECT is a hash table, else nil.
781 return HASH_TABLEP (object) ? Qt : Qnil;
784 DEFUN ("make-hash-table", Fmake_hash_table, 0, MANY, 0, /*
785 Return a new empty hash table object.
786 Use Common Lisp style keywords to specify hash table properties.
787 (make-hash-table &key test size rehash-size rehash-threshold weakness)
789 Keyword :test can be `eq', `eql' (default) or `equal'.
790 Comparison between keys is done using this function.
791 If speed is important, consider using `eq'.
792 When storing strings in the hash table, you will likely need to use `equal'.
794 Keyword :size specifies the number of keys likely to be inserted.
795 This number of entries can be inserted without enlarging the hash table.
797 Keyword :rehash-size must be a float greater than 1.0, and specifies
798 the factor by which to increase the size of the hash table when enlarging.
800 Keyword :rehash-threshold must be a float between 0.0 and 1.0,
801 and specifies the load factor of the hash table which triggers enlarging.
803 Non-standard keyword :weakness can be `nil' (default), `t', `key' or `value'.
805 A weak hash table is one whose pointers do not count as GC referents:
806 for any key-value pair in the hash table, if the only remaining pointer
807 to either the key or the value is in a weak hash table, then the pair
808 will be removed from the hash table, and the key and value collected.
809 A non-weak hash table (or any other pointer) would prevent the object
810 from being collected.
812 A key-weak hash table is similar to a fully-weak hash table except that
813 a key-value pair will be removed only if the key remains unmarked
814 outside of weak hash tables. The pair will remain in the hash table if
815 the key is pointed to by something other than a weak hash table, even
818 A value-weak hash table is similar to a fully-weak hash table except
819 that a key-value pair will be removed only if the value remains
820 unmarked outside of weak hash tables. The pair will remain in the
821 hash table if the value is pointed to by something other than a weak
822 hash table, even if the key is not.
824 (int nargs, Lisp_Object *args))
827 Lisp_Object test = Qnil;
828 Lisp_Object size = Qnil;
829 Lisp_Object rehash_size = Qnil;
830 Lisp_Object rehash_threshold = Qnil;
831 Lisp_Object weakness = Qnil;
833 while (i + 1 < nargs)
835 Lisp_Object keyword = args[i++];
836 Lisp_Object value = args[i++];
838 if (EQ (keyword, Q_test)) test = value;
839 else if (EQ (keyword, Q_size)) size = value;
840 else if (EQ (keyword, Q_rehash_size)) rehash_size = value;
841 else if (EQ (keyword, Q_rehash_threshold)) rehash_threshold = value;
842 else if (EQ (keyword, Q_weakness)) weakness = value;
843 else if (EQ (keyword, Q_type))/*obsolete*/ weakness = value;
844 else signal_simple_error ("Invalid hash table property keyword", keyword);
848 signal_simple_error ("Hash table property requires a value", args[i]);
850 #define VALIDATE_VAR(var) \
851 if (!NILP (var)) hash_table_##var##_validate (Q##var, var, ERROR_ME);
855 VALIDATE_VAR (rehash_size);
856 VALIDATE_VAR (rehash_threshold);
857 VALIDATE_VAR (weakness);
859 return make_general_lisp_hash_table
860 (decode_hash_table_test (test),
861 decode_hash_table_size (size),
862 decode_hash_table_rehash_size (rehash_size),
863 decode_hash_table_rehash_threshold (rehash_threshold),
864 decode_hash_table_weakness (weakness));
867 DEFUN ("copy-hash-table", Fcopy_hash_table, 1, 1, 0, /*
868 Return a new hash table containing the same keys and values as HASH-TABLE.
869 The keys and values will not themselves be copied.
873 const Lisp_Hash_Table *ht_old = xhash_table (hash_table);
874 Lisp_Hash_Table *ht = alloc_lcrecord_type (Lisp_Hash_Table, &lrecord_hash_table);
876 copy_lcrecord (ht, ht_old);
878 ht->hentries = xnew_array (hentry, ht_old->size + 1);
879 memcpy (ht->hentries, ht_old->hentries, (ht_old->size + 1) * sizeof (hentry));
881 XSETHASH_TABLE (hash_table, ht);
883 if (! EQ (ht->next_weak, Qunbound))
885 ht->next_weak = Vall_weak_hash_tables;
886 Vall_weak_hash_tables = hash_table;
893 resize_hash_table (Lisp_Hash_Table *ht, size_t new_size)
895 hentry *old_entries, *new_entries, *sentinel, *e;
901 old_entries = ht->hentries;
903 ht->hentries = xnew_array_and_zero (hentry, new_size + 1);
904 new_entries = ht->hentries;
906 compute_hash_table_derived_values (ht);
908 for (e = old_entries, sentinel = e + old_size; e < sentinel; e++)
909 if (!HENTRY_CLEAR_P (e))
911 hentry *probe = new_entries + HASH_CODE (e->key, ht);
912 LINEAR_PROBING_LOOP (probe, new_entries, new_size)
917 if (!DUMPEDP (old_entries))
921 /* After a hash table has been saved to disk and later restored by the
922 portable dumper, it contains the same objects, but their addresses
923 and thus their HASH_CODEs have changed. */
925 pdump_reorganize_hash_table (Lisp_Object hash_table)
927 const Lisp_Hash_Table *ht = xhash_table (hash_table);
928 hentry *new_entries = xnew_array_and_zero (hentry, ht->size + 1);
929 hentry *e, *sentinel;
931 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
932 if (!HENTRY_CLEAR_P (e))
934 hentry *probe = new_entries + HASH_CODE (e->key, ht);
935 LINEAR_PROBING_LOOP (probe, new_entries, ht->size)
940 memcpy (ht->hentries, new_entries, ht->size * sizeof (hentry));
946 enlarge_hash_table (Lisp_Hash_Table *ht)
949 hash_table_size ((size_t) ((double) ht->size * ht->rehash_size));
950 resize_hash_table (ht, new_size);
954 find_hentry (Lisp_Object key, const Lisp_Hash_Table *ht)
956 hash_table_test_function_t test_function = ht->test_function;
957 hentry *entries = ht->hentries;
958 hentry *probe = entries + HASH_CODE (key, ht);
960 LINEAR_PROBING_LOOP (probe, entries, ht->size)
961 if (KEYS_EQUAL_P (probe->key, key, test_function))
967 DEFUN ("gethash", Fgethash, 2, 3, 0, /*
968 Find hash value for KEY in HASH-TABLE.
969 If there is no corresponding value, return DEFAULT (which defaults to nil).
971 (key, hash_table, default_))
973 const Lisp_Hash_Table *ht = xhash_table (hash_table);
974 hentry *e = find_hentry (key, ht);
976 return HENTRY_CLEAR_P (e) ? default_ : e->value;
979 DEFUN ("puthash", Fputhash, 3, 3, 0, /*
980 Hash KEY to VALUE in HASH-TABLE.
982 (key, value, hash_table))
984 Lisp_Hash_Table *ht = xhash_table (hash_table);
985 hentry *e = find_hentry (key, ht);
987 if (!HENTRY_CLEAR_P (e))
988 return e->value = value;
993 if (++ht->count >= ht->rehash_count)
994 enlarge_hash_table (ht);
999 /* Remove hentry pointed at by PROBE.
1000 Subsequent entries are removed and reinserted.
1001 We don't use tombstones - too wasteful. */
1003 remhash_1 (Lisp_Hash_Table *ht, hentry *entries, hentry *probe)
1005 size_t size = ht->size;
1006 CLEAR_HENTRY (probe);
1010 LINEAR_PROBING_LOOP (probe, entries, size)
1012 Lisp_Object key = probe->key;
1013 hentry *probe2 = entries + HASH_CODE (key, ht);
1014 LINEAR_PROBING_LOOP (probe2, entries, size)
1015 if (EQ (probe2->key, key))
1016 /* hentry at probe doesn't need to move. */
1017 goto continue_outer_loop;
1018 /* Move hentry from probe to new home at probe2. */
1020 CLEAR_HENTRY (probe);
1021 continue_outer_loop: continue;
1025 DEFUN ("remhash", Fremhash, 2, 2, 0, /*
1026 Remove the entry for KEY from HASH-TABLE.
1027 Do nothing if there is no entry for KEY in HASH-TABLE.
1031 Lisp_Hash_Table *ht = xhash_table (hash_table);
1032 hentry *e = find_hentry (key, ht);
1034 if (HENTRY_CLEAR_P (e))
1037 remhash_1 (ht, ht->hentries, e);
1041 DEFUN ("clrhash", Fclrhash, 1, 1, 0, /*
1042 Remove all entries from HASH-TABLE, leaving it empty.
1046 Lisp_Hash_Table *ht = xhash_table (hash_table);
1047 hentry *e, *sentinel;
1049 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1056 /************************************************************************/
1057 /* Accessor Functions */
1058 /************************************************************************/
1060 DEFUN ("hash-table-count", Fhash_table_count, 1, 1, 0, /*
1061 Return the number of entries in HASH-TABLE.
1065 return make_int (xhash_table (hash_table)->count);
1068 DEFUN ("hash-table-test", Fhash_table_test, 1, 1, 0, /*
1069 Return the test function of HASH-TABLE.
1070 This can be one of `eq', `eql' or `equal'.
1074 hash_table_test_function_t fun = xhash_table (hash_table)->test_function;
1076 return (fun == lisp_object_eql_equal ? Qeql :
1077 fun == lisp_object_equal_equal ? Qequal :
1081 DEFUN ("hash-table-size", Fhash_table_size, 1, 1, 0, /*
1082 Return the size of HASH-TABLE.
1083 This is the current number of slots in HASH-TABLE, whether occupied or not.
1087 return make_int (xhash_table (hash_table)->size);
1090 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size, 1, 1, 0, /*
1091 Return the current rehash size of HASH-TABLE.
1092 This is a float greater than 1.0; the factor by which HASH-TABLE
1093 is enlarged when the rehash threshold is exceeded.
1097 return make_float (xhash_table (hash_table)->rehash_size);
1100 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold, 1, 1, 0, /*
1101 Return the current rehash threshold of HASH-TABLE.
1102 This is a float between 0.0 and 1.0; the maximum `load factor' of HASH-TABLE,
1103 beyond which the HASH-TABLE is enlarged by rehashing.
1107 return make_float (xhash_table (hash_table)->rehash_threshold);
1110 DEFUN ("hash-table-weakness", Fhash_table_weakness, 1, 1, 0, /*
1111 Return the weakness of HASH-TABLE.
1112 This can be one of `nil', `t', `key' or `value'.
1116 switch (xhash_table (hash_table)->weakness)
1118 case HASH_TABLE_WEAK: return Qt;
1119 case HASH_TABLE_KEY_WEAK: return Qkey;
1120 case HASH_TABLE_VALUE_WEAK: return Qvalue;
1121 default: return Qnil;
1125 /* obsolete as of 19990901 in xemacs-21.2 */
1126 DEFUN ("hash-table-type", Fhash_table_type, 1, 1, 0, /*
1127 Return the type of HASH-TABLE.
1128 This can be one of `non-weak', `weak', `key-weak' or `value-weak'.
1132 switch (xhash_table (hash_table)->weakness)
1134 case HASH_TABLE_WEAK: return Qweak;
1135 case HASH_TABLE_KEY_WEAK: return Qkey_weak;
1136 case HASH_TABLE_VALUE_WEAK: return Qvalue_weak;
1137 default: return Qnon_weak;
1141 /************************************************************************/
1142 /* Mapping Functions */
1143 /************************************************************************/
1144 DEFUN ("maphash", Fmaphash, 2, 2, 0, /*
1145 Map FUNCTION over entries in HASH-TABLE, calling it with two args,
1146 each key and value in HASH-TABLE.
1148 FUNCTION may not modify HASH-TABLE, with the one exception that FUNCTION
1149 may remhash or puthash the entry currently being processed by FUNCTION.
1151 (function, hash_table))
1153 const Lisp_Hash_Table *ht = xhash_table (hash_table);
1154 const hentry *e, *sentinel;
1156 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1157 if (!HENTRY_CLEAR_P (e))
1159 Lisp_Object args[3], key;
1165 Ffuncall (countof (args), args);
1166 /* Has FUNCTION done a remhash? */
1167 if (!EQ (key, e->key) && !HENTRY_CLEAR_P (e))
1174 /* Map *C* function FUNCTION over the elements of a lisp hash table. */
1176 elisp_maphash (maphash_function_t function,
1177 Lisp_Object hash_table, void *extra_arg)
1179 const Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1180 const hentry *e, *sentinel;
1182 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1183 if (!HENTRY_CLEAR_P (e))
1188 if (function (key, e->value, extra_arg))
1190 /* Has FUNCTION done a remhash? */
1191 if (!EQ (key, e->key) && !HENTRY_CLEAR_P (e))
1196 /* Remove all elements of a lisp hash table satisfying *C* predicate PREDICATE. */
1198 elisp_map_remhash (maphash_function_t predicate,
1199 Lisp_Object hash_table, void *extra_arg)
1201 Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1202 hentry *e, *entries, *sentinel;
1204 for (e = entries = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1205 if (!HENTRY_CLEAR_P (e))
1208 if (predicate (e->key, e->value, extra_arg))
1210 remhash_1 (ht, entries, e);
1211 if (!HENTRY_CLEAR_P (e))
1218 /************************************************************************/
1219 /* garbage collecting weak hash tables */
1220 /************************************************************************/
1222 /* Complete the marking for semi-weak hash tables. */
1224 finish_marking_weak_hash_tables (void)
1226 Lisp_Object hash_table;
1229 for (hash_table = Vall_weak_hash_tables;
1231 hash_table = XHASH_TABLE (hash_table)->next_weak)
1233 const Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1234 const hentry *e = ht->hentries;
1235 const hentry *sentinel = e + ht->size;
1237 if (! marked_p (hash_table))
1238 /* The hash table is probably garbage. Ignore it. */
1241 /* Now, scan over all the pairs. For all pairs that are
1242 half-marked, we may need to mark the other half if we're
1243 keeping this pair. */
1244 #define MARK_OBJ(obj) \
1245 do { if (!marked_p (obj)) mark_object (obj), did_mark = 1; } while (0)
1247 switch (ht->weakness)
1249 case HASH_TABLE_KEY_WEAK:
1250 for (; e < sentinel; e++)
1251 if (!HENTRY_CLEAR_P (e))
1252 if (marked_p (e->key))
1253 MARK_OBJ (e->value);
1256 case HASH_TABLE_VALUE_WEAK:
1257 for (; e < sentinel; e++)
1258 if (!HENTRY_CLEAR_P (e))
1259 if (marked_p (e->value))
1263 case HASH_TABLE_KEY_CAR_WEAK:
1264 for (; e < sentinel; e++)
1265 if (!HENTRY_CLEAR_P (e))
1266 if (!CONSP (e->key) || marked_p (XCAR (e->key)))
1269 MARK_OBJ (e->value);
1273 case HASH_TABLE_VALUE_CAR_WEAK:
1274 for (; e < sentinel; e++)
1275 if (!HENTRY_CLEAR_P (e))
1276 if (!CONSP (e->value) || marked_p (XCAR (e->value)))
1279 MARK_OBJ (e->value);
1292 prune_weak_hash_tables (void)
1294 Lisp_Object hash_table, prev = Qnil;
1295 for (hash_table = Vall_weak_hash_tables;
1297 hash_table = XHASH_TABLE (hash_table)->next_weak)
1299 if (! marked_p (hash_table))
1301 /* This hash table itself is garbage. Remove it from the list. */
1303 Vall_weak_hash_tables = XHASH_TABLE (hash_table)->next_weak;
1305 XHASH_TABLE (prev)->next_weak = XHASH_TABLE (hash_table)->next_weak;
1309 /* Now, scan over all the pairs. Remove all of the pairs
1310 in which the key or value, or both, is unmarked
1311 (depending on the weakness of the hash table). */
1312 Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1313 hentry *entries = ht->hentries;
1314 hentry *sentinel = entries + ht->size;
1317 for (e = entries; e < sentinel; e++)
1318 if (!HENTRY_CLEAR_P (e))
1321 if (!marked_p (e->key) || !marked_p (e->value))
1323 remhash_1 (ht, entries, e);
1324 if (!HENTRY_CLEAR_P (e))
1334 /* Return a hash value for an array of Lisp_Objects of size SIZE. */
1337 internal_array_hash (Lisp_Object *arr, int size, int depth)
1340 hashcode_t hash = 0;
1345 for (i = 0; i < size; i++)
1346 hash = HASH2 (hash, internal_hash (arr[i], depth));
1350 /* just pick five elements scattered throughout the array.
1351 A slightly better approach would be to offset by some
1352 noise factor from the points chosen below. */
1353 for (i = 0; i < 5; i++)
1354 hash = HASH2 (hash, internal_hash (arr[i*size/5], depth));
1359 /* Return a hash value for a Lisp_Object. This is for use when hashing
1360 objects with the comparison being `equal' (for `eq', you can just
1361 use the Lisp_Object itself as the hash value). You need to make a
1362 tradeoff between the speed of the hash function and how good the
1363 hashing is. In particular, the hash function needs to be FAST,
1364 so you can't just traipse down the whole tree hashing everything
1365 together. Most of the time, objects will differ in the first
1366 few elements you hash. Thus, we only go to a short depth (5)
1367 and only hash at most 5 elements out of a vector. Theoretically
1368 we could still take 5^5 time (a big big number) to compute a
1369 hash, but practically this won't ever happen. */
1372 internal_hash (Lisp_Object obj, int depth)
1378 /* no point in worrying about tail recursion, since we're not
1380 return HASH2 (internal_hash (XCAR (obj), depth + 1),
1381 internal_hash (XCDR (obj), depth + 1));
1385 return hash_string (XSTRING_DATA (obj), XSTRING_LENGTH (obj));
1389 const struct lrecord_implementation
1390 *imp = XRECORD_LHEADER_IMPLEMENTATION (obj);
1392 return imp->hash (obj, depth);
1395 return LISP_HASH (obj);
1398 DEFUN ("sxhash", Fsxhash, 1, 1, 0, /*
1399 Return a hash value for OBJECT.
1400 (equal obj1 obj2) implies (= (sxhash obj1) (sxhash obj2)).
1404 return make_int (internal_hash (object, 0));
1408 xxDEFUN ("internal-hash-value", Finternal_hash_value, 1, 1, 0, /*
1409 Hash value of OBJECT. For debugging.
1410 The value is returned as (HIGH . LOW).
1414 /* This function is pretty 32bit-centric. */
1415 hashcode_t hash = internal_hash (object, 0);
1416 return Fcons (hash >> 16, hash & 0xffff);
1421 /************************************************************************/
1422 /* initialization */
1423 /************************************************************************/
1426 syms_of_elhash (void)
1428 INIT_LRECORD_IMPLEMENTATION (hash_table);
1430 DEFSUBR (Fhash_table_p);
1431 DEFSUBR (Fmake_hash_table);
1432 DEFSUBR (Fcopy_hash_table);
1438 DEFSUBR (Fhash_table_count);
1439 DEFSUBR (Fhash_table_test);
1440 DEFSUBR (Fhash_table_size);
1441 DEFSUBR (Fhash_table_rehash_size);
1442 DEFSUBR (Fhash_table_rehash_threshold);
1443 DEFSUBR (Fhash_table_weakness);
1444 DEFSUBR (Fhash_table_type); /* obsolete */
1447 DEFSUBR (Finternal_hash_value);
1450 defsymbol (&Qhash_tablep, "hash-table-p");
1451 defsymbol (&Qhash_table, "hash-table");
1452 defsymbol (&Qhashtable, "hashtable");
1453 defsymbol (&Qweakness, "weakness");
1454 defsymbol (&Qvalue, "value");
1455 defsymbol (&Qrehash_size, "rehash-size");
1456 defsymbol (&Qrehash_threshold, "rehash-threshold");
1458 defsymbol (&Qweak, "weak"); /* obsolete */
1459 defsymbol (&Qkey_weak, "key-weak"); /* obsolete */
1460 defsymbol (&Qvalue_weak, "value-weak"); /* obsolete */
1461 defsymbol (&Qnon_weak, "non-weak"); /* obsolete */
1463 defkeyword (&Q_test, ":test");
1464 defkeyword (&Q_size, ":size");
1465 defkeyword (&Q_rehash_size, ":rehash-size");
1466 defkeyword (&Q_rehash_threshold, ":rehash-threshold");
1467 defkeyword (&Q_weakness, ":weakness");
1468 defkeyword (&Q_type, ":type"); /* obsolete */
1472 vars_of_elhash (void)
1474 /* This must NOT be staticpro'd */
1475 Vall_weak_hash_tables = Qnil;
1476 pdump_wire_list (&Vall_weak_hash_tables);