From: Noam Postavsky <npostavs@gmail.com>
To: Philipp Stephani <p.stephani2@gmail.com>
Cc: 40727@debbugs.gnu.org, Tino Calancha <tino.calancha@gmail.com>
Subject: bug#40727: 27.0.91; 'cl-loop ... across ... and' seems broken
Date: Thu, 30 Apr 2020 19:40:43 -0400 [thread overview]
Message-ID: <87v9lgmtj8.fsf@gmail.com> (raw)
In-Reply-To: <871ro5nojr.fsf@gmail.com> (Noam Postavsky's message of "Thu, 30 Apr 2020 08:30:48 -0400")
[-- Attachment #1: Type: text/plain, Size: 600 bytes --]
Noam Postavsky <npostavs@gmail.com> writes:
> By the way, while adding the test case I found an additional regression
> involving loop termination by a 'var = ...' clause. I'll open another
> bug about it soon.
Actually, it's very closely connected (only observable after fixing the
original bug, since otherwise the necessary conditions trigger the
--cl-vec-- is void error), so I'll keep it here. When there is a
(cl-loop for VAR across ARRAY and VAR2 = ...) the array index would get
incremented twice per loop. Fixed by the patch below (applies on top of
the patch in my previous message).
[-- Attachment #2: patch --]
[-- Type: text/plain, Size: 2046 bytes --]
From 62d4626a1684ec7fd7d560cdf75f1b6a5f726c37 Mon Sep 17 00:00:00 2001
From: Noam Postavsky <npostavs@gmail.com>
Date: Thu, 30 Apr 2020 18:55:40 -0400
Subject: [PATCH 2/2] Don't increment array index in cl-loop twice (Bug#40727)
* lisp/emacs-lisp/cl-macs.el (cl--parse-loop-clause): Put the temp-idx
increment in cl--loop-body, leaving just the side-effect free testing
of the index for both cl--loop-body and cl--loop-conditions.
* test/lisp/emacs-lisp/cl-macs-tests.el (cl-macs-loop-and-arrays):
Extend test to cover this case.
---
lisp/emacs-lisp/cl-macs.el | 3 ++-
test/lisp/emacs-lisp/cl-macs-tests.el | 3 +++
2 files changed, 5 insertions(+), 1 deletion(-)
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 20bd1883c3..d6997ce0d2 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -1325,8 +1325,9 @@ cl--parse-loop-clause
(temp-idx (make-symbol "--cl-idx--")))
(push (list temp-vec (pop cl--loop-args)) loop-for-bindings)
(push (list temp-idx -1) loop-for-bindings)
+ (push `(setq ,temp-idx (1+ ,temp-idx)) cl--loop-body)
(cl--push-clause-loop-body
- `(< (setq ,temp-idx (1+ ,temp-idx)) (length ,temp-vec)))
+ `(< ,temp-idx (length ,temp-vec)))
(if (eq word 'across-ref)
(push (list var `(aref ,temp-vec ,temp-idx))
cl--loop-symbol-macs)
diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el
index 77609a42a9..983e79ac57 100644
--- a/test/lisp/emacs-lisp/cl-macs-tests.el
+++ b/test/lisp/emacs-lisp/cl-macs-tests.el
@@ -43,6 +43,9 @@ cl-macs-loop-and-arrays
"Bug#40727"
(should (equal (cl-loop for y = (- (or x 0)) and x across [1 2]
collect (cons x y))
+ '((1 . 0) (2 . -1))))
+ (should (equal (cl-loop for x across [1 2] and y = (- (or x 0))
+ collect (cons x y))
'((1 . 0) (2 . -1)))))
(ert-deftest cl-macs-loop-destructure ()
--
2.11.0
[-- Attachment #3: Type: text/plain, Size: 143 bytes --]
Eli, is it okay to push both of these to emacs-27? Alternatively,
reverting both fixes to Bug#29799 in addition to the Bug#29866 fix
works:
[-- Attachment #4: patch --]
[-- Type: text/plain, Size: 9439 bytes --]
From 431d7ebc466163808535706cbb4929b25e5b4fbc Mon Sep 17 00:00:00 2001
From: Noam Postavsky <npostavs@gmail.com>
Date: Thu, 30 Apr 2020 19:33:34 -0400
Subject: [PATCH 1/4] Revert "Refix conditional step clauses in cl-loop"
This reverts commit 045cfbef09a67c334e4772cb045181cf2203d839.
---
lisp/emacs-lisp/cl-macs.el | 96 ++++++++++++++++++++++++++++------------------
1 file changed, 59 insertions(+), 37 deletions(-)
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index d56f4151df..cda25d186f 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-conditions)
+(defvar cl--loop-bindings) (defvar cl--loop-body)
(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-symbol-macs) (defvar cl--loop-guard-cond)
(defun cl--loop-set-iterator-function (kind iterator)
(if cl--loop-iterator-function
@@ -966,8 +966,7 @@ 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-conditions nil))
+ (cl--loop-symbol-macs nil) (cl--loop-guard-cond nil))
;; Here is more or less how those dynbind vars are used after looping
;; over cl--parse-loop-clause:
;;
@@ -1002,7 +1001,24 @@ 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) (nreverse cl--loop-steps)))
+ (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)))))))
(body (append
(nreverse cl--loop-initially)
(list (if cl--loop-iterator-function
@@ -1035,12 +1051,6 @@ 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
@@ -1191,6 +1201,8 @@ cl--push-clause-loop-body
;; (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))
@@ -1269,11 +1281,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))
- (when end
- (cl--push-clause-loop-body
- (list
- (if down (if excl '> '>=) (if excl '< '<=))
- var (or end-var end))))
+ (if end
+ (push (list
+ (if down (if excl '> '>=) (if excl '< '<=))
+ var (or end-var end))
+ cl--loop-body))
(push (list var (list (if down '- '+) var
(or step-var step 1)))
loop-for-steps)))
@@ -1283,7 +1295,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)
- (cl--push-clause-loop-body `(consp ,temp))
+ (push `(consp ,temp) cl--loop-body)
(if (eq word 'in-ref)
(push (list var `(car ,temp)) cl--loop-symbol-macs)
(or (eq temp var)
@@ -1306,19 +1318,24 @@ 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))
- (first-assign (or cl--loop-first-flag
- (setq cl--loop-first-flag
- (make-symbol "--cl-var--")))))
+ (cl--pop2 cl--loop-args) start)))
(push (list var nil) loop-for-bindings)
(if (or ands (eq (car cl--loop-args) 'and))
(progn
- (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))))
+ (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))))
((memq word '(across across-ref))
(let ((temp-vec (make-symbol "--cl-vec--"))
@@ -1327,8 +1344,9 @@ 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)
- (cl--push-clause-loop-body
- `(< (setq ,temp-idx (1+ ,temp-idx)) ,temp-len))
+ (push `(< (setq ,temp-idx (1+ ,temp-idx))
+ ,temp-len)
+ cl--loop-body)
(if (eq word 'across-ref)
(push (list var `(aref ,temp-vec ,temp-idx))
cl--loop-symbol-macs)
@@ -1358,14 +1376,15 @@ cl--parse-loop-clause
loop-for-bindings)
(push (list var `(elt ,temp-seq ,temp-idx))
cl--loop-symbol-macs)
- (cl--push-clause-loop-body `(< ,temp-idx ,temp-len)))
+ (push `(< ,temp-idx ,temp-len) cl--loop-body))
;; 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)
- (cl--push-clause-loop-body `(and ,temp-seq
- (or (consp ,temp-seq)
- (< ,temp-idx ,temp-len))))
+ (push `(and ,temp-seq
+ (or (consp ,temp-seq)
+ (< ,temp-idx ,temp-len)))
+ cl--loop-body)
(push (list var `(if (consp ,temp-seq)
(pop ,temp-seq)
(aref ,temp-seq ,temp-idx)))
@@ -1461,8 +1480,9 @@ cl--parse-loop-clause
(push (list var '(selected-frame))
loop-for-bindings)
(push (list temp nil) loop-for-bindings)
- (cl--push-clause-loop-body `(prog1 (not (eq ,var ,temp))
- (or ,temp (setq ,temp ,var))))
+ (push `(prog1 (not (eq ,var ,temp))
+ (or ,temp (setq ,temp ,var)))
+ cl--loop-body)
(push (list var `(next-frame ,var))
loop-for-steps)))
@@ -1483,8 +1503,9 @@ cl--parse-loop-clause
(push (list minip `(minibufferp (window-buffer ,var)))
loop-for-bindings)
(push (list temp nil) loop-for-bindings)
- (cl--push-clause-loop-body `(prog1 (not (eq ,var ,temp))
- (or ,temp (setq ,temp ,var))))
+ (push `(prog1 (not (eq ,var ,temp))
+ (or ,temp (setq ,temp ,var)))
+ cl--loop-body)
(push (list var `(next-window ,var ,minip))
loop-for-steps)))
@@ -1508,6 +1529,7 @@ 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))))
--
2.11.0
[-- Attachment #5: patch --]
[-- Type: text/plain, Size: 3297 bytes --]
From 8982a0756c7fc4e1cffd3989509fd243989f946c Mon Sep 17 00:00:00 2001
From: Noam Postavsky <npostavs@gmail.com>
Date: Thu, 30 Apr 2020 19:33:50 -0400
Subject: [PATCH 2/4] Revert "cl-loop: Add missing guard condition"
This reverts commit a0365437c9ee308ad7978e436631020f513b25e7.
---
lisp/emacs-lisp/cl-macs.el | 32 +++++++-------------------------
1 file changed, 7 insertions(+), 25 deletions(-)
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index cda25d186f..00f34d3fb6 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -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,7 @@ 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))
;; Here is more or less how those dynbind vars are used after looping
;; over cl--parse-loop-clause:
;;
@@ -1001,24 +1001,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
@@ -1528,11 +1511,10 @@ cl--parse-loop-clause
,(cl--loop-let (nreverse loop-for-sets) 'setq ands)
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))))
+ (if loop-for-steps
+ (push (cons (if ands 'cl-psetq 'setq)
+ (apply 'append (nreverse loop-for-steps)))
+ cl--loop-steps))))
((eq word 'repeat)
(let ((temp (make-symbol "--cl-var--")))
--
2.11.0
[-- Attachment #6: patch --]
[-- Type: text/plain, Size: 2643 bytes --]
From 338c67f58b80462b02620cf77f16cb11770786c0 Mon Sep 17 00:00:00 2001
From: Noam Postavsky <npostavs@gmail.com>
Date: Thu, 30 Apr 2020 19:33:51 -0400
Subject: [PATCH 3/4] Revert "cl-loop: Calculate the array length just once"
This reverts commit bfca19e475c01f13dbacc7f8b7bb1aecf46cb7e4.
---
lisp/emacs-lisp/cl-macs.el | 12 +++---------
1 file changed, 3 insertions(+), 9 deletions(-)
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 00f34d3fb6..78d083fcc6 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -1322,13 +1322,11 @@ cl--parse-loop-clause
((memq word '(across across-ref))
(let ((temp-vec (make-symbol "--cl-vec--"))
- (temp-len (make-symbol "--cl-len--"))
(temp-idx (make-symbol "--cl-idx--")))
(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)
+ (length ,temp-vec))
cl--loop-body)
(if (eq word 'across-ref)
(push (list var `(aref ,temp-vec ,temp-idx))
@@ -1343,7 +1341,6 @@ cl--parse-loop-clause
(error "Expected `of'"))))
(seq (cl--pop2 cl--loop-args))
(temp-seq (make-symbol "--cl-seq--"))
- (temp-len (make-symbol "--cl-len--"))
(temp-idx
(if (eq (car cl--loop-args) 'using)
(if (and (= (length (cadr cl--loop-args)) 2)
@@ -1354,19 +1351,16 @@ cl--parse-loop-clause
(push (list temp-seq seq) loop-for-bindings)
(push (list temp-idx 0) loop-for-bindings)
(if ref
- (progn
+ (let ((temp-len (make-symbol "--cl-len--")))
(push (list temp-len `(length ,temp-seq))
loop-for-bindings)
(push (list var `(elt ,temp-seq ,temp-idx))
cl--loop-symbol-macs)
(push `(< ,temp-idx ,temp-len) cl--loop-body))
- ;; 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)))
+ (< ,temp-idx (length ,temp-seq))))
cl--loop-body)
(push (list var `(if (consp ,temp-seq)
(pop ,temp-seq)
--
2.11.0
[-- Attachment #7: patch --]
[-- Type: text/plain, Size: 1335 bytes --]
From 36c48b5c21278c0f42be31b7253bfed7f698b479 Mon Sep 17 00:00:00 2001
From: Noam Postavsky <npostavs@gmail.com>
Date: Thu, 30 Apr 2020 19:35:45 -0400
Subject: [PATCH 4/4] ; Mark Bug#29799 tests as failing since we reverted the
fix
* test/lisp/emacs-lisp/cl-macs-tests.el (cl-macs-loop-for-as-equals-and)
(cl-macs-loop-conditional-step-clauses): Set :expected-result to
:failed.
---
test/lisp/emacs-lisp/cl-macs-tests.el | 2 ++
1 file changed, 2 insertions(+)
diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el
index 9ca84f156a..c357ecde95 100644
--- a/test/lisp/emacs-lisp/cl-macs-tests.el
+++ b/test/lisp/emacs-lisp/cl-macs-tests.el
@@ -498,6 +498,7 @@ cl-macs-loop-vconcat
(ert-deftest cl-macs-loop-for-as-equals-and ()
"Test for https://debbugs.gnu.org/29799 ."
+ :expected-result :failed
(let ((arr (make-vector 3 0)))
(should (equal '((0 0) (1 1) (2 2))
(cl-loop for k below 3 for x = k and z = (elt arr k)
@@ -531,6 +532,7 @@ cl-macs-test--symbol-macrolet
(ert-deftest cl-macs-loop-conditional-step-clauses ()
"These tests failed under the initial fixes in #bug#29799."
+ :expected-result :failed
(should (cl-loop for i from 1 upto 100 and j = 1 then (1+ j)
if (not (= i j))
return nil
--
2.11.0
next prev parent reply other threads:[~2020-04-30 23:40 UTC|newest]
Thread overview: 6+ messages / expand[flat|nested] mbox.gz Atom feed top
2020-04-20 0:33 bug#40727: 27.0.91; 'cl-loop ... across ... and' seems broken Philipp Stephani
2020-04-30 12:30 ` Noam Postavsky
2020-04-30 23:40 ` Noam Postavsky [this message]
2020-05-01 6:11 ` Eli Zaretskii
2020-05-06 1:16 ` Noam Postavsky
2020-05-09 23:13 ` Philipp Stephani
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/emacs/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=87v9lgmtj8.fsf@gmail.com \
--to=npostavs@gmail.com \
--cc=40727@debbugs.gnu.org \
--cc=p.stephani2@gmail.com \
--cc=tino.calancha@gmail.com \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).