Mercurial > hg > xemacs-beta

comparison src/elhash.c @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children ac2d302a0011
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 /* Lisp interface to hash tables.
2 Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
3 Copyright (C) 1995, 1996 Ben Wing.
4
5 This file is part of XEmacs.
6
7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 2, or (at your option) any
10 later version.
11
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with XEmacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
21
22 /* Synched up with: Not in FSF. */
23
24 #include <config.h>
25 #include "lisp.h"
26 #include "hash.h"
27 #include "elhash.h"
28 #include "bytecode.h"
29
30 Lisp_Object Qhashtablep;
31
32 #define LISP_OBJECTS_PER_HENTRY (sizeof (hentry) / sizeof (Lisp_Object))/* 2 */
33
34 struct hashtable_struct
35 {
36 struct lcrecord_header header;
37 unsigned int fullness;
38 unsigned long (*hash_function) (CONST void *);
39 int (*test_function) (CONST void *, CONST void *);
40 Lisp_Object zero_entry;
41 Lisp_Object harray;
42 enum hashtable_type type; /* whether and how this hashtable is weak */
43 Lisp_Object next_weak; /* Used to chain together all of the weak
44 hashtables. Don't mark through this. */
45 };
46
47 static Lisp_Object Vall_weak_hashtables;
48
49 static Lisp_Object mark_hashtable (Lisp_Object, void (*) (Lisp_Object));
50 static void print_hashtable (Lisp_Object, Lisp_Object, int);
51 DEFINE_LRECORD_IMPLEMENTATION ("hashtable", hashtable,
52 mark_hashtable, print_hashtable, 0, 0, 0,
53 struct hashtable_struct);
54
55 static Lisp_Object
56 mark_hashtable (Lisp_Object obj, void (*markobj) (Lisp_Object))
57 {
58 struct hashtable_struct *table = XHASHTABLE (obj);
59
60 if (table->type != HASHTABLE_NONWEAK)
61 {
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. */
67 return Qnil;
68 }
69 ((markobj) (table->zero_entry));
70 return (table->harray);
71 }
72
73 static void
74 print_hashtable (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
75 {
76 struct hashtable_struct *table = XHASHTABLE (obj);
77 char buf[200];
78 if (print_readably)
79 error ("printing unreadable object #<hashtable 0x%x>",
80 table->header.uid);
81 sprintf (buf, GETTEXT ("#<%shashtable %d/%ld 0x%x>"),
82 (table->type == HASHTABLE_WEAK ? "weak " :
83 table->type == HASHTABLE_KEY_WEAK ? "key-weak " :
84 table->type == HASHTABLE_VALUE_WEAK ? "value-weak " :
85 table->type == HASHTABLE_KEY_CAR_WEAK ? "key-car-weak " :
86 table->type == HASHTABLE_VALUE_CAR_WEAK ? "value-car-weak " :
87 ""),
88 table->fullness,
89 (vector_length (XVECTOR (table->harray)) / LISP_OBJECTS_PER_HENTRY),
90 table->header.uid);
91 write_c_string (buf, printcharfun);
92 }
93
94 static void
95 ht_copy_to_c (struct hashtable_struct *ht,
96 c_hashtable c_table)
97 {
98 int len;
99
100 c_table->harray = (void *) vector_data (XVECTOR (ht->harray));
101 c_table->zero_set = (!GC_UNBOUNDP (ht->zero_entry));
102 c_table->zero_entry = LISP_TO_VOID (ht->zero_entry);
103 len = vector_length (XVECTOR (ht->harray));
104 if (len < 0)
105 {
106 /* #### if alloc.c mark_object() changes, this must change too. */
107 /* barf gag retch. When a vector is marked, its len is
108 made less than 0. In the prune_weak_hashtables() stage,
109 we are called on vectors that are like this, and we must
110 be able to deal. */
111 assert (gc_in_progress);
112 len = -1 - len;
113 }
114 c_table->size = len/LISP_OBJECTS_PER_HENTRY;
115 c_table->fullness = ht->fullness;
116 c_table->hash_function = ht->hash_function;
117 c_table->test_function = ht->test_function;
118 XSETHASHTABLE (c_table->elisp_table, ht);
119 }
120
121 static void
122 ht_copy_from_c (c_hashtable c_table,
123 struct hashtable_struct *ht)
124 {
125 struct Lisp_Vector dummy;
126 /* C is truly hateful */
127 void *vec_addr
128 = ((char *) c_table->harray
129 - ((char *) &(dummy.contents) - (char *) &dummy));
130
131 XSETVECTOR (ht->harray, vec_addr);
132 if (c_table->zero_set)
133 VOID_TO_LISP (ht->zero_entry, c_table->zero_entry);
134 else
135 ht->zero_entry = Qunbound;
136 ht->fullness = c_table->fullness;
137 }
138
139
140 static struct hashtable_struct *
141 allocate_hashtable (void)
142 {
143 struct hashtable_struct *table
144 = alloc_lcrecord (sizeof (struct hashtable_struct), lrecord_hashtable);
145 table->harray = Qnil;
146 table->zero_entry = Qunbound;
147 table->fullness = 0;
148 table->hash_function = 0;
149 table->test_function = 0;
150 return (table);
151 }
152
153 char *
154 elisp_hvector_malloc (unsigned int bytes, Lisp_Object table)
155 {
156 Lisp_Object new_vector;
157 struct hashtable_struct *ht;
158
159 ht = XHASHTABLE (table);
160 assert (bytes > vector_length (XVECTOR (ht->harray)) * sizeof (Lisp_Object));
161 new_vector = make_vector ((bytes / sizeof (Lisp_Object)), Qzero);
162 return ((char *) (vector_data (XVECTOR (new_vector))));
163 }
164
165 void
166 elisp_hvector_free (void *ptr, Lisp_Object table)
167 {
168 struct hashtable_struct *ht = XHASHTABLE (table);
169 #if defined (USE_ASSERTIONS) || defined (DEBUG_XEMACS)
170 Lisp_Object current_vector = ht->harray;
171 #endif
172
173 assert (((void *) vector_data (XVECTOR (current_vector))) == ptr);
174 ht->harray = Qnil; /* Let GC do its job */
175 return;
176 }
177
178
179 DEFUN ("hashtablep", Fhashtablep, Shashtablep, 1, 1, 0 /*
180 Return t if OBJ is a hashtable, else nil.
181 */ )
182 (obj)
183 Lisp_Object obj;
184 {
185 return ((HASHTABLEP (obj)) ? Qt : Qnil);
186 }
187
188
189
190
191 #if 0 /* I don't think these are needed any more.
192 If using the general lisp_object_equal_*() functions
193 causes efficiency problems, these can be resurrected. --ben */
194 /* equality and hash functions for Lisp strings */
195 int
196 lisp_string_equal (CONST void *x1, CONST void *x2)
197 {
198 Lisp_Object str1, str2;
199 CVOID_TO_LISP (str1, x1);
200 CVOID_TO_LISP (str2, x2);
201 return !strcmp ((char *) string_data (XSTRING (str1)),
202 (char *) string_data (XSTRING (str2)));
203 }
204
205 unsigned long
206 lisp_string_hash (CONST void *x)
207 {
208 Lisp_Object str;
209 CVOID_TO_LISP (str, x);
210 return hash_string (string_data (XSTRING (str)),
211 string_length (XSTRING (str)));
212 }
213
214 #endif /* 0 */
215
216 static int
217 lisp_object_eql_equal (CONST void *x1, CONST void *x2)
218 {
219 Lisp_Object obj1, obj2;
220 CVOID_TO_LISP (obj1, x1);
221 CVOID_TO_LISP (obj2, x2);
222 return
223 (FLOATP (obj1) ? !NILP (Fequal (obj1, obj2)) : EQ (obj1, obj2));
224 }
225
226 static unsigned long
227 lisp_object_eql_hash (CONST void *x)
228 {
229 Lisp_Object obj;
230 CVOID_TO_LISP (obj, x);
231 if (FLOATP (obj))
232 return internal_hash (obj, 0);
233 else
234 return LISP_HASH (obj);
235 }
236
237 static int
238 lisp_object_equal_equal (CONST void *x1, CONST void *x2)
239 {
240 Lisp_Object obj1, obj2;
241 CVOID_TO_LISP (obj1, x1);
242 CVOID_TO_LISP (obj2, x2);
243 return !NILP (Fequal (obj1, obj2));
244 }
245
246 static unsigned long
247 lisp_object_equal_hash (CONST void *x)
248 {
249 Lisp_Object obj;
250 CVOID_TO_LISP (obj, x);
251 return internal_hash (obj, 0);
252 }
253
254 Lisp_Object
255 make_lisp_hashtable (int size,
256 enum hashtable_type type,
257 enum hashtable_test_fun test)
258 {
259 Lisp_Object result;
260 struct hashtable_struct *table = allocate_hashtable ();
261
262 table->harray = make_vector ((compute_harray_size (size)
263 * LISP_OBJECTS_PER_HENTRY),
264 Qzero);
265 switch (test)
266 {
267 case HASHTABLE_EQ:
268 table->test_function = 0;
269 table->hash_function = 0;
270 break;
271
272 case HASHTABLE_EQL:
273 table->test_function = lisp_object_eql_equal;
274 table->hash_function = lisp_object_eql_hash;
275 break;
276
277 case HASHTABLE_EQUAL:
278 table->test_function = lisp_object_equal_equal;
279 table->hash_function = lisp_object_equal_hash;
280 break;
281
282 default:
283 abort ();
284 }
285
286 table->type = type;
287 XSETHASHTABLE (result, table);
288
289 if (table->type != HASHTABLE_NONWEAK)
290 {
291 table->next_weak = Vall_weak_hashtables;
292 Vall_weak_hashtables = result;
293 }
294 else
295 table->next_weak = Qunbound;
296
297 return (result);
298 }
299
300 static enum hashtable_test_fun
301 decode_hashtable_test_fun (Lisp_Object sym)
302 {
303 if (NILP (sym))
304 return HASHTABLE_EQL;
305
306 CHECK_SYMBOL (sym);
307
308 if (EQ (sym, Qeq))
309 return HASHTABLE_EQ;
310 if (EQ (sym, Qequal))
311 return HASHTABLE_EQUAL;
312 if (EQ (sym, Qeql))
313 return HASHTABLE_EQL;
314 signal_simple_error ("Invalid hashtable test fun", sym);
315 return 0; /* not reached */
316 }
317
318 DEFUN ("make-hashtable", Fmake_hashtable, Smake_hashtable, 1, 2, 0 /*
319 Make a hashtable of initial size SIZE.
320 Comparison between keys is done with TEST-FUN, which must be one of
321 `eq', `eql', or `equal'. The default is `eql'; i.e. two keys must
322 be the same object (or have the same floating-point value, for floats)
323 to be considered equivalent.
324
325 See also `make-weak-hashtable', `make-key-weak-hashtable', and
326 `make-value-weak-hashtable'.
327 */ )
328 (size, test_fun)
329 Lisp_Object size, test_fun;
330 {
331 CHECK_NATNUM (size);
332 return make_lisp_hashtable (XINT (size), HASHTABLE_NONWEAK,
333 decode_hashtable_test_fun (test_fun));
334 }
335
336 DEFUN ("copy-hashtable", Fcopy_hashtable, Scopy_hashtable, 1, 1, 0 /*
337 Make a new hashtable which contains the same keys and values
338 as the given table. The keys and values will not themselves be copied.
339 */ )
340 (old_table)
341 Lisp_Object old_table;
342 {
343 struct _C_hashtable old_htbl;
344 struct _C_hashtable new_htbl;
345 struct hashtable_struct *old_ht;
346 struct hashtable_struct *new_ht;
347 Lisp_Object result;
348
349 CHECK_HASHTABLE (old_table);
350 old_ht = XHASHTABLE (old_table);
351 ht_copy_to_c (old_ht, &old_htbl);
352
353 /* we can't just call Fmake_hashtable() here because that will make a
354 table that is slightly larger than the one we're trying to copy,
355 which will make copy_hash() blow up. */
356 new_ht = allocate_hashtable ();
357 new_ht->fullness = 0;
358 new_ht->zero_entry = Qunbound;
359 new_ht->hash_function = old_ht->hash_function;
360 new_ht->test_function = old_ht->test_function;
361 new_ht->harray = Fmake_vector (Flength (old_ht->harray), Qzero);
362 ht_copy_to_c (new_ht, &new_htbl);
363 copy_hash (&new_htbl, &old_htbl);
364 ht_copy_from_c (&new_htbl, new_ht);
365 new_ht->type = old_ht->type;
366 XSETHASHTABLE (result, new_ht);
367
368 if (UNBOUNDP (old_ht->next_weak))
369 new_ht->next_weak = Qunbound;
370 else
371 {
372 new_ht->next_weak = Vall_weak_hashtables;
373 Vall_weak_hashtables = result;
374 }
375
376 return (result);
377 }
378
379
380 DEFUN ("gethash", Fgethash, Sgethash, 2, 3, 0 /*
381 Find hash value for KEY in TABLE.
382 If there is no corresponding value, return DEFAULT (defaults to nil).
383 */ )
384 (key, table, defalt)
385 Lisp_Object key, table, defalt; /* One can't even spell correctly in C */
386 {
387 CONST void *vval;
388 struct _C_hashtable htbl;
389 if (!gc_in_progress)
390 CHECK_HASHTABLE (table);
391 ht_copy_to_c (XHASHTABLE (table), &htbl);
392 if (gethash (LISP_TO_VOID (key), &htbl, &vval))
393 {
394 Lisp_Object val;
395 CVOID_TO_LISP (val, vval);
396 return val;
397 }
398 else
399 return defalt;
400 }
401
402
403 DEFUN ("remhash", Fremhash, Sremhash, 2, 2, 0 /*
404 Remove hash value for KEY in TABLE.
405 */ )
406 (key, table)
407 Lisp_Object key, table;
408 {
409 struct _C_hashtable htbl;
410 CHECK_HASHTABLE (table);
411
412 ht_copy_to_c (XHASHTABLE (table), &htbl);
413 remhash (LISP_TO_VOID (key), &htbl);
414 ht_copy_from_c (&htbl, XHASHTABLE (table));
415 return Qnil;
416 }
417
418
419 DEFUN ("puthash", Fputhash, Sputhash, 3, 3, 0 /*
420 Hash KEY to VAL in TABLE.
421 */ )
422 (key, val, table)
423 Lisp_Object key, val, table;
424 {
425 struct hashtable_struct *ht;
426 void *vkey = LISP_TO_VOID (key);
427
428 CHECK_HASHTABLE (table);
429 ht = XHASHTABLE (table);
430 if (!vkey)
431 ht->zero_entry = val;
432 else
433 {
434 struct gcpro gcpro1, gcpro2, gcpro3;
435 struct _C_hashtable htbl;
436
437 ht_copy_to_c (XHASHTABLE (table), &htbl);
438 GCPRO3 (key, val, table);
439 puthash (vkey, LISP_TO_VOID (val), &htbl);
440 ht_copy_from_c (&htbl, XHASHTABLE (table));
441 UNGCPRO;
442 }
443 return (val);
444 }
445
446 DEFUN ("clrhash", Fclrhash, Sclrhash, 1, 1, 0 /*
447 Flush TABLE.
448 */ )
449 (table)
450 Lisp_Object table;
451 {
452 struct _C_hashtable htbl;
453 CHECK_HASHTABLE (table);
454 ht_copy_to_c (XHASHTABLE (table), &htbl);
455 clrhash (&htbl);
456 ht_copy_from_c (&htbl, XHASHTABLE (table));
457 return Qnil;
458 }
459
460 DEFUN ("hashtable-fullness", Fhashtable_fullness, Shashtable_fullness, 1, 1, 0 /*
461 Return number of entries in TABLE.
462 */ )
463 (table)
464 Lisp_Object table;
465 {
466 struct _C_hashtable htbl;
467 CHECK_HASHTABLE (table);
468 ht_copy_to_c (XHASHTABLE (table), &htbl);
469 return (make_int (htbl.fullness));
470 }
471
472
473 static void
474 verify_function (Lisp_Object function, CONST char *description)
475 {
476 if (SYMBOLP (function))
477 {
478 if (NILP (function))
479 return;
480 else
481 function = indirect_function (function, 1);
482 }
483 if (SUBRP (function) || COMPILED_FUNCTIONP (function))
484 return;
485 else if (CONSP (function))
486 {
487 Lisp_Object funcar = Fcar (function);
488 if ((SYMBOLP (funcar))
489 && (EQ (funcar, Qlambda)
490 #ifdef MOCKLISP_SUPPORT
491 || EQ (funcar, Qmocklisp)
492 #endif
493 || EQ (funcar, Qautoload)))
494 return;
495 }
496 signal_error (Qinvalid_function, list1 (function));
497 }
498
499 static void
500 lisp_maphash_function (CONST void *void_key,
501 void *void_val,
502 void *void_fn)
503 {
504 /* This function can GC */
505 Lisp_Object key, val, fn;
506 CVOID_TO_LISP (key, void_key);
507 VOID_TO_LISP (val, void_val);
508 VOID_TO_LISP (fn, void_fn);
509 call2 (fn, key, val);
510 }
511
512
513 DEFUN ("maphash", Fmaphash, Smaphash, 2, 2, 0 /*
514 Map FUNCTION over entries in TABLE, calling it with two args,
515 each key and value in the table.
516 */ )
517 (function, table)
518 Lisp_Object function, table;
519 {
520 struct _C_hashtable htbl;
521 struct gcpro gcpro1, gcpro2;
522
523 verify_function (function, GETTEXT ("hashtable mapping function"));
524 CHECK_HASHTABLE (table);
525 ht_copy_to_c (XHASHTABLE (table), &htbl);
526 GCPRO2 (table, function);
527 maphash (lisp_maphash_function, &htbl, LISP_TO_VOID (function));
528 UNGCPRO;
529 return Qnil;
530 }
531
532
533 /* This function is for mapping a *C* function over the elements of a
534 lisp hashtable.
535 */
536 void
537 elisp_maphash (maphash_function function, Lisp_Object table, void *closure)
538 {
539 struct _C_hashtable htbl;
540
541 if (!gc_in_progress) CHECK_HASHTABLE (table);
542 ht_copy_to_c (XHASHTABLE (table), &htbl);
543 maphash (function, &htbl, closure);
544 }
545
546 void
547 elisp_map_remhash (remhash_predicate function,
548 Lisp_Object table,
549 void *closure)
550 {
551 struct _C_hashtable htbl;
552
553 if (!gc_in_progress) CHECK_HASHTABLE (table);
554 ht_copy_to_c (XHASHTABLE (table), &htbl);
555 map_remhash (function, &htbl, closure);
556 ht_copy_from_c (&htbl, XHASHTABLE (table));
557 }
558
559 #if 0
560 void
561 elisp_table_op (Lisp_Object table, generic_hashtable_op op, void *arg1,
562 void *arg2, void *arg3)
563 {
564 struct _C_hashtable htbl;
565 CHECK_HASHTABLE (table);
566 ht_copy_to_c (XHASHTABLE (table), &htbl);
567 (*op) (&htbl, arg1, arg2, arg3);
568 ht_copy_from_c (&htbl, XHASHTABLE (table));
569 }
570 #endif /* 0 */
571
572
573
574 DEFUN ("make-weak-hashtable", Fmake_weak_hashtable, Smake_weak_hashtable,
575 1, 2, 0 /*
576 Make a fully weak hashtable of initial size SIZE.
577 A weak hashtable is one whose pointers do not count as GC referents:
578 for any key-value pair in the hashtable, if the only remaining pointer
579 to either the key or the value is in a weak hash table, then the pair
580 will be removed from the table, and the key and value collected. A
581 non-weak hash table (or any other pointer) would prevent the object
582 from being collected.
583
584 You can also create semi-weak hashtables; see `make-key-weak-hashtable'
585 and `make-value-weak-hashtable'.
586 */ )
587 (size, test_fun)
588 Lisp_Object size, test_fun;
589 {
590 CHECK_NATNUM (size);
591 return make_lisp_hashtable (XINT (size), HASHTABLE_WEAK,
592 decode_hashtable_test_fun (test_fun));
593 }
594
595 DEFUN ("make-key-weak-hashtable", Fmake_key_weak_hashtable,
596 Smake_key_weak_hashtable, 1, 2, 0 /*
597 Make a key-weak hashtable of initial size SIZE.
598 A key-weak hashtable is similar to a fully-weak hashtable (see
599 `make-weak-hashtable') except that a key-value pair will be removed
600 only if the key remains unmarked outside of weak hashtables. The pair
601 will remain in the hashtable if the key is pointed to by something other
602 than a weak hashtable, even if the value is not.
603 */ )
604 (size, test_fun)
605 Lisp_Object size, test_fun;
606 {
607 CHECK_NATNUM (size);
608 return make_lisp_hashtable (XINT (size), HASHTABLE_KEY_WEAK,
609 decode_hashtable_test_fun (test_fun));
610 }
611
612 DEFUN ("make-value-weak-hashtable", Fmake_value_weak_hashtable,
613 Smake_value_weak_hashtable, 1, 2, 0 /*
614 Make a value-weak hashtable of initial size SIZE.
615 A value-weak hashtable is similar to a fully-weak hashtable (see
616 `make-weak-hashtable') except that a key-value pair will be removed only
617 if the value remains unmarked outside of weak hashtables. The pair will
618 remain in the hashtable if the value is pointed to by something other
619 than a weak hashtable, even if the key is not.
620 */ )
621 (size, test_fun)
622 Lisp_Object size, test_fun;
623 {
624 CHECK_NATNUM (size);
625 return make_lisp_hashtable (XINT (size), HASHTABLE_VALUE_WEAK,
626 decode_hashtable_test_fun (test_fun));
627 }
628
629 struct marking_closure
630 {
631 int (*obj_marked_p) (Lisp_Object);
632 void (*markobj) (Lisp_Object);
633 enum hashtable_type type;
634 int did_mark;
635 };
636
637 static void
638 marking_mapper (CONST void *key, void *contents, void *closure)
639 {
640 Lisp_Object keytem, valuetem;
641 struct marking_closure *fmh =
642 (struct marking_closure *) closure;
643
644 /* This function is called over each pair in the hashtable.
645 We complete the marking for semi-weak hashtables. */
646 CVOID_TO_LISP (keytem, key);
647 CVOID_TO_LISP (valuetem, contents);
648
649 switch (fmh->type)
650 {
651 case HASHTABLE_KEY_WEAK:
652 if ((fmh->obj_marked_p) (keytem) &&
653 !(fmh->obj_marked_p) (valuetem))
654 {
655 (fmh->markobj) (valuetem);
656 fmh->did_mark = 1;
657 }
658 break;
659
660 case HASHTABLE_VALUE_WEAK:
661 if ((fmh->obj_marked_p) (valuetem) &&
662 !(fmh->obj_marked_p) (keytem))
663 {
664 (fmh->markobj) (keytem);
665 fmh->did_mark = 1;
666 }
667 break;
668
669 case HASHTABLE_KEY_CAR_WEAK:
670 if (!CONSP (keytem) || (fmh->obj_marked_p) (XCAR (keytem)))
671 {
672 if (!(fmh->obj_marked_p) (keytem))
673 {
674 (fmh->markobj) (keytem);
675 fmh->did_mark = 1;
676 }
677 if (!(fmh->obj_marked_p) (valuetem))
678 {
679 (fmh->markobj) (valuetem);
680 fmh->did_mark = 1;
681 }
682 }
683 break;
684
685 case HASHTABLE_VALUE_CAR_WEAK:
686 if (!CONSP (valuetem) || (fmh->obj_marked_p) (XCAR (valuetem)))
687 {
688 if (!(fmh->obj_marked_p) (keytem))
689 {
690 (fmh->markobj) (keytem);
691 fmh->did_mark = 1;
692 }
693 if (!(fmh->obj_marked_p) (valuetem))
694 {
695 (fmh->markobj) (valuetem);
696 fmh->did_mark = 1;
697 }
698 }
699 break;
700
701 default:
702 abort (); /* Huh? */
703 }
704
705 return;
706 }
707
708 int
709 finish_marking_weak_hashtables (int (*obj_marked_p) (Lisp_Object),
710 void (*markobj) (Lisp_Object))
711 {
712 Lisp_Object rest;
713 int did_mark = 0;
714
715 for (rest = Vall_weak_hashtables;
716 !GC_NILP (rest);
717 rest = XHASHTABLE (rest)->next_weak)
718 {
719 enum hashtable_type type;
720
721 if (! ((*obj_marked_p) (rest)))
722 /* The hashtable is probably garbage. Ignore it. */
723 continue;
724 type = XHASHTABLE (rest)->type;
725 if (type == HASHTABLE_KEY_WEAK || type == HASHTABLE_VALUE_WEAK
726 || type == HASHTABLE_KEY_CAR_WEAK
727 || type == HASHTABLE_VALUE_CAR_WEAK)
728 {
729 struct marking_closure fmh;
730
731 fmh.obj_marked_p = obj_marked_p;
732 fmh.markobj = markobj;
733 fmh.type = type;
734 fmh.did_mark = 0;
735 /* Now, scan over all the pairs. For all pairs that are
736 half-marked, we may need to mark the other half if we're
737 keeping this pair. */
738 elisp_maphash (marking_mapper, rest, &fmh);
739 if (fmh.did_mark)
740 did_mark = 1;
741 }
742
743 /* #### If alloc.c mark_object changes, this must change also... */
744 {
745 /* Now mark the vector itself. (We don't need to call markobj
746 here because we know that everything *in* it is already marked,
747 we just need to prevent the vector itself from disappearing.)
748 (The remhash above has taken care of zero_entry.)
749 */
750 struct Lisp_Vector *ptr = XVECTOR (XHASHTABLE (rest)->harray);
751 int len = vector_length (ptr);
752 if (len >= 0)
753 {
754 ptr->size = -1 - len;
755 did_mark = 1;
756 }
757 /* else it's already marked (remember, this function is iterated
758 until marking stops) */
759 }
760 }
761
762 return did_mark;
763 }
764
765 struct pruning_closure
766 {
767 int (*obj_marked_p) (Lisp_Object);
768 };
769
770 static int
771 pruning_mapper (CONST void *key, CONST void *contents, void *closure)
772 {
773 Lisp_Object keytem, valuetem;
774 struct pruning_closure *fmh =
775 (struct pruning_closure *) closure;
776
777 /* This function is called over each pair in the hashtable.
778 We remove the pairs that aren't completely marked (everything
779 that is going to stay ought to have been marked already
780 by the finish_marking stage). */
781 CVOID_TO_LISP (keytem, key);
782 CVOID_TO_LISP (valuetem, contents);
783
784 return (! ((*fmh->obj_marked_p) (keytem) &&
785 (*fmh->obj_marked_p) (valuetem)));
786 }
787
788 void
789 prune_weak_hashtables (int (*obj_marked_p) (Lisp_Object))
790 {
791 Lisp_Object rest, prev = Qnil;
792 for (rest = Vall_weak_hashtables;
793 !GC_NILP (rest);
794 rest = XHASHTABLE (rest)->next_weak)
795 {
796 if (! ((*obj_marked_p) (rest)))
797 {
798 /* This table itself is garbage. Remove it from the list. */
799 if (GC_NILP (prev))
800 Vall_weak_hashtables = XHASHTABLE (rest)->next_weak;
801 else
802 XHASHTABLE (prev)->next_weak = XHASHTABLE (rest)->next_weak;
803 }
804 else
805 {
806 struct pruning_closure fmh;
807 fmh.obj_marked_p = obj_marked_p;
808 /* Now, scan over all the pairs. Remove all of the pairs
809 in which the key or value, or both, is unmarked
810 (depending on the type of weak hashtable). */
811 elisp_map_remhash (pruning_mapper, rest, &fmh);
812 prev = rest;
813 }
814 }
815 }
816
817 /* Return a hash value for an array of Lisp_Objects of size SIZE. */
818
819 unsigned long
820 internal_array_hash (Lisp_Object *arr, int size, int depth)
821 {
822 int i;
823 unsigned long hash = 0;
824
825 if (size <= 5)
826 {
827 for (i = 0; i < size; i++)
828 hash = HASH2 (hash, internal_hash (arr[i], depth + 1));
829 return hash;
830 }
831
832 /* just pick five elements scattered throughout the array.
833 A slightly better approach would be to offset by some
834 noise factor from the points chosen below. */
835 for (i = 0; i < 5; i++)
836 hash = HASH2 (hash, internal_hash (arr[i*size/5], depth + 1));
837
838 return hash;
839 }
840
841 /* Return a hash value for a Lisp_Object. This is for use when hashing
842 objects with the comparison being `equal' (for `eq', you can just
843 use the Lisp_Object itself as the hash value). You need to make a
844 tradeoff between the speed of the hash function and how good the
845 hashing is. In particular, the hash function needs to be FAST,
846 so you can't just traipse down the whole tree hashing everything
847 together. Most of the time, objects will differ in the first
848 few elements you hash. Thus, we only go to a short depth (5)
849 and only hash at most 5 elements out of a vector. Theoretically
850 we could still take 5^5 time (a big big number) to compute a
851 hash, but practically this won't ever happen. */
852
853 unsigned long
854 internal_hash (Lisp_Object obj, int depth)
855 {
856 if (depth > 5)
857 return 0;
858 if (CONSP (obj))
859 {
860 /* no point in worrying about tail recursion, since we're not
861 going very deep */
862 return HASH2 (internal_hash (XCAR (obj), depth + 1),
863 internal_hash (XCDR (obj), depth + 1));
864 }
865 else if (STRINGP (obj))
866 return hash_string (string_data (XSTRING (obj)),
867 string_length (XSTRING (obj)));
868 #ifndef LRECORD_VECTOR
869 else if (VECTORP (obj))
870 {
871 struct Lisp_Vector *v = XVECTOR (obj);
872 return HASH2 (vector_length (v),
873 internal_array_hash (v->contents, vector_length (v),
874 depth + 1));
875 }
876 #endif /* !LRECORD_VECTOR */
877 else if (LRECORDP (obj))
878 {
879 CONST struct lrecord_implementation
880 *imp = XRECORD_LHEADER (obj)->implementation;
881 if (imp->hash)
882 return ((imp->hash) (obj, depth));
883 }
884
885 return LISP_HASH (obj);
886 }
887
888
889 /************************************************************************/
890 /* initialization */
891 /************************************************************************/
892
893 void
894 syms_of_elhash (void)
895 {
896 defsubr (&Smake_hashtable);
897 defsubr (&Scopy_hashtable);
898 defsubr (&Shashtablep);
899 defsubr (&Sgethash);
900 defsubr (&Sputhash);
901 defsubr (&Sremhash);
902 defsubr (&Sclrhash);
903 defsubr (&Smaphash);
904 defsubr (&Shashtable_fullness);
905 defsubr (&Smake_weak_hashtable);
906 defsubr (&Smake_key_weak_hashtable);
907 defsubr (&Smake_value_weak_hashtable);
908 defsymbol (&Qhashtablep, "hashtablep");
909 }
910
911 void
912 vars_of_elhash (void)
913 {
914 /* This must not be staticpro'd */
915 Vall_weak_hashtables = Qnil;
916 }