bug#29799: 24.5; cl-loop guard clause missing

bug#29799: 24.5; cl-loop guard clause missing

[Tino Calancha]

X-Debbugs-CC: monnier@iro.umontreal.ca,npostavs@gmail.com

Consider the following snippet code:

--8<-----------------------------cut here---------------start------------->8---
(require 'cl-lib)
(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)))
--8<-----------------------------cut here---------------end--------------->8---

When you execute the form above it fails because
the loop overrun `arr'.

The equivalent code in CL works:
--8<-----------------------------cut here---------------start------------->8---
(let* ((size 7)
       (arr (make-array size :initial-element 0)))
  (loop :for k :below size
           :for x = (* 2 k) :and y = (1+ (elt arr k))
           :collect (list k x y)))
--8<-----------------------------cut here---------------end--------------->8---

* The expansion of `loop' in CL checks the condition
  (>= k 7)
  right before update the internal variables (`x' and `y').

* The expansion of `cl-loop' instead, doesn't check the condition
  before update the vars  =>  in the code above we overrun `arr'.


In GNU Emacs 24.5.1 (x86_64-pc-linux-gnu, GTK+ Version 3.22.11)
 of 2017-09-12 on hullmann, modified by Debian
Windowing system distributor `The X.Org Foundation', version 11.0.11902000
System Description:	Debian GNU/Linux 9.3 (stretch)

bug#29799: 24.5; cl-loop guard clause missing

[Noam Postavsky]

Tino Calancha <tino.calancha@gmail.com> writes:

> (require 'cl-lib)
> (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)))
>
>
> When you execute the form above it fails because
> the loop overrun `arr'.

A simpler example:

    (require 'cl-lib)
    (cl-loop for k below 3
         for x = (progn (message "k = %d" k) 1)
         and y = 1)

prints

    k = 0
    k = 1
    k = 2
    k = 3

in *Messages*.  The expansion looks like this:

    (cl-block nil
      (let* ((k 0))
        (let ((x nil)
              (y nil))
          (let* ((--cl-var-- t))
            (while (< k 3)
              (cl-psetq x
                        (if --cl-var--
                            (progn
                              (message "k = %d" k)
                              1)
                          x)
                        y (if --cl-var-- 1 y))
              (setq k (+ k 1))
              (cl-psetq x (progn
                            (message "k = %d" k)
                            1)
                        y 1)
              (setq --cl-var-- nil))
            nil))))

I don't understand why the "then" step is put at the of the loop.  The
following patch (commenting out the "ands" branch) avoids doing that,
and fixes this bug.  But presumably there is some reason for having this
code in the first place?  I guess some more complicated example would be
needed to show why this naive fix won't work.

--- i/lisp/emacs-lisp/cl-macs.el
+++ w/lisp/emacs-lisp/cl-macs.el
@@ -1288,7 +1288,7 @@ cl--parse-loop-clause
 		       (then (if (eq (car cl--loop-args) 'then)
                                  (cl--pop2 cl--loop-args) start)))
 		  (push (list var nil) loop-for-bindings)
-		  (if (or ands (eq (car cl--loop-args) 'and))
+		  (if nil ;(or ands (eq (car cl--loop-args) 'and))
 		      (progn
 			(push `(,var
 				(if ,(or cl--loop-first-flag

bug#29799: 24.5; cl-loop guard clause missing

[Noam Postavsky]

Noam Postavsky <npostavs@users.sourceforge.net> writes:

> I don't understand why the "then" step is put at the of the loop.  The
> following patch (commenting out the "ands" branch) avoids doing that,
> and fixes this bug.  But presumably there is some reason for having this
> code in the first place?  I guess some more complicated example would be
> needed to show why this naive fix won't work.

Oh, 'make -C test cl-macs-tests' provides some.  And I see we've in fact
been over this naive solution before:
https://debbugs.gnu.org/cgi/bugreport.cgi?bug=6583#28

bug#29799: 24.5; cl-loop guard clause missing

[Tino Calancha]

Noam Postavsky <npostavs@users.sourceforge.net> writes:

> Noam Postavsky <npostavs@users.sourceforge.net> writes:
>
>> I don't understand why the "then" step is put at the of the loop.  The
>> following patch (commenting out the "ands" branch) avoids doing that,
>> and fixes this bug.  But presumably there is some reason for having this
>> code in the first place?  I guess some more complicated example would be
>> needed to show why this naive fix won't work.
>
> Oh, 'make -C test cl-macs-tests' provides some.  And I see we've in fact
> been over this naive solution before:
> https://debbugs.gnu.org/cgi/bugreport.cgi?bug=6583#28
Bug#6583 requires more thinking; I couldn't find a satisfactory fix for
it.

For Bug#29799 I propose the patch below:
* It adds a new variable `cl--loop-guard-cond'
* In a for clause, rigth after update the loop var, check if
  the loop condition is still valid before update the remaining
  variables.
  AFAIS, this is similar to the CL expansions for these cases.

--8<-----------------------------cut here---------------start------------->8---
commit 25fb3aad45ea3c545c6389c4f7bb6f1a76ebffe8
Author: Tino Calancha <tino.calancha@gmail.com>
Date:   Wed Jan 3 19:15:14 2018 +0900

    Fix #Bug#29799
    
    * lisp/emacs-lisp/cl-macs.el (cl--loop-guard-cond): New variable.
    (cl--parse-loop-clause): Set it non-nil if the loop contains
    a for/as clause.
    (cl-loop): After update the loop variable, update other variables
    only if cl--loop-guard-cond is non-nil.
    
    * test/lisp/emacs-lisp/cl-macs-tests.el (cl-macs-loop-for-as-equals-and):
    New test.

diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index f5311041cc..db1b811f38 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -892,7 +892,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
@@ -961,7 +961,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-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:
       ;;
@@ -996,7 +996,22 @@ 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 do not
+                 ;; update other variables (#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))) sets the
+                 ;; remaining variables.
+                 (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
@@ -1500,10 +1515,11 @@ cl--parse-loop-clause
                      ,(cl--loop-let (nreverse loop-for-sets) 'setq ands)
                      t)
                   cl--loop-body))
-	(if loop-for-steps
-	    (push (cons (if ands 'cl-psetq 'setq)
-			(apply 'append (nreverse loop-for-steps)))
-		  cl--loop-steps))))
+	(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))))
 
      ((eq word 'repeat)
       (let ((temp (make-symbol "--cl-var--")))
diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el
index 575f170af6..2aab002964 100644
--- a/test/lisp/emacs-lisp/cl-macs-tests.el
+++ b/test/lisp/emacs-lisp/cl-macs-tests.el
@@ -497,4 +497,12 @@
                           vconcat (vector (1+ x)))
                  [2 3 4 5 6])))
 
+
+(ert-deftest cl-macs-loop-for-as-equals-and ()
+  "Test for https://debbugs.gnu.org/29799 ."
+  (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)
+                            collect (list k x))))))
+
 ;;; cl-macs-tests.el ends here

--8<-----------------------------cut here---------------end--------------->8---

bug#29799: 24.5; cl-loop guard clause missing

[Noam Postavsky]

Tino Calancha <tino.calancha@gmail.com> writes:

>     Fix #Bug#29799
>     
>     * lisp/emacs-lisp/cl-macs.el (cl--loop-guard-cond): New variable.
>     (cl--parse-loop-clause): Set it non-nil if the loop contains
>     a for/as clause.
>     (cl-loop): After update the loop variable, update other variables
>     only if cl--loop-guard-cond is non-nil.
>     
>     * test/lisp/emacs-lisp/cl-macs-tests.el (cl-macs-loop-for-as-equals-and):
>     New test.

Looks good, but please add some more info to the summary line.

bug#29799: 24.5; cl-loop guard clause missing

[Tino Calancha]

Noam Postavsky <npostavs@users.sourceforge.net> writes:

> Tino Calancha <tino.calancha@gmail.com> writes:
>
>>     Fix #Bug#29799
>>     
>>     * lisp/emacs-lisp/cl-macs.el (cl--loop-guard-cond): New variable.
>>     (cl--parse-loop-clause): Set it non-nil if the loop contains
>>     a for/as clause.
>>     (cl-loop): After update the loop variable, update other variables
>>     only if cl--loop-guard-cond is non-nil.
>>     
>>     * test/lisp/emacs-lisp/cl-macs-tests.el (cl-macs-loop-for-as-equals-and):
>>     New test.
>
> Looks good, but please add some more info to the summary line.
Thank you very much.
Extended the commit message with more detailed explanations.

Fixed in master branch as commit 'cl-loop: Add missing guard condition'
(a0365437c9ee308ad7978e436631020f513b25e7).

bug#29799: 24.5; cl-loop guard clause missing

[dick.r.chiang]

[-- Attachment #1: Type: text/plain, Size: 369 bytes --]

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)


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: patch --]
[-- Type: text/x-diff, Size: 14071 bytes --]

From c193f58b91ce875de4b8d4d4a87fbaea8111fdf5 Mon Sep 17 00:00:00 2001
From: dickmao <none>
Date: Sun, 27 Oct 2019 16:11:48 -0400
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):
Add cl--loop-conditions, remove cl--loop-guard-cond
(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            | 96 +++++++++++----------------
 test/lisp/emacs-lisp/cl-macs-tests.el | 77 +++++++++++++++++++--
 2 files changed, 110 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..8beb9d317b 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,74 @@
                    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 with result
+                          for x below 3
+                          for y below 2 and z = 1
+                          collect x)
+                 '(0 1)))
+
+  (should (equal (cl-loop with result
+                          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 result
+                          finally return result)
+                 '(2 1 0 0 0 1 1 2 2)))
+
+  ;; this is actually disallowed in clisp, but is semantically consistent
+  (should (equal (cl-loop with result
+                          for x below 3
+                          and y = (progn (push x result) x) and z = 1
+                          append (list x y) into result
+                          finally return result)
+                 '(2 1 0 0 0 0 1 0 2 1)))
+
+  (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

bug#29799: 24.5; cl-loop guard clause missing

[dick.r.chiang]

[-- Attachment #1: Type: text/plain, Size: 369 bytes --]

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)


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: patch v2 --]
[-- Type: text/x-diff, Size: 14072 bytes --]

From a7fb384120c60cb1131c3e8136cc92fddf3c097c Mon Sep 17 00:00:00 2001
From: dickmao <none>
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

bug#29799: 24.5; cl-loop guard clause missing

[Lars Ingebrigtsen]

dick.r.chiang@gmail.com writes:

> 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)

I applied the patch and ran that test case, and it returned
(2 1 0).  But shouldn't it return (2 1)?

-- 
(domestic pets only, the antidote for overdose, milk.)
   bloggy blog: http://lars.ingebrigtsen.no

bug#29799: 24.5; cl-loop guard clause missing

[dick.r.chiang]

>>>>> Lars Ingebrigtsen <larsi@gnus.org> writes:

>> ;; 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)

> I applied the patch and ran that test case, and it returned
> (2 1 0).  But shouldn't it return (2 1)?

Ah, clisp also returns (2 1 0), so while my initial claim is wrong, I am happy
the patch conforms with clisp.

My human instinct is to say it should return (1 0), but the simultaneity
semantics of "and" are tricky.

Under no interpretation, do I see it returning (2 1).

iter#1 x is 0, *simultaneously* set y = 0 and result = (0)
iter#2 x is 1, *simultaneously* set y = 1 and result = (1 0)
iter#3 x is 2, *simultaneously* break out of loop and result = (2 1 0)

bug#29799: 24.5; cl-loop guard clause missing

[Lars Ingebrigtsen]

dick.r.chiang@gmail.com writes:

>>> ;; 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)
>
>> I applied the patch and ran that test case, and it returned
>> (2 1 0).  But shouldn't it return (2 1)?
>
> Ah, clisp also returns (2 1 0), so while my initial claim is wrong, I am happy
> the patch conforms with clisp.
>
> My human instinct is to say it should return (1 0), but the simultaneity
> semantics of "and" are tricky.
>
> Under no interpretation, do I see it returning (2 1).
>
> iter#1 x is 0, *simultaneously* set y = 0 and result = (0)
> iter#2 x is 1, *simultaneously* set y = 1 and result = (1 0)
> iter#3 x is 2, *simultaneously* break out of loop and result = (2 1 0)

Yes, you're right -- I was somehow thinking that "below 3" meant the
same as "from 2 downto 0" instead of what it really means: "upto 2".
And that "for ... and" meant that I had never realised.  :-)

loop is a complicated language.

So it all looks correct to me now, and I'm applying your patch.

-- 
(domestic pets only, the antidote for overdose, milk.)
   bloggy blog: http://lars.ingebrigtsen.no