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, Qhashtable, Qhash_table;
31 Lisp_Object Qweak, Qkey_weak, Qvalue_weak, Qnon_weak;
32 static Lisp_Object Vall_weak_hash_tables;
33 static Lisp_Object Qrehash_size, Qrehash_threshold;
34 static Lisp_Object Q_size, Q_test, Q_type, Q_rehash_size, Q_rehash_threshold;
42 struct Lisp_Hash_Table
44 struct lcrecord_header header;
49 double rehash_threshold;
51 hash_table_hash_function_t hash_function;
52 hash_table_test_function_t test_function;
54 enum hash_table_type type; /* whether and how this hash table is weak */
55 Lisp_Object next_weak; /* Used to chain together all of the weak
56 hash tables. Don't mark through this. */
58 typedef struct Lisp_Hash_Table Lisp_Hash_Table;
60 #define HENTRY_CLEAR_P(hentry) ((*(EMACS_UINT*)(&((hentry)->key))) == 0)
61 #define CLEAR_HENTRY(hentry) ((*(EMACS_UINT*)(&((hentry)->key))) = 0)
63 #define HASH_TABLE_DEFAULT_SIZE 16
64 #define HASH_TABLE_DEFAULT_REHASH_SIZE 1.3
65 #define HASH_TABLE_MIN_SIZE 10
67 #define HASH_CODE(key, ht) \
68 (((((ht)->hash_function ? (ht)->hash_function (key) : LISP_HASH (key)) \
72 #define KEYS_EQUAL_P(key1, key2, testfun) \
73 (EQ ((key1), (key2)) || ((testfun) && (testfun) ((key1), (key2))))
75 #define LINEAR_PROBING_LOOP(probe, entries, size) \
77 !HENTRY_CLEAR_P (probe) || \
78 (probe == entries + size ? \
79 (probe = entries, !HENTRY_CLEAR_P (probe)) : 0); \
82 #ifndef ERROR_CHECK_HASH_TABLE
83 # ifdef ERROR_CHECK_TYPECHECK
84 # define ERROR_CHECK_HASH_TABLE 1
86 # define ERROR_CHECK_HASH_TABLE 0
90 #if ERROR_CHECK_HASH_TABLE
92 check_hash_table_invariants (Lisp_Hash_Table *ht)
94 assert (ht->count < ht->size);
95 assert (ht->count <= ht->rehash_count);
96 assert (ht->rehash_count < ht->size);
97 assert ((double) ht->count * ht->rehash_threshold - 1 <= (double) ht->rehash_count);
98 assert (HENTRY_CLEAR_P (ht->hentries + ht->size));
101 #define check_hash_table_invariants(ht)
104 /* We use linear probing instead of double hashing, despite its lack
105 of blessing by Knuth and company, because, as a result of the
106 increasing discrepancy between CPU speeds and memory speeds, cache
107 behavior is becoming increasingly important, e.g:
109 For a trivial loop, the penalty for non-sequential access of an array is:
110 - a factor of 3-4 on Pentium Pro 200 Mhz
111 - a factor of 10 on Ultrasparc 300 Mhz */
113 /* Return a suitable size for a hash table, with at least SIZE slots. */
115 hash_table_size (size_t requested_size)
117 /* Return some prime near, but greater than or equal to, SIZE.
118 Decades from the time of writing, someone will have a system large
119 enough that the list below will be too short... */
120 static CONST size_t primes [] =
122 19, 29, 41, 59, 79, 107, 149, 197, 263, 347, 457, 599, 787, 1031,
123 1361, 1777, 2333, 3037, 3967, 5167, 6719, 8737, 11369, 14783,
124 19219, 24989, 32491, 42257, 54941, 71429, 92861, 120721, 156941,
125 204047, 265271, 344857, 448321, 582821, 757693, 985003, 1280519,
126 1664681, 2164111, 2813353, 3657361, 4754591, 6180989, 8035301,
127 10445899, 13579681, 17653589, 22949669, 29834603, 38784989,
128 50420551, 65546729, 85210757, 110774011, 144006217, 187208107,
129 243370577, 316381771, 411296309, 534685237, 695090819, 903618083,
130 1174703521, 1527114613, 1985248999, 2580823717UL, 3355070839UL
132 /* We've heard of binary search. */
134 for (low = 0, high = countof (primes) - 1; high - low > 1;)
136 /* Loop Invariant: size < primes [high] */
137 int mid = (low + high) / 2;
138 if (primes [mid] < requested_size)
143 return primes [high];
147 #if 0 /* I don't think these are needed any more.
148 If using the general lisp_object_equal_*() functions
149 causes efficiency problems, these can be resurrected. --ben */
150 /* equality and hash functions for Lisp strings */
152 lisp_string_equal (Lisp_Object str1, Lisp_Object str2)
154 /* This is wrong anyway. You can't use strcmp() on Lisp strings,
155 because they can contain zero characters. */
156 return !strcmp ((char *) XSTRING_DATA (str1), (char *) XSTRING_DATA (str2));
160 lisp_string_hash (Lisp_Object obj)
162 return hash_string (XSTRING_DATA (str), XSTRING_LENGTH (str));
168 lisp_object_eql_equal (Lisp_Object obj1, Lisp_Object obj2)
170 return EQ (obj1, obj2) || (FLOATP (obj1) && internal_equal (obj1, obj2, 0));
174 lisp_object_eql_hash (Lisp_Object obj)
176 return FLOATP (obj) ? internal_hash (obj, 0) : LISP_HASH (obj);
180 lisp_object_equal_equal (Lisp_Object obj1, Lisp_Object obj2)
182 return internal_equal (obj1, obj2, 0);
186 lisp_object_equal_hash (Lisp_Object obj)
188 return internal_hash (obj, 0);
193 mark_hash_table (Lisp_Object obj, void (*markobj) (Lisp_Object))
195 Lisp_Hash_Table *ht = XHASH_TABLE (obj);
197 /* If the hash table is weak, we don't want to mark the keys and
198 values (we scan over them after everything else has been marked,
199 and mark or remove them as necessary). */
200 if (ht->type == HASH_TABLE_NON_WEAK)
202 hentry *e, *sentinel;
204 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
205 if (!HENTRY_CLEAR_P (e))
214 /* Equality of hash tables. Two hash tables are equal when they are of
215 the same type and test function, they have the same number of
216 elements, and for each key in the hash table, the values are `equal'.
218 This is similar to Common Lisp `equalp' of hash tables, with the
219 difference that CL requires the keys to be compared with the test
220 function, which we don't do. Doing that would require consing, and
221 consing is a bad idea in `equal'. Anyway, our method should provide
222 the same result -- if the keys are not equal according to the test
223 function, then Fgethash() in hash_table_equal_mapper() will fail. */
225 hash_table_equal (Lisp_Object hash_table1, Lisp_Object hash_table2, int depth)
227 Lisp_Hash_Table *ht1 = XHASH_TABLE (hash_table1);
228 Lisp_Hash_Table *ht2 = XHASH_TABLE (hash_table2);
229 hentry *e, *sentinel;
231 if ((ht1->test_function != ht2->test_function) ||
232 (ht1->type != ht2->type) ||
233 (ht1->count != ht2->count))
238 for (e = ht1->hentries, sentinel = e + ht1->size; e < sentinel; e++)
239 if (!HENTRY_CLEAR_P (e))
240 /* Look up the key in the other hash table, and compare the values. */
242 Lisp_Object value_in_other = Fgethash (e->key, hash_table2, Qunbound);
243 if (UNBOUNDP (value_in_other) ||
244 !internal_equal (e->value, value_in_other, depth))
245 return 0; /* Give up */
251 /* Printing hash tables.
253 This is non-trivial, because we use a readable structure-style
254 syntax for hash tables. This means that a typical hash table will be
255 readably printed in the form of:
257 #s(hash-table size 2 data (key1 value1 key2 value2))
259 The supported keywords are `type' (non-weak (or nil), weak,
260 key-weak and value-weak), `test' (eql (or nil), eq or equal),
261 `size' (a natnum or nil) and `data' (a list).
263 If `print-readably' is non-nil, then a simpler syntax is used; for
266 #<hash-table size 2/13 data (key1 value1 key2 value2) 0x874d>
268 The data is truncated to four pairs, and the rest is shown with
269 `...'. This printer does not cons. */
272 /* Print the data of the hash table. This maps through a Lisp
273 hash table and prints key/value pairs using PRINTCHARFUN. */
275 print_hash_table_data (Lisp_Hash_Table *ht, Lisp_Object printcharfun)
278 hentry *e, *sentinel;
280 write_c_string (" data (", printcharfun);
282 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
283 if (!HENTRY_CLEAR_P (e))
286 write_c_string (" ", printcharfun);
287 if (!print_readably && count > 3)
289 write_c_string ("...", printcharfun);
292 print_internal (e->key, printcharfun, 1);
293 write_c_string (" ", printcharfun);
294 print_internal (e->value, printcharfun, 1);
298 write_c_string (")", printcharfun);
302 print_hash_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
304 Lisp_Hash_Table *ht = XHASH_TABLE (obj);
307 write_c_string (print_readably ? "#s(hash-table" : "#<hash-table",
310 if (ht->type != HASH_TABLE_NON_WEAK)
312 sprintf (buf, " type %s",
313 (ht->type == HASH_TABLE_WEAK ? "weak" :
314 ht->type == HASH_TABLE_KEY_WEAK ? "key-weak" :
315 ht->type == HASH_TABLE_VALUE_WEAK ? "value-weak" :
316 "you-d-better-not-see-this"));
317 write_c_string (buf, printcharfun);
320 /* These checks have a kludgy look to them, but they are safe.
321 Due to nature of hashing, you cannot use arbitrary
322 test functions anyway. */
323 if (!ht->test_function)
324 write_c_string (" test eq", printcharfun);
325 else if (ht->test_function == lisp_object_equal_equal)
326 write_c_string (" test equal", printcharfun);
327 else if (ht->test_function == lisp_object_eql_equal)
332 if (ht->count || !print_readably)
335 sprintf (buf, " size %lu", (unsigned long) ht->count);
337 sprintf (buf, " size %lu/%lu",
338 (unsigned long) ht->count,
339 (unsigned long) ht->size);
340 write_c_string (buf, printcharfun);
344 print_hash_table_data (ht, printcharfun);
347 write_c_string (")", printcharfun);
350 sprintf (buf, " 0x%x>", ht->header.uid);
351 write_c_string (buf, printcharfun);
356 finalize_hash_table (void *header, int for_disksave)
360 Lisp_Hash_Table *ht = (Lisp_Hash_Table *) header;
362 xfree (ht->hentries);
367 DEFINE_LRECORD_IMPLEMENTATION ("hash-table", hash_table,
368 mark_hash_table, print_hash_table,
370 /* #### Implement hash_table_hash()! */
374 static Lisp_Hash_Table *
375 xhash_table (Lisp_Object hash_table)
378 CHECK_HASH_TABLE (hash_table);
379 check_hash_table_invariants (XHASH_TABLE (hash_table));
380 return XHASH_TABLE (hash_table);
384 /************************************************************************/
385 /* Creation of Hash Tables */
386 /************************************************************************/
388 /* Creation of hash tables, without error-checking. */
390 hash_table_rehash_threshold (Lisp_Hash_Table *ht)
393 ht->rehash_threshold > 0.0 ? ht->rehash_threshold :
394 ht->size > 4096 && !ht->test_function ? 0.7 : 0.6;
398 compute_hash_table_derived_values (Lisp_Hash_Table *ht)
400 ht->rehash_count = (size_t)
401 ((double) ht->size * hash_table_rehash_threshold (ht));
402 ht->golden = (size_t)
403 ((double) ht->size * (.6180339887 / (double) sizeof (Lisp_Object)));
407 make_general_lisp_hash_table (size_t size,
408 enum hash_table_type type,
409 enum hash_table_test test,
411 double rehash_threshold)
413 Lisp_Object hash_table;
414 Lisp_Hash_Table *ht = alloc_lcrecord_type (Lisp_Hash_Table, lrecord_hash_table);
417 ht->rehash_size = rehash_size;
418 ht->rehash_threshold = rehash_threshold;
423 ht->test_function = 0;
424 ht->hash_function = 0;
428 ht->test_function = lisp_object_eql_equal;
429 ht->hash_function = lisp_object_eql_hash;
432 case HASH_TABLE_EQUAL:
433 ht->test_function = lisp_object_equal_equal;
434 ht->hash_function = lisp_object_equal_hash;
441 if (ht->rehash_size <= 0.0)
442 ht->rehash_size = HASH_TABLE_DEFAULT_REHASH_SIZE;
443 if (size < HASH_TABLE_MIN_SIZE)
444 size = HASH_TABLE_MIN_SIZE;
445 if (rehash_threshold < 0.0)
446 rehash_threshold = 0.75;
448 hash_table_size ((size_t) ((double) size / hash_table_rehash_threshold (ht)) + 1);
450 compute_hash_table_derived_values (ht);
452 /* We leave room for one never-occupied sentinel hentry at the end. */
453 ht->hentries = xnew_array (hentry, ht->size + 1);
456 hentry *e, *sentinel;
457 for (e = ht->hentries, sentinel = e + ht->size; e <= sentinel; e++)
461 XSETHASH_TABLE (hash_table, ht);
463 if (type == HASH_TABLE_NON_WEAK)
464 ht->next_weak = Qunbound;
466 ht->next_weak = Vall_weak_hash_tables, Vall_weak_hash_tables = hash_table;
472 make_lisp_hash_table (size_t size,
473 enum hash_table_type type,
474 enum hash_table_test test)
476 return make_general_lisp_hash_table (size, type, test,
477 HASH_TABLE_DEFAULT_REHASH_SIZE, -1.0);
480 /* Pretty reading of hash tables.
482 Here we use the existing structures mechanism (which is,
483 unfortunately, pretty cumbersome) for validating and instantiating
484 the hash tables. The idea is that the side-effect of reading a
485 #s(hash-table PLIST) object is creation of a hash table with desired
486 properties, and that the hash table is returned. */
488 /* Validation functions: each keyword provides its own validation
489 function. The errors should maybe be continuable, but it is
490 unclear how this would cope with ERRB. */
492 hash_table_size_validate (Lisp_Object keyword, Lisp_Object value,
498 maybe_signal_error (Qwrong_type_argument, list2 (Qnatnump, value),
504 decode_hash_table_size (Lisp_Object obj)
506 return NILP (obj) ? HASH_TABLE_DEFAULT_SIZE : XINT (obj);
510 hash_table_type_validate (Lisp_Object keyword, Lisp_Object value,
513 if (EQ (value, Qnil)) return 1;
514 if (EQ (value, Qnon_weak)) return 1;
515 if (EQ (value, Qweak)) return 1;
516 if (EQ (value, Qkey_weak)) return 1;
517 if (EQ (value, Qvalue_weak)) return 1;
519 maybe_signal_simple_error ("Invalid hash table type",
520 value, Qhash_table, errb);
524 static enum hash_table_type
525 decode_hash_table_type (Lisp_Object obj)
527 if (EQ (obj, Qnil)) return HASH_TABLE_NON_WEAK;
528 if (EQ (obj, Qnon_weak)) return HASH_TABLE_NON_WEAK;
529 if (EQ (obj, Qweak)) return HASH_TABLE_WEAK;
530 if (EQ (obj, Qkey_weak)) return HASH_TABLE_KEY_WEAK;
531 if (EQ (obj, Qvalue_weak)) return HASH_TABLE_VALUE_WEAK;
533 signal_simple_error ("Invalid hash table type", obj);
534 return HASH_TABLE_NON_WEAK; /* not reached */
538 hash_table_test_validate (Lisp_Object keyword, Lisp_Object value,
541 if (EQ (value, Qnil)) return 1;
542 if (EQ (value, Qeq)) return 1;
543 if (EQ (value, Qequal)) return 1;
544 if (EQ (value, Qeql)) return 1;
546 maybe_signal_simple_error ("Invalid hash table test",
547 value, Qhash_table, errb);
551 static enum hash_table_test
552 decode_hash_table_test (Lisp_Object obj)
554 if (EQ (obj, Qnil)) return HASH_TABLE_EQL;
555 if (EQ (obj, Qeq)) return HASH_TABLE_EQ;
556 if (EQ (obj, Qequal)) return HASH_TABLE_EQUAL;
557 if (EQ (obj, Qeql)) return HASH_TABLE_EQL;
559 signal_simple_error ("Invalid hash table test", obj);
560 return HASH_TABLE_EQ; /* not reached */
564 hash_table_rehash_size_validate (Lisp_Object keyword, Lisp_Object value,
569 maybe_signal_error (Qwrong_type_argument, list2 (Qfloatp, value),
575 double rehash_size = XFLOAT_DATA (value);
576 if (rehash_size <= 1.0)
578 maybe_signal_simple_error
579 ("Hash table rehash size must be greater than 1.0",
580 value, Qhash_table, errb);
589 decode_hash_table_rehash_size (Lisp_Object rehash_size)
591 return NILP (rehash_size) ? -1.0 : XFLOAT_DATA (rehash_size);
595 hash_table_rehash_threshold_validate (Lisp_Object keyword, Lisp_Object value,
600 maybe_signal_error (Qwrong_type_argument, list2 (Qfloatp, value),
606 double rehash_threshold = XFLOAT_DATA (value);
607 if (rehash_threshold <= 0.0 || rehash_threshold >= 1.0)
609 maybe_signal_simple_error
610 ("Hash table rehash threshold must be between 0.0 and 1.0",
611 value, Qhash_table, errb);
620 decode_hash_table_rehash_threshold (Lisp_Object rehash_threshold)
622 return NILP (rehash_threshold) ? -1.0 : XFLOAT_DATA (rehash_threshold);
626 hash_table_data_validate (Lisp_Object keyword, Lisp_Object value,
631 GET_EXTERNAL_LIST_LENGTH (value, len);
635 maybe_signal_simple_error
636 ("Hash table data must have alternating key/value pairs",
637 value, Qhash_table, errb);
643 /* The actual instantiation of a hash table. This does practically no
644 error checking, because it relies on the fact that the paranoid
645 functions above have error-checked everything to the last details.
646 If this assumption is wrong, we will get a crash immediately (with
647 error-checking compiled in), and we'll know if there is a bug in
648 the structure mechanism. So there. */
650 hash_table_instantiate (Lisp_Object plist)
652 Lisp_Object hash_table;
653 Lisp_Object test = Qnil;
654 Lisp_Object type = Qnil;
655 Lisp_Object size = Qnil;
656 Lisp_Object data = Qnil;
657 Lisp_Object rehash_size = Qnil;
658 Lisp_Object rehash_threshold = Qnil;
660 while (!NILP (plist))
662 Lisp_Object key, value;
663 key = XCAR (plist); plist = XCDR (plist);
664 value = XCAR (plist); plist = XCDR (plist);
666 if (EQ (key, Qtest)) test = value;
667 else if (EQ (key, Qtype)) type = value;
668 else if (EQ (key, Qsize)) size = value;
669 else if (EQ (key, Qdata)) data = value;
670 else if (EQ (key, Qrehash_size)) rehash_size = value;
671 else if (EQ (key, Qrehash_threshold)) rehash_threshold = value;
676 /* Create the hash table. */
677 hash_table = make_general_lisp_hash_table
678 (decode_hash_table_size (size),
679 decode_hash_table_type (type),
680 decode_hash_table_test (test),
681 decode_hash_table_rehash_size (rehash_size),
682 decode_hash_table_rehash_threshold (rehash_threshold));
684 /* I'm not sure whether this can GC, but better safe than sorry. */
689 /* And fill it with data. */
692 Lisp_Object key, value;
693 key = XCAR (data); data = XCDR (data);
694 value = XCAR (data); data = XCDR (data);
695 Fputhash (key, value, hash_table);
704 structure_type_create_hash_table_structure_name (Lisp_Object structure_name)
706 struct structure_type *st;
708 st = define_structure_type (structure_name, 0, hash_table_instantiate);
709 define_structure_type_keyword (st, Qsize, hash_table_size_validate);
710 define_structure_type_keyword (st, Qtest, hash_table_test_validate);
711 define_structure_type_keyword (st, Qtype, hash_table_type_validate);
712 define_structure_type_keyword (st, Qdata, hash_table_data_validate);
713 define_structure_type_keyword (st, Qrehash_size, hash_table_rehash_size_validate);
714 define_structure_type_keyword (st, Qrehash_threshold, hash_table_rehash_threshold_validate);
717 /* Create a built-in Lisp structure type named `hash-table'.
718 We make #s(hashtable ...) equivalent to #s(hash-table ...),
719 for backward comptabibility.
720 This is called from emacs.c. */
722 structure_type_create_hash_table (void)
724 structure_type_create_hash_table_structure_name (Qhash_table);
725 structure_type_create_hash_table_structure_name (Qhashtable); /* compat */
729 /************************************************************************/
730 /* Definition of Lisp-visible methods */
731 /************************************************************************/
733 DEFUN ("hash-table-p", Fhash_table_p, 1, 1, 0, /*
734 Return t if OBJECT is a hash table, else nil.
738 return HASH_TABLEP (object) ? Qt : Qnil;
741 DEFUN ("make-hash-table", Fmake_hash_table, 0, MANY, 0, /*
742 Return a new empty hash table object.
743 Use Common Lisp style keywords to specify hash table properties.
744 (make-hash-table &key :size :test :type :rehash-size :rehash-threshold)
746 Keyword :size specifies the number of keys likely to be inserted.
747 This number of entries can be inserted without enlarging the hash table.
749 Keyword :test can be `eq', `eql' (default) or `equal'.
750 Comparison between keys is done using this function.
751 If speed is important, consider using `eq'.
752 When storing strings in the hash table, you will likely need to use `equal'.
754 Keyword :type can be `non-weak' (default), `weak', `key-weak' or `value-weak'.
756 A weak hash table is one whose pointers do not count as GC referents:
757 for any key-value pair in the hash table, if the only remaining pointer
758 to either the key or the value is in a weak hash table, then the pair
759 will be removed from the hash table, and the key and value collected.
760 A non-weak hash table (or any other pointer) would prevent the object
761 from being collected.
763 A key-weak hash table is similar to a fully-weak hash table except that
764 a key-value pair will be removed only if the key remains unmarked
765 outside of weak hash tables. The pair will remain in the hash table if
766 the key is pointed to by something other than a weak hash table, even
769 A value-weak hash table is similar to a fully-weak hash table except
770 that a key-value pair will be removed only if the value remains
771 unmarked outside of weak hash tables. The pair will remain in the
772 hash table if the value is pointed to by something other than a weak
773 hash table, even if the key is not.
775 Keyword :rehash-size must be a float greater than 1.0, and specifies
776 the factor by which to increase the size of the hash table when enlarging.
778 Keyword :rehash-threshold must be a float between 0.0 and 1.0,
779 and specifies the load factor of the hash table which triggers enlarging.
782 (int nargs, Lisp_Object *args))
785 Lisp_Object size = Qnil;
786 Lisp_Object type = Qnil;
787 Lisp_Object test = Qnil;
788 Lisp_Object rehash_size = Qnil;
789 Lisp_Object rehash_threshold = Qnil;
793 Lisp_Object keyword, value;
796 if (!KEYWORDP (keyword))
797 signal_simple_error ("Invalid hash table property keyword", keyword);
799 signal_simple_error ("Hash table property requires a value", keyword);
803 if (EQ (keyword, Q_size)) size = value;
804 else if (EQ (keyword, Q_type)) type = value;
805 else if (EQ (keyword, Q_test)) test = value;
806 else if (EQ (keyword, Q_rehash_size)) rehash_size = value;
807 else if (EQ (keyword, Q_rehash_threshold)) rehash_threshold = value;
808 else signal_simple_error ("Invalid hash table property keyword", keyword);
811 #define VALIDATE_VAR(var) \
812 if (!NILP (var)) hash_table_##var##_validate (Q##var, var, ERROR_ME);
817 VALIDATE_VAR (rehash_size);
818 VALIDATE_VAR (rehash_threshold);
820 return make_general_lisp_hash_table
821 (decode_hash_table_size (size),
822 decode_hash_table_type (type),
823 decode_hash_table_test (test),
824 decode_hash_table_rehash_size (rehash_size),
825 decode_hash_table_rehash_threshold (rehash_threshold));
828 DEFUN ("copy-hash-table", Fcopy_hash_table, 1, 1, 0, /*
829 Return a new hash table containing the same keys and values as HASH-TABLE.
830 The keys and values will not themselves be copied.
834 CONST Lisp_Hash_Table *ht_old = xhash_table (hash_table);
835 Lisp_Hash_Table *ht = alloc_lcrecord_type (Lisp_Hash_Table, lrecord_hash_table);
837 copy_lcrecord (ht, ht_old);
839 ht->hentries = xnew_array (hentry, ht_old->size + 1);
840 memcpy (ht->hentries, ht_old->hentries, (ht_old->size + 1) * sizeof (hentry));
842 XSETHASH_TABLE (hash_table, ht);
844 if (! EQ (ht->next_weak, Qunbound))
846 ht->next_weak = Vall_weak_hash_tables;
847 Vall_weak_hash_tables = hash_table;
854 enlarge_hash_table (Lisp_Hash_Table *ht)
856 hentry *old_entries, *new_entries, *old_sentinel, *new_sentinel, *e;
857 size_t old_size, new_size;
860 new_size = ht->size =
861 hash_table_size ((size_t) ((double) old_size * ht->rehash_size));
863 old_entries = ht->hentries;
865 ht->hentries = xnew_array (hentry, new_size + 1);
866 new_entries = ht->hentries;
868 old_sentinel = old_entries + old_size;
869 new_sentinel = new_entries + new_size;
871 for (e = new_entries; e <= new_sentinel; e++)
874 compute_hash_table_derived_values (ht);
876 for (e = old_entries; e < old_sentinel; e++)
877 if (!HENTRY_CLEAR_P (e))
879 hentry *probe = new_entries + HASH_CODE (e->key, ht);
880 LINEAR_PROBING_LOOP (probe, new_entries, new_size)
889 find_hentry (Lisp_Object key, CONST Lisp_Hash_Table *ht)
891 hash_table_test_function_t test_function = ht->test_function;
892 hentry *entries = ht->hentries;
893 hentry *probe = entries + HASH_CODE (key, ht);
895 LINEAR_PROBING_LOOP (probe, entries, ht->size)
896 if (KEYS_EQUAL_P (probe->key, key, test_function))
902 DEFUN ("gethash", Fgethash, 2, 3, 0, /*
903 Find hash value for KEY in HASH-TABLE.
904 If there is no corresponding value, return DEFAULT (which defaults to nil).
906 (key, hash_table, default_))
908 CONST Lisp_Hash_Table *ht = xhash_table (hash_table);
909 hentry *e = find_hentry (key, ht);
911 return HENTRY_CLEAR_P (e) ? default_ : e->value;
914 DEFUN ("puthash", Fputhash, 3, 3, 0, /*
915 Hash KEY to VALUE in HASH-TABLE.
917 (key, value, hash_table))
919 Lisp_Hash_Table *ht = xhash_table (hash_table);
920 hentry *e = find_hentry (key, ht);
922 if (!HENTRY_CLEAR_P (e))
923 return e->value = value;
928 if (++ht->count >= ht->rehash_count)
929 enlarge_hash_table (ht);
934 /* Remove hentry pointed at by PROBE.
935 Subsequent entries are removed and reinserted.
936 We don't use tombstones - too wasteful. */
938 remhash_1 (Lisp_Hash_Table *ht, hentry *entries, hentry *probe)
940 size_t size = ht->size;
941 CLEAR_HENTRY (probe++);
944 LINEAR_PROBING_LOOP (probe, entries, size)
946 Lisp_Object key = probe->key;
947 hentry *probe2 = entries + HASH_CODE (key, ht);
948 LINEAR_PROBING_LOOP (probe2, entries, size)
949 if (EQ (probe2->key, key))
950 /* hentry at probe doesn't need to move. */
951 goto continue_outer_loop;
952 /* Move hentry from probe to new home at probe2. */
954 CLEAR_HENTRY (probe);
955 continue_outer_loop: continue;
959 DEFUN ("remhash", Fremhash, 2, 2, 0, /*
960 Remove the entry for KEY from HASH-TABLE.
961 Do nothing if there is no entry for KEY in HASH-TABLE.
965 Lisp_Hash_Table *ht = xhash_table (hash_table);
966 hentry *e = find_hentry (key, ht);
968 if (HENTRY_CLEAR_P (e))
971 remhash_1 (ht, ht->hentries, e);
975 DEFUN ("clrhash", Fclrhash, 1, 1, 0, /*
976 Remove all entries from HASH-TABLE, leaving it empty.
980 Lisp_Hash_Table *ht = xhash_table (hash_table);
981 hentry *e, *sentinel;
983 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
990 /************************************************************************/
991 /* Accessor Functions */
992 /************************************************************************/
994 DEFUN ("hash-table-count", Fhash_table_count, 1, 1, 0, /*
995 Return the number of entries in HASH-TABLE.
999 return make_int (xhash_table (hash_table)->count);
1002 DEFUN ("hash-table-size", Fhash_table_size, 1, 1, 0, /*
1003 Return the size of HASH-TABLE.
1004 This is the current number of slots in HASH-TABLE, whether occupied or not.
1008 return make_int (xhash_table (hash_table)->size);
1011 DEFUN ("hash-table-type", Fhash_table_type, 1, 1, 0, /*
1012 Return the type of HASH-TABLE.
1013 This can be one of `non-weak', `weak', `key-weak' or `value-weak'.
1017 switch (xhash_table (hash_table)->type)
1019 case HASH_TABLE_WEAK: return Qweak;
1020 case HASH_TABLE_KEY_WEAK: return Qkey_weak;
1021 case HASH_TABLE_VALUE_WEAK: return Qvalue_weak;
1022 default: return Qnon_weak;
1026 DEFUN ("hash-table-test", Fhash_table_test, 1, 1, 0, /*
1027 Return the test function of HASH-TABLE.
1028 This can be one of `eq', `eql' or `equal'.
1032 hash_table_test_function_t fun = xhash_table (hash_table)->test_function;
1034 return (fun == lisp_object_eql_equal ? Qeql :
1035 fun == lisp_object_equal_equal ? Qequal :
1039 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size, 1, 1, 0, /*
1040 Return the current rehash size of HASH-TABLE.
1041 This is a float greater than 1.0; the factor by which HASH-TABLE
1042 is enlarged when the rehash threshold is exceeded.
1046 return make_float (xhash_table (hash_table)->rehash_size);
1049 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold, 1, 1, 0, /*
1050 Return the current rehash threshold of HASH-TABLE.
1051 This is a float between 0.0 and 1.0; the maximum `load factor' of HASH-TABLE,
1052 beyond which the HASH-TABLE is enlarged by rehashing.
1056 return make_float (hash_table_rehash_threshold (xhash_table (hash_table)));
1059 /************************************************************************/
1060 /* Mapping Functions */
1061 /************************************************************************/
1062 DEFUN ("maphash", Fmaphash, 2, 2, 0, /*
1063 Map FUNCTION over entries in HASH-TABLE, calling it with two args,
1064 each key and value in HASH-TABLE.
1066 FUNCTION may not modify HASH-TABLE, with the one exception that FUNCTION
1067 may remhash or puthash the entry currently being processed by FUNCTION.
1069 (function, hash_table))
1071 CONST Lisp_Hash_Table *ht = xhash_table (hash_table);
1072 CONST hentry *e, *sentinel;
1074 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1075 if (!HENTRY_CLEAR_P (e))
1077 Lisp_Object args[3], key;
1083 Ffuncall (countof (args), args);
1084 /* Has FUNCTION done a remhash? */
1085 if (!EQ (key, e->key) && !HENTRY_CLEAR_P (e))
1092 /* Map *C* function FUNCTION over the elements of a lisp hash table. */
1094 elisp_maphash (maphash_function_t function,
1095 Lisp_Object hash_table, void *extra_arg)
1097 CONST Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1098 CONST hentry *e, *sentinel;
1100 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1101 if (!HENTRY_CLEAR_P (e))
1106 if (function (key, e->value, extra_arg))
1108 /* Has FUNCTION done a remhash? */
1109 if (!EQ (key, e->key) && !HENTRY_CLEAR_P (e))
1114 /* Remove all elements of a lisp hash table satisfying *C* predicate PREDICATE. */
1116 elisp_map_remhash (maphash_function_t predicate,
1117 Lisp_Object hash_table, void *extra_arg)
1119 Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1120 hentry *e, *entries, *sentinel;
1122 for (e = entries = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1123 if (!HENTRY_CLEAR_P (e))
1126 if (predicate (e->key, e->value, extra_arg))
1128 remhash_1 (ht, entries, e);
1129 if (!HENTRY_CLEAR_P (e))
1136 /************************************************************************/
1137 /* garbage collecting weak hash tables */
1138 /************************************************************************/
1140 /* Complete the marking for semi-weak hash tables. */
1142 finish_marking_weak_hash_tables (int (*obj_marked_p) (Lisp_Object),
1143 void (*markobj) (Lisp_Object))
1145 Lisp_Object hash_table;
1148 for (hash_table = Vall_weak_hash_tables;
1149 !GC_NILP (hash_table);
1150 hash_table = XHASH_TABLE (hash_table)->next_weak)
1152 CONST Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1153 CONST hentry *e = ht->hentries;
1154 CONST hentry *sentinel = e + ht->size;
1156 if (! obj_marked_p (hash_table))
1157 /* The hash table is probably garbage. Ignore it. */
1160 /* Now, scan over all the pairs. For all pairs that are
1161 half-marked, we may need to mark the other half if we're
1162 keeping this pair. */
1163 #define MARK_OBJ(obj) \
1164 do { if (!obj_marked_p (obj)) markobj (obj), did_mark = 1; } while (0)
1168 case HASH_TABLE_KEY_WEAK:
1169 for (; e < sentinel; e++)
1170 if (!HENTRY_CLEAR_P (e))
1171 if (obj_marked_p (e->key))
1172 MARK_OBJ (e->value);
1175 case HASH_TABLE_VALUE_WEAK:
1176 for (; e < sentinel; e++)
1177 if (!HENTRY_CLEAR_P (e))
1178 if (obj_marked_p (e->value))
1182 case HASH_TABLE_KEY_CAR_WEAK:
1183 for (; e < sentinel; e++)
1184 if (!HENTRY_CLEAR_P (e))
1185 if (!CONSP (e->key) || obj_marked_p (XCAR (e->key)))
1188 MARK_OBJ (e->value);
1192 case HASH_TABLE_VALUE_CAR_WEAK:
1193 for (; e < sentinel; e++)
1194 if (!HENTRY_CLEAR_P (e))
1195 if (!CONSP (e->value) || obj_marked_p (XCAR (e->value)))
1198 MARK_OBJ (e->value);
1211 prune_weak_hash_tables (int (*obj_marked_p) (Lisp_Object))
1213 Lisp_Object hash_table, prev = Qnil;
1214 for (hash_table = Vall_weak_hash_tables;
1215 !GC_NILP (hash_table);
1216 hash_table = XHASH_TABLE (hash_table)->next_weak)
1218 if (! obj_marked_p (hash_table))
1220 /* This hash table itself is garbage. Remove it from the list. */
1222 Vall_weak_hash_tables = XHASH_TABLE (hash_table)->next_weak;
1224 XHASH_TABLE (prev)->next_weak = XHASH_TABLE (hash_table)->next_weak;
1228 /* Now, scan over all the pairs. Remove all of the pairs
1229 in which the key or value, or both, is unmarked
1230 (depending on the type of weak hash table). */
1231 Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1232 hentry *entries = ht->hentries;
1233 hentry *sentinel = entries + ht->size;
1236 for (e = entries; e < sentinel; e++)
1237 if (!HENTRY_CLEAR_P (e))
1240 if (!obj_marked_p (e->key) || !obj_marked_p (e->value))
1242 remhash_1 (ht, entries, e);
1243 if (!HENTRY_CLEAR_P (e))
1253 /* Return a hash value for an array of Lisp_Objects of size SIZE. */
1256 internal_array_hash (Lisp_Object *arr, int size, int depth)
1259 unsigned long hash = 0;
1263 for (i = 0; i < size; i++)
1264 hash = HASH2 (hash, internal_hash (arr[i], depth + 1));
1268 /* just pick five elements scattered throughout the array.
1269 A slightly better approach would be to offset by some
1270 noise factor from the points chosen below. */
1271 for (i = 0; i < 5; i++)
1272 hash = HASH2 (hash, internal_hash (arr[i*size/5], depth + 1));
1277 /* Return a hash value for a Lisp_Object. This is for use when hashing
1278 objects with the comparison being `equal' (for `eq', you can just
1279 use the Lisp_Object itself as the hash value). You need to make a
1280 tradeoff between the speed of the hash function and how good the
1281 hashing is. In particular, the hash function needs to be FAST,
1282 so you can't just traipse down the whole tree hashing everything
1283 together. Most of the time, objects will differ in the first
1284 few elements you hash. Thus, we only go to a short depth (5)
1285 and only hash at most 5 elements out of a vector. Theoretically
1286 we could still take 5^5 time (a big big number) to compute a
1287 hash, but practically this won't ever happen. */
1290 internal_hash (Lisp_Object obj, int depth)
1296 /* no point in worrying about tail recursion, since we're not
1298 return HASH2 (internal_hash (XCAR (obj), depth + 1),
1299 internal_hash (XCDR (obj), depth + 1));
1303 return hash_string (XSTRING_DATA (obj), XSTRING_LENGTH (obj));
1307 return HASH2 (XVECTOR_LENGTH (obj),
1308 internal_array_hash (XVECTOR_DATA (obj),
1309 XVECTOR_LENGTH (obj),
1314 CONST struct lrecord_implementation
1315 *imp = XRECORD_LHEADER_IMPLEMENTATION (obj);
1317 return imp->hash (obj, depth);
1320 return LISP_HASH (obj);
1324 xxDEFUN ("internal-hash-value", Finternal_hash_value, 1, 1, 0, /*
1325 Hash value of OBJECT. For debugging.
1326 The value is returned as (HIGH . LOW).
1330 /* This function is pretty 32bit-centric. */
1331 unsigned long hash = internal_hash (object, 0);
1332 return Fcons (hash >> 16, hash & 0xffff);
1337 /************************************************************************/
1338 /* initialization */
1339 /************************************************************************/
1342 syms_of_elhash (void)
1344 DEFSUBR (Fhash_table_p);
1345 DEFSUBR (Fmake_hash_table);
1346 DEFSUBR (Fcopy_hash_table);
1352 DEFSUBR (Fhash_table_count);
1353 DEFSUBR (Fhash_table_size);
1354 DEFSUBR (Fhash_table_rehash_size);
1355 DEFSUBR (Fhash_table_rehash_threshold);
1356 DEFSUBR (Fhash_table_type);
1357 DEFSUBR (Fhash_table_test);
1359 DEFSUBR (Finternal_hash_value);
1362 defsymbol (&Qhash_tablep, "hash-table-p");
1363 defsymbol (&Qhash_table, "hash-table");
1364 defsymbol (&Qhashtable, "hashtable");
1365 defsymbol (&Qweak, "weak");
1366 defsymbol (&Qkey_weak, "key-weak");
1367 defsymbol (&Qvalue_weak, "value-weak");
1368 defsymbol (&Qnon_weak, "non-weak");
1369 defsymbol (&Qrehash_size, "rehash-size");
1370 defsymbol (&Qrehash_threshold, "rehash-threshold");
1372 defkeyword (&Q_size, ":size");
1373 defkeyword (&Q_test, ":test");
1374 defkeyword (&Q_type, ":type");
1375 defkeyword (&Q_rehash_size, ":rehash-size");
1376 defkeyword (&Q_rehash_threshold, ":rehash-threshold");
1380 vars_of_elhash (void)
1382 /* This must NOT be staticpro'd */
1383 Vall_weak_hash_tables = Qnil;