scratch/sort-key b0a32c899b4 3/7: Add value-less-p

[Mattias Engdegård]

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

    Add value-less-p
    
    It's a general-purpose polymorphic ordering function, like `<` but
    for any two values of the same type.
---
 src/data.c            |   2 +
 src/fns.c             | 239 ++++++++++++++++++++++++++++++++++++++++++++++++++
 test/src/fns-tests.el | 170 +++++++++++++++++++++++++++++++++++
 3 files changed, 411 insertions(+)

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 94848e6a9e7..75da359a7c6 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"
@@ -2966,6 +2967,243 @@ 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-less-p.
+   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).
+
+   If lessp_only is true, then we may return 0 instead of 1 when a>b,
+   if this is faster.  */
+static int
+value_cmp (Lisp_Object a, Lisp_Object b, int maxdepth, bool lessp_only)
+{
+  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 : ia > XFIXNUM (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))
+       {
+         struct Lisp_Symbol *sa = XBARE_SYMBOL (a);
+         struct Lisp_Symbol *sb = XBARE_SYMBOL (b);
+         if (!NILP (Fstring_lessp (sa->u.s.name, sb->u.s.name)))
+           return -1;
+         if (lessp_only)
+           return 0;
+         if (sa->u.s.interned == SYMBOL_INTERNED_IN_INITIAL_OBARRAY
+             && sb->u.s.interned == SYMBOL_INTERNED_IN_INITIAL_OBARRAY)
+           /* Both symbols are interned in the initial obarray, so cannot have
+              equal names.  */
+           return 1;
+         return !NILP (Fstring_lessp (sb->u.s.name, sa->u.s.name));
+       }
+      if (CONSP (b) && NILP (a))
+       return -1;
+      if (SYMBOLP (b))
+       {
+         /* Slow-path branch when B is a symbol-with-pos.  */
+         if (!NILP (Fstring_lessp (a, b)))
+           return -1;
+         if (lessp_only)
+           return 0;
+         return !NILP (Fstring_lessp (b, a));
+       }
+      goto type_mismatch;
+
+    case Lisp_String:
+      if (STRINGP (b))
+       {
+         if (!NILP (Fstring_lessp (a, b)))
+           return -1;
+         /* FIXME: We would go even faster, and wouldn't need the
+            lessp_only hack, if we had a string comparison with -1/0/1 result.
+            Generalise the code in Fstring_lessp for internal use?  */
+         if (lessp_only)
+           return 0;
+         return !NILP (Fstring_lessp (b, a));
+       }
+      goto type_mismatch;
+
+    case Lisp_Cons:
+      /* FIXME: circle check */
+      while (CONSP (b))
+       {
+         int cmp = value_cmp (XCAR (a), XCAR (b), maxdepth - 1, false);
+         if (cmp != 0)
+           return cmp;
+         a = XCDR (a);
+         b = XCDR (b);
+         if (!CONSP (a))
+           break;
+       }
+      if (CONSP (a))
+       {
+         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, false);
+                     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, false);
+                 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, lessp_only);
+             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, lessp_only);
+               }
+
+             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, false);
+      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-less-p", Fvalue_less_p, Svalue_less_p, 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, true) < 0 ? Qt : Qnil;
+}
+
 
 
 DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0,
@@ -6647,6 +6885,7 @@ For best results this should end in a space.  */);
   defsubr (&Seql);
   defsubr (&Sequal);
   defsubr (&Sequal_including_properties);
+  defsubr (&Svalue_less_p);
   defsubr (&Sfillarray);
   defsubr (&Sclear_string);
   defsubr (&Snconc);
diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el
index 7437c07f156..4c5697cd223 100644
--- a/test/src/fns-tests.el
+++ b/test/src/fns-tests.el
@@ -1513,4 +1513,174 @@
   (should-error (copy-alist "abc")
                 :type 'wrong-type-argument))
 
+(ert-deftest fns-value-less-p-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-less-p x y))
+            (should-not (value-less-p y x))
+            (should-not (value-less-p x x))
+            (should-not (value-less-p y y))))
+
+      (delete-process proc2)
+      (delete-process proc1)
+      (kill-buffer buf2)
+      (kill-buffer buf1))))
+
+(ert-deftest fns-value-less-p-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-less-p x y))
+        (should-not (value-less-p y x))))))
+
+(ert-deftest fns-value-less-p-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-less-p x y) :type 'type-mismatch)
+            (should-error (value-less-p y x) :type 'type-mismatch)))
+        (setq tail (cdr tail))))))
+
+(ert-deftest fns-value-less-p-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-less-p x y))
+            (should-not (value-less-p y x))
+            (should-not (value-less-p x x))
+            (should-not (value-less-p y y))))
+        (should-not (value-less-p a-sp-1 a-sp-2))
+        (should-not (value-less-p a-sp-2 a-sp-1))))
+
+    ;; When disabled, symbol-with-pos and symbols do not compare.
+    (should-error (value-less-p a-sp-1 'a) :type 'type-mismatch)
+    (should-error (value-less-p '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-less-p x y))
+          (should-not (value-less-p y x))
+          (should-not (value-less-p x x))
+          (should-not (value-less-p y y))))
+      (should-not (value-less-p a-sp-1 'a))
+      (should-not (value-less-p 'a a-sp-1)))))
+
 ;;; fns-tests.el ends here