From: Tino Calancha <tino.calancha@gmail.com>
Date: Mon, 8 Jan 2018 10:11:20 +0000 (+0900)
Subject: cl-loop: Add missing guard condition
X-Git-Tag: emacs-27.0.90~5913
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=a0365437c9ee308ad7978e436631020f513b25e7;p=emacs.git

cl-loop: Add missing guard condition

Consider the expansion of `cl-loop' with a `for' clause and more
than one internal variables, X, Y, processed in parallel.
Each step updates X and Y right after update the loop variable, K; if
either X or Y depend on K, then some forms of the body are
evaluated with the wrong K (Bug#29799).

For instance, consider the following code:
(cl-loop for k below 2
         for x = (progn (message "k = %d" k) 1)
         and y = 1)

This code should show in *Messages*:
k = 0
k = 1

Instead, the code shows:
k = 0
k = 1
k = 2

To prevent this we must ensure that the loop condition is still
satisfied right after update the loop variable.
In the macro expansion of the example above, right after:
(setq k (+ k 1))

evaluate the rest of the body forms iif the condition
(< k 2)
is still valid.

* 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, evaluate the remaining of
the body forms just if the loop condition is still valid (Bug#29799).

* 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 9af014cf8e9..43eb4261162 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -892,7 +892,7 @@ This is compatible with Common Lisp, but note that `defun' and
 (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 @@ For more details, see Info node `(cl)Loop Facility'.
 	  (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,24 @@ For more details, see Info node `(cl)Loop Facility'.
 			      (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
@@ -1506,10 +1523,11 @@ For more details, see Info node `(cl)Loop Facility'.
                      ,(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 f0bde7af397..edb1530cad5 100644
--- a/test/lisp/emacs-lisp/cl-macs-tests.el
+++ b/test/lisp/emacs-lisp/cl-macs-tests.el
@@ -497,4 +497,12 @@ collection clause."
                           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