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. */
31 Lisp_Object Qhash_tablep, Qhashtable, Qhash_table;
32 Lisp_Object Qweak, Qkey_weak, Qvalue_weak, Qnon_weak;
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_type, Q_rehash_size, Q_rehash_threshold;
43 struct Lisp_Hash_Table
45 struct lcrecord_header header;
50 double rehash_threshold;
52 hash_table_hash_function_t hash_function;
53 hash_table_test_function_t test_function;
55 enum hash_table_type type; /* whether and how this hash table is weak */
56 Lisp_Object next_weak; /* Used to chain together all of the weak
57 hash tables. Don't mark through this. */
59 typedef struct Lisp_Hash_Table Lisp_Hash_Table;
61 #define HENTRY_CLEAR_P(hentry) ((*(EMACS_UINT*)(&((hentry)->key))) == 0)
62 #define CLEAR_HENTRY(hentry) ((*(EMACS_UINT*)(&((hentry)->key))) = 0)
64 #define HASH_TABLE_DEFAULT_SIZE 16
65 #define HASH_TABLE_DEFAULT_REHASH_SIZE 1.3
66 #define HASH_TABLE_MIN_SIZE 10
68 #define HASH_CODE(key, ht) \
69 (((((ht)->hash_function ? (ht)->hash_function (key) : LISP_HASH (key)) \
70 * (ht)->golden_ratio) \
73 #define KEYS_EQUAL_P(key1, key2, testfun) \
74 (EQ ((key1), (key2)) || ((testfun) && (testfun) ((key1), (key2))))
76 #define LINEAR_PROBING_LOOP(probe, entries, size) \
78 !HENTRY_CLEAR_P (probe) || \
79 (probe == entries + size ? \
80 (probe = entries, !HENTRY_CLEAR_P (probe)) : 0); \
83 #ifndef ERROR_CHECK_HASH_TABLE
84 # ifdef ERROR_CHECK_TYPECHECK
85 # define ERROR_CHECK_HASH_TABLE 1
87 # define ERROR_CHECK_HASH_TABLE 0
91 #if ERROR_CHECK_HASH_TABLE
93 check_hash_table_invariants (Lisp_Hash_Table *ht)
95 assert (ht->count < ht->size);
96 assert (ht->count <= ht->rehash_count);
97 assert (ht->rehash_count < ht->size);
98 assert ((double) ht->count * ht->rehash_threshold - 1 <= (double) ht->rehash_count);
99 assert (HENTRY_CLEAR_P (ht->hentries + ht->size));
102 #define check_hash_table_invariants(ht)
105 /* We use linear probing instead of double hashing, despite its lack
106 of blessing by Knuth and company, because, as a result of the
107 increasing discrepancy between CPU speeds and memory speeds, cache
108 behavior is becoming increasingly important, e.g:
110 For a trivial loop, the penalty for non-sequential access of an array is:
111 - a factor of 3-4 on Pentium Pro 200 Mhz
112 - a factor of 10 on Ultrasparc 300 Mhz */
114 /* Return a suitable size for a hash table, with at least SIZE slots. */
116 hash_table_size (size_t requested_size)
118 /* Return some prime near, but greater than or equal to, SIZE.
119 Decades from the time of writing, someone will have a system large
120 enough that the list below will be too short... */
121 static CONST size_t primes [] =
123 19, 29, 41, 59, 79, 107, 149, 197, 263, 347, 457, 599, 787, 1031,
124 1361, 1777, 2333, 3037, 3967, 5167, 6719, 8737, 11369, 14783,
125 19219, 24989, 32491, 42257, 54941, 71429, 92861, 120721, 156941,
126 204047, 265271, 344857, 448321, 582821, 757693, 985003, 1280519,
127 1664681, 2164111, 2813353, 3657361, 4754591, 6180989, 8035301,
128 10445899, 13579681, 17653589, 22949669, 29834603, 38784989,
129 50420551, 65546729, 85210757, 110774011, 144006217, 187208107,
130 243370577, 316381771, 411296309, 534685237, 695090819, 903618083,
131 1174703521, 1527114613, 1985248999, 2580823717UL, 3355070839UL
133 /* We've heard of binary search. */
135 for (low = 0, high = countof (primes) - 1; high - low > 1;)
137 /* Loop Invariant: size < primes [high] */
138 int mid = (low + high) / 2;
139 if (primes [mid] < requested_size)
144 return primes [high];
148 #if 0 /* I don't think these are needed any more.
149 If using the general lisp_object_equal_*() functions
150 causes efficiency problems, these can be resurrected. --ben */
151 /* equality and hash functions for Lisp strings */
153 lisp_string_equal (Lisp_Object str1, Lisp_Object str2)
155 /* This is wrong anyway. You can't use strcmp() on Lisp strings,
156 because they can contain zero characters. */
157 return !strcmp ((char *) XSTRING_DATA (str1), (char *) XSTRING_DATA (str2));
161 lisp_string_hash (Lisp_Object obj)
163 return hash_string (XSTRING_DATA (str), XSTRING_LENGTH (str));
169 lisp_object_eql_equal (Lisp_Object obj1, Lisp_Object obj2)
171 return EQ (obj1, obj2) || (FLOATP (obj1) && internal_equal (obj1, obj2, 0));
175 lisp_object_eql_hash (Lisp_Object obj)
177 return FLOATP (obj) ? internal_hash (obj, 0) : LISP_HASH (obj);
181 lisp_object_equal_equal (Lisp_Object obj1, Lisp_Object obj2)
183 return internal_equal (obj1, obj2, 0);
187 lisp_object_equal_hash (Lisp_Object obj)
189 return internal_hash (obj, 0);
194 mark_hash_table (Lisp_Object obj, void (*markobj) (Lisp_Object))
196 Lisp_Hash_Table *ht = XHASH_TABLE (obj);
198 /* If the hash table is weak, we don't want to mark the keys and
199 values (we scan over them after everything else has been marked,
200 and mark or remove them as necessary). */
201 if (ht->type == HASH_TABLE_NON_WEAK)
203 hentry *e, *sentinel;
205 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
206 if (!HENTRY_CLEAR_P (e))
215 /* Equality of hash tables. Two hash tables are equal when they are of
216 the same type and test function, they have the same number of
217 elements, and for each key in the hash table, the values are `equal'.
219 This is similar to Common Lisp `equalp' of hash tables, with the
220 difference that CL requires the keys to be compared with the test
221 function, which we don't do. Doing that would require consing, and
222 consing is a bad idea in `equal'. Anyway, our method should provide
223 the same result -- if the keys are not equal according to the test
224 function, then Fgethash() in hash_table_equal_mapper() will fail. */
226 hash_table_equal (Lisp_Object hash_table1, Lisp_Object hash_table2, int depth)
228 Lisp_Hash_Table *ht1 = XHASH_TABLE (hash_table1);
229 Lisp_Hash_Table *ht2 = XHASH_TABLE (hash_table2);
230 hentry *e, *sentinel;
232 if ((ht1->test_function != ht2->test_function) ||
233 (ht1->type != ht2->type) ||
234 (ht1->count != ht2->count))
239 for (e = ht1->hentries, sentinel = e + ht1->size; e < sentinel; e++)
240 if (!HENTRY_CLEAR_P (e))
241 /* Look up the key in the other hash table, and compare the values. */
243 Lisp_Object value_in_other = Fgethash (e->key, hash_table2, Qunbound);
244 if (UNBOUNDP (value_in_other) ||
245 !internal_equal (e->value, value_in_other, depth))
246 return 0; /* Give up */
252 /* Printing hash tables.
254 This is non-trivial, because we use a readable structure-style
255 syntax for hash tables. This means that a typical hash table will be
256 readably printed in the form of:
258 #s(hash-table size 2 data (key1 value1 key2 value2))
260 The supported keywords are `type' (non-weak (or nil), weak,
261 key-weak and value-weak), `test' (eql (or nil), eq or equal),
262 `size' (a natnum or nil) and `data' (a list).
264 If `print-readably' is non-nil, then a simpler syntax is used; for
267 #<hash-table size 2/13 data (key1 value1 key2 value2) 0x874d>
269 The data is truncated to four pairs, and the rest is shown with
270 `...'. This printer does not cons. */
273 /* Print the data of the hash table. This maps through a Lisp
274 hash table and prints key/value pairs using PRINTCHARFUN. */
276 print_hash_table_data (Lisp_Hash_Table *ht, Lisp_Object printcharfun)
279 hentry *e, *sentinel;
281 write_c_string (" data (", printcharfun);
283 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
284 if (!HENTRY_CLEAR_P (e))
287 write_c_string (" ", printcharfun);
288 if (!print_readably && count > 3)
290 write_c_string ("...", printcharfun);
293 print_internal (e->key, printcharfun, 1);
294 write_c_string (" ", printcharfun);
295 print_internal (e->value, printcharfun, 1);
299 write_c_string (")", printcharfun);
303 print_hash_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
305 Lisp_Hash_Table *ht = XHASH_TABLE (obj);
308 write_c_string (print_readably ? "#s(hash-table" : "#<hash-table",
311 if (ht->type != HASH_TABLE_NON_WEAK)
313 sprintf (buf, " type %s",
314 (ht->type == HASH_TABLE_WEAK ? "weak" :
315 ht->type == HASH_TABLE_KEY_WEAK ? "key-weak" :
316 ht->type == HASH_TABLE_VALUE_WEAK ? "value-weak" :
317 "you-d-better-not-see-this"));
318 write_c_string (buf, printcharfun);
321 /* These checks have a kludgy look to them, but they are safe.
322 Due to nature of hashing, you cannot use arbitrary
323 test functions anyway. */
324 if (!ht->test_function)
325 write_c_string (" test eq", printcharfun);
326 else if (ht->test_function == lisp_object_equal_equal)
327 write_c_string (" test equal", printcharfun);
328 else if (ht->test_function == lisp_object_eql_equal)
333 if (ht->count || !print_readably)
336 sprintf (buf, " size %lu", (unsigned long) ht->count);
338 sprintf (buf, " size %lu/%lu",
339 (unsigned long) ht->count,
340 (unsigned long) ht->size);
341 write_c_string (buf, printcharfun);
345 print_hash_table_data (ht, printcharfun);
348 write_c_string (")", printcharfun);
351 sprintf (buf, " 0x%x>", ht->header.uid);
352 write_c_string (buf, printcharfun);
357 finalize_hash_table (void *header, int for_disksave)
361 Lisp_Hash_Table *ht = (Lisp_Hash_Table *) header;
363 xfree (ht->hentries);
368 static const struct lrecord_description hentry_description_1[] = {
369 { XD_LISP_OBJECT, offsetof(hentry, key), 2 },
373 static const struct struct_description hentry_description = {
378 static const struct lrecord_description hash_table_description[] = {
379 { XD_SIZE_T, offsetof(Lisp_Hash_Table, size) },
380 { XD_STRUCT_PTR, offsetof(Lisp_Hash_Table, hentries), XD_INDIRECT(0), &hentry_description },
384 DEFINE_LRECORD_IMPLEMENTATION ("hash-table", hash_table,
385 mark_hash_table, print_hash_table,
387 /* #### Implement hash_table_hash()! */
389 hash_table_description,
392 static Lisp_Hash_Table *
393 xhash_table (Lisp_Object hash_table)
396 CHECK_HASH_TABLE (hash_table);
397 check_hash_table_invariants (XHASH_TABLE (hash_table));
398 return XHASH_TABLE (hash_table);
402 /************************************************************************/
403 /* Creation of Hash Tables */
404 /************************************************************************/
406 /* Creation of hash tables, without error-checking. */
408 hash_table_rehash_threshold (Lisp_Hash_Table *ht)
411 ht->rehash_threshold > 0.0 ? ht->rehash_threshold :
412 ht->size > 4096 && !ht->test_function ? 0.7 : 0.6;
416 compute_hash_table_derived_values (Lisp_Hash_Table *ht)
418 ht->rehash_count = (size_t)
419 ((double) ht->size * hash_table_rehash_threshold (ht));
420 ht->golden_ratio = (size_t)
421 ((double) ht->size * (.6180339887 / (double) sizeof (Lisp_Object)));
425 make_general_lisp_hash_table (size_t size,
426 enum hash_table_type type,
427 enum hash_table_test test,
429 double rehash_threshold)
431 Lisp_Object hash_table;
432 Lisp_Hash_Table *ht = alloc_lcrecord_type (Lisp_Hash_Table, &lrecord_hash_table);
435 ht->rehash_size = rehash_size;
436 ht->rehash_threshold = rehash_threshold;
441 ht->test_function = 0;
442 ht->hash_function = 0;
446 ht->test_function = lisp_object_eql_equal;
447 ht->hash_function = lisp_object_eql_hash;
450 case HASH_TABLE_EQUAL:
451 ht->test_function = lisp_object_equal_equal;
452 ht->hash_function = lisp_object_equal_hash;
459 if (ht->rehash_size <= 0.0)
460 ht->rehash_size = HASH_TABLE_DEFAULT_REHASH_SIZE;
461 if (size < HASH_TABLE_MIN_SIZE)
462 size = HASH_TABLE_MIN_SIZE;
463 if (rehash_threshold < 0.0)
464 rehash_threshold = 0.75;
466 hash_table_size ((size_t) ((double) size / hash_table_rehash_threshold (ht)) + 1);
468 compute_hash_table_derived_values (ht);
470 /* We leave room for one never-occupied sentinel hentry at the end. */
471 ht->hentries = xnew_array (hentry, ht->size + 1);
474 hentry *e, *sentinel;
475 for (e = ht->hentries, sentinel = e + ht->size; e <= sentinel; e++)
479 XSETHASH_TABLE (hash_table, ht);
481 if (type == HASH_TABLE_NON_WEAK)
482 ht->next_weak = Qunbound;
484 ht->next_weak = Vall_weak_hash_tables, Vall_weak_hash_tables = hash_table;
490 make_lisp_hash_table (size_t size,
491 enum hash_table_type type,
492 enum hash_table_test test)
494 return make_general_lisp_hash_table (size, type, test,
495 HASH_TABLE_DEFAULT_REHASH_SIZE, -1.0);
498 /* Pretty reading of hash tables.
500 Here we use the existing structures mechanism (which is,
501 unfortunately, pretty cumbersome) for validating and instantiating
502 the hash tables. The idea is that the side-effect of reading a
503 #s(hash-table PLIST) object is creation of a hash table with desired
504 properties, and that the hash table is returned. */
506 /* Validation functions: each keyword provides its own validation
507 function. The errors should maybe be continuable, but it is
508 unclear how this would cope with ERRB. */
510 hash_table_size_validate (Lisp_Object keyword, Lisp_Object value,
516 maybe_signal_error (Qwrong_type_argument, list2 (Qnatnump, value),
522 decode_hash_table_size (Lisp_Object obj)
524 return NILP (obj) ? HASH_TABLE_DEFAULT_SIZE : XINT (obj);
528 hash_table_type_validate (Lisp_Object keyword, Lisp_Object value,
531 if (EQ (value, Qnil)) return 1;
532 if (EQ (value, Qnon_weak)) return 1;
533 if (EQ (value, Qweak)) return 1;
534 if (EQ (value, Qkey_weak)) return 1;
535 if (EQ (value, Qvalue_weak)) return 1;
537 maybe_signal_simple_error ("Invalid hash table type",
538 value, Qhash_table, errb);
542 static enum hash_table_type
543 decode_hash_table_type (Lisp_Object obj)
545 if (EQ (obj, Qnil)) return HASH_TABLE_NON_WEAK;
546 if (EQ (obj, Qnon_weak)) return HASH_TABLE_NON_WEAK;
547 if (EQ (obj, Qweak)) return HASH_TABLE_WEAK;
548 if (EQ (obj, Qkey_weak)) return HASH_TABLE_KEY_WEAK;
549 if (EQ (obj, Qvalue_weak)) return HASH_TABLE_VALUE_WEAK;
551 signal_simple_error ("Invalid hash table type", obj);
552 return HASH_TABLE_NON_WEAK; /* not reached */
556 hash_table_test_validate (Lisp_Object keyword, Lisp_Object value,
559 if (EQ (value, Qnil)) return 1;
560 if (EQ (value, Qeq)) return 1;
561 if (EQ (value, Qequal)) return 1;
562 if (EQ (value, Qeql)) return 1;
564 maybe_signal_simple_error ("Invalid hash table test",
565 value, Qhash_table, errb);
569 static enum hash_table_test
570 decode_hash_table_test (Lisp_Object obj)
572 if (EQ (obj, Qnil)) return HASH_TABLE_EQL;
573 if (EQ (obj, Qeq)) return HASH_TABLE_EQ;
574 if (EQ (obj, Qequal)) return HASH_TABLE_EQUAL;
575 if (EQ (obj, Qeql)) return HASH_TABLE_EQL;
577 signal_simple_error ("Invalid hash table test", obj);
578 return HASH_TABLE_EQ; /* not reached */
582 hash_table_rehash_size_validate (Lisp_Object keyword, Lisp_Object value,
587 maybe_signal_error (Qwrong_type_argument, list2 (Qfloatp, value),
593 double rehash_size = XFLOAT_DATA (value);
594 if (rehash_size <= 1.0)
596 maybe_signal_simple_error
597 ("Hash table rehash size must be greater than 1.0",
598 value, Qhash_table, errb);
607 decode_hash_table_rehash_size (Lisp_Object rehash_size)
609 return NILP (rehash_size) ? -1.0 : XFLOAT_DATA (rehash_size);
613 hash_table_rehash_threshold_validate (Lisp_Object keyword, Lisp_Object value,
618 maybe_signal_error (Qwrong_type_argument, list2 (Qfloatp, value),
624 double rehash_threshold = XFLOAT_DATA (value);
625 if (rehash_threshold <= 0.0 || rehash_threshold >= 1.0)
627 maybe_signal_simple_error
628 ("Hash table rehash threshold must be between 0.0 and 1.0",
629 value, Qhash_table, errb);
638 decode_hash_table_rehash_threshold (Lisp_Object rehash_threshold)
640 return NILP (rehash_threshold) ? -1.0 : XFLOAT_DATA (rehash_threshold);
644 hash_table_data_validate (Lisp_Object keyword, Lisp_Object value,
649 GET_EXTERNAL_LIST_LENGTH (value, len);
653 maybe_signal_simple_error
654 ("Hash table data must have alternating key/value pairs",
655 value, Qhash_table, errb);
661 /* The actual instantiation of a hash table. This does practically no
662 error checking, because it relies on the fact that the paranoid
663 functions above have error-checked everything to the last details.
664 If this assumption is wrong, we will get a crash immediately (with
665 error-checking compiled in), and we'll know if there is a bug in
666 the structure mechanism. So there. */
668 hash_table_instantiate (Lisp_Object plist)
670 Lisp_Object hash_table;
671 Lisp_Object test = Qnil;
672 Lisp_Object type = Qnil;
673 Lisp_Object size = Qnil;
674 Lisp_Object data = Qnil;
675 Lisp_Object rehash_size = Qnil;
676 Lisp_Object rehash_threshold = Qnil;
678 while (!NILP (plist))
680 Lisp_Object key, value;
681 key = XCAR (plist); plist = XCDR (plist);
682 value = XCAR (plist); plist = XCDR (plist);
684 if (EQ (key, Qtest)) test = value;
685 else if (EQ (key, Qtype)) type = value;
686 else if (EQ (key, Qsize)) size = value;
687 else if (EQ (key, Qdata)) data = value;
688 else if (EQ (key, Qrehash_size)) rehash_size = value;
689 else if (EQ (key, Qrehash_threshold)) rehash_threshold = value;
694 /* Create the hash table. */
695 hash_table = make_general_lisp_hash_table
696 (decode_hash_table_size (size),
697 decode_hash_table_type (type),
698 decode_hash_table_test (test),
699 decode_hash_table_rehash_size (rehash_size),
700 decode_hash_table_rehash_threshold (rehash_threshold));
702 /* I'm not sure whether this can GC, but better safe than sorry. */
707 /* And fill it with data. */
710 Lisp_Object key, value;
711 key = XCAR (data); data = XCDR (data);
712 value = XCAR (data); data = XCDR (data);
713 Fputhash (key, value, hash_table);
722 structure_type_create_hash_table_structure_name (Lisp_Object structure_name)
724 struct structure_type *st;
726 st = define_structure_type (structure_name, 0, hash_table_instantiate);
727 define_structure_type_keyword (st, Qsize, hash_table_size_validate);
728 define_structure_type_keyword (st, Qtest, hash_table_test_validate);
729 define_structure_type_keyword (st, Qtype, hash_table_type_validate);
730 define_structure_type_keyword (st, Qdata, hash_table_data_validate);
731 define_structure_type_keyword (st, Qrehash_size, hash_table_rehash_size_validate);
732 define_structure_type_keyword (st, Qrehash_threshold, hash_table_rehash_threshold_validate);
735 /* Create a built-in Lisp structure type named `hash-table'.
736 We make #s(hashtable ...) equivalent to #s(hash-table ...),
737 for backward comptabibility.
738 This is called from emacs.c. */
740 structure_type_create_hash_table (void)
742 structure_type_create_hash_table_structure_name (Qhash_table);
743 structure_type_create_hash_table_structure_name (Qhashtable); /* compat */
747 /************************************************************************/
748 /* Definition of Lisp-visible methods */
749 /************************************************************************/
751 DEFUN ("hash-table-p", Fhash_table_p, 1, 1, 0, /*
752 Return t if OBJECT is a hash table, else nil.
756 return HASH_TABLEP (object) ? Qt : Qnil;
759 DEFUN ("make-hash-table", Fmake_hash_table, 0, MANY, 0, /*
760 Return a new empty hash table object.
761 Use Common Lisp style keywords to specify hash table properties.
762 (make-hash-table &key :size :test :type :rehash-size :rehash-threshold)
764 Keyword :size specifies the number of keys likely to be inserted.
765 This number of entries can be inserted without enlarging the hash table.
767 Keyword :test can be `eq', `eql' (default) or `equal'.
768 Comparison between keys is done using this function.
769 If speed is important, consider using `eq'.
770 When storing strings in the hash table, you will likely need to use `equal'.
772 Keyword :type can be `non-weak' (default), `weak', `key-weak' or `value-weak'.
774 A weak hash table is one whose pointers do not count as GC referents:
775 for any key-value pair in the hash table, if the only remaining pointer
776 to either the key or the value is in a weak hash table, then the pair
777 will be removed from the hash table, and the key and value collected.
778 A non-weak hash table (or any other pointer) would prevent the object
779 from being collected.
781 A key-weak hash table is similar to a fully-weak hash table except that
782 a key-value pair will be removed only if the key remains unmarked
783 outside of weak hash tables. The pair will remain in the hash table if
784 the key is pointed to by something other than a weak hash table, even
787 A value-weak hash table is similar to a fully-weak hash table except
788 that a key-value pair will be removed only if the value remains
789 unmarked outside of weak hash tables. The pair will remain in the
790 hash table if the value is pointed to by something other than a weak
791 hash table, even if the key is not.
793 Keyword :rehash-size must be a float greater than 1.0, and specifies
794 the factor by which to increase the size of the hash table when enlarging.
796 Keyword :rehash-threshold must be a float between 0.0 and 1.0,
797 and specifies the load factor of the hash table which triggers enlarging.
800 (int nargs, Lisp_Object *args))
803 Lisp_Object size = Qnil;
804 Lisp_Object type = Qnil;
805 Lisp_Object test = Qnil;
806 Lisp_Object rehash_size = Qnil;
807 Lisp_Object rehash_threshold = Qnil;
811 Lisp_Object keyword, value;
814 if (!KEYWORDP (keyword))
815 signal_simple_error ("Invalid hash table property keyword", keyword);
817 signal_simple_error ("Hash table property requires a value", keyword);
821 if (EQ (keyword, Q_size)) size = value;
822 else if (EQ (keyword, Q_type)) type = value;
823 else if (EQ (keyword, Q_test)) test = value;
824 else if (EQ (keyword, Q_rehash_size)) rehash_size = value;
825 else if (EQ (keyword, Q_rehash_threshold)) rehash_threshold = value;
826 else signal_simple_error ("Invalid hash table property keyword", keyword);
829 #define VALIDATE_VAR(var) \
830 if (!NILP (var)) hash_table_##var##_validate (Q##var, var, ERROR_ME);
835 VALIDATE_VAR (rehash_size);
836 VALIDATE_VAR (rehash_threshold);
838 return make_general_lisp_hash_table
839 (decode_hash_table_size (size),
840 decode_hash_table_type (type),
841 decode_hash_table_test (test),
842 decode_hash_table_rehash_size (rehash_size),
843 decode_hash_table_rehash_threshold (rehash_threshold));
846 DEFUN ("copy-hash-table", Fcopy_hash_table, 1, 1, 0, /*
847 Return a new hash table containing the same keys and values as HASH-TABLE.
848 The keys and values will not themselves be copied.
852 CONST Lisp_Hash_Table *ht_old = xhash_table (hash_table);
853 Lisp_Hash_Table *ht = alloc_lcrecord_type (Lisp_Hash_Table, &lrecord_hash_table);
855 copy_lcrecord (ht, ht_old);
857 ht->hentries = xnew_array (hentry, ht_old->size + 1);
858 memcpy (ht->hentries, ht_old->hentries, (ht_old->size + 1) * sizeof (hentry));
860 XSETHASH_TABLE (hash_table, ht);
862 if (! EQ (ht->next_weak, Qunbound))
864 ht->next_weak = Vall_weak_hash_tables;
865 Vall_weak_hash_tables = hash_table;
872 enlarge_hash_table (Lisp_Hash_Table *ht)
874 hentry *old_entries, *new_entries, *old_sentinel, *new_sentinel, *e;
875 size_t old_size, new_size;
878 new_size = ht->size =
879 hash_table_size ((size_t) ((double) old_size * ht->rehash_size));
881 old_entries = ht->hentries;
883 ht->hentries = xnew_array (hentry, new_size + 1);
884 new_entries = ht->hentries;
886 old_sentinel = old_entries + old_size;
887 new_sentinel = new_entries + new_size;
889 for (e = new_entries; e <= new_sentinel; e++)
892 compute_hash_table_derived_values (ht);
894 for (e = old_entries; e < old_sentinel; e++)
895 if (!HENTRY_CLEAR_P (e))
897 hentry *probe = new_entries + HASH_CODE (e->key, ht);
898 LINEAR_PROBING_LOOP (probe, new_entries, new_size)
907 find_hentry (Lisp_Object key, CONST Lisp_Hash_Table *ht)
909 hash_table_test_function_t test_function = ht->test_function;
910 hentry *entries = ht->hentries;
911 hentry *probe = entries + HASH_CODE (key, ht);
913 LINEAR_PROBING_LOOP (probe, entries, ht->size)
914 if (KEYS_EQUAL_P (probe->key, key, test_function))
920 DEFUN ("gethash", Fgethash, 2, 3, 0, /*
921 Find hash value for KEY in HASH-TABLE.
922 If there is no corresponding value, return DEFAULT (which defaults to nil).
924 (key, hash_table, default_))
926 CONST Lisp_Hash_Table *ht = xhash_table (hash_table);
927 hentry *e = find_hentry (key, ht);
929 return HENTRY_CLEAR_P (e) ? default_ : e->value;
932 DEFUN ("puthash", Fputhash, 3, 3, 0, /*
933 Hash KEY to VALUE in HASH-TABLE.
935 (key, value, hash_table))
937 Lisp_Hash_Table *ht = xhash_table (hash_table);
938 hentry *e = find_hentry (key, ht);
940 if (!HENTRY_CLEAR_P (e))
941 return e->value = value;
946 if (++ht->count >= ht->rehash_count)
947 enlarge_hash_table (ht);
952 /* Remove hentry pointed at by PROBE.
953 Subsequent entries are removed and reinserted.
954 We don't use tombstones - too wasteful. */
956 remhash_1 (Lisp_Hash_Table *ht, hentry *entries, hentry *probe)
958 size_t size = ht->size;
959 CLEAR_HENTRY (probe++);
962 LINEAR_PROBING_LOOP (probe, entries, size)
964 Lisp_Object key = probe->key;
965 hentry *probe2 = entries + HASH_CODE (key, ht);
966 LINEAR_PROBING_LOOP (probe2, entries, size)
967 if (EQ (probe2->key, key))
968 /* hentry at probe doesn't need to move. */
969 goto continue_outer_loop;
970 /* Move hentry from probe to new home at probe2. */
972 CLEAR_HENTRY (probe);
973 continue_outer_loop: continue;
977 DEFUN ("remhash", Fremhash, 2, 2, 0, /*
978 Remove the entry for KEY from HASH-TABLE.
979 Do nothing if there is no entry for KEY in HASH-TABLE.
983 Lisp_Hash_Table *ht = xhash_table (hash_table);
984 hentry *e = find_hentry (key, ht);
986 if (HENTRY_CLEAR_P (e))
989 remhash_1 (ht, ht->hentries, e);
993 DEFUN ("clrhash", Fclrhash, 1, 1, 0, /*
994 Remove all entries from HASH-TABLE, leaving it empty.
998 Lisp_Hash_Table *ht = xhash_table (hash_table);
999 hentry *e, *sentinel;
1001 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1008 /************************************************************************/
1009 /* Accessor Functions */
1010 /************************************************************************/
1012 DEFUN ("hash-table-count", Fhash_table_count, 1, 1, 0, /*
1013 Return the number of entries in HASH-TABLE.
1017 return make_int (xhash_table (hash_table)->count);
1020 DEFUN ("hash-table-size", Fhash_table_size, 1, 1, 0, /*
1021 Return the size of HASH-TABLE.
1022 This is the current number of slots in HASH-TABLE, whether occupied or not.
1026 return make_int (xhash_table (hash_table)->size);
1029 DEFUN ("hash-table-type", Fhash_table_type, 1, 1, 0, /*
1030 Return the type of HASH-TABLE.
1031 This can be one of `non-weak', `weak', `key-weak' or `value-weak'.
1035 switch (xhash_table (hash_table)->type)
1037 case HASH_TABLE_WEAK: return Qweak;
1038 case HASH_TABLE_KEY_WEAK: return Qkey_weak;
1039 case HASH_TABLE_VALUE_WEAK: return Qvalue_weak;
1040 default: return Qnon_weak;
1044 DEFUN ("hash-table-test", Fhash_table_test, 1, 1, 0, /*
1045 Return the test function of HASH-TABLE.
1046 This can be one of `eq', `eql' or `equal'.
1050 hash_table_test_function_t fun = xhash_table (hash_table)->test_function;
1052 return (fun == lisp_object_eql_equal ? Qeql :
1053 fun == lisp_object_equal_equal ? Qequal :
1057 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size, 1, 1, 0, /*
1058 Return the current rehash size of HASH-TABLE.
1059 This is a float greater than 1.0; the factor by which HASH-TABLE
1060 is enlarged when the rehash threshold is exceeded.
1064 return make_float (xhash_table (hash_table)->rehash_size);
1067 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold, 1, 1, 0, /*
1068 Return the current rehash threshold of HASH-TABLE.
1069 This is a float between 0.0 and 1.0; the maximum `load factor' of HASH-TABLE,
1070 beyond which the HASH-TABLE is enlarged by rehashing.
1074 return make_float (hash_table_rehash_threshold (xhash_table (hash_table)));
1077 /************************************************************************/
1078 /* Mapping Functions */
1079 /************************************************************************/
1080 DEFUN ("maphash", Fmaphash, 2, 2, 0, /*
1081 Map FUNCTION over entries in HASH-TABLE, calling it with two args,
1082 each key and value in HASH-TABLE.
1084 FUNCTION may not modify HASH-TABLE, with the one exception that FUNCTION
1085 may remhash or puthash the entry currently being processed by FUNCTION.
1087 (function, hash_table))
1089 CONST Lisp_Hash_Table *ht = xhash_table (hash_table);
1090 CONST hentry *e, *sentinel;
1092 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1093 if (!HENTRY_CLEAR_P (e))
1095 Lisp_Object args[3], key;
1101 Ffuncall (countof (args), args);
1102 /* Has FUNCTION done a remhash? */
1103 if (!EQ (key, e->key) && !HENTRY_CLEAR_P (e))
1110 /* Map *C* function FUNCTION over the elements of a lisp hash table. */
1112 elisp_maphash (maphash_function_t function,
1113 Lisp_Object hash_table, void *extra_arg)
1115 CONST Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1116 CONST hentry *e, *sentinel;
1118 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1119 if (!HENTRY_CLEAR_P (e))
1124 if (function (key, e->value, extra_arg))
1126 /* Has FUNCTION done a remhash? */
1127 if (!EQ (key, e->key) && !HENTRY_CLEAR_P (e))
1132 /* Remove all elements of a lisp hash table satisfying *C* predicate PREDICATE. */
1134 elisp_map_remhash (maphash_function_t predicate,
1135 Lisp_Object hash_table, void *extra_arg)
1137 Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1138 hentry *e, *entries, *sentinel;
1140 for (e = entries = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1141 if (!HENTRY_CLEAR_P (e))
1144 if (predicate (e->key, e->value, extra_arg))
1146 remhash_1 (ht, entries, e);
1147 if (!HENTRY_CLEAR_P (e))
1154 /************************************************************************/
1155 /* garbage collecting weak hash tables */
1156 /************************************************************************/
1158 /* Complete the marking for semi-weak hash tables. */
1160 finish_marking_weak_hash_tables (int (*obj_marked_p) (Lisp_Object),
1161 void (*markobj) (Lisp_Object))
1163 Lisp_Object hash_table;
1166 for (hash_table = Vall_weak_hash_tables;
1167 !GC_NILP (hash_table);
1168 hash_table = XHASH_TABLE (hash_table)->next_weak)
1170 CONST Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1171 CONST hentry *e = ht->hentries;
1172 CONST hentry *sentinel = e + ht->size;
1174 if (! obj_marked_p (hash_table))
1175 /* The hash table is probably garbage. Ignore it. */
1178 /* Now, scan over all the pairs. For all pairs that are
1179 half-marked, we may need to mark the other half if we're
1180 keeping this pair. */
1181 #define MARK_OBJ(obj) \
1182 do { if (!obj_marked_p (obj)) markobj (obj), did_mark = 1; } while (0)
1186 case HASH_TABLE_KEY_WEAK:
1187 for (; e < sentinel; e++)
1188 if (!HENTRY_CLEAR_P (e))
1189 if (obj_marked_p (e->key))
1190 MARK_OBJ (e->value);
1193 case HASH_TABLE_VALUE_WEAK:
1194 for (; e < sentinel; e++)
1195 if (!HENTRY_CLEAR_P (e))
1196 if (obj_marked_p (e->value))
1200 case HASH_TABLE_KEY_CAR_WEAK:
1201 for (; e < sentinel; e++)
1202 if (!HENTRY_CLEAR_P (e))
1203 if (!CONSP (e->key) || obj_marked_p (XCAR (e->key)))
1206 MARK_OBJ (e->value);
1210 case HASH_TABLE_VALUE_CAR_WEAK:
1211 for (; e < sentinel; e++)
1212 if (!HENTRY_CLEAR_P (e))
1213 if (!CONSP (e->value) || obj_marked_p (XCAR (e->value)))
1216 MARK_OBJ (e->value);
1229 prune_weak_hash_tables (int (*obj_marked_p) (Lisp_Object))
1231 Lisp_Object hash_table, prev = Qnil;
1232 for (hash_table = Vall_weak_hash_tables;
1233 !GC_NILP (hash_table);
1234 hash_table = XHASH_TABLE (hash_table)->next_weak)
1236 if (! obj_marked_p (hash_table))
1238 /* This hash table itself is garbage. Remove it from the list. */
1240 Vall_weak_hash_tables = XHASH_TABLE (hash_table)->next_weak;
1242 XHASH_TABLE (prev)->next_weak = XHASH_TABLE (hash_table)->next_weak;
1246 /* Now, scan over all the pairs. Remove all of the pairs
1247 in which the key or value, or both, is unmarked
1248 (depending on the type of weak hash table). */
1249 Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1250 hentry *entries = ht->hentries;
1251 hentry *sentinel = entries + ht->size;
1254 for (e = entries; e < sentinel; e++)
1255 if (!HENTRY_CLEAR_P (e))
1258 if (!obj_marked_p (e->key) || !obj_marked_p (e->value))
1260 remhash_1 (ht, entries, e);
1261 if (!HENTRY_CLEAR_P (e))
1271 /* Return a hash value for an array of Lisp_Objects of size SIZE. */
1274 internal_array_hash (Lisp_Object *arr, int size, int depth)
1277 unsigned long hash = 0;
1281 for (i = 0; i < size; i++)
1282 hash = HASH2 (hash, internal_hash (arr[i], depth + 1));
1286 /* just pick five elements scattered throughout the array.
1287 A slightly better approach would be to offset by some
1288 noise factor from the points chosen below. */
1289 for (i = 0; i < 5; i++)
1290 hash = HASH2 (hash, internal_hash (arr[i*size/5], depth + 1));
1295 /* Return a hash value for a Lisp_Object. This is for use when hashing
1296 objects with the comparison being `equal' (for `eq', you can just
1297 use the Lisp_Object itself as the hash value). You need to make a
1298 tradeoff between the speed of the hash function and how good the
1299 hashing is. In particular, the hash function needs to be FAST,
1300 so you can't just traipse down the whole tree hashing everything
1301 together. Most of the time, objects will differ in the first
1302 few elements you hash. Thus, we only go to a short depth (5)
1303 and only hash at most 5 elements out of a vector. Theoretically
1304 we could still take 5^5 time (a big big number) to compute a
1305 hash, but practically this won't ever happen. */
1308 internal_hash (Lisp_Object obj, int depth)
1314 /* no point in worrying about tail recursion, since we're not
1316 return HASH2 (internal_hash (XCAR (obj), depth + 1),
1317 internal_hash (XCDR (obj), depth + 1));
1321 return hash_string (XSTRING_DATA (obj), XSTRING_LENGTH (obj));
1325 return HASH2 (XVECTOR_LENGTH (obj),
1326 internal_array_hash (XVECTOR_DATA (obj),
1327 XVECTOR_LENGTH (obj),
1332 CONST struct lrecord_implementation
1333 *imp = XRECORD_LHEADER_IMPLEMENTATION (obj);
1335 return imp->hash (obj, depth);
1338 return LISP_HASH (obj);
1342 xxDEFUN ("internal-hash-value", Finternal_hash_value, 1, 1, 0, /*
1343 Hash value of OBJECT. For debugging.
1344 The value is returned as (HIGH . LOW).
1348 /* This function is pretty 32bit-centric. */
1349 unsigned long hash = internal_hash (object, 0);
1350 return Fcons (hash >> 16, hash & 0xffff);
1355 /************************************************************************/
1356 /* initialization */
1357 /************************************************************************/
1360 syms_of_elhash (void)
1362 DEFSUBR (Fhash_table_p);
1363 DEFSUBR (Fmake_hash_table);
1364 DEFSUBR (Fcopy_hash_table);
1370 DEFSUBR (Fhash_table_count);
1371 DEFSUBR (Fhash_table_size);
1372 DEFSUBR (Fhash_table_rehash_size);
1373 DEFSUBR (Fhash_table_rehash_threshold);
1374 DEFSUBR (Fhash_table_type);
1375 DEFSUBR (Fhash_table_test);
1377 DEFSUBR (Finternal_hash_value);
1380 defsymbol (&Qhash_tablep, "hash-table-p");
1381 defsymbol (&Qhash_table, "hash-table");
1382 defsymbol (&Qhashtable, "hashtable");
1383 defsymbol (&Qweak, "weak");
1384 defsymbol (&Qkey_weak, "key-weak");
1385 defsymbol (&Qvalue_weak, "value-weak");
1386 defsymbol (&Qnon_weak, "non-weak");
1387 defsymbol (&Qrehash_size, "rehash-size");
1388 defsymbol (&Qrehash_threshold, "rehash-threshold");
1390 defkeyword (&Q_size, ":size");
1391 defkeyword (&Q_test, ":test");
1392 defkeyword (&Q_type, ":type");
1393 defkeyword (&Q_rehash_size, ":rehash-size");
1394 defkeyword (&Q_rehash_threshold, ":rehash-threshold");
1398 vars_of_elhash (void)
1400 /* This must NOT be staticpro'd */
1401 Vall_weak_hash_tables = Qnil;