Mercurial > hg > xemacs-beta
changeset 5191:71ee43b8a74d
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.
line wrap: on
line diff
--- a/man/ChangeLog Mon Apr 05 00:18:49 2010 -0500 +++ b/man/ChangeLog Mon Apr 05 13:03:35 2010 +0100 @@ -1,3 +1,10 @@ +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. + 2010-04-01 Aidan Kehoe <kehoea@parhasard.net> * lispref/lists.texi (Rearrangement):
--- a/man/lispref/hash-tables.texi Mon Apr 05 00:18:49 2010 -0500 +++ b/man/lispref/hash-tables.texi Mon Apr 05 13:03:35 2010 +0100 @@ -78,10 +78,12 @@ @defun make-hash-table &key @code{test} @code{size} @code{rehash-size} @code{rehash-threshold} @code{weakness} This function returns a new empty hash table object. -Keyword @code{:test} can be @code{eq}, @code{eql} (default) or @code{equal}. +Keyword @code{:test} can be @code{eq}, @code{eql} (default), +@code{equal}, or @code{equalp}. Comparison between keys is done using this function. If speed is important, consider using @code{eq}. -When storing strings in the hash table, you will likely need to use @code{equal}. +When storing strings in the hash table, you will likely need to use +@code{equal}, or @code{equalp} for case-insensitivity. Keyword @code{:size} specifies the number of keys likely to be inserted. This number of entries can be inserted without enlarging the hash table. @@ -135,7 +137,8 @@ @defun hash-table-test hash-table This function returns the test function of @var{hash-table}. -This can be one of @code{eq}, @code{eql} or @code{equal}. +This can be one of @code{eq}, @code{eql}, @code{equal}, @code{equalp}, +or some @var{name} parameter given to @code{define-hash-table-test}. @end defun @defun hash-table-size hash-table @@ -191,6 +194,24 @@ processed by @var{function}. @end defun +@defun define-hash-table-test name test-function hash-function +Creates a new hash table test function, beyond the four specified by +Common Lisp. @var{name} is a symbol, and @code{define-hash-table-test} +will error if there exists a hash table test with that name already. +(If you want to repeatedly define hash tables, use a symbol generated +with @code{gensym} for @var{name}). + +@var{test-function} must accept two arguments and return non-nil if both +arguments are the same. + +@var{hash-function} must accept one argument and return an integer hash +code for its argument. @var{hash-function} should use the entire range +of the underlying C long type, typically represented with two more value +bits than the Lisp fixnum type. + +Returns t on success, an incompatibility with GNU Emacs, which returns +a list comprising @var{test-function} and @var{hash-function}. +@end defun @node Weak Hash Tables @section Weak Hash Tables
--- a/src/ChangeLog Mon Apr 05 00:18:49 2010 -0500 +++ b/src/ChangeLog Mon Apr 05 13:03:35 2010 +0100 @@ -80,11 +80,62 @@ with the string resize. Fixes a test hang reported by Vin Shelton; thanks, Vin. +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. + 2010-04-02 Aidan Kehoe <kehoea@parhasard.net> * fns.c (FsortX, Ffill): Don't try to be clever with the ascii_begin string header slot in - these function, just call init_string_ascii_begin(). + these functions, just call init_string_ascii_begin(). 2010-04-02 Aidan Kehoe <kehoea@parhasard.net>
--- a/src/alloc.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/alloc.c Mon Apr 05 13:03:35 2010 +0100 @@ -1691,12 +1691,12 @@ } static Hashcode -vector_hash (Lisp_Object obj, int depth) +vector_hash (Lisp_Object obj, int depth, Boolint equalp) { return HASH2 (XVECTOR_LENGTH (obj), internal_array_hash (XVECTOR_DATA (obj), XVECTOR_LENGTH (obj), - depth + 1)); + depth + 1, equalp)); } static const struct memory_description vector_description[] = {
--- a/src/buffer.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/buffer.c Mon Apr 05 13:03:35 2010 +0100 @@ -640,7 +640,7 @@ b->generated_modeline_string = Fmake_string (make_int (84), make_int (' ')); b->modeline_extent_table = make_lisp_hash_table (20, HASH_TABLE_KEY_WEAK, - HASH_TABLE_EQ); + Qeq); return buf;
--- a/src/bytecode.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/bytecode.c Mon Apr 05 13:03:35 2010 +0100 @@ -2348,14 +2348,14 @@ } static Hashcode -compiled_function_hash (Lisp_Object obj, int depth) +compiled_function_hash (Lisp_Object obj, int depth, Boolint UNUSED (equalp)) { Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj); return HASH3 ((f->flags.documentationp << 2) + (f->flags.interactivep << 1) + f->flags.domainp, - internal_hash (f->instructions, depth + 1), - internal_hash (f->constants, depth + 1)); + internal_hash (f->instructions, depth + 1, 0), + internal_hash (f->constants, depth + 1, 0)); } static const struct memory_description compiled_function_description[] = {
--- a/src/chartab.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/chartab.c Mon Apr 05 13:03:35 2010 +0100 @@ -128,11 +128,11 @@ } static Hashcode -char_table_entry_hash (Lisp_Object obj, int depth) +char_table_entry_hash (Lisp_Object obj, int depth, Boolint equalp) { Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj); - return internal_array_hash (cte->level2, 96, depth + 1); + return internal_array_hash (cte->level2, 96, depth + 1, equalp); } static const struct memory_description char_table_entry_description[] = { @@ -369,17 +369,17 @@ } static Hashcode -char_table_hash (Lisp_Object obj, int depth) +char_table_hash (Lisp_Object obj, int depth, Boolint equalp) { Lisp_Char_Table *ct = XCHAR_TABLE (obj); Hashcode hashval = internal_array_hash (ct->ascii, NUM_ASCII_CHARS, - depth + 1); + depth + 1, equalp); #ifdef MULE hashval = HASH2 (hashval, internal_array_hash (ct->level1, NUM_LEADING_BYTES, - depth + 1)); + depth + 1, equalp)); #endif /* MULE */ - return HASH2 (hashval, internal_hash (ct->default_, depth + 1)); + return HASH2 (hashval, internal_hash (ct->default_, depth + 1, equalp)); } static const struct memory_description char_table_description[] = {
--- a/src/console-gtk.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/console-gtk.c Mon Apr 05 13:03:35 2010 +0100 @@ -160,7 +160,7 @@ if (!(HASH_TABLEP(Vgtk_seen_characters))) { Vgtk_seen_characters = make_lisp_hash_table (128, HASH_TABLE_NON_WEAK, - HASH_TABLE_EQUAL); + Qequal); } /* Might give the user an opaque error if make_lisp_hash_table fails,
--- a/src/console-impl.h Mon Apr 05 00:18:49 2010 -0500 +++ b/src/console-impl.h Mon Apr 05 13:03:35 2010 +0100 @@ -193,7 +193,7 @@ Lisp_Color_Instance *, int depth); Hashcode (*color_instance_hash_method) (Lisp_Color_Instance *, - int depth); + int depth); Lisp_Object (*color_instance_rgb_components_method) (Lisp_Color_Instance *); int (*valid_color_name_p_method) (struct device *, Lisp_Object color); Lisp_Object (*color_list_method) (void);
--- a/src/console-msw.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/console-msw.c Mon Apr 05 13:03:35 2010 +0100 @@ -212,7 +212,7 @@ can use eq as the test without worrying. */ Vmswindows_seen_characters = make_lisp_hash_table (128, HASH_TABLE_NON_WEAK, - HASH_TABLE_EQ); + Qeq); } /* Might give the user an opaque error if make_lisp_hash_table fails, but it shouldn't crash. */
--- a/src/console-tty.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/console-tty.c Mon Apr 05 13:03:35 2010 +0100 @@ -428,7 +428,7 @@ /* All the keysyms we deal with are character objects; therefore, we can use eq as the test without worrying. */ Vtty_seen_characters = make_lisp_hash_table (128, HASH_TABLE_NON_WEAK, - HASH_TABLE_EQ); + Qeq); } /* Might give the user an opaque error if make_lisp_hash_table fails,
--- a/src/data.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/data.c Mon Apr 05 13:03:35 2010 +0100 @@ -2633,12 +2633,12 @@ } static Hashcode -weak_list_hash (Lisp_Object obj, int depth) +weak_list_hash (Lisp_Object obj, int depth, Boolint equalp) { struct weak_list *w = XWEAK_LIST (obj); return HASH2 ((Hashcode) w->type, - internal_hash (w->list, depth + 1)); + internal_hash (w->list, depth + 1, equalp)); } Lisp_Object @@ -3105,11 +3105,11 @@ } static Hashcode -weak_box_hash (Lisp_Object obj, int depth) +weak_box_hash (Lisp_Object obj, int depth, Boolint equalp) { struct weak_box *wb = XWEAK_BOX (obj); - return internal_hash (wb->value, depth + 1); + return internal_hash (wb->value, depth + 1, equalp); } Lisp_Object @@ -3326,9 +3326,9 @@ } static Hashcode -ephemeron_hash(Lisp_Object obj, int depth) +ephemeron_hash(Lisp_Object obj, int depth, Boolint equalp) { - return internal_hash (XEPHEMERON_REF (obj), depth + 1); + return internal_hash (XEPHEMERON_REF (obj), depth + 1, equalp); } Lisp_Object
--- a/src/device.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/device.c Mon Apr 05 13:03:35 2010 +0100 @@ -222,9 +222,9 @@ /* #### is 20 reasonable? */ d->color_instance_cache = - make_lisp_hash_table (20, HASH_TABLE_KEY_WEAK, HASH_TABLE_EQUAL); + make_lisp_hash_table (20, HASH_TABLE_KEY_WEAK, Qequal); d->font_instance_cache = - make_lisp_hash_table (20, HASH_TABLE_KEY_WEAK, HASH_TABLE_EQUAL); + make_lisp_hash_table (20, HASH_TABLE_KEY_WEAK, Qequal); #ifdef MULE initialize_charset_font_caches (d); #endif @@ -234,7 +234,7 @@ time there aren't very many different masks that will be used. */ d->image_instance_cache = - make_lisp_hash_table (5, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); + make_lisp_hash_table (5, HASH_TABLE_NON_WEAK, Qeq); UNGCPRO; return d;
--- a/src/dired.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/dired.c Mon Apr 05 13:03:35 2010 +0100 @@ -784,7 +784,7 @@ { DIRENTRY *dp; Lisp_Object hash = - make_lisp_hash_table (20, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL); + make_lisp_hash_table (20, HASH_TABLE_NON_WEAK, Qeq); while ((dp = qxe_readdir (d))) {
--- a/src/elhash.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/elhash.c Mon Apr 05 13:03:35 2010 +0100 @@ -83,18 +83,69 @@ #include "elhash.h" #include "gc.h" #include "opaque.h" +#include "buffer.h" Lisp_Object Qhash_tablep; +Lisp_Object Qeq, Qeql, Qequal, Qequalp; +Lisp_Object Qeq_hash, Qeql_hash, Qequal_hash, Qequalp_hash; + static Lisp_Object Qhashtable, Qhash_table, Qmake_hash_table; static Lisp_Object Qweakness, Qvalue, Qkey_or_value, Qkey_and_value; static Lisp_Object Vall_weak_hash_tables; static Lisp_Object Qrehash_size, Qrehash_threshold; static Lisp_Object Q_size, Q_test, Q_weakness, Q_rehash_size, Q_rehash_threshold; +static Lisp_Object Vhash_table_test_eq, Vhash_table_test_eql; +static Lisp_Object Vhash_table_test_weak_list; /* obsolete as of 19990901 in xemacs-21.2 */ static Lisp_Object Qweak, Qkey_weak, Qvalue_weak, Qkey_or_value_weak; static Lisp_Object Qnon_weak, Q_type, Q_data; +/* A hash table test, with its associated hash function. equal_function may + call lisp_equal_function, and hash_function similarly may call + lisp_hash_function. */ +struct Hash_Table_Test +{ + NORMAL_LISP_OBJECT_HEADER header; + Lisp_Object name; + hash_table_equal_function_t equal_function; + hash_table_hash_function_t hash_function; + Lisp_Object lisp_equal_function; + Lisp_Object lisp_hash_function; +}; + +static Lisp_Object +mark_hash_table_test (Lisp_Object obj) +{ + Hash_Table_Test *http = XHASH_TABLE_TEST (obj); + + mark_object (http->name); + mark_object (http->lisp_equal_function); + mark_object (http->lisp_hash_function); + + return Qnil; +} + +static const struct memory_description hash_table_test_description_1[] = + { + { XD_LISP_OBJECT, offsetof (struct Hash_Table_Test, name) }, + { XD_LISP_OBJECT, offsetof (struct Hash_Table_Test, lisp_equal_function) }, + { XD_LISP_OBJECT, offsetof (struct Hash_Table_Test, lisp_hash_function) }, + { XD_END } + }; + +static const struct sized_memory_description hash_table_test_description = + { + sizeof (struct Hash_Table_Test), + hash_table_test_description_1 + }; + +DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("hash-table-test", hash_table_test, + mark_hash_table_test, + hash_table_test_description_1, + Hash_Table_Test); +/* A hash table. */ + struct Lisp_Hash_Table { NORMAL_LISP_OBJECT_HEADER header; @@ -104,9 +155,8 @@ double rehash_size; double rehash_threshold; Elemcount golden_ratio; - hash_table_hash_function_t hash_function; - hash_table_test_function_t test_function; htentry *hentries; + Lisp_Object test; enum hash_table_weakness weakness; Lisp_Object next_weak; /* Used to chain together all of the weak hash tables. Don't mark through this. */ @@ -119,16 +169,17 @@ #define HASH_TABLE_DEFAULT_SIZE 16 #define HASH_TABLE_DEFAULT_REHASH_SIZE 1.3 #define HASH_TABLE_MIN_SIZE 10 -#define HASH_TABLE_DEFAULT_REHASH_THRESHOLD(size, test_function) \ - (((size) > 4096 && NULL == (test_function)) ? 0.7 : 0.6) +#define HASH_TABLE_DEFAULT_REHASH_THRESHOLD(size, test) \ + (((size) > 4096 && EQ (Vhash_table_test_eq, test)) ? 0.7 : 0.6) -#define HASHCODE(key, ht) \ - ((((ht)->hash_function ? (ht)->hash_function (key) : LISP_HASH (key)) \ - * (ht)->golden_ratio) \ - % (ht)->size) +#define HASHCODE(key, ht, http) \ + ((((!EQ (Vhash_table_test_eq, ht->test)) ? \ + (http)->hash_function (http, key) : \ + LISP_HASH (key)) * (ht)->golden_ratio) % (ht)->size) -#define KEYS_EQUAL_P(key1, key2, testfun) \ - (EQ (key1, key2) || ((testfun) && (testfun) (key1, key2))) +#define KEYS_EQUAL_P(key1, key2, test, http) \ + (EQ (key1, key2) || ((!EQ (Vhash_table_test_eq, test) && \ + (http->equal_function) (http, key1, key2)))) #define LINEAR_PROBING_LOOP(probe, entries, size) \ for (; \ @@ -187,28 +238,92 @@ static int -lisp_object_eql_equal (Lisp_Object obj1, Lisp_Object obj2) +lisp_object_eql_equal (const Hash_Table_Test *UNUSED (http), Lisp_Object obj1, + Lisp_Object obj2) { return EQ (obj1, obj2) || (NON_FIXNUM_NUMBER_P (obj1) && internal_equal (obj1, obj2, 0)); } static Hashcode -lisp_object_eql_hash (Lisp_Object obj) +lisp_object_eql_hash (const Hash_Table_Test *UNUSED (http), Lisp_Object obj) { - return NON_FIXNUM_NUMBER_P (obj) ? internal_hash (obj, 0) : LISP_HASH (obj); + return NON_FIXNUM_NUMBER_P (obj) ? + internal_hash (obj, 0, 0) : LISP_HASH (obj); } static int -lisp_object_equal_equal (Lisp_Object obj1, Lisp_Object obj2) +lisp_object_equal_equal (const Hash_Table_Test *UNUSED (http), + Lisp_Object obj1, Lisp_Object obj2) { return internal_equal (obj1, obj2, 0); } static Hashcode -lisp_object_equal_hash (Lisp_Object obj) +lisp_object_equal_hash (const Hash_Table_Test *UNUSED (http), Lisp_Object obj) +{ + return internal_hash (obj, 0, 0); +} + +static Hashcode +lisp_object_equalp_hash (const Hash_Table_Test *UNUSED (http), Lisp_Object obj) +{ + return internal_hash (obj, 0, 1); +} + +static int +lisp_object_equalp_equal (const Hash_Table_Test *UNUSED (http), + Lisp_Object obj1, Lisp_Object obj2) +{ + return internal_equalp (obj1, obj2, 0); +} + +static Hashcode +lisp_object_general_hash (const Hash_Table_Test *http, Lisp_Object obj) { - return internal_hash (obj, 0); + struct gcpro gcpro1; + Lisp_Object args[2] = { http->lisp_hash_function, obj }, res; + + /* Make sure any weakly referenced objects don't get collected before the + funcall: */ + GCPRO1 (args[0]); + gcpro1.nvars = countof (args); + res = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)); + UNGCPRO; + + if (INTP (res)) + { + return (Hashcode) (XINT (res)); + } + +#ifdef HAVE_BIGNUM + if (BIGNUMP (res)) + { + if (bignum_fits_emacs_int_p (XBIGNUM_DATA (res))) + { + return (Hashcode) bignum_to_emacs_int (XBIGNUM_DATA (res)); + } + + signal_error (Qrange_error, "Not a valid hash code", res); + } +#endif + + dead_wrong_type_argument (Qintegerp, res); +} + +static int +lisp_object_general_equal (const Hash_Table_Test *http, Lisp_Object obj1, + Lisp_Object obj2) +{ + struct gcpro gcpro1; + Lisp_Object args[] = { http->lisp_equal_function, obj1, obj2 }, res; + + GCPRO1 (args[0]); + gcpro1.nvars = countof (args); + res = IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)); + UNGCPRO; + + return !(NILP (res)); } @@ -231,6 +346,9 @@ mark_object (e->value); } } + + mark_object (ht->test); + return Qnil; } @@ -252,8 +370,8 @@ Lisp_Hash_Table *ht2 = XHASH_TABLE (hash_table2); htentry *e, *sentinel; - if ((ht1->test_function != ht2->test_function) || - (ht1->weakness != ht2->weakness) || + if (!(EQ (ht1->test, ht2->test)) || + (ht1->weakness != ht2->weakness) || (ht1->count != ht2->count)) return 0; @@ -276,7 +394,8 @@ Examining all entries is too expensive, and examining a random subset does not yield a correct hash function. */ static Hashcode -hash_table_hash (Lisp_Object hash_table, int UNUSED (depth)) +hash_table_hash (Lisp_Object hash_table, int UNUSED (depth), + int UNUSED (equalp)) { return XHASH_TABLE (hash_table)->count; } @@ -366,17 +485,11 @@ write_ascstring (printcharfun, print_readably ? "#s(hash-table" : "#<hash-table"); - /* These checks have a kludgy look to them, but they are safe. - Due to nature of hashing, you cannot use arbitrary - test functions anyway. */ - if (!ht->test_function) - write_ascstring (printcharfun, " :test eq"); - else if (ht->test_function == lisp_object_equal_equal) - write_ascstring (printcharfun, " :test equal"); - else if (ht->test_function == lisp_object_eql_equal) - DO_NOTHING; - else - ABORT (); + if (!(EQ (ht->test, Vhash_table_test_eql))) + { + write_fmt_string_lisp (printcharfun, " :test %S", + 1, XHASH_TABLE_TEST (ht->test)->name); + } if (ht->count || !print_readably) { @@ -405,8 +518,7 @@ } if (ht->rehash_threshold - != HASH_TABLE_DEFAULT_REHASH_THRESHOLD (ht->size, - ht->test_function)) + != HASH_TABLE_DEFAULT_REHASH_THRESHOLD (ht->size, ht->test)) { float_to_string (pigbuf, ht->rehash_threshold); write_fmt_string (printcharfun, " :rehash-threshold %s", pigbuf); @@ -507,6 +619,7 @@ { XD_UNION, offsetof (Lisp_Hash_Table, hentries), XD_INDIRECT (1, 0), { &htentry_union_description } }, { XD_LO_LINK, offsetof (Lisp_Hash_Table, next_weak) }, + { XD_LISP_OBJECT,offsetof (Lisp_Hash_Table, test) }, { XD_END } }; @@ -553,45 +666,10 @@ #endif /* not NEW_GC */ } -Lisp_Object -make_standard_lisp_hash_table (enum hash_table_test test, - Elemcount size, - double rehash_size, - double rehash_threshold, - enum hash_table_weakness weakness) -{ - hash_table_hash_function_t hash_function = 0; - hash_table_test_function_t test_function = 0; - - switch (test) - { - case HASH_TABLE_EQ: - test_function = 0; - hash_function = 0; - break; - - case HASH_TABLE_EQL: - test_function = lisp_object_eql_equal; - hash_function = lisp_object_eql_hash; - break; - - case HASH_TABLE_EQUAL: - test_function = lisp_object_equal_equal; - hash_function = lisp_object_equal_hash; - break; - - default: - ABORT (); - } - - return make_general_lisp_hash_table (hash_function, test_function, - size, rehash_size, rehash_threshold, - weakness); -} +static Lisp_Object decode_hash_table_test (Lisp_Object obj); Lisp_Object -make_general_lisp_hash_table (hash_table_hash_function_t hash_function, - hash_table_test_function_t test_function, +make_general_lisp_hash_table (Lisp_Object test, Elemcount size, double rehash_size, double rehash_threshold, @@ -600,8 +678,9 @@ Lisp_Object hash_table = ALLOC_NORMAL_LISP_OBJECT (hash_table); Lisp_Hash_Table *ht = XHASH_TABLE (hash_table); - ht->test_function = test_function; - ht->hash_function = hash_function; + assert (HASH_TABLE_TESTP (test)); + + ht->test = test; ht->weakness = weakness; ht->rehash_size = @@ -609,7 +688,7 @@ ht->rehash_threshold = rehash_threshold > 0.0 ? rehash_threshold : - HASH_TABLE_DEFAULT_REHASH_THRESHOLD (size, ht->test_function); + HASH_TABLE_DEFAULT_REHASH_THRESHOLD (size, ht->test); if (size < HASH_TABLE_MIN_SIZE) size = HASH_TABLE_MIN_SIZE; @@ -631,11 +710,11 @@ } Lisp_Object -make_lisp_hash_table (Elemcount size, - enum hash_table_weakness weakness, - enum hash_table_test test) +make_lisp_hash_table (Elemcount size, enum hash_table_weakness weakness, + Lisp_Object test) { - return make_standard_lisp_hash_table (test, size, -1.0, -1.0, weakness); + test = decode_hash_table_test (test); + return make_general_lisp_hash_table (test, size, -1.0, -1.0, weakness); } /* Pretty reading of hash tables. @@ -678,12 +757,14 @@ if (EQ (value, Qkey_or_value)) return 1; if (EQ (value, Qvalue)) return 1; +#ifndef NO_NEED_TO_HANDLE_21_4_CODE /* Following values are obsolete as of 19990901 in xemacs-21.2 */ if (EQ (value, Qnon_weak)) return 1; if (EQ (value, Qweak)) return 1; if (EQ (value, Qkey_weak)) return 1; if (EQ (value, Qkey_or_value_weak)) return 1; if (EQ (value, Qvalue_weak)) return 1; +#endif maybe_invalid_constant ("Invalid hash table weakness", value, Qhash_table, errb); @@ -700,12 +781,14 @@ if (EQ (obj, Qkey_or_value)) return HASH_TABLE_KEY_VALUE_WEAK; if (EQ (obj, Qvalue)) return HASH_TABLE_VALUE_WEAK; +#ifndef NO_NEED_TO_HANDLE_21_4_CODE /* Following values are obsolete as of 19990901 in xemacs-21.2 */ if (EQ (obj, Qnon_weak)) return HASH_TABLE_NON_WEAK; if (EQ (obj, Qweak)) return HASH_TABLE_WEAK; if (EQ (obj, Qkey_weak)) return HASH_TABLE_KEY_WEAK; if (EQ (obj, Qkey_or_value_weak)) return HASH_TABLE_KEY_VALUE_WEAK; if (EQ (obj, Qvalue_weak)) return HASH_TABLE_VALUE_WEAK; +#endif invalid_constant ("Invalid hash table weakness", obj); RETURN_NOT_REACHED (HASH_TABLE_NON_WEAK); @@ -715,26 +798,40 @@ hash_table_test_validate (Lisp_Object UNUSED (keyword), Lisp_Object value, Error_Behavior errb) { - if (EQ (value, Qnil)) return 1; - if (EQ (value, Qeq)) return 1; - if (EQ (value, Qequal)) return 1; - if (EQ (value, Qeql)) return 1; + Lisp_Object lookup; + + if (NILP (value)) + { + return 1; + } - maybe_invalid_constant ("Invalid hash table test", - value, Qhash_table, errb); - return 0; + lookup = Fassq (value, XWEAK_LIST_LIST (Vhash_table_test_weak_list)); + if (NILP (lookup)) + { + maybe_invalid_constant ("Invalid hash table test", + value, Qhash_table, errb); + } + + return 1; } -static enum hash_table_test +static Lisp_Object decode_hash_table_test (Lisp_Object obj) { - if (EQ (obj, Qnil)) return HASH_TABLE_EQL; - if (EQ (obj, Qeq)) return HASH_TABLE_EQ; - if (EQ (obj, Qequal)) return HASH_TABLE_EQUAL; - if (EQ (obj, Qeql)) return HASH_TABLE_EQL; + Lisp_Object result; + + if (NILP (obj)) + { + obj = Qeql; + } - invalid_constant ("Invalid hash table test", obj); - RETURN_NOT_REACHED (HASH_TABLE_EQ); + result = Fassq (obj, XWEAK_LIST_LIST (Vhash_table_test_weak_list)); + if (NILP (result)) + { + invalid_constant ("Invalid hash table test", obj); + } + + return XCDR (result); } static int @@ -865,7 +962,9 @@ else if (EQ (key, Qrehash_threshold)) rehash_threshold = value; else if (EQ (key, Qweakness)) weakness = value; else if (EQ (key, Qdata)) data = value; +#ifndef NO_NEED_TO_HANDLE_21_4_CODE else if (EQ (key, Qtype))/*obsolete*/ weakness = value; +#endif else if (KEYWORDP (key)) signal_error (Qinvalid_read_syntax, "can't mix keyword and non-keyword hash table syntax", @@ -875,14 +974,14 @@ } /* Create the hash table. */ - hash_table = make_standard_lisp_hash_table + hash_table = make_general_lisp_hash_table (decode_hash_table_test (test), decode_hash_table_size (size), decode_hash_table_rehash_size (rehash_size), decode_hash_table_rehash_threshold (rehash_threshold), decode_hash_table_weakness (weakness)); - /* I'm not sure whether this can GC, but better safe than sorry. */ + /* This can GC with a user-specified test. */ { struct gcpro gcpro1; GCPRO1 (hash_table); @@ -924,8 +1023,10 @@ define_structure_type_keyword (st, Qweakness, hash_table_weakness_validate); define_structure_type_keyword (st, Qdata, hash_table_data_validate); +#ifndef NO_NEED_TO_HANDLE_21_4_CODE /* obsolete as of 19990901 in xemacs-21.2 */ define_structure_type_keyword (st, Qtype, hash_table_weakness_validate); +#endif } /* Create a built-in Lisp structure type named `hash-table'. @@ -956,10 +1057,13 @@ Return a new empty hash table object. Use Common Lisp style keywords to specify hash table properties. -Keyword :test can be `eq', `eql' (default) or `equal'. -Comparison between keys is done using this function. -If speed is important, consider using `eq'. -When storing strings in the hash table, you will likely need to use `equal'. +Keyword :test can be `eq', `eql' (default), `equal' or `equalp'. +Comparison between keys is done using this function. If speed is important, +consider using `eq'. When storing strings in the hash table, you will +likely need to use `equal' or `equalp' (for case-insensitivity). With other +objects, consider using a test function defined with +`define-hash-table-test', an emacs extension to this Common Lisp hash table +API. Keyword :size specifies the number of keys likely to be inserted. This number of entries can be inserted without enlarging the hash table. @@ -1006,7 +1110,7 @@ #ifdef NO_NEED_TO_HANDLE_21_4_CODE PARSE_KEYWORDS (Qmake_hash_table, nargs, args, 0, 5, (test, size, rehash_size, rehash_threshold, weakness), - NULL, weakness = Qunbound), 0); + NULL, 0); #else PARSE_KEYWORDS (Qmake_hash_table, nargs, args, 0, 6, (test, size, rehash_size, rehash_threshold, weakness, @@ -1034,7 +1138,7 @@ VALIDATE_VAR (rehash_threshold); VALIDATE_VAR (weakness); - return make_standard_lisp_hash_table + return make_general_lisp_hash_table (decode_hash_table_test (test), decode_hash_table_size (size), decode_hash_table_rehash_size (rehash_size), @@ -1071,6 +1175,7 @@ { htentry *old_entries, *new_entries, *sentinel, *e; Elemcount old_size; + Hash_Table_Test *http = XHASH_TABLE_TEST (ht->test); old_size = ht->size; ht->size = new_size; @@ -1086,7 +1191,7 @@ for (e = old_entries, sentinel = e + old_size; e < sentinel; e++) if (!HTENTRY_CLEAR_P (e)) { - htentry *probe = new_entries + HASHCODE (e->key, ht); + htentry *probe = new_entries + HASHCODE (e->key, ht, http); LINEAR_PROBING_LOOP (probe, new_entries, new_size) ; *probe = *e; @@ -1107,11 +1212,12 @@ /* We leave room for one never-occupied sentinel htentry at the end. */ htentry *new_entries = allocate_hash_table_entries (ht->size + 1); htentry *e, *sentinel; + Hash_Table_Test *http = XHASH_TABLE_TEST (ht->test); for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++) if (!HTENTRY_CLEAR_P (e)) { - htentry *probe = new_entries + HASHCODE (e->key, ht); + htentry *probe = new_entries + HASHCODE (e->key, ht, http); LINEAR_PROBING_LOOP (probe, new_entries, ht->size) ; *probe = *e; @@ -1135,19 +1241,21 @@ htentry * find_htentry (Lisp_Object key, const Lisp_Hash_Table *ht) { - hash_table_test_function_t test_function = ht->test_function; + Lisp_Object test = ht->test; + Hash_Table_Test *http = XHASH_TABLE_TEST (test); + htentry *entries = ht->hentries; - htentry *probe = entries + HASHCODE (key, ht); + htentry *probe = entries + HASHCODE (key, ht, http); LINEAR_PROBING_LOOP (probe, entries, ht->size) - if (KEYS_EQUAL_P (probe->key, key, test_function)) + if (KEYS_EQUAL_P (probe->key, key, test, http)) break; return probe; } /* A version of Fputhash() that increments the value by the specified - amount and dispenses will all error checks. Assumes that tables does + amount and dispenses with all error checks. Assumes that tables does comparison using EQ. Used by the profiling routines to avoid overhead -- profiling overhead was being recorded at up to 15% of the total time. */ @@ -1156,8 +1264,9 @@ inchash_eq (Lisp_Object key, Lisp_Object table, EMACS_INT offset) { Lisp_Hash_Table *ht = XHASH_TABLE (table); + Hash_Table_Test *http = XHASH_TABLE_TEST (ht->test); htentry *entries = ht->hentries; - htentry *probe = entries + HASHCODE (key, ht); + htentry *probe = entries + HASHCODE (key, ht, http); LINEAR_PROBING_LOOP (probe, entries, ht->size) if (EQ (probe->key, key)) @@ -1213,6 +1322,7 @@ static void remhash_1 (Lisp_Hash_Table *ht, htentry *entries, htentry *probe) { + Hash_Table_Test *http = XHASH_TABLE_TEST (ht->test); Elemcount size = ht->size; CLEAR_HTENTRY (probe); probe++; @@ -1221,7 +1331,7 @@ LINEAR_PROBING_LOOP (probe, entries, size) { Lisp_Object key = probe->key; - htentry *probe2 = entries + HASHCODE (key, ht); + htentry *probe2 = entries + HASHCODE (key, ht, http); LINEAR_PROBING_LOOP (probe2, entries, size) if (EQ (probe2->key, key)) /* htentry at probe doesn't need to move. */ @@ -1279,16 +1389,15 @@ } DEFUN ("hash-table-test", Fhash_table_test, 1, 1, 0, /* -Return the test function of HASH-TABLE. -This can be one of `eq', `eql' or `equal'. +Return HASH-TABLE's test. + +This can be one of `eq', `eql', `equal', `equalp', or some symbol supplied +as the NAME argument to `define-hash-table-test', which see. */ (hash_table)) { - hash_table_test_function_t fun = xhash_table (hash_table)->test_function; - - return (fun == lisp_object_eql_equal ? Qeql : - fun == lisp_object_equal_equal ? Qequal : - Qeq); + CHECK_HASH_TABLE (hash_table); + return XHASH_TABLE_TEST (XHASH_TABLE (hash_table)->test)->name; } DEFUN ("hash-table-size", Fhash_table_size, 1, 1, 0, /* @@ -1711,7 +1820,7 @@ /* Return a hash value for an array of Lisp_Objects of size SIZE. */ Hashcode -internal_array_hash (Lisp_Object *arr, int size, int depth) +internal_array_hash (Lisp_Object *arr, int size, int depth, Boolint equalp) { int i; Hashcode hash = 0; @@ -1720,7 +1829,7 @@ if (size <= 5) { for (i = 0; i < size; i++) - hash = HASH2 (hash, internal_hash (arr[i], depth)); + hash = HASH2 (hash, internal_hash (arr[i], depth, equalp)); return hash; } @@ -1728,11 +1837,78 @@ A slightly better approach would be to offset by some noise factor from the points chosen below. */ for (i = 0; i < 5; i++) - hash = HASH2 (hash, internal_hash (arr[i*size/5], depth)); + hash = HASH2 (hash, internal_hash (arr[i*size/5], depth, equalp)); return hash; } +/* This needs to be algorithmically the same as + internal_array_hash(). Unfortunately, for strings with non-ASCII content, + it has to be O(2N), I don't see a reasonable alternative to hashing + sequence relying on their length. It is O(1) for pure ASCII strings, + though. */ + +static Hashcode +string_equalp_hash (Lisp_Object string) +{ + Bytecount len = XSTRING_LENGTH (string), + ascii_begin = (Bytecount) XSTRING_ASCII_BEGIN (string); + const Ibyte *ptr = XSTRING_DATA (string), *pend = ptr + len; + Charcount clen; + Hashcode hash = 0; + + if (len == ascii_begin) + { + clen = len; + } + else + { + clen = string_char_length (string); + } + + if (clen <= 5) + { + while (ptr < pend) + { + hash = HASH2 (hash, + LISP_HASH (make_char (CANONCASE (NULL, + itext_ichar (ptr))))); + INC_IBYTEPTR (ptr); + } + } + else + { + int ii; + + if (clen == len) + { + for (ii = 0; ii < 5; ii++) + { + hash = HASH2 (hash, + LISP_HASH (make_char + (CANONCASE (NULL, + ptr[ii * clen / 5])))); + } + } + else + { + Charcount this_char = 0, last_char = 0; + for (ii = 0; ii < 5; ii++) + { + this_char = ii * clen / 5; + ptr = itext_n_addr (ptr, this_char - last_char); + last_char = this_char; + + hash = HASH2 (hash, + LISP_HASH (make_char + (CANONCASE (NULL, itext_ichar (ptr))))); + } + } + } + + return HASH2 (clen, hash); +} + /* Return a hash value for a Lisp_Object. This is for use when hashing objects with the comparison being `equal' (for `eq', you can just use the Lisp_Object itself as the hash value). You need to make a @@ -1746,7 +1922,7 @@ hash, but practically this won't ever happen. */ Hashcode -internal_hash (Lisp_Object obj, int depth) +internal_hash (Lisp_Object obj, int depth, Boolint equalp) { if (depth > 5) return 0; @@ -1761,18 +1937,18 @@ if (!CONSP(XCDR(obj))) { /* special case for '(a . b) conses */ - return HASH2(internal_hash(XCAR(obj), depth), - internal_hash(XCDR(obj), depth)); + return HASH2(internal_hash(XCAR(obj), depth, equalp), + internal_hash(XCDR(obj), depth, equalp)); } /* Don't simply tail recurse; we want to hash lists with the same contents in distinct orders differently. */ - hash = internal_hash(XCAR(obj), depth); + hash = internal_hash(XCAR(obj), depth, equalp); obj = XCDR(obj); for (s = 1; s < 6 && CONSP(obj); obj = XCDR(obj), s++) { - h = internal_hash(XCAR(obj), depth); + h = internal_hash(XCAR(obj), depth, equalp); hash = HASH3(hash, h, s); } @@ -1780,6 +1956,11 @@ } if (STRINGP (obj)) { + if (equalp) + { + return string_equalp_hash (obj); + } + return hash_string (XSTRING_DATA (obj), XSTRING_LENGTH (obj)); } if (LRECORDP (obj)) @@ -1787,34 +1968,247 @@ const struct lrecord_implementation *imp = XRECORD_LHEADER_IMPLEMENTATION (obj); if (imp->hash) - return imp->hash (obj, depth); + return imp->hash (obj, depth, equalp); + } + + if (equalp) + { + if (CHARP (obj)) + { + /* Characters and numbers of the same numeric value hash + differently, which is fine, they're not equalp. */ + return LISP_HASH (make_char (CANONCASE (NULL, XCHAR (obj)))); + } + + if (INTP (obj)) + { + return FLOAT_HASHCODE_FROM_DOUBLE ((double) (XINT (obj))); + } } return LISP_HASH (obj); } -DEFUN ("sxhash", Fsxhash, 1, 1, 0, /* -Return a hash value for OBJECT. -\(equal obj1 obj2) implies (= (sxhash obj1) (sxhash obj2)). +DEFUN ("eq-hash", Feq_hash, 1, 1, 0, /* +Return a hash value for OBJECT appropriate for use with `eq.' +*/ + (object)) +{ + return make_integer (XPNTRVAL (object)); +} + +DEFUN ("eql-hash", Feql_hash, 1, 1, 0, /* +Return a hash value for OBJECT appropriate for use with `eql.' +*/ + (object)) +{ + EMACS_INT hashed = lisp_object_eql_hash (NULL, object); + return make_integer (hashed); +} + +DEFUN ("equal-hash", Fequal_hash, 1, 1, 0, /* +Return a hash value for OBJECT appropriate for use with `equal.' +\(equal obj1 obj2) implies (= (equal-hash obj1) (equal-hash obj2)). +*/ + (object)) +{ + EMACS_INT hashed = internal_hash (object, 0, 0); + return make_integer (hashed); +} + +DEFUN ("equalp-hash", Fequalp_hash, 1, 1, 0, /* +Return a hash value for OBJECT appropriate for use with `equalp.' */ (object)) { - return make_int (internal_hash (object, 0)); + EMACS_INT hashed = internal_hash (object, 0, 1); + return make_integer (hashed); +} + +static Lisp_Object +make_hash_table_test (Lisp_Object name, + hash_table_equal_function_t equal_function, + hash_table_hash_function_t hash_function, + Lisp_Object lisp_equal_function, + Lisp_Object lisp_hash_function) +{ + Lisp_Object result = ALLOC_NORMAL_LISP_OBJECT (hash_table_test); + Hash_Table_Test *http = XHASH_TABLE_TEST (result); + + http->name = name; + http->equal_function = equal_function; + http->hash_function = hash_function; + http->lisp_equal_function = lisp_equal_function; + http->lisp_hash_function = lisp_hash_function; + + return result; +} + +Lisp_Object +define_hash_table_test (Lisp_Object name, + hash_table_equal_function_t equal_function, + hash_table_hash_function_t hash_function, + Lisp_Object lisp_equal_function, + Lisp_Object lisp_hash_function) +{ + Lisp_Object result = make_hash_table_test (name, equal_function, + hash_function, + lisp_equal_function, + lisp_hash_function); + XWEAK_LIST_LIST (Vhash_table_test_weak_list) + = Fcons (Fcons (name, result), + XWEAK_LIST_LIST (Vhash_table_test_weak_list)); + + return result; } -#if 0 -DEFUN ("internal-hash-value", Finternal_hash_value, 1, 1, 0, /* -Hash value of OBJECT. For debugging. -The value is returned as (HIGH . LOW). +DEFUN ("define-hash-table-test", Fdefine_hash_table_test, 3, 3, 0, /* +Define a new hash table test with name NAME, a symbol. + +In a hash table created with NAME as its test, use EQUAL-FUNCTION to compare +keys, and HASH-FUNCTION for computing hash codes of keys. + +EQUAL-FUNCTION must be a function taking two arguments and returning non-nil +if both arguments are the same. HASH-FUNCTION must be a function taking one +argument and returning an integer that is the hash code of the argument. + +Computation should use the whole value range of the underlying machine long +type. In XEmacs this will necessitate bignums for values above +`most-positive-fixnum' but below (1+ (* most-positive-fixnum 2)) and +analagous values below `most-negative-fixnum'. Relatively poor hashing +performance is guaranteed in a build without bignums. + +This function returns t if successful, and errors if NAME +cannot be defined as a hash table test. +*/ + (name, equal_function, hash_function)) +{ + Lisp_Object min, max, lookup; + + CHECK_SYMBOL (name); + + lookup = Fassq (name, XWEAK_LIST_LIST (Vhash_table_test_weak_list)); + + if (!NILP (lookup)) + { + invalid_change ("Cannot redefine existing hash table test", name); + } + + min = Ffunction_min_args (equal_function); + max = Ffunction_max_args (equal_function); + + if (!((XINT (min) <= 2) && (NILP (max) || 2 <= XINT (max)))) + { + signal_wrong_number_of_arguments_error (equal_function, 2); + } + + min = Ffunction_min_args (hash_function); + max = Ffunction_max_args (hash_function); + + if (!((XINT (min) <= 1) && (NILP (max) || 1 <= XINT (max)))) + { + signal_wrong_number_of_arguments_error (hash_function, 1); + } + + define_hash_table_test (name, lisp_object_general_equal, + lisp_object_general_hash, equal_function, + hash_function); + return Qt; +} + +DEFUN ("valid-hash-table-test-p", Fvalid_hash_table_test_p, 1, 1, 0, /* +Return t if OBJECT names a hash table test, nil otherwise. + +A valid hash table test is one of the symbols `eq', `eql', `equal', +`equalp', or some symbol passed as the NAME argument to +`define-hash-table-test'. As a special case, `nil' is regarded as +equivalent to `eql'. */ (object)) { - /* This function is pretty 32bit-centric. */ - Hashcode hash = internal_hash (object, 0); - return Fcons (hash >> 16, hash & 0xffff); + Lisp_Object lookup; + + if (NILP (object)) + { + return Qt; + } + + lookup = Fassq (object, XWEAK_LIST_LIST (Vhash_table_test_weak_list)); + + if (!NILP (lookup)) + { + return Qt; + } + + return Qnil; +} + +DEFUN ("hash-table-test-list", Fhash_table_test_list, 0, 0, 0, /* +Return a list of symbols naming valid hash table tests. +These can be passed as the value of the TEST keyword to `make-hash-table'. +This list does not include nil, regarded as equivalent to `eql' by +`make-hash-table'. +*/ + ()) +{ + Lisp_Object result = Qnil; + + LIST_LOOP_2 (test, XWEAK_LIST_LIST (Vhash_table_test_weak_list)) + { + if (!UNBOUNDP (XCAR (test))) + { + result = Fcons (XCAR (test), result); + } + } + + return result; } -#endif + +DEFUN ("hash-table-test-equal-function", + Fhash_table_test_equal_function, 1, 1, 0, /* +Return the comparison function used for hash table test TEST. +See `define-hash-table-test' and `make-hash-table'. +*/ + (test)) +{ + Lisp_Object lookup; + + if (NILP (test)) + { + test = Qeql; + } + + lookup = Fassq (test, XWEAK_LIST_LIST (Vhash_table_test_weak_list)); + if (NILP (lookup)) + { + invalid_argument ("Not a defined hash table test", test); + } + return XHASH_TABLE_TEST (XCDR (lookup))->lisp_equal_function; +} + +DEFUN ("hash-table-test-hash-function", + Fhash_table_test_hash_function, 1, 1, 0, /* +Return the hash function used for hash table test TEST. +See `define-hash-table-test' and `make-hash-table'. +*/ + (test)) +{ + Lisp_Object lookup; + + if (NILP (test)) + { + test = Qeql; + } + + lookup = Fassq (test, XWEAK_LIST_LIST (Vhash_table_test_weak_list)); + if (NILP (lookup)) + { + invalid_argument ("Not a defined hash table test", test); + } + + return XHASH_TABLE_TEST (XCDR (lookup))->lisp_hash_function; +} /************************************************************************/ /* initialization */ @@ -1846,12 +2240,21 @@ DEFSUBR (Fhash_table_rehash_threshold); DEFSUBR (Fhash_table_weakness); DEFSUBR (Fhash_table_type); /* obsolete */ - DEFSUBR (Fsxhash); -#if 0 - DEFSUBR (Finternal_hash_value); -#endif + + DEFSUBR (Feq_hash); + DEFSUBR (Feql_hash); + DEFSUBR (Fequal_hash); + Ffset (intern ("sxhash"), intern ("equal-hash")); + DEFSUBR (Fequalp_hash); + + DEFSUBR (Fdefine_hash_table_test); + DEFSUBR (Fvalid_hash_table_test_p); + DEFSUBR (Fhash_table_test_list); + DEFSUBR (Fhash_table_test_equal_function); + DEFSUBR (Fhash_table_test_hash_function); DEFSYMBOL_MULTIWORD_PREDICATE (Qhash_tablep); + DEFSYMBOL (Qhash_table); DEFSYMBOL (Qhashtable); DEFSYMBOL (Qmake_hash_table); @@ -1880,6 +2283,22 @@ void vars_of_elhash (void) { + Lisp_Object weak_list_list = XWEAK_LIST_LIST (Vhash_table_test_weak_list); + + /* This var was staticpro'd and initialised in + init_elhash_once_early, but its Vall_weak_lists isn't sane, since + that was done before vars_of_data() was called. Create a sane + weak list object now, set its list appropriately, assert that our + data haven't been garbage collected. */ + assert (!NILP (Fassq (Qeq, weak_list_list))); + assert (!NILP (Fassq (Qeql, weak_list_list))); + assert (!NILP (Fassq (Qequal, weak_list_list))); + assert (!NILP (Fassq (Qequalp, weak_list_list))); + assert (4 == XINT (Flength (weak_list_list))); + + Vhash_table_test_weak_list = make_weak_list (WEAK_LIST_KEY_ASSOC); + XWEAK_LIST_LIST (Vhash_table_test_weak_list) = weak_list_list; + #ifdef MEMORY_USAGE_STATS OBJECT_HAS_PROPERTY (hash_table, memusage_stats_list, list1 (intern ("hash-entries"))); @@ -1890,11 +2309,40 @@ init_elhash_once_early (void) { INIT_LISP_OBJECT (hash_table); + INIT_LISP_OBJECT (hash_table_test); + #ifdef NEW_GC INIT_LISP_OBJECT (hash_table_entry); #endif /* NEW_GC */ + /* init_elhash_once_early() is called very early, we can't have these + DEFSYMBOLs in syms_of_elhash(), unfortunately. */ + + DEFSYMBOL (Qeq); + DEFSYMBOL (Qeql); + DEFSYMBOL (Qequal); + DEFSYMBOL (Qequalp); + + DEFSYMBOL (Qeq_hash); + DEFSYMBOL (Qeql_hash); + DEFSYMBOL (Qequal_hash); + DEFSYMBOL (Qequalp_hash); + /* This must NOT be staticpro'd */ Vall_weak_hash_tables = Qnil; dump_add_weak_object_chain (&Vall_weak_hash_tables); + + staticpro (&Vhash_table_test_weak_list); + Vhash_table_test_weak_list = make_weak_list (WEAK_LIST_KEY_ASSOC); + + staticpro (&Vhash_table_test_eq); + Vhash_table_test_eq = define_hash_table_test (Qeq, NULL, NULL, Qeq, Qeq_hash); + staticpro (&Vhash_table_test_eql); + Vhash_table_test_eql + = define_hash_table_test (Qeql, lisp_object_eql_equal, + lisp_object_eql_hash, Qeql, Qeql_hash); + (void) define_hash_table_test (Qequal, lisp_object_equal_equal, + lisp_object_equal_hash, Qequal, Qequal_hash); + (void) define_hash_table_test (Qequalp, lisp_object_equalp_equal, + lisp_object_equalp_hash, Qequalp, Qequalp_hash); }
--- a/src/elhash.h Mon Apr 05 00:18:49 2010 -0500 +++ b/src/elhash.h Mon Apr 05 13:03:35 2010 +0100 @@ -74,7 +74,8 @@ { HASH_TABLE_EQ, HASH_TABLE_EQL, - HASH_TABLE_EQUAL + HASH_TABLE_EQUAL, + HASH_TABLE_EQUALP }; extern const struct memory_description hash_table_description[]; @@ -86,27 +87,34 @@ EXFUN (Fremhash, 2); EXFUN (Fclrhash, 1); -typedef int (*hash_table_test_function_t) (Lisp_Object obj1, Lisp_Object obj2); -typedef Hashcode (*hash_table_hash_function_t) (Lisp_Object obj); +typedef struct Hash_Table_Test Hash_Table_Test; + +DECLARE_LISP_OBJECT (hash_table_test, struct Hash_Table_Test); +#define XHASH_TABLE_TEST(x) XRECORD (x, hash_table_test, struct Hash_Table_Test) +#define wrap_hash_table_test(p) wrap_record (p, hash_table_test) +#define HASH_TABLE_TESTP(x) RECORDP (x, hash_table_test) +#define CHECK_HASH_TABLE_TEST(x) CHECK_RECORD (x, hash_table_test) +#define CONCHECK_HASH_TABLE_TEST(x) CONCHECK_RECORD (x, hash_table_test) + +typedef int (*hash_table_equal_function_t) (const Hash_Table_Test *http, + Lisp_Object obj1, Lisp_Object obj2); +typedef Hashcode (*hash_table_hash_function_t) (const Hash_Table_Test *http, + Lisp_Object obj); typedef int (*maphash_function_t) (Lisp_Object key, Lisp_Object value, void* extra_arg); -Lisp_Object make_standard_lisp_hash_table (enum hash_table_test test, - Elemcount size, - double rehash_size, - double rehash_threshold, - enum hash_table_weakness weakness); - -Lisp_Object make_general_lisp_hash_table (hash_table_hash_function_t hash_function, - hash_table_test_function_t test_function, +/* test here is a Lisp_Object of type hash-table-test. You probably don't + want to call this, unless you have registered your own test. */ +Lisp_Object make_general_lisp_hash_table (Lisp_Object test, Elemcount size, double rehash_size, double rehash_threshold, enum hash_table_weakness weakness); +/* test here is a symbol, e.g. Qeq, Qequal. */ Lisp_Object make_lisp_hash_table (Elemcount size, enum hash_table_weakness weakness, - enum hash_table_test test); + Lisp_Object test); void elisp_maphash (maphash_function_t function, Lisp_Object hash_table, void *extra_arg); @@ -126,4 +134,12 @@ htentry *find_htentry (Lisp_Object key, const Lisp_Hash_Table *ht); +Lisp_Object define_hash_table_test (Lisp_Object name, + hash_table_equal_function_t equal_function, + hash_table_hash_function_t hash_function, + Lisp_Object lisp_equal_function, + Lisp_Object lisp_hash_function); + +void mark_hash_table_tests (void); + #endif /* INCLUDED_elhash_h_ */
--- a/src/event-Xt.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/event-Xt.c Mon Apr 05 13:03:35 2010 +0100 @@ -231,7 +231,7 @@ Fclrhash (hash_table); else xd->x_keysym_map_hash_table = hash_table = - make_lisp_hash_table (128, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL); + make_lisp_hash_table (128, HASH_TABLE_NON_WEAK, Qequal); for (keysym = xd->x_keysym_map, keysyms_per_code = xd->x_keysym_map_keysyms_per_code,
--- a/src/event-gtk.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/event-gtk.c Mon Apr 05 13:03:35 2010 +0100 @@ -1759,7 +1759,7 @@ else { xd->x_keysym_map_hashtable = hashtable = - make_lisp_hash_table (128, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL); + make_lisp_hash_table (128, HASH_TABLE_NON_WEAK, Qequal); } for (keysym = xd->x_keysym_map,
--- a/src/event-stream.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/event-stream.c Mon Apr 05 13:03:35 2010 +0100 @@ -5234,7 +5234,7 @@ inhibit_input_event_recording = 0; Vkeyboard_translate_table = - make_lisp_hash_table (100, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); + make_lisp_hash_table (100, HASH_TABLE_NON_WEAK, Qequal); DEFVAR_BOOL ("try-alternate-layouts-for-commands", &try_alternate_layouts_for_commands /*
--- a/src/events.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/events.c Mon Apr 05 13:03:35 2010 +0100 @@ -433,7 +433,7 @@ } static Hashcode -event_hash (Lisp_Object obj, int depth) +event_hash (Lisp_Object obj, int depth, Boolint UNUSED (equalp)) { Lisp_Event *e = XEVENT (obj); Hashcode hash; @@ -446,8 +446,8 @@ case timeout_event: return HASH3 (hash, - internal_hash (EVENT_TIMEOUT_FUNCTION (e), depth + 1), - internal_hash (EVENT_TIMEOUT_OBJECT (e), depth + 1)); + internal_hash (EVENT_TIMEOUT_FUNCTION (e), depth + 1, 0), + internal_hash (EVENT_TIMEOUT_OBJECT (e), depth + 1, 0)); case key_press_event: return HASH3 (hash, LISP_HASH (EVENT_KEY_KEYSYM (e)), @@ -462,18 +462,18 @@ case misc_user_event: return HASH5 (hash, - internal_hash (EVENT_MISC_USER_FUNCTION (e), depth + 1), - internal_hash (EVENT_MISC_USER_OBJECT (e), depth + 1), + internal_hash (EVENT_MISC_USER_FUNCTION (e), depth + 1, 0), + internal_hash (EVENT_MISC_USER_OBJECT (e), depth + 1, 0), EVENT_MISC_USER_BUTTON (e), EVENT_MISC_USER_MODIFIERS (e)); case eval_event: - return HASH3 (hash, internal_hash (EVENT_EVAL_FUNCTION (e), depth + 1), - internal_hash (EVENT_EVAL_OBJECT (e), depth + 1)); + return HASH3 (hash, internal_hash (EVENT_EVAL_FUNCTION (e), depth + 1, 0), + internal_hash (EVENT_EVAL_OBJECT (e), depth + 1, 0)); case magic_eval_event: return HASH3 (hash, (Hashcode) EVENT_MAGIC_EVAL_INTERNAL_FUNCTION (e), - internal_hash (EVENT_MAGIC_EVAL_OBJECT (e), depth + 1)); + internal_hash (EVENT_MAGIC_EVAL_OBJECT (e), depth + 1, 0)); case magic_event: return HASH2 (hash, event_stream_hash_magic_event (e));
--- a/src/extents.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/extents.c Mon Apr 05 13:03:35 2010 +0100 @@ -3004,13 +3004,13 @@ } static Hashcode -extent_hash (Lisp_Object obj, int depth) +extent_hash (Lisp_Object obj, int depth, Boolint UNUSED (equalp)) { struct extent *e = XEXTENT (obj); /* No need to hash all of the elements; that would take too long. Just hash the most common ones. */ return HASH3 (extent_start (e), extent_end (e), - internal_hash (extent_object (e), depth + 1)); + internal_hash (extent_object (e), depth + 1, 0)); } static const struct memory_description extent_description[] = { @@ -7200,10 +7200,10 @@ to do `eq' comparison because the lists of faces are already memoized. */ Vextent_face_memoize_hash_table = - make_lisp_hash_table (100, HASH_TABLE_VALUE_WEAK, HASH_TABLE_EQUAL); + make_lisp_hash_table (100, HASH_TABLE_VALUE_WEAK, Qequal); staticpro (&Vextent_face_reverse_memoize_hash_table); Vextent_face_reverse_memoize_hash_table = - make_lisp_hash_table (100, HASH_TABLE_KEY_WEAK, HASH_TABLE_EQ); + make_lisp_hash_table (100, HASH_TABLE_KEY_WEAK, Qeq); QSin_map_extents_internal = build_defer_string ("(in map-extents-internal)"); staticpro (&QSin_map_extents_internal);
--- a/src/faces.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/faces.c Mon Apr 05 13:03:35 2010 +0100 @@ -178,7 +178,7 @@ } static Hashcode -face_hash (Lisp_Object obj, int depth) +face_hash (Lisp_Object obj, int depth, Boolint UNUSED (equalp)) { Lisp_Face *f = XFACE (obj); @@ -186,9 +186,9 @@ /* No need to hash all of the elements; that would take too long. Just hash the most common ones. */ - return HASH3 (internal_hash (f->foreground, depth), - internal_hash (f->background, depth), - internal_hash (f->font, depth)); + return HASH3 (internal_hash (f->foreground, depth, 0), + internal_hash (f->background, depth, 0), + internal_hash (f->font, depth, 0)); } static Lisp_Object @@ -2187,10 +2187,10 @@ { staticpro (&Vpermanent_faces_cache); Vpermanent_faces_cache = - make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); + make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, Qeq); staticpro (&Vtemporary_faces_cache); Vtemporary_faces_cache = - make_lisp_hash_table (0, HASH_TABLE_WEAK, HASH_TABLE_EQ); + make_lisp_hash_table (0, HASH_TABLE_WEAK, Qeq); staticpro (&Vdefault_face); Vdefault_face = Qnil;
--- a/src/file-coding.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/file-coding.c Mon Apr 05 13:03:35 2010 +0100 @@ -4605,7 +4605,7 @@ staticpro (&Vcoding_system_hash_table); Vcoding_system_hash_table = - make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); + make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, Qeq); the_coding_system_type_entry_dynarr = Dynarr_new (coding_system_type_entry); dump_add_root_block_ptr (&the_coding_system_type_entry_dynarr, @@ -4792,7 +4792,7 @@ enable_multibyte_characters = 1; Vchain_canonicalize_hash_table = - make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL); + make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, Qequal); staticpro (&Vchain_canonicalize_hash_table); #ifdef DEBUG_XEMACS @@ -4805,7 +4805,7 @@ #ifdef MULE Vdefault_query_coding_region_chartab_cache - = make_lisp_hash_table (25, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL); + = make_lisp_hash_table (25, HASH_TABLE_NON_WEAK, Qequal); staticpro (&Vdefault_query_coding_region_chartab_cache); #endif }
--- a/src/floatfns.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/floatfns.c Mon Apr 05 13:03:35 2010 +0100 @@ -183,11 +183,9 @@ } static Hashcode -float_hash (Lisp_Object obj, int UNUSED (depth)) +float_hash (Lisp_Object obj, int UNUSED (depth), Boolint UNUSED (equalp)) { - /* mod the value down to 32-bit range */ - /* #### change for 64-bit machines */ - return (unsigned long) fmod (extract_float (obj), 4e9); + return FLOAT_HASHCODE_FROM_DOUBLE (extract_float (obj)); } static const struct memory_description float_description[] = {
--- a/src/fns.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/fns.c Mon Apr 05 13:03:35 2010 +0100 @@ -108,10 +108,49 @@ sizeof (long))); } +/* This needs to be algorithmically identical to internal_array_hash in + elhash.c when equalp is one, so arrays and bit vectors with the same + contents hash the same. It would be possible to enforce this by giving + internal_ARRAYLIKE_hash its own file and including it twice, but right + now that doesn't seem worth it. */ static Hashcode -bit_vector_hash (Lisp_Object obj, int UNUSED (depth)) +internal_bit_vector_equalp_hash (Lisp_Bit_Vector *v) +{ + int ii, size = bit_vector_length (v); + Hashcode hash = 0; + + if (size <= 5) + { + for (ii = 0; ii < size; ii++) + { + hash = HASH2 + (hash, + FLOAT_HASHCODE_FROM_DOUBLE ((double) (bit_vector_bit (v, ii)))); + } + return hash; + } + + /* just pick five elements scattered throughout the array. + A slightly better approach would be to offset by some + noise factor from the points chosen below. */ + for (ii = 0; ii < 5; ii++) + hash = HASH2 (hash, + FLOAT_HASHCODE_FROM_DOUBLE + ((double) (bit_vector_bit (v, ii * size / 5)))); + + return hash; +} + +static Hashcode +bit_vector_hash (Lisp_Object obj, int UNUSED (depth), Boolint equalp) { Lisp_Bit_Vector *v = XBIT_VECTOR (obj); + if (equalp) + { + return HASH2 (bit_vector_length (v), + internal_bit_vector_equalp_hash (v)); + } + return HASH2 (bit_vector_length (v), memory_hash (v->bits, BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)) *
--- a/src/fontcolor-gtk.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/fontcolor-gtk.c Mon Apr 05 13:03:35 2010 +0100 @@ -188,7 +188,8 @@ } static Hashcode -gtk_color_instance_hash (struct Lisp_Color_Instance *c, int UNUSED (depth)) +gtk_color_instance_hash (struct Lisp_Color_Instance *c, int UNUSED (depth), + Boolint UNUSED (equalp)) { return (gdk_color_hash (COLOR_INSTANCE_GTK_COLOR (c), NULL)); }
--- a/src/fontcolor-msw.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/fontcolor-msw.c Mon Apr 05 13:03:35 2010 +0100 @@ -1393,7 +1393,8 @@ } static Hashcode -mswindows_color_instance_hash (Lisp_Color_Instance *c, int UNUSED (depth)) +mswindows_color_instance_hash (Lisp_Color_Instance *c, int UNUSED (depth), + Boolint UNUSED (equalp)) { return (unsigned long) COLOR_INSTANCE_MSWINDOWS_COLOR (c); } @@ -2336,7 +2337,7 @@ { #ifdef MULE Vfont_signature_data = - make_lisp_hash_table (100, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL); + make_lisp_hash_table (100, HASH_TABLE_NON_WEAK, Qequal); staticpro (&Vfont_signature_data); #endif /* MULE */ }
--- a/src/fontcolor.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/fontcolor.c Mon Apr 05 13:03:35 2010 +0100 @@ -137,7 +137,7 @@ } static Hashcode -color_instance_hash (Lisp_Object obj, int depth) +color_instance_hash (Lisp_Object obj, int depth, Boolint UNUSED (equalp)) { Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj); struct device *d = DEVICEP (c->device) ? XDEVICE (c->device) : 0; @@ -359,11 +359,11 @@ } static Hashcode -font_instance_hash (Lisp_Object obj, int depth) +font_instance_hash (Lisp_Object obj, int depth, Boolint UNUSED (equalp)) { return internal_hash (font_instance_truename_internal (obj, ERROR_ME_DEBUG_WARN), - depth + 1); + depth + 1, 0); } DEFINE_NODUMP_LISP_OBJECT ("font-instance", font_instance, @@ -819,9 +819,9 @@ { /* Note that the following tables are bi-level. */ d->charset_font_cache_stage_1 = - make_lisp_hash_table (20, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); + make_lisp_hash_table (20, HASH_TABLE_NON_WEAK, Qeq); d->charset_font_cache_stage_2 = - make_lisp_hash_table (20, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); + make_lisp_hash_table (20, HASH_TABLE_NON_WEAK, Qeq); } void @@ -949,7 +949,7 @@ { /* need to make a sub hash table. */ hash_table = make_lisp_hash_table (20, HASH_TABLE_KEY_WEAK, - HASH_TABLE_EQUAL); + Qequal); Fputhash (charset, hash_table, cache); } else
--- a/src/frame-gtk.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/frame-gtk.c Mon Apr 05 13:03:35 2010 +0100 @@ -992,11 +992,11 @@ now that we have internal_equal_trapping_problems(). --ben */ FRAME_GTK_WIDGET_INSTANCE_HASH_TABLE (f) = - make_lisp_hash_table (50, HASH_TABLE_VALUE_WEAK, HASH_TABLE_EQ); + make_lisp_hash_table (50, HASH_TABLE_VALUE_WEAK, Qeq); FRAME_GTK_WIDGET_CALLBACK_HASH_TABLE (f) = - make_lisp_hash_table (50, HASH_TABLE_VALUE_WEAK, HASH_TABLE_EQ); + make_lisp_hash_table (50, HASH_TABLE_VALUE_WEAK, Qeq); FRAME_GTK_WIDGET_CALLBACK_EX_HASH_TABLE (f) = - make_lisp_hash_table (50, HASH_TABLE_VALUE_WEAK, HASH_TABLE_EQ); + make_lisp_hash_table (50, HASH_TABLE_VALUE_WEAK, Qeq); }
--- a/src/frame-msw.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/frame-msw.c Mon Apr 05 13:03:35 2010 +0100 @@ -190,7 +190,7 @@ #ifdef HAVE_TOOLBARS /* EQ not EQUAL or we will get QUIT crashes, see below. */ FRAME_MSWINDOWS_TOOLBAR_HASH_TABLE (f) = - make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); + make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, Qeq); #endif /* hashtable of instantiated glyphs on the frame. [[ Make them EQ because we only use ints as keys. Otherwise we run into stickiness in @@ -198,11 +198,11 @@ enter_redisplay_critical_section(). ]] -- probably not true any more, now that we have internal_equal_trapping_problems(). --ben */ FRAME_MSWINDOWS_WIDGET_HASH_TABLE1 (f) = - make_lisp_hash_table (50, HASH_TABLE_VALUE_WEAK, HASH_TABLE_EQ); + make_lisp_hash_table (50, HASH_TABLE_VALUE_WEAK, Qeq); FRAME_MSWINDOWS_WIDGET_HASH_TABLE2 (f) = - make_lisp_hash_table (50, HASH_TABLE_VALUE_WEAK, HASH_TABLE_EQ); + make_lisp_hash_table (50, HASH_TABLE_VALUE_WEAK, Qeq); FRAME_MSWINDOWS_WIDGET_HASH_TABLE3 (f) = - make_lisp_hash_table (50, HASH_TABLE_VALUE_WEAK, HASH_TABLE_EQ); + make_lisp_hash_table (50, HASH_TABLE_VALUE_WEAK, Qeq); /* Will initialize these in WM_SIZE handler. We cannot do it now, because we do not know what is CW_USEDEFAULT height and width */ FRAME_WIDTH (f) = 0;
--- a/src/gc.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/gc.c Mon Apr 05 13:03:35 2010 +0100 @@ -1757,6 +1757,7 @@ } mark_profiling_info (); + #ifdef USE_KKCC # undef mark_object #endif
--- a/src/general-slots.h Mon Apr 05 00:18:49 2010 -0500 +++ b/src/general-slots.h Mon Apr 05 13:03:35 2010 +0100 @@ -119,9 +119,6 @@ SYMBOL (Qempty); SYMBOL_KEYWORD (Q_end); SYMBOL (Qencode_as_utf_8); -SYMBOL (Qeq); -SYMBOL (Qeql); -SYMBOL (Qequal); SYMBOL (Qeval); SYMBOL (Qevent); SYMBOL (Qextents); @@ -134,6 +131,7 @@ SYMBOL_KEYWORD (Q_filter); SYMBOL (Qfinal); SYMBOL (Qfixnum); +SYMBOL (Qfixnump); SYMBOL (Qfloat); SYMBOL (Qfont); SYMBOL (Qframe);
--- a/src/glyphs-gtk.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/glyphs-gtk.c Mon Apr 05 13:03:35 2010 +0100 @@ -483,7 +483,8 @@ } static Hashcode -gtk_image_instance_hash (struct Lisp_Image_Instance *p, int UNUSED (depth)) +gtk_image_instance_hash (struct Lisp_Image_Instance *p, int UNUSED (depth), + Boolint UNUSED (equalp)) { switch (IMAGE_INSTANCE_TYPE (p)) {
--- a/src/glyphs-msw.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/glyphs-msw.c Mon Apr 05 13:03:35 2010 +0100 @@ -2168,7 +2168,8 @@ } static Hashcode -mswindows_image_instance_hash (Lisp_Image_Instance *p, int UNUSED (depth)) +mswindows_image_instance_hash (Lisp_Image_Instance *p, int UNUSED (depth), + Boolint UNUSED (equalp)) { switch (IMAGE_INSTANCE_TYPE (p)) {
--- a/src/glyphs.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/glyphs.c Mon Apr 05 13:03:35 2010 +0100 @@ -94,6 +94,7 @@ Lisp_Object Vglyph_type_list; int disable_animated_pixmaps; +static Lisp_Object Vimage_instance_hash_table_test; DEFINE_IMAGE_INSTANTIATOR_FORMAT (nothing); DEFINE_IMAGE_INSTANTIATOR_FORMAT (inherit); @@ -1259,7 +1260,7 @@ } static Hashcode -image_instance_hash (Lisp_Object obj, int depth) +image_instance_hash (Lisp_Object obj, int depth, Boolint UNUSED (equalp)) { Lisp_Image_Instance *i = XIMAGE_INSTANCE (obj); Hashcode hash = HASH5 (LISP_HASH (IMAGE_INSTANCE_DOMAIN (i)), @@ -1267,7 +1268,7 @@ IMAGE_INSTANCE_MARGIN_WIDTH (i), IMAGE_INSTANCE_HEIGHT (i), internal_hash (IMAGE_INSTANCE_INSTANTIATOR (i), - depth + 1)); + depth + 1, 0)); ERROR_CHECK_IMAGE_INSTANCE (obj); @@ -1278,7 +1279,7 @@ case IMAGE_TEXT: hash = HASH2 (hash, internal_hash (IMAGE_INSTANCE_TEXT_STRING (i), - depth + 1)); + depth + 1, 0)); break; case IMAGE_MONO_PIXMAP: @@ -1287,7 +1288,7 @@ hash = HASH4 (hash, IMAGE_INSTANCE_PIXMAP_DEPTH (i), IMAGE_INSTANCE_PIXMAP_SLICE (i), internal_hash (IMAGE_INSTANCE_PIXMAP_FILENAME (i), - depth + 1)); + depth + 1, 0)); break; case IMAGE_WIDGET: @@ -1295,10 +1296,12 @@ displayed. */ hash = HASH5 (hash, LISP_HASH (IMAGE_INSTANCE_WIDGET_TYPE (i)), - internal_hash (IMAGE_INSTANCE_WIDGET_PROPS (i), depth + 1), - internal_hash (IMAGE_INSTANCE_WIDGET_ITEMS (i), depth + 1), + internal_hash (IMAGE_INSTANCE_WIDGET_PROPS (i), + depth + 1, 0), + internal_hash (IMAGE_INSTANCE_WIDGET_ITEMS (i), + depth + 1, 0), internal_hash (IMAGE_INSTANCE_LAYOUT_CHILDREN (i), - depth + 1)); + depth + 1, 0)); case IMAGE_SUBWINDOW: hash = HASH2 (hash, (EMACS_INT) IMAGE_INSTANCE_SUBWINDOW_ID (i)); break; @@ -3202,29 +3205,29 @@ } static int -instantiator_eq_equal (Lisp_Object obj1, Lisp_Object obj2) +instantiator_eq_equal (const Hash_Table_Test *UNUSED (http), + Lisp_Object obj1, Lisp_Object obj2) { if (EQ (obj1, obj2)) return 1; else if (CONSP (obj1) && CONSP (obj2)) { - return instantiator_eq_equal (XCAR (obj1), XCAR (obj2)) - && - instantiator_eq_equal (XCDR (obj1), XCDR (obj2)); + return instantiator_eq_equal (NULL, XCAR (obj1), XCAR (obj2)) + && instantiator_eq_equal (NULL, XCDR (obj1), XCDR (obj2)); } return 0; } static Hashcode -instantiator_eq_hash (Lisp_Object obj) +instantiator_eq_hash (const Hash_Table_Test *UNUSED (http), Lisp_Object obj) { if (CONSP (obj)) { /* no point in worrying about tail recursion, since we're not going very deep */ - return HASH2 (instantiator_eq_hash (XCAR (obj)), - instantiator_eq_hash (XCDR (obj))); + return HASH2 (instantiator_eq_hash (NULL, XCAR (obj)), + instantiator_eq_hash (NULL, XCDR (obj))); } return LISP_HASH (obj); } @@ -3233,10 +3236,9 @@ Lisp_Object make_image_instance_cache_hash_table (void) { - return make_general_lisp_hash_table - (instantiator_eq_hash, instantiator_eq_equal, - 30, -1.0, -1.0, - HASH_TABLE_KEY_CAR_VALUE_WEAK); + return make_general_lisp_hash_table (Vimage_instance_hash_table_test, 30, + -1.0, -1.0, + HASH_TABLE_KEY_CAR_VALUE_WEAK); } static Lisp_Object @@ -3737,14 +3739,14 @@ } static Hashcode -glyph_hash (Lisp_Object obj, int depth) +glyph_hash (Lisp_Object obj, int depth, Boolint UNUSED (equalp)) { depth++; /* No need to hash all of the elements; that would take too long. Just hash the most common ones. */ - return HASH2 (internal_hash (XGLYPH (obj)->image, depth), - internal_hash (XGLYPH (obj)->face, depth)); + return HASH2 (internal_hash (XGLYPH (obj)->image, depth, 0), + internal_hash (XGLYPH (obj)->face, depth, 0)); } static Lisp_Object @@ -4759,7 +4761,8 @@ we might need. We can get better hashing by making the depth negative - currently it will recurse down 7 levels.*/ IMAGE_INSTANCE_DISPLAY_HASH (ii) = internal_hash (subwindow, - IMAGE_INSTANCE_HASH_DEPTH); + IMAGE_INSTANCE_HASH_DEPTH, + 0); unbind_to (count); } @@ -4778,7 +4781,7 @@ { Lisp_Image_Instance* ii = XIMAGE_INSTANCE (subwindow); - if (internal_hash (subwindow, IMAGE_INSTANCE_HASH_DEPTH) != + if (internal_hash (subwindow, IMAGE_INSTANCE_HASH_DEPTH, 0) != IMAGE_INSTANCE_DISPLAY_HASH (ii)) return 1; /* #### I think there is probably a bug here. This gets called for @@ -5524,6 +5527,12 @@ Qpointer, Qsubwindow, Qwidget)); staticpro (&Vimage_instance_type_list); + /* The Qunbound name means this test is not available from Lisp. */ + Vimage_instance_hash_table_test + = define_hash_table_test (Qunbound, instantiator_eq_equal, + instantiator_eq_hash, Qunbound, Qunbound); + staticpro (&Vimage_instance_hash_table_test); + /* glyphs */ Vglyph_type_list = list3 (Qbuffer, Qpointer, Qicon);
--- a/src/gui.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/gui.c Mon Apr 05 13:03:35 2010 +0100 @@ -596,28 +596,28 @@ } static Hashcode -gui_item_hash (Lisp_Object obj, int depth) +gui_item_hash (Lisp_Object obj, int depth, Boolint UNUSED (equalp)) { Lisp_Gui_Item *p = XGUI_ITEM (obj); - return HASH2 (HASH6 (internal_hash (p->name, depth + 1), - internal_hash (p->callback, depth + 1), - internal_hash (p->callback_ex, depth + 1), - internal_hash (p->suffix, depth + 1), - internal_hash (p->active, depth + 1), - internal_hash (p->included, depth + 1)), - HASH6 (internal_hash (p->config, depth + 1), - internal_hash (p->filter, depth + 1), - internal_hash (p->style, depth + 1), - internal_hash (p->selected, depth + 1), - internal_hash (p->keys, depth + 1), - internal_hash (p->value, depth + 1))); + return HASH2 (HASH6 (internal_hash (p->name, depth + 1, 0), + internal_hash (p->callback, depth + 1, 0), + internal_hash (p->callback_ex, depth + 1, 0), + internal_hash (p->suffix, depth + 1, 0), + internal_hash (p->active, depth + 1, 0), + internal_hash (p->included, depth + 1, 0)), + HASH6 (internal_hash (p->config, depth + 1, 0), + internal_hash (p->filter, depth + 1, 0), + internal_hash (p->style, depth + 1, 0), + internal_hash (p->selected, depth + 1, 0), + internal_hash (p->keys, depth + 1, 0), + internal_hash (p->value, depth + 1, 0))); } int gui_item_id_hash (Lisp_Object hashtable, Lisp_Object gitem, int slot) { - int hashid = gui_item_hash (gitem, 0); + int hashid = gui_item_hash (gitem, 0, 0); int id = GUI_ITEM_ID_BITS (hashid, slot); while (!UNBOUNDP (Fgethash (make_int (id), hashtable, Qunbound))) {
--- a/src/intl-win32.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/intl-win32.c Mon Apr 05 13:03:35 2010 +0100 @@ -2329,10 +2329,10 @@ { #ifdef MULE Vmswindows_charset_code_page_table = - make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); + make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, Qeq); staticpro (&Vmswindows_charset_code_page_table); Vmswindows_charset_registry_table = - make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); + make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, Qeq); staticpro (&Vmswindows_charset_registry_table); #endif /* MULE */ }
--- a/src/keymap.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/keymap.c Mon Apr 05 13:03:35 2010 +0100 @@ -253,7 +253,7 @@ } static Hashcode -keymap_hash (Lisp_Object obj, int depth) +keymap_hash (Lisp_Object obj, int depth, Boolint UNUSED (equalp)) { Lisp_Keymap *k = XKEYMAP (obj); Hashcode hash = 0xCAFEBABE; /* why not? */ @@ -261,7 +261,7 @@ depth++; #define MARKED_SLOT(x) \ - hash = HASH2 (hash, internal_hash (k->x, depth)); + hash = HASH2 (hash, internal_hash (k->x, depth, 0)); #define MARKED_SLOT_NOCOMPARE(x) #include "keymap-slots.h" @@ -787,12 +787,12 @@ if (size != 0) /* hack for copy-keymap */ { keymap->table = - make_lisp_hash_table (size, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); + make_lisp_hash_table (size, HASH_TABLE_NON_WEAK, Qeq); /* Inverse table is often less dense because of duplicate key-bindings. If not, it will grow anyway. */ keymap->inverse_table = make_lisp_hash_table (size * 3 / 4, HASH_TABLE_NON_WEAK, - HASH_TABLE_EQ); + Qeq); } return obj; }
--- a/src/lisp.h Mon Apr 05 00:18:49 2010 -0500 +++ b/src/lisp.h Mon Apr 05 13:03:35 2010 +0100 @@ -119,6 +119,7 @@ #include <stddef.h> /* offsetof */ #include <sys/types.h> #include <limits.h> +#include <math.h> #ifdef __cplusplus #include <limits> /* necessary for max()/min() under G++ 4 */ #endif @@ -2904,12 +2905,12 @@ #define CHECK_INT(x) do { \ if (!INTP (x)) \ - dead_wrong_type_argument (Qintegerp, x); \ + dead_wrong_type_argument (Qfixnump, x); \ } while (0) #define CONCHECK_INT(x) do { \ if (!INTP (x)) \ - x = wrong_type_argument (Qintegerp, x); \ + x = wrong_type_argument (Qfixnump, x); \ } while (0) /* NOTE NOTE NOTE! This definition of "natural number" is mathematically @@ -3130,6 +3131,10 @@ # define INT_OR_FLOATP(x) (INTP (x) || FLOATP (x)) +/* #### change for 64-bit machines */ +#define FLOAT_HASHCODE_FROM_DOUBLE(dbl) \ + (unsigned long)(fmod (dbl, 4e9)) + /*--------------------------- readonly objects -------------------------*/ #ifndef NEW_GC @@ -3705,8 +3710,9 @@ #define LISP_HASH(obj) ((unsigned long) STORE_LISP_IN_VOID (obj)) Hashcode memory_hash (const void *xv, Bytecount size); -Hashcode internal_hash (Lisp_Object obj, int depth); -Hashcode internal_array_hash (Lisp_Object *arr, int size, int depth); +Hashcode internal_hash (Lisp_Object obj, int depth, Boolint equalp); +Hashcode internal_array_hash (Lisp_Object *arr, int size, int depth, + Boolint equalp); /************************************************************************/ @@ -5255,6 +5261,11 @@ #undef SYMBOL_KEYWORD #undef SYMBOL_GENERAL +extern Lisp_Object Qeq; +extern Lisp_Object Qeql; +extern Lisp_Object Qequal; +extern Lisp_Object Qequalp; + /* Defined in glyphs.c */ EXFUN (Fmake_glyph_internal, 1);
--- a/src/lread.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/lread.c Mon Apr 05 13:03:35 2010 +0100 @@ -894,6 +894,9 @@ { /* This function can GC */ Lisp_Object tp; + static int locate_file_called; + + ++locate_file_called; CHECK_STRING (filename); @@ -3480,7 +3483,7 @@ Vlocate_file_hash_table = make_lisp_hash_table (200, HASH_TABLE_NON_WEAK, - HASH_TABLE_EQUAL); + Qequal); staticpro (&Vlocate_file_hash_table); #ifdef DEBUG_XEMACS symbol_value (XSYMBOL (intern ("Vlocate-file-hash-table")))
--- a/src/lrecord.h Mon Apr 05 00:18:49 2010 -0500 +++ b/src/lrecord.h Mon Apr 05 13:03:35 2010 +0100 @@ -334,6 +334,7 @@ lrecord_type_weak_list, lrecord_type_bit_vector, lrecord_type_float, + lrecord_type_hash_table_test, lrecord_type_hash_table, lrecord_type_lstream, lrecord_type_process, @@ -489,7 +490,7 @@ hash to the same value in order for hash tables to work properly. This means that `hash' can be NULL only if the `equal' method is also NULL. */ - Hashcode (*hash) (Lisp_Object, int); + Hashcode (*hash) (Lisp_Object, int, Boolint); /* Data layout description for your object. See long comment below. */ const struct memory_description *description;
--- a/src/marker.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/marker.c Mon Apr 05 13:03:35 2010 +0100 @@ -90,7 +90,7 @@ } static Hashcode -marker_hash (Lisp_Object obj, int UNUSED (depth)) +marker_hash (Lisp_Object obj, int UNUSED (depth), Boolint UNUSED (equalp)) { Hashcode hash = (Hashcode) XMARKER (obj)->buffer; if (hash)
--- a/src/menubar-msw.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/menubar-msw.c Mon Apr 05 13:03:35 2010 +0100 @@ -521,7 +521,7 @@ /* Come with empty hash table */ if (NILP (FRAME_MSWINDOWS_MENU_HASH_TABLE (f))) FRAME_MSWINDOWS_MENU_HASH_TABLE (f) = - make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL); + make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, Qequal); else Fclrhash (FRAME_MSWINDOWS_MENU_HASH_TABLE (f)); @@ -832,7 +832,7 @@ current_menudesc = menu_desc; current_hash_table = - make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL); + make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, Qequal); menu = create_empty_popup_menu (); Fputhash (hmenu_to_lisp_object (menu), Qnil, current_hash_table); top_level_menu = menu;
--- a/src/mule-charset.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/mule-charset.c Mon Apr 05 13:03:35 2010 +0100 @@ -1121,7 +1121,7 @@ staticpro (&Vcharset_hash_table); Vcharset_hash_table = - make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); + make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, Qeq); } void
--- a/src/mule-coding.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/mule-coding.c Mon Apr 05 13:03:35 2010 +0100 @@ -3970,9 +3970,9 @@ void vars_of_mule_coding (void) { - /* This needs to be HASH_TABLE_EQ, there's a corner case where - HASH_TABLE_EQUAL won't work. */ + /* This needs to be Qeq, there's a corner case where + Qequal won't work. */ Vfixed_width_query_ranges_cache - = make_lisp_hash_table (32, HASH_TABLE_KEY_WEAK, HASH_TABLE_EQ); + = make_lisp_hash_table (32, HASH_TABLE_KEY_WEAK, Qeq); staticpro (&Vfixed_width_query_ranges_cache); }
--- a/src/number.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/number.c Mon Apr 05 13:03:35 2010 +0100 @@ -80,9 +80,16 @@ } static Hashcode -bignum_hash (Lisp_Object obj, int UNUSED (depth)) +bignum_hash (Lisp_Object obj, int UNUSED (depth), Boolint equalp) { - return bignum_hashcode (XBIGNUM_DATA (obj)); + if (equalp) + { + return FLOAT_HASHCODE_FROM_DOUBLE (bignum_to_double (XBIGNUM_DATA (obj))); + } + else + { + return bignum_hashcode (XBIGNUM_DATA (obj)); + } } static void @@ -170,9 +177,16 @@ } static Hashcode -ratio_hash (Lisp_Object obj, int UNUSED (depth)) +ratio_hash (Lisp_Object obj, int UNUSED (depth), Boolint equalp) { - return ratio_hashcode (XRATIO_DATA (obj)); + if (equalp) + { + return FLOAT_HASHCODE_FROM_DOUBLE (ratio_to_double (XRATIO_DATA (obj))); + } + else + { + return ratio_hashcode (XRATIO_DATA (obj)); + } } static const struct memory_description ratio_description[] = { @@ -274,9 +288,17 @@ } static Hashcode -bigfloat_hash (Lisp_Object obj, int UNUSED (depth)) +bigfloat_hash (Lisp_Object obj, int UNUSED (depth), Boolint equalp) { - return bigfloat_hashcode (XBIGFLOAT_DATA (obj)); + if (equalp) + { + return + FLOAT_HASHCODE_FROM_DOUBLE (bigfloat_to_double (XBIGFLOAT_DATA (obj))); + } + else + { + return bigfloat_hashcode (XBIGFLOAT_DATA (obj)); + } } static const struct memory_description bigfloat_description[] = {
--- a/src/opaque.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/opaque.c Mon Apr 05 13:03:35 2010 +0100 @@ -103,7 +103,7 @@ /* This will not work correctly for opaques with subobjects! */ static Hashcode -hash_opaque (Lisp_Object obj, int UNUSED (depth)) +hash_opaque (Lisp_Object obj, int UNUSED (depth), int UNUSED (equalp)) { if (XOPAQUE_SIZE (obj) == sizeof (unsigned long)) return *((Hashcode *) XOPAQUE_DATA (obj)); @@ -144,7 +144,7 @@ } static Hashcode -hash_opaque_ptr (Lisp_Object obj, int UNUSED (depth)) +hash_opaque_ptr (Lisp_Object obj, int UNUSED (depth), int UNUSED (equalp)) { return (Hashcode) XOPAQUE_PTR (obj)->ptr; }
--- a/src/print.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/print.c Mon Apr 05 13:03:35 2010 +0100 @@ -1872,7 +1872,7 @@ } #else /* not NEW_GC */ Lisp_String *l = (Lisp_String *) lheader; - if (!debug_can_access_memory (l->data_, l->size_)) + if (l->size_ && !debug_can_access_memory (l->data_, l->size_)) { printing_major_badness (printcharfun, "BAD STRING DATA", (int) (lheader->type),
--- a/src/profile.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/profile.c Mon Apr 05 13:03:35 2010 +0100 @@ -138,16 +138,16 @@ create_timing_profile_table (); if (NILP (Vtotal_timing_profile_table)) Vtotal_timing_profile_table = - make_lisp_hash_table (1000, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); + make_lisp_hash_table (1000, HASH_TABLE_NON_WEAK, Qeq); if (NILP (Vcall_count_profile_table)) Vcall_count_profile_table = - make_lisp_hash_table (1000, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); + make_lisp_hash_table (1000, HASH_TABLE_NON_WEAK, Qeq); if (NILP (Vgc_usage_profile_table)) Vgc_usage_profile_table = - make_lisp_hash_table (1000, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); + make_lisp_hash_table (1000, HASH_TABLE_NON_WEAK, Qeq); if (NILP (Vtotal_gc_usage_profile_table)) Vtotal_gc_usage_profile_table = - make_lisp_hash_table (1000, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); + make_lisp_hash_table (1000, HASH_TABLE_NON_WEAK, Qeq); } static Lisp_Object @@ -476,7 +476,7 @@ { return !NILP (table) ? Fcopy_hash_table (table) : make_lisp_hash_table (100, HASH_TABLE_NON_WEAK, - HASH_TABLE_EQ); + Qeq); } DEFUN ("get-profiling-info", Fget_profiling_info, 0, 0, 0, /* @@ -515,7 +515,7 @@ const void *overhead; closure.timing = - make_lisp_hash_table (100, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL); + make_lisp_hash_table (100, HASH_TABLE_NON_WEAK, Qequal); if (big_profile_table) {
--- a/src/rangetab.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/rangetab.c Mon Apr 05 13:03:35 2010 +0100 @@ -163,13 +163,15 @@ } static Hashcode -range_table_entry_hash (struct range_table_entry *rte, int depth) +range_table_entry_hash (struct range_table_entry *rte, int depth, + Boolint equalp) { - return HASH3 (rte->first, rte->last, internal_hash (rte->val, depth + 1)); + return HASH3 (rte->first, rte->last, + internal_hash (rte->val, depth + 1, equalp)); } static Hashcode -range_table_hash (Lisp_Object obj, int depth) +range_table_hash (Lisp_Object obj, int depth, Boolint equalp) { Lisp_Range_Table *rt = XRANGE_TABLE (obj); int i; @@ -182,7 +184,7 @@ for (i = 0; i < size; i++) hash = HASH2 (hash, range_table_entry_hash - (rangetab_gap_array_atp (rt->entries, i), depth)); + (rangetab_gap_array_atp (rt->entries, i), depth, equalp)); return hash; } @@ -192,7 +194,8 @@ for (i = 0; i < 5; i++) hash = HASH2 (hash, range_table_entry_hash - (rangetab_gap_array_atp (rt->entries, i*size/5), depth)); + (rangetab_gap_array_atp (rt->entries, i*size/5), + depth, equalp)); return hash; }
--- a/src/scrollbar-msw.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/scrollbar-msw.c Mon Apr 05 13:03:35 2010 +0100 @@ -490,5 +490,5 @@ staticpro (&Vmswindows_scrollbar_instance_table); Vmswindows_scrollbar_instance_table = - make_lisp_hash_table (100, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); + make_lisp_hash_table (100, HASH_TABLE_NON_WEAK, Qeq); }
--- a/src/specifier.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/specifier.c Mon Apr 05 13:03:35 2010 +0100 @@ -348,7 +348,7 @@ } static Hashcode -specifier_hash (Lisp_Object obj, int depth) +specifier_hash (Lisp_Object obj, int depth, Boolint equalp) { Lisp_Specifier *s = XSPECIFIER (obj); @@ -356,11 +356,11 @@ many places where data can be stored. We pick what are perhaps the most likely places where interesting stuff will be. */ return HASH5 ((HAS_SPECMETH_P (s, hash) ? - SPECMETH (s, hash, (obj, depth)) : 0), + SPECMETH (s, hash, (obj, depth, equalp)) : 0), (Hashcode) s->methods, - internal_hash (s->global_specs, depth + 1), - internal_hash (s->frame_specs, depth + 1), - internal_hash (s->buffer_specs, depth + 1)); + internal_hash (s->global_specs, depth + 1, equalp), + internal_hash (s->frame_specs, depth + 1, equalp), + internal_hash (s->buffer_specs, depth + 1, equalp)); } inline static Bytecount @@ -3912,6 +3912,6 @@ staticpro (&Vunlock_ghost_specifiers); Vcharset_tag_lists = - make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); + make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, Qeq); staticpro (&Vcharset_tag_lists); }
--- a/src/specifier.h Mon Apr 05 00:18:49 2010 -0500 +++ b/src/specifier.h Mon Apr 05 13:03:35 2010 +0100 @@ -115,7 +115,7 @@ If this function is not present, hashing behaves as if it returned zero. */ - Hashcode (*hash_method) (Lisp_Object specifier, int depth); + Hashcode (*hash_method) (Lisp_Object specifier, int depth, Boolint equalp); /* Validate method: Given an instantiator, verify that it's valid for this specifier type. If not, signal an error.
--- a/src/tests.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/tests.c Mon Apr 05 13:03:35 2010 +0100 @@ -615,7 +615,7 @@ test_hash_tables_data data; data.hash_table = make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, - HASH_TABLE_EQUAL); + Qequal); Fputhash (make_int (1), make_int (2), data.hash_table); Fputhash (make_int (3), make_int (4), data.hash_table);
--- a/src/text.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/text.c Mon Apr 05 13:03:35 2010 +0100 @@ -5170,9 +5170,9 @@ composite_char_col_next = 32; Vcomposite_char_string2char_hash_table = - make_lisp_hash_table (500, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL); + make_lisp_hash_table (500, HASH_TABLE_NON_WEAK, Qequal); Vcomposite_char_char2string_hash_table = - make_lisp_hash_table (500, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); + make_lisp_hash_table (500, HASH_TABLE_NON_WEAK, Qeq); staticpro (&Vcomposite_char_string2char_hash_table); staticpro (&Vcomposite_char_char2string_hash_table); #endif /* ENABLE_COMPOSITE_CHARS */
--- a/src/tooltalk.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/tooltalk.c Mon Apr 05 13:03:35 2010 +0100 @@ -1473,7 +1473,7 @@ staticpro (&Vtooltalk_message_gcpro); staticpro (&Vtooltalk_pattern_gcpro); Vtooltalk_message_gcpro = - make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); + make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, Qeq); Vtooltalk_pattern_gcpro = - make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); + make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, Qeq); }
--- a/src/ui-gtk.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/ui-gtk.c Mon Apr 05 13:03:35 2010 +0100 @@ -1117,7 +1117,8 @@ } static Hashcode -emacs_gtk_boxed_hash (Lisp_Object obj, int UNUSED (depth)) +emacs_gtk_boxed_hash (Lisp_Object obj, int UNUSED (depth), + Boolint UNUSED (equalp)) { emacs_gtk_boxed_data *data = XGTK_BOXED(obj); return (HASH2 ((Hashcode) data->object, data->object_type));
--- a/src/window.c Mon Apr 05 00:18:49 2010 -0500 +++ b/src/window.c Mon Apr 05 13:03:35 2010 +0100 @@ -365,7 +365,7 @@ static Lisp_Object make_saved_buffer_point_cache (void) { - return make_lisp_hash_table (20, HASH_TABLE_KEY_WEAK, HASH_TABLE_EQ); + return make_lisp_hash_table (20, HASH_TABLE_KEY_WEAK, Qeq); } DEFINE_NODUMP_LISP_OBJECT ("window", window,
--- a/tests/ChangeLog Mon Apr 05 00:18:49 2010 -0500 +++ b/tests/ChangeLog Mon Apr 05 13:03:35 2010 +0100 @@ -1,3 +1,12 @@ +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. + 2010-04-03 Aidan Kehoe <kehoea@parhasard.net> * automated/lisp-tests.el:
--- a/tests/automated/hash-table-tests.el Mon Apr 05 00:18:49 2010 -0500 +++ b/tests/automated/hash-table-tests.el Mon Apr 05 13:03:35 2010 +0100 @@ -37,7 +37,7 @@ (require 'test-harness)))) ;; Test all combinations of make-hash-table keywords -(dolist (test '(eq eql equal)) +(dolist (test '(eq eql equal equalp)) (dolist (size '(0 1 100)) (dolist (rehash-size '(1.1 9.9)) (dolist (rehash-threshold '(0.2 .9)) @@ -200,6 +200,25 @@ (check-copy ht) ) + (let ((ht (make-hash-table :size 100 :rehash-threshold .6 :test 'equalp))) + (dotimes (j iterations) + (puthash (+ one 0.0) t ht) + (puthash 1 t ht) + (puthash (+ two 0.0) t ht) + (puthash 2 t ht) + (puthash (cons 1.0 2.0) (gensym) ht) + ;; Override the previous entry. + (puthash (cons 1 2) t ht) + (puthash (cons 3.0 4.0) (gensym) ht) + (puthash (cons 3 4) t ht)) + (Assert (eq (hashtable-test-function ht) 'equalp)) + (Assert (eq (hash-table-test ht) 'equalp)) + (Assert (= 4 (hash-table-count ht))) + (Assert (eq t (gethash 1.0 ht))) + (Assert (eq t (gethash '(1 . 2) ht))) + (check-copy ht) + ) + )) ;; Test that weak hash-tables are properly handled @@ -248,8 +267,8 @@ (Assert (= v-sum k-sum)))) ;;; Test reading and printing of hash-table objects -(let ((h1 #s(hashtable weakness t rehash-size 3.0 rehash-threshold .2 test eq data (1 2 3 4))) - (h2 #s(hash-table weakness t rehash-size 3.0 rehash-threshold .2 test eq data (1 2 3 4))) +(let ((h1 #s(hashtable :weakness t :rehash-size 3.0 :rehash-threshold .2 :test eq :data (1 2 3 4))) + (h2 #s(hash-table :weakness t :rehash-size 3.0 :rehash-threshold .2 :test eq :data (1 2 3 4))) (h3 (make-hash-table :weakness t :rehash-size 3.0 :rehash-threshold .2 :test 'eq))) (Assert (equal h1 h2)) (Assert (not (equal h1 h3))) @@ -282,3 +301,91 @@ (Assert (= (sxhash "foo") (sxhash "foo"))) (Assert (= (sxhash '(1 2 3)) (sxhash '(1 2 3)))) (Assert (/= (sxhash '(1 2 3)) (sxhash '(3 2 1)))) + +;; Test #'define-hash-table-test. + +(defstruct hash-table-test-structure + number-identifier padding-zero padding-one padding-two) + +(macrolet + ((good-hash () 65599) + (hash-modulo-figure () + (if (featurep 'bignum) + (1+ (* most-positive-fixnum 2)) + most-positive-fixnum)) + (hash-table-test-structure-first-hash-figure () + (rem* (* 65599 (eq-hash 'hash-table-test-structure)) + (if (featurep 'bignum) + (1+ (* most-positive-fixnum 2)) + most-positive-fixnum)))) + (let ((hash-table-test (gensym)) + (no-entry-found (gensym)) + (two 2.0) + (equal-function + #'(lambda (object-one object-two) + (or (equal object-one object-two) + (and (hash-table-test-structure-p object-one) + (hash-table-test-structure-p object-two) + (= (hash-table-test-structure-number-identifier + object-one) + (hash-table-test-structure-number-identifier + object-two)))))) + (hash-function + #'(lambda (object) + (if (hash-table-test-structure-p object) + (rem* (+ (hash-table-test-structure-first-hash-figure) + (equalp-hash + (hash-table-test-structure-number-identifier + object))) + (hash-modulo-figure)) + (equal-hash object)))) + hash-table-test-hash equal-hash) + (Check-Error wrong-type-argument (define-hash-table-test + "hi there everyone" + equal-function hash-function)) + (Check-Error wrong-number-of-arguments (define-hash-table-test + (gensym) + hash-function hash-function)) + (Check-Error wrong-number-of-arguments (define-hash-table-test + (gensym) + equal-function equal-function)) + (define-hash-table-test hash-table-test equal-function hash-function) + (Assert (valid-hash-table-test-p hash-table-test)) + (setq equal-hash (make-hash-table :test #'equal) + hash-table-test-hash (make-hash-table :test hash-table-test)) + (Assert (hash-table-p equal-hash)) + (Assert (hash-table-p hash-table-test-hash)) + (Assert (eq hash-table-test (hash-table-test hash-table-test-hash))) + (loop + for ii from 200 below 300 + with structure = nil + do + (setf structure (make-hash-table-test-structure + :number-identifier (if (oddp ii) (float (% ii 10)) + (% ii 10)) + :padding-zero (random) + :padding-one (random) + :padding-two (random)) + (gethash structure hash-table-test-hash) t + (gethash structure equal-hash) t)) + (Assert (= (hash-table-count hash-table-test-hash) 10)) + (Assert (= (hash-table-count equal-hash) 100)) + (Assert (eq t (gethash (make-hash-table-test-structure + :number-identifier 1 + :padding-zero (random) + :padding-one (random) + :padding-two (random)) + hash-table-test-hash))) + (Assert (eq t (gethash (make-hash-table-test-structure + :number-identifier 2.0 + :padding-zero (random) + :padding-one (random) + :padding-two (random)) + hash-table-test-hash))) + (Assert (eq no-entry-found (gethash (make-hash-table-test-structure + :number-identifier (+ two 0.0) + :padding-zero (random) + :padding-one (random) + :padding-two (random)) + equal-hash + no-entry-found)))))
--- a/tests/automated/lisp-tests.el Mon Apr 05 00:18:49 2010 -0500 +++ b/tests/automated/lisp-tests.el Mon Apr 05 13:03:35 2010 +0100 @@ -2149,7 +2149,10 @@ (push `(Assert (equalp ,(quote-maybe x) ,(quote-maybe y))) res) (push `(Assert (equalp ,(quote-maybe y) - ,(quote-maybe x))) res)))) + ,(quote-maybe x))) res) + (push `(Assert (eql (equalp-hash ,(quote-maybe y)) + (equalp-hash ,(quote-maybe x)))) + res)))) (cons 'progn (nreverse res)))) (equalp-diff-list-tests (diff-list) (let (res) @@ -2160,7 +2163,13 @@ ,(quote-maybe y)))) res) (push `(Assert (not (equalp ,(quote-maybe y) ,(quote-maybe x)))) res))) - (cons 'progn (nreverse res))))) + (cons 'progn (nreverse res)))) + (Assert-equalp (object-one object-two &optional failing-case description) + `(progn + (Assert (equalp ,object-one ,object-two) + ,@(if failing-case + (list failing-case description))) + (Assert (eql (equalp-hash ,object-one) (equalp-hash ,object-two)))))) (equalp-equal-list-tests `(,@(when (featurep 'bignum) (read "((111111111111111111111111111111111111111111111111111 @@ -2183,72 +2192,78 @@ ,@(when (featurep 'ratio) (mapcar* #'/ '(3/2 3/2) '(0.2 0.7))) 55555555555555555555555555555555555555555/2718281828459045 0.111111111111111111111111111111111111111111111111111111111111111 - 1e+300 1e+301 -1e+300 -1e+301))) + 1e+300 1e+301 -1e+300 -1e+301)) - (Assert (equalp "hi there" "Hi There") - "checking equalp isn't case-sensitive") - (Assert (equalp 99 99.0) - "checking equalp compares numerical values of different types") - (Assert (null (equalp 99 ?c)) - "checking equalp does not convert characters to numbers") - ;; Fixed in Hg d0ea57eb3de4. - (Assert (null (equalp "hi there" [hi there])) - "checking equalp doesn't error with string and non-string") - (Assert (equalp "ABCDEEFGH\u00CDJ" string-variable) - "checking #'equalp is case-insensitive with an upcased constant") - (Assert (equalp "abcdeefgh\xedj" string-variable) - "checking #'equalp is case-insensitive with a downcased constant") - (Assert (equalp string-variable string-variable) - "checking #'equalp works when handed the same string twice") - (Assert (equalp string-variable "aBcDeeFgH\u00Edj") - "check #'equalp is case-insensitive with a variable-cased constant") - (Assert (equalp "" (bit-vector)) - "check empty string and empty bit-vector are #'equalp.") - (Assert (equalp (string) (bit-vector)) - "check empty string and empty bit-vector are #'equalp, no constants") - (Assert (equalp "hi there" (vector ?h ?i ?\ ?t ?h ?e ?r ?e)) - "check string and vector with same contents #'equalp") - (Assert (equalp (string ?h ?i ?\ ?t ?h ?e ?r ?e) - (vector ?h ?i ?\ ?t ?h ?e ?r ?e)) - "check string and vector with same contents #'equalp, no constants") - (Assert (equalp [?h ?i ?\ ?t ?h ?e ?r ?e] - (string ?h ?i ?\ ?t ?h ?e ?r ?e)) - "check string and vector with same contents #'equalp, vector constant") - (Assert (equalp [0 1.0 0.0 0 1] - (bit-vector 0 1 0 0 1)) - "check vector and bit-vector with same contents #'equalp,\ + (Assert-equalp "hi there" "Hi There" + "checking equalp isn't case-sensitive") + (Assert-equalp + 99 99.0 + "checking equalp compares numerical values of different types") + (Assert (null (equalp 99 ?c)) + "checking equalp does not convert characters to numbers") + ;; Fixed in Hg d0ea57eb3de4. + (Assert (null (equalp "hi there" [hi there])) + "checking equalp doesn't error with string and non-string") + (Assert-equalp + "ABCDEEFGH\u00CDJ" string-variable + "checking #'equalp is case-insensitive with an upcased constant") + (Assert-equalp + "abcdeefgh\xedj" string-variable + "checking #'equalp is case-insensitive with a downcased constant") + (Assert-equalp string-variable string-variable + "checking #'equalp works when handed the same string twice") + (Assert (equalp string-variable "aBcDeeFgH\u00Edj") + "check #'equalp is case-insensitive with a variable-cased constant") + (Assert-equalp "" (bit-vector) + "check empty string and empty bit-vector are #'equalp.") + (Assert-equalp + (string) (bit-vector) + "check empty string and empty bit-vector are #'equalp, no constants") + (Assert-equalp "hi there" (vector ?h ?i ?\ ?t ?h ?e ?r ?e) + "check string and vector with same contents #'equalp") + (Assert-equalp + (string ?h ?i ?\ ?t ?h ?e ?r ?e) + (vector ?h ?i ?\ ?t ?h ?e ?r ?e) + "check string and vector with same contents #'equalp, no constants") + (Assert-equalp + [?h ?i ?\ ?t ?h ?e ?r ?e] + (string ?h ?i ?\ ?t ?h ?e ?r ?e) + "check string and vector with same contents #'equalp, vector constant") + (Assert-equalp [0 1.0 0.0 0 1] + (bit-vector 0 1 0 0 1) + "check vector and bit-vector with same contents #'equalp,\ vector constant") - (Assert (not (equalp [0 2 0.0 0 1] - (bit-vector 0 1 0 0 1))) - "check vector and bit-vector with different contents not #'equalp,\ + (Assert (not (equalp [0 2 0.0 0 1] + (bit-vector 0 1 0 0 1))) + "check vector and bit-vector with different contents not #'equalp,\ vector constant") - (Assert (equalp #*01001 - (vector 0 1.0 0.0 0 1)) + (Assert-equalp #*01001 + (vector 0 1.0 0.0 0 1) "check vector and bit-vector with same contents #'equalp,\ bit-vector constant") - (Assert (equalp ?\u00E9 Eacute-character) - "checking characters are case-insensitive, one constant") - (Assert (not (equalp ?\u00E9 (aref (format "%c" ?a) 0))) - "checking distinct characters are not equalp, one constant") - (Assert (equalp t (and)) - "checking symbols are correctly #'equalp") - (Assert (not (equalp t (or nil '#:t))) - "checking distinct symbols with the same name are not #'equalp") - (Assert (equalp #s(char-table type generic data (?\u0080 "hi-there")) - (let ((aragh (make-char-table 'generic))) - (put-char-table ?\u0080 "hi-there" aragh) - aragh)) - "checking #'equalp succeeds correctly, char-tables") - (Assert (equalp #s(char-table type generic data (?\u0080 "hi-there")) - (let ((aragh (make-char-table 'generic))) - (put-char-table ?\u0080 "HI-THERE" aragh) - aragh)) - "checking #'equalp succeeds correctly, char-tables") - (Assert (not (equalp #s(char-table type generic data (?\u0080 "hi-there")) - (let ((aragh (make-char-table 'generic))) - (put-char-table ?\u0080 "hi there" aragh) - aragh))) - "checking #'equalp fails correctly, char-tables")) + (Assert-equalp ?\u00E9 Eacute-character + "checking characters are case-insensitive, one constant") + (Assert (not (equalp ?\u00E9 (aref (format "%c" ?a) 0))) + "checking distinct characters are not equalp, one constant") + (Assert-equalp t (and) + "checking symbols are correctly #'equalp") + (Assert (not (equalp t (or nil '#:t))) + "checking distinct symbols with the same name are not #'equalp") + (Assert-equalp #s(char-table type generic data (?\u0080 "hi-there")) + (let ((aragh (make-char-table 'generic))) + (put-char-table ?\u0080 "hi-there" aragh) + aragh) + "checking #'equalp succeeds correctly, char-tables") + (Assert-equalp #s(char-table type generic data (?\u0080 "hi-there")) + (let ((aragh (make-char-table 'generic))) + (put-char-table ?\u0080 "HI-THERE" aragh) + aragh) + "checking #'equalp succeeds correctly, char-tables") + (Assert (not (equalp #s(char-table type generic data (?\u0080 "hi-there")) + (let ((aragh (make-char-table 'generic))) + (put-char-table ?\u0080 "hi there" aragh) + aragh))) + "checking #'equalp fails correctly, char-tables"))) ;; There are more tests available for equalp here: ;;