Mercurial > hg > xemacs-beta

comparison src/elhash.c @ 380:8626e4521993 r21-2-5

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