master d62766305a: Add `take` and `ntake` (bug#56521)

[Mattias Engdegård]

branch: master
commit d62766305ad8fe6ca1695341c34b9836d051e3cb
Author: Mattias Engdegård <mattiase@acm.org>
Commit: Mattias Engdegård <mattiase@acm.org>

    Add `take` and `ntake` (bug#56521)
    
    These are useful list primitives, complementary to `nthcdr`.
    
    * src/fns.c (Ftake, Fntake): New.
    (syms_of_fns): Defsubr them.
    * doc/lispref/lists.texi (List Elements):
    * lisp/emacs-lisp/shortdoc.el (list): Document.
    * lisp/emacs-lisp/byte-opt.el (side-effect-free-fns, pure-fns):
    Declare `take` pure and side-effect-free.
    * test/src/fns-tests.el (fns-tests--take-ref, fns--take-ntake):
    New test.
    * etc/NEWS: Announce.
---
 doc/lispref/lists.texi      | 29 +++++++++++++++++++++++
 etc/NEWS                    |  5 ++++
 lisp/emacs-lisp/byte-opt.el |  4 ++--
 lisp/emacs-lisp/shortdoc.el |  4 ++++
 src/fns.c                   | 57 +++++++++++++++++++++++++++++++++++++++++++++
 test/src/fns-tests.el       | 49 ++++++++++++++++++++++++++++++++++++++
 6 files changed, 146 insertions(+), 2 deletions(-)

diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi
index a4f0ba815b..2a9ad1d5e0 100644
--- a/doc/lispref/lists.texi
+++ b/doc/lispref/lists.texi
@@ -340,6 +340,35 @@ If @var{n} is zero, @code{nthcdr} returns all of
 @end example
 @end defun
 
+@defun take n list
+This function returns the @var{n} first elements of @var{list}.  Essentially,
+it returns the part of @var{list} that @code{nthcdr} skips.
+
+@code{take} returns @var{list} if it is shorter than @var{n} elements;
+it returns @code{nil} if @var{n} is zero or negative.
+
+@example
+@group
+(take 3 '(a b c d))
+     @result{} (a b c)
+@end group
+@group
+(take 10 '(a b c d))
+     @result{} (a b c d)
+@end group
+@group
+(take 0 '(a b c d))
+     @result{} nil
+@end group
+@end example
+@end defun
+
+@defun ntake n list
+This is a version of @code{take} that works by destructively modifying
+the list structure of the argument.  That makes it faster, but the
+original value of @var{list} is lost.
+@end defun
+
 @defun last list &optional n
 This function returns the last link of @var{list}.  The @code{car} of
 this link is the list's last element.  If @var{list} is null,
diff --git a/etc/NEWS b/etc/NEWS
index 604e30ce25..11189020f1 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -3197,6 +3197,11 @@ to preserve the old behavior, apply
     (let ((default-directory temporary-file-directory))
       (process-attributes pid))
 
++++
+** New functions 'take' and 'ntake'.
+'(take N LIST)' returns the first N elements of LIST; 'ntake' does
+the same but works by modifying LIST destructively.
+
 
 
 * Changes in Emacs 29.1 on Non-Free Operating Systems
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index ce73a5e91f..a457e2044d 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -1459,7 +1459,7 @@ See Info node `(elisp) Integer Basics'."
         symbol-function symbol-name symbol-plist symbol-value 
string-make-unibyte
         string-make-multibyte string-as-multibyte string-as-unibyte
         string-to-multibyte
-        tan time-convert truncate
+        take tan time-convert truncate
         unibyte-char-to-multibyte upcase user-full-name
         user-login-name user-original-login-name custom-variable-p
         vconcat
@@ -1560,7 +1560,7 @@ See Info node `(elisp) Integer Basics'."
          ;; arguments.  This is pure enough for the purposes of
          ;; constant folding, but not necessarily for all kinds of
          ;; code motion.
-         car cdr car-safe cdr-safe nth nthcdr last
+         car cdr car-safe cdr-safe nth nthcdr last take
          equal
          length safe-length
          memq memql member
diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el
index a2d954cadb..1514ece6d1 100644
--- a/lisp/emacs-lisp/shortdoc.el
+++ b/lisp/emacs-lisp/shortdoc.el
@@ -595,6 +595,10 @@ A FUNC form can have any number of `:no-eval' (or 
`:no-value'),
    :eval (nth 1 '(one two three)))
   (nthcdr
    :eval (nthcdr 1 '(one two three)))
+  (take
+   :eval (take 3 '(one two three four)))
+  (ntake
+   :eval (ntake 3 (list 'one 'two 'three 'four)))
   (elt
    :eval (elt '(one two three) 1))
   (car-safe
diff --git a/src/fns.c b/src/fns.c
index 1f57e675b1..84cfec6c3f 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -1557,6 +1557,61 @@ substring_both (Lisp_Object string, ptrdiff_t from, 
ptrdiff_t from_byte,
   return res;
 }
 
+DEFUN ("take", Ftake, Stake, 2, 2, 0,
+       doc: /* Return the first N elements of LIST.
+If N is zero or negative, return nil.
+If LIST is no more than N elements long, return it (or a copy).  */)
+  (Lisp_Object n, Lisp_Object list)
+{
+  CHECK_FIXNUM (n);
+  EMACS_INT m = XFIXNUM (n);
+  if (m <= 0)
+    return Qnil;
+  CHECK_LIST (list);
+  if (NILP (list))
+    return Qnil;
+  Lisp_Object ret = Fcons (XCAR (list), Qnil);
+  Lisp_Object prev = ret;
+  m--;
+  list = XCDR (list);
+  while (m > 0 && CONSP (list))
+    {
+      Lisp_Object p = Fcons (XCAR (list), Qnil);
+      XSETCDR (prev, p);
+      prev = p;
+      m--;
+      list = XCDR (list);
+    }
+  if (m > 0 && !NILP (list))
+    wrong_type_argument (Qlistp, list);
+  return ret;
+}
+
+DEFUN ("ntake", Fntake, Sntake, 2, 2, 0,
+       doc: /* Modify LIST to keep only the first N elements.
+If N is zero or negative, return nil.
+If LIST is no more than N elements long, return it.  */)
+  (Lisp_Object n, Lisp_Object list)
+{
+  CHECK_FIXNUM (n);
+  EMACS_INT m = XFIXNUM (n);
+  if (m <= 0)
+    return Qnil;
+  CHECK_LIST (list);
+  Lisp_Object tail = list;
+  --m;
+  while (m > 0 && CONSP (tail))
+    {
+      tail = XCDR (tail);
+      m--;
+    }
+  if (CONSP (tail))
+    XSETCDR (tail, Qnil);
+  else if (!NILP (tail))
+    wrong_type_argument (Qlistp, list);
+  return list;
+}
+
 DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0,
        doc: /* Take cdr N times on LIST, return the result.  */)
   (Lisp_Object n, Lisp_Object list)
@@ -6082,6 +6137,8 @@ The same variable also affects the function 
`read-answer'.  */);
   defsubr (&Scopy_alist);
   defsubr (&Ssubstring);
   defsubr (&Ssubstring_no_properties);
+  defsubr (&Stake);
+  defsubr (&Sntake);
   defsubr (&Snthcdr);
   defsubr (&Snth);
   defsubr (&Selt);
diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el
index 20074ca0d2..a84cce3ad4 100644
--- a/test/src/fns-tests.el
+++ b/test/src/fns-tests.el
@@ -1365,4 +1365,53 @@
   (should-error (string-to-unibyte "å"))
   (should-error (string-to-unibyte "ABC∀BC")))
 
+(defun fns-tests--take-ref (n list)
+  "Reference implementation of `take'."
+  (named-let loop ((m n) (tail list) (ac nil))
+    (if (and (> m 0) tail)
+        (loop (1- m) (cdr tail) (cons (car tail) ac))
+      (nreverse ac))))
+
+(ert-deftest fns--take-ntake ()
+  "Test `take' and `ntake'."
+  ;; Check errors and edge cases.
+  (should-error (take 'x '(a)))
+  (should-error (ntake 'x '(a)))
+  (should-error (take 1 'a))
+  (should-error (ntake 1 'a))
+  (should-error (take 2 '(a . b)))
+  (should-error (ntake 2 '(a . b)))
+  ;; Tolerate non-lists for a count of zero.
+  (should (equal (take 0 'a) nil))
+  (should (equal (ntake 0 'a) nil))
+  ;; But not non-numbers for empty lists.
+  (should-error (take 'x nil))
+  (should-error (ntake 'x nil))
+
+  (dolist (list '(nil (a) (a b) (a b c) (a b c d) (a . b) (a b . c)))
+    (ert-info ((prin1-to-string list) :prefix "list: ")
+      (let ((max (if (proper-list-p list)
+                     (+ 2 (length list))
+                   (safe-length list))))
+        (dolist (n (number-sequence -1 max))
+          (ert-info ((prin1-to-string n) :prefix "n: ")
+            (let* ((l (copy-tree list))
+                   (ref (fns-tests--take-ref n l)))
+              (should (equal (take n l) ref))
+              (should (equal l list))
+              (should (equal (ntake n l) ref))))))))
+
+  ;; Circular list.
+  (let ((list (list 'a 'b 'c)))
+    (setcdr (nthcdr 2 list) (cdr list)) ; list now (a b c b c b c ...)
+    (should (equal (take 0 list) nil))
+    (should (equal (take 1 list) '(a)))
+    (should (equal (take 2 list) '(a b)))
+    (should (equal (take 3 list) '(a b c)))
+    (should (equal (take 4 list) '(a b c b)))
+    (should (equal (take 5 list) '(a b c b c)))
+    (should (equal (take 10 list) '(a b c b c b c b c b)))
+
+    (should (equal (ntake 10 list) '(a b)))))
+
 ;;; fns-tests.el ends here