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);