scratch/sort-key 2cef2a91c13 05/11: New `sort` keyword arguments (bug#69709)

[Mattias Engdegård]

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

    New `sort` keyword arguments (bug#69709)
    
    Add the :key, :lessp, :reverse and :in-place keyword arguments.
    The old calling style remains available and is unchanged.
    
    * src/fns.c (sort_list, sort_vector, Fsort):
    * src/sort.c (tim_sort):
    Add keyword arguments with associated new features.
    All callers of Fsort adapted.
    * test/src/fns-tests.el (fns-tests--shuffle-vector, fns-tests-sort-kw):
    New test.
---
 src/dired.c           |  2 +-
 src/fns.c             | 92 +++++++++++++++++++++++++++++++++++++++++++--------
 src/lisp.h            |  3 +-
 src/pdumper.c         |  6 ++--
 src/sort.c            | 14 ++++----
 test/src/fns-tests.el | 44 ++++++++++++++++++++++++
 6 files changed, 137 insertions(+), 24 deletions(-)

diff --git a/src/dired.c b/src/dired.c
index 9a372201ae0..bfbacf70917 100644
--- a/src/dired.c
+++ b/src/dired.c
@@ -351,7 +351,7 @@ directory_files_internal (Lisp_Object directory, 
Lisp_Object full,
   specpdl_ptr = specpdl_ref_to_ptr (count);
 
   if (NILP (nosort))
-    list = Fsort (Fnreverse (list),
+    list = CALLN (Fsort, Fnreverse (list),
                  attrs ? Qfile_attributes_lessp : Qstring_lessp);
 
   (void) directory_volatile;
diff --git a/src/fns.c b/src/fns.c
index 59e26d6083d..033fb20c184 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -2353,7 +2353,8 @@ See also the function `nreverse', which is used more 
often.  */)
    is destructively reused to hold the sorted result.  */
 
 static Lisp_Object
-sort_list (Lisp_Object list, Lisp_Object predicate, Lisp_Object keyfunc)
+sort_list (Lisp_Object list, Lisp_Object predicate, Lisp_Object keyfunc,
+          bool reverse)
 {
   ptrdiff_t length = list_length (list);
   if (length < 2)
@@ -2369,7 +2370,7 @@ sort_list (Lisp_Object list, Lisp_Object predicate, 
Lisp_Object keyfunc)
          result[i] = Fcar (tail);
          tail = XCDR (tail);
        }
-      tim_sort (predicate, keyfunc, result, length);
+      tim_sort (predicate, keyfunc, result, length, reverse);
 
       ptrdiff_t i = 0;
       tail = list;
@@ -2388,27 +2389,86 @@ sort_list (Lisp_Object list, Lisp_Object predicate, 
Lisp_Object keyfunc)
    algorithm.  */
 
 static void
-sort_vector (Lisp_Object vector, Lisp_Object predicate, Lisp_Object keyfunc)
+sort_vector (Lisp_Object vector, Lisp_Object predicate, Lisp_Object keyfunc,
+            bool reverse)
 {
   ptrdiff_t length = ASIZE (vector);
   if (length < 2)
     return;
 
-  tim_sort (predicate, keyfunc, XVECTOR (vector)->contents, length);
+  tim_sort (predicate, keyfunc, XVECTOR (vector)->contents, length, reverse);
 }
 
-DEFUN ("sort", Fsort, Ssort, 2, 2, 0,
-       doc: /* Sort SEQ, stably, comparing elements using PREDICATE.
-Returns the sorted sequence.  SEQ should be a list or vector.  SEQ is
-modified by side effects.  PREDICATE is called with two elements of
-SEQ, and should return non-nil if the first element should sort before
-the second.  */)
-  (Lisp_Object seq, Lisp_Object predicate)
+DEFUN ("sort", Fsort, Ssort, 1, MANY, 0,
+       doc: /* Sort SEQ, stably, and return the sorted sequence.
+SEQ should be a list or vector.
+Optional arguments are specified as keyword/argument pairs.  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.
+
+usage: (sort SEQ &key KEY LESSP REVERSE IN-PLACE)  */)
+  (ptrdiff_t nargs, Lisp_Object *args)
 {
+  Lisp_Object seq = args[0];
+  Lisp_Object key = Qnil;
+  Lisp_Object lessp = Qnil;
+  bool inplace = false;
+  bool reverse = false;
+  if (nargs == 2)
+    {
+      /* old-style invocation without keywords */
+      lessp = args[1];
+      inplace = true;
+    }
+  else if ((nargs & 1) == 0)
+    error ("Invalid argument list");
+  else
+    for (ptrdiff_t i = 1; i < nargs - 1; i += 2)
+      {
+       if (EQ (args[i], QCkey))
+         key = args[i + 1];
+       else if (EQ (args[i], QClessp))
+         lessp = args[i + 1];
+       else if (EQ (args[i], QCin_place))
+         inplace = !NILP (args[i + 1]);
+       else if (EQ (args[i], QCreverse))
+         reverse = !NILP (args[i + 1]);
+       else
+         signal_error ("Invalid keyword argument", args[i]);
+      }
+
+  if (NILP (lessp))
+    /* FIXME: normalise it as Qnil instead, and special-case it in tim_sort?
+       That would remove the funcall overhead for the common case.  */
+    lessp = Qvaluelt;
+
+  /* FIXME: for lists it may be slightly faster to make the copy after
+     sorting? Measure.  */
+  if (!inplace)
+    seq = Fcopy_sequence (seq);
+
   if (CONSP (seq))
-    seq = sort_list (seq, predicate, Qnil);
+    seq = sort_list (seq, lessp, key, reverse);
   else if (VECTORP (seq))
-    sort_vector (seq, predicate, Qnil);
+    sort_vector (seq, lessp, key, reverse);
   else if (!NILP (seq))
     wrong_type_argument (Qlist_or_vector_p, seq);
   return seq;
@@ -6838,4 +6898,10 @@ For best results this should end in a space.  */);
   DEFSYM (Qfrom__tty_menu_p, "from--tty-menu-p");
   DEFSYM (Qyes_or_no_p, "yes-or-no-p");
   DEFSYM (Qy_or_n_p, "y-or-n-p");
+
+  DEFSYM (QCkey, ":key");
+  DEFSYM (QClessp, ":lessp");
+  DEFSYM (QCin_place, ":in-place");
+  DEFSYM (QCreverse, ":reverse");
+  DEFSYM (Qvaluelt, "value<");
 }
diff --git a/src/lisp.h b/src/lisp.h
index 17e8279a907..4e1217c7494 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -4275,7 +4275,8 @@ extern void syms_of_fns (void);
 extern void mark_fns (void);
 
 /* Defined in sort.c  */
-extern void tim_sort (Lisp_Object, Lisp_Object, Lisp_Object *, const 
ptrdiff_t);
+extern void tim_sort (Lisp_Object, Lisp_Object, Lisp_Object *, const ptrdiff_t,
+                     bool);
 
 /* Defined in floatfns.c.  */
 verify (FLT_RADIX == 2 || FLT_RADIX == 16);
diff --git a/src/pdumper.c b/src/pdumper.c
index c7ebb38dea5..ac8bf6f31f4 100644
--- a/src/pdumper.c
+++ b/src/pdumper.c
@@ -3368,7 +3368,7 @@ dump_sort_copied_objects (struct dump_context *ctx)
      file and the copy into Emacs in-order, where prefetch will be
      most effective.  */
   ctx->copied_queue =
-    Fsort (Fnreverse (ctx->copied_queue),
+    CALLN (Fsort, Fnreverse (ctx->copied_queue),
            Qdump_emacs_portable__sort_predicate_copied);
 }
 
@@ -3935,7 +3935,7 @@ drain_reloc_list (struct dump_context *ctx,
 {
   struct dump_flags old_flags = ctx->flags;
   ctx->flags.pack_objects = true;
-  Lisp_Object relocs = Fsort (Fnreverse (*reloc_list),
+  Lisp_Object relocs = CALLN (Fsort, Fnreverse (*reloc_list),
                               Qdump_emacs_portable__sort_predicate);
   *reloc_list = Qnil;
   dump_align_output (ctx, max (alignof (struct dump_reloc),
@@ -4057,7 +4057,7 @@ static void
 dump_do_fixups (struct dump_context *ctx)
 {
   dump_off saved_offset = ctx->offset;
-  Lisp_Object fixups = Fsort (Fnreverse (ctx->fixups),
+  Lisp_Object fixups = CALLN (Fsort, Fnreverse (ctx->fixups),
                               Qdump_emacs_portable__sort_predicate);
   Lisp_Object prev_fixup = Qnil;
   ctx->fixups = Qnil;
diff --git a/src/sort.c b/src/sort.c
index d91993c8c65..a0f127c35b3 100644
--- a/src/sort.c
+++ b/src/sort.c
@@ -1072,11 +1072,11 @@ resolve_fun (Lisp_Object fun)
 }
 
 /* Sort the array SEQ with LENGTH elements in the order determined by
-   PREDICATE.  */
-
+   PREDICATE (where Qnil means value<) and KEYFUNC (where Qnil means identity),
+   optionally reversed.  */
 void
 tim_sort (Lisp_Object predicate, Lisp_Object keyfunc,
-         Lisp_Object *seq, const ptrdiff_t length)
+         Lisp_Object *seq, const ptrdiff_t length, bool reverse)
 {
   /* FIXME: optimise for the predicate being value<; at the very
      least we'd go without the Lisp funcall overhead.  */
@@ -1091,9 +1091,8 @@ tim_sort (Lisp_Object predicate, Lisp_Object keyfunc,
   if (EQ (keyfunc, Qidentity))
     keyfunc = Qnil;
 
-  /* FIXME: consider a built-in reverse sorting flag: we would reverse
-     the input in-place here and reverse it back just before
-     returning.  */
+  if (reverse)
+    reverse_slice (seq, seq + length);    /* preserve stability */
 
   if (NILP (keyfunc))
     {
@@ -1159,6 +1158,9 @@ tim_sort (Lisp_Object predicate, Lisp_Object keyfunc,
   eassume (ms.pending[0].len == length);
   lo = ms.pending[0].base;
 
+  if (reverse)
+    reverse_slice (seq, seq + length);
+
   if (ms.a.keys != ms.temparray || allocated_keys != NULL)
     unbind_to (ms.count, Qnil);
 }
diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el
index 025e09cb755..6dfc866681d 100644
--- a/test/src/fns-tests.el
+++ b/test/src/fns-tests.el
@@ -375,6 +375,50 @@
   (should (equal (should-error (sort "cba" #'<) :type 'wrong-type-argument)
                  '(wrong-type-argument list-or-vector-p "cba"))))
 
+(defun fns-tests--shuffle-vector (vect)
+  "Shuffle VECT in place."
+  (let ((n (length vect)))
+    (dotimes (i (1- n))
+      (let* ((j (+ i (random (- n i))))
+             (vi (aref vect i)))
+        (aset vect i (aref vect j))
+        (aset vect j vi)))))
+
+(ert-deftest fns-tests-sort-kw ()
+  ;; Test the `sort' keyword calling convention by comparing with
+  ;; the results from using the old (positional) style tested above.
+  (random "my seed")
+  (dolist (size '(0 1 2 3 10 100 1000))
+    ;; Use a vector with both positive and negative numbers (asymmetric).
+    (let ((numbers (vconcat
+                    (number-sequence (- (/ size 3)) (- size 1 (/ size 3))))))
+      (fns-tests--shuffle-vector numbers)
+      ;; Test both list and vector input.
+      (dolist (input (list (append numbers nil) numbers))
+        (dolist (in-place '(nil t))
+          (dolist (reverse '(nil t))
+            (dolist (key '(nil abs))
+              (dolist (lessp '(nil >))
+                (let* ((seq (copy-sequence input))
+                       (res (sort seq :key key :lessp lessp
+                                  :in-place in-place :reverse reverse))
+                       (pred (or lessp #'value<))
+                       (exp-in (copy-sequence input))
+                       (exp-out
+                        (sort (if reverse (reverse exp-in) exp-in)
+                              (if key
+                                  (lambda (a b)
+                                    (funcall pred
+                                             (funcall key a) (funcall key b)))
+                                pred)))
+                       (expected (if reverse (reverse exp-out) exp-out)))
+                  (should (equal res expected))
+                  (if in-place
+                      (should (eq res seq))
+                    (should-not (and (> size 0) (eq res seq)))
+                    (should (equal seq input)))
+                  )))))))))
+
 (defvar w32-collate-ignore-punctuation)
 
 (ert-deftest fns-tests-collate-sort ()