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 12:08:34 +0900 Message-ID: <87lgsyncr1.fsf@calancha-pc> References: <87d1ecyno9.fsf@calancha-pc> <87shn7hdbx.fsf@users.sourceforge.net> NNTP-Posting-Host: blaine.gmane.org Mime-Version: 1.0 Content-Type: text/plain X-Trace: blaine.gmane.org 1487732956 11453 195.159.176.226 (22 Feb 2017 03:09:16 GMT) X-Complaints-To: usenet@blaine.gmane.org NNTP-Posting-Date: Wed, 22 Feb 2017 03:09:16 +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 04:09:12 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 1cgNIk-0002Ib-Nb for geb-bug-gnu-emacs@m.gmane.org; Wed, 22 Feb 2017 04:09:10 +0100 Original-Received: from localhost ([::1]:49549 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1cgNIq-0000UL-Dy for geb-bug-gnu-emacs@m.gmane.org; Tue, 21 Feb 2017 22:09:16 -0500 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:38477) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1cgNIg-0000Ra-1e for bug-gnu-emacs@gnu.org; Tue, 21 Feb 2017 22:09:07 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1cgNIc-0001HN-LG for bug-gnu-emacs@gnu.org; Tue, 21 Feb 2017 22:09:06 -0500 Original-Received: from debbugs.gnu.org ([208.118.235.43]:51276) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1cgNIc-0001HJ-Hu for bug-gnu-emacs@gnu.org; Tue, 21 Feb 2017 22:09:02 -0500 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1cgNIc-0001Xj-Df for bug-gnu-emacs@gnu.org; Tue, 21 Feb 2017 22:09:02 -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 03:09:02 +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.14877329275907 (code B ref 25826); Wed, 22 Feb 2017 03:09:02 +0000 Original-Received: (at 25826) by debbugs.gnu.org; 22 Feb 2017 03:08:47 +0000 Original-Received: from localhost ([127.0.0.1]:49475 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1cgNIN-0001X7-9b for submit@debbugs.gnu.org; Tue, 21 Feb 2017 22:08:47 -0500 Original-Received: from mail-pg0-f65.google.com ([74.125.83.65]:36817) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1cgNIL-0001Wj-FG for 25826@debbugs.gnu.org; Tue, 21 Feb 2017 22:08:45 -0500 Original-Received: by mail-pg0-f65.google.com with SMTP id z128so2591091pgb.3 for <25826@debbugs.gnu.org>; Tue, 21 Feb 2017 19:08:45 -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=AxFFQvreDV/rIWdzRvgwZOtlSWzsNpJQ/yY1Oo2UHik=; b=Chg+MzWLZNPnWjzGHLDGwKA+p64LJQrtFs77m8wY5PSB7wHSOF2SplAfobXj07epw8 JQPhmx6tNEOmIWt/BrTvoLj9Y2B2590NXlU8wqUW8zl78/yQEvK1Z8FzPz3nhfZeFWbR KuVh/8XJmIGTu/gVSVbfWYiLKw1qLw9GHv1S617iSgC3BuBwNKaEVf3e6o+6nkyQdDjC x9Lz0fYvpSq/pvO8sp0QHPJjvo26BFOY2vkY8wAALmQ1s+sNF3XnAa1aJZaAsBPJEov6 fL2IclmmgYcnyXljAWvYDuQjIn5P58v987oFtlgF7dSfbn7mSTDvLLX/Hw16sPMESfNB I/bQ== 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=AxFFQvreDV/rIWdzRvgwZOtlSWzsNpJQ/yY1Oo2UHik=; b=pMaLt1Kw8BaxYC9p4N+zjoflLthIEhiS9cz4A+QvZ9ViZmoNj0fBqc5TozWOA7qCXh e96IPQguNPvX6UD4dLv677OR33DMMf9wNEaBQnGxLOZk6Vak6T4WsAmGcgb8cfMoP1zC XjVgmDX9xCb/Ia7B6UzMwWjSlv4ytu2kZp+Z40ODmRlQOZXUArrosfXNISYhwM+GihAN yI3AJB8Ddh5xrKUGtgHED4l/kRSE1FTRuoEPNZS2VeBtBl9n8bc4fmAExNiK/dd+NLHa n2kP53ib7ygj3h5d/m53+R19x2YSgFdW3B8zwXaouDD/LY+lXw2mbKDhJH2V8Di20uc9 Ez9w== X-Gm-Message-State: AMke39lAOaQWQhPd57bNM7InYwOKMwhnSm3+j4pZFfmifiTRtCGVGJBYzvitqW2v0h7QrQ== X-Received: by 10.98.65.148 with SMTP id g20mr37770928pfd.44.1487732919762; Tue, 21 Feb 2017 19:08:39 -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 64sm43300358pfq.112.2017.02.21.19.08.37 (version=TLS1_2 cipher=ECDHE-RSA-CHACHA20-POLY1305 bits=256/256); Tue, 21 Feb 2017 19:08:39 -0800 (PST) In-Reply-To: <87shn7hdbx.fsf@users.sourceforge.net> (npostavs's message of "Tue, 21 Feb 2017 08:40:18 -0500") 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:129644 Archived-At: npostavs@users.sourceforge.net writes: > Tino Calancha writes: > >> Current implementation of cl-mapc (cl-mapl) uses `cl-mapcar' >> (`cl-maplist') when input contains > 1 sequence. Thus, >> they cons the values and just discard then at the end. >> >> Following patch adds a defvar which acts as a flag for consing >> the values. The flag is bind to nil in the case of `cl-mapc' and >> `cl-mapl'. > > Is it possible to do this via a parameter instead? Using a global > variable seems like asking for trouble in case of nested calls or > similar. How about the following updated patch? ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; >From 917e290e9101426b492becd814f2f570d1fc9802 Mon Sep 17 00:00:00 2001 From: Tino Calancha Date: Wed, 22 Feb 2017 12:06:04 +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. --- lisp/emacs-lisp/cl-extra.el | 38 ++++++++++++++++++++++++++------------ lisp/emacs-lisp/cl-lib.el | 5 +++-- 2 files changed, 29 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)) -- 2.11.0 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; In GNU Emacs 26.0.50 (build 2, x86_64-pc-linux-gnu, GTK+ Version 3.22.7) of 2017-02-22 Repository revision: fb997d30af28da4712ca64876feddbd07db20e13