1 /* Lisp interface to hash tables.
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 MERCHANTABILITY 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 EXFUN (Fmake_weak_hashtable, 2);
32 EXFUN (Fmake_key_weak_hashtable, 2);
33 EXFUN (Fmake_value_weak_hashtable, 2);
35 Lisp_Object Qhashtablep, Qhashtable;
36 Lisp_Object Qweak, Qkey_weak, Qvalue_weak, Qnon_weak;
38 #define LISP_OBJECTS_PER_HENTRY (sizeof (hentry) / sizeof (Lisp_Object))/* 2 */
42 struct lcrecord_header header;
43 unsigned int fullness;
44 unsigned long (*hash_function) (CONST void *);
45 int (*test_function) (CONST void *, CONST void *);
46 Lisp_Object zero_entry;
48 enum hashtable_type type; /* whether and how this hashtable is weak */
49 Lisp_Object next_weak; /* Used to chain together all of the weak
50 hashtables. Don't mark through this. */
53 static Lisp_Object Vall_weak_hashtables;
56 mark_hashtable (Lisp_Object obj, void (*markobj) (Lisp_Object))
58 struct hashtable *table = XHASHTABLE (obj);
60 if (table->type != HASHTABLE_NONWEAK)
62 /* If the table is weak, we don't want to mark the keys and values
63 (we scan over them after everything else has been marked,
64 and mark or remove them as necessary). Note that we will mark
65 the table->harray itself at the same time; it's hard to mark
66 that here without also marking its contents. */
69 ((markobj) (table->zero_entry));
73 /* Equality of hashtables. Two hashtables are equal when they are of
74 the same type and test function, they have the same number of
75 elements, and for each key in hashtable, the values are `equal'.
77 This is similar to Common Lisp `equalp' of hashtables, with the
78 difference that CL requires the keys to be compared with the test
79 function, which we don't do. Doing that would require consing, and
80 consing is bad idea in `equal'. Anyway, our method should provide
81 the same result -- if the keys are not equal according to test
82 function, then Fgethash() in hashtable_equal_mapper() will fail. */
83 struct hashtable_equal_closure
87 Lisp_Object other_table;
91 hashtable_equal_mapper (CONST void *key, void *contents, void *arg)
93 struct hashtable_equal_closure *closure =
94 (struct hashtable_equal_closure *)arg;
95 Lisp_Object keytem, valuetem;
96 Lisp_Object value_in_other;
98 CVOID_TO_LISP (keytem, key);
99 CVOID_TO_LISP (valuetem, contents);
100 /* Look up the key in the other hashtable, and compare the values. */
101 value_in_other = Fgethash (keytem, closure->other_table, Qunbound);
102 if (UNBOUNDP (value_in_other)
103 || !internal_equal (valuetem, value_in_other, closure->depth))
113 hashtable_equal (Lisp_Object t1, Lisp_Object t2, int depth)
115 struct hashtable_equal_closure closure;
116 struct hashtable *table1 = XHASHTABLE (t1);
117 struct hashtable *table2 = XHASHTABLE (t2);
119 /* The objects are `equal' if they are of the same type, so return 0
120 if types or test functions are not the same. Obviously, the
121 number of elements must be equal, too. #### table->fullness is
122 broken, so we cannot use it. */
123 if ((table1->test_function != table2->test_function)
124 || (table1->type != table2->type)
125 /*|| (table1->fullness != table2->fullness))*/
129 closure.depth = depth + 1;
131 closure.other_table = t2;
132 elisp_maphash (hashtable_equal_mapper, t1, &closure);
133 return closure.equal;
136 /* Printing hashtables.
138 This is non-trivial, because we use a readable structure-style
139 syntax for hashtables. This means that a typical hashtable will be
140 readably printed in the form of:
142 #s(hashtable size 2 data (key1 value1 key2 value2))
144 The supported keywords are `type' (non-weak (or nil), weak,
145 key-weak and value-weak), `test' (eql (or nil), eq or equal),
146 `size' (a natnum or nil) and `data' (a list).
148 If `print-readably' is non-nil, then a simpler syntax is used; for
151 #<hashtable size 2/13 data (key1 value1 key2 value2) 0x874d>
153 The data is truncated to four pairs, and the rest is shown with
154 `...'. This printer does not cons. */
156 struct print_hashtable_data_closure
158 EMACS_INT count; /* Used to implement truncation for
159 non-readable printing, as well as
160 to avoid the unnecessary space at
162 Lisp_Object printcharfun;
166 print_hashtable_data_mapper (CONST void *key, void *contents, void *arg)
168 Lisp_Object keytem, valuetem;
169 struct print_hashtable_data_closure *closure =
170 (struct print_hashtable_data_closure *)arg;
172 if (closure->count < 4 || print_readably)
174 CVOID_TO_LISP (keytem, key);
175 CVOID_TO_LISP (valuetem, contents);
178 write_c_string (" ", closure->printcharfun);
180 print_internal (keytem, closure->printcharfun, 1);
181 write_c_string (" ", closure->printcharfun);
182 print_internal (valuetem, closure->printcharfun, 1);
188 /* Print the data of the hashtable. This maps through a Lisp
189 hashtable and prints key/value pairs using PRINTCHARFUN. */
191 print_hashtable_data (Lisp_Object hashtable, Lisp_Object printcharfun)
193 struct print_hashtable_data_closure closure;
195 closure.printcharfun = printcharfun;
197 write_c_string (" data (", printcharfun);
198 elisp_maphash (print_hashtable_data_mapper, hashtable, &closure);
199 write_c_string ((!print_readably && closure.count > 4) ? " ...)" : ")",
203 /* Needed for tests. */
204 static int lisp_object_eql_equal (CONST void *x1, CONST void *x2);
205 static int lisp_object_equal_equal (CONST void *x1, CONST void *x2);
208 print_hashtable (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
210 struct hashtable *table = XHASHTABLE (obj);
213 write_c_string (print_readably ? "#s(hashtable" : "#<hashtable",
215 if (table->type != HASHTABLE_NONWEAK)
217 sprintf (buf, " type %s",
218 (table->type == HASHTABLE_WEAK ? "weak" :
219 table->type == HASHTABLE_KEY_WEAK ? "key-weak" :
220 table->type == HASHTABLE_VALUE_WEAK ? "value-weak" :
221 "you-d-better-not-see-this"));
222 write_c_string (buf, printcharfun);
224 /* These checks have a kludgy look to them, but they are safe. Due
225 to nature of hashing, you cannot use arbitrary test functions
227 if (!table->test_function)
228 write_c_string (" test eq", printcharfun);
229 else if (table->test_function == lisp_object_equal_equal)
230 write_c_string (" test equal", printcharfun);
231 else if (table->test_function == lisp_object_eql_equal)
235 if (table->fullness || !print_readably)
238 sprintf (buf, " size %u", table->fullness);
240 sprintf (buf, " size %u/%ld", table->fullness,
241 XVECTOR_LENGTH (table->harray) / LISP_OBJECTS_PER_HENTRY);
242 write_c_string (buf, printcharfun);
245 print_hashtable_data (obj, printcharfun);
247 write_c_string (")", printcharfun);
250 sprintf (buf, " 0x%x>", table->header.uid);
251 write_c_string (buf, printcharfun);
255 DEFINE_LRECORD_IMPLEMENTATION ("hashtable", hashtable,
256 mark_hashtable, print_hashtable, 0,
257 /* #### Implement hashtable_hash()! */
261 /* Pretty reading of hashtables.
263 Here we use the existing structures mechanism (which is,
264 unfortunately, pretty cumbersome) for validating and instantiating
265 the hashtables. The idea is that the side-effect of reading a
266 #s(hashtable PLIST) object is creation of a hashtable with desired
267 properties, and that the hashtable is returned. */
269 /* Validation functions: each keyword provides its own validation
270 function. The errors should maybe be continuable, but it is
271 unclear how this would cope with ERRB. */
273 hashtable_type_validate (Lisp_Object keyword, Lisp_Object value,
277 || EQ (value, Qnon_weak)
279 || EQ (value, Qkey_weak)
280 || EQ (value, Qvalue_weak)))
282 maybe_signal_simple_error ("Invalid hashtable type", value,
290 hashtable_test_validate (Lisp_Object keyword, Lisp_Object value,
296 || EQ (value, Qequal)))
298 maybe_signal_simple_error ("Invalid hashtable test", value,
306 hashtable_size_validate (Lisp_Object keyword, Lisp_Object value,
309 if (!NATNUMP (value))
311 maybe_signal_error (Qwrong_type_argument, list2 (Qnatnump, value),
319 hashtable_data_validate (Lisp_Object keyword, Lisp_Object value,
325 /* #### Doesn't respect ERRB! */
326 EXTERNAL_LIST_LOOP (tail, value)
333 maybe_signal_simple_error
334 ("Hashtable data must have alternating keyword/value pairs", value,
341 /* The actual instantiation of hashtable. This does practically no
342 error checking, because it relies on the fact that the paranoid
343 functions above have error-checked everything to the last details.
344 If this assumption is wrong, we will get a crash immediately (with
345 error-checking compiled in), and we'll know if there is a bug in
346 the structure mechanism. So there. */
348 hashtable_instantiate (Lisp_Object plist)
350 /* I'm not sure whether this can GC, but better safe than sorry. */
351 Lisp_Object hashtab = Qnil;
352 Lisp_Object type = Qnil, test = Qnil, size = Qnil, data = Qnil;
356 while (!NILP (plist))
358 Lisp_Object key, value;
359 key = XCAR (plist); plist = XCDR (plist);
360 value = XCAR (plist); plist = XCDR (plist);
362 if (EQ (key, Qtype)) type = value;
363 else if (EQ (key, Qtest)) test = value;
364 else if (EQ (key, Qsize)) size = value;
365 else if (EQ (key, Qdata)) data = value;
374 /* Divide by two, because data is a plist. */
375 size = make_int (XINT (Flength (data)) / 2);
377 /* Create the hashtable. */
378 if (EQ (type, Qnon_weak))
379 hashtab = Fmake_hashtable (size, test);
380 else if (EQ (type, Qweak))
381 hashtab = Fmake_weak_hashtable (size, test);
382 else if (EQ (type, Qkey_weak))
383 hashtab = Fmake_key_weak_hashtable (size, test);
384 else if (EQ (type, Qvalue_weak))
385 hashtab = Fmake_value_weak_hashtable (size, test);
389 /* And fill it with data. */
392 Lisp_Object key, value;
393 key = XCAR (data); data = XCDR (data);
394 value = XCAR (data); data = XCDR (data);
395 Fputhash (key, value, hashtab);
402 /* Initialize the hashtable as a structure type. This is called from
405 structure_type_create_hashtable (void)
407 struct structure_type *st;
409 st = define_structure_type (Qhashtable, 0, hashtable_instantiate);
410 define_structure_type_keyword (st, Qtype, hashtable_type_validate);
411 define_structure_type_keyword (st, Qtest, hashtable_test_validate);
412 define_structure_type_keyword (st, Qsize, hashtable_size_validate);
413 define_structure_type_keyword (st, Qdata, hashtable_data_validate);
416 /* Basic conversion and allocation functions. */
418 /* Create a C hashtable from the data in the Lisp hashtable. The
419 actual vector is not copied, nor are the keys or values copied. */
421 ht_copy_to_c (struct hashtable *ht, c_hashtable c_table)
423 int len = XVECTOR_LENGTH (ht->harray);
425 c_table->harray = (hentry *) XVECTOR_DATA (ht->harray);
426 c_table->zero_set = (!GC_UNBOUNDP (ht->zero_entry));
427 c_table->zero_entry = LISP_TO_VOID (ht->zero_entry);
428 #ifndef LRECORD_VECTOR
431 /* #### if alloc.c mark_object() changes, this must change too. */
432 /* barf gag retch. When a vector is marked, its len is
433 made less than 0. In the prune_weak_hashtables() stage,
434 we are called on vectors that are like this, and we must
436 assert (gc_in_progress);
440 c_table->size = len/LISP_OBJECTS_PER_HENTRY;
441 c_table->fullness = ht->fullness;
442 c_table->hash_function = ht->hash_function;
443 c_table->test_function = ht->test_function;
444 XSETHASHTABLE (c_table->elisp_table, ht);
448 ht_copy_from_c (c_hashtable c_table, struct hashtable *ht)
450 struct Lisp_Vector dummy;
451 /* C is truly hateful */
453 = ((char *) c_table->harray
454 - ((char *) &(dummy.contents[0]) - (char *) &dummy));
456 XSETVECTOR (ht->harray, vec_addr);
457 if (c_table->zero_set)
458 VOID_TO_LISP (ht->zero_entry, c_table->zero_entry);
460 ht->zero_entry = Qunbound;
461 ht->fullness = c_table->fullness;
465 static struct hashtable *
466 allocate_hashtable (void)
468 struct hashtable *table =
469 alloc_lcrecord_type (struct hashtable, lrecord_hashtable);
470 table->harray = Qnil;
471 table->zero_entry = Qunbound;
473 table->hash_function = 0;
474 table->test_function = 0;
479 elisp_hvector_malloc (unsigned int bytes, Lisp_Object table)
481 Lisp_Object new_vector;
482 struct hashtable *ht = XHASHTABLE (table);
484 assert (bytes > XVECTOR_LENGTH (ht->harray) * sizeof (Lisp_Object));
485 new_vector = make_vector ((bytes / sizeof (Lisp_Object)), Qnull_pointer);
486 return (void *) XVECTOR_DATA (new_vector);
490 elisp_hvector_free (void *ptr, Lisp_Object table)
492 struct hashtable *ht = XHASHTABLE (table);
493 #if defined (USE_ASSERTIONS) || defined (DEBUG_XEMACS)
494 Lisp_Object current_vector = ht->harray;
497 assert (((void *) XVECTOR_DATA (current_vector)) == ptr);
498 ht->harray = Qnil; /* Let GC do its job */
502 DEFUN ("hashtablep", Fhashtablep, 1, 1, 0, /*
503 Return t if OBJ is a hashtable, else nil.
507 return HASHTABLEP (obj) ? Qt : Qnil;
513 #if 0 /* I don't think these are needed any more.
514 If using the general lisp_object_equal_*() functions
515 causes efficiency problems, these can be resurrected. --ben */
516 /* equality and hash functions for Lisp strings */
518 lisp_string_equal (CONST void *x1, CONST void *x2)
520 /* This is wrong anyway. You can't use strcmp() on Lisp strings,
521 because they can contain zero characters. */
522 Lisp_Object str1, str2;
523 CVOID_TO_LISP (str1, x1);
524 CVOID_TO_LISP (str2, x2);
525 return !strcmp ((char *) XSTRING_DATA (str1), (char *) XSTRING_DATA (str2));
529 lisp_string_hash (CONST void *x)
532 CVOID_TO_LISP (str, x);
533 return hash_string (XSTRING_DATA (str), XSTRING_LENGTH (str));
539 lisp_object_eql_equal (CONST void *x1, CONST void *x2)
541 Lisp_Object obj1, obj2;
542 CVOID_TO_LISP (obj1, x1);
543 CVOID_TO_LISP (obj2, x2);
544 return FLOATP (obj1) ? internal_equal (obj1, obj2, 0) : EQ (obj1, obj2);
548 lisp_object_eql_hash (CONST void *x)
551 CVOID_TO_LISP (obj, x);
553 return internal_hash (obj, 0);
555 return LISP_HASH (obj);
559 lisp_object_equal_equal (CONST void *x1, CONST void *x2)
561 Lisp_Object obj1, obj2;
562 CVOID_TO_LISP (obj1, x1);
563 CVOID_TO_LISP (obj2, x2);
564 return internal_equal (obj1, obj2, 0);
568 lisp_object_equal_hash (CONST void *x)
571 CVOID_TO_LISP (obj, x);
572 return internal_hash (obj, 0);
576 make_lisp_hashtable (int size,
577 enum hashtable_type type,
578 enum hashtable_test_fun test)
581 struct hashtable *table = allocate_hashtable ();
583 table->harray = make_vector ((compute_harray_size (size)
584 * LISP_OBJECTS_PER_HENTRY),
589 table->test_function = NULL;
590 table->hash_function = NULL;
594 table->test_function = lisp_object_eql_equal;
595 table->hash_function = lisp_object_eql_hash;
598 case HASHTABLE_EQUAL:
599 table->test_function = lisp_object_equal_equal;
600 table->hash_function = lisp_object_equal_hash;
608 XSETHASHTABLE (result, table);
610 if (table->type != HASHTABLE_NONWEAK)
612 table->next_weak = Vall_weak_hashtables;
613 Vall_weak_hashtables = result;
616 table->next_weak = Qunbound;
621 static enum hashtable_test_fun
622 decode_hashtable_test_fun (Lisp_Object sym)
624 if (NILP (sym)) return HASHTABLE_EQL;
625 if (EQ (sym, Qeq)) return HASHTABLE_EQ;
626 if (EQ (sym, Qequal)) return HASHTABLE_EQUAL;
627 if (EQ (sym, Qeql)) return HASHTABLE_EQL;
629 signal_simple_error ("Invalid hashtable test function", sym);
630 return HASHTABLE_EQ; /* not reached */
633 DEFUN ("make-hashtable", Fmake_hashtable, 1, 2, 0, /*
634 Return a new hashtable object of initial size SIZE.
635 Comparison between keys is done with TEST-FUN, which must be one of
636 `eq', `eql', or `equal'. The default is `eql'; i.e. two keys must
637 be the same object (or have the same floating-point value, for floats)
638 to be considered equivalent.
640 See also `make-weak-hashtable', `make-key-weak-hashtable', and
641 `make-value-weak-hashtable'.
646 return make_lisp_hashtable (XINT (size), HASHTABLE_NONWEAK,
647 decode_hashtable_test_fun (test_fun));
650 DEFUN ("copy-hashtable", Fcopy_hashtable, 1, 1, 0, /*
651 Return a new hashtable containing the same keys and values as HASHTABLE.
652 The keys and values will not themselves be copied.
656 struct _C_hashtable old_htbl;
657 struct _C_hashtable new_htbl;
658 struct hashtable *old_ht;
659 struct hashtable *new_ht;
662 CHECK_HASHTABLE (hashtable);
663 old_ht = XHASHTABLE (hashtable);
664 ht_copy_to_c (old_ht, &old_htbl);
666 /* we can't just call Fmake_hashtable() here because that will make a
667 table that is slightly larger than the one we're trying to copy,
668 which will make copy_hash() blow up. */
669 new_ht = allocate_hashtable ();
670 new_ht->fullness = 0;
671 new_ht->zero_entry = Qunbound;
672 new_ht->hash_function = old_ht->hash_function;
673 new_ht->test_function = old_ht->test_function;
674 new_ht->harray = Fmake_vector (Flength (old_ht->harray), Qnull_pointer);
675 ht_copy_to_c (new_ht, &new_htbl);
676 copy_hash (&new_htbl, &old_htbl);
677 ht_copy_from_c (&new_htbl, new_ht);
678 new_ht->type = old_ht->type;
679 XSETHASHTABLE (result, new_ht);
681 if (UNBOUNDP (old_ht->next_weak))
682 new_ht->next_weak = Qunbound;
685 new_ht->next_weak = Vall_weak_hashtables;
686 Vall_weak_hashtables = result;
693 DEFUN ("gethash", Fgethash, 2, 3, 0, /*
694 Find hash value for KEY in HASHTABLE.
695 If there is no corresponding value, return DEFAULT (defaults to nil).
697 (key, hashtable, default_))
700 struct _C_hashtable htbl;
702 CHECK_HASHTABLE (hashtable);
703 ht_copy_to_c (XHASHTABLE (hashtable), &htbl);
704 if (gethash (LISP_TO_VOID (key), &htbl, &vval))
707 CVOID_TO_LISP (val, vval);
715 DEFUN ("remhash", Fremhash, 2, 2, 0, /*
716 Remove hash value for KEY in HASHTABLE.
720 struct _C_hashtable htbl;
721 CHECK_HASHTABLE (hashtable);
723 ht_copy_to_c (XHASHTABLE (hashtable), &htbl);
724 remhash (LISP_TO_VOID (key), &htbl);
725 ht_copy_from_c (&htbl, XHASHTABLE (hashtable));
730 DEFUN ("puthash", Fputhash, 3, 3, 0, /*
731 Hash KEY to VAL in HASHTABLE.
733 (key, val, hashtable))
735 struct hashtable *ht;
736 void *vkey = LISP_TO_VOID (key);
738 CHECK_HASHTABLE (hashtable);
739 ht = XHASHTABLE (hashtable);
741 ht->zero_entry = val;
744 struct gcpro gcpro1, gcpro2, gcpro3;
745 struct _C_hashtable htbl;
747 ht_copy_to_c (XHASHTABLE (hashtable), &htbl);
748 GCPRO3 (key, val, hashtable);
749 puthash (vkey, LISP_TO_VOID (val), &htbl);
750 ht_copy_from_c (&htbl, XHASHTABLE (hashtable));
756 DEFUN ("clrhash", Fclrhash, 1, 1, 0, /*
757 Remove all entries from HASHTABLE.
761 struct _C_hashtable htbl;
762 CHECK_HASHTABLE (hashtable);
763 ht_copy_to_c (XHASHTABLE (hashtable), &htbl);
765 ht_copy_from_c (&htbl, XHASHTABLE (hashtable));
769 DEFUN ("hashtable-fullness", Fhashtable_fullness, 1, 1, 0, /*
770 Return number of entries in HASHTABLE.
774 struct _C_hashtable htbl;
775 CHECK_HASHTABLE (hashtable);
776 ht_copy_to_c (XHASHTABLE (hashtable), &htbl);
777 return make_int (htbl.fullness);
780 DEFUN ("hashtable-type", Fhashtable_type, 1, 1, 0, /*
781 Return type of HASHTABLE.
782 This can be one of `non-weak', `weak', `key-weak' and `value-weak'.
786 CHECK_HASHTABLE (hashtable);
788 switch (XHASHTABLE (hashtable)->type)
790 case HASHTABLE_WEAK: return Qweak;
791 case HASHTABLE_KEY_WEAK: return Qkey_weak;
792 case HASHTABLE_VALUE_WEAK: return Qvalue_weak;
793 default: return Qnon_weak;
797 DEFUN ("hashtable-test-function", Fhashtable_test_function, 1, 1, 0, /*
798 Return test function of HASHTABLE.
799 This can be one of `eq', `eql' or `equal'.
803 int (*fun) (CONST void *, CONST void *);
805 CHECK_HASHTABLE (hashtable);
807 fun = XHASHTABLE (hashtable)->test_function;
809 if (fun == lisp_object_eql_equal)
811 else if (fun == lisp_object_equal_equal)
818 verify_function (Lisp_Object function, CONST char *description)
820 /* #### Unused DESCRIPTION? */
821 if (SYMBOLP (function))
826 function = indirect_function (function, 1);
828 if (SUBRP (function) || COMPILED_FUNCTIONP (function))
830 else if (CONSP (function))
832 Lisp_Object funcar = XCAR (function);
833 if ((SYMBOLP (funcar)) && (EQ (funcar, Qlambda) ||
834 EQ (funcar, Qautoload)))
837 signal_error (Qinvalid_function, list1 (function));
841 lisp_maphash_function (CONST void *void_key,
845 /* This function can GC */
846 Lisp_Object key, val, fn;
847 CVOID_TO_LISP (key, void_key);
848 VOID_TO_LISP (val, void_val);
849 VOID_TO_LISP (fn, void_fn);
850 call2 (fn, key, val);
855 DEFUN ("maphash", Fmaphash, 2, 2, 0, /*
856 Map FUNCTION over entries in HASHTABLE, calling it with two args,
857 each key and value in the table.
859 (function, hashtable))
861 struct _C_hashtable htbl;
862 struct gcpro gcpro1, gcpro2;
864 verify_function (function, GETTEXT ("hashtable mapping function"));
865 CHECK_HASHTABLE (hashtable);
866 ht_copy_to_c (XHASHTABLE (hashtable), &htbl);
867 GCPRO2 (hashtable, function);
868 maphash (lisp_maphash_function, &htbl, LISP_TO_VOID (function));
874 /* This function is for mapping a *C* function over the elements of a
878 elisp_maphash (int (*function) (CONST void *key, void *contents,
880 Lisp_Object hashtable, void *closure)
882 struct _C_hashtable htbl;
884 if (!gc_in_progress) CHECK_HASHTABLE (hashtable);
885 ht_copy_to_c (XHASHTABLE (hashtable), &htbl);
886 maphash (function, &htbl, closure);
890 elisp_map_remhash (remhash_predicate function, Lisp_Object hashtable,
893 struct _C_hashtable htbl;
895 if (!gc_in_progress) CHECK_HASHTABLE (hashtable);
896 ht_copy_to_c (XHASHTABLE (hashtable), &htbl);
897 map_remhash (function, &htbl, closure);
898 ht_copy_from_c (&htbl, XHASHTABLE (hashtable));
903 elisp_table_op (Lisp_Object table, generic_hashtable_op op, void *arg1,
904 void *arg2, void *arg3)
906 struct _C_hashtable htbl;
907 CHECK_HASHTABLE (table);
908 ht_copy_to_c (XHASHTABLE (table), &htbl);
909 (*op) (&htbl, arg1, arg2, arg3);
910 ht_copy_from_c (&htbl, XHASHTABLE (table));
916 DEFUN ("make-weak-hashtable", Fmake_weak_hashtable, 1, 2, 0, /*
917 Return a new fully weak hashtable object of initial size SIZE.
918 A weak hashtable is one whose pointers do not count as GC referents:
919 for any key-value pair in the hashtable, if the only remaining pointer
920 to either the key or the value is in a weak hash table, then the pair
921 will be removed from the table, and the key and value collected. A
922 non-weak hash table (or any other pointer) would prevent the object
923 from being collected.
925 You can also create semi-weak hashtables; see `make-key-weak-hashtable'
926 and `make-value-weak-hashtable'.
931 return make_lisp_hashtable (XINT (size), HASHTABLE_WEAK,
932 decode_hashtable_test_fun (test_fun));
935 DEFUN ("make-key-weak-hashtable", Fmake_key_weak_hashtable, 1, 2, 0, /*
936 Return a new key-weak hashtable object of initial size SIZE.
937 A key-weak hashtable is similar to a fully-weak hashtable (see
938 `make-weak-hashtable') except that a key-value pair will be removed
939 only if the key remains unmarked outside of weak hashtables. The pair
940 will remain in the hashtable if the key is pointed to by something other
941 than a weak hashtable, even if the value is not.
946 return make_lisp_hashtable (XINT (size), HASHTABLE_KEY_WEAK,
947 decode_hashtable_test_fun (test_fun));
950 DEFUN ("make-value-weak-hashtable", Fmake_value_weak_hashtable, 1, 2, 0, /*
951 Return a new value-weak hashtable object of initial size SIZE.
952 A value-weak hashtable is similar to a fully-weak hashtable (see
953 `make-weak-hashtable') except that a key-value pair will be removed only
954 if the value remains unmarked outside of weak hashtables. The pair will
955 remain in the hashtable if the value is pointed to by something other
956 than a weak hashtable, even if the key is not.
961 return make_lisp_hashtable (XINT (size), HASHTABLE_VALUE_WEAK,
962 decode_hashtable_test_fun (test_fun));
965 struct marking_closure
967 int (*obj_marked_p) (Lisp_Object);
968 void (*markobj) (Lisp_Object);
969 enum hashtable_type type;
974 marking_mapper (CONST void *key, void *contents, void *closure)
976 Lisp_Object keytem, valuetem;
977 struct marking_closure *fmh =
978 (struct marking_closure *) closure;
980 /* This function is called over each pair in the hashtable.
981 We complete the marking for semi-weak hashtables. */
982 CVOID_TO_LISP (keytem, key);
983 CVOID_TO_LISP (valuetem, contents);
987 case HASHTABLE_KEY_WEAK:
988 if ((fmh->obj_marked_p) (keytem) &&
989 !(fmh->obj_marked_p) (valuetem))
991 (fmh->markobj) (valuetem);
996 case HASHTABLE_VALUE_WEAK:
997 if ((fmh->obj_marked_p) (valuetem) &&
998 !(fmh->obj_marked_p) (keytem))
1000 (fmh->markobj) (keytem);
1005 case HASHTABLE_KEY_CAR_WEAK:
1006 if (!CONSP (keytem) || (fmh->obj_marked_p) (XCAR (keytem)))
1008 if (!(fmh->obj_marked_p) (keytem))
1010 (fmh->markobj) (keytem);
1013 if (!(fmh->obj_marked_p) (valuetem))
1015 (fmh->markobj) (valuetem);
1021 case HASHTABLE_VALUE_CAR_WEAK:
1022 if (!CONSP (valuetem) || (fmh->obj_marked_p) (XCAR (valuetem)))
1024 if (!(fmh->obj_marked_p) (keytem))
1026 (fmh->markobj) (keytem);
1029 if (!(fmh->obj_marked_p) (valuetem))
1031 (fmh->markobj) (valuetem);
1038 abort (); /* Huh? */
1045 finish_marking_weak_hashtables (int (*obj_marked_p) (Lisp_Object),
1046 void (*markobj) (Lisp_Object))
1051 for (rest = Vall_weak_hashtables;
1053 rest = XHASHTABLE (rest)->next_weak)
1055 enum hashtable_type type;
1057 if (! ((*obj_marked_p) (rest)))
1058 /* The hashtable is probably garbage. Ignore it. */
1060 type = XHASHTABLE (rest)->type;
1061 if (type == HASHTABLE_KEY_WEAK ||
1062 type == HASHTABLE_VALUE_WEAK ||
1063 type == HASHTABLE_KEY_CAR_WEAK ||
1064 type == HASHTABLE_VALUE_CAR_WEAK)
1066 struct marking_closure fmh;
1068 fmh.obj_marked_p = obj_marked_p;
1069 fmh.markobj = markobj;
1072 /* Now, scan over all the pairs. For all pairs that are
1073 half-marked, we may need to mark the other half if we're
1074 keeping this pair. */
1075 elisp_maphash (marking_mapper, rest, &fmh);
1080 /* #### If alloc.c mark_object changes, this must change also... */
1082 /* Now mark the vector itself. (We don't need to call markobj
1083 here because we know that everything *in* it is already marked,
1084 we just need to prevent the vector itself from disappearing.)
1085 (The remhash above has taken care of zero_entry.)
1087 struct Lisp_Vector *ptr = XVECTOR (XHASHTABLE (rest)->harray);
1088 #ifdef LRECORD_VECTOR
1089 if (! MARKED_RECORD_P(XHASHTABLE(rest)->harray))
1091 MARK_RECORD_HEADER(&(ptr->header.lheader));
1095 int len = vector_length (ptr);
1098 ptr->size = -1 - len;
1102 /* else it's already marked (remember, this function is iterated
1103 until marking stops) */
1110 struct pruning_closure
1112 int (*obj_marked_p) (Lisp_Object);
1116 pruning_mapper (CONST void *key, CONST void *contents, void *closure)
1118 Lisp_Object keytem, valuetem;
1119 struct pruning_closure *fmh = (struct pruning_closure *) closure;
1121 /* This function is called over each pair in the hashtable.
1122 We remove the pairs that aren't completely marked (everything
1123 that is going to stay ought to have been marked already
1124 by the finish_marking stage). */
1125 CVOID_TO_LISP (keytem, key);
1126 CVOID_TO_LISP (valuetem, contents);
1128 return ! ((*fmh->obj_marked_p) (keytem) &&
1129 (*fmh->obj_marked_p) (valuetem));
1133 prune_weak_hashtables (int (*obj_marked_p) (Lisp_Object))
1135 Lisp_Object rest, prev = Qnil;
1136 for (rest = Vall_weak_hashtables;
1138 rest = XHASHTABLE (rest)->next_weak)
1140 if (! ((*obj_marked_p) (rest)))
1142 /* This table itself is garbage. Remove it from the list. */
1144 Vall_weak_hashtables = XHASHTABLE (rest)->next_weak;
1146 XHASHTABLE (prev)->next_weak = XHASHTABLE (rest)->next_weak;
1150 struct pruning_closure fmh;
1151 fmh.obj_marked_p = obj_marked_p;
1152 /* Now, scan over all the pairs. Remove all of the pairs
1153 in which the key or value, or both, is unmarked
1154 (depending on the type of weak hashtable). */
1155 elisp_map_remhash (pruning_mapper, rest, &fmh);
1161 /* Return a hash value for an array of Lisp_Objects of size SIZE. */
1164 internal_array_hash (Lisp_Object *arr, int size, int depth)
1167 unsigned long hash = 0;
1171 for (i = 0; i < size; i++)
1172 hash = HASH2 (hash, internal_hash (arr[i], depth + 1));
1176 /* just pick five elements scattered throughout the array.
1177 A slightly better approach would be to offset by some
1178 noise factor from the points chosen below. */
1179 for (i = 0; i < 5; i++)
1180 hash = HASH2 (hash, internal_hash (arr[i*size/5], depth + 1));
1185 /* Return a hash value for a Lisp_Object. This is for use when hashing
1186 objects with the comparison being `equal' (for `eq', you can just
1187 use the Lisp_Object itself as the hash value). You need to make a
1188 tradeoff between the speed of the hash function and how good the
1189 hashing is. In particular, the hash function needs to be FAST,
1190 so you can't just traipse down the whole tree hashing everything
1191 together. Most of the time, objects will differ in the first
1192 few elements you hash. Thus, we only go to a short depth (5)
1193 and only hash at most 5 elements out of a vector. Theoretically
1194 we could still take 5^5 time (a big big number) to compute a
1195 hash, but practically this won't ever happen. */
1198 internal_hash (Lisp_Object obj, int depth)
1204 /* no point in worrying about tail recursion, since we're not
1206 return HASH2 (internal_hash (XCAR (obj), depth + 1),
1207 internal_hash (XCDR (obj), depth + 1));
1209 else if (STRINGP (obj))
1210 return hash_string (XSTRING_DATA (obj), XSTRING_LENGTH (obj));
1211 else if (VECTORP (obj))
1213 struct Lisp_Vector *v = XVECTOR (obj);
1214 return HASH2 (vector_length (v),
1215 internal_array_hash (v->contents, vector_length (v),
1218 else if (LRECORDP (obj))
1220 CONST struct lrecord_implementation
1221 *imp = XRECORD_LHEADER_IMPLEMENTATION (obj);
1223 return (imp->hash) (obj, depth);
1226 return LISP_HASH (obj);
1230 xxDEFUN ("internal-hash-value", Finternal_hash_value, 1, 1, 0, /*
1231 Hash value of OBJECT. For debugging.
1232 The value is returned as (HIGH . LOW).
1236 /* This function is pretty 32bit-centric. */
1237 unsigned long hash = internal_hash (object, 0);
1238 return Fcons (hash >> 16, hash & 0xffff);
1243 /************************************************************************/
1244 /* initialization */
1245 /************************************************************************/
1248 syms_of_elhash (void)
1250 DEFSUBR (Fmake_hashtable);
1251 DEFSUBR (Fcopy_hashtable);
1252 DEFSUBR (Fhashtablep);
1258 DEFSUBR (Fhashtable_fullness);
1259 DEFSUBR (Fhashtable_type);
1260 DEFSUBR (Fhashtable_test_function);
1261 DEFSUBR (Fmake_weak_hashtable);
1262 DEFSUBR (Fmake_key_weak_hashtable);
1263 DEFSUBR (Fmake_value_weak_hashtable);
1265 DEFSUBR (Finternal_hash_value);
1267 defsymbol (&Qhashtablep, "hashtablep");
1268 defsymbol (&Qhashtable, "hashtable");
1269 defsymbol (&Qweak, "weak");
1270 defsymbol (&Qkey_weak, "key-weak");
1271 defsymbol (&Qvalue_weak, "value-weak");
1272 defsymbol (&Qnon_weak, "non-weak");
1276 vars_of_elhash (void)
1278 /* This must NOT be staticpro'd */
1279 Vall_weak_hashtables = Qnil;