Mercurial > hg > xemacs-beta

comparison src/elhash.c @ 5191:71ee43b8a74d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API tests/ChangeLog addition: 2010-04-05 Aidan Kehoe <kehoea@parhasard.net> * automated/hash-table-tests.el: Test the new built-in #'equalp hash table test. Test #'define-hash-table-test. * automated/lisp-tests.el: When asserting that two objects are #'equalp, also assert that their #'equalp-hash is identical. man/ChangeLog addition: 2010-04-03 Aidan Kehoe <kehoea@parhasard.net> * lispref/hash-tables.texi (Introduction to Hash Tables): Document that we now support #'equalp as a hash table test by default, and mention #'define-hash-table-test. (Working With Hash Tables): Document #'define-hash-table-test. src/ChangeLog addition: 2010-04-05 Aidan Kehoe <kehoea@parhasard.net> * elhash.h: * elhash.c (struct Hash_Table_Test, lisp_object_eql_equal) (lisp_object_eql_hash, lisp_object_equal_equal) (lisp_object_equal_hash, lisp_object_equalp_hash) (lisp_object_equalp_equal, lisp_object_general_hash) (lisp_object_general_equal, Feq_hash, Feql_hash, Fequal_hash) (Fequalp_hash, define_hash_table_test, Fdefine_hash_table_test) (init_elhash_once_early, mark_hash_table_tests, string_equalp_hash): * glyphs.c (vars_of_glyphs): Add a new hash table test in C, #'equalp. Make it possible to specify new hash table tests with functions define_hash_table_test, #'define-hash-table-test. Use define_hash_table_test() in glyphs.c. Expose the hash functions (besides that used for #'equal) to Lisp, for people writing functions to be used with #'define-hash-table-test. Call define_hash_table_test() very early in temacs, to create the built-in hash table tests. * ui-gtk.c (emacs_gtk_boxed_hash): * specifier.h (struct specifier_methods): * specifier.c (specifier_hash): * rangetab.c (range_table_entry_hash, range_table_hash): * number.c (bignum_hash, ratio_hash, bigfloat_hash): * marker.c (marker_hash): * lrecord.h (struct lrecord_implementation): * keymap.c (keymap_hash): * gui.c (gui_item_id_hash, gui_item_hash): * glyphs.c (image_instance_hash, glyph_hash): * glyphs-x.c (x_image_instance_hash): * glyphs-msw.c (mswindows_image_instance_hash): * glyphs-gtk.c (gtk_image_instance_hash): * frame-msw.c (mswindows_set_title_from_ibyte): * fontcolor.c (color_instance_hash, font_instance_hash): * fontcolor-x.c (x_color_instance_hash): * fontcolor-tty.c (tty_color_instance_hash): * fontcolor-msw.c (mswindows_color_instance_hash): * fontcolor-gtk.c (gtk_color_instance_hash): * fns.c (bit_vector_hash): * floatfns.c (float_hash): * faces.c (face_hash): * extents.c (extent_hash): * events.c (event_hash): * data.c (weak_list_hash, weak_box_hash): * chartab.c (char_table_entry_hash, char_table_hash): * bytecode.c (compiled_function_hash): * alloc.c (vector_hash): Change the various object hash methods to take a new EQUALP parameter, hashing appropriately for #'equalp if it is true.
author Aidan Kehoe <kehoea@parhasard.net>
date Mon, 05 Apr 2010 13:03:35 +0100
parents 6c6d78781d59
children 41ac827cb71b
comparison
equal deleted inserted replaced
5190:1c1d8843de5e 5191:71ee43b8a74d
81 #include "lisp.h" 81 #include "lisp.h"
82 #include "bytecode.h" 82 #include "bytecode.h"
83 #include "elhash.h" 83 #include "elhash.h"
84 #include "gc.h" 84 #include "gc.h"
85 #include "opaque.h" 85 #include "opaque.h"
86 #include "buffer.h"
86 87
87 Lisp_Object Qhash_tablep; 88 Lisp_Object Qhash_tablep;
89 Lisp_Object Qeq, Qeql, Qequal, Qequalp;
90 Lisp_Object Qeq_hash, Qeql_hash, Qequal_hash, Qequalp_hash;
91
88 static Lisp_Object Qhashtable, Qhash_table, Qmake_hash_table; 92 static Lisp_Object Qhashtable, Qhash_table, Qmake_hash_table;
89 static Lisp_Object Qweakness, Qvalue, Qkey_or_value, Qkey_and_value; 93 static Lisp_Object Qweakness, Qvalue, Qkey_or_value, Qkey_and_value;
90 static Lisp_Object Vall_weak_hash_tables; 94 static Lisp_Object Vall_weak_hash_tables;
91 static Lisp_Object Qrehash_size, Qrehash_threshold; 95 static Lisp_Object Qrehash_size, Qrehash_threshold;
92 static Lisp_Object Q_size, Q_test, Q_weakness, Q_rehash_size, Q_rehash_threshold; 96 static Lisp_Object Q_size, Q_test, Q_weakness, Q_rehash_size, Q_rehash_threshold;
97 static Lisp_Object Vhash_table_test_eq, Vhash_table_test_eql;
98 static Lisp_Object Vhash_table_test_weak_list;
93 99
94 /* obsolete as of 19990901 in xemacs-21.2 */ 100 /* obsolete as of 19990901 in xemacs-21.2 */
95 static Lisp_Object Qweak, Qkey_weak, Qvalue_weak, Qkey_or_value_weak; 101 static Lisp_Object Qweak, Qkey_weak, Qvalue_weak, Qkey_or_value_weak;
96 static Lisp_Object Qnon_weak, Q_type, Q_data; 102 static Lisp_Object Qnon_weak, Q_type, Q_data;
103
104 /* A hash table test, with its associated hash function. equal_function may
105 call lisp_equal_function, and hash_function similarly may call
106 lisp_hash_function. */
107 struct Hash_Table_Test
108 {
109 NORMAL_LISP_OBJECT_HEADER header;
110 Lisp_Object name;
111 hash_table_equal_function_t equal_function;
112 hash_table_hash_function_t hash_function;
113 Lisp_Object lisp_equal_function;
114 Lisp_Object lisp_hash_function;
115 };
116
117 static Lisp_Object
118 mark_hash_table_test (Lisp_Object obj)
119 {
120 Hash_Table_Test *http = XHASH_TABLE_TEST (obj);
121
122 mark_object (http->name);
123 mark_object (http->lisp_equal_function);
124 mark_object (http->lisp_hash_function);
125
126 return Qnil;
127 }
128
129 static const struct memory_description hash_table_test_description_1[] =
130 {
131 { XD_LISP_OBJECT, offsetof (struct Hash_Table_Test, name) },
132 { XD_LISP_OBJECT, offsetof (struct Hash_Table_Test, lisp_equal_function) },
133 { XD_LISP_OBJECT, offsetof (struct Hash_Table_Test, lisp_hash_function) },
134 { XD_END }
135 };
136
137 static const struct sized_memory_description hash_table_test_description =
138 {
139 sizeof (struct Hash_Table_Test),
140 hash_table_test_description_1
141 };
142
143 DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("hash-table-test", hash_table_test,
144 mark_hash_table_test,
145 hash_table_test_description_1,
146 Hash_Table_Test);
147 /* A hash table. */
97 148
98 struct Lisp_Hash_Table 149 struct Lisp_Hash_Table
99 { 150 {
100 NORMAL_LISP_OBJECT_HEADER header; 151 NORMAL_LISP_OBJECT_HEADER header;
101 Elemcount size; 152 Elemcount size;
102 Elemcount count; 153 Elemcount count;
103 Elemcount rehash_count; 154 Elemcount rehash_count;
104 double rehash_size; 155 double rehash_size;
105 double rehash_threshold; 156 double rehash_threshold;
106 Elemcount golden_ratio; 157 Elemcount golden_ratio;
107 hash_table_hash_function_t hash_function;
108 hash_table_test_function_t test_function;
109 htentry *hentries; 158 htentry *hentries;
159 Lisp_Object test;
110 enum hash_table_weakness weakness; 160 enum hash_table_weakness weakness;
111 Lisp_Object next_weak; /* Used to chain together all of the weak 161 Lisp_Object next_weak; /* Used to chain together all of the weak
112 hash tables. Don't mark through this. */ 162 hash tables. Don't mark through this. */
113 }; 163 };
114 164
117 (*(EMACS_UINT*)(&((htentry)->value))) = 0) 167 (*(EMACS_UINT*)(&((htentry)->value))) = 0)
118 168
119 #define HASH_TABLE_DEFAULT_SIZE 16 169 #define HASH_TABLE_DEFAULT_SIZE 16
120 #define HASH_TABLE_DEFAULT_REHASH_SIZE 1.3 170 #define HASH_TABLE_DEFAULT_REHASH_SIZE 1.3
121 #define HASH_TABLE_MIN_SIZE 10 171 #define HASH_TABLE_MIN_SIZE 10
122 #define HASH_TABLE_DEFAULT_REHASH_THRESHOLD(size, test_function) \ 172 #define HASH_TABLE_DEFAULT_REHASH_THRESHOLD(size, test) \
123 (((size) > 4096 && NULL == (test_function)) ? 0.7 : 0.6) 173 (((size) > 4096 && EQ (Vhash_table_test_eq, test)) ? 0.7 : 0.6)
124 174
125 #define HASHCODE(key, ht) \ 175 #define HASHCODE(key, ht, http) \
126 ((((ht)->hash_function ? (ht)->hash_function (key) : LISP_HASH (key)) \ 176 ((((!EQ (Vhash_table_test_eq, ht->test)) ? \
127 * (ht)->golden_ratio) \ 177 (http)->hash_function (http, key) : \
128 % (ht)->size) 178 LISP_HASH (key)) * (ht)->golden_ratio) % (ht)->size)
129 179
130 #define KEYS_EQUAL_P(key1, key2, testfun) \ 180 #define KEYS_EQUAL_P(key1, key2, test, http) \
131 (EQ (key1, key2) || ((testfun) && (testfun) (key1, key2))) 181 (EQ (key1, key2) || ((!EQ (Vhash_table_test_eq, test) && \
182 (http->equal_function) (http, key1, key2))))
132 183
133 #define LINEAR_PROBING_LOOP(probe, entries, size) \ 184 #define LINEAR_PROBING_LOOP(probe, entries, size) \
134 for (; \ 185 for (; \
135 !HTENTRY_CLEAR_P (probe) || \ 186 !HTENTRY_CLEAR_P (probe) || \
136 (probe == entries + size ? \ 187 (probe == entries + size ? \
185 } 236 }
186 237
187 238
188 239
189 static int 240 static int
190 lisp_object_eql_equal (Lisp_Object obj1, Lisp_Object obj2) 241 lisp_object_eql_equal (const Hash_Table_Test *UNUSED (http), Lisp_Object obj1,
242 Lisp_Object obj2)
191 { 243 {
192 return EQ (obj1, obj2) || 244 return EQ (obj1, obj2) ||
193 (NON_FIXNUM_NUMBER_P (obj1) && internal_equal (obj1, obj2, 0)); 245 (NON_FIXNUM_NUMBER_P (obj1) && internal_equal (obj1, obj2, 0));
194 } 246 }
195 247
196 static Hashcode 248 static Hashcode
197 lisp_object_eql_hash (Lisp_Object obj) 249 lisp_object_eql_hash (const Hash_Table_Test *UNUSED (http), Lisp_Object obj)
198 { 250 {
199 return NON_FIXNUM_NUMBER_P (obj) ? internal_hash (obj, 0) : LISP_HASH (obj); 251 return NON_FIXNUM_NUMBER_P (obj) ?
252 internal_hash (obj, 0, 0) : LISP_HASH (obj);
200 } 253 }
201 254
202 static int 255 static int
203 lisp_object_equal_equal (Lisp_Object obj1, Lisp_Object obj2) 256 lisp_object_equal_equal (const Hash_Table_Test *UNUSED (http),
257 Lisp_Object obj1, Lisp_Object obj2)
204 { 258 {
205 return internal_equal (obj1, obj2, 0); 259 return internal_equal (obj1, obj2, 0);
206 } 260 }
207 261
208 static Hashcode 262 static Hashcode
209 lisp_object_equal_hash (Lisp_Object obj) 263 lisp_object_equal_hash (const Hash_Table_Test *UNUSED (http), Lisp_Object obj)
210 { 264 {
211 return internal_hash (obj, 0); 265 return internal_hash (obj, 0, 0);
266 }
267
268 static Hashcode
269 lisp_object_equalp_hash (const Hash_Table_Test *UNUSED (http), Lisp_Object obj)
270 {
271 return internal_hash (obj, 0, 1);
272 }
273
274 static int
275 lisp_object_equalp_equal (const Hash_Table_Test *UNUSED (http),
276 Lisp_Object obj1, Lisp_Object obj2)
277 {
278 return internal_equalp (obj1, obj2, 0);
279 }
280
281 static Hashcode
282 lisp_object_general_hash (const Hash_Table_Test *http, Lisp_Object obj)
283 {
284 struct gcpro gcpro1;
285 Lisp_Object args[2] = { http->lisp_hash_function, obj }, res;
286
287 /* Make sure any weakly referenced objects don't get collected before the
288 funcall: */
289 GCPRO1 (args[0]);
290 gcpro1.nvars = countof (args);
291 res = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args));
292 UNGCPRO;
293
294 if (INTP (res))
295 {
296 return (Hashcode) (XINT (res));
297 }
298
299 #ifdef HAVE_BIGNUM
300 if (BIGNUMP (res))
301 {
302 if (bignum_fits_emacs_int_p (XBIGNUM_DATA (res)))
303 {
304 return (Hashcode) bignum_to_emacs_int (XBIGNUM_DATA (res));
305 }
306
307 signal_error (Qrange_error, "Not a valid hash code", res);
308 }
309 #endif
310
311 dead_wrong_type_argument (Qintegerp, res);
312 }
313
314 static int
315 lisp_object_general_equal (const Hash_Table_Test *http, Lisp_Object obj1,
316 Lisp_Object obj2)
317 {
318 struct gcpro gcpro1;
319 Lisp_Object args[] = { http->lisp_equal_function, obj1, obj2 }, res;
320
321 GCPRO1 (args[0]);
322 gcpro1.nvars = countof (args);
323 res = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args));
324 UNGCPRO;
325
326 return !(NILP (res));
212 } 327 }
213 328
214 329
215 static Lisp_Object 330 static Lisp_Object
216 mark_hash_table (Lisp_Object obj) 331 mark_hash_table (Lisp_Object obj)
229 { 344 {
230 mark_object (e->key); 345 mark_object (e->key);
231 mark_object (e->value); 346 mark_object (e->value);
232 } 347 }
233 } 348 }
349
350 mark_object (ht->test);
351
234 return Qnil; 352 return Qnil;
235 } 353 }
236 354
237 /* Equality of hash tables. Two hash tables are equal when they are of 355 /* Equality of hash tables. Two hash tables are equal when they are of
238 the same weakness and test function, they have the same number of 356 the same weakness and test function, they have the same number of
250 { 368 {
251 Lisp_Hash_Table *ht1 = XHASH_TABLE (hash_table1); 369 Lisp_Hash_Table *ht1 = XHASH_TABLE (hash_table1);
252 Lisp_Hash_Table *ht2 = XHASH_TABLE (hash_table2); 370 Lisp_Hash_Table *ht2 = XHASH_TABLE (hash_table2);
253 htentry *e, *sentinel; 371 htentry *e, *sentinel;
254 372
255 if ((ht1->test_function != ht2->test_function) || 373 if (!(EQ (ht1->test, ht2->test)) ||
256 (ht1->weakness != ht2->weakness) || 374 (ht1->weakness != ht2->weakness) ||
257 (ht1->count != ht2->count)) 375 (ht1->count != ht2->count))
258 return 0; 376 return 0;
259 377
260 depth++; 378 depth++;
261 379
274 392
275 /* This is not a great hash function, but it _is_ correct and fast. 393 /* This is not a great hash function, but it _is_ correct and fast.
276 Examining all entries is too expensive, and examining a random 394 Examining all entries is too expensive, and examining a random
277 subset does not yield a correct hash function. */ 395 subset does not yield a correct hash function. */
278 static Hashcode 396 static Hashcode
279 hash_table_hash (Lisp_Object hash_table, int UNUSED (depth)) 397 hash_table_hash (Lisp_Object hash_table, int UNUSED (depth),
398 int UNUSED (equalp))
280 { 399 {
281 return XHASH_TABLE (hash_table)->count; 400 return XHASH_TABLE (hash_table)->count;
282 } 401 }
283 402
284 #ifdef MEMORY_USAGE_STATS 403 #ifdef MEMORY_USAGE_STATS
364 Ascbyte pigbuf[350]; 483 Ascbyte pigbuf[350];
365 484
366 write_ascstring (printcharfun, 485 write_ascstring (printcharfun,
367 print_readably ? "#s(hash-table" : "#<hash-table"); 486 print_readably ? "#s(hash-table" : "#<hash-table");
368 487
369 /* These checks have a kludgy look to them, but they are safe. 488 if (!(EQ (ht->test, Vhash_table_test_eql)))
370 Due to nature of hashing, you cannot use arbitrary 489 {
371 test functions anyway. */ 490 write_fmt_string_lisp (printcharfun, " :test %S",
372 if (!ht->test_function) 491 1, XHASH_TABLE_TEST (ht->test)->name);
373 write_ascstring (printcharfun, " :test eq"); 492 }
374 else if (ht->test_function == lisp_object_equal_equal)
375 write_ascstring (printcharfun, " :test equal");
376 else if (ht->test_function == lisp_object_eql_equal)
377 DO_NOTHING;
378 else
379 ABORT ();
380 493
381 if (ht->count || !print_readably) 494 if (ht->count || !print_readably)
382 { 495 {
383 if (print_readably) 496 if (print_readably)
384 write_fmt_string (printcharfun, " :size %ld", (long) ht->count); 497 write_fmt_string (printcharfun, " :size %ld", (long) ht->count);
403 float_to_string (pigbuf, ht->rehash_size); 516 float_to_string (pigbuf, ht->rehash_size);
404 write_fmt_string (printcharfun, " :rehash-size %s", pigbuf); 517 write_fmt_string (printcharfun, " :rehash-size %s", pigbuf);
405 } 518 }
406 519
407 if (ht->rehash_threshold 520 if (ht->rehash_threshold
408 != HASH_TABLE_DEFAULT_REHASH_THRESHOLD (ht->size, 521 != HASH_TABLE_DEFAULT_REHASH_THRESHOLD (ht->size, ht->test))
409 ht->test_function))
410 { 522 {
411 float_to_string (pigbuf, ht->rehash_threshold); 523 float_to_string (pigbuf, ht->rehash_threshold);
412 write_fmt_string (printcharfun, " :rehash-threshold %s", pigbuf); 524 write_fmt_string (printcharfun, " :rehash-threshold %s", pigbuf);
413 } 525 }
414 526
505 { XD_ELEMCOUNT, offsetof (Lisp_Hash_Table, size) }, 617 { XD_ELEMCOUNT, offsetof (Lisp_Hash_Table, size) },
506 { XD_INT, offsetof (Lisp_Hash_Table, weakness) }, 618 { XD_INT, offsetof (Lisp_Hash_Table, weakness) },
507 { XD_UNION, offsetof (Lisp_Hash_Table, hentries), XD_INDIRECT (1, 0), 619 { XD_UNION, offsetof (Lisp_Hash_Table, hentries), XD_INDIRECT (1, 0),
508 { &htentry_union_description } }, 620 { &htentry_union_description } },
509 { XD_LO_LINK, offsetof (Lisp_Hash_Table, next_weak) }, 621 { XD_LO_LINK, offsetof (Lisp_Hash_Table, next_weak) },
622 { XD_LISP_OBJECT,offsetof (Lisp_Hash_Table, test) },
510 { XD_END } 623 { XD_END }
511 }; 624 };
512 625
513 DEFINE_DUMPABLE_LISP_OBJECT ("hash-table", hash_table, 626 DEFINE_DUMPABLE_LISP_OBJECT ("hash-table", hash_table,
514 mark_hash_table, print_hash_table, 627 mark_hash_table, print_hash_table,
551 #else /* not NEW_GC */ 664 #else /* not NEW_GC */
552 return xnew_array_and_zero (htentry, size); 665 return xnew_array_and_zero (htentry, size);
553 #endif /* not NEW_GC */ 666 #endif /* not NEW_GC */
554 } 667 }
555 668
669 static Lisp_Object decode_hash_table_test (Lisp_Object obj);
670
556 Lisp_Object 671 Lisp_Object
557 make_standard_lisp_hash_table (enum hash_table_test test, 672 make_general_lisp_hash_table (Lisp_Object test,
558 Elemcount size,
559 double rehash_size,
560 double rehash_threshold,
561 enum hash_table_weakness weakness)
562 {
563 hash_table_hash_function_t hash_function = 0;
564 hash_table_test_function_t test_function = 0;
565
566 switch (test)
567 {
568 case HASH_TABLE_EQ:
569 test_function = 0;
570 hash_function = 0;
571 break;
572
573 case HASH_TABLE_EQL:
574 test_function = lisp_object_eql_equal;
575 hash_function = lisp_object_eql_hash;
576 break;
577
578 case HASH_TABLE_EQUAL:
579 test_function = lisp_object_equal_equal;
580 hash_function = lisp_object_equal_hash;
581 break;
582
583 default:
584 ABORT ();
585 }
586
587 return make_general_lisp_hash_table (hash_function, test_function,
588 size, rehash_size, rehash_threshold,
589 weakness);
590 }
591
592 Lisp_Object
593 make_general_lisp_hash_table (hash_table_hash_function_t hash_function,
594 hash_table_test_function_t test_function,
595 Elemcount size, 673 Elemcount size,
596 double rehash_size, 674 double rehash_size,
597 double rehash_threshold, 675 double rehash_threshold,
598 enum hash_table_weakness weakness) 676 enum hash_table_weakness weakness)
599 { 677 {
600 Lisp_Object hash_table = ALLOC_NORMAL_LISP_OBJECT (hash_table); 678 Lisp_Object hash_table = ALLOC_NORMAL_LISP_OBJECT (hash_table);
601 Lisp_Hash_Table *ht = XHASH_TABLE (hash_table); 679 Lisp_Hash_Table *ht = XHASH_TABLE (hash_table);
602 680
603 ht->test_function = test_function; 681 assert (HASH_TABLE_TESTP (test));
604 ht->hash_function = hash_function; 682
683 ht->test = test;
605 ht->weakness = weakness; 684 ht->weakness = weakness;
606 685
607 ht->rehash_size = 686 ht->rehash_size =
608 rehash_size > 1.0 ? rehash_size : HASH_TABLE_DEFAULT_REHASH_SIZE; 687 rehash_size > 1.0 ? rehash_size : HASH_TABLE_DEFAULT_REHASH_SIZE;
609 688
610 ht->rehash_threshold = 689 ht->rehash_threshold =
611 rehash_threshold > 0.0 ? rehash_threshold : 690 rehash_threshold > 0.0 ? rehash_threshold :
612 HASH_TABLE_DEFAULT_REHASH_THRESHOLD (size, ht->test_function); 691 HASH_TABLE_DEFAULT_REHASH_THRESHOLD (size, ht->test);
613 692
614 if (size < HASH_TABLE_MIN_SIZE) 693 if (size < HASH_TABLE_MIN_SIZE)
615 size = HASH_TABLE_MIN_SIZE; 694 size = HASH_TABLE_MIN_SIZE;
616 ht->size = hash_table_size ((Elemcount) (((double) size / ht->rehash_threshold) 695 ht->size = hash_table_size ((Elemcount) (((double) size / ht->rehash_threshold)
617 + 1.0)); 696 + 1.0));
629 708
630 return hash_table; 709 return hash_table;
631 } 710 }
632 711
633 Lisp_Object 712 Lisp_Object
634 make_lisp_hash_table (Elemcount size, 713 make_lisp_hash_table (Elemcount size, enum hash_table_weakness weakness,
635 enum hash_table_weakness weakness, 714 Lisp_Object test)
636 enum hash_table_test test) 715 {
637 { 716 test = decode_hash_table_test (test);
638 return make_standard_lisp_hash_table (test, size, -1.0, -1.0, weakness); 717 return make_general_lisp_hash_table (test, size, -1.0, -1.0, weakness);
639 } 718 }
640 719
641 /* Pretty reading of hash tables. 720 /* Pretty reading of hash tables.
642 721
643 Here we use the existing structures mechanism (which is, 722 Here we use the existing structures mechanism (which is,
676 if (EQ (value, Qkey)) return 1; 755 if (EQ (value, Qkey)) return 1;
677 if (EQ (value, Qkey_and_value)) return 1; 756 if (EQ (value, Qkey_and_value)) return 1;
678 if (EQ (value, Qkey_or_value)) return 1; 757 if (EQ (value, Qkey_or_value)) return 1;
679 if (EQ (value, Qvalue)) return 1; 758 if (EQ (value, Qvalue)) return 1;
680 759
760 #ifndef NO_NEED_TO_HANDLE_21_4_CODE
681 /* Following values are obsolete as of 19990901 in xemacs-21.2 */ 761 /* Following values are obsolete as of 19990901 in xemacs-21.2 */
682 if (EQ (value, Qnon_weak)) return 1; 762 if (EQ (value, Qnon_weak)) return 1;
683 if (EQ (value, Qweak)) return 1; 763 if (EQ (value, Qweak)) return 1;
684 if (EQ (value, Qkey_weak)) return 1; 764 if (EQ (value, Qkey_weak)) return 1;
685 if (EQ (value, Qkey_or_value_weak)) return 1; 765 if (EQ (value, Qkey_or_value_weak)) return 1;
686 if (EQ (value, Qvalue_weak)) return 1; 766 if (EQ (value, Qvalue_weak)) return 1;
767 #endif
687 768
688 maybe_invalid_constant ("Invalid hash table weakness", 769 maybe_invalid_constant ("Invalid hash table weakness",
689 value, Qhash_table, errb); 770 value, Qhash_table, errb);
690 return 0; 771 return 0;
691 } 772 }
698 if (EQ (obj, Qkey_and_value)) return HASH_TABLE_WEAK; 779 if (EQ (obj, Qkey_and_value)) return HASH_TABLE_WEAK;
699 if (EQ (obj, Qkey)) return HASH_TABLE_KEY_WEAK; 780 if (EQ (obj, Qkey)) return HASH_TABLE_KEY_WEAK;
700 if (EQ (obj, Qkey_or_value)) return HASH_TABLE_KEY_VALUE_WEAK; 781 if (EQ (obj, Qkey_or_value)) return HASH_TABLE_KEY_VALUE_WEAK;
701 if (EQ (obj, Qvalue)) return HASH_TABLE_VALUE_WEAK; 782 if (EQ (obj, Qvalue)) return HASH_TABLE_VALUE_WEAK;
702 783
784 #ifndef NO_NEED_TO_HANDLE_21_4_CODE
703 /* Following values are obsolete as of 19990901 in xemacs-21.2 */ 785 /* Following values are obsolete as of 19990901 in xemacs-21.2 */
704 if (EQ (obj, Qnon_weak)) return HASH_TABLE_NON_WEAK; 786 if (EQ (obj, Qnon_weak)) return HASH_TABLE_NON_WEAK;
705 if (EQ (obj, Qweak)) return HASH_TABLE_WEAK; 787 if (EQ (obj, Qweak)) return HASH_TABLE_WEAK;
706 if (EQ (obj, Qkey_weak)) return HASH_TABLE_KEY_WEAK; 788 if (EQ (obj, Qkey_weak)) return HASH_TABLE_KEY_WEAK;
707 if (EQ (obj, Qkey_or_value_weak)) return HASH_TABLE_KEY_VALUE_WEAK; 789 if (EQ (obj, Qkey_or_value_weak)) return HASH_TABLE_KEY_VALUE_WEAK;
708 if (EQ (obj, Qvalue_weak)) return HASH_TABLE_VALUE_WEAK; 790 if (EQ (obj, Qvalue_weak)) return HASH_TABLE_VALUE_WEAK;
791 #endif
709 792
710 invalid_constant ("Invalid hash table weakness", obj); 793 invalid_constant ("Invalid hash table weakness", obj);
711 RETURN_NOT_REACHED (HASH_TABLE_NON_WEAK); 794 RETURN_NOT_REACHED (HASH_TABLE_NON_WEAK);
712 } 795 }
713 796
714 static int 797 static int
715 hash_table_test_validate (Lisp_Object UNUSED (keyword), Lisp_Object value, 798 hash_table_test_validate (Lisp_Object UNUSED (keyword), Lisp_Object value,
716 Error_Behavior errb) 799 Error_Behavior errb)
717 { 800 {
718 if (EQ (value, Qnil)) return 1; 801 Lisp_Object lookup;
719 if (EQ (value, Qeq)) return 1; 802
720 if (EQ (value, Qequal)) return 1; 803 if (NILP (value))
721 if (EQ (value, Qeql)) return 1; 804 {
722 805 return 1;
723 maybe_invalid_constant ("Invalid hash table test", 806 }
724 value, Qhash_table, errb); 807
725 return 0; 808 lookup = Fassq (value, XWEAK_LIST_LIST (Vhash_table_test_weak_list));
726 } 809 if (NILP (lookup))
727 810 {
728 static enum hash_table_test 811 maybe_invalid_constant ("Invalid hash table test",
812 value, Qhash_table, errb);
813 }
814
815 return 1;
816 }
817
818 static Lisp_Object
729 decode_hash_table_test (Lisp_Object obj) 819 decode_hash_table_test (Lisp_Object obj)
730 { 820 {
731 if (EQ (obj, Qnil)) return HASH_TABLE_EQL; 821 Lisp_Object result;
732 if (EQ (obj, Qeq)) return HASH_TABLE_EQ; 822
733 if (EQ (obj, Qequal)) return HASH_TABLE_EQUAL; 823 if (NILP (obj))
734 if (EQ (obj, Qeql)) return HASH_TABLE_EQL; 824 {
735 825 obj = Qeql;
736 invalid_constant ("Invalid hash table test", obj); 826 }
737 RETURN_NOT_REACHED (HASH_TABLE_EQ); 827
828 result = Fassq (obj, XWEAK_LIST_LIST (Vhash_table_test_weak_list));
829 if (NILP (result))
830 {
831 invalid_constant ("Invalid hash table test", obj);
832 }
833
834 return XCDR (result);
738 } 835 }
739 836
740 static int 837 static int
741 hash_table_rehash_size_validate (Lisp_Object UNUSED (keyword), 838 hash_table_rehash_size_validate (Lisp_Object UNUSED (keyword),
742 Lisp_Object value, Error_Behavior errb) 839 Lisp_Object value, Error_Behavior errb)
863 else if (EQ (key, Qsize)) size = value; 960 else if (EQ (key, Qsize)) size = value;
864 else if (EQ (key, Qrehash_size)) rehash_size = value; 961 else if (EQ (key, Qrehash_size)) rehash_size = value;
865 else if (EQ (key, Qrehash_threshold)) rehash_threshold = value; 962 else if (EQ (key, Qrehash_threshold)) rehash_threshold = value;
866 else if (EQ (key, Qweakness)) weakness = value; 963 else if (EQ (key, Qweakness)) weakness = value;
867 else if (EQ (key, Qdata)) data = value; 964 else if (EQ (key, Qdata)) data = value;
965 #ifndef NO_NEED_TO_HANDLE_21_4_CODE
868 else if (EQ (key, Qtype))/*obsolete*/ weakness = value; 966 else if (EQ (key, Qtype))/*obsolete*/ weakness = value;
967 #endif
869 else if (KEYWORDP (key)) 968 else if (KEYWORDP (key))
870 signal_error (Qinvalid_read_syntax, 969 signal_error (Qinvalid_read_syntax,
871 "can't mix keyword and non-keyword hash table syntax", 970 "can't mix keyword and non-keyword hash table syntax",
872 key); 971 key);
873 else ABORT(); 972 else ABORT();
874 } 973 }
875 } 974 }
876 975
877 /* Create the hash table. */ 976 /* Create the hash table. */
878 hash_table = make_standard_lisp_hash_table 977 hash_table = make_general_lisp_hash_table
879 (decode_hash_table_test (test), 978 (decode_hash_table_test (test),
880 decode_hash_table_size (size), 979 decode_hash_table_size (size),
881 decode_hash_table_rehash_size (rehash_size), 980 decode_hash_table_rehash_size (rehash_size),
882 decode_hash_table_rehash_threshold (rehash_threshold), 981 decode_hash_table_rehash_threshold (rehash_threshold),
883 decode_hash_table_weakness (weakness)); 982 decode_hash_table_weakness (weakness));
884 983
885 /* I'm not sure whether this can GC, but better safe than sorry. */ 984 /* This can GC with a user-specified test. */
886 { 985 {
887 struct gcpro gcpro1; 986 struct gcpro gcpro1;
888 GCPRO1 (hash_table); 987 GCPRO1 (hash_table);
889 988
890 /* And fill it with data. */ 989 /* And fill it with data. */
922 define_structure_type_keyword (st, Qrehash_size, hash_table_rehash_size_validate); 1021 define_structure_type_keyword (st, Qrehash_size, hash_table_rehash_size_validate);
923 define_structure_type_keyword (st, Qrehash_threshold, hash_table_rehash_threshold_validate); 1022 define_structure_type_keyword (st, Qrehash_threshold, hash_table_rehash_threshold_validate);
924 define_structure_type_keyword (st, Qweakness, hash_table_weakness_validate); 1023 define_structure_type_keyword (st, Qweakness, hash_table_weakness_validate);
925 define_structure_type_keyword (st, Qdata, hash_table_data_validate); 1024 define_structure_type_keyword (st, Qdata, hash_table_data_validate);
926 1025
1026 #ifndef NO_NEED_TO_HANDLE_21_4_CODE
927 /* obsolete as of 19990901 in xemacs-21.2 */ 1027 /* obsolete as of 19990901 in xemacs-21.2 */
928 define_structure_type_keyword (st, Qtype, hash_table_weakness_validate); 1028 define_structure_type_keyword (st, Qtype, hash_table_weakness_validate);
1029 #endif
929 } 1030 }
930 1031
931 /* Create a built-in Lisp structure type named `hash-table'. 1032 /* Create a built-in Lisp structure type named `hash-table'.
932 We make #s(hashtable ...) equivalent to #s(hash-table ...), 1033 We make #s(hashtable ...) equivalent to #s(hash-table ...),
933 for backward compatibility. 1034 for backward compatibility.
954 1055
955 DEFUN ("make-hash-table", Fmake_hash_table, 0, MANY, 0, /* 1056 DEFUN ("make-hash-table", Fmake_hash_table, 0, MANY, 0, /*
956 Return a new empty hash table object. 1057 Return a new empty hash table object.
957 Use Common Lisp style keywords to specify hash table properties. 1058 Use Common Lisp style keywords to specify hash table properties.
958 1059
959 Keyword :test can be `eq', `eql' (default) or `equal'. 1060 Keyword :test can be `eq', `eql' (default), `equal' or `equalp'.
960 Comparison between keys is done using this function. 1061 Comparison between keys is done using this function. If speed is important,
961 If speed is important, consider using `eq'. 1062 consider using `eq'. When storing strings in the hash table, you will
962 When storing strings in the hash table, you will likely need to use `equal'. 1063 likely need to use `equal' or `equalp' (for case-insensitivity). With other
1064 objects, consider using a test function defined with
1065 `define-hash-table-test', an emacs extension to this Common Lisp hash table
1066 API.
963 1067
964 Keyword :size specifies the number of keys likely to be inserted. 1068 Keyword :size specifies the number of keys likely to be inserted.
965 This number of entries can be inserted without enlarging the hash table. 1069 This number of entries can be inserted without enlarging the hash table.
966 1070
967 Keyword :rehash-size must be a float greater than 1.0, and specifies 1071 Keyword :rehash-size must be a float greater than 1.0, and specifies
1004 (int nargs, Lisp_Object *args)) 1108 (int nargs, Lisp_Object *args))
1005 { 1109 {
1006 #ifdef NO_NEED_TO_HANDLE_21_4_CODE 1110 #ifdef NO_NEED_TO_HANDLE_21_4_CODE
1007 PARSE_KEYWORDS (Qmake_hash_table, nargs, args, 0, 5, 1111 PARSE_KEYWORDS (Qmake_hash_table, nargs, args, 0, 5,
1008 (test, size, rehash_size, rehash_threshold, weakness), 1112 (test, size, rehash_size, rehash_threshold, weakness),
1009 NULL, weakness = Qunbound), 0); 1113 NULL, 0);
1010 #else 1114 #else
1011 PARSE_KEYWORDS (Qmake_hash_table, nargs, args, 0, 6, 1115 PARSE_KEYWORDS (Qmake_hash_table, nargs, args, 0, 6,
1012 (test, size, rehash_size, rehash_threshold, weakness, 1116 (test, size, rehash_size, rehash_threshold, weakness,
1013 type), (type = Qunbound, weakness = Qunbound), 0); 1117 type), (type = Qunbound, weakness = Qunbound), 0);
1014 1118
1032 VALIDATE_VAR (size); 1136 VALIDATE_VAR (size);
1033 VALIDATE_VAR (rehash_size); 1137 VALIDATE_VAR (rehash_size);
1034 VALIDATE_VAR (rehash_threshold); 1138 VALIDATE_VAR (rehash_threshold);
1035 VALIDATE_VAR (weakness); 1139 VALIDATE_VAR (weakness);
1036 1140
1037 return make_standard_lisp_hash_table 1141 return make_general_lisp_hash_table
1038 (decode_hash_table_test (test), 1142 (decode_hash_table_test (test),
1039 decode_hash_table_size (size), 1143 decode_hash_table_size (size),
1040 decode_hash_table_rehash_size (rehash_size), 1144 decode_hash_table_rehash_size (rehash_size),
1041 decode_hash_table_rehash_threshold (rehash_threshold), 1145 decode_hash_table_rehash_threshold (rehash_threshold),
1042 decode_hash_table_weakness (weakness)); 1146 decode_hash_table_weakness (weakness));
1069 static void 1173 static void
1070 resize_hash_table (Lisp_Hash_Table *ht, Elemcount new_size) 1174 resize_hash_table (Lisp_Hash_Table *ht, Elemcount new_size)
1071 { 1175 {
1072 htentry *old_entries, *new_entries, *sentinel, *e; 1176 htentry *old_entries, *new_entries, *sentinel, *e;
1073 Elemcount old_size; 1177 Elemcount old_size;
1178 Hash_Table_Test *http = XHASH_TABLE_TEST (ht->test);
1074 1179
1075 old_size = ht->size; 1180 old_size = ht->size;
1076 ht->size = new_size; 1181 ht->size = new_size;
1077 1182
1078 old_entries = ht->hentries; 1183 old_entries = ht->hentries;
1084 compute_hash_table_derived_values (ht); 1189 compute_hash_table_derived_values (ht);
1085 1190
1086 for (e = old_entries, sentinel = e + old_size; e < sentinel; e++) 1191 for (e = old_entries, sentinel = e + old_size; e < sentinel; e++)
1087 if (!HTENTRY_CLEAR_P (e)) 1192 if (!HTENTRY_CLEAR_P (e))
1088 { 1193 {
1089 htentry *probe = new_entries + HASHCODE (e->key, ht); 1194 htentry *probe = new_entries + HASHCODE (e->key, ht, http);
1090 LINEAR_PROBING_LOOP (probe, new_entries, new_size) 1195 LINEAR_PROBING_LOOP (probe, new_entries, new_size)
1091 ; 1196 ;
1092 *probe = *e; 1197 *probe = *e;
1093 } 1198 }
1094 1199
1105 { 1210 {
1106 const Lisp_Hash_Table *ht = xhash_table (hash_table); 1211 const Lisp_Hash_Table *ht = xhash_table (hash_table);
1107 /* We leave room for one never-occupied sentinel htentry at the end. */ 1212 /* We leave room for one never-occupied sentinel htentry at the end. */
1108 htentry *new_entries = allocate_hash_table_entries (ht->size + 1); 1213 htentry *new_entries = allocate_hash_table_entries (ht->size + 1);
1109 htentry *e, *sentinel; 1214 htentry *e, *sentinel;
1215 Hash_Table_Test *http = XHASH_TABLE_TEST (ht->test);
1110 1216
1111 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++) 1217 for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++)
1112 if (!HTENTRY_CLEAR_P (e)) 1218 if (!HTENTRY_CLEAR_P (e))
1113 { 1219 {
1114 htentry *probe = new_entries + HASHCODE (e->key, ht); 1220 htentry *probe = new_entries + HASHCODE (e->key, ht, http);
1115 LINEAR_PROBING_LOOP (probe, new_entries, ht->size) 1221 LINEAR_PROBING_LOOP (probe, new_entries, ht->size)
1116 ; 1222 ;
1117 *probe = *e; 1223 *probe = *e;
1118 } 1224 }
1119 1225
1133 } 1239 }
1134 1240
1135 htentry * 1241 htentry *
1136 find_htentry (Lisp_Object key, const Lisp_Hash_Table *ht) 1242 find_htentry (Lisp_Object key, const Lisp_Hash_Table *ht)
1137 { 1243 {
1138 hash_table_test_function_t test_function = ht->test_function; 1244 Lisp_Object test = ht->test;
1245 Hash_Table_Test *http = XHASH_TABLE_TEST (test);
1246
1139 htentry *entries = ht->hentries; 1247 htentry *entries = ht->hentries;
1140 htentry *probe = entries + HASHCODE (key, ht); 1248 htentry *probe = entries + HASHCODE (key, ht, http);
1141 1249
1142 LINEAR_PROBING_LOOP (probe, entries, ht->size) 1250 LINEAR_PROBING_LOOP (probe, entries, ht->size)
1143 if (KEYS_EQUAL_P (probe->key, key, test_function)) 1251 if (KEYS_EQUAL_P (probe->key, key, test, http))
1144 break; 1252 break;
1145 1253
1146 return probe; 1254 return probe;
1147 } 1255 }
1148 1256
1149 /* A version of Fputhash() that increments the value by the specified 1257 /* A version of Fputhash() that increments the value by the specified
1150 amount and dispenses will all error checks. Assumes that tables does 1258 amount and dispenses with all error checks. Assumes that tables does
1151 comparison using EQ. Used by the profiling routines to avoid 1259 comparison using EQ. Used by the profiling routines to avoid
1152 overhead -- profiling overhead was being recorded at up to 15% of the 1260 overhead -- profiling overhead was being recorded at up to 15% of the
1153 total time. */ 1261 total time. */
1154 1262
1155 void 1263 void
1156 inchash_eq (Lisp_Object key, Lisp_Object table, EMACS_INT offset) 1264 inchash_eq (Lisp_Object key, Lisp_Object table, EMACS_INT offset)
1157 { 1265 {
1158 Lisp_Hash_Table *ht = XHASH_TABLE (table); 1266 Lisp_Hash_Table *ht = XHASH_TABLE (table);
1267 Hash_Table_Test *http = XHASH_TABLE_TEST (ht->test);
1159 htentry *entries = ht->hentries; 1268 htentry *entries = ht->hentries;
1160 htentry *probe = entries + HASHCODE (key, ht); 1269 htentry *probe = entries + HASHCODE (key, ht, http);
1161 1270
1162 LINEAR_PROBING_LOOP (probe, entries, ht->size) 1271 LINEAR_PROBING_LOOP (probe, entries, ht->size)
1163 if (EQ (probe->key, key)) 1272 if (EQ (probe->key, key))
1164 break; 1273 break;
1165 1274
1211 Subsequent entries are removed and reinserted. 1320 Subsequent entries are removed and reinserted.
1212 We don't use tombstones - too wasteful. */ 1321 We don't use tombstones - too wasteful. */
1213 static void 1322 static void
1214 remhash_1 (Lisp_Hash_Table *ht, htentry *entries, htentry *probe) 1323 remhash_1 (Lisp_Hash_Table *ht, htentry *entries, htentry *probe)
1215 { 1324 {
1325 Hash_Table_Test *http = XHASH_TABLE_TEST (ht->test);
1216 Elemcount size = ht->size; 1326 Elemcount size = ht->size;
1217 CLEAR_HTENTRY (probe); 1327 CLEAR_HTENTRY (probe);
1218 probe++; 1328 probe++;
1219 ht->count--; 1329 ht->count--;
1220 1330
1221 LINEAR_PROBING_LOOP (probe, entries, size) 1331 LINEAR_PROBING_LOOP (probe, entries, size)
1222 { 1332 {
1223 Lisp_Object key = probe->key; 1333 Lisp_Object key = probe->key;
1224 htentry *probe2 = entries + HASHCODE (key, ht); 1334 htentry *probe2 = entries + HASHCODE (key, ht, http);
1225 LINEAR_PROBING_LOOP (probe2, entries, size) 1335 LINEAR_PROBING_LOOP (probe2, entries, size)
1226 if (EQ (probe2->key, key)) 1336 if (EQ (probe2->key, key))
1227 /* htentry at probe doesn't need to move. */ 1337 /* htentry at probe doesn't need to move. */
1228 goto continue_outer_loop; 1338 goto continue_outer_loop;
1229 /* Move htentry from probe to new home at probe2. */ 1339 /* Move htentry from probe to new home at probe2. */
1277 { 1387 {
1278 return make_int (xhash_table (hash_table)->count); 1388 return make_int (xhash_table (hash_table)->count);
1279 } 1389 }
1280 1390
1281 DEFUN ("hash-table-test", Fhash_table_test, 1, 1, 0, /* 1391 DEFUN ("hash-table-test", Fhash_table_test, 1, 1, 0, /*
1282 Return the test function of HASH-TABLE. 1392 Return HASH-TABLE's test.
1283 This can be one of `eq', `eql' or `equal'. 1393
1394 This can be one of `eq', `eql', `equal', `equalp', or some symbol supplied
1395 as the NAME argument to `define-hash-table-test', which see.
1284 */ 1396 */
1285 (hash_table)) 1397 (hash_table))
1286 { 1398 {
1287 hash_table_test_function_t fun = xhash_table (hash_table)->test_function; 1399 CHECK_HASH_TABLE (hash_table);
1288 1400 return XHASH_TABLE_TEST (XHASH_TABLE (hash_table)->test)->name;
1289 return (fun == lisp_object_eql_equal ? Qeql :
1290 fun == lisp_object_equal_equal ? Qequal :
1291 Qeq);
1292 } 1401 }
1293 1402
1294 DEFUN ("hash-table-size", Fhash_table_size, 1, 1, 0, /* 1403 DEFUN ("hash-table-size", Fhash_table_size, 1, 1, 0, /*
1295 Return the size of HASH-TABLE. 1404 Return the size of HASH-TABLE.
1296 This is the current number of slots in HASH-TABLE, whether occupied or not. 1405 This is the current number of slots in HASH-TABLE, whether occupied or not.
1709 } 1818 }
1710 1819
1711 /* Return a hash value for an array of Lisp_Objects of size SIZE. */ 1820 /* Return a hash value for an array of Lisp_Objects of size SIZE. */
1712 1821
1713 Hashcode 1822 Hashcode
1714 internal_array_hash (Lisp_Object *arr, int size, int depth) 1823 internal_array_hash (Lisp_Object *arr, int size, int depth, Boolint equalp)
1715 { 1824 {
1716 int i; 1825 int i;
1717 Hashcode hash = 0; 1826 Hashcode hash = 0;
1718 depth++; 1827 depth++;
1719 1828
1720 if (size <= 5) 1829 if (size <= 5)
1721 { 1830 {
1722 for (i = 0; i < size; i++) 1831 for (i = 0; i < size; i++)
1723 hash = HASH2 (hash, internal_hash (arr[i], depth)); 1832 hash = HASH2 (hash, internal_hash (arr[i], depth, equalp));
1724 return hash; 1833 return hash;
1725 } 1834 }
1726 1835
1727 /* just pick five elements scattered throughout the array. 1836 /* just pick five elements scattered throughout the array.
1728 A slightly better approach would be to offset by some 1837 A slightly better approach would be to offset by some
1729 noise factor from the points chosen below. */ 1838 noise factor from the points chosen below. */
1730 for (i = 0; i < 5; i++) 1839 for (i = 0; i < 5; i++)
1731 hash = HASH2 (hash, internal_hash (arr[i*size/5], depth)); 1840 hash = HASH2 (hash, internal_hash (arr[i*size/5], depth, equalp));
1732 1841
1733 return hash; 1842 return hash;
1843 }
1844
1845 /* This needs to be algorithmically the same as
1846 internal_array_hash(). Unfortunately, for strings with non-ASCII content,
1847 it has to be O(2N), I don't see a reasonable alternative to hashing
1848 sequence relying on their length. It is O(1) for pure ASCII strings,
1849 though. */
1850
1851 static Hashcode
1852 string_equalp_hash (Lisp_Object string)
1853 {
1854 Bytecount len = XSTRING_LENGTH (string),
1855 ascii_begin = (Bytecount) XSTRING_ASCII_BEGIN (string);
1856 const Ibyte *ptr = XSTRING_DATA (string), *pend = ptr + len;
1857 Charcount clen;
1858 Hashcode hash = 0;
1859
1860 if (len == ascii_begin)
1861 {
1862 clen = len;
1863 }
1864 else
1865 {
1866 clen = string_char_length (string);
1867 }
1868
1869 if (clen <= 5)
1870 {
1871 while (ptr < pend)
1872 {
1873 hash = HASH2 (hash,
1874 LISP_HASH (make_char (CANONCASE (NULL,
1875 itext_ichar (ptr)))));
1876 INC_IBYTEPTR (ptr);
1877 }
1878 }
1879 else
1880 {
1881 int ii;
1882
1883 if (clen == len)
1884 {
1885 for (ii = 0; ii < 5; ii++)
1886 {
1887 hash = HASH2 (hash,
1888 LISP_HASH (make_char
1889 (CANONCASE (NULL,
1890 ptr[ii * clen / 5]))));
1891 }
1892 }
1893 else
1894 {
1895 Charcount this_char = 0, last_char = 0;
1896 for (ii = 0; ii < 5; ii++)
1897 {
1898 this_char = ii * clen / 5;
1899 ptr = itext_n_addr (ptr, this_char - last_char);
1900 last_char = this_char;
1901
1902 hash = HASH2 (hash,
1903 LISP_HASH (make_char
1904 (CANONCASE (NULL, itext_ichar (ptr)))));
1905 }
1906 }
1907 }
1908
1909 return HASH2 (clen, hash);
1734 } 1910 }
1735 1911
1736 /* Return a hash value for a Lisp_Object. This is for use when hashing 1912 /* Return a hash value for a Lisp_Object. This is for use when hashing
1737 objects with the comparison being `equal' (for `eq', you can just 1913 objects with the comparison being `equal' (for `eq', you can just
1738 use the Lisp_Object itself as the hash value). You need to make a 1914 use the Lisp_Object itself as the hash value). You need to make a
1744 and only hash at most 5 elements out of a vector. Theoretically 1920 and only hash at most 5 elements out of a vector. Theoretically
1745 we could still take 5^5 time (a big big number) to compute a 1921 we could still take 5^5 time (a big big number) to compute a
1746 hash, but practically this won't ever happen. */ 1922 hash, but practically this won't ever happen. */
1747 1923
1748 Hashcode 1924 Hashcode
1749 internal_hash (Lisp_Object obj, int depth) 1925 internal_hash (Lisp_Object obj, int depth, Boolint equalp)
1750 { 1926 {
1751 if (depth > 5) 1927 if (depth > 5)
1752 return 0; 1928 return 0;
1753 1929
1754 if (CONSP(obj)) 1930 if (CONSP(obj))
1759 depth += 1; 1935 depth += 1;
1760 1936
1761 if (!CONSP(XCDR(obj))) 1937 if (!CONSP(XCDR(obj)))
1762 { 1938 {
1763 /* special case for '(a . b) conses */ 1939 /* special case for '(a . b) conses */
1764 return HASH2(internal_hash(XCAR(obj), depth), 1940 return HASH2(internal_hash(XCAR(obj), depth, equalp),
1765 internal_hash(XCDR(obj), depth)); 1941 internal_hash(XCDR(obj), depth, equalp));
1766 } 1942 }
1767 1943
1768 /* Don't simply tail recurse; we want to hash lists with the 1944 /* Don't simply tail recurse; we want to hash lists with the
1769 same contents in distinct orders differently. */ 1945 same contents in distinct orders differently. */
1770 hash = internal_hash(XCAR(obj), depth); 1946 hash = internal_hash(XCAR(obj), depth, equalp);
1771 1947
1772 obj = XCDR(obj); 1948 obj = XCDR(obj);
1773 for (s = 1; s < 6 && CONSP(obj); obj = XCDR(obj), s++) 1949 for (s = 1; s < 6 && CONSP(obj); obj = XCDR(obj), s++)
1774 { 1950 {
1775 h = internal_hash(XCAR(obj), depth); 1951 h = internal_hash(XCAR(obj), depth, equalp);
1776 hash = HASH3(hash, h, s); 1952 hash = HASH3(hash, h, s);
1777 } 1953 }
1778 1954
1779 return hash; 1955 return hash;
1780 } 1956 }
1781 if (STRINGP (obj)) 1957 if (STRINGP (obj))
1782 { 1958 {
1959 if (equalp)
1960 {
1961 return string_equalp_hash (obj);
1962 }
1963
1783 return hash_string (XSTRING_DATA (obj), XSTRING_LENGTH (obj)); 1964 return hash_string (XSTRING_DATA (obj), XSTRING_LENGTH (obj));
1784 } 1965 }
1785 if (LRECORDP (obj)) 1966 if (LRECORDP (obj))
1786 { 1967 {
1787 const struct lrecord_implementation 1968 const struct lrecord_implementation
1788 *imp = XRECORD_LHEADER_IMPLEMENTATION (obj); 1969 *imp = XRECORD_LHEADER_IMPLEMENTATION (obj);
1789 if (imp->hash) 1970 if (imp->hash)
1790 return imp->hash (obj, depth); 1971 return imp->hash (obj, depth, equalp);
1972 }
1973
1974 if (equalp)
1975 {
1976 if (CHARP (obj))
1977 {
1978 /* Characters and numbers of the same numeric value hash
1979 differently, which is fine, they're not equalp. */
1980 return LISP_HASH (make_char (CANONCASE (NULL, XCHAR (obj))));
1981 }
1982
1983 if (INTP (obj))
1984 {
1985 return FLOAT_HASHCODE_FROM_DOUBLE ((double) (XINT (obj)));
1986 }
1791 } 1987 }
1792 1988
1793 return LISP_HASH (obj); 1989 return LISP_HASH (obj);
1794 } 1990 }
1795 1991
1796 DEFUN ("sxhash", Fsxhash, 1, 1, 0, /* 1992 DEFUN ("eq-hash", Feq_hash, 1, 1, 0, /*
1797 Return a hash value for OBJECT. 1993 Return a hash value for OBJECT appropriate for use with `eq.'
1798 \(equal obj1 obj2) implies (= (sxhash obj1) (sxhash obj2)).
1799 */ 1994 */
1800 (object)) 1995 (object))
1801 { 1996 {
1802 return make_int (internal_hash (object, 0)); 1997 return make_integer (XPNTRVAL (object));
1803 } 1998 }
1804 1999
1805 #if 0 2000 DEFUN ("eql-hash", Feql_hash, 1, 1, 0, /*
1806 DEFUN ("internal-hash-value", Finternal_hash_value, 1, 1, 0, /* 2001 Return a hash value for OBJECT appropriate for use with `eql.'
1807 Hash value of OBJECT. For debugging.
1808 The value is returned as (HIGH . LOW).
1809 */ 2002 */
1810 (object)) 2003 (object))
1811 { 2004 {
1812 /* This function is pretty 32bit-centric. */ 2005 EMACS_INT hashed = lisp_object_eql_hash (NULL, object);
1813 Hashcode hash = internal_hash (object, 0); 2006 return make_integer (hashed);
1814 return Fcons (hash >> 16, hash & 0xffff); 2007 }
1815 } 2008
1816 #endif 2009 DEFUN ("equal-hash", Fequal_hash, 1, 1, 0, /*
1817 2010 Return a hash value for OBJECT appropriate for use with `equal.'
2011 \(equal obj1 obj2) implies (= (equal-hash obj1) (equal-hash obj2)).
2012 */
2013 (object))
2014 {
2015 EMACS_INT hashed = internal_hash (object, 0, 0);
2016 return make_integer (hashed);
2017 }
2018
2019 DEFUN ("equalp-hash", Fequalp_hash, 1, 1, 0, /*
2020 Return a hash value for OBJECT appropriate for use with `equalp.'
2021 */
2022 (object))
2023 {
2024 EMACS_INT hashed = internal_hash (object, 0, 1);
2025 return make_integer (hashed);
2026 }
2027
2028 static Lisp_Object
2029 make_hash_table_test (Lisp_Object name,
2030 hash_table_equal_function_t equal_function,
2031 hash_table_hash_function_t hash_function,
2032 Lisp_Object lisp_equal_function,
2033 Lisp_Object lisp_hash_function)
2034 {
2035 Lisp_Object result = ALLOC_NORMAL_LISP_OBJECT (hash_table_test);
2036 Hash_Table_Test *http = XHASH_TABLE_TEST (result);
2037
2038 http->name = name;
2039 http->equal_function = equal_function;
2040 http->hash_function = hash_function;
2041 http->lisp_equal_function = lisp_equal_function;
2042 http->lisp_hash_function = lisp_hash_function;
2043
2044 return result;
2045 }
2046
2047 Lisp_Object
2048 define_hash_table_test (Lisp_Object name,
2049 hash_table_equal_function_t equal_function,
2050 hash_table_hash_function_t hash_function,
2051 Lisp_Object lisp_equal_function,
2052 Lisp_Object lisp_hash_function)
2053 {
2054 Lisp_Object result = make_hash_table_test (name, equal_function,
2055 hash_function,
2056 lisp_equal_function,
2057 lisp_hash_function);
2058 XWEAK_LIST_LIST (Vhash_table_test_weak_list)
2059 = Fcons (Fcons (name, result),
2060 XWEAK_LIST_LIST (Vhash_table_test_weak_list));
2061
2062 return result;
2063 }
2064
2065 DEFUN ("define-hash-table-test", Fdefine_hash_table_test, 3, 3, 0, /*
2066 Define a new hash table test with name NAME, a symbol.
2067
2068 In a hash table created with NAME as its test, use EQUAL-FUNCTION to compare
2069 keys, and HASH-FUNCTION for computing hash codes of keys.
2070
2071 EQUAL-FUNCTION must be a function taking two arguments and returning non-nil
2072 if both arguments are the same. HASH-FUNCTION must be a function taking one
2073 argument and returning an integer that is the hash code of the argument.
2074
2075 Computation should use the whole value range of the underlying machine long
2076 type. In XEmacs this will necessitate bignums for values above
2077 `most-positive-fixnum' but below (1+ (* most-positive-fixnum 2)) and
2078 analagous values below `most-negative-fixnum'. Relatively poor hashing
2079 performance is guaranteed in a build without bignums.
2080
2081 This function returns t if successful, and errors if NAME
2082 cannot be defined as a hash table test.
2083 */
2084 (name, equal_function, hash_function))
2085 {
2086 Lisp_Object min, max, lookup;
2087
2088 CHECK_SYMBOL (name);
2089
2090 lookup = Fassq (name, XWEAK_LIST_LIST (Vhash_table_test_weak_list));
2091
2092 if (!NILP (lookup))
2093 {
2094 invalid_change ("Cannot redefine existing hash table test", name);
2095 }
2096
2097 min = Ffunction_min_args (equal_function);
2098 max = Ffunction_max_args (equal_function);
2099
2100 if (!((XINT (min) <= 2) && (NILP (max) || 2 <= XINT (max))))
2101 {
2102 signal_wrong_number_of_arguments_error (equal_function, 2);
2103 }
2104
2105 min = Ffunction_min_args (hash_function);
2106 max = Ffunction_max_args (hash_function);
2107
2108 if (!((XINT (min) <= 1) && (NILP (max) || 1 <= XINT (max))))
2109 {
2110 signal_wrong_number_of_arguments_error (hash_function, 1);
2111 }
2112
2113 define_hash_table_test (name, lisp_object_general_equal,
2114 lisp_object_general_hash, equal_function,
2115 hash_function);
2116 return Qt;
2117 }
2118
2119 DEFUN ("valid-hash-table-test-p", Fvalid_hash_table_test_p, 1, 1, 0, /*
2120 Return t if OBJECT names a hash table test, nil otherwise.
2121
2122 A valid hash table test is one of the symbols `eq', `eql', `equal',
2123 `equalp', or some symbol passed as the NAME argument to
2124 `define-hash-table-test'. As a special case, `nil' is regarded as
2125 equivalent to `eql'.
2126 */
2127 (object))
2128 {
2129 Lisp_Object lookup;
2130
2131 if (NILP (object))
2132 {
2133 return Qt;
2134 }
2135
2136 lookup = Fassq (object, XWEAK_LIST_LIST (Vhash_table_test_weak_list));
2137
2138 if (!NILP (lookup))
2139 {
2140 return Qt;
2141 }
2142
2143 return Qnil;
2144 }
2145
2146 DEFUN ("hash-table-test-list", Fhash_table_test_list, 0, 0, 0, /*
2147 Return a list of symbols naming valid hash table tests.
2148 These can be passed as the value of the TEST keyword to `make-hash-table'.
2149 This list does not include nil, regarded as equivalent to `eql' by
2150 `make-hash-table'.
2151 */
2152 ())
2153 {
2154 Lisp_Object result = Qnil;
2155
2156 LIST_LOOP_2 (test, XWEAK_LIST_LIST (Vhash_table_test_weak_list))
2157 {
2158 if (!UNBOUNDP (XCAR (test)))
2159 {
2160 result = Fcons (XCAR (test), result);
2161 }
2162 }
2163
2164 return result;
2165 }
2166
2167 DEFUN ("hash-table-test-equal-function",
2168 Fhash_table_test_equal_function, 1, 1, 0, /*
2169 Return the comparison function used for hash table test TEST.
2170 See `define-hash-table-test' and `make-hash-table'.
2171 */
2172 (test))
2173 {
2174 Lisp_Object lookup;
2175
2176 if (NILP (test))
2177 {
2178 test = Qeql;
2179 }
2180
2181 lookup = Fassq (test, XWEAK_LIST_LIST (Vhash_table_test_weak_list));
2182 if (NILP (lookup))
2183 {
2184 invalid_argument ("Not a defined hash table test", test);
2185 }
2186
2187 return XHASH_TABLE_TEST (XCDR (lookup))->lisp_equal_function;
2188 }
2189
2190 DEFUN ("hash-table-test-hash-function",
2191 Fhash_table_test_hash_function, 1, 1, 0, /*
2192 Return the hash function used for hash table test TEST.
2193 See `define-hash-table-test' and `make-hash-table'.
2194 */
2195 (test))
2196 {
2197 Lisp_Object lookup;
2198
2199 if (NILP (test))
2200 {
2201 test = Qeql;
2202 }
2203
2204 lookup = Fassq (test, XWEAK_LIST_LIST (Vhash_table_test_weak_list));
2205 if (NILP (lookup))
2206 {
2207 invalid_argument ("Not a defined hash table test", test);
2208 }
2209
2210 return XHASH_TABLE_TEST (XCDR (lookup))->lisp_hash_function;
2211 }
1818 2212
1819 /************************************************************************/ 2213 /************************************************************************/
1820 /* initialization */ 2214 /* initialization */
1821 /************************************************************************/ 2215 /************************************************************************/
1822 2216
1844 DEFSUBR (Fhash_table_size); 2238 DEFSUBR (Fhash_table_size);
1845 DEFSUBR (Fhash_table_rehash_size); 2239 DEFSUBR (Fhash_table_rehash_size);
1846 DEFSUBR (Fhash_table_rehash_threshold); 2240 DEFSUBR (Fhash_table_rehash_threshold);
1847 DEFSUBR (Fhash_table_weakness); 2241 DEFSUBR (Fhash_table_weakness);
1848 DEFSUBR (Fhash_table_type); /* obsolete */ 2242 DEFSUBR (Fhash_table_type); /* obsolete */
1849 DEFSUBR (Fsxhash); 2243
1850 #if 0 2244 DEFSUBR (Feq_hash);
1851 DEFSUBR (Finternal_hash_value); 2245 DEFSUBR (Feql_hash);
1852 #endif 2246 DEFSUBR (Fequal_hash);
2247 Ffset (intern ("sxhash"), intern ("equal-hash"));
2248 DEFSUBR (Fequalp_hash);
2249
2250 DEFSUBR (Fdefine_hash_table_test);
2251 DEFSUBR (Fvalid_hash_table_test_p);
2252 DEFSUBR (Fhash_table_test_list);
2253 DEFSUBR (Fhash_table_test_equal_function);
2254 DEFSUBR (Fhash_table_test_hash_function);
1853 2255
1854 DEFSYMBOL_MULTIWORD_PREDICATE (Qhash_tablep); 2256 DEFSYMBOL_MULTIWORD_PREDICATE (Qhash_tablep);
2257
1855 DEFSYMBOL (Qhash_table); 2258 DEFSYMBOL (Qhash_table);
1856 DEFSYMBOL (Qhashtable); 2259 DEFSYMBOL (Qhashtable);
1857 DEFSYMBOL (Qmake_hash_table); 2260 DEFSYMBOL (Qmake_hash_table);
1858 DEFSYMBOL (Qweakness); 2261 DEFSYMBOL (Qweakness);
1859 DEFSYMBOL (Qvalue); 2262 DEFSYMBOL (Qvalue);
1878 } 2281 }
1879 2282
1880 void 2283 void
1881 vars_of_elhash (void) 2284 vars_of_elhash (void)
1882 { 2285 {
2286 Lisp_Object weak_list_list = XWEAK_LIST_LIST (Vhash_table_test_weak_list);
2287
2288 /* This var was staticpro'd and initialised in
2289 init_elhash_once_early, but its Vall_weak_lists isn't sane, since
2290 that was done before vars_of_data() was called. Create a sane
2291 weak list object now, set its list appropriately, assert that our
2292 data haven't been garbage collected. */
2293 assert (!NILP (Fassq (Qeq, weak_list_list)));
2294 assert (!NILP (Fassq (Qeql, weak_list_list)));
2295 assert (!NILP (Fassq (Qequal, weak_list_list)));
2296 assert (!NILP (Fassq (Qequalp, weak_list_list)));
2297 assert (4 == XINT (Flength (weak_list_list)));
2298
2299 Vhash_table_test_weak_list = make_weak_list (WEAK_LIST_KEY_ASSOC);
2300 XWEAK_LIST_LIST (Vhash_table_test_weak_list) = weak_list_list;
2301
1883 #ifdef MEMORY_USAGE_STATS 2302 #ifdef MEMORY_USAGE_STATS
1884 OBJECT_HAS_PROPERTY 2303 OBJECT_HAS_PROPERTY
1885 (hash_table, memusage_stats_list, list1 (intern ("hash-entries"))); 2304 (hash_table, memusage_stats_list, list1 (intern ("hash-entries")));
1886 #endif /* MEMORY_USAGE_STATS */ 2305 #endif /* MEMORY_USAGE_STATS */
1887 } 2306 }
1888 2307
1889 void 2308 void
1890 init_elhash_once_early (void) 2309 init_elhash_once_early (void)
1891 { 2310 {
1892 INIT_LISP_OBJECT (hash_table); 2311 INIT_LISP_OBJECT (hash_table);
2312 INIT_LISP_OBJECT (hash_table_test);
2313
1893 #ifdef NEW_GC 2314 #ifdef NEW_GC
1894 INIT_LISP_OBJECT (hash_table_entry); 2315 INIT_LISP_OBJECT (hash_table_entry);
1895 #endif /* NEW_GC */ 2316 #endif /* NEW_GC */
1896 2317
2318 /* init_elhash_once_early() is called very early, we can't have these
2319 DEFSYMBOLs in syms_of_elhash(), unfortunately. */
2320
2321 DEFSYMBOL (Qeq);
2322 DEFSYMBOL (Qeql);
2323 DEFSYMBOL (Qequal);
2324 DEFSYMBOL (Qequalp);
2325
2326 DEFSYMBOL (Qeq_hash);
2327 DEFSYMBOL (Qeql_hash);
2328 DEFSYMBOL (Qequal_hash);
2329 DEFSYMBOL (Qequalp_hash);
2330
1897 /* This must NOT be staticpro'd */ 2331 /* This must NOT be staticpro'd */
1898 Vall_weak_hash_tables = Qnil; 2332 Vall_weak_hash_tables = Qnil;
1899 dump_add_weak_object_chain (&Vall_weak_hash_tables); 2333 dump_add_weak_object_chain (&Vall_weak_hash_tables);
1900 } 2334
2335 staticpro (&Vhash_table_test_weak_list);
2336 Vhash_table_test_weak_list = make_weak_list (WEAK_LIST_KEY_ASSOC);
2337
2338 staticpro (&Vhash_table_test_eq);
2339 Vhash_table_test_eq = define_hash_table_test (Qeq, NULL, NULL, Qeq, Qeq_hash);
2340 staticpro (&Vhash_table_test_eql);
2341 Vhash_table_test_eql
2342 = define_hash_table_test (Qeql, lisp_object_eql_equal,
2343 lisp_object_eql_hash, Qeql, Qeql_hash);
2344 (void) define_hash_table_test (Qequal, lisp_object_equal_equal,
2345 lisp_object_equal_hash, Qequal, Qequal_hash);
2346 (void) define_hash_table_test (Qequalp, lisp_object_equalp_equal,
2347 lisp_object_equalp_hash, Qequalp, Qequalp_hash);
2348 }