Mercurial > hg > xemacs-beta

comparison src/fns.c @ 4906:6ef8256a020a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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
comparison
equal deleted inserted replaced
4903:70089046adef 4906:6ef8256a020a
93 if (last != len) 93 if (last != len)
94 write_c_string (printcharfun, "..."); 94 write_c_string (printcharfun, "...");
95 } 95 }
96 96
97 static int 97 static int
98 bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth)) 98 bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth),
99 int UNUSED (foldcase))
99 { 100 {
100 Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1); 101 Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1);
101 Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2); 102 Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2);
102 103
103 return ((bit_vector_length (v1) == bit_vector_length (v2)) && 104 return ((bit_vector_length (v1) == bit_vector_length (v2)) &&
1980 NIL_MEANS_NOT_PRESENT is as in `plists-eq' etc. 1981 NIL_MEANS_NOT_PRESENT is as in `plists-eq' etc.
1981 LAXP means use `equal' for comparisons. 1982 LAXP means use `equal' for comparisons.
1982 */ 1983 */
1983 int 1984 int
1984 plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present, 1985 plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present,
1985 int laxp, int depth) 1986 int laxp, int depth, int foldcase)
1986 { 1987 {
1987 int eqp = (depth == -1); /* -1 as depth means use eq, not equal. */ 1988 int eqp = (depth == -1); /* -1 as depth means use eq, not equal. */
1988 int la, lb, m, i, fill; 1989 int la, lb, m, i, fill;
1989 Lisp_Object *keys, *vals; 1990 Lisp_Object *keys, *vals;
1990 char *flags; 1991 char *flags;
2024 Lisp_Object v = XCAR (XCDR (rest)); 2025 Lisp_Object v = XCAR (XCDR (rest));
2025 /* Maybe be Ebolified. */ 2026 /* Maybe be Ebolified. */
2026 if (nil_means_not_present && NILP (v)) continue; 2027 if (nil_means_not_present && NILP (v)) continue;
2027 for (i = 0; i < fill; i++) 2028 for (i = 0; i < fill; i++)
2028 { 2029 {
2029 if (!laxp ? EQ (k, keys [i]) : internal_equal (k, keys [i], depth)) 2030 if (!laxp ? EQ (k, keys [i]) :
2031 internal_equal_0 (k, keys [i], depth, foldcase))
2030 { 2032 {
2031 if (eqp 2033 if (eqp
2032 /* We narrowly escaped being Ebolified here. */ 2034 /* We narrowly escaped being Ebolified here. */
2033 ? !EQ_WITH_EBOLA_NOTICE (v, vals [i]) 2035 ? !EQ_WITH_EBOLA_NOTICE (v, vals [i])
2034 : !internal_equal (v, vals [i], depth)) 2036 : !internal_equal_0 (v, vals [i], depth, foldcase))
2035 /* a property in B has a different value than in A */ 2037 /* a property in B has a different value than in A */
2036 goto MISMATCH; 2038 goto MISMATCH;
2037 flags [i] = 1; 2039 flags [i] = 1;
2038 break; 2040 break;
2039 } 2041 }
2065 old Lisp implementations, but should not be used except for backward 2067 old Lisp implementations, but should not be used except for backward
2066 compatibility. 2068 compatibility.
2067 */ 2069 */
2068 (a, b, nil_means_not_present)) 2070 (a, b, nil_means_not_present))
2069 { 2071 {
2070 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, -1) 2072 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, -1, 0)
2071 ? Qnil : Qt); 2073 ? Qnil : Qt);
2072 } 2074 }
2073 2075
2074 DEFUN ("plists-equal", Fplists_equal, 2, 3, 0, /* 2076 DEFUN ("plists-equal", Fplists_equal, 2, 3, 0, /*
2075 Return non-nil if property lists A and B are `equal'. 2077 Return non-nil if property lists A and B are `equal'.
2082 old Lisp implementations, but should not be used except for backward 2084 old Lisp implementations, but should not be used except for backward
2083 compatibility. 2085 compatibility.
2084 */ 2086 */
2085 (a, b, nil_means_not_present)) 2087 (a, b, nil_means_not_present))
2086 { 2088 {
2087 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, 1) 2089 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, 1, 0)
2088 ? Qnil : Qt); 2090 ? Qnil : Qt);
2089 } 2091 }
2090 2092
2091 2093
2092 DEFUN ("lax-plists-eq", Flax_plists_eq, 2, 3, 0, /* 2094 DEFUN ("lax-plists-eq", Flax_plists_eq, 2, 3, 0, /*
2102 old Lisp implementations, but should not be used except for backward 2104 old Lisp implementations, but should not be used except for backward
2103 compatibility. 2105 compatibility.
2104 */ 2106 */
2105 (a, b, nil_means_not_present)) 2107 (a, b, nil_means_not_present))
2106 { 2108 {
2107 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, -1) 2109 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, -1, 0)
2108 ? Qnil : Qt); 2110 ? Qnil : Qt);
2109 } 2111 }
2110 2112
2111 DEFUN ("lax-plists-equal", Flax_plists_equal, 2, 3, 0, /* 2113 DEFUN ("lax-plists-equal", Flax_plists_equal, 2, 3, 0, /*
2112 Return non-nil if lax property lists A and B are `equal'. 2114 Return non-nil if lax property lists A and B are `equal'.
2121 old Lisp implementations, but should not be used except for backward 2123 old Lisp implementations, but should not be used except for backward
2122 compatibility. 2124 compatibility.
2123 */ 2125 */
2124 (a, b, nil_means_not_present)) 2126 (a, b, nil_means_not_present))
2125 { 2127 {
2126 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, 1) 2128 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, 1, 0)
2127 ? Qnil : Qt); 2129 ? Qnil : Qt);
2128 } 2130 }
2129 2131
2130 /* Return the value associated with key PROPERTY in property list PLIST. 2132 /* Return the value associated with key PROPERTY in property list PLIST.
2131 Return nil if key not found. This function is used for internal 2133 Return nil if key not found. This function is used for internal
2843 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1), 2845 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
2844 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2); 2846 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
2845 2847
2846 return (imp1 == imp2) && 2848 return (imp1 == imp2) &&
2847 /* EQ-ness of the objects was noticed above */ 2849 /* EQ-ness of the objects was noticed above */
2848 (imp1->equal && (imp1->equal) (obj1, obj2, depth)); 2850 (imp1->equal && (imp1->equal) (obj1, obj2, depth, 0));
2849 } 2851 }
2850 2852
2851 return 0; 2853 return 0;
2854 }
2855
2856 enum array_type
2857 {
2858 ARRAY_NONE = 0,
2859 ARRAY_STRING,
2860 ARRAY_VECTOR,
2861 ARRAY_BIT_VECTOR
2862 };
2863
2864 static enum array_type
2865 array_type (Lisp_Object obj)
2866 {
2867 if (STRINGP (obj))
2868 return ARRAY_STRING;
2869 if (VECTORP (obj))
2870 return ARRAY_VECTOR;
2871 if (BIT_VECTORP (obj))
2872 return ARRAY_BIT_VECTOR;
2873 return ARRAY_NONE;
2852 } 2874 }
2853 2875
2854 int 2876 int
2855 internal_equalp (Lisp_Object obj1, Lisp_Object obj2, int depth) 2877 internal_equalp (Lisp_Object obj1, Lisp_Object obj2, int depth)
2856 { 2878 {
2857 if (depth > 200) 2879 if (depth > 200)
2858 stack_overflow ("Stack overflow in equalp", Qunbound); 2880 stack_overflow ("Stack overflow in equalp", Qunbound);
2859 QUIT; 2881 QUIT;
2882
2883 /* 1. Objects that are `eq' are equal. This will catch the common case
2884 of two equal fixnums or the same object seen twice. */
2860 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2)) 2885 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2))
2861 return 1; 2886 return 1;
2862 #ifdef WITH_NUMBER_TYPES 2887
2888 /* 2. If both numbers, compare with `='. */
2863 if (NUMBERP (obj1) && NUMBERP (obj2)) 2889 if (NUMBERP (obj1) && NUMBERP (obj2))
2864 { 2890 {
2865 switch (promote_args (&obj1, &obj2)) 2891 Lisp_Object args[2];
2866 { 2892 args[0] = obj1;
2867 case FIXNUM_T: 2893 args[1] = obj2;
2868 return XREALINT (obj1) == XREALINT (obj2); 2894 return !NILP (Feqlsign (2, args));
2869 #ifdef HAVE_BIGNUM 2895 }
2870 case BIGNUM_T: 2896
2871 return bignum_eql (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2)); 2897 /* 3. If characters, compare case-insensitively. */
2872 #endif
2873 #ifdef HAVE_RATIO
2874 case RATIO_T:
2875 return ratio_eql (XRATIO_DATA (obj1), XRATIO_DATA (obj2));
2876 #endif
2877 case FLOAT_T:
2878 return XFLOAT_DATA (obj1) == XFLOAT_DATA (obj2);
2879 #ifdef HAVE_BIGFLOAT
2880 case BIGFLOAT_T:
2881 return bigfloat_eql (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2));
2882 #endif
2883 }
2884 }
2885 #else
2886 if ((INTP (obj1) && FLOATP (obj2)) || (FLOATP (obj1) && INTP (obj2)))
2887 return extract_float (obj1) == extract_float (obj2);
2888 #endif
2889 if (CHARP (obj1) && CHARP (obj2)) 2898 if (CHARP (obj1) && CHARP (obj2))
2890 return DOWNCASE (0, XCHAR (obj1)) == DOWNCASE (0, XCHAR (obj2)); 2899 return DOWNCASE (0, XCHAR (obj1)) == DOWNCASE (0, XCHAR (obj2));
2900
2901 /* 4. If arrays of different types, compare their lengths, and
2902 then compare element-by-element. */
2903 {
2904 enum array_type artype1, artype2;
2905 artype1 = array_type (obj1);
2906 artype2 = array_type (obj2);
2907 if (artype1 != artype2 && artype1 && artype2)
2908 {
2909 EMACS_INT i;
2910 EMACS_INT l1 = XINT (Flength (obj1));
2911 EMACS_INT l2 = XINT (Flength (obj2));
2912 /* Both arrays, but of different types */
2913 if (l1 != l2)
2914 return 0;
2915 for (i = 0; i < l1; i++)
2916 if (!internal_equalp (Faref (obj1, make_int (i)),
2917 Faref (obj2, make_int (i)), depth + 1))
2918 return 0;
2919 return 1;
2920 }
2921 }
2922 /* 5. Else, they must be the same type. If so, call the equal() method,
2923 telling it to fold case. For objects that care about case-folding
2924 their contents, the equal() method will call internal_equal_0(). */
2891 if (XTYPE (obj1) != XTYPE (obj2)) 2925 if (XTYPE (obj1) != XTYPE (obj2))
2892 return 0; 2926 return 0;
2893 if (LRECORDP (obj1)) 2927 if (LRECORDP (obj1))
2894 { 2928 {
2895 const struct lrecord_implementation 2929 const struct lrecord_implementation
2896 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1), 2930 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
2897 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2); 2931 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
2898 2932
2899 /* #### not yet implemented properly, needs another flag to specify
2900 equalp-ness */
2901 return (imp1 == imp2) && 2933 return (imp1 == imp2) &&
2902 /* EQ-ness of the objects was noticed above */ 2934 /* EQ-ness of the objects was noticed above */
2903 (imp1->equal && (imp1->equal) (obj1, obj2, depth)); 2935 (imp1->equal && (imp1->equal) (obj1, obj2, depth, 1));
2904 } 2936 }
2905 2937
2906 return 0; 2938 return 0;
2939 }
2940
2941 int
2942 internal_equal_0 (Lisp_Object obj1, Lisp_Object obj2, int depth, int foldcase)
2943 {
2944 if (foldcase)
2945 return internal_equalp (obj1, obj2, depth);
2946 else
2947 return internal_equal (obj1, obj2, depth);
2907 } 2948 }
2908 2949
2909 /* Note that we may be calling sub-objects that will use 2950 /* Note that we may be calling sub-objects that will use
2910 internal_equal() (instead of internal_old_equal()). Oh well. 2951 internal_equal() (instead of internal_old_equal()). Oh well.
2911 We will get an Ebola note if there's any possibility of confusion, 2952 We will get an Ebola note if there's any possibility of confusion,
2934 Numbers are compared by value. Symbols must match exactly. 2975 Numbers are compared by value. Symbols must match exactly.
2935 */ 2976 */
2936 (object1, object2)) 2977 (object1, object2))
2937 { 2978 {
2938 return internal_equal (object1, object2, 0) ? Qt : Qnil; 2979 return internal_equal (object1, object2, 0) ? Qt : Qnil;
2980 }
2981
2982 DEFUN ("equalp", Fequalp, 2, 2, 0, /*
2983 Return t if two Lisp objects have similar structure and contents.
2984
2985 This is like `equal', except that it accepts numerically equal
2986 numbers of different types (float, integer, bignum, bigfloat), and also
2987 compares strings and characters case-insensitively.
2988
2989 Type objects that are arrays (that is, strings, bit-vectors, and vectors)
2990 of the same length and with contents that are `equalp' are themselves
2991 `equalp', regardless of whether the two objects have the same type.
2992
2993 Other objects whose primary purpose is as containers of other objects are
2994 `equalp' if they would otherwise be equal (same length, type, etc.) and
2995 their contents are `equalp'. This goes for conses, weak lists,
2996 weak boxes, ephemerons, specifiers, hash tables, char tables and range
2997 tables. However, objects that happen to contain other objects but are not
2998 primarily designed for this purpose (e.g. compiled functions, events or
2999 display-related objects such as glyphs, faces or extents) are currently
3000 compared using `equalp' the same way as using `equal'.
3001
3002 More specifically, two hash tables are `equalp' if they have the same test
3003 (see `hash-table-test'), the same number of entries, and the same value for
3004 `hash-table-weakness', and if, for each entry in one hash table, its key is
3005 equivalent to a key in the other hash table using the hash table test, and
3006 its value is `equalp' to the other hash table's value for that key.
3007 */
3008 (object1, object2))
3009 {
3010 return internal_equalp (object1, object2, 0) ? Qt : Qnil;
2939 } 3011 }
2940 3012
2941 DEFUN ("old-equal", Fold_equal, 2, 2, 0, /* 3013 DEFUN ("old-equal", Fold_equal, 2, 2, 0, /*
2942 Return t if two Lisp objects have similar structure and contents. 3014 Return t if two Lisp objects have similar structure and contents.
2943 They must have the same data type. 3015 They must have the same data type.
4104 DEFSUBR (Fget); 4176 DEFSUBR (Fget);
4105 DEFSUBR (Fput); 4177 DEFSUBR (Fput);
4106 DEFSUBR (Fremprop); 4178 DEFSUBR (Fremprop);
4107 DEFSUBR (Fobject_plist); 4179 DEFSUBR (Fobject_plist);
4108 DEFSUBR (Fequal); 4180 DEFSUBR (Fequal);
4181 DEFSUBR (Fequalp);
4109 DEFSUBR (Fold_equal); 4182 DEFSUBR (Fold_equal);
4110 DEFSUBR (Ffillarray); 4183 DEFSUBR (Ffillarray);
4111 DEFSUBR (Fnconc); 4184 DEFSUBR (Fnconc);
4112 DEFSUBR (Fmapcar); 4185 DEFSUBR (Fmapcar);
4113 DEFSUBR (Fmapvector); 4186 DEFSUBR (Fmapvector);