Mercurial > hg > xemacs-beta
diff src/fns.c @ 4906:6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
-------------------- ChangeLog entries follow: --------------------
lisp/ChangeLog addition:
2010-02-01 Ben Wing <ben@xemacs.org>
* cl-extra.el:
* cl-extra.el (cl-string-vector-equalp): Removed.
* cl-extra.el (cl-bit-vector-vector-equalp): Removed.
* cl-extra.el (cl-vector-array-equalp): Removed.
* cl-extra.el (cl-hash-table-contents-equalp): Removed.
* cl-extra.el (equalp): Removed.
* cl-extra.el (cl-mapcar-many):
Comment out the whole `equalp' implementation for the moment;
remove once we're sure the C implementation works.
* cl-macs.el:
* cl-macs.el (equalp):
Simplify the compiler-macro for `equalp' -- once it's in C,
we don't need to try so hard to expand it.
src/ChangeLog addition:
2010-02-01 Ben Wing <ben@xemacs.org>
* abbrev.c (abbrev_match_mapper):
* buffer.h (CANON_TABLE_OF):
* buffer.h:
* editfns.c (Fchar_equal):
* minibuf.c (scmp_1):
* text.c (qxestrcasecmp_i18n):
* text.c (qxestrncasecmp_i18n):
* text.c (qxetextcasecmp):
* text.c (qxetextcasecmp_matching):
Create new macro CANONCASE that converts to a canonical mapping
and use it to do caseless comparisons instead of DOWNCASE.
* alloc.c:
* alloc.c (cons_equal):
* alloc.c (vector_equal):
* alloc.c (string_equal):
* bytecode.c (compiled_function_equal):
* chartab.c (char_table_entry_equal):
* chartab.c (char_table_equal):
* data.c (weak_list_equal):
* data.c (weak_box_equal):
* data.c (ephemeron_equal):
* device-msw.c (equal_devmode):
* elhash.c (hash_table_equal):
* events.c (event_equal):
* extents.c (properties_equal):
* extents.c (extent_equal):
* faces.c:
* faces.c (face_equal):
* faces.c (face_hash):
* floatfns.c (float_equal):
* fns.c:
* fns.c (bit_vector_equal):
* fns.c (plists_differ):
* fns.c (Fplists_eq):
* fns.c (Fplists_equal):
* fns.c (Flax_plists_eq):
* fns.c (Flax_plists_equal):
* fns.c (internal_equal):
* fns.c (internal_equalp):
* fns.c (internal_equal_0):
* fns.c (syms_of_fns):
* glyphs.c (image_instance_equal):
* glyphs.c (glyph_equal):
* glyphs.c (glyph_hash):
* gui.c (gui_item_equal):
* lisp.h:
* lrecord.h (struct lrecord_implementation):
* marker.c (marker_equal):
* number.c (bignum_equal):
* number.c (ratio_equal):
* number.c (bigfloat_equal):
* objects.c (color_instance_equal):
* objects.c (font_instance_equal):
* opaque.c (equal_opaque):
* opaque.c (equal_opaque_ptr):
* rangetab.c (range_table_equal):
* specifier.c (specifier_equal):
Add a `foldcase' param to the equal() method and use it to implement
`equalp' comparisons. Also add to plists_differ(), although we
don't currently use it here.
Rewrite internal_equalp(). Implement cross-type vector comparisons.
Don't implement our own handling of numeric promotion -- just use
the `=' primitive.
Add internal_equal_0(), which takes a `foldcase' param and calls
either internal_equal() or internal_equalp().
* buffer.h:
When given a 0 for buffer (which is the norm when functions don't
have a specific buffer available), use the current buffer's table,
not `standard-case-table'; otherwise the current settings are
ignored.
* casetab.c:
* casetab.c (set_case_table):
When handling old-style vectors of 256 in `set-case-table' don't
overwrite the existing table! Instead create a new table and
populate.
* device-msw.c (sync_printer_with_devmode):
* lisp.h:
* text.c (lisp_strcasecmp_ascii):
Rename lisp_strcasecmp to lisp_strcasecmp_ascii and use
lisp_strcasecmp_i18n for caseless comparisons in some places.
* elhash.c:
Delete unused lisp_string_hash and lisp_string_equal().
* events.h:
* keymap-buttons.h:
* keymap.h:
* keymap.c (keymap_lookup_directly):
* keymap.c (keymap_store):
* keymap.c (FROB):
* keymap.c (key_desc_list_to_event):
* keymap.c (describe_map_mapper):
* keymap.c (INCLUDE_BUTTON_ZERO):
New file keymap-buttons.h; use to handle buttons 1-26 in place of
duplicating code 26 times.
* frame-gtk.c (allocate_gtk_frame_struct):
* frame-msw.c (mswindows_init_frame_1):
Fix some comments about internal_equal() in redisplay that don't
apply any more.
* keymap-slots.h:
* keymap.c:
New file keymap-slots.h. Use it to notate the slots in a keymap
structure, similar to frameslots.h or coding-system-slots.h.
* keymap.c (MARKED_SLOT):
* keymap.c (keymap_equal):
* keymap.c (keymap_hash):
Implement.
tests/ChangeLog addition:
2010-02-01 Ben Wing <ben@xemacs.org>
* automated/case-tests.el:
* automated/case-tests.el (uni-mappings):
* automated/search-tests.el:
Delete old pristine-case-table code. Rewrite the Unicode torture
test to take into account whether overlapping mappings exist for
more than one character, and not doing the upcase/downcase
comparisons in such cases.
* automated/lisp-tests.el (foo):
* automated/lisp-tests.el (string-variable):
* automated/lisp-tests.el (featurep):
Replace Assert (equal ... with Assert-equal; same for other types
of equality. Replace some awkward equivalents of Assert-equalp
with Assert-equalp. Add lots of equalp tests.
* automated/case-tests.el:
* automated/regexp-tests.el:
* automated/search-tests.el:
Fix up the comments at the top of the files. Move rules about where
to put tests into case-tests.el.
* automated/test-harness.el:
* automated/test-harness.el (test-harness-aborted-summary-template): New.
* automated/test-harness.el (test-harness-from-buffer):
* automated/test-harness.el (batch-test-emacs):
Fix Assert-test-not. Create Assert-not-equal and variants.
Delete the doc strings from all these convenience functions to avoid
excessive repetition; instead use one copy in a comment.
author | Ben Wing <ben@xemacs.org> |
---|---|
date | Mon, 01 Feb 2010 01:02:40 -0600 |
parents | a5eca70cf401 |
children | 6bc1f3f6cf0d e813cf16c015 |
line wrap: on
line diff
--- a/src/fns.c Sat Jan 30 20:34:23 2010 -0600 +++ b/src/fns.c Mon Feb 01 01:02:40 2010 -0600 @@ -95,7 +95,8 @@ } static int -bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth)) +bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth), + int UNUSED (foldcase)) { Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1); Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2); @@ -1982,7 +1983,7 @@ */ int plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present, - int laxp, int depth) + int laxp, int depth, int foldcase) { int eqp = (depth == -1); /* -1 as depth means use eq, not equal. */ int la, lb, m, i, fill; @@ -2026,12 +2027,13 @@ if (nil_means_not_present && NILP (v)) continue; for (i = 0; i < fill; i++) { - if (!laxp ? EQ (k, keys [i]) : internal_equal (k, keys [i], depth)) + if (!laxp ? EQ (k, keys [i]) : + internal_equal_0 (k, keys [i], depth, foldcase)) { if (eqp /* We narrowly escaped being Ebolified here. */ ? !EQ_WITH_EBOLA_NOTICE (v, vals [i]) - : !internal_equal (v, vals [i], depth)) + : !internal_equal_0 (v, vals [i], depth, foldcase)) /* a property in B has a different value than in A */ goto MISMATCH; flags [i] = 1; @@ -2067,7 +2069,7 @@ */ (a, b, nil_means_not_present)) { - return (plists_differ (a, b, !NILP (nil_means_not_present), 0, -1) + return (plists_differ (a, b, !NILP (nil_means_not_present), 0, -1, 0) ? Qnil : Qt); } @@ -2084,7 +2086,7 @@ */ (a, b, nil_means_not_present)) { - return (plists_differ (a, b, !NILP (nil_means_not_present), 0, 1) + return (plists_differ (a, b, !NILP (nil_means_not_present), 0, 1, 0) ? Qnil : Qt); } @@ -2104,7 +2106,7 @@ */ (a, b, nil_means_not_present)) { - return (plists_differ (a, b, !NILP (nil_means_not_present), 1, -1) + return (plists_differ (a, b, !NILP (nil_means_not_present), 1, -1, 0) ? Qnil : Qt); } @@ -2123,7 +2125,7 @@ */ (a, b, nil_means_not_present)) { - return (plists_differ (a, b, !NILP (nil_means_not_present), 1, 1) + return (plists_differ (a, b, !NILP (nil_means_not_present), 1, 1, 0) ? Qnil : Qt); } @@ -2845,49 +2847,81 @@ return (imp1 == imp2) && /* EQ-ness of the objects was noticed above */ - (imp1->equal && (imp1->equal) (obj1, obj2, depth)); + (imp1->equal && (imp1->equal) (obj1, obj2, depth, 0)); } return 0; } +enum array_type + { + ARRAY_NONE = 0, + ARRAY_STRING, + ARRAY_VECTOR, + ARRAY_BIT_VECTOR + }; + +static enum array_type +array_type (Lisp_Object obj) +{ + if (STRINGP (obj)) + return ARRAY_STRING; + if (VECTORP (obj)) + return ARRAY_VECTOR; + if (BIT_VECTORP (obj)) + return ARRAY_BIT_VECTOR; + return ARRAY_NONE; +} + int internal_equalp (Lisp_Object obj1, Lisp_Object obj2, int depth) { if (depth > 200) stack_overflow ("Stack overflow in equalp", Qunbound); QUIT; + + /* 1. Objects that are `eq' are equal. This will catch the common case + of two equal fixnums or the same object seen twice. */ if (EQ_WITH_EBOLA_NOTICE (obj1, obj2)) return 1; -#ifdef WITH_NUMBER_TYPES + + /* 2. If both numbers, compare with `='. */ if (NUMBERP (obj1) && NUMBERP (obj2)) { - switch (promote_args (&obj1, &obj2)) - { - case FIXNUM_T: - return XREALINT (obj1) == XREALINT (obj2); -#ifdef HAVE_BIGNUM - case BIGNUM_T: - return bignum_eql (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2)); -#endif -#ifdef HAVE_RATIO - case RATIO_T: - return ratio_eql (XRATIO_DATA (obj1), XRATIO_DATA (obj2)); -#endif - case FLOAT_T: - return XFLOAT_DATA (obj1) == XFLOAT_DATA (obj2); -#ifdef HAVE_BIGFLOAT - case BIGFLOAT_T: - return bigfloat_eql (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2)); -#endif - } + Lisp_Object args[2]; + args[0] = obj1; + args[1] = obj2; + return !NILP (Feqlsign (2, args)); } -#else - if ((INTP (obj1) && FLOATP (obj2)) || (FLOATP (obj1) && INTP (obj2))) - return extract_float (obj1) == extract_float (obj2); -#endif + + /* 3. If characters, compare case-insensitively. */ if (CHARP (obj1) && CHARP (obj2)) return DOWNCASE (0, XCHAR (obj1)) == DOWNCASE (0, XCHAR (obj2)); + + /* 4. If arrays of different types, compare their lengths, and + then compare element-by-element. */ + { + enum array_type artype1, artype2; + artype1 = array_type (obj1); + artype2 = array_type (obj2); + if (artype1 != artype2 && artype1 && artype2) + { + EMACS_INT i; + EMACS_INT l1 = XINT (Flength (obj1)); + EMACS_INT l2 = XINT (Flength (obj2)); + /* Both arrays, but of different types */ + if (l1 != l2) + return 0; + for (i = 0; i < l1; i++) + if (!internal_equalp (Faref (obj1, make_int (i)), + Faref (obj2, make_int (i)), depth + 1)) + return 0; + return 1; + } + } + /* 5. Else, they must be the same type. If so, call the equal() method, + telling it to fold case. For objects that care about case-folding + their contents, the equal() method will call internal_equal_0(). */ if (XTYPE (obj1) != XTYPE (obj2)) return 0; if (LRECORDP (obj1)) @@ -2896,16 +2930,23 @@ *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1), *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2); - /* #### not yet implemented properly, needs another flag to specify - equalp-ness */ return (imp1 == imp2) && /* EQ-ness of the objects was noticed above */ - (imp1->equal && (imp1->equal) (obj1, obj2, depth)); + (imp1->equal && (imp1->equal) (obj1, obj2, depth, 1)); } return 0; } +int +internal_equal_0 (Lisp_Object obj1, Lisp_Object obj2, int depth, int foldcase) +{ + if (foldcase) + return internal_equalp (obj1, obj2, depth); + else + return internal_equal (obj1, obj2, depth); +} + /* Note that we may be calling sub-objects that will use internal_equal() (instead of internal_old_equal()). Oh well. We will get an Ebola note if there's any possibility of confusion, @@ -2938,6 +2979,37 @@ return internal_equal (object1, object2, 0) ? Qt : Qnil; } +DEFUN ("equalp", Fequalp, 2, 2, 0, /* +Return t if two Lisp objects have similar structure and contents. + +This is like `equal', except that it accepts numerically equal +numbers of different types (float, integer, bignum, bigfloat), and also +compares strings and characters case-insensitively. + +Type objects that are arrays (that is, strings, bit-vectors, and vectors) +of the same length and with contents that are `equalp' are themselves +`equalp', regardless of whether the two objects have the same type. + +Other objects whose primary purpose is as containers of other objects are +`equalp' if they would otherwise be equal (same length, type, etc.) and +their contents are `equalp'. This goes for conses, weak lists, +weak boxes, ephemerons, specifiers, hash tables, char tables and range +tables. However, objects that happen to contain other objects but are not +primarily designed for this purpose (e.g. compiled functions, events or +display-related objects such as glyphs, faces or extents) are currently +compared using `equalp' the same way as using `equal'. + +More specifically, two hash tables are `equalp' if they have the same test +(see `hash-table-test'), the same number of entries, and the same value for +`hash-table-weakness', and if, for each entry in one hash table, its key is +equivalent to a key in the other hash table using the hash table test, and +its value is `equalp' to the other hash table's value for that key. +*/ + (object1, object2)) +{ + return internal_equalp (object1, object2, 0) ? Qt : Qnil; +} + DEFUN ("old-equal", Fold_equal, 2, 2, 0, /* Return t if two Lisp objects have similar structure and contents. They must have the same data type. @@ -4106,6 +4178,7 @@ DEFSUBR (Fremprop); DEFSUBR (Fobject_plist); DEFSUBR (Fequal); + DEFSUBR (Fequalp); DEFSUBR (Fold_equal); DEFSUBR (Ffillarray); DEFSUBR (Fnconc);