Subject: [PATCH] Add new reduction primitives `fold-left' and `fold-right'

From: Zach Shaftel <[email-masked]>
Date: Sat, 31 May 2025 22:35:20 -0400

Tags: patch

this patch adds left and right sequence reduction functions in C, along
with tests for them. i don't know if this is the sort of thing the
maintainers actually would want to merge, but i figured i would just
submit it and hear your feedback. would also appreciate any stylistic
feedback, for future patch submissions.

In GNU Emacs 31.0.50 (build 1, x86_64-pc-linux-gnu, GTK+ Version
 3.24.49, cairo version 1.18.4) of 2025-05-27 built on bigbox
Repository revision: 75acd19b011febb3eb35ee1bec1552b96e1bb25a
Repository branch: HEAD
System Description: Arch Linux

Configured using:
 'configure --with-modules --without-xwidgets --with-native-compilation
 --with-tree-sitter --without-gsettings --without-gconf --without-gpm
 --with-pgtk --without-compress-install --with-mps --without-xaw3d
 'CFLAGS=-mtune=native -march=native -O2 -g''

>From 3bd2fe4ddd0d46587923b07238f5475891551ac8 Mon Sep 17 00:00:00 2001
From: Zach Shaftel <[email-masked]>
Date: Sat, 31 May 2025 00:58:44 -0400
Subject: [PATCH] Add new reduction primitives `fold-left' and `fold-right'

New primitives to reduce sequences from either direction.

* src/fns.c (Ffold_left, Ffold_right): New functions.
(syms_of_fns): Defsubr them.
* test/src/fns-tests.el (fns-tests-fold-left, fns-tests-fold-right): New
tests for them.
(fns-tests--emit-fold-tests): Helper macro for the test boilerplate.
---
 src/fns.c             | 75 +++++++++++++++++++++++++++++++++++++++++++
 test/src/fns-tests.el | 43 +++++++++++++++++++++++++
 2 files changed, 118 insertions(+)

diff --git a/src/fns.c b/src/fns.c
index 21916b6fb46..ac863e0ba5c 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -3541,6 +3541,79 @@ DEFUN ("mapcan", Fmapcan, Smapcan, 2, 2, 0,
   SAFE_FREE ();
   return ret;
 }
+
+DEFUN ("fold-left", Ffold_left, Sfold_left, 3, 3, 0,
+       doc: /* Reduce SEQUENCE from the left with FUNCTION, starting from
+INIT-VALUE.
+
+FUNCTION is first applied to INIT-VALUE and the first element of SEQUENCE, then
+to that result and the second element of SEQUENCE, and so on.  After reaching
+the end of SEQUENCE, the final value is returned.  If SEQUENCE is empty,
+INIT-VALUE is returned and FUNCTION is never called.  */)
+  (Lisp_Object function, Lisp_Object init_value, Lisp_Object sequence)
+{
+  Lisp_Object result = init_value;
+
+  if (NILP (sequence))
+    ;
+  else if (CONSP (sequence))
+    FOR_EACH_TAIL (sequence)
+      result = calln (function, result, XCAR (sequence));
+  else if (VECTORP (sequence))
+    for (ptrdiff_t i = 0, len = ASIZE (sequence); i < len; i++)
+      result = calln (function, result, AREF (sequence, i));
+  else
+    for (ptrdiff_t i = 0, len = XFIXNUM (Flength (sequence)); i < len; i++)
+      result = calln (function, result, Faref (sequence, make_fixnum(i)));
+
+  return result;
+}
+
+static Lisp_Object
+fold_right_array (Lisp_Object fn, Lisp_Object value, Lisp_Object *elts, EMACS_INT len)
+{
+  Lisp_Object result = value;
+  for (ptrdiff_t idx = len; idx > 0;)
+    result = calln (fn, elts[--idx], result);
+  return result;
+}
+
+DEFUN ("fold-right", Ffold_right, Sfold_right, 3, 3, 0,
+       doc: /* Reduce SEQUENCE from the right with FUNCTION, starting from
+INIT-VALUE.
+
+FUNCTION is first applied to the last element of SEQUENCE and INIT-VALUE, then
+to the preceding element and the result of the previous call, and so on.  After
+reaching the start of SEQUENCE, the final value is returned.  If SEQUENCE is
+empty, INIT-VALUE is returned and FUNCTION is never called.  */)
+  (Lisp_Object function, Lisp_Object sequence, Lisp_Object init_value)
+{
+  if (NILP (sequence))
+    return init_value;
+  if (CONSP (sequence))
+    {
+      USE_SAFE_ALLOCA;
+      ptrdiff_t len = list_length (sequence);
+      Lisp_Object *temp, tail = sequence;
+      SAFE_ALLOCA_LISP (temp, len);
+      /* fill up a temporary array with the contents of the list, then reduce it
+	 in reverse.  TODO consider the algorithm in Durand & Strandh 2015,
+	 "Processing List Elements in Reverse Order".  */
+      for (ptrdiff_t i = 0; i < len; i++, tail = XCDR (tail))
+	temp[i] = XCAR (tail);
+      Lisp_Object result = fold_right_array (function, init_value, temp, len);
+      SAFE_FREE ();
+      return result;
+    }
+  Lisp_Object result = init_value;
+  if (VECTORP (sequence))
+    result = fold_right_array(function, init_value,
+			      XVECTOR (sequence)->contents, ASIZE (sequence));
+  else
+    for (ptrdiff_t i = XFIXNUM (Flength (sequence)); i > 0;)
+      result = calln (function, Faref (sequence, make_fixnum (--i)), result);
+  return result;
+}
 
 /* This is how C code calls `yes-or-no-p' and allows the user
    to redefine it.  */
@@ -6843,6 +6916,8 @@ syms_of_fns (void)
   defsubr (&Smapc);
   defsubr (&Smapcan);
   defsubr (&Smapconcat);
+  defsubr (&Sfold_left);
+  defsubr (&Sfold_right);
   defsubr (&Syes_or_no_p);
   defsubr (&Sload_average);
   defsubr (&Sfeaturep);
diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el
index e6abcdc34e7..a7f24a687e1 100644
--- a/test/src/fns-tests.el
+++ b/test/src/fns-tests.el
@@ -740,6 +740,49 @@ fns-tests-mapcan
     (should (equal (mapcan #'identity data) '(foo bar)))
     (should (equal data                     '((foo bar) (bar))))))
 
+(defmacro fns-tests--emit-fold-tests (folder)
+  (let ((args (if (eq folder 'fold-left) #'identity #'reverse)))
+    `(let* ((nums (number-sequence 0 100))
+            (vnums (vconcat nums))
+            (shuffled (vconcat nums)))
+       (fns-tests--shuffle-vector shuffled)
+       ;; verify the sequence arg index
+       (should-error (,folder #'ignore ,@(funcall args '(nil t)))
+                     :type 'wrong-type-argument)
+       (should ,(if (eq folder 'fold-left)
+                    `(equal (fold-left (lambda (x y) (cons y x)) () nums)
+                            (reverse nums))
+                  `(equal (fold-right #'cons nums ()) nums)))
+       (should (= (,folder #'+ ,@(funcall args '(0 nums)))
+                  (apply #'+ 0 nums)))
+       ;; other sequence types
+       (let* ((count-odd (lambda ,(funcall args '(acc n))
+                           (if (oddp n) (1+ acc) acc)))
+              (ustr (concat nums))
+              (mstr (decode-coding-string ustr 'utf-8-unix))
+              (bv (apply #'bool-vector (mapcar #'oddp nums))))
+         ;; vectors
+         (should (= 50 (,folder count-odd ,@(funcall args '(0 vnums)))))
+         ;; unibyte strings
+         (should (= 50 (,folder count-odd ,@(funcall args '(0 ustr)))))
+         ;; multibyte strings
+         (should (= 50 (,folder count-odd ,@(funcall args '(0 mstr)))))
+         ;; bool-vectors
+         (should (= 50 (,folder (lambda ,(funcall args '(acc bool))
+                                  (if bool (1+ acc) acc))
+                                ,@(funcall args '(0 bv))))))
+       ;; commutativity preserved
+       (should (= (,folder #'min ,@(funcall args '(0 vnums)))
+                  (,folder #'min ,@(funcall args '(0 shuffled)))))
+       ;; no-op with empty sequence
+       (should (eq (,folder #'+ ,@(funcall args '(t ()))) t)))))
+
+(ert-deftest fns-tests-fold-left ()
+  (fns-tests--emit-fold-tests fold-left))
+
+(ert-deftest fns-tests-fold-right ()
+  (fns-tests--emit-fold-tests fold-right))
+
 ;; Test handling of cyclic and dotted lists.
 
 (defun cyc1 (a)
-- 
2.49.0