Re: [PATCH] Add cl-map-into, revision 2

[akater]

New version of the patch.  Changes:

- Use with-memoization
- Add tests
- Trim docstrings

signature.asc
Description: PGP signature

>From acf93e8ae4371dde0b56aea6d0ab58516c97e36a Mon Sep 17 00:00:00 2001
From: akater <nuclearspace@gmail.com>
Date: Wed, 15 Sep 2021 19:42:47 +0000
Subject: [PATCH] Add cl-map-into

map-into is a standard Common Lisp function that acts as cl-map, only
values are recorded into a preallocated sequence.

* lisp/emacs-lisp/cl-extra.el
(cl-map-into): New primary function
(cl--map-into-basic-call-arguments-limit,
cl--map-into-max-small-signature): New auxiliary constant
(cl--map-into-mappers-array, cl--map-into-mappers-alist): New variable
(cl--compute-map-into-signature, cl--make-map-into-mapper): New auxiliary 
function
(cl--do-seq-type-signature): New auxiliary macro
---
 lisp/emacs-lisp/cl-extra.el            | 212 +++++++++++++++++++++++++
 test/lisp/emacs-lisp/cl-extra-tests.el |  40 +++++
 2 files changed, 252 insertions(+)

diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index 499d26b737..12a11df62c 100644
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -88,6 +88,218 @@ defun cl-equalp (x y)
        (t (equal x y))))
 
 
+;;; map-into
+
+;; We implement a simple dispatcher for sequence types.
+;;
+;; cl-extra has cl--mapcar-many for similar purpose.
+;; The core issue with it, it goes through args pre-emptively
+;; to compute min length when there are more than 2 arguments
+;; which makes it and its reverse dependencies fail on circular lists
+;; unless there are <3 args.
+;; Other issues are
+;; - it performs type checks for sequences of known types at runtime
+;; - it may cons whole arglist thrice per invocation
+;; - looks like it's hard to extend.
+
+;; Our approach doesn't have these issues.
+
+(defconst cl--map-into-basic-call-arguments-limit 7
+  "Maximal reasonably expected number of arguments to `cl-map-into'.
+
+`cl-map-into' caches its code corresponding to various signature
+types of arglists supplied to `cl-map-into'.  Arglists may vary
+in length.
+
+Code corresponding to arglists of length less than
+`cl--map-into-basic-call-arguments-limit' is accessed via array.
+
+Code corresponding to arglists of length greater than or equal to
+`cl--map-into-basic-call-arguments-limit' is accessed via alist.
+")
+
+(defconst cl--map-into-max-small-signature
+  (expt 2 cl--map-into-basic-call-arguments-limit)
+  "Length of array to allocate for caching `cl-map-into' mappers
+corresponding to small arglists.
+
+Such mappers are accessed by their position in an array; position
+equals the signature.
+
+Consider `cl-map-into' arglist
+
+(target f seq-1 seq-2)
+
+call-arguments-limit corresponding to arglists of this length or
+shorter, is 4 (as there are 4 arguments).  This leaves at most 3
+sequences to contribute to type signature.
+
+Hovewer, we have to store one additional bit for fixnum-based
+encoding to be unambiguous and simple.  So overall array length
+ends up being exactly (expt 2 call-arguments-limit).")
+
+(defvar cl--map-into-mappers-array
+  (make-vector cl--map-into-max-small-signature nil)
+  "Array holding mappers corresponding to small arglists of `cl-map-into'.
+
+Element type is (or function null).")
+
+(defvar cl--map-into-mappers-alist nil
+  "Alist holding mappers corresponding to large arglists of `cl-map-into'.")
+
+(defun cl--compute-map-into-signature (&rest all-sequences)
+  "Compute lookup key for `cl-map-into''s almost-arglist ALL-SEQUENCES.
+
+Namely: ALL-SEQUENCES would be (TARGET   &rest SEQUENCES)
+               for (cl-map-into TARGET f &rest SEQUENCES)
+
+As a side effect, it checks that ALL-SEQUENCES are of sequence
+types.
+
+Example:
+ELISP> (mapcar (lambda (arglist)
+                 (apply #'cl--compute-map-into-signature arglist))
+               '(( () () () )                ; signature #b1000
+                 ( () () [] )                ; signature #b1001
+                 ( () [] () )                ; signature #b1010
+                 ( () [] [] )                ; signature #b1011
+                 ( [] () () )                ; signature #b1100
+                 ))
+(8 9 10 11 12)"
+  ;; This is not `cl-map-into'-specific and could be used for other caches
+  ;; which is why we don't specify arglist as (target &rest sequences).
+  ;; For the time being (while this dispatch is not used widely),
+  ;; neither docstring nor name reflect this.
+  (let ((signature 1))
+    (dolist (s all-sequences signature)
+      (setq signature (ash signature 1))
+      (cl-etypecase s
+        (list)
+        (vector (cl-incf signature))))))
+
+(cl-defmacro cl--do-seq-type-signature ((type-var signature &optional result)
+                                        &body body)
+  "With TYPE-VAR bound to sequence type, evaluate BODY forms.  Return RESULT.
+
+TYPE-VAR goes across sequence types in an arglist corresponding
+to SIGNATURE that encodes sequence types in that arglist.
+
+Iteration goes from arglist's end to arglist's start.
+
+If :first is present at toplevel in BODY, all forms following
+it (and those forms only) are evaluated in order when TYPE-VAR is
+bound to the first sequence type in the arglist --- which would
+be the last sequence type derived from SIGNATURE: see the
+previous paragraph.  At other iteration steps, only forms
+preceding the first :first are evaluated.
+
+Subsequent instances of toplevel :first in BODY don't affect anything."
+  (declare (indent 1))
+  (let* ((main (cl-copy-list body))
+         (first (if (eq :first (car main)) (progn (setf main nil)
+                                                  (cdr main))
+                  (cl-loop with sublist = main
+                           while sublist do
+                           (when (eq :first (cadr sublist))
+                             (setf first (cddr sublist) (cdr sublist) nil)
+                             (cl-return first))
+                           (pop sublist)))))
+    (let ((sig (gensym "sig-")))
+      `(let ((,sig ,signature) ,type-var)
+         ;; (declare (type (integer (1)) ,sig)
+         ;;          ;; Let's keep nil for now.
+         ;;          (type (member nil list vector) ,type-var))
+         (cl-check-type ,sig (integer (1)))
+         (cl-loop (cond
+                   ((or (when (= 2 ,sig) (setq ,type-var 'list))
+                        (when (= 3 ,sig) (setq ,type-var 'vector)))
+                    ;; TODO: This duplicates main code sometimes,
+                    ;; think of elegant enough way to eliminate duplication.
+                    ,@(or first main) (cl-return ,result))
+                   (t (setq ,type-var (if (zerop (mod ,sig 2))
+                                          'list
+                                        'vector))
+                      ,@main))
+                  (setf ,sig (floor ,sig 2)))))))
+
+(defun cl--make-map-into-mapper (signature &optional do-not-compile)
+  "Return mapper for `cl-map-into' specialized on arglists of type
+encoded by SIGNATURE.
+
+If DO-NOT-COMPILE is nil (default), return byte-compiled function.
+Otherwise, return lambda form.
+
+Example:
+ELISP> (cl--make-map-into-mapper #b1011 t)
+(lambda (f target-list vector-2 vector-1)
+  (cl-symbol-macrolet ((place (car target-cons)))
+    (cl-loop for target-cons on target-list
+             for elt-2 across vector-2
+             for elt-1 across vector-1
+             do (setf place (funcall f elt-2 elt-1))
+             finally return target-list)))"
+  (let ((gensym-counter 1) f xs ss loop
+        target-type target-index target-place target-var)
+    (cl-macrolet ((nconcf (var &rest seqs) `(setf ,var (nconc ,@seqs ,var))))
+      ;; The only good thing about this name is, it's short and ends with f
+      (cl--do-seq-type-signature (type signature)
+        (nconcf loop (list 'for (let ((it (gensym "elt-")))
+                                  (push it xs)
+                                  (cl-decf gensym-counter)
+                                  it)
+                           (cl-case type
+                             (list 'in)
+                             (vector 'across))
+                           (let ((it (gensym (concat (symbol-name type) "-"))))
+                             (push it ss)
+                             it)))
+        :first (setq target-type type
+                     target-var (make-symbol
+                                 (concat "target-" (symbol-name target-type))))
+        (nconcf loop (list 'for)
+                (cl-case type
+                  (list (list (setq target-index (make-symbol "target-cons"))
+                              'on target-var))
+                  (vector (list (setq target-index (gensym "target-i"))
+                                'to `(1- (length ,target-var))))))))
+    (funcall
+     (if do-not-compile #'identity #'byte-compile)
+     `(lambda ,(cons (setq f (make-symbol "f")) (cons target-var ss))
+        (cl-symbol-macrolet ((,(setq target-place (make-symbol "place"))
+                              ,(cl-case target-type
+                                 (list `(car ,target-index))
+                                 (vector `(aref ,target-var ,target-index)))))
+          (cl-loop ,@(nconc loop `(do (setf ,target-place (funcall ,f ,@xs))
+                                      ;; Bytecode looks better
+                                      ;; with finally return ..
+                                      ;; than with finally (cl-return ..).
+                                      finally return ,target-var))))))))
+
+(defun cl-map-into (target function &rest sequences)
+  "Common Lisp's map-into.
+
+Destructively modify TARGET to contain the results of applying
+FUNCTION to each element in the argument SEQUENCES in turn.
+
+TARGET and each element of SEQUENCES can each be either a list
+or a vector.  If TARGET and each element of SEQUENCES are not
+all the same length, the iteration terminates when the shortest sequence
+(of any of the SEQUENCES or the TARGET) is exhausted.  If TARGET
+is longer than the shortest element of SEQUENCES, extra elements
+at the end of TARGET are left unchanged."
+  (cl-check-type function function)
+  (apply
+   (let* ((sig (apply #'cl--compute-map-into-signature target sequences))
+          (small (< sig cl--map-into-max-small-signature)))
+     (with-memoization (if small (aref cl--map-into-mappers-array sig)
+                         ;; TODO: Order alist entries for faster lookup
+                         ;; (note that we'll have to abandon alist-get then).
+                         (alist-get sig cl--map-into-mappers-alist
+                                    nil nil #'=))
+       (cl--make-map-into-mapper sig)))
+   function target sequences))
+
+
 ;;; Control structures.
 
 ;;;###autoload
diff --git a/test/lisp/emacs-lisp/cl-extra-tests.el 
b/test/lisp/emacs-lisp/cl-extra-tests.el
index 91f0a1e201..4cf5d84220 100644
--- a/test/lisp/emacs-lisp/cl-extra-tests.el
+++ b/test/lisp/emacs-lisp/cl-extra-tests.el
@@ -35,6 +35,46 @@
     (should (eq (cl-getf plist 'y :none) nil))
     (should (eq (cl-getf plist 'z :none) :none))))
 
+(ert-deftest cl-map-into ()
+  (should (equal '(42 42 42)
+                 (cl-map-into (list 0 0 0) #'+ '(1 2 3) [41 40 39])))
+  (should (equal '(42 42 42)
+                 (cl-map-into (list 0 0 0) #'+ [41 40 39] '(1 2 3))))
+  (should (equal '(42 42 42)
+                 (cl-map-into (list 0 0 0) #'* '(1 2 3) [42 21 14])))
+  (should (equal '(42 42 42)
+                 (let ((s (list 0 0 0)))
+                   (cl-map-into s #'+ '(1 2 3) [41 40 39])
+                   s)))
+  (should (equal '(42 42 42)
+                 (let ((s (list 0 0 0)))
+                   (cl-map-into s #'+ s [41 40 39] '(1 2 3))
+                   s)))
+  (should (equal '(42 42 42)
+                 (let ((s (list 0 0 0)))
+                   (cl-map-into s #'+ '(1 2 3) s [41 40 39])
+                   s)))
+  (should (equal '(42 42 42)
+                 (let ((s (list 0 0 0)))
+                   (cl-map-into s #'+ '(1 2 3) [41 40 39] s)
+                   s)))
+  (should (equal '(42 42 42)
+                 (let ((s (list 18 19 20)))
+                   (cl-map-into s #'+ s '(6 4 2 1 not-even-a-number) s)
+                   s)))
+  (should (equal [42 42 42]
+                 (let ((s (vector 0 0 0)))
+                   (cl-map-into s #'+ '(1 2 3) [41 40 39])
+                   s)))
+  (should (equal [42 42 42]
+                 (let ((s (vector 0 0 0)))
+                   (cl-map-into s #'+ [41 40 39] '(1 2 3))
+                   s)))
+  (should (equal [42 42 42]
+                 (let ((s (vector 18 19 20)))
+                   (cl-map-into s #'+ s '(6 4 2 1 not-even-a-number) s)
+                   s))))
+
 (ert-deftest cl-extra-test-mapc ()
   (let ((lst '(a b c))
         (lst2 '(d e f))
-- 
2.32.0