compat-30: Add value< and sort with keyword arguments

NEWS.org

@@ -4,6 +4,8 @@
 
 * Development
 
+- compat-30: Add extended function =sort= with keyword arguments.
+- compat-30: New function =value<=.
 - compat-30: Add extended =copy-tree= with support for copying records with
   non-nil optional second argument.
 - compat-30: New macro =static-if=.

compat-25.el

@@ -40,23 +40,6 @@ usage: (bool-vector &rest OBJECTS)"
             i (1+ i)))
     vec))
 
-;;;; Defined in fns.c
-
-(compat-defun sort (seq predicate) ;; <compat-tests:sort>
-  "Handle vector SEQ."
-  :extended t
-  (cond
-   ((listp seq)
-    (sort seq predicate))
-   ((vectorp seq)
-    (let* ((list (sort (append seq nil) predicate))
-           (p list) (i 0))
-      (while p
-        (aset seq i (car p))
-        (setq i (1+ i) p (cdr p)))
-      (apply #'vector list)))
-   (t (signal 'wrong-type-argument (list 'list-or-vector-p seq)))))
-
 ;;;; Defined in editfns.c
 
 (compat-defalias format-message format) ;; <compat-tests:format-message>

compat-30.el

@@ -219,5 +219,96 @@ enclosed in a `progn' form.  ELSE-FORMS may be empty."
       then-form
     (cons 'progn else-forms)))
 
+;;;; Defined in fns.c
+
+(compat-defun value< (a b) ;; <compat-tests:value<>
+  "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’."
+  (cond
+   ((and (number-or-marker-p a) (number-or-marker-p b))
+    (< a b))
+   ((or (and (stringp a) (stringp b))
+        (and (symbolp a) (symbolp b)))
+    (string< a b))
+   ((and (listp a) (listp b))
+    (while (and (consp a) (consp b) (equal (car a) (car b)))
+      (setq a (cdr a) b (cdr b)))
+    (cond
+     ((not b) nil)
+     ((not a) t)
+     ((and (consp a) (consp b)) (value< (car a) (car b)))
+     (t (value< a b))))
+   ((and (vectorp a) (vectorp b))
+    (let* ((na (length a))
+           (nb (length b))
+           (n (min na nb))
+           (i 0))
+      (while (and (< i n) (equal (aref a i) (aref b i)))
+        (cl-incf i))
+      (if (< i n) (value< (aref a i) (aref b i)) (< n nb))))
+   ;; TODO Add support for more types.
+   (t (error "value< unsupported type: %S %S" a b))))
+
+(compat-defun sort (seq &optional lessp &rest rest) ;; <compat-tests:sort>
+  "Sort function with support for keyword arguments.
+The following arguments are defined:
+
+:key FUNC -- FUNC is a function that takes a single element from SEQ and
+  returns the key value to be used in comparison.  If absent or nil,
+  `identity' is used.
+
+:lessp FUNC -- FUNC is a function that takes two arguments and returns
+  non-nil if the first element should come before the second.
+  If absent or nil, `value<' is used.
+
+:reverse BOOL -- if BOOL is non-nil, the sorting order implied by FUNC is
+  reversed.  This does not affect stability: equal elements still retain
+  their order in the input sequence.
+
+:in-place BOOL -- if BOOL is non-nil, SEQ is sorted in-place and returned.
+  Otherwise, a sorted copy of SEQ is returned and SEQ remains unmodified;
+  this is the default.
+
+For compatibility, the calling convention (sort SEQ LESSP) can also be used;
+in this case, sorting is always done in-place."
+  :extended t
+  (let ((in-place t) (orig-seq seq))
+    (when (or (not lessp) rest)
+      (setq
+       rest (if lessp (cons lessp rest) rest)
+       in-place (plist-get rest :in-place)
+       lessp (let ((key (plist-get rest :key))
+                   (reverse (plist-get rest :reverse))
+                   (< (or (plist-get rest :lessp) #'value<)))
+               (cond
+                ((and key reverse)
+                 (lambda (a b) (not (funcall < (funcall key a) (funcall key b)))))
+                (key
+                 (lambda (a b) (funcall < (funcall key a) (funcall key b))))
+                (reverse
+                 (lambda (a b) (not (funcall < a b))))
+                (t <)))
+       seq (if (or (eval-when-compile (< emacs-major-version 25)) in-place)
+               seq
+             (copy-sequence seq))))
+    ;; Emacs 24 does not support vectors. Convert to list.
+    (when (and (eval-when-compile (< emacs-major-version 25)) (vectorp seq))
+      (setq seq (append seq nil)))
+    (setq seq (sort seq lessp))
+    ;; Emacs 24: Convert back to vector.
+    (if (and (eval-when-compile (< emacs-major-version 25)) (vectorp orig-seq))
+        (if in-place
+            (cl-loop for i from 0 for x in seq
+                     do (aset orig-seq i x)
+                     finally return orig-seq)
+          (apply #'vector seq))
+      seq)))
+
 (provide 'compat-30)
 ;;; compat-30.el ends here

compat-tests.el

@@ -1757,21 +1757,80 @@
   (should-equal '(1 2 3 4) (flatten-tree '((1) nil 2 ((3 4)))))
   (should-equal '(1 2 3 4) (flatten-tree '(((1 nil)) 2 (((3 nil nil) 4))))))
 
+(defmacro compat--should-value< (x y)
+  "Helper for (value< X Y) test."
+  `(progn
+     (should (value< ,x ,y))
+     (should-not (value< ,y ,x))))
+
+(ert-deftest compat-value< ()
+  ;; Type mismatch
+  (should-error (value< 'aa "aa"))
+  (should-error (value< 1 "aa"))
+  (should-error (value< 1 (cons 1 2)))
+  ;; Nil symbol
+  (compat--should-value< nil t)
+  (compat--should-value< nil 'nim)
+  (compat--should-value< nil 'nll)
+  (compat--should-value< 'mil nil)
+  ;; Atoms
+  (compat--should-value< 1 2)
+  (compat--should-value< "aa" "b")
+  (compat--should-value< 'aa 'b)
+  ;; Lists
+  (compat--should-value< nil '(1))
+  (compat--should-value< '(1 2) '(2 3))
+  (compat--should-value< '(1 2 3) '(2))
+  (compat--should-value< '(0 1 2) '(0 2 3))
+  (compat--should-value< '(0 1 2 3) '(0 2))
+  ;; Pairs and improper lists
+  (compat--should-value< nil '(1 . 2))
+  (compat--should-value< nil '(1 2 . 3))
+  (compat--should-value< '(1 . 2) '(2 . 2))
+  (compat--should-value< '(1 . 2) '(1 . 3))
+  (compat--should-value< '(1 2 . 3) '(1 2 . 4))
+  ;; Vectors
+  (compat--should-value< [] [1])
+  (compat--should-value< [1 2] [2 3])
+  (compat--should-value< [1 2 3] [2])
+  (compat--should-value< [0 1 2] [0 2 3])
+  (compat--should-value< [0 1 2 3] [0 2]))
+
 (ert-deftest compat-sort ()
   (should-equal (list 1 2 3) (sort (list 1 2 3) #'<))
   (should-equal (list 1 2 3) (sort (list 1 3 2) #'<))
   (should-equal (list 1 2 3) (sort (list 3 2 1) #'<))
   (should-equal (list 1 2 3) (compat-call sort (list 1 2 3) #'<))
   (should-equal (list 1 2 3) (compat-call sort (list 1 3 2) #'<))
   (should-equal (list 1 2 3) (compat-call sort (list 3 2 1) #'<))
+  ;; Test Emacs 25 support for vectors.
   (should-equal [1 2 3] (compat-call sort (vector 1 2 3) #'<))
   (should-equal [1 2 3] (compat-call sort (vector 1 3 2) #'<))
   (should-equal [1 2 3] (compat-call sort (vector 3 2 1) #'<))
   ;; Test side effect
   (let* ((vec (vector 4 5 8 3 1 2 3 2 3 4))
          (sorted (compat-call sort vec #'>)))
+    (should (eq vec sorted))
     (should-equal sorted [8 5 4 4 3 3 3 2 2 1])
-    (should-equal vec [8 5 4 4 3 3 3 2 2 1])))
+    (should-equal vec [8 5 4 4 3 3 3 2 2 1]))
+  ;; Test Emacs 30 keyword arguments.
+  (should-equal '(1 2 3) (compat-call sort '(2 3 1)))
+  (should-equal '(3 2 1) (compat-call sort '(2 3 1) :reverse t))
+  (should-equal '((x 3) (y 2) (z 1)) (compat-call sort '((z 1) (x 3) (y 2)) :key #'car))
+  (should-equal '((z 1) (y 2) (x 3)) (compat-call sort '((z 1) (x 3) (y 2)) :key #'car :reverse t))
+  (should-equal '((z 1) (y 2) (x 3)) (compat-call sort '((z 1) (x 3) (y 2)) :key #'cadr))
+  (should-equal '((x 3) (y 2) (z 1)) (compat-call sort '((z 1) (x 3) (y 2)) :key #'cadr :reverse t))
+  (should-equal '(3 2 1) (compat-call sort '(2 3 1) :lessp #'>))
+  (should-equal '(1 2 3) (compat-call sort '(2 3 1) :reverse t :lessp #'>))
+  (should-equal '((30 1) (20 2) (10 3)) (compat-call sort '((30 1) (10 3) (20 2)) :key #'car :lessp #'>))
+  (should-equal '((10 3) (20 2) (30 1)) (compat-call sort '((30 1) (10 3) (20 2)) :key #'car :reverse t :lessp #'>))
+  (should-equal '((x 3) (y 2) (z 1)) (compat-call sort '((z 1) (x 3) (y 2)) :key #'cadr :lessp #'>))
+  (should-equal '((z 1) (y 2) (x 3)) (compat-call sort '((z 1) (x 3) (y 2)) :key #'cadr :reverse t :lessp #'>))
+  (let* ((vec (vector 4 5 8 3 1 2 3 2 3 4))
+         (sorted (compat-call sort vec :in-place t)))
+    (should (eq vec sorted))
+    (should-equal sorted [1 2 2 3 3 3 4 4 5 8])
+    (should-equal vec [1 2 2 3 3 3 4 4 5 8])))
 
 (ert-deftest compat-replace-string-in-region ()
   (with-temp-buffer