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 9af014cf8e95cf15ed46b31bc62fb2aa54bfa1a0..43eb4261162f08cf783e25d079f9953c197f67da 100644 (file)
--- 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 f0bde7af3974e279c709d849cec76c3900a51cb2..edb1530cad57b03fc133b9e096619e59329aa565 100644 (file)
--- 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