Reformatted.
[chise/xemacs-chise.git.1] / src / elhash.c
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, Qkey_or_value, Qkey_and_value;
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, Qkey_or_value_weak;
39 static Lisp_Object Qnon_weak, Q_type;
40
41 typedef struct hentry
42 {
43   Lisp_Object key;
44   Lisp_Object value;
45 } hentry;
46
47 struct Lisp_Hash_Table
48 {
49   struct lcrecord_header header;
50   size_t size;
51   size_t count;
52   size_t rehash_count;
53   double rehash_size;
54   double rehash_threshold;
55   size_t golden_ratio;
56   hash_table_hash_function_t hash_function;
57   hash_table_test_function_t test_function;
58   hentry *hentries;
59   enum hash_table_weakness weakness;
60   Lisp_Object next_weak;     /* Used to chain together all of the weak
61                                 hash tables.  Don't mark through this. */
62 };
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 \f
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 \f
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 \f
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 /* This is not a great hash function, but it _is_ correct and fast.
258    Examining all entries is too expensive, and examining a random
259    subset does not yield a correct hash function. */
260 static hashcode_t
261 hash_table_hash (Lisp_Object hash_table, int depth)
262 {
263   return XHASH_TABLE (hash_table)->count;
264 }
265
266 \f
267 /* Printing hash tables.
268
269    This is non-trivial, because we use a readable structure-style
270    syntax for hash tables.  This means that a typical hash table will be
271    readably printed in the form of:
272
273    #s(hash-table size 2 data (key1 value1 key2 value2))
274
275    The supported hash table structure keywords and their values are:
276    `test'             (eql (or nil), eq or equal)
277    `size'             (a natnum or nil)
278    `rehash-size'      (a float)
279    `rehash-threshold' (a float)
280    `weakness'         (nil, key, value, key-and-value, or key-or-value)
281    `data'             (a list)
282
283    If `print-readably' is nil, then a simpler syntax is used, for example
284
285    #<hash-table size 2/13 data (key1 value1 key2 value2) 0x874d>
286
287    The data is truncated to four pairs, and the rest is shown with
288    `...'.  This printer does not cons.  */
289
290
291 /* Print the data of the hash table.  This maps through a Lisp
292    hash table and prints key/value pairs using PRINTCHARFUN.  */
293 static void
294 print_hash_table_data (Lisp_Hash_Table *ht, Lisp_Object printcharfun)
295 {
296   int count = 0;
297   hentry *e, *sentinel;
298
299   write_c_string (" data (", printcharfun);
300
301   for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
302     if (!HENTRY_CLEAR_P (e))
303       {
304         if (count > 0)
305           write_c_string (" ", printcharfun);
306         if (!print_readably && count > 3)
307           {
308             write_c_string ("...", printcharfun);
309             break;
310           }
311         print_internal (e->key, printcharfun, 1);
312         write_c_string (" ", printcharfun);
313         print_internal (e->value, printcharfun, 1);
314         count++;
315       }
316
317   write_c_string (")", printcharfun);
318 }
319
320 static void
321 print_hash_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
322 {
323   Lisp_Hash_Table *ht = XHASH_TABLE (obj);
324   char buf[128];
325
326   write_c_string (print_readably ? "#s(hash-table" : "#<hash-table",
327                   printcharfun);
328
329   /* These checks have a kludgy look to them, but they are safe.
330      Due to nature of hashing, you cannot use arbitrary
331      test functions anyway.  */
332   if (!ht->test_function)
333     write_c_string (" test eq", printcharfun);
334   else if (ht->test_function == lisp_object_equal_equal)
335     write_c_string (" test equal", printcharfun);
336   else if (ht->test_function == lisp_object_eql_equal)
337     DO_NOTHING;
338   else
339     ABORT ();
340
341   if (ht->count || !print_readably)
342     {
343       if (print_readably)
344         sprintf (buf, " size %lu", (unsigned long) ht->count);
345       else
346         sprintf (buf, " size %lu/%lu",
347                  (unsigned long) ht->count,
348                  (unsigned long) ht->size);
349       write_c_string (buf, printcharfun);
350     }
351
352   if (ht->weakness != HASH_TABLE_NON_WEAK)
353     {
354       sprintf (buf, " weakness %s",
355                (ht->weakness == HASH_TABLE_WEAK           ? "key-and-value" :
356                 ht->weakness == HASH_TABLE_KEY_WEAK       ? "key" :
357                 ht->weakness == HASH_TABLE_VALUE_WEAK     ? "value" :
358                 ht->weakness == HASH_TABLE_KEY_VALUE_WEAK ? "key-or-value" :
359                 "you-d-better-not-see-this"));
360       write_c_string (buf, printcharfun);
361     }
362
363   if (ht->count)
364     print_hash_table_data (ht, printcharfun);
365
366   if (print_readably)
367     write_c_string (")", printcharfun);
368   else
369     {
370       sprintf (buf, " 0x%x>", ht->header.uid);
371       write_c_string (buf, printcharfun);
372     }
373 }
374
375 static void
376 finalize_hash_table (void *header, int for_disksave)
377 {
378   if (!for_disksave)
379     {
380       Lisp_Hash_Table *ht = (Lisp_Hash_Table *) header;
381
382       xfree (ht->hentries);
383       ht->hentries = 0;
384     }
385 }
386
387 static const struct lrecord_description hentry_description_1[] = {
388   { XD_LISP_OBJECT, offsetof (hentry, key) },
389   { XD_LISP_OBJECT, offsetof (hentry, value) },
390   { XD_END }
391 };
392
393 static const struct struct_description hentry_description = {
394   sizeof (hentry),
395   hentry_description_1
396 };
397
398 const struct lrecord_description hash_table_description[] = {
399   { XD_SIZE_T,     offsetof (Lisp_Hash_Table, size) },
400   { XD_STRUCT_PTR, offsetof (Lisp_Hash_Table, hentries), XD_INDIRECT(0, 1), &hentry_description },
401   { XD_LO_LINK,    offsetof (Lisp_Hash_Table, next_weak) },
402   { XD_END }
403 };
404
405 DEFINE_LRECORD_IMPLEMENTATION ("hash-table", hash_table,
406                                mark_hash_table, print_hash_table,
407                                finalize_hash_table,
408                                hash_table_equal, hash_table_hash,
409                                hash_table_description,
410                                Lisp_Hash_Table);
411
412 static Lisp_Hash_Table *
413 xhash_table (Lisp_Object hash_table)
414 {
415   if (!gc_in_progress)
416     CHECK_HASH_TABLE (hash_table);
417   check_hash_table_invariants (XHASH_TABLE (hash_table));
418   return XHASH_TABLE (hash_table);
419 }
420
421 \f
422 /************************************************************************/
423 /*                       Creation of Hash Tables                        */
424 /************************************************************************/
425
426 /* Creation of hash tables, without error-checking. */
427 static void
428 compute_hash_table_derived_values (Lisp_Hash_Table *ht)
429 {
430   ht->rehash_count = (size_t)
431     ((double) ht->size * ht->rehash_threshold);
432   ht->golden_ratio = (size_t)
433     ((double) ht->size * (.6180339887 / (double) sizeof (Lisp_Object)));
434 }
435
436 Lisp_Object
437 make_standard_lisp_hash_table (enum hash_table_test test,
438                                size_t size,
439                                double rehash_size,
440                                double rehash_threshold,
441                                enum hash_table_weakness weakness)
442 {
443   hash_table_hash_function_t hash_function =  0;
444   hash_table_test_function_t test_function = 0;
445
446   switch (test)
447     {
448     case HASH_TABLE_EQ:
449       test_function = 0;
450       hash_function = 0;
451       break;
452
453     case HASH_TABLE_EQL:
454       test_function = lisp_object_eql_equal;
455       hash_function = lisp_object_eql_hash;
456       break;
457
458     case HASH_TABLE_EQUAL:
459       test_function = lisp_object_equal_equal;
460       hash_function = lisp_object_equal_hash;
461       break;
462
463     default:
464       ABORT ();
465     }
466
467   return make_general_lisp_hash_table (hash_function, test_function,
468                                        size, rehash_size, rehash_threshold,
469                                        weakness);
470 }
471
472 Lisp_Object
473 make_general_lisp_hash_table (hash_table_hash_function_t hash_function,
474                               hash_table_test_function_t test_function,
475                               size_t size,
476                               double rehash_size,
477                               double rehash_threshold,
478                               enum hash_table_weakness weakness)
479 {
480   Lisp_Object hash_table;
481   Lisp_Hash_Table *ht = alloc_lcrecord_type (Lisp_Hash_Table, &lrecord_hash_table);
482
483   ht->test_function = test_function;
484   ht->hash_function = hash_function;
485   ht->weakness = weakness;
486
487   ht->rehash_size =
488     rehash_size > 1.0 ? rehash_size : HASH_TABLE_DEFAULT_REHASH_SIZE;
489
490   ht->rehash_threshold =
491     rehash_threshold > 0.0 ? rehash_threshold :
492     size > 4096 && !ht->test_function ? 0.7 : 0.6;
493
494   if (size < HASH_TABLE_MIN_SIZE)
495     size = HASH_TABLE_MIN_SIZE;
496   ht->size = hash_table_size ((size_t) (((double) size / ht->rehash_threshold)
497                                         + 1.0));
498   ht->count = 0;
499
500   compute_hash_table_derived_values (ht);
501
502   /* We leave room for one never-occupied sentinel hentry at the end.  */
503   ht->hentries = xnew_array_and_zero (hentry, ht->size + 1);
504
505   XSETHASH_TABLE (hash_table, ht);
506
507   if (weakness == HASH_TABLE_NON_WEAK)
508     ht->next_weak = Qunbound;
509   else
510     ht->next_weak = Vall_weak_hash_tables, Vall_weak_hash_tables = hash_table;
511
512   return hash_table;
513 }
514
515 Lisp_Object
516 make_lisp_hash_table (size_t size,
517                       enum hash_table_weakness weakness,
518                       enum hash_table_test test)
519 {
520   return make_standard_lisp_hash_table (test, size, -1.0, -1.0, weakness);
521 }
522
523 /* Pretty reading of hash tables.
524
525    Here we use the existing structures mechanism (which is,
526    unfortunately, pretty cumbersome) for validating and instantiating
527    the hash tables.  The idea is that the side-effect of reading a
528    #s(hash-table PLIST) object is creation of a hash table with desired
529    properties, and that the hash table is returned.  */
530
531 /* Validation functions: each keyword provides its own validation
532    function.  The errors should maybe be continuable, but it is
533    unclear how this would cope with ERRB.  */
534 static int
535 hash_table_size_validate (Lisp_Object keyword, Lisp_Object value,
536                          Error_behavior errb)
537 {
538   if (NATNUMP (value))
539     return 1;
540
541   maybe_signal_error (Qwrong_type_argument, list2 (Qnatnump, value),
542                       Qhash_table, errb);
543   return 0;
544 }
545
546 static size_t
547 decode_hash_table_size (Lisp_Object obj)
548 {
549   return NILP (obj) ? HASH_TABLE_DEFAULT_SIZE : XINT (obj);
550 }
551
552 static int
553 hash_table_weakness_validate (Lisp_Object keyword, Lisp_Object value,
554                               Error_behavior errb)
555 {
556   if (EQ (value, Qnil))                 return 1;
557   if (EQ (value, Qt))                   return 1;
558   if (EQ (value, Qkey))                 return 1;
559   if (EQ (value, Qkey_and_value))       return 1;
560   if (EQ (value, Qkey_or_value))        return 1;
561   if (EQ (value, Qvalue))               return 1;
562
563   /* Following values are obsolete as of 19990901 in xemacs-21.2 */
564   if (EQ (value, Qnon_weak))            return 1;
565   if (EQ (value, Qweak))                return 1;
566   if (EQ (value, Qkey_weak))            return 1;
567   if (EQ (value, Qkey_or_value_weak))   return 1;
568   if (EQ (value, Qvalue_weak))          return 1;
569
570   maybe_signal_simple_error ("Invalid hash table weakness",
571                              value, Qhash_table, errb);
572   return 0;
573 }
574
575 static enum hash_table_weakness
576 decode_hash_table_weakness (Lisp_Object obj)
577 {
578   if (EQ (obj, Qnil))                   return HASH_TABLE_NON_WEAK;
579   if (EQ (obj, Qt))                     return HASH_TABLE_WEAK;
580   if (EQ (obj, Qkey_and_value))         return HASH_TABLE_WEAK;
581   if (EQ (obj, Qkey))                   return HASH_TABLE_KEY_WEAK;
582   if (EQ (obj, Qkey_or_value))          return HASH_TABLE_KEY_VALUE_WEAK;
583   if (EQ (obj, Qvalue))                 return HASH_TABLE_VALUE_WEAK;
584
585   /* Following values are obsolete as of 19990901 in xemacs-21.2 */
586   if (EQ (obj, Qnon_weak))              return HASH_TABLE_NON_WEAK;
587   if (EQ (obj, Qweak))                  return HASH_TABLE_WEAK;
588   if (EQ (obj, Qkey_weak))              return HASH_TABLE_KEY_WEAK;
589   if (EQ (obj, Qkey_or_value_weak))     return HASH_TABLE_KEY_VALUE_WEAK;
590   if (EQ (obj, Qvalue_weak))            return HASH_TABLE_VALUE_WEAK;
591
592   signal_simple_error ("Invalid hash table weakness", obj);
593   return HASH_TABLE_NON_WEAK; /* not reached */
594 }
595
596 static int
597 hash_table_test_validate (Lisp_Object keyword, Lisp_Object value,
598                          Error_behavior errb)
599 {
600   if (EQ (value, Qnil))   return 1;
601   if (EQ (value, Qeq))    return 1;
602   if (EQ (value, Qequal)) return 1;
603   if (EQ (value, Qeql))   return 1;
604
605   maybe_signal_simple_error ("Invalid hash table test",
606                              value, Qhash_table, errb);
607   return 0;
608 }
609
610 static enum hash_table_test
611 decode_hash_table_test (Lisp_Object obj)
612 {
613   if (EQ (obj, Qnil))   return HASH_TABLE_EQL;
614   if (EQ (obj, Qeq))    return HASH_TABLE_EQ;
615   if (EQ (obj, Qequal)) return HASH_TABLE_EQUAL;
616   if (EQ (obj, Qeql))   return HASH_TABLE_EQL;
617
618   signal_simple_error ("Invalid hash table test", obj);
619   return HASH_TABLE_EQ; /* not reached */
620 }
621
622 static int
623 hash_table_rehash_size_validate (Lisp_Object keyword, Lisp_Object value,
624                                  Error_behavior errb)
625 {
626   if (!FLOATP (value))
627     {
628       maybe_signal_error (Qwrong_type_argument, list2 (Qfloatp, value),
629                           Qhash_table, errb);
630       return 0;
631     }
632
633   {
634     double rehash_size = XFLOAT_DATA (value);
635     if (rehash_size <= 1.0)
636       {
637         maybe_signal_simple_error
638           ("Hash table rehash size must be greater than 1.0",
639            value, Qhash_table, errb);
640         return 0;
641       }
642   }
643
644   return 1;
645 }
646
647 static double
648 decode_hash_table_rehash_size (Lisp_Object rehash_size)
649 {
650   return NILP (rehash_size) ? -1.0 : XFLOAT_DATA (rehash_size);
651 }
652
653 static int
654 hash_table_rehash_threshold_validate (Lisp_Object keyword, Lisp_Object value,
655                                      Error_behavior errb)
656 {
657   if (!FLOATP (value))
658     {
659       maybe_signal_error (Qwrong_type_argument, list2 (Qfloatp, value),
660                           Qhash_table, errb);
661       return 0;
662     }
663
664   {
665     double rehash_threshold = XFLOAT_DATA (value);
666     if (rehash_threshold <= 0.0 || rehash_threshold >= 1.0)
667       {
668         maybe_signal_simple_error
669           ("Hash table rehash threshold must be between 0.0 and 1.0",
670            value, Qhash_table, errb);
671         return 0;
672       }
673   }
674
675   return 1;
676 }
677
678 static double
679 decode_hash_table_rehash_threshold (Lisp_Object rehash_threshold)
680 {
681   return NILP (rehash_threshold) ? -1.0 : XFLOAT_DATA (rehash_threshold);
682 }
683
684 static int
685 hash_table_data_validate (Lisp_Object keyword, Lisp_Object value,
686                          Error_behavior errb)
687 {
688   int len;
689
690   GET_EXTERNAL_LIST_LENGTH (value, len);
691
692   if (len & 1)
693     {
694       maybe_signal_simple_error
695         ("Hash table data must have alternating key/value pairs",
696          value, Qhash_table, errb);
697       return 0;
698     }
699   return 1;
700 }
701
702 /* The actual instantiation of a hash table.  This does practically no
703    error checking, because it relies on the fact that the paranoid
704    functions above have error-checked everything to the last details.
705    If this assumption is wrong, we will get a crash immediately (with
706    error-checking compiled in), and we'll know if there is a bug in
707    the structure mechanism.  So there.  */
708 static Lisp_Object
709 hash_table_instantiate (Lisp_Object plist)
710 {
711   Lisp_Object hash_table;
712   Lisp_Object test             = Qnil;
713   Lisp_Object size             = Qnil;
714   Lisp_Object rehash_size      = Qnil;
715   Lisp_Object rehash_threshold = Qnil;
716   Lisp_Object weakness         = Qnil;
717   Lisp_Object data             = Qnil;
718
719   while (!NILP (plist))
720     {
721       Lisp_Object key, value;
722       key   = XCAR (plist); plist = XCDR (plist);
723       value = XCAR (plist); plist = XCDR (plist);
724
725       if      (EQ (key, Qtest))             test             = value;
726       else if (EQ (key, Qsize))             size             = value;
727       else if (EQ (key, Qrehash_size))      rehash_size      = value;
728       else if (EQ (key, Qrehash_threshold)) rehash_threshold = value;
729       else if (EQ (key, Qweakness))         weakness         = value;
730       else if (EQ (key, Qdata))             data             = value;
731       else if (EQ (key, Qtype))/*obsolete*/ weakness         = value;
732       else
733         ABORT ();
734     }
735
736   /* Create the hash table.  */
737   hash_table = make_standard_lisp_hash_table
738     (decode_hash_table_test (test),
739      decode_hash_table_size (size),
740      decode_hash_table_rehash_size (rehash_size),
741      decode_hash_table_rehash_threshold (rehash_threshold),
742      decode_hash_table_weakness (weakness));
743
744   /* I'm not sure whether this can GC, but better safe than sorry.  */
745   {
746     struct gcpro gcpro1;
747     GCPRO1 (hash_table);
748
749     /* And fill it with data.  */
750     while (!NILP (data))
751       {
752         Lisp_Object key, value;
753         key   = XCAR (data); data = XCDR (data);
754         value = XCAR (data); data = XCDR (data);
755         Fputhash (key, value, hash_table);
756       }
757     UNGCPRO;
758   }
759
760   return hash_table;
761 }
762
763 static void
764 structure_type_create_hash_table_structure_name (Lisp_Object structure_name)
765 {
766   struct structure_type *st;
767
768   st = define_structure_type (structure_name, 0, hash_table_instantiate);
769   define_structure_type_keyword (st, Qtest, hash_table_test_validate);
770   define_structure_type_keyword (st, Qsize, hash_table_size_validate);
771   define_structure_type_keyword (st, Qrehash_size, hash_table_rehash_size_validate);
772   define_structure_type_keyword (st, Qrehash_threshold, hash_table_rehash_threshold_validate);
773   define_structure_type_keyword (st, Qweakness, hash_table_weakness_validate);
774   define_structure_type_keyword (st, Qdata, hash_table_data_validate);
775
776   /* obsolete as of 19990901 in xemacs-21.2 */
777   define_structure_type_keyword (st, Qtype, hash_table_weakness_validate);
778 }
779
780 /* Create a built-in Lisp structure type named `hash-table'.
781    We make #s(hashtable ...) equivalent to #s(hash-table ...),
782    for backward compatibility.
783    This is called from emacs.c.  */
784 void
785 structure_type_create_hash_table (void)
786 {
787   structure_type_create_hash_table_structure_name (Qhash_table);
788   structure_type_create_hash_table_structure_name (Qhashtable); /* compat */
789 }
790
791 \f
792 /************************************************************************/
793 /*              Definition of Lisp-visible methods                      */
794 /************************************************************************/
795
796 DEFUN ("hash-table-p", Fhash_table_p, 1, 1, 0, /*
797 Return t if OBJECT is a hash table, else nil.
798 */
799        (object))
800 {
801   return HASH_TABLEP (object) ? Qt : Qnil;
802 }
803
804 DEFUN ("make-hash-table", Fmake_hash_table, 0, MANY, 0, /*
805 Return a new empty hash table object.
806 Use Common Lisp style keywords to specify hash table properties.
807  (make-hash-table &key test size rehash-size rehash-threshold weakness)
808
809 Keyword :test can be `eq', `eql' (default) or `equal'.
810 Comparison between keys is done using this function.
811 If speed is important, consider using `eq'.
812 When hash table keys may be strings, you will likely need to use `equal'.
813
814 Keyword :size specifies the number of keys likely to be inserted.
815 This number of entries can be inserted without enlarging the hash table.
816
817 Keyword :rehash-size must be a float greater than 1.0, and specifies
818 the factor by which to increase the size of the hash table when enlarging.
819
820 Keyword :rehash-threshold must be a float between 0.0 and 1.0,
821 and specifies the load factor of the hash table which triggers enlarging.
822
823 Non-standard keyword :weakness can be `nil' (default), `t', `key-and-value',
824 `key', `value' or `key-or-value'. `t' is an alias for `key-and-value'.
825
826 A key-and-value-weak hash table, also known as a fully-weak or simply
827 as a weak hash table, is one whose pointers do not count as GC
828 referents: for any key-value pair in the hash table, if the only
829 remaining pointer to either the key or the value is in a weak hash
830 table, then the pair will be removed from the hash table, and the key
831 and value collected.  A non-weak hash table (or any other pointer)
832 would prevent the object from being collected.
833
834 A key-weak hash table is similar to a fully-weak hash table except that
835 a key-value pair will be removed only if the key remains unmarked
836 outside of weak hash tables.  The pair will remain in the hash table if
837 the key is pointed to by something other than a weak hash table, even
838 if the value is not.
839
840 A value-weak hash table is similar to a fully-weak hash table except
841 that a key-value pair will be removed only if the value remains
842 unmarked outside of weak hash tables.  The pair will remain in the
843 hash table if the value is pointed to by something other than a weak
844 hash table, even if the key is not.
845
846 A key-or-value-weak hash table is similar to a fully-weak hash table except
847 that a key-value pair will be removed only if the value and the key remain
848 unmarked outside of weak hash tables.  The pair will remain in the
849 hash table if the value or key are pointed to by something other than a weak
850 hash table, even if the other is not.
851 */
852        (int nargs, Lisp_Object *args))
853 {
854   int i = 0;
855   Lisp_Object test             = Qnil;
856   Lisp_Object size             = Qnil;
857   Lisp_Object rehash_size      = Qnil;
858   Lisp_Object rehash_threshold = Qnil;
859   Lisp_Object weakness         = Qnil;
860
861   while (i + 1 < nargs)
862     {
863       Lisp_Object keyword = args[i++];
864       Lisp_Object value   = args[i++];
865
866       if      (EQ (keyword, Q_test))             test             = value;
867       else if (EQ (keyword, Q_size))             size             = value;
868       else if (EQ (keyword, Q_rehash_size))      rehash_size      = value;
869       else if (EQ (keyword, Q_rehash_threshold)) rehash_threshold = value;
870       else if (EQ (keyword, Q_weakness))         weakness         = value;
871       else if (EQ (keyword, Q_type))/*obsolete*/ weakness         = value;
872       else signal_simple_error ("Invalid hash table property keyword", keyword);
873     }
874
875   if (i < nargs)
876     signal_simple_error ("Hash table property requires a value", args[i]);
877
878 #define VALIDATE_VAR(var) \
879 if (!NILP (var)) hash_table_##var##_validate (Q##var, var, ERROR_ME);
880
881   VALIDATE_VAR (test);
882   VALIDATE_VAR (size);
883   VALIDATE_VAR (rehash_size);
884   VALIDATE_VAR (rehash_threshold);
885   VALIDATE_VAR (weakness);
886
887   return make_standard_lisp_hash_table
888     (decode_hash_table_test (test),
889      decode_hash_table_size (size),
890      decode_hash_table_rehash_size (rehash_size),
891      decode_hash_table_rehash_threshold (rehash_threshold),
892      decode_hash_table_weakness (weakness));
893 }
894
895 DEFUN ("copy-hash-table", Fcopy_hash_table, 1, 1, 0, /*
896 Return a new hash table containing the same keys and values as HASH-TABLE.
897 The keys and values will not themselves be copied.
898 */
899        (hash_table))
900 {
901   const Lisp_Hash_Table *ht_old = xhash_table (hash_table);
902   Lisp_Hash_Table *ht = alloc_lcrecord_type (Lisp_Hash_Table, &lrecord_hash_table);
903
904   copy_lcrecord (ht, ht_old);
905
906   ht->hentries = xnew_array (hentry, ht_old->size + 1);
907   memcpy (ht->hentries, ht_old->hentries, (ht_old->size + 1) * sizeof (hentry));
908
909   XSETHASH_TABLE (hash_table, ht);
910
911   if (! EQ (ht->next_weak, Qunbound))
912     {
913       ht->next_weak = Vall_weak_hash_tables;
914       Vall_weak_hash_tables = hash_table;
915     }
916
917   return hash_table;
918 }
919
920 static void
921 resize_hash_table (Lisp_Hash_Table *ht, size_t new_size)
922 {
923   hentry *old_entries, *new_entries, *sentinel, *e;
924   size_t old_size;
925
926   old_size = ht->size;
927   ht->size = new_size;
928
929   old_entries = ht->hentries;
930
931   ht->hentries = xnew_array_and_zero (hentry, new_size + 1);
932   new_entries = ht->hentries;
933
934   compute_hash_table_derived_values (ht);
935
936   for (e = old_entries, sentinel = e + old_size; e < sentinel; e++)
937     if (!HENTRY_CLEAR_P (e))
938       {
939         hentry *probe = new_entries + HASH_CODE (e->key, ht);
940         LINEAR_PROBING_LOOP (probe, new_entries, new_size)
941           ;
942         *probe = *e;
943       }
944
945   if (!DUMPEDP (old_entries))
946     xfree (old_entries);
947 }
948
949 /* After a hash table has been saved to disk and later restored by the
950    portable dumper, it contains the same objects, but their addresses
951    and thus their HASH_CODEs have changed. */
952 void
953 pdump_reorganize_hash_table (Lisp_Object hash_table)
954 {
955   const Lisp_Hash_Table *ht = xhash_table (hash_table);
956   hentry *new_entries = xnew_array_and_zero (hentry, ht->size + 1);
957   hentry *e, *sentinel;
958
959   for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
960     if (!HENTRY_CLEAR_P (e))
961       {
962         hentry *probe = new_entries + HASH_CODE (e->key, ht);
963         LINEAR_PROBING_LOOP (probe, new_entries, ht->size)
964           ;
965         *probe = *e;
966       }
967
968   memcpy (ht->hentries, new_entries, ht->size * sizeof (hentry));
969
970   xfree (new_entries);
971 }
972
973 static void
974 enlarge_hash_table (Lisp_Hash_Table *ht)
975 {
976   size_t new_size =
977     hash_table_size ((size_t) ((double) ht->size * ht->rehash_size));
978   resize_hash_table (ht, new_size);
979 }
980
981 static hentry *
982 find_hentry (Lisp_Object key, const Lisp_Hash_Table *ht)
983 {
984   hash_table_test_function_t test_function = ht->test_function;
985   hentry *entries = ht->hentries;
986   hentry *probe = entries + HASH_CODE (key, ht);
987
988   LINEAR_PROBING_LOOP (probe, entries, ht->size)
989     if (KEYS_EQUAL_P (probe->key, key, test_function))
990       break;
991
992   return probe;
993 }
994
995 DEFUN ("gethash", Fgethash, 2, 3, 0, /*
996 Find hash value for KEY in HASH-TABLE.
997 If there is no corresponding value, return DEFAULT (which defaults to nil).
998 */
999        (key, hash_table, default_))
1000 {
1001   const Lisp_Hash_Table *ht = xhash_table (hash_table);
1002   hentry *e = find_hentry (key, ht);
1003
1004   return HENTRY_CLEAR_P (e) ? default_ : e->value;
1005 }
1006
1007 DEFUN ("puthash", Fputhash, 3, 3, 0, /*
1008 Hash KEY to VALUE in HASH-TABLE.
1009 */
1010        (key, value, hash_table))
1011 {
1012   Lisp_Hash_Table *ht = xhash_table (hash_table);
1013   hentry *e = find_hentry (key, ht);
1014
1015   if (!HENTRY_CLEAR_P (e))
1016     return e->value = value;
1017
1018   e->key   = key;
1019   e->value = value;
1020
1021   if (++ht->count >= ht->rehash_count)
1022     enlarge_hash_table (ht);
1023
1024   return value;
1025 }
1026
1027 /* Remove hentry pointed at by PROBE.
1028    Subsequent entries are removed and reinserted.
1029    We don't use tombstones - too wasteful.  */
1030 static void
1031 remhash_1 (Lisp_Hash_Table *ht, hentry *entries, hentry *probe)
1032 {
1033   size_t size = ht->size;
1034   CLEAR_HENTRY (probe);
1035   probe++;
1036   ht->count--;
1037
1038   LINEAR_PROBING_LOOP (probe, entries, size)
1039     {
1040       Lisp_Object key = probe->key;
1041       hentry *probe2 = entries + HASH_CODE (key, ht);
1042       LINEAR_PROBING_LOOP (probe2, entries, size)
1043         if (EQ (probe2->key, key))
1044           /* hentry at probe doesn't need to move. */
1045           goto continue_outer_loop;
1046       /* Move hentry from probe to new home at probe2. */
1047       *probe2 = *probe;
1048       CLEAR_HENTRY (probe);
1049     continue_outer_loop: continue;
1050     }
1051 }
1052
1053 DEFUN ("remhash", Fremhash, 2, 2, 0, /*
1054 Remove the entry for KEY from HASH-TABLE.
1055 Do nothing if there is no entry for KEY in HASH-TABLE.
1056 */
1057        (key, hash_table))
1058 {
1059   Lisp_Hash_Table *ht = xhash_table (hash_table);
1060   hentry *e = find_hentry (key, ht);
1061
1062   if (HENTRY_CLEAR_P (e))
1063     return Qnil;
1064
1065   remhash_1 (ht, ht->hentries, e);
1066   return Qt;
1067 }
1068
1069 DEFUN ("clrhash", Fclrhash, 1, 1, 0, /*
1070 Remove all entries from HASH-TABLE, leaving it empty.
1071 */
1072        (hash_table))
1073 {
1074   Lisp_Hash_Table *ht = xhash_table (hash_table);
1075   hentry *e, *sentinel;
1076
1077   for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1078     CLEAR_HENTRY (e);
1079   ht->count = 0;
1080
1081   return hash_table;
1082 }
1083
1084 /************************************************************************/
1085 /*                          Accessor Functions                          */
1086 /************************************************************************/
1087
1088 DEFUN ("hash-table-count", Fhash_table_count, 1, 1, 0, /*
1089 Return the number of entries in HASH-TABLE.
1090 */
1091        (hash_table))
1092 {
1093   return make_int (xhash_table (hash_table)->count);
1094 }
1095
1096 DEFUN ("hash-table-test", Fhash_table_test, 1, 1, 0, /*
1097 Return the test function of HASH-TABLE.
1098 This can be one of `eq', `eql' or `equal'.
1099 */
1100        (hash_table))
1101 {
1102   hash_table_test_function_t fun = xhash_table (hash_table)->test_function;
1103
1104   return (fun == lisp_object_eql_equal   ? Qeql   :
1105           fun == lisp_object_equal_equal ? Qequal :
1106           Qeq);
1107 }
1108
1109 DEFUN ("hash-table-size", Fhash_table_size, 1, 1, 0, /*
1110 Return the size of HASH-TABLE.
1111 This is the current number of slots in HASH-TABLE, whether occupied or not.
1112 */
1113        (hash_table))
1114 {
1115   return make_int (xhash_table (hash_table)->size);
1116 }
1117
1118 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size, 1, 1, 0, /*
1119 Return the current rehash size of HASH-TABLE.
1120 This is a float greater than 1.0; the factor by which HASH-TABLE
1121 is enlarged when the rehash threshold is exceeded.
1122 */
1123        (hash_table))
1124 {
1125   return make_float (xhash_table (hash_table)->rehash_size);
1126 }
1127
1128 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold, 1, 1, 0, /*
1129 Return the current rehash threshold of HASH-TABLE.
1130 This is a float between 0.0 and 1.0; the maximum `load factor' of HASH-TABLE,
1131 beyond which the HASH-TABLE is enlarged by rehashing.
1132 */
1133        (hash_table))
1134 {
1135   return make_float (xhash_table (hash_table)->rehash_threshold);
1136 }
1137
1138 DEFUN ("hash-table-weakness", Fhash_table_weakness, 1, 1, 0, /*
1139 Return the weakness of HASH-TABLE.
1140 This can be one of `nil', `key-and-value', `key-or-value', `key' or `value'.
1141 */
1142        (hash_table))
1143 {
1144   switch (xhash_table (hash_table)->weakness)
1145     {
1146     case HASH_TABLE_WEAK:               return Qkey_and_value;
1147     case HASH_TABLE_KEY_WEAK:           return Qkey;
1148     case HASH_TABLE_KEY_VALUE_WEAK:     return Qkey_or_value;
1149     case HASH_TABLE_VALUE_WEAK:         return Qvalue;
1150     default:                            return Qnil;
1151     }
1152 }
1153
1154 /* obsolete as of 19990901 in xemacs-21.2 */
1155 DEFUN ("hash-table-type", Fhash_table_type, 1, 1, 0, /*
1156 Return the type of HASH-TABLE.
1157 This can be one of `non-weak', `weak', `key-weak' or `value-weak'.
1158 */
1159        (hash_table))
1160 {
1161   switch (xhash_table (hash_table)->weakness)
1162     {
1163     case HASH_TABLE_WEAK:               return Qweak;
1164     case HASH_TABLE_KEY_WEAK:           return Qkey_weak;
1165     case HASH_TABLE_KEY_VALUE_WEAK:     return Qkey_or_value_weak;
1166     case HASH_TABLE_VALUE_WEAK:         return Qvalue_weak;
1167     default:                            return Qnon_weak;
1168     }
1169 }
1170
1171 /************************************************************************/
1172 /*                          Mapping Functions                           */
1173 /************************************************************************/
1174 DEFUN ("maphash", Fmaphash, 2, 2, 0, /*
1175 Map FUNCTION over entries in HASH-TABLE, calling it with two args,
1176 each key and value in HASH-TABLE.
1177
1178 FUNCTION may not modify HASH-TABLE, with the one exception that FUNCTION
1179 may remhash or puthash the entry currently being processed by FUNCTION.
1180 */
1181        (function, hash_table))
1182 {
1183   const Lisp_Hash_Table *ht = xhash_table (hash_table);
1184   const hentry *e, *sentinel;
1185
1186   for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1187     if (!HENTRY_CLEAR_P (e))
1188       {
1189         Lisp_Object args[3], key;
1190       again:
1191         key = e->key;
1192         args[0] = function;
1193         args[1] = key;
1194         args[2] = e->value;
1195         Ffuncall (countof (args), args);
1196         /* Has FUNCTION done a remhash? */
1197         if (!EQ (key, e->key) && !HENTRY_CLEAR_P (e))
1198           goto again;
1199       }
1200
1201   return Qnil;
1202 }
1203
1204 /* #### If the Lisp function being called does a puthash and this
1205    #### causes the hash table to be resized, the results will be quite
1206    #### random and we will likely crash.  To fix this, either set a
1207    #### flag in the hash table while we're mapping and signal an error
1208    #### when new entries are added, or fix things to make this
1209    #### operation work properly, like this: Store two hash tables in
1210    #### each hash table object -- the second one is written to when
1211    #### you do a puthash inside of a mapping operation, and the
1212    #### various operations need to check both hash tables for entries.
1213    #### As soon as the last maphash over a particular hash table
1214    #### object terminates, the entries in the second table are added
1215    #### to the first (using an unwind-protect). --ben */
1216
1217 /* Map *C* function FUNCTION over the elements of a lisp hash table. */
1218 void
1219 elisp_maphash (maphash_function_t function,
1220                Lisp_Object hash_table, void *extra_arg)
1221 {
1222   const Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1223   const hentry *e, *sentinel;
1224
1225   for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1226     if (!HENTRY_CLEAR_P (e))
1227       {
1228         Lisp_Object key;
1229       again:
1230         key = e->key;
1231         if (function (key, e->value, extra_arg))
1232           return;
1233         /* Has FUNCTION done a remhash? */
1234         if (!EQ (key, e->key) && !HENTRY_CLEAR_P (e))
1235           goto again;
1236       }
1237 }
1238
1239 /* Remove all elements of a lisp hash table satisfying *C* predicate PREDICATE. */
1240 void
1241 elisp_map_remhash (maphash_function_t predicate,
1242                    Lisp_Object hash_table, void *extra_arg)
1243 {
1244   Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1245   hentry *e, *entries, *sentinel;
1246
1247   for (e = entries = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1248     if (!HENTRY_CLEAR_P (e))
1249       {
1250       again:
1251         if (predicate (e->key, e->value, extra_arg))
1252           {
1253             remhash_1 (ht, entries, e);
1254             if (!HENTRY_CLEAR_P (e))
1255               goto again;
1256           }
1257       }
1258 }
1259
1260 \f
1261 /************************************************************************/
1262 /*                 garbage collecting weak hash tables                  */
1263 /************************************************************************/
1264 #define MARK_OBJ(obj) do {              \
1265   Lisp_Object mo_obj = (obj);           \
1266   if (!marked_p (mo_obj))               \
1267     {                                   \
1268       mark_object (mo_obj);             \
1269       did_mark = 1;                     \
1270     }                                   \
1271 } while (0)
1272
1273
1274 /* Complete the marking for semi-weak hash tables. */
1275 int
1276 finish_marking_weak_hash_tables (void)
1277 {
1278   Lisp_Object hash_table;
1279   int did_mark = 0;
1280
1281   for (hash_table = Vall_weak_hash_tables;
1282        !NILP (hash_table);
1283        hash_table = XHASH_TABLE (hash_table)->next_weak)
1284     {
1285       const Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1286       const hentry *e = ht->hentries;
1287       const hentry *sentinel = e + ht->size;
1288
1289       if (! marked_p (hash_table))
1290         /* The hash table is probably garbage.  Ignore it. */
1291         continue;
1292
1293       /* Now, scan over all the pairs.  For all pairs that are
1294          half-marked, we may need to mark the other half if we're
1295          keeping this pair. */
1296       switch (ht->weakness)
1297         {
1298         case HASH_TABLE_KEY_WEAK:
1299           for (; e < sentinel; e++)
1300             if (!HENTRY_CLEAR_P (e))
1301               if (marked_p (e->key))
1302                 MARK_OBJ (e->value);
1303           break;
1304
1305         case HASH_TABLE_VALUE_WEAK:
1306           for (; e < sentinel; e++)
1307             if (!HENTRY_CLEAR_P (e))
1308               if (marked_p (e->value))
1309                 MARK_OBJ (e->key);
1310           break;
1311
1312         case HASH_TABLE_KEY_VALUE_WEAK:
1313           for (; e < sentinel; e++)
1314             if (!HENTRY_CLEAR_P (e))
1315               {
1316                 if (marked_p (e->value))
1317                   MARK_OBJ (e->key);
1318                 else if (marked_p (e->key))
1319                   MARK_OBJ (e->value);
1320               }
1321           break;
1322
1323         case HASH_TABLE_KEY_CAR_WEAK:
1324           for (; e < sentinel; e++)
1325             if (!HENTRY_CLEAR_P (e))
1326               if (!CONSP (e->key) || marked_p (XCAR (e->key)))
1327                 {
1328                   MARK_OBJ (e->key);
1329                   MARK_OBJ (e->value);
1330                 }
1331           break;
1332
1333           /* We seem to be sprouting new weakness types at an alarming
1334              rate. At least this is not externally visible - and in
1335              fact all of these KEY_CAR_* types are only used by the
1336              glyph code. */
1337         case HASH_TABLE_KEY_CAR_VALUE_WEAK:
1338           for (; e < sentinel; e++)
1339             if (!HENTRY_CLEAR_P (e))
1340               {
1341                 if (!CONSP (e->key) || marked_p (XCAR (e->key)))
1342                   {
1343                     MARK_OBJ (e->key);
1344                     MARK_OBJ (e->value);
1345                   }
1346                 else if (marked_p (e->value))
1347                   MARK_OBJ (e->key);
1348               }
1349           break;
1350
1351         case HASH_TABLE_VALUE_CAR_WEAK:
1352           for (; e < sentinel; e++)
1353             if (!HENTRY_CLEAR_P (e))
1354               if (!CONSP (e->value) || marked_p (XCAR (e->value)))
1355                 {
1356                   MARK_OBJ (e->key);
1357                   MARK_OBJ (e->value);
1358                 }
1359           break;
1360
1361         default:
1362           break;
1363         }
1364     }
1365
1366   return did_mark;
1367 }
1368
1369 void
1370 prune_weak_hash_tables (void)
1371 {
1372   Lisp_Object hash_table, prev = Qnil;
1373   for (hash_table = Vall_weak_hash_tables;
1374        !NILP (hash_table);
1375        hash_table = XHASH_TABLE (hash_table)->next_weak)
1376     {
1377       if (! marked_p (hash_table))
1378         {
1379           /* This hash table itself is garbage.  Remove it from the list. */
1380           if (NILP (prev))
1381             Vall_weak_hash_tables = XHASH_TABLE (hash_table)->next_weak;
1382           else
1383             XHASH_TABLE (prev)->next_weak = XHASH_TABLE (hash_table)->next_weak;
1384         }
1385       else
1386         {
1387           /* Now, scan over all the pairs.  Remove all of the pairs
1388              in which the key or value, or both, is unmarked
1389              (depending on the weakness of the hash table). */
1390           Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
1391           hentry *entries = ht->hentries;
1392           hentry *sentinel = entries + ht->size;
1393           hentry *e;
1394
1395           for (e = entries; e < sentinel; e++)
1396             if (!HENTRY_CLEAR_P (e))
1397               {
1398               again:
1399                 if (!marked_p (e->key) || !marked_p (e->value))
1400                   {
1401                     remhash_1 (ht, entries, e);
1402                     if (!HENTRY_CLEAR_P (e))
1403                       goto again;
1404                   }
1405               }
1406
1407           prev = hash_table;
1408         }
1409     }
1410 }
1411
1412 /* Return a hash value for an array of Lisp_Objects of size SIZE. */
1413
1414 hashcode_t
1415 internal_array_hash (Lisp_Object *arr, int size, int depth)
1416 {
1417   int i;
1418   hashcode_t hash = 0;
1419   depth++;
1420
1421   if (size <= 5)
1422     {
1423       for (i = 0; i < size; i++)
1424         hash = HASH2 (hash, internal_hash (arr[i], depth));
1425       return hash;
1426     }
1427
1428   /* just pick five elements scattered throughout the array.
1429      A slightly better approach would be to offset by some
1430      noise factor from the points chosen below. */
1431   for (i = 0; i < 5; i++)
1432     hash = HASH2 (hash, internal_hash (arr[i*size/5], depth));
1433
1434   return hash;
1435 }
1436
1437 /* Return a hash value for a Lisp_Object.  This is for use when hashing
1438    objects with the comparison being `equal' (for `eq', you can just
1439    use the Lisp_Object itself as the hash value).  You need to make a
1440    tradeoff between the speed of the hash function and how good the
1441    hashing is.  In particular, the hash function needs to be FAST,
1442    so you can't just traipse down the whole tree hashing everything
1443    together.  Most of the time, objects will differ in the first
1444    few elements you hash.  Thus, we only go to a short depth (5)
1445    and only hash at most 5 elements out of a vector.  Theoretically
1446    we could still take 5^5 time (a big big number) to compute a
1447    hash, but practically this won't ever happen. */
1448
1449 hashcode_t
1450 internal_hash (Lisp_Object obj, int depth)
1451 {
1452   if (depth > 5)
1453     return 0;
1454   if (CONSP (obj))
1455     {
1456       /* no point in worrying about tail recursion, since we're not
1457          going very deep */
1458       return HASH2 (internal_hash (XCAR (obj), depth + 1),
1459                     internal_hash (XCDR (obj), depth + 1));
1460     }
1461   if (STRINGP (obj))
1462     {
1463       return hash_string (XSTRING_DATA (obj), XSTRING_LENGTH (obj));
1464     }
1465   if (LRECORDP (obj))
1466     {
1467       const struct lrecord_implementation
1468         *imp = XRECORD_LHEADER_IMPLEMENTATION (obj);
1469       if (imp->hash)
1470         return imp->hash (obj, depth);
1471     }
1472
1473   return LISP_HASH (obj);
1474 }
1475
1476 DEFUN ("sxhash", Fsxhash, 1, 1, 0, /*
1477 Return a hash value for OBJECT.
1478 \(equal obj1 obj2) implies (= (sxhash obj1) (sxhash obj2)).
1479 */
1480        (object))
1481 {
1482   return make_int (internal_hash (object, 0));
1483 }
1484
1485 #if 0
1486 xxDEFUN ("internal-hash-value", Finternal_hash_value, 1, 1, 0, /*
1487 Hash value of OBJECT.  For debugging.
1488 The value is returned as (HIGH . LOW).
1489 */
1490        (object))
1491 {
1492   /* This function is pretty 32bit-centric. */
1493   hashcode_t hash = internal_hash (object, 0);
1494   return Fcons (hash >> 16, hash & 0xffff);
1495 }
1496 #endif
1497
1498 \f
1499 /************************************************************************/
1500 /*                            initialization                            */
1501 /************************************************************************/
1502
1503 void
1504 syms_of_elhash (void)
1505 {
1506   INIT_LRECORD_IMPLEMENTATION (hash_table);
1507
1508   DEFSUBR (Fhash_table_p);
1509   DEFSUBR (Fmake_hash_table);
1510   DEFSUBR (Fcopy_hash_table);
1511   DEFSUBR (Fgethash);
1512   DEFSUBR (Fremhash);
1513   DEFSUBR (Fputhash);
1514   DEFSUBR (Fclrhash);
1515   DEFSUBR (Fmaphash);
1516   DEFSUBR (Fhash_table_count);
1517   DEFSUBR (Fhash_table_test);
1518   DEFSUBR (Fhash_table_size);
1519   DEFSUBR (Fhash_table_rehash_size);
1520   DEFSUBR (Fhash_table_rehash_threshold);
1521   DEFSUBR (Fhash_table_weakness);
1522   DEFSUBR (Fhash_table_type); /* obsolete */
1523   DEFSUBR (Fsxhash);
1524 #if 0
1525   DEFSUBR (Finternal_hash_value);
1526 #endif
1527
1528   defsymbol (&Qhash_tablep, "hash-table-p");
1529   defsymbol (&Qhash_table, "hash-table");
1530   defsymbol (&Qhashtable, "hashtable");
1531   defsymbol (&Qweakness, "weakness");
1532   defsymbol (&Qvalue, "value");
1533   defsymbol (&Qkey_or_value, "key-or-value");
1534   defsymbol (&Qkey_and_value, "key-and-value");
1535   defsymbol (&Qrehash_size, "rehash-size");
1536   defsymbol (&Qrehash_threshold, "rehash-threshold");
1537
1538   defsymbol (&Qweak, "weak");             /* obsolete */
1539   defsymbol (&Qkey_weak, "key-weak");     /* obsolete */
1540   defsymbol (&Qkey_or_value_weak, "key-or-value-weak");    /* obsolete */
1541   defsymbol (&Qvalue_weak, "value-weak"); /* obsolete */
1542   defsymbol (&Qnon_weak, "non-weak");     /* obsolete */
1543
1544   defkeyword (&Q_test, ":test");
1545   defkeyword (&Q_size, ":size");
1546   defkeyword (&Q_rehash_size, ":rehash-size");
1547   defkeyword (&Q_rehash_threshold, ":rehash-threshold");
1548   defkeyword (&Q_weakness, ":weakness");
1549   defkeyword (&Q_type, ":type"); /* obsolete */
1550 }
1551
1552 void
1553 vars_of_elhash (void)
1554 {
1555   /* This must NOT be staticpro'd */
1556   Vall_weak_hash_tables = Qnil;
1557   dump_add_weak_object_chain (&Vall_weak_hash_tables);
1558 }