scratch/sort-key 72d4e3a9d26 01/11: Add value< (bug#69709)

[Mattias Engdegård]

branch: scratch/sort-key
commit 72d4e3a9d26c5a19b7263359107eb4bff4527da2
Author: Mattias Engdegård <mattiase@acm.org>
Commit: Mattias Engdegård <mattiase@acm.org>

    Add value< (bug#69709)
    
    It's a general-purpose polymorphic ordering function, like `<` but
    for any two values of the same type.
    
    * src/data.c (syms_of_data): Add the `type-mismatch` error.
    * src/fns.c (Fstring_lessp): Extract the bulk of this function to...
    (string_cmp): ...this 3-way comparison function, for use elsewhere.
    (value_cmp, Fvaluelt): New.
    * test/src/fns-tests.el (fns-value<-ordered, fns-value<-unordered)
    (fns-value<-type-mismatch, fns-value<-symbol-with-pos)
    (fns-value<-circle): New tests.
---
 src/data.c            |   2 +
 src/fns.c             | 258 ++++++++++++++++++++++++++++++++++++++++++++++----
 test/src/fns-tests.el | 179 ++++++++++++++++++++++++++++++++++
 3 files changed, 418 insertions(+), 21 deletions(-)

diff --git a/src/data.c b/src/data.c
index 69b990bed76..600cefce96a 100644
--- a/src/data.c
+++ b/src/data.c
@@ -4072,6 +4072,7 @@ syms_of_data (void)
   DEFSYM (Qminibuffer_quit, "minibuffer-quit");
   DEFSYM (Qwrong_length_argument, "wrong-length-argument");
   DEFSYM (Qwrong_type_argument, "wrong-type-argument");
+  DEFSYM (Qtype_mismatch, "type-mismatch")
   DEFSYM (Qargs_out_of_range, "args-out-of-range");
   DEFSYM (Qvoid_function, "void-function");
   DEFSYM (Qcyclic_function_indirection, "cyclic-function-indirection");
@@ -4163,6 +4164,7 @@ syms_of_data (void)
   PUT_ERROR (Quser_error, error_tail, "");
   PUT_ERROR (Qwrong_length_argument, error_tail, "Wrong length argument");
   PUT_ERROR (Qwrong_type_argument, error_tail, "Wrong type argument");
+  PUT_ERROR (Qtype_mismatch, error_tail, "Types do not match");
   PUT_ERROR (Qargs_out_of_range, error_tail, "Args out of range");
   PUT_ERROR (Qvoid_function, error_tail,
             "Symbol's function definition is void");
diff --git a/src/fns.c b/src/fns.c
index 0a64e515402..1ec8676f231 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -27,6 +27,7 @@ along with GNU Emacs.  If not, see 
<https://www.gnu.org/licenses/>.  */
 #include <vla.h>
 #include <errno.h>
 #include <ctype.h>
+#include <math.h>
 
 #include "lisp.h"
 #include "bignum.h"
@@ -466,21 +467,10 @@ load_unaligned_size_t (const void *p)
   return x;
 }
 
-DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
-       doc: /* Return non-nil if STRING1 is less than STRING2 in lexicographic 
order.
-Case is significant.
-Symbols are also allowed; their print names are used instead.  */)
-  (Lisp_Object string1, Lisp_Object string2)
+/* Return -1/0/1 to indicate the relation </=/> between string1 and string2.  
*/
+static int
+string_cmp (Lisp_Object string1, Lisp_Object string2)
 {
-  if (SYMBOLP (string1))
-    string1 = SYMBOL_NAME (string1);
-  else
-    CHECK_STRING (string1);
-  if (SYMBOLP (string2))
-    string2 = SYMBOL_NAME (string2);
-  else
-    CHECK_STRING (string2);
-
   ptrdiff_t n = min (SCHARS (string1), SCHARS (string2));
 
   if ((!STRING_MULTIBYTE (string1) || SCHARS (string1) == SBYTES (string1))
@@ -489,7 +479,9 @@ Symbols are also allowed; their print names are used 
instead.  */)
       /* Each argument is either unibyte or all-ASCII multibyte:
         we can compare bytewise.  */
       int d = memcmp (SSDATA (string1), SSDATA (string2), n);
-      return d < 0 || (d == 0 && n < SCHARS (string2)) ? Qt : Qnil;
+      if (d)
+       return d;
+      return n < SCHARS (string2) ? -1 : n > SCHARS (string2);
     }
   else if (STRING_MULTIBYTE (string1) && STRING_MULTIBYTE (string2))
     {
@@ -523,7 +515,7 @@ Symbols are also allowed; their print names are used 
instead.  */)
 
       if (b >= nb)
        /* One string is a prefix of the other.  */
-       return b < nb2 ? Qt : Qnil;
+       return b < nb2 ? -1 : b > nb2;
 
       /* Now back up to the start of the differing characters:
         it's the last byte not having the bit pattern 10xxxxxx.  */
@@ -535,7 +527,7 @@ Symbols are also allowed; their print names are used 
instead.  */)
       ptrdiff_t i1_byte = b, i2_byte = b;
       int c1 = fetch_string_char_advance_no_check (string1, &i1, &i1_byte);
       int c2 = fetch_string_char_advance_no_check (string2, &i2, &i2_byte);
-      return c1 < c2 ? Qt : Qnil;
+      return c1 < c2 ? -1 : c1 > c2;
     }
   else if (STRING_MULTIBYTE (string1))
     {
@@ -546,9 +538,9 @@ Symbols are also allowed; their print names are used 
instead.  */)
          int c1 = fetch_string_char_advance_no_check (string1, &i1, &i1_byte);
          int c2 = SREF (string2, i2++);
          if (c1 != c2)
-           return c1 < c2 ? Qt : Qnil;
+           return c1 < c2 ? -1 : 1;
        }
-      return i1 < SCHARS (string2) ? Qt : Qnil;
+      return i1 < SCHARS (string2) ? -1 : i1 > SCHARS (string2);
     }
   else
     {
@@ -559,12 +551,30 @@ Symbols are also allowed; their print names are used 
instead.  */)
          int c1 = SREF (string1, i1++);
          int c2 = fetch_string_char_advance_no_check (string2, &i2, &i2_byte);
          if (c1 != c2)
-           return c1 < c2 ? Qt : Qnil;
+           return c1 < c2 ? -1 : 1;
        }
-      return i1 < SCHARS (string2) ? Qt : Qnil;
+      return i1 < SCHARS (string2) ? -1 : i1 > SCHARS (string2);
     }
 }
 
+DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
+       doc: /* Return non-nil if STRING1 is less than STRING2 in lexicographic 
order.
+Case is significant.
+Symbols are also allowed; their print names are used instead.  */)
+  (Lisp_Object string1, Lisp_Object string2)
+{
+  if (SYMBOLP (string1))
+    string1 = SYMBOL_NAME (string1);
+  else
+    CHECK_STRING (string1);
+  if (SYMBOLP (string2))
+    string2 = SYMBOL_NAME (string2);
+  else
+    CHECK_STRING (string2);
+
+  return string_cmp (string1, string2) < 0 ? Qt : Qnil;
+}
+
 DEFUN ("string-version-lessp", Fstring_version_lessp,
        Sstring_version_lessp, 2, 2, 0,
        doc: /* Return non-nil if S1 is less than S2, as version strings.
@@ -2908,6 +2918,211 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum 
equal_kind equal_kind,
 
   return false;
 }
+
+
+/* Return -1, 0 or 1 to indicate whether a<b, a=b or a>b in the sense of 
value<.
+   In particular 0 does not mean equality in the sense of Fequal, only
+   that the arguments cannot be ordered yet they can be compared (same
+   type).  */
+static int
+value_cmp (Lisp_Object a, Lisp_Object b, int maxdepth)
+{
+  if (maxdepth < 0)
+    error ("Maximum depth exceeded in comparison");
+
+ tail_recurse:
+  /* Shortcut for a common case.  */
+  if (BASE_EQ (a, b))
+    return 0;
+
+  switch (XTYPE (a))
+    {
+    case_Lisp_Int:
+      {
+       EMACS_INT ia = XFIXNUM (a);
+       if (FIXNUMP (b))
+         return ia < XFIXNUM (b) ? -1 : 1;   /* we know that a≠b */
+       if (FLOATP (b))
+         return ia < XFLOAT_DATA (b) ? -1 : ia > XFLOAT_DATA (b);
+       if (BIGNUMP (b))
+         return -mpz_sgn (*xbignum_val (b));
+      }
+      goto type_mismatch;
+
+    case Lisp_Symbol:
+      if (BARE_SYMBOL_P (b))
+       return string_cmp (XBARE_SYMBOL (a)->u.s.name,
+                          XBARE_SYMBOL (b)->u.s.name);
+      if (CONSP (b) && NILP (a))
+       return -1;
+      if (SYMBOLP (b))
+       /* Slow-path branch when B is a symbol-with-pos.  */
+       return string_cmp (XBARE_SYMBOL (a)->u.s.name, XSYMBOL (b)->u.s.name);
+      goto type_mismatch;
+
+    case Lisp_String:
+      if (STRINGP (b))
+       return string_cmp (a, b);
+      goto type_mismatch;
+
+    case Lisp_Cons:
+      /* FIXME: Optimise for difference in the first element? */
+      FOR_EACH_TAIL (b)
+       {
+         int cmp = value_cmp (XCAR (a), XCAR (b), maxdepth - 1);
+         if (cmp != 0)
+           return cmp;
+         a = XCDR (a);
+         if (!CONSP (a))
+           {
+             b = XCDR (b);
+             goto tail_recurse;
+           }
+       }
+      if (NILP (b))
+       return 1;
+      else
+       goto type_mismatch;
+      goto tail_recurse;
+
+    case Lisp_Vectorlike:
+      if (VECTORLIKEP (b))
+       {
+         enum pvec_type ta = PSEUDOVECTOR_TYPE (XVECTOR (a));
+         enum pvec_type tb = PSEUDOVECTOR_TYPE (XVECTOR (b));
+         if (ta == tb)
+           switch (ta)
+             {
+             case PVEC_NORMAL_VECTOR:
+             case PVEC_RECORD:
+               {
+                 ptrdiff_t len_a = ASIZE (a);
+                 ptrdiff_t len_b = ASIZE (b);
+                 if (ta == PVEC_RECORD)
+                   {
+                     len_a &= PSEUDOVECTOR_SIZE_MASK;
+                     len_b &= PSEUDOVECTOR_SIZE_MASK;
+                   }
+                 ptrdiff_t len_min = min (len_a, len_b);
+                 for (ptrdiff_t i = 0; i < len_min; i++)
+                   {
+                     int cmp = value_cmp (AREF (a, i), AREF (b, i),
+                                          maxdepth - 1);
+                     if (cmp != 0)
+                       return cmp;
+                   }
+                 return len_a < len_b ? -1 : len_a > len_b;
+               }
+
+             case PVEC_BOOL_VECTOR:
+               {
+                 ptrdiff_t len_a = bool_vector_size (a);
+                 ptrdiff_t len_b = bool_vector_size (b);
+                 ptrdiff_t len_min = min (len_a, len_b);
+                 /* FIXME: very inefficient, we could compare words.  */
+                 for (ptrdiff_t i = 0; i < len_min; i++)
+                   {
+                     bool ai = bool_vector_bitref (a, i);
+                     bool bi = bool_vector_bitref (b, i);
+                     if (ai != bi)
+                       return bi ? -1 : ai;
+                   }
+                 return len_a < len_b ? -1 : len_a > len_b;
+               }
+
+             case PVEC_MARKER:
+               {
+                 Lisp_Object buf_a = Fmarker_buffer (a);
+                 Lisp_Object buf_b = Fmarker_buffer (b);
+                 if (NILP (buf_a))
+                   return NILP (buf_b) ? 0 : -1;
+                 if (NILP (buf_b))
+                   return 1;
+                 int cmp = value_cmp (buf_a, buf_b, maxdepth - 1);
+                 if (cmp != 0)
+                   return cmp;
+                 ptrdiff_t pa = XMARKER (a)->charpos;
+                 ptrdiff_t pb = XMARKER (b)->charpos;
+                 return pa < pb ? -1 : pa > pb;
+               }
+
+             case PVEC_PROCESS:
+               return value_cmp (Fprocess_name (a), Fprocess_name (b),
+                                 maxdepth - 1);
+             case PVEC_BUFFER:
+               {
+                 /* Killed buffers lack names and sort before those alive.  */
+                 Lisp_Object na = Fbuffer_name (a);
+                 Lisp_Object nb = Fbuffer_name (b);
+                 if (NILP (na))
+                   return NILP (nb) ? 0 : -1;
+                 if (NILP (nb))
+                   return 1;
+                 return value_cmp (na, nb, maxdepth - 1);
+               }
+
+             case PVEC_BIGNUM:
+               return mpz_cmp (*xbignum_val (a), *xbignum_val (b));
+
+             case PVEC_SYMBOL_WITH_POS:
+               /* Compare by name, enabled or not.  */
+               a = XSYMBOL_WITH_POS_SYM (a);
+               b = XSYMBOL_WITH_POS_SYM (b);
+               goto tail_recurse;
+
+             default:
+               /* Treat other types as unordered.  */
+               return 0;
+             }
+       }
+      else if (BIGNUMP (a))
+       return -value_cmp (b, a, maxdepth);
+      else if (SYMBOL_WITH_POS_P (a) && symbols_with_pos_enabled)
+       {
+         a = XSYMBOL_WITH_POS_SYM (a);
+         goto tail_recurse;
+       }
+
+      goto type_mismatch;
+
+    case Lisp_Float:
+      {
+       double fa = XFLOAT_DATA (a);
+       if (FLOATP (b))
+         return fa < XFLOAT_DATA (b) ? -1 : fa > XFLOAT_DATA (b);
+       if (FIXNUMP (b))
+         return fa < XFIXNUM (b) ? -1 : fa > XFIXNUM (b);
+       if (BIGNUMP (b))
+         {
+           if (isnan (fa))
+             return 0;
+           return -mpz_cmp_d (*xbignum_val (b), fa);
+         }
+      }
+      goto type_mismatch;
+
+    default:
+      eassume (0);
+    }
+ type_mismatch:
+  xsignal2 (Qtype_mismatch, a, b);
+}
+
+DEFUN ("value<", Fvaluelt, Svaluelt, 2, 2, 0,
+       doc: /* Return non-nil if A precedes B in standard value order.
+A and B must have the same basic type.
+Numbers are compared with `<'.
+Strings and symbols are compared with `string-lessp'.
+Lists, vectors, bool-vectors and records are compared lexicographically.
+Markers are compared lexicographically by buffer and position.
+Buffers and processes are compared by name.
+Other types are considered unordered and the return value will be `nil'.  */)
+  (Lisp_Object a, Lisp_Object b)
+{
+  int maxdepth = 20;             /* FIXME: arbitrary value */
+  return value_cmp (a, b, maxdepth) < 0 ? Qt : Qnil;
+}
+
 
 
 DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0,
@@ -6589,6 +6804,7 @@ For best results this should end in a space.  */);
   defsubr (&Seql);
   defsubr (&Sequal);
   defsubr (&Sequal_including_properties);
+  defsubr (&Svaluelt);
   defsubr (&Sfillarray);
   defsubr (&Sclear_string);
   defsubr (&Snconc);
diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el
index 7437c07f156..025e09cb755 100644
--- a/test/src/fns-tests.el
+++ b/test/src/fns-tests.el
@@ -1513,4 +1513,183 @@
   (should-error (copy-alist "abc")
                 :type 'wrong-type-argument))
 
+(ert-deftest fns-value<-ordered ()
+  ;; values (X . Y) where X<Y
+  (let* ((big (* 10 most-positive-fixnum))
+         (buf1 (get-buffer-create " *one*"))
+         (buf2 (get-buffer-create " *two*"))
+         (buf3 (get-buffer-create " *three*"))
+         (_ (progn (with-current-buffer buf1 (insert (make-string 20 ?a)))
+                   (with-current-buffer buf2 (insert (make-string 20 ?b)))))
+         (mark1 (set-marker (make-marker) 12 buf1))
+         (mark2 (set-marker (make-marker) 13 buf1))
+         (mark3 (set-marker (make-marker) 12 buf2))
+         (mark4 (set-marker (make-marker) 13 buf2))
+         (proc1 (make-pipe-process :name " *proc one*"))
+         (proc2 (make-pipe-process :name " *proc two*")))
+    (kill-buffer buf3)
+    (unwind-protect
+        (dolist (c
+                 `(
+                   ;; fixnums
+                   (1 . 2)  (-2 . -1) (-2 . 1) (-1 . 2)
+                   ;; bignums
+                   (,big . ,(1+ big)) (,(- big) . ,big)
+                   (,(- -1 big) . ,(- big))
+                   ;; fixnums/bignums
+                   (1 . ,big) (-1 . ,big) (,(- big) . -1) (,(- big) . 1)
+                   ;; floats
+                   (1.5 . 1.6) (-1.3 . -1.2) (-13.0 . 12.0)
+                   ;; floats/fixnums
+                   (1 . 1.1) (1.9 . 2) (-2.0 . 1) (-2 . 1.0)
+                   ;; floats/bignums
+                   (,big . ,(float (* 2 big))) (,(float big) . ,(* 2 big))
+                   ;; symbols
+                   (a . b) (nil . nix) (b . ba) (## . a) (A . a)
+                   (#:a . #:b) (a . #:b) (#:a . b)
+                   ;; strings
+                   ("" . "a") ("a" . "b") ("A" . "a") ("abc" . "abd")
+                   ("b" . "ba")
+
+                   ;; lists
+                   ((1 2 3) . (2 3 4)) ((2) . (2 1)) (() . (0))
+                   ((1 2 3) . (1 3)) ((1 2 3) . (1 3 2))
+                   (((b a) (c d) e) . ((b a) (c d) f))
+                   (((b a) (c D) e) . ((b a) (c d) e))
+                   (((b a) (c d () x) e) . ((b a) (c d (1) x) e))
+                   ((1 . 2) . (1 . 3)) ((1 2 . 3) . (1 2 . 4))
+
+                   ;; vectors
+                   ([1 2 3] . [2 3 4]) ([2] . [2 1]) ([] . [0])
+                   ([1 2 3] . [1 3]) ([1 2 3] . [1 3 2])
+                   ([[b a] [c d] e] . [[b a] [c d] f])
+                   ([[b a] [c D] e] . [[b a] [c d] e])
+                   ([[b a] [c d [] x] e] . [[b a] [c d [1] x] e])
+
+                   ;; bool-vectors
+                   (,(bool-vector) . ,(bool-vector nil))
+                   (,(bool-vector nil) . ,(bool-vector t))
+                   (,(bool-vector t nil t nil) . ,(bool-vector t nil t t))
+                   (,(bool-vector t nil t) . ,(bool-vector t nil t nil))
+
+                   ;; records
+                   (#s(a 2 3) . #s(b 3 4)) (#s(b) . #s(b a))
+                   (#s(a 2 3) . #s(a 3)) (#s(a 2 3) . #s(a 3 2))
+                   (#s(#s(b a) #s(c d) e) . #s(#s(b a) #s(c d) f))
+                   (#s(#s(b a) #s(c D) e) . #s(#s(b a) #s(c d) e))
+                   (#s(#s(b a) #s(c d #s(u) x) e)
+                    . #s(#s(b a) #s(c d #s(v) x) e))
+
+                   ;; markers
+                   (,mark1 . ,mark2) (,mark1 . ,mark3) (,mark1 . ,mark4)
+                   (,mark2 . ,mark3) (,mark2 . ,mark4) (,mark3 . ,mark4)
+
+                   ;; buffers
+                   (,buf1 . ,buf2) (,buf3 . ,buf1) (,buf3 . ,buf2)
+
+                   ;; processes
+                   (,proc1 . ,proc2)
+                   ))
+          (let ((x (car c))
+                (y (cdr c)))
+            (should (value< x y))
+            (should-not (value< y x))
+            (should-not (value< x x))
+            (should-not (value< y y))))
+
+      (delete-process proc2)
+      (delete-process proc1)
+      (kill-buffer buf2)
+      (kill-buffer buf1))))
+
+(ert-deftest fns-value<-unordered ()
+  ;; values (X . Y) where neither X<Y nor Y<X
+
+  (let ((buf1 (get-buffer-create " *one*"))
+        (buf2 (get-buffer-create " *two*")))
+    (kill-buffer buf2)
+    (kill-buffer buf1)
+    (dolist (c `(
+                 ;; numbers
+                 (0 . 0.0) (0 . -0.0) (0.0 . -0.0)
+
+                 ;; symbols
+                 (a . #:a)
+
+                 ;; (dead) buffers
+                 (,buf1 . ,buf2)
+
+                 ;; unordered types
+                 (,(make-hash-table) . ,(make-hash-table))
+                 (,(obarray-make) . ,(obarray-make))
+                 ;; FIXME: more?
+                 ))
+      (let ((x (car c))
+            (y (cdr c)))
+        (should-not (value< x y))
+        (should-not (value< y x))))))
+
+(ert-deftest fns-value<-type-mismatch ()
+  ;; values of disjoint (incomparable) types
+  (let ((incomparable
+         `( 1 a "a" (a b) [a b] ,(bool-vector nil t) #s(a b)
+            ,(make-char-table 'test)
+            ,(make-hash-table)
+            ,(obarray-make)
+            ;; FIXME: more?
+            )))
+    (let ((tail incomparable))
+      (while tail
+        (let ((x (car tail)))
+          (dolist (y (cdr tail))
+            (should-error (value< x y) :type 'type-mismatch)
+            (should-error (value< y x) :type 'type-mismatch)))
+        (setq tail (cdr tail))))))
+
+(ert-deftest fns-value<-symbol-with-pos ()
+  ;; values (X . Y) where X<Y
+  (let* ((a-sp-1 (position-symbol 'a 1))
+         (a-sp-2 (position-symbol 'a 2))
+         (b-sp-1 (position-symbol 'b 1))
+         (b-sp-2 (position-symbol 'b 2)))
+
+    (dolist (swp '(nil t))
+      (let ((symbols-with-pos-enabled swp))
+        ;; Enabled or not, they compare by name.
+        (dolist (c `((,a-sp-1 . ,b-sp-1) (,a-sp-1 . ,b-sp-2)
+                     (,a-sp-2 . ,b-sp-1) (,a-sp-2 . ,b-sp-2)))
+          (let ((x (car c))
+                (y (cdr c)))
+            (should (value< x y))
+            (should-not (value< y x))
+            (should-not (value< x x))
+            (should-not (value< y y))))
+        (should-not (value< a-sp-1 a-sp-2))
+        (should-not (value< a-sp-2 a-sp-1))))
+
+    ;; When disabled, symbol-with-pos and symbols do not compare.
+    (should-error (value< a-sp-1 'a) :type 'type-mismatch)
+    (should-error (value< 'a a-sp-1) :type 'type-mismatch)
+
+    (let ((symbols-with-pos-enabled t))
+      ;; When enabled, a symbol-with-pos compares as a plain symbol.
+      (dolist (c `((,a-sp-1 . b) (a . ,b-sp-1)))
+        (let ((x (car c))
+              (y (cdr c)))
+          (should (value< x y))
+          (should-not (value< y x))
+          (should-not (value< x x))
+          (should-not (value< y y))))
+      (should-not (value< a-sp-1 'a))
+      (should-not (value< 'a a-sp-1)))))
+
+(ert-deftest fns-value<-circle ()
+  ;; Check that we at least don't hang when comparing two circular lists.
+  (let ((a (number-sequence 1 5))
+        (b (number-sequence 1 5)))
+    (setcdr (last a) (nthcdr 2 a))
+    (setcdr (last b) (nthcdr 2 b))
+    (should-error (value< a b :type 'circular))
+    (should-error (value< b a :type 'circular))))
+
 ;;; fns-tests.el ends here