From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED.blaine.gmane.org!not-for-mail From: dick.r.chiang@gmail.com Newsgroups: gmane.emacs.bugs Subject: bug#29799: 24.5; cl-loop guard clause missing Date: Thu, 21 Nov 2019 18:25:04 -0500 Message-ID: <87pnhkke27.fsf@dick> References: <87d138beur.fsf@gmail.com> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Injection-Info: blaine.gmane.org; posting-host="blaine.gmane.org:195.159.176.226"; logging-data="143834"; mail-complaints-to="usenet@blaine.gmane.org" User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/27.0.50 (gnu/linux) Cc: 29799@debbugs.gnu.org, monnier@iro.umontreal.ca, npostavs@gmail.com To: Tino Calancha Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Fri Nov 22 00:26:47 2019 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane.org Original-Received: from lists.gnu.org ([209.51.188.17]) by blaine.gmane.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.89) (envelope-from ) id 1iXvqY-000bGM-Lj for geb-bug-gnu-emacs@m.gmane.org; Fri, 22 Nov 2019 00:26:47 +0100 Original-Received: from localhost ([::1]:46576 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1iXvqX-00038k-Hz for geb-bug-gnu-emacs@m.gmane.org; Thu, 21 Nov 2019 18:26:45 -0500 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:34777) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1iXvq3-00038M-6w for bug-gnu-emacs@gnu.org; Thu, 21 Nov 2019 18:26:17 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1iXvpv-0007YC-Pb for bug-gnu-emacs@gnu.org; Thu, 21 Nov 2019 18:26:12 -0500 Original-Received: from debbugs.gnu.org ([209.51.188.43]:44726) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1iXvpv-0007Y0-Jp for bug-gnu-emacs@gnu.org; Thu, 21 Nov 2019 18:26:07 -0500 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1iXvpq-0008Ka-6C for bug-gnu-emacs@gnu.org; Thu, 21 Nov 2019 18:26:07 -0500 X-Loop: help-debbugs@gnu.org Resent-From: dick.r.chiang@gmail.com Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Thu, 21 Nov 2019 23:26:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 29799 X-GNU-PR-Package: emacs Original-Received: via spool by 29799-submit@debbugs.gnu.org id=B29799.157437872331974 (code B ref 29799); Thu, 21 Nov 2019 23:26:02 +0000 Original-Received: (at 29799) by debbugs.gnu.org; 21 Nov 2019 23:25:23 +0000 Original-Received: from localhost ([127.0.0.1]:53547 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1iXvpB-0008Jb-36 for submit@debbugs.gnu.org; Thu, 21 Nov 2019 18:25:21 -0500 Original-Received: from mail-qt1-f193.google.com ([209.85.160.193]:44561) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1iXvp2-0008J7-2K for 29799@debbugs.gnu.org; Thu, 21 Nov 2019 18:25:20 -0500 Original-Received: by mail-qt1-f193.google.com with SMTP id o11so5673389qtr.11 for <29799@debbugs.gnu.org>; Thu, 21 Nov 2019 15:25:12 -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=lfbPsVNeUztfGlCT5s5jBQyUdP+kH9wwD50CqpmVCYI=; b=DQi694R79xHQzoNIWMSc/LAzrWPr4rSDzmZmAy9KXmedE997ROJHG1W91+cFem951C oZkSdqcCYZMlrS9YNU4Vs7JZ1agcm1mGTSoO4iovrShJ7MQuWQRg2c6/pCeO5JD380ws +J+dGi+vKtvlDhsF8joxzYFKjQNnc31JWf4eIj279RSZJGJZvx3bU8jA1pswft3nMZ2U jQv5vkgrT9fMru4Z8XMZAplmYg62WNtoD5W0/B9FrZoAQbyK7s0mrKEqMvvGNwDrPVJ0 8WLWyAs+FGMkYm6z3snXMPxpvKKu5rxbxA/WmjHTHyD7ogJ4q/+JRYcFjRTY8Z7++HJu CuUQ== 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=lfbPsVNeUztfGlCT5s5jBQyUdP+kH9wwD50CqpmVCYI=; b=Yem5jyD1Hty+7tY0pVh3To6rG2alRzOMyWzFdfHxf88vit8I7KZ78HT5ojYP3EL+EP IQn4I4kn1JF/jDdAs140lp874Nsxwcv2NdCybGQksDqQ4TyjIINdljMxDxg7+8OubE5B EYCHripddioE/FeeHUpCQmMZN6EaXnw15cDqEZl6Wt3mtPlyc+QVTLJ/WXfz0Z9NYPgc WiPWzvPVMe0kHh9f5K10sN4HoCOHYWkpEwXdpVyowjgrOLXFP1B5IJHRkEkCrd58BOUa cwf2rMv0hPscSzshoBox+I0rKB4Yez3emo/kMFH0StVuiNqL+rxi1HD3A+yaTVkqO22N z7wA== X-Gm-Message-State: APjAAAUsjAlRepO/ou0YRez3TdnH6Q4K+JN2bq17uIXJ/hYpXHEgI1KW MkNMSKVK8HP3NbQMbsEDV5w= X-Google-Smtp-Source: APXvYqzOamW2hKmr0d112pZLSzDsvTskswOA44c+jt3copZCHoVn5lYkQO0oiK09OyD8pZHdun2TXQ== X-Received: by 2002:ac8:f35:: with SMTP id e50mr11582640qtk.39.1574378706493; Thu, 21 Nov 2019 15:25:06 -0800 (PST) Original-Received: from localhost (pool-100-33-98-8.nycmny.fios.verizon.net. [100.33.98.8]) by smtp.gmail.com with ESMTPSA id w18sm2203196qkb.41.2019.11.21.15.25.05 (version=TLS1_2 cipher=ECDHE-RSA-AES128-GCM-SHA256 bits=128/128); Thu, 21 Nov 2019 15:25:05 -0800 (PST) X-Google-Original-From: 29799@debbugs.gnu.org In-Reply-To: <87d138beur.fsf@gmail.com> (Tino Calancha's message of "Thu, 21 Dec 2017 18:38:20 +0900") 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: 209.51.188.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:172184 Archived-At: --=-=-= Content-Type: text/plain I noticed the following cases stopped working after commit a036543. ;; should not fail (cl-loop for i from 1 upto 100 and j = 1 then (1+ j) do (cl-assert (= i j) t) until (> j 10)) ;; should return (1 0) (cl-loop with result for x below 3 for y below 2 and z = (progn (push x result) nil) finally return result) --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=0001-Refix-conditional-step-clauses-in-cl-loop.patch Content-Description: patch v2 >From a7fb384120c60cb1131c3e8136cc92fddf3c097c Mon Sep 17 00:00:00 2001 From: dickmao Date: Thu, 21 Nov 2019 12:00:17 -0500 Subject: [PATCH] Refix conditional step clauses in cl-loop Readdress (bug#29799), and add more tests. * lisp/emacs-lisp/cl-macs.el (cl--loop-bindings, cl-loop): (cl--push-clause-loop-body, cl--parse-loop-clause): New convenience macro for tracking cl--loop-conditions (bug#29799) * lisp/emacs-lisp/cl-macs.el (cl--loop-bindings, cl--loop-symbol-macs, cl-loop): Add cl--loop-conditions, remove cl--loop-guard-cond. (cl--push-clause-loop-body): Apply clause to both cl--loop-conditions and cl--loop-body (cl--parse-loop-clause): Use cl--push-clause-loop-body. * test/lisp/emacs-lisp/cl-macs-tests.el (cl-macs-loop-and-assignment): Use docstring. (cl-macs-loop-for-as-arith): Removed expected failure. (cl-macs-loop-conditional-step-clauses): Add some tests. --- lisp/emacs-lisp/cl-macs.el | 96 +++++++++++---------------- test/lisp/emacs-lisp/cl-macs-tests.el | 68 +++++++++++++++++-- 2 files changed, 101 insertions(+), 63 deletions(-) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 80e218884a..a5ecf33203 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -889,7 +889,7 @@ cl-return-from ;;; The "cl-loop" macro. (defvar cl--loop-args) (defvar cl--loop-accum-var) (defvar cl--loop-accum-vars) -(defvar cl--loop-bindings) (defvar cl--loop-body) +(defvar cl--loop-bindings) (defvar cl--loop-body) (defvar cl--loop-conditions) (defvar cl--loop-finally) (defvar cl--loop-finish-flag) ;Symbol set to nil to exit the loop? (defvar cl--loop-first-flag) @@ -897,7 +897,7 @@ cl--loop-initially (defvar cl--loop-name) (defvar cl--loop-result) (defvar cl--loop-result-explicit) (defvar cl--loop-result-var) (defvar cl--loop-steps) -(defvar cl--loop-symbol-macs) (defvar cl--loop-guard-cond) +(defvar cl--loop-symbol-macs) (defun cl--loop-set-iterator-function (kind iterator) (if cl--loop-iterator-function @@ -966,7 +966,8 @@ cl-loop (cl--loop-accum-var nil) (cl--loop-accum-vars nil) (cl--loop-initially nil) (cl--loop-finally nil) (cl--loop-iterator-function nil) (cl--loop-first-flag nil) - (cl--loop-symbol-macs nil) (cl--loop-guard-cond nil)) + (cl--loop-symbol-macs nil) + (cl--loop-conditions nil)) ;; Here is more or less how those dynbind vars are used after looping ;; over cl--parse-loop-clause: ;; @@ -1001,24 +1002,7 @@ cl-loop (list (or cl--loop-result-explicit cl--loop-result)))) (ands (cl--loop-build-ands (nreverse cl--loop-body))) - (while-body - (nconc - (cadr ands) - (if (or (not cl--loop-guard-cond) (not cl--loop-first-flag)) - (nreverse cl--loop-steps) - ;; Right after update the loop variable ensure that the loop - ;; condition, i.e. (car ands), is still satisfied; otherwise, - ;; set `cl--loop-first-flag' nil and skip the remaining - ;; body forms (#Bug#29799). - ;; - ;; (last cl--loop-steps) updates the loop var - ;; (car (butlast cl--loop-steps)) sets `cl--loop-first-flag' nil - ;; (nreverse (cdr (butlast cl--loop-steps))) are the - ;; remaining body forms. - (append (last cl--loop-steps) - `((and ,(car ands) - ,@(nreverse (cdr (butlast cl--loop-steps))))) - `(,(car (butlast cl--loop-steps))))))) + (while-body (nconc (cadr ands) (nreverse cl--loop-steps))) (body (append (nreverse cl--loop-initially) (list (if cl--loop-iterator-function @@ -1051,6 +1035,12 @@ cl-loop (list `(cl-symbol-macrolet ,cl--loop-symbol-macs ,@body)))) `(cl-block ,cl--loop-name ,@body))))) +(defmacro cl--push-clause-loop-body (clause) + "Apply CLAUSE to both `cl--loop-conditions' and `cl--loop-body'." + `(progn + (push ,clause cl--loop-conditions) + (push ,clause cl--loop-body))) + ;; Below is a complete spec for cl-loop, in several parts that correspond ;; to the syntax given in CLtL2. The specs do more than specify where ;; the forms are; it also specifies, as much as Edebug allows, all the @@ -1201,8 +1191,6 @@ cl-loop ;; (def-edebug-spec loop-d-type-spec ;; (&or (loop-d-type-spec . [&or nil loop-d-type-spec]) cl-type-spec)) - - (defun cl--parse-loop-clause () ; uses loop-* (let ((word (pop cl--loop-args)) (hash-types '(hash-key hash-keys hash-value hash-values)) @@ -1281,11 +1269,11 @@ cl--parse-loop-clause (if end-var (push (list end-var end) loop-for-bindings)) (if step-var (push (list step-var step) loop-for-bindings)) - (if end - (push (list - (if down (if excl '> '>=) (if excl '< '<=)) - var (or end-var end)) - cl--loop-body)) + (when end + (cl--push-clause-loop-body + (list + (if down (if excl '> '>=) (if excl '< '<=)) + var (or end-var end)))) (push (list var (list (if down '- '+) var (or step-var step 1))) loop-for-steps))) @@ -1295,7 +1283,7 @@ cl--parse-loop-clause (temp (if (and on (symbolp var)) var (make-symbol "--cl-var--")))) (push (list temp (pop cl--loop-args)) loop-for-bindings) - (push `(consp ,temp) cl--loop-body) + (cl--push-clause-loop-body `(consp ,temp)) (if (eq word 'in-ref) (push (list var `(car ,temp)) cl--loop-symbol-macs) (or (eq temp var) @@ -1318,24 +1306,19 @@ cl--parse-loop-clause ((eq word '=) (let* ((start (pop cl--loop-args)) (then (if (eq (car cl--loop-args) 'then) - (cl--pop2 cl--loop-args) start))) + (cl--pop2 cl--loop-args) start)) + (first-assign (or cl--loop-first-flag + (setq cl--loop-first-flag + (make-symbol "--cl-var--"))))) (push (list var nil) loop-for-bindings) (if (or ands (eq (car cl--loop-args) 'and)) (progn - (push `(,var - (if ,(or cl--loop-first-flag - (setq cl--loop-first-flag - (make-symbol "--cl-var--"))) - ,start ,var)) - loop-for-sets) - (push (list var then) loop-for-steps)) - (push (list var - (if (eq start then) start - `(if ,(or cl--loop-first-flag - (setq cl--loop-first-flag - (make-symbol "--cl-var--"))) - ,start ,then))) - loop-for-sets)))) + (push `(,var (if ,first-assign ,start ,var)) loop-for-sets) + (push `(,var (if ,(car (cl--loop-build-ands + (nreverse cl--loop-conditions))) + ,then ,var)) + loop-for-steps)) + (push `(,var (if ,first-assign ,start ,then)) loop-for-sets)))) ((memq word '(across across-ref)) (let ((temp-vec (make-symbol "--cl-vec--")) @@ -1344,9 +1327,8 @@ cl--parse-loop-clause (push (list temp-vec (pop cl--loop-args)) loop-for-bindings) (push (list temp-len `(length ,temp-vec)) loop-for-bindings) (push (list temp-idx -1) loop-for-bindings) - (push `(< (setq ,temp-idx (1+ ,temp-idx)) - ,temp-len) - cl--loop-body) + (cl--push-clause-loop-body + `(< (setq ,temp-idx (1+ ,temp-idx)) ,temp-len)) (if (eq word 'across-ref) (push (list var `(aref ,temp-vec ,temp-idx)) cl--loop-symbol-macs) @@ -1376,15 +1358,14 @@ cl--parse-loop-clause loop-for-bindings) (push (list var `(elt ,temp-seq ,temp-idx)) cl--loop-symbol-macs) - (push `(< ,temp-idx ,temp-len) cl--loop-body)) + (cl--push-clause-loop-body `(< ,temp-idx ,temp-len))) ;; Evaluate seq length just if needed, that is, when seq is not a cons. (push (list temp-len (or (consp seq) `(length ,temp-seq))) loop-for-bindings) (push (list var nil) loop-for-bindings) - (push `(and ,temp-seq - (or (consp ,temp-seq) - (< ,temp-idx ,temp-len))) - cl--loop-body) + (cl--push-clause-loop-body `(and ,temp-seq + (or (consp ,temp-seq) + (< ,temp-idx ,temp-len)))) (push (list var `(if (consp ,temp-seq) (pop ,temp-seq) (aref ,temp-seq ,temp-idx))) @@ -1480,9 +1461,8 @@ cl--parse-loop-clause (push (list var '(selected-frame)) loop-for-bindings) (push (list temp nil) loop-for-bindings) - (push `(prog1 (not (eq ,var ,temp)) - (or ,temp (setq ,temp ,var))) - cl--loop-body) + (cl--push-clause-loop-body `(prog1 (not (eq ,var ,temp)) + (or ,temp (setq ,temp ,var)))) (push (list var `(next-frame ,var)) loop-for-steps))) @@ -1503,9 +1483,8 @@ cl--parse-loop-clause (push (list minip `(minibufferp (window-buffer ,var))) loop-for-bindings) (push (list temp nil) loop-for-bindings) - (push `(prog1 (not (eq ,var ,temp)) - (or ,temp (setq ,temp ,var))) - cl--loop-body) + (cl--push-clause-loop-body `(prog1 (not (eq ,var ,temp)) + (or ,temp (setq ,temp ,var)))) (push (list var `(next-window ,var ,minip)) loop-for-steps))) @@ -1529,7 +1508,6 @@ cl--parse-loop-clause t) cl--loop-body)) (when loop-for-steps - (setq cl--loop-guard-cond t) (push (cons (if ands 'cl-psetq 'setq) (apply 'append (nreverse loop-for-steps))) cl--loop-steps)))) diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index 09ce660a2f..8523044714 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -30,7 +30,7 @@ ;;; ANSI 6.1.1.7 Destructuring (ert-deftest cl-macs-loop-and-assignment () - ;; Bug#6583 + "Bug#6583" :expected-result :failed (should (equal (cl-loop for numlist in '((1 2 4.0) (5 6 8.3) (8 9 10.4)) for a = (cl-first numlist) @@ -61,7 +61,6 @@ ;;; 6.1.2.1.1 The for-as-arithmetic subclause (ert-deftest cl-macs-loop-for-as-arith () "Test various for-as-arithmetic subclauses." - :expected-result :failed (should (equal (cl-loop for i to 10 by 3 collect i) '(0 3 6 9))) (should (equal (cl-loop for i upto 3 collect i) @@ -74,9 +73,9 @@ '(10 8 6))) (should (equal (cl-loop for i from 10 downto 1 by 3 collect i) '(10 7 4 1))) - (should (equal (cl-loop for i above 0 by 2 downfrom 10 collect i) + (should (equal (cl-loop for i downfrom 10 above 0 by 2 collect i) '(10 8 6 4 2))) - (should (equal (cl-loop for i downto 10 from 15 collect i) + (should (equal (cl-loop for i from 15 downto 10 collect i) '(15 14 13 12 11 10)))) (ert-deftest cl-macs-loop-for-as-arith-order-side-effects () @@ -530,4 +529,65 @@ l) '(1)))) +(ert-deftest cl-macs-loop-conditional-step-clauses () + "These tests failed under the initial fixes in #bug#29799." + (should (cl-loop for i from 1 upto 100 and j = 1 then (1+ j) + if (not (= i j)) + return nil + end + until (> j 10) + finally return t)) + + (should (equal (let* ((size 7) + (arr (make-vector size 0))) + (cl-loop for k below size + for x = (* 2 k) and y = (1+ (elt arr k)) + collect (list k x y))) + '((0 0 1) (1 2 1) (2 4 1) (3 6 1) (4 8 1) (5 10 1) (6 12 1)))) + + (should (equal (cl-loop for x below 3 + for y below 2 and z = 1 + collect x) + '(0 1))) + + (should (equal (cl-loop for x below 3 + and y below 2 + collect x) + '(0 1))) + + ;; this is actually disallowed in clisp, but is semantically consistent + (should (equal (cl-loop with result + for x below 3 + for y = (progn (push x result) x) and z = 1 + append (list x y) into result1 + finally return (append result result1)) + '(2 1 0 0 0 1 1 2 2))) + + (should (equal (cl-loop with result + for x below 3 + for _y = (progn (push x result)) + finally return result) + '(2 1 0))) + + ;; this nonintuitive result is replicated by clisp + (should (equal (cl-loop with result + for x below 3 + and y = (progn (push x result)) + finally return result) + '(2 1 0 0))) + + ;; this nonintuitive result is replicated by clisp + (should (equal (cl-loop with result + for x below 3 + and y = (progn (push x result)) then (progn (push (1+ x) result)) + finally return result) + '(3 2 1 0))) + + (should (cl-loop with result + for x below 3 + for y = (progn (push x result) x) then (progn (push (1+ x) result) (1+ x)) + and z = 1 + collect y into result1 + finally return (equal (nreverse result) result1)))) + ;;; cl-macs-tests.el ends here -- 2.23.0 --=-=-=--