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.
(bits_word_to_host_endian): Move...
* src/lisp.h (bits_word_to_host_endian): ...here, and declare inline.
* src/fns.c (Fstring_lessp): Extract the bulk of this function to...
(string_cmp): ...this 3-way comparison function, for use elsewhere.
(bool_vector_cmp, value_cmp, Fvaluelt): New.
* lisp/emacs-lisp/byte-opt.el (side-effect-free-fns, pure-fns):
Add `value<`, which is pure and side-effect-free.
* test/src/fns-tests.el (fns-value<-ordered, fns-value<-unordered)
(fns-value<-type-mismatch, fns-value<-symbol-with-pos)
(fns-value<-circle, ert-deftest fns-value<-bool-vector): New tests.
* doc/lispref/sequences.texi (Sequence Functions):
* doc/lispref/numbers.texi (Comparison of Numbers):
* doc/lispref/strings.texi (Text Comparison):
Document the new value< function.
* etc/NEWS: Announce.

1 files changed, 218 insertions, 0 deletions

diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el
index 7437c07f156..844000cdc76 100644
--- a/test/src/fns-tests.el
+++ b/test/src/fns-tests.el
@@ -1513,4 +1513,222 @@
   (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))))
+
+(ert-deftest fns-value<-bool-vector ()
+  ;; More thorough test of `value<' for bool-vectors.
+  (random "my seed")
+  (dolist (na '(0 1 5 8 9 32 63 64 65 200 1001 1024))
+    (let ((a (make-bool-vector na nil)))
+      (dotimes (i na)
+        (aset a i (zerop (random 2))))
+      (dolist (nb '(0 1 5 8 9 32 63 64 65 200 1001 1024))
+        (when (<= nb na)
+          (let ((b (make-bool-vector nb nil)))
+            (dotimes (i nb)
+              (aset b i (aref a i)))
+            ;; `b' is now a prefix of `a'.
+            (should-not (value< a b))
+            (cond ((= nb na)
+                   (should (equal a b))
+                   (should-not (value< b a)))
+                  (t
+                   (should-not (equal a b))
+                   (should (value< b a))))
+            (unless (zerop nb)
+              ;; Flip random bits in `b' and check how it affects the order.
+              (dotimes (_ 3)
+                (let ((i (random nb)))
+                  (let ((val (aref b i)))
+                    (aset b i (not val))
+                    (should-not (equal a b))
+                    (cond
+                     (val
+                      ;; t -> nil: `b' is now always a proper prefix of `a'.
+                      (should-not (value< a b))
+                      (should (value< b a)))
+                     (t
+                      ;; nil -> t: `a' is now less than `b'.
+                      (should (value< a b))
+                      (should-not (value< b a))))
+                    ;; Undo the flip.
+                    (aset b i val)))))))))))
+
 ;;; fns-tests.el ends here