From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED!not-for-mail From: Tino Calancha Newsgroups: gmane.emacs.bugs Subject: bug#25826: 26.0.50; cl-mapc and cl-mapl do needless consing Date: Wed, 22 Feb 2017 14:46:45 +0900 Message-ID: <87y3wyojzu.fsf@calancha-pc> References: <87d1ecyno9.fsf@calancha-pc> <87shn7hdbx.fsf@users.sourceforge.net> <87lgsyncr1.fsf@calancha-pc> <87efyqhpb5.fsf@users.sourceforge.net> NNTP-Posting-Host: blaine.gmane.org Mime-Version: 1.0 Content-Type: text/plain X-Trace: blaine.gmane.org 1487742445 18244 195.159.176.226 (22 Feb 2017 05:47:25 GMT) X-Complaints-To: usenet@blaine.gmane.org NNTP-Posting-Date: Wed, 22 Feb 2017 05:47:25 +0000 (UTC) User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.0.50 (gnu/linux) Cc: 25826@debbugs.gnu.org, tino.calancha@gmail.com To: npostavs@users.sourceforge.net Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Wed Feb 22 06:47:17 2017 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by blaine.gmane.org with esmtp (Exim 4.84_2) (envelope-from ) id 1cgPlh-0003V1-TY for geb-bug-gnu-emacs@m.gmane.org; Wed, 22 Feb 2017 06:47:14 +0100 Original-Received: from localhost ([::1]:50006 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1cgPlk-0005lX-4S for geb-bug-gnu-emacs@m.gmane.org; Wed, 22 Feb 2017 00:47:16 -0500 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:58279) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1cgPlZ-0005kY-Co for bug-gnu-emacs@gnu.org; Wed, 22 Feb 2017 00:47:08 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1cgPlW-0004mv-5M for bug-gnu-emacs@gnu.org; Wed, 22 Feb 2017 00:47:05 -0500 Original-Received: from debbugs.gnu.org ([208.118.235.43]:51360) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1cgPlW-0004mr-0I for bug-gnu-emacs@gnu.org; Wed, 22 Feb 2017 00:47:02 -0500 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1cgPlV-00024T-L7 for bug-gnu-emacs@gnu.org; Wed, 22 Feb 2017 00:47:01 -0500 X-Loop: help-debbugs@gnu.org Resent-From: Tino Calancha Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Wed, 22 Feb 2017 05:47:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 25826 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: Original-Received: via spool by 25826-submit@debbugs.gnu.org id=B25826.14877424197953 (code B ref 25826); Wed, 22 Feb 2017 05:47:01 +0000 Original-Received: (at 25826) by debbugs.gnu.org; 22 Feb 2017 05:46:59 +0000 Original-Received: from localhost ([127.0.0.1]:49559 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1cgPlS-00024C-KI for submit@debbugs.gnu.org; Wed, 22 Feb 2017 00:46:58 -0500 Original-Received: from mail-pg0-f66.google.com ([74.125.83.66]:34857) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1cgPlQ-00023z-A7 for 25826@debbugs.gnu.org; Wed, 22 Feb 2017 00:46:56 -0500 Original-Received: by mail-pg0-f66.google.com with SMTP id 1so407293pgz.2 for <25826@debbugs.gnu.org>; Tue, 21 Feb 2017 21:46:56 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20161025; h=from:to:cc:subject:references:date:in-reply-to:message-id :user-agent:mime-version; bh=TCXL5hR+UkbGB/aCv20maAaZ6r6KUJ6U3Ym6ypBM4cM=; b=OicSiS6TJr04WSMBnN/COLDLJXd91fhAhdhw+XBq7pavIRShY/ic4Pl7wiBYLhxoD1 dOtMvMFZZyiGHNEBwfslLadMqh6Y4q1SbjJGwPkBuh2ieyyWBfXJpg1LX9d13+z5ajdc k5z4hsa+Frw/51vDSjc1RM0Nr3JoyVJaNMzVn+GYfP5QkFOjf6NzD5U03WBBZ2JBeBWe CRzUYLR7bWhH10dRf9Q1FcEKj9MYmyE6Cm1XXN+OLsqqQsa3o5+6aZ0LTpBPq8wd+4bu KyKSSzeADZi5PHfvL2JUgCNoK7CahStINjWmxPx2TW7qw2L9T+rEzlB6V1tfZjeMvI1D mc9w== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20161025; h=x-gm-message-state:from:to:cc:subject:references:date:in-reply-to :message-id:user-agent:mime-version; bh=TCXL5hR+UkbGB/aCv20maAaZ6r6KUJ6U3Ym6ypBM4cM=; b=qVmpz/GYP0DPyAae4odW4Y0Ea71hFovsM19usrthN5mCfDjOcWzE5kkeysUF9hlo79 tP0YiIZRFYiuPNdKHyrHcHK/qxcbvrVpCYj8TW3XpEr16IsSPpgUhY2JMt9ZauitzHvJ uIZRN+OzHBXiXBz+kqSDFCqrpb1e5wpkroaV7QDC52zia0Q91HTmz7nsqqmM7kOT2R9S TLMpJpztg0obweGOyzGAMWCF30GsDPLOvNqj99YECBoDbHST6kwQBwPdL4GGX82cLlVS ulrfl88Dx3Bio8c9Qe+b3ubQWcqa9j4aGKIRv8FdWNP5PGxciz0xbFxZH6v7W6m8j5lh t23g== X-Gm-Message-State: AMke39mgk3IvELi2eGaPsqPuWpFb+vPJj80a8I8XA7L1uUyFOtGNjfuKr5umBAm8lnT7Sg== X-Received: by 10.98.102.21 with SMTP id a21mr37624084pfc.29.1487742410326; Tue, 21 Feb 2017 21:46:50 -0800 (PST) Original-Received: from calancha-pc (104.81.147.124.dy.bbexcite.jp. [124.147.81.104]) by smtp.gmail.com with ESMTPSA id q90sm619229pfk.73.2017.02.21.21.46.48 (version=TLS1_2 cipher=ECDHE-RSA-CHACHA20-POLY1305 bits=256/256); Tue, 21 Feb 2017 21:46:49 -0800 (PST) In-Reply-To: (Tino Calancha's message of "Wed, 22 Feb 2017 13:14:04 +0900 (JST)") X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 208.118.235.43 X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Original-Sender: "bug-gnu-emacs" Xref: news.gmane.org gmane.emacs.bugs:129649 Archived-At: Tino Calancha writes: > On Tue, 21 Feb 2017, npostavs@users.sourceforge.net wrote: > >> Tino Calancha writes: >> >>> How about the following updated patch? >> >> Looks good. Perhaps some tests would be a good idea too? > I think so, i will prepare some and post them here. Thanks. It's tricky to write a test to check if cl-mapc/cl-mapl over cons. Thus, i have written tests that just ensure the return values are as expected. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; >From 2824777a3b1b5217fb1dd5cddc89f4f2b5679b7a Mon Sep 17 00:00:00 2001 From: Tino Calancha Date: Wed, 22 Feb 2017 14:38:17 +0900 Subject: [PATCH] Prevent for consing in cl-mapc and cl-mapl * lisp/emacs-lisp/cl-extra.el (cl--mapcar-many): Add optional arg ACC; If non-nil, accumulate values in the result (Bug#25826). (cl-mapc): Do computations inside function instead of call cl-map. (cl-mapl): Do computations inside function instead of call cl-maplist. * lisp/emacs-lisp/cl-lib.el (mapcar): Add autoload cookie. Call cl--mapcar-many with non-nil 3rd argument. * test/lisp/emacs-lisp/cl-extra-tests.el (cl-extra-test-map) (cl-extra-test-mapc, cl-extra-test-mapcar, cl-extra-test-mapl) (cl-extra-test-maplist): New tests. --- lisp/emacs-lisp/cl-extra.el | 38 +++++++++++++++------- lisp/emacs-lisp/cl-lib.el | 5 +-- test/lisp/emacs-lisp/cl-extra-tests.el | 59 ++++++++++++++++++++++++++++++++++ 3 files changed, 88 insertions(+), 14 deletions(-) diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index edd14b816f..8cba913710 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -89,7 +89,7 @@ cl-equalp ;;; Control structures. ;;;###autoload -(defun cl--mapcar-many (cl-func cl-seqs) +(defun cl--mapcar-many (cl-func cl-seqs &optional acc) (if (cdr (cdr cl-seqs)) (let* ((cl-res nil) (cl-n (apply 'min (mapcar 'length cl-seqs))) @@ -106,20 +106,23 @@ cl--mapcar-many (setcar cl-p1 (cdr (car cl-p1)))) (aref (car cl-p1) cl-i))) (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2))) - (push (apply cl-func cl-args) cl-res) + (if acc + (push (apply cl-func cl-args) cl-res) + (apply cl-func cl-args)) (setq cl-i (1+ cl-i))) - (nreverse cl-res)) + (and acc (nreverse cl-res))) (let ((cl-res nil) (cl-x (car cl-seqs)) (cl-y (nth 1 cl-seqs))) (let ((cl-n (min (length cl-x) (length cl-y))) (cl-i -1)) (while (< (setq cl-i (1+ cl-i)) cl-n) - (push (funcall cl-func - (if (consp cl-x) (pop cl-x) (aref cl-x cl-i)) - (if (consp cl-y) (pop cl-y) (aref cl-y cl-i))) - cl-res))) - (nreverse cl-res)))) + (let ((val (funcall cl-func + (if (consp cl-x) (pop cl-x) (aref cl-x cl-i)) + (if (consp cl-y) (pop cl-y) (aref cl-y cl-i))))) + (when acc + (push val cl-res))))) + (and acc (nreverse cl-res))))) ;;;###autoload (defun cl-map (cl-type cl-func cl-seq &rest cl-rest) @@ -142,7 +145,7 @@ cl-maplist (while (not (memq nil cl-args)) (push (apply cl-func cl-args) cl-res) (setq cl-p cl-args) - (while cl-p (setcar cl-p (cdr (pop cl-p)) ))) + (while cl-p (setcar cl-p (cdr (pop cl-p))))) (nreverse cl-res)) (let ((cl-res nil)) (while cl-list @@ -155,8 +158,14 @@ cl-mapc "Like `cl-mapcar', but does not accumulate values returned by the function. \n(fn FUNCTION SEQUENCE...)" (if cl-rest - (progn (apply 'cl-map nil cl-func cl-seq cl-rest) - cl-seq) + (if (or (cdr cl-rest) (nlistp cl-seq) (nlistp (car cl-rest))) + (progn + (cl--mapcar-many cl-func (cons cl-seq cl-rest)) + cl-seq) + (let ((cl-x cl-seq) (cl-y (car cl-rest))) + (while (and cl-x cl-y) + (funcall cl-func (pop cl-x) (pop cl-y))) + cl-seq)) (mapc cl-func cl-seq))) ;;;###autoload @@ -164,7 +173,12 @@ cl-mapl "Like `cl-maplist', but does not accumulate values returned by the function. \n(fn FUNCTION LIST...)" (if cl-rest - (apply 'cl-maplist cl-func cl-list cl-rest) + (let ((cl-args (cons cl-list (copy-sequence cl-rest))) + cl-p) + (while (not (memq nil cl-args)) + (apply cl-func cl-args) + (setq cl-p cl-args) + (while cl-p (setcar cl-p (cdr (pop cl-p)))))) (let ((cl-p cl-list)) (while cl-p (funcall cl-func cl-p) (setq cl-p (cdr cl-p))))) cl-list) diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 5aa8f1bf65..8c4455a3da 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -347,8 +347,9 @@ cl-float-negative-epsilon (cl--defalias 'cl-copy-seq 'copy-sequence) -(declare-function cl--mapcar-many "cl-extra" (cl-func cl-seqs)) +(declare-function cl--mapcar-many "cl-extra" (cl-func cl-seqs &optional acc)) +;;;###autoload (defun cl-mapcar (cl-func cl-x &rest cl-rest) "Apply FUNCTION to each element of SEQ, and make a list of the results. If there are several SEQs, FUNCTION is called with that many arguments, @@ -358,7 +359,7 @@ cl-mapcar \n(fn FUNCTION SEQ...)" (if cl-rest (if (or (cdr cl-rest) (nlistp cl-x) (nlistp (car cl-rest))) - (cl--mapcar-many cl-func (cons cl-x cl-rest)) + (cl--mapcar-many cl-func (cons cl-x cl-rest) 'accumulate) (let ((cl-res nil) (cl-y (car cl-rest))) (while (and cl-x cl-y) (push (funcall cl-func (pop cl-x) (pop cl-y)) cl-res)) diff --git a/test/lisp/emacs-lisp/cl-extra-tests.el b/test/lisp/emacs-lisp/cl-extra-tests.el index 3e2388acc6..82b2206a6c 100644 --- a/test/lisp/emacs-lisp/cl-extra-tests.el +++ b/test/lisp/emacs-lisp/cl-extra-tests.el @@ -35,4 +35,63 @@ (should (eq (cl-getf plist 'y :none) nil)) (should (eq (cl-getf plist 'z :none) :none)))) +(ert-deftest cl-extra-test-mapc () + (let ((lst '(a b c)) + (lst2 '(d e f)) + (lst3 '(1 2 3)) + (fn1 (lambda (x) nil)) + (fn2 (lambda (x y) nil)) + (fn3 (lambda (x y z) nil))) + (should (equal lst (cl-mapc fn1 lst))) + (should (equal lst (cl-mapc fn2 lst lst2))) + (should (equal lst (cl-mapc fn3 lst lst2 lst3))))) + +(ert-deftest cl-extra-test-mapl () + (let ((lst '(a b c)) + (lst2 '(d e f)) + (lst3 '(1 2 3)) + (fn1 (lambda (x) nil)) + (fn2 (lambda (x y) nil)) + (fn3 (lambda (x y z) nil))) + (should (equal lst (cl-mapl fn1 lst))) + (should (equal lst (cl-mapl fn2 lst lst2))) + (should (equal lst (cl-mapl fn3 lst lst2 lst3))))) + +(ert-deftest cl-extra-test-mapcar () + (let ((lst '(a b c)) + (lst2 '(d e f)) + (lst3 '(1 2 3)) + (fn1 (lambda (x) x)) + (fn2 (lambda (x y) y)) + (fn3 (lambda (x y z) z))) + (should (equal lst (cl-mapcar fn1 lst))) + (should (equal lst2 (cl-mapcar fn2 lst lst2))) + (should (equal lst3 (cl-mapcar fn3 lst lst2 lst3))))) + +(ert-deftest cl-extra-test-map () + (let ((lst '(a b c)) + (lst2 '(d e f)) + (lst3 '(1 2 3)) + (fn1 (lambda (x) x)) + (fn2 (lambda (x y) y)) + (fn3 (lambda (x y z) (string-to-char (format "%S" x))))) + (should (equal lst (cl-map 'list fn1 lst))) + (should (equal (vconcat lst2) (cl-map 'vector fn2 lst lst2))) + (should (equal (mapconcat (lambda (x) (format "%S" x)) lst "") + (cl-map 'string fn3 lst lst2 lst3))))) + +(ert-deftest cl-extra-test-maplist () + (let ((lst '(a b c)) + (lst2 '(d e f)) + (lst3 '(1 2 3)) + (fn1 (lambda (x) x)) + (fn2 (lambda (x y) y)) + (fn3 (lambda (x y z) z))) + (should (equal (list lst (cdr lst) (cddr lst)) + (cl-maplist fn1 lst))) + (should (equal (list lst2 (cdr lst2) (cddr lst2)) + (cl-maplist fn2 lst lst2))) + (should (equal (list lst3 (cdr lst3) (cddr lst3)) + (cl-maplist fn3 lst lst2 lst3))))) + ;;; cl-extra-tests.el ends here -- 2.11.0 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; In GNU Emacs 26.0.50 (build 4, x86_64-pc-linux-gnu, GTK+ Version 3.22.7) of 2017-02-22 Repository revision: fb997d30af28da4712ca64876feddbd07db20e13