Mercurial > hg > xemacs-beta

comparison src/elhash.c @ 428:3ecd8885ac67 r21-2-22

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-22
author cvs
date Mon, 13 Aug 2007 11:28:15 +0200
parents
children a5df635868b2
comparison
equal deleted inserted replaced
427:0a0253eac470 428:3ecd8885ac67
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.
5
6 This file is part of XEmacs.
7
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
11 later version.
12
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
16 for more details.
17
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. */
22
23 /* Synched up with: Not in FSF. */
24
25 #include <config.h>
26 #include "lisp.h"
27 #include "bytecode.h"
28 #include "elhash.h"
29
30 Lisp_Object Qhash_tablep;
31 static Lisp_Object Qhashtable, Qhash_table;
32 static Lisp_Object Qweakness, Qvalue;
33 static Lisp_Object Vall_weak_hash_tables;
34 static Lisp_Object Qrehash_size, Qrehash_threshold;
35 static Lisp_Object Q_size, Q_test, Q_weakness, Q_rehash_size, Q_rehash_threshold;
36
37 /* obsolete as of 19990901 in xemacs-21.2 */
38 static Lisp_Object Qweak, Qkey_weak, Qvalue_weak, Qnon_weak, Q_type;
39
40 typedef struct hentry
41 {
42 Lisp_Object key;
43 Lisp_Object value;
44 } hentry;
45
46 struct Lisp_Hash_Table
47 {
48 struct lcrecord_header header;
49 size_t size;
50 size_t count;
51 size_t rehash_count;
52 double rehash_size;
53 double rehash_threshold;
54 size_t golden_ratio;
55 hash_table_hash_function_t hash_function;
56 hash_table_test_function_t test_function;
57 hentry *hentries;
58 enum hash_table_weakness weakness;
59 Lisp_Object next_weak; /* Used to chain together all of the weak
60 hash tables. Don't mark through this. */
61 };
62 typedef struct Lisp_Hash_Table Lisp_Hash_Table;
63
64 #define HENTRY_CLEAR_P(hentry) ((*(EMACS_UINT*)(&((hentry)->key))) == 0)
65 #define CLEAR_HENTRY(hentry) \
66 ((*(EMACS_UINT*)(&((hentry)->key))) = 0, \
67 (*(EMACS_UINT*)(&((hentry)->value))) = 0)
68
69 #define HASH_TABLE_DEFAULT_SIZE 16
70 #define HASH_TABLE_DEFAULT_REHASH_SIZE 1.3
71 #define HASH_TABLE_MIN_SIZE 10
72
73 #define HASH_CODE(key, ht) \
74 (((((ht)->hash_function ? (ht)->hash_function (key) : LISP_HASH (key)) \
75 * (ht)->golden_ratio) \
76 % (ht)->size))
77
78 #define KEYS_EQUAL_P(key1, key2, testfun) \
79 (EQ ((key1), (key2)) || ((testfun) && (testfun) ((key1), (key2))))
80
81 #define LINEAR_PROBING_LOOP(probe, entries, size) \
82 for (; \
83 !HENTRY_CLEAR_P (probe) || \
84 (probe == entries + size ? \
85 (probe = entries, !HENTRY_CLEAR_P (probe)) : 0); \
86 probe++)
87
88 #ifndef ERROR_CHECK_HASH_TABLE
89 # ifdef ERROR_CHECK_TYPECHECK
90 # define ERROR_CHECK_HASH_TABLE 1
91 # else
92 # define ERROR_CHECK_HASH_TABLE 0
93 # endif
94 #endif
95
96 #if ERROR_CHECK_HASH_TABLE
97 static void
98 check_hash_table_invariants (Lisp_Hash_Table *ht)
99 {
100 assert (ht->count < ht->size);
101 assert (ht->count <= ht->rehash_count);
102 assert (ht->rehash_count < ht->size);
103 assert ((double) ht->count * ht->rehash_threshold - 1 <= (double) ht->rehash_count);
104 assert (HENTRY_CLEAR_P (ht->hentries + ht->size));
105 }
106 #else
107 #define check_hash_table_invariants(ht)
108 #endif
109
110 /* We use linear probing instead of double hashing, despite its lack
111 of blessing by Knuth and company, because, as a result of the
112 increasing discrepancy between CPU speeds and memory speeds, cache
113 behavior is becoming increasingly important, e.g:
114
115 For a trivial loop, the penalty for non-sequential access of an array is:
116 - a factor of 3-4 on Pentium Pro 200 Mhz
117 - a factor of 10 on Ultrasparc 300 Mhz */
118
119 /* Return a suitable size for a hash table, with at least SIZE slots. */
120 static size_t
121 hash_table_size (size_t requested_size)
122 {
123 /* Return some prime near, but greater than or equal to, SIZE.
124 Decades from the time of writing, someone will have a system large
125 enough that the list below will be too short... */
126 static CONST size_t primes [] =
127 {
128 19, 29, 41, 59, 79, 107, 149, 197, 263, 347, 457, 599, 787, 1031,
129 1361, 1777, 2333, 3037, 3967, 5167, 6719, 8737, 11369, 14783,
130 19219, 24989, 32491, 42257, 54941, 71429, 92861, 120721, 156941,
131 204047, 265271, 344857, 448321, 582821, 757693, 985003, 1280519,
132 1664681, 2164111, 2813353, 3657361, 4754591, 6180989, 8035301,
133 10445899, 13579681, 17653589, 22949669, 29834603, 38784989,
134 50420551, 65546729, 85210757, 110774011, 144006217, 187208107,
135 243370577, 316381771, 411296309, 534685237, 695090819, 903618083,
136 1174703521, 1527114613, 1985248999, 2580823717UL, 3355070839UL
137 };
138 /* We've heard of binary search. */
139 int low, high;
140 for (low = 0, high = countof (primes) - 1; high - low > 1;)
141 {
142 /* Loop Invariant: size < primes [high] */
143 int mid = (low + high) / 2;
144 if (primes [mid] < requested_size)
145 low = mid;
146 else
147 high = mid;
148 }
149 return primes [high];
150 }
151
152
153 #if 0 /* I don't think these are needed any more.
154 If using the general lisp_object_equal_*() functions
155 causes efficiency problems, these can be resurrected. --ben */
156 /* equality and hash functions for Lisp strings */
157 int
158 lisp_string_equal (Lisp_Object str1, Lisp_Object str2)
159 {
160 /* This is wrong anyway. You can't use strcmp() on Lisp strings,
161 because they can contain zero characters. */
162 return !strcmp ((char *) XSTRING_DATA (str1), (char *) XSTRING_DATA (str2));
163 }
164
165 static hashcode_t
166 lisp_string_hash (Lisp_Object obj)
167 {
168 return hash_string (XSTRING_DATA (str), XSTRING_LENGTH (str));
169 }
170
171 #endif /* 0 */
172
173 static int
174 lisp_object_eql_equal (Lisp_Object obj1, Lisp_Object obj2)
175 {
176 return EQ (obj1, obj2) || (FLOATP (obj1) && internal_equal (obj1, obj2, 0));
177 }
178
179 static hashcode_t
180 lisp_object_eql_hash (Lisp_Object obj)
181 {
182 return FLOATP (obj) ? internal_hash (obj, 0) : LISP_HASH (obj);
183 }
184
185 static int
186 lisp_object_equal_equal (Lisp_Object obj1, Lisp_Object obj2)
187 {
188 return internal_equal (obj1, obj2, 0);
189 }
190
191 static hashcode_t
192 lisp_object_equal_hash (Lisp_Object obj)
193 {
194 return internal_hash (obj, 0);
195 }
196
197
198 static Lisp_Object
199 mark_hash_table (Lisp_Object obj)
200 {
201 Lisp_Hash_Table *ht = XHASH_TABLE (obj);
202
203 /* If the hash table is weak, we don't want to mark the keys and
204 values (we scan over them after everything else has been marked,
205 and mark or remove them as necessary). */
206 if (ht->weakness == HASH_TABLE_NON_WEAK)
207 {
208 hentry *e, *sentinel;
209
210 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
211 if (!HENTRY_CLEAR_P (e))
212 {
213 mark_object (e->key);
214 mark_object (e->value);
215 }
216 }
217 return Qnil;
218 }
219
220 /* Equality of hash tables. Two hash tables are equal when they are of
221 the same weakness and test function, they have the same number of
222 elements, and for each key in the hash table, the values are `equal'.
223
224 This is similar to Common Lisp `equalp' of hash tables, with the
225 difference that CL requires the keys to be compared with the test
226 function, which we don't do. Doing that would require consing, and
227 consing is a bad idea in `equal'. Anyway, our method should provide
228 the same result -- if the keys are not equal according to the test
229 function, then Fgethash() in hash_table_equal_mapper() will fail. */
230 static int
231 hash_table_equal (Lisp_Object hash_table1, Lisp_Object hash_table2, int depth)
232 {
233 Lisp_Hash_Table *ht1 = XHASH_TABLE (hash_table1);
234 Lisp_Hash_Table *ht2 = XHASH_TABLE (hash_table2);
235 hentry *e, *sentinel;
236
237 if ((ht1->test_function != ht2->test_function) ||
238 (ht1->weakness != ht2->weakness) ||
239 (ht1->count != ht2->count))
240 return 0;
241
242 depth++;
243
244 for (e = ht1->hentries, sentinel = e + ht1->size; e < sentinel; e++)
245 if (!HENTRY_CLEAR_P (e))
246 /* Look up the key in the other hash table, and compare the values. */
247 {
248 Lisp_Object value_in_other = Fgethash (e->key, hash_table2, Qunbound);
249 if (UNBOUNDP (value_in_other) ||
250 !internal_equal (e->value, value_in_other, depth))
251 return 0; /* Give up */
252 }
253
254 return 1;
255 }
256
257 /* Printing hash tables.
258
259 This is non-trivial, because we use a readable structure-style
260 syntax for hash tables. This means that a typical hash table will be
261 readably printed in the form of:
262
263 #s(hash-table size 2 data (key1 value1 key2 value2))
264
265 The supported hash table structure keywords and their values are:
266 `test' (eql (or nil), eq or equal)
267 `size' (a natnum or nil)
268 `rehash-size' (a float)
269 `rehash-threshold' (a float)
270 `weakness' (nil, t, key or value)
271 `data' (a list)
272
273 If `print-readably' is non-nil, then a simpler syntax is used; for
274 instance:
275
276 #<hash-table size 2/13 data (key1 value1 key2 value2) 0x874d>
277
278 The data is truncated to four pairs, and the rest is shown with
279 `...'. This printer does not cons. */
280
281
282 /* Print the data of the hash table. This maps through a Lisp
283 hash table and prints key/value pairs using PRINTCHARFUN. */
284 static void
285 print_hash_table_data (Lisp_Hash_Table *ht, Lisp_Object printcharfun)
286 {
287 int count = 0;
288 hentry *e, *sentinel;
289
290 write_c_string (" data (", printcharfun);
291
292 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
293 if (!HENTRY_CLEAR_P (e))
294 {
295 if (count > 0)
296 write_c_string (" ", printcharfun);
297 if (!print_readably && count > 3)
298 {
299 write_c_string ("...", printcharfun);
300 break;
301 }
302 print_internal (e->key, printcharfun, 1);
303 write_c_string (" ", printcharfun);
304 print_internal (e->value, printcharfun, 1);
305 count++;
306 }
307
308 write_c_string (")", printcharfun);
309 }
310
311 static void
312 print_hash_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
313 {
314 Lisp_Hash_Table *ht = XHASH_TABLE (obj);
315 char buf[128];
316
317 write_c_string (print_readably ? "#s(hash-table" : "#<hash-table",
318 printcharfun);
319
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)
328 DO_NOTHING;
329 else
330 abort ();
331
332 if (ht->count || !print_readably)
333 {
334 if (print_readably)
335 sprintf (buf, " size %lu", (unsigned long) ht->count);
336 else
337 sprintf (buf, " size %lu/%lu",
338 (unsigned long) ht->count,
339 (unsigned long) ht->size);
340 write_c_string (buf, printcharfun);
341 }
342
343 if (ht->weakness != HASH_TABLE_NON_WEAK)
344 {
345 sprintf (buf, " weakness %s",
346 (ht->weakness == HASH_TABLE_WEAK ? "t" :
347 ht->weakness == HASH_TABLE_KEY_WEAK ? "key" :
348 ht->weakness == HASH_TABLE_VALUE_WEAK ? "value" :
349 "you-d-better-not-see-this"));
350 write_c_string (buf, printcharfun);
351 }
352
353 if (ht->count)
354 print_hash_table_data (ht, printcharfun);
355
356 if (print_readably)
357 write_c_string (")", printcharfun);
358 else
359 {
360 sprintf (buf, " 0x%x>", ht->header.uid);
361 write_c_string (buf, printcharfun);
362 }
363 }
364
365 static void
366 finalize_hash_table (void *header, int for_disksave)
367 {
368 if (!for_disksave)
369 {
370 Lisp_Hash_Table *ht = (Lisp_Hash_Table *) header;
371
372 xfree (ht->hentries);
373 ht->hentries = 0;
374 }
375 }
376
377 static const struct lrecord_description hentry_description_1[] = {
378 { XD_LISP_OBJECT, offsetof(hentry, key), 2 },
379 { XD_END }
380 };
381
382 static const struct struct_description hentry_description = {
383 sizeof(hentry),
384 hentry_description_1
385 };
386
387 const struct lrecord_description hash_table_description[] = {
388 { XD_SIZE_T, offsetof(Lisp_Hash_Table, size) },
389 { XD_STRUCT_PTR, offsetof(Lisp_Hash_Table, hentries), XD_INDIRECT(0, 1), &hentry_description },
390 { XD_LO_LINK, offsetof(Lisp_Hash_Table, next_weak) },
391 { XD_END }
392 };
393
394 DEFINE_LRECORD_IMPLEMENTATION ("hash-table", hash_table,
395 mark_hash_table, print_hash_table,
396 finalize_hash_table,
397 /* #### Implement hash_table_hash()! */
398 hash_table_equal, 0,
399 hash_table_description,
400 Lisp_Hash_Table);
401
402 static Lisp_Hash_Table *
403 xhash_table (Lisp_Object hash_table)
404 {
405 if (!gc_in_progress)
406 CHECK_HASH_TABLE (hash_table);
407 check_hash_table_invariants (XHASH_TABLE (hash_table));
408 return XHASH_TABLE (hash_table);
409 }
410
411
412 /************************************************************************/
413 /* Creation of Hash Tables */
414 /************************************************************************/
415
416 /* Creation of hash tables, without error-checking. */
417 static double
418 hash_table_rehash_threshold (Lisp_Hash_Table *ht)
419 {
420 return
421 ht->rehash_threshold > 0.0 ? ht->rehash_threshold :
422 ht->size > 4096 && !ht->test_function ? 0.7 : 0.6;
423 }
424
425 static void
426 compute_hash_table_derived_values (Lisp_Hash_Table *ht)
427 {
428 ht->rehash_count = (size_t)
429 ((double) ht->size * hash_table_rehash_threshold (ht));
430 ht->golden_ratio = (size_t)
431 ((double) ht->size * (.6180339887 / (double) sizeof (Lisp_Object)));
432 }
433
434 Lisp_Object
435 make_general_lisp_hash_table (enum hash_table_test test,
436 size_t size,
437 double rehash_size,
438 double rehash_threshold,
439 enum hash_table_weakness weakness)
440 {
441 Lisp_Object hash_table;
442 Lisp_Hash_Table *ht = alloc_lcrecord_type (Lisp_Hash_Table, &lrecord_hash_table);
443
444 ht->rehash_size = rehash_size;
445 ht->rehash_threshold = rehash_threshold;
446 ht->weakness = weakness;
447
448 switch (test)
449 {
450 case HASH_TABLE_EQ:
451 ht->test_function = 0;
452 ht->hash_function = 0;
453 break;
454
455 case HASH_TABLE_EQL:
456 ht->test_function = lisp_object_eql_equal;
457 ht->hash_function = lisp_object_eql_hash;
458 break;
459
460 case HASH_TABLE_EQUAL:
461 ht->test_function = lisp_object_equal_equal;
462 ht->hash_function = lisp_object_equal_hash;
463 break;
464
465 default:
466 abort ();
467 }
468
469 if (ht->rehash_size <= 0.0)
470 ht->rehash_size = HASH_TABLE_DEFAULT_REHASH_SIZE;
471 if (size < HASH_TABLE_MIN_SIZE)
472 size = HASH_TABLE_MIN_SIZE;
473 if (rehash_threshold < 0.0)
474 rehash_threshold = 0.75;
475 ht->size =
476 hash_table_size ((size_t) ((double) size / hash_table_rehash_threshold (ht)) + 1);
477 ht->count = 0;
478 compute_hash_table_derived_values (ht);
479
480 /* We leave room for one never-occupied sentinel hentry at the end. */
481 ht->hentries = xnew_array (hentry, ht->size + 1);
482
483 {
484 hentry *e, *sentinel;
485 for (e = ht->hentries, sentinel = e + ht->size; e <= sentinel; e++)
486 CLEAR_HENTRY (e);
487 }
488
489 XSETHASH_TABLE (hash_table, ht);
490
491 if (weakness == HASH_TABLE_NON_WEAK)
492 ht->next_weak = Qunbound;
493 else
494 ht->next_weak = Vall_weak_hash_tables, Vall_weak_hash_tables = hash_table;
495
496 return hash_table;
497 }
498
499 Lisp_Object
500 make_lisp_hash_table (size_t size,
501 enum hash_table_weakness weakness,
502 enum hash_table_test test)
503 {
504 return make_general_lisp_hash_table
505 (test, size, HASH_TABLE_DEFAULT_REHASH_SIZE, -1.0, weakness);
506 }
507
508 /* Pretty reading of hash tables.
509
510 Here we use the existing structures mechanism (which is,
511 unfortunately, pretty cumbersome) for validating and instantiating
512 the hash tables. The idea is that the side-effect of reading a
513 #s(hash-table PLIST) object is creation of a hash table with desired
514 properties, and that the hash table is returned. */
515
516 /* Validation functions: each keyword provides its own validation
517 function. The errors should maybe be continuable, but it is
518 unclear how this would cope with ERRB. */
519 static int
520 hash_table_size_validate (Lisp_Object keyword, Lisp_Object value,
521 Error_behavior errb)
522 {
523 if (NATNUMP (value))
524 return 1;
525
526 maybe_signal_error (Qwrong_type_argument, list2 (Qnatnump, value),
527 Qhash_table, errb);
528 return 0;
529 }
530
531 static size_t
532 decode_hash_table_size (Lisp_Object obj)
533 {
534 return NILP (obj) ? HASH_TABLE_DEFAULT_SIZE : XINT (obj);
535 }
536
537 static int
538 hash_table_weakness_validate (Lisp_Object keyword, Lisp_Object value,
539 Error_behavior errb)
540 {
541 if (EQ (value, Qnil)) return 1;
542 if (EQ (value, Qt)) return 1;
543 if (EQ (value, Qkey)) return 1;
544 if (EQ (value, Qvalue)) return 1;
545
546 /* Following values are obsolete as of 19990901 in xemacs-21.2 */
547 if (EQ (value, Qnon_weak)) return 1;
548 if (EQ (value, Qweak)) return 1;
549 if (EQ (value, Qkey_weak)) return 1;
550 if (EQ (value, Qvalue_weak)) return 1;
551
552 maybe_signal_simple_error ("Invalid hash table weakness",
553 value, Qhash_table, errb);
554 return 0;
555 }
556
557 static enum hash_table_weakness
558 decode_hash_table_weakness (Lisp_Object obj)
559 {
560 if (EQ (obj, Qnil)) return HASH_TABLE_NON_WEAK;
561 if (EQ (obj, Qt)) return HASH_TABLE_WEAK;
562 if (EQ (obj, Qkey)) return HASH_TABLE_KEY_WEAK;
563 if (EQ (obj, Qvalue)) return HASH_TABLE_VALUE_WEAK;
564
565 /* Following values are obsolete as of 19990901 in xemacs-21.2 */
566 if (EQ (obj, Qnon_weak)) return HASH_TABLE_NON_WEAK;
567 if (EQ (obj, Qweak)) return HASH_TABLE_WEAK;
568 if (EQ (obj, Qkey_weak)) return HASH_TABLE_KEY_WEAK;
569 if (EQ (obj, Qvalue_weak)) return HASH_TABLE_VALUE_WEAK;
570
571 signal_simple_error ("Invalid hash table weakness", obj);
572 return HASH_TABLE_NON_WEAK; /* not reached */
573 }
574
575 static int
576 hash_table_test_validate (Lisp_Object keyword, Lisp_Object value,
577 Error_behavior errb)
578 {
579 if (EQ (value, Qnil)) return 1;
580 if (EQ (value, Qeq)) return 1;
581 if (EQ (value, Qequal)) return 1;
582 if (EQ (value, Qeql)) return 1;
583
584 maybe_signal_simple_error ("Invalid hash table test",
585 value, Qhash_table, errb);
586 return 0;
587 }
588
589 static enum hash_table_test
590 decode_hash_table_test (Lisp_Object obj)
591 {
592 if (EQ (obj, Qnil)) return HASH_TABLE_EQL;
593 if (EQ (obj, Qeq)) return HASH_TABLE_EQ;
594 if (EQ (obj, Qequal)) return HASH_TABLE_EQUAL;
595 if (EQ (obj, Qeql)) return HASH_TABLE_EQL;
596
597 signal_simple_error ("Invalid hash table test", obj);
598 return HASH_TABLE_EQ; /* not reached */
599 }
600
601 static int
602 hash_table_rehash_size_validate (Lisp_Object keyword, Lisp_Object value,
603 Error_behavior errb)
604 {
605 if (!FLOATP (value))
606 {
607 maybe_signal_error (Qwrong_type_argument, list2 (Qfloatp, value),
608 Qhash_table, errb);
609 return 0;
610 }
611
612 {
613 double rehash_size = XFLOAT_DATA (value);
614 if (rehash_size <= 1.0)
615 {
616 maybe_signal_simple_error
617 ("Hash table rehash size must be greater than 1.0",
618 value, Qhash_table, errb);
619 return 0;
620 }
621 }
622
623 return 1;
624 }
625
626 static double
627 decode_hash_table_rehash_size (Lisp_Object rehash_size)
628 {
629 return NILP (rehash_size) ? -1.0 : XFLOAT_DATA (rehash_size);
630 }
631
632 static int
633 hash_table_rehash_threshold_validate (Lisp_Object keyword, Lisp_Object value,
634 Error_behavior errb)
635 {
636 if (!FLOATP (value))
637 {
638 maybe_signal_error (Qwrong_type_argument, list2 (Qfloatp, value),
639 Qhash_table, errb);
640 return 0;
641 }
642
643 {
644 double rehash_threshold = XFLOAT_DATA (value);
645 if (rehash_threshold <= 0.0 || rehash_threshold >= 1.0)
646 {
647 maybe_signal_simple_error
648 ("Hash table rehash threshold must be between 0.0 and 1.0",
649 value, Qhash_table, errb);
650 return 0;
651 }
652 }
653
654 return 1;
655 }
656
657 static double
658 decode_hash_table_rehash_threshold (Lisp_Object rehash_threshold)
659 {
660 return NILP (rehash_threshold) ? -1.0 : XFLOAT_DATA (rehash_threshold);
661 }
662
663 static int
664 hash_table_data_validate (Lisp_Object keyword, Lisp_Object value,
665 Error_behavior errb)
666 {
667 int len;
668
669 GET_EXTERNAL_LIST_LENGTH (value, len);
670
671 if (len & 1)
672 {
673 maybe_signal_simple_error
674 ("Hash table data must have alternating key/value pairs",
675 value, Qhash_table, errb);
676 return 0;
677 }
678 return 1;
679 }
680
681 /* The actual instantiation of a hash table. This does practically no
682 error checking, because it relies on the fact that the paranoid
683 functions above have error-checked everything to the last details.
684 If this assumption is wrong, we will get a crash immediately (with
685 error-checking compiled in), and we'll know if there is a bug in
686 the structure mechanism. So there. */
687 static Lisp_Object
688 hash_table_instantiate (Lisp_Object plist)
689 {
690 Lisp_Object hash_table;
691 Lisp_Object test = Qnil;
692 Lisp_Object size = Qnil;
693 Lisp_Object rehash_size = Qnil;
694 Lisp_Object rehash_threshold = Qnil;
695 Lisp_Object weakness = Qnil;
696 Lisp_Object data = Qnil;
697
698 while (!NILP (plist))
699 {
700 Lisp_Object key, value;
701 key = XCAR (plist); plist = XCDR (plist);
702 value = XCAR (plist); plist = XCDR (plist);
703
704 if (EQ (key, Qtest)) test = value;
705 else if (EQ (key, Qsize)) size = value;
706 else if (EQ (key, Qrehash_size)) rehash_size = value;
707 else if (EQ (key, Qrehash_threshold)) rehash_threshold = value;
708 else if (EQ (key, Qweakness)) weakness = value;
709 else if (EQ (key, Qdata)) data = value;
710 else if (EQ (key, Qtype))/*obsolete*/ weakness = value;
711 else
712 abort ();
713 }
714
715 /* Create the hash table. */
716 hash_table = make_general_lisp_hash_table
717 (decode_hash_table_test (test),
718 decode_hash_table_size (size),
719 decode_hash_table_rehash_size (rehash_size),
720 decode_hash_table_rehash_threshold (rehash_threshold),
721 decode_hash_table_weakness (weakness));
722
723 /* I'm not sure whether this can GC, but better safe than sorry. */
724 {
725 struct gcpro gcpro1;
726 GCPRO1 (hash_table);
727
728 /* And fill it with data. */
729 while (!NILP (data))
730 {
731 Lisp_Object key, value;
732 key = XCAR (data); data = XCDR (data);
733 value = XCAR (data); data = XCDR (data);
734 Fputhash (key, value, hash_table);
735 }
736 UNGCPRO;
737 }
738
739 return hash_table;
740 }
741
742 static void
743 structure_type_create_hash_table_structure_name (Lisp_Object structure_name)
744 {
745 struct structure_type *st;
746
747 st = define_structure_type (structure_name, 0, hash_table_instantiate);
748 define_structure_type_keyword (st, Qtest, hash_table_test_validate);
749 define_structure_type_keyword (st, Qsize, hash_table_size_validate);
750 define_structure_type_keyword (st, Qrehash_size, hash_table_rehash_size_validate);
751 define_structure_type_keyword (st, Qrehash_threshold, hash_table_rehash_threshold_validate);
752 define_structure_type_keyword (st, Qweakness, hash_table_weakness_validate);
753 define_structure_type_keyword (st, Qdata, hash_table_data_validate);
754
755 /* obsolete as of 19990901 in xemacs-21.2 */
756 define_structure_type_keyword (st, Qtype, hash_table_weakness_validate);
757 }
758
759 /* Create a built-in Lisp structure type named `hash-table'.
760 We make #s(hashtable ...) equivalent to #s(hash-table ...),
761 for backward compatibility.
762 This is called from emacs.c. */
763 void
764 structure_type_create_hash_table (void)
765 {
766 structure_type_create_hash_table_structure_name (Qhash_table);
767 structure_type_create_hash_table_structure_name (Qhashtable); /* compat */
768 }
769
770
771 /************************************************************************/
772 /* Definition of Lisp-visible methods */
773 /************************************************************************/
774
775 DEFUN ("hash-table-p", Fhash_table_p, 1, 1, 0, /*
776 Return t if OBJECT is a hash table, else nil.
777 */
778 (object))
779 {
780 return HASH_TABLEP (object) ? Qt : Qnil;
781 }
782
783 DEFUN ("make-hash-table", Fmake_hash_table, 0, MANY, 0, /*
784 Return a new empty hash table object.
785 Use Common Lisp style keywords to specify hash table properties.
786 (make-hash-table &key test size rehash-size rehash-threshold weakness)
787
788 Keyword :test can be `eq', `eql' (default) or `equal'.
789 Comparison between keys is done using this function.
790 If speed is important, consider using `eq'.
791 When storing strings in the hash table, you will likely need to use `equal'.
792
793 Keyword :size specifies the number of keys likely to be inserted.
794 This number of entries can be inserted without enlarging the hash table.
795
796 Keyword :rehash-size must be a float greater than 1.0, and specifies
797 the factor by which to increase the size of the hash table when enlarging.
798
799 Keyword :rehash-threshold must be a float between 0.0 and 1.0,
800 and specifies the load factor of the hash table which triggers enlarging.
801
802 Non-standard keyword :weakness can be `nil' (default), `t', `key' or `value'.
803
804 A weak hash table is one whose pointers do not count as GC referents:
805 for any key-value pair in the hash table, if the only remaining pointer
806 to either the key or the value is in a weak hash table, then the pair
807 will be removed from the hash table, and the key and value collected.
808 A non-weak hash table (or any other pointer) would prevent the object
809 from being collected.
810
811 A key-weak hash table is similar to a fully-weak hash table except that
812 a key-value pair will be removed only if the key remains unmarked
813 outside of weak hash tables. The pair will remain in the hash table if
814 the key is pointed to by something other than a weak hash table, even
815 if the value is not.
816
817 A value-weak hash table is similar to a fully-weak hash table except
818 that a key-value pair will be removed only if the value remains
819 unmarked outside of weak hash tables. The pair will remain in the
820 hash table if the value is pointed to by something other than a weak
821 hash table, even if the key is not.
822 */
823 (int nargs, Lisp_Object *args))
824 {
825 int i = 0;
826 Lisp_Object test = Qnil;
827 Lisp_Object size = Qnil;
828 Lisp_Object rehash_size = Qnil;
829 Lisp_Object rehash_threshold = Qnil;
830 Lisp_Object weakness = Qnil;
831
832 while (i + 1 < nargs)
833 {
834 Lisp_Object keyword = args[i++];
835 Lisp_Object value = args[i++];
836
837 if (EQ (keyword, Q_test)) test = value;
838 else if (EQ (keyword, Q_size)) size = value;
839 else if (EQ (keyword, Q_rehash_size)) rehash_size = value;
840 else if (EQ (keyword, Q_rehash_threshold)) rehash_threshold = value;
841 else if (EQ (keyword, Q_weakness)) weakness = value;
842 else if (EQ (keyword, Q_type))/*obsolete*/ weakness = value;
843 else signal_simple_error ("Invalid hash table property keyword", keyword);
844 }
845
846 if (i < nargs)
847 signal_simple_error ("Hash table property requires a value", args[i]);
848
849 #define VALIDATE_VAR(var) \
850 if (!NILP (var)) hash_table_##var##_validate (Q##var, var, ERROR_ME);
851
852 VALIDATE_VAR (test);
853 VALIDATE_VAR (size);
854 VALIDATE_VAR (rehash_size);
855 VALIDATE_VAR (rehash_threshold);
856 VALIDATE_VAR (weakness);
857
858 return make_general_lisp_hash_table
859 (decode_hash_table_test (test),
860 decode_hash_table_size (size),
861 decode_hash_table_rehash_size (rehash_size),
862 decode_hash_table_rehash_threshold (rehash_threshold),
863 decode_hash_table_weakness (weakness));
864 }
865
866 DEFUN ("copy-hash-table", Fcopy_hash_table, 1, 1, 0, /*
867 Return a new hash table containing the same keys and values as HASH-TABLE.
868 The keys and values will not themselves be copied.
869 */
870 (hash_table))
871 {
872 CONST Lisp_Hash_Table *ht_old = xhash_table (hash_table);
873 Lisp_Hash_Table *ht = alloc_lcrecord_type (Lisp_Hash_Table, &lrecord_hash_table);
874
875 copy_lcrecord (ht, ht_old);
876
877 ht->hentries = xnew_array (hentry, ht_old->size + 1);
878 memcpy (ht->hentries, ht_old->hentries, (ht_old->size + 1) * sizeof (hentry));
879
880 XSETHASH_TABLE (hash_table, ht);
881
882 if (! EQ (ht->next_weak, Qunbound))
883 {
884 ht->next_weak = Vall_weak_hash_tables;
885 Vall_weak_hash_tables = hash_table;
886 }
887
888 return hash_table;
889 }
890
891 static void
892 resize_hash_table (Lisp_Hash_Table *ht, size_t new_size)
893 {
894 hentry *old_entries, *new_entries, *old_sentinel, *new_sentinel, *e;
895 size_t old_size;
896
897 old_size = ht->size;
898 ht->size = new_size;
899
900 old_entries = ht->hentries;
901
902 ht->hentries = xnew_array (hentry, new_size + 1);
903 new_entries = ht->hentries;
904
905 old_sentinel = old_entries + old_size;
906 new_sentinel = new_entries + new_size;
907
908 for (e = new_entries; e <= new_sentinel; e++)
909 CLEAR_HENTRY (e);
910
911 compute_hash_table_derived_values (ht);
912
913 for (e = old_entries; e < old_sentinel; e++)
914 if (!HENTRY_CLEAR_P (e))
915 {
916 hentry *probe = new_entries + HASH_CODE (e->key, ht);
917 LINEAR_PROBING_LOOP (probe, new_entries, new_size)
918 ;
919 *probe = *e;
920 }
921
922 if (!DUMPEDP (old_entries))
923 xfree (old_entries);
924 }
925
926 void
927 reorganize_hash_table (Lisp_Hash_Table *ht)
928 {
929 resize_hash_table (ht, ht->size);
930 }
931
932 static void
933 enlarge_hash_table (Lisp_Hash_Table *ht)
934 {
935 size_t new_size =
936 hash_table_size ((size_t) ((double) ht->size * ht->rehash_size));
937 resize_hash_table (ht, new_size);
938 }
939
940 static hentry *
941 find_hentry (Lisp_Object key, CONST Lisp_Hash_Table *ht)
942 {
943 hash_table_test_function_t test_function = ht->test_function;
944 hentry *entries = ht->hentries;
945 hentry *probe = entries + HASH_CODE (key, ht);
946
947 LINEAR_PROBING_LOOP (probe, entries, ht->size)
948 if (KEYS_EQUAL_P (probe->key, key, test_function))
949 break;
950
951 return probe;
952 }
953
954 DEFUN ("gethash", Fgethash, 2, 3, 0, /*
955 Find hash value for KEY in HASH-TABLE.
956 If there is no corresponding value, return DEFAULT (which defaults to nil).
957 */
958 (key, hash_table, default_))
959 {
960 CONST Lisp_Hash_Table *ht = xhash_table (hash_table);
961 hentry *e = find_hentry (key, ht);
962
963 return HENTRY_CLEAR_P (e) ? default_ : e->value;
964 }
965
966 DEFUN ("puthash", Fputhash, 3, 3, 0, /*
967 Hash KEY to VALUE in HASH-TABLE.
968 */
969 (key, value, hash_table))
970 {
971 Lisp_Hash_Table *ht = xhash_table (hash_table);
972 hentry *e = find_hentry (key, ht);
973
974 if (!HENTRY_CLEAR_P (e))
975 return e->value = value;
976
977 e->key = key;
978 e->value = value;
979
980 if (++ht->count >= ht->rehash_count)
981 enlarge_hash_table (ht);
982
983 return value;
984 }
985
986 /* Remove hentry pointed at by PROBE.
987 Subsequent entries are removed and reinserted.
988 We don't use tombstones - too wasteful. */
989 static void
990 remhash_1 (Lisp_Hash_Table *ht, hentry *entries, hentry *probe)
991 {
992 size_t size = ht->size;
993 CLEAR_HENTRY (probe);
994 probe++;
995 ht->count--;
996
997 LINEAR_PROBING_LOOP (probe, entries, size)
998 {
999 Lisp_Object key = probe->key;
1000 hentry *probe2 = entries + HASH_CODE (key, ht);
1001 LINEAR_PROBING_LOOP (probe2, entries, size)
1002 if (EQ (probe2->key, key))
1003 /* hentry at probe doesn't need to move. */
1004 goto continue_outer_loop;
1005 /* Move hentry from probe to new home at probe2. */
1006 *probe2 = *probe;
1007 CLEAR_HENTRY (probe);
1008 continue_outer_loop: continue;
1009 }
1010 }
1011
1012 DEFUN ("remhash", Fremhash, 2, 2, 0, /*
1013 Remove the entry for KEY from HASH-TABLE.
1014 Do nothing if there is no entry for KEY in HASH-TABLE.
1015 */
1016 (key, hash_table))
1017 {
1018 Lisp_Hash_Table *ht = xhash_table (hash_table);
1019 hentry *e = find_hentry (key, ht);
1020
1021 if (HENTRY_CLEAR_P (e))
1022 return Qnil;
1023
1024 remhash_1 (ht, ht->hentries, e);
1025 return Qt;
1026 }
1027
1028 DEFUN ("clrhash", Fclrhash, 1, 1, 0, /*
1029 Remove all entries from HASH-TABLE, leaving it empty.
1030 */
1031 (hash_table))
1032 {
1033 Lisp_Hash_Table *ht = xhash_table (hash_table);
1034 hentry *e, *sentinel;
1035
1036 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1037 CLEAR_HENTRY (e);
1038 ht->count = 0;
1039
1040 return hash_table;
1041 }
1042
1043 /************************************************************************/
1044 /* Accessor Functions */
1045 /************************************************************************/
1046
1047 DEFUN ("hash-table-count", Fhash_table_count, 1, 1, 0, /*
1048 Return the number of entries in HASH-TABLE.
1049 */
1050 (hash_table))
1051 {
1052 return make_int (xhash_table (hash_table)->count);
1053 }
1054
1055 DEFUN ("hash-table-test", Fhash_table_test, 1, 1, 0, /*
1056 Return the test function of HASH-TABLE.
1057 This can be one of `eq', `eql' or `equal'.
1058 */
1059 (hash_table))
1060 {
1061 hash_table_test_function_t fun = xhash_table (hash_table)->test_function;
1062
1063 return (fun == lisp_object_eql_equal ? Qeql :
1064 fun == lisp_object_equal_equal ? Qequal :
1065 Qeq);
1066 }
1067
1068 DEFUN ("hash-table-size", Fhash_table_size, 1, 1, 0, /*
1069 Return the size of HASH-TABLE.
1070 This is the current number of slots in HASH-TABLE, whether occupied or not.
1071 */
1072 (hash_table))
1073 {
1074 return make_int (xhash_table (hash_table)->size);
1075 }
1076
1077 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size, 1, 1, 0, /*
1078 Return the current rehash size of HASH-TABLE.
1079 This is a float greater than 1.0; the factor by which HASH-TABLE
1080 is enlarged when the rehash threshold is exceeded.
1081 */
1082 (hash_table))
1083 {
1084 return make_float (xhash_table (hash_table)->rehash_size);
1085 }
1086
1087 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold, 1, 1, 0, /*
1088 Return the current rehash threshold of HASH-TABLE.
1089 This is a float between 0.0 and 1.0; the maximum `load factor' of HASH-TABLE,
1090 beyond which the HASH-TABLE is enlarged by rehashing.
1091 */
1092 (hash_table))
1093 {
1094 return make_float (hash_table_rehash_threshold (xhash_table (hash_table)));
1095 }
1096
1097 DEFUN ("hash-table-weakness", Fhash_table_weakness, 1, 1, 0, /*
1098 Return the weakness of HASH-TABLE.
1099 This can be one of `nil', `t', `key' or `value'.
1100 */
1101 (hash_table))
1102 {
1103 switch (xhash_table (hash_table)->weakness)
1104 {
1105 case HASH_TABLE_WEAK: return Qt;
1106 case HASH_TABLE_KEY_WEAK: return Qkey;
1107 case HASH_TABLE_VALUE_WEAK: return Qvalue;
1108 default: return Qnil;
1109 }
1110 }
1111
1112 /* obsolete as of 19990901 in xemacs-21.2 */
1113 DEFUN ("hash-table-type", Fhash_table_type, 1, 1, 0, /*
1114 Return the type of HASH-TABLE.
1115 This can be one of `non-weak', `weak', `key-weak' or `value-weak'.
1116 */
1117 (hash_table))
1118 {
1119 switch (xhash_table (hash_table)->weakness)
1120 {
1121 case HASH_TABLE_WEAK: return Qweak;
1122 case HASH_TABLE_KEY_WEAK: return Qkey_weak;
1123 case HASH_TABLE_VALUE_WEAK: return Qvalue_weak;
1124 default: return Qnon_weak;
1125 }
1126 }
1127
1128 /************************************************************************/
1129 /* Mapping Functions */
1130 /************************************************************************/
1131 DEFUN ("maphash", Fmaphash, 2, 2, 0, /*
1132 Map FUNCTION over entries in HASH-TABLE, calling it with two args,
1133 each key and value in HASH-TABLE.
1134
1135 FUNCTION may not modify HASH-TABLE, with the one exception that FUNCTION
1136 may remhash or puthash the entry currently being processed by FUNCTION.
1137 */
1138 (function, hash_table))
1139 {
1140 CONST Lisp_Hash_Table *ht = xhash_table (hash_table);
1141 CONST hentry *e, *sentinel;
1142
1143 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1144 if (!HENTRY_CLEAR_P (e))
1145 {
1146 Lisp_Object args[3], key;
1147 again:
1148 key = e->key;
1149 args[0] = function;
1150 args[1] = key;
1151 args[2] = e->value;
1152 Ffuncall (countof (args), args);
1153 /* Has FUNCTION done a remhash? */
1154 if (!EQ (key, e->key) && !HENTRY_CLEAR_P (e))
1155 goto again;
1156 }
1157
1158 return Qnil;
1159 }
1160
1161 /* Map *C* function FUNCTION over the elements of a lisp hash table. */
1162 void
1163 elisp_maphash (maphash_function_t function,
1164 Lisp_Object hash_table, void *extra_arg)
1165 {
1166 CONST Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1167 CONST hentry *e, *sentinel;
1168
1169 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1170 if (!HENTRY_CLEAR_P (e))
1171 {
1172 Lisp_Object key;
1173 again:
1174 key = e->key;
1175 if (function (key, e->value, extra_arg))
1176 return;
1177 /* Has FUNCTION done a remhash? */
1178 if (!EQ (key, e->key) && !HENTRY_CLEAR_P (e))
1179 goto again;
1180 }
1181 }
1182
1183 /* Remove all elements of a lisp hash table satisfying *C* predicate PREDICATE. */
1184 void
1185 elisp_map_remhash (maphash_function_t predicate,
1186 Lisp_Object hash_table, void *extra_arg)
1187 {
1188 Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1189 hentry *e, *entries, *sentinel;
1190
1191 for (e = entries = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1192 if (!HENTRY_CLEAR_P (e))
1193 {
1194 again:
1195 if (predicate (e->key, e->value, extra_arg))
1196 {
1197 remhash_1 (ht, entries, e);
1198 if (!HENTRY_CLEAR_P (e))
1199 goto again;
1200 }
1201 }
1202 }
1203
1204
1205 /************************************************************************/
1206 /* garbage collecting weak hash tables */
1207 /************************************************************************/
1208
1209 /* Complete the marking for semi-weak hash tables. */
1210 int
1211 finish_marking_weak_hash_tables (void)
1212 {
1213 Lisp_Object hash_table;
1214 int did_mark = 0;
1215
1216 for (hash_table = Vall_weak_hash_tables;
1217 !NILP (hash_table);
1218 hash_table = XHASH_TABLE (hash_table)->next_weak)
1219 {
1220 CONST Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1221 CONST hentry *e = ht->hentries;
1222 CONST hentry *sentinel = e + ht->size;
1223
1224 if (! marked_p (hash_table))
1225 /* The hash table is probably garbage. Ignore it. */
1226 continue;
1227
1228 /* Now, scan over all the pairs. For all pairs that are
1229 half-marked, we may need to mark the other half if we're
1230 keeping this pair. */
1231 #define MARK_OBJ(obj) \
1232 do { if (!marked_p (obj)) mark_object (obj), did_mark = 1; } while (0)
1233
1234 switch (ht->weakness)
1235 {
1236 case HASH_TABLE_KEY_WEAK:
1237 for (; e < sentinel; e++)
1238 if (!HENTRY_CLEAR_P (e))
1239 if (marked_p (e->key))
1240 MARK_OBJ (e->value);
1241 break;
1242
1243 case HASH_TABLE_VALUE_WEAK:
1244 for (; e < sentinel; e++)
1245 if (!HENTRY_CLEAR_P (e))
1246 if (marked_p (e->value))
1247 MARK_OBJ (e->key);
1248 break;
1249
1250 case HASH_TABLE_KEY_CAR_WEAK:
1251 for (; e < sentinel; e++)
1252 if (!HENTRY_CLEAR_P (e))
1253 if (!CONSP (e->key) || marked_p (XCAR (e->key)))
1254 {
1255 MARK_OBJ (e->key);
1256 MARK_OBJ (e->value);
1257 }
1258 break;
1259
1260 case HASH_TABLE_VALUE_CAR_WEAK:
1261 for (; e < sentinel; e++)
1262 if (!HENTRY_CLEAR_P (e))
1263 if (!CONSP (e->value) || marked_p (XCAR (e->value)))
1264 {
1265 MARK_OBJ (e->key);
1266 MARK_OBJ (e->value);
1267 }
1268 break;
1269
1270 default:
1271 break;
1272 }
1273 }
1274
1275 return did_mark;
1276 }
1277
1278 void
1279 prune_weak_hash_tables (void)
1280 {
1281 Lisp_Object hash_table, prev = Qnil;
1282 for (hash_table = Vall_weak_hash_tables;
1283 !NILP (hash_table);
1284 hash_table = XHASH_TABLE (hash_table)->next_weak)
1285 {
1286 if (! marked_p (hash_table))
1287 {
1288 /* This hash table itself is garbage. Remove it from the list. */
1289 if (NILP (prev))
1290 Vall_weak_hash_tables = XHASH_TABLE (hash_table)->next_weak;
1291 else
1292 XHASH_TABLE (prev)->next_weak = XHASH_TABLE (hash_table)->next_weak;
1293 }
1294 else
1295 {
1296 /* Now, scan over all the pairs. Remove all of the pairs
1297 in which the key or value, or both, is unmarked
1298 (depending on the weakness of the hash table). */
1299 Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1300 hentry *entries = ht->hentries;
1301 hentry *sentinel = entries + ht->size;
1302 hentry *e;
1303
1304 for (e = entries; e < sentinel; e++)
1305 if (!HENTRY_CLEAR_P (e))
1306 {
1307 again:
1308 if (!marked_p (e->key) || !marked_p (e->value))
1309 {
1310 remhash_1 (ht, entries, e);
1311 if (!HENTRY_CLEAR_P (e))
1312 goto again;
1313 }
1314 }
1315
1316 prev = hash_table;
1317 }
1318 }
1319 }
1320
1321 /* Return a hash value for an array of Lisp_Objects of size SIZE. */
1322
1323 hashcode_t
1324 internal_array_hash (Lisp_Object *arr, int size, int depth)
1325 {
1326 int i;
1327 unsigned long hash = 0;
1328
1329 if (size <= 5)
1330 {
1331 for (i = 0; i < size; i++)
1332 hash = HASH2 (hash, internal_hash (arr[i], depth + 1));
1333 return hash;
1334 }
1335
1336 /* just pick five elements scattered throughout the array.
1337 A slightly better approach would be to offset by some
1338 noise factor from the points chosen below. */
1339 for (i = 0; i < 5; i++)
1340 hash = HASH2 (hash, internal_hash (arr[i*size/5], depth + 1));
1341
1342 return hash;
1343 }
1344
1345 /* Return a hash value for a Lisp_Object. This is for use when hashing
1346 objects with the comparison being `equal' (for `eq', you can just
1347 use the Lisp_Object itself as the hash value). You need to make a
1348 tradeoff between the speed of the hash function and how good the
1349 hashing is. In particular, the hash function needs to be FAST,
1350 so you can't just traipse down the whole tree hashing everything
1351 together. Most of the time, objects will differ in the first
1352 few elements you hash. Thus, we only go to a short depth (5)
1353 and only hash at most 5 elements out of a vector. Theoretically
1354 we could still take 5^5 time (a big big number) to compute a
1355 hash, but practically this won't ever happen. */
1356
1357 hashcode_t
1358 internal_hash (Lisp_Object obj, int depth)
1359 {
1360 if (depth > 5)
1361 return 0;
1362 if (CONSP (obj))
1363 {
1364 /* no point in worrying about tail recursion, since we're not
1365 going very deep */
1366 return HASH2 (internal_hash (XCAR (obj), depth + 1),
1367 internal_hash (XCDR (obj), depth + 1));
1368 }
1369 if (STRINGP (obj))
1370 {
1371 return hash_string (XSTRING_DATA (obj), XSTRING_LENGTH (obj));
1372 }
1373 if (VECTORP (obj))
1374 {
1375 return HASH2 (XVECTOR_LENGTH (obj),
1376 internal_array_hash (XVECTOR_DATA (obj),
1377 XVECTOR_LENGTH (obj),
1378 depth + 1));
1379 }
1380 if (LRECORDP (obj))
1381 {
1382 CONST struct lrecord_implementation
1383 *imp = XRECORD_LHEADER_IMPLEMENTATION (obj);
1384 if (imp->hash)
1385 return imp->hash (obj, depth);
1386 }
1387
1388 return LISP_HASH (obj);
1389 }
1390
1391 DEFUN ("sxhash", Fsxhash, 1, 1, 0, /*
1392 Return a hash value for OBJECT.
1393 (equal obj1 obj2) implies (= (sxhash obj1) (sxhash obj2)).
1394 */
1395 (object))
1396 {
1397 return make_int (internal_hash (object, 0));
1398 }
1399
1400 #if 0
1401 xxDEFUN ("internal-hash-value", Finternal_hash_value, 1, 1, 0, /*
1402 Hash value of OBJECT. For debugging.
1403 The value is returned as (HIGH . LOW).
1404 */
1405 (object))
1406 {
1407 /* This function is pretty 32bit-centric. */
1408 unsigned long hash = internal_hash (object, 0);
1409 return Fcons (hash >> 16, hash & 0xffff);
1410 }
1411 #endif
1412
1413
1414 /************************************************************************/
1415 /* initialization */
1416 /************************************************************************/
1417
1418 void
1419 syms_of_elhash (void)
1420 {
1421 DEFSUBR (Fhash_table_p);
1422 DEFSUBR (Fmake_hash_table);
1423 DEFSUBR (Fcopy_hash_table);
1424 DEFSUBR (Fgethash);
1425 DEFSUBR (Fremhash);
1426 DEFSUBR (Fputhash);
1427 DEFSUBR (Fclrhash);
1428 DEFSUBR (Fmaphash);
1429 DEFSUBR (Fhash_table_count);
1430 DEFSUBR (Fhash_table_test);
1431 DEFSUBR (Fhash_table_size);
1432 DEFSUBR (Fhash_table_rehash_size);
1433 DEFSUBR (Fhash_table_rehash_threshold);
1434 DEFSUBR (Fhash_table_weakness);
1435 DEFSUBR (Fhash_table_type); /* obsolete */
1436 DEFSUBR (Fsxhash);
1437 #if 0
1438 DEFSUBR (Finternal_hash_value);
1439 #endif
1440
1441 defsymbol (&Qhash_tablep, "hash-table-p");
1442 defsymbol (&Qhash_table, "hash-table");
1443 defsymbol (&Qhashtable, "hashtable");
1444 defsymbol (&Qweakness, "weakness");
1445 defsymbol (&Qvalue, "value");
1446 defsymbol (&Qrehash_size, "rehash-size");
1447 defsymbol (&Qrehash_threshold, "rehash-threshold");
1448
1449 defsymbol (&Qweak, "weak"); /* obsolete */
1450 defsymbol (&Qkey_weak, "key-weak"); /* obsolete */
1451 defsymbol (&Qvalue_weak, "value-weak"); /* obsolete */
1452 defsymbol (&Qnon_weak, "non-weak"); /* obsolete */
1453
1454 defkeyword (&Q_test, ":test");
1455 defkeyword (&Q_size, ":size");
1456 defkeyword (&Q_rehash_size, ":rehash-size");
1457 defkeyword (&Q_rehash_threshold, ":rehash-threshold");
1458 defkeyword (&Q_weakness, ":weakness");
1459 defkeyword (&Q_type, ":type"); /* obsolete */
1460 }
1461
1462 void
1463 vars_of_elhash (void)
1464 {
1465 /* This must NOT be staticpro'd */
1466 Vall_weak_hash_tables = Qnil;
1467 pdump_wire_list (&Vall_weak_hash_tables);
1468 }