From 79e133da034cd2d7cccfc5a6eb7db340f2dc45a8 Mon Sep 17 00:00:00 2001 From: Noam Postavsky Date: Thu, 30 Apr 2020 19:33:34 -0400 Subject: [PATCH 1/4] Revert "Refix conditional step clauses in cl-loop" Don't merge to master. This is a safe-for-release fix for Bug#40727. --- 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 d56f4151df7..cda25d186fd 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -889,7 +889,7 @@ This is compatible with Common Lisp, but note that `defun' and ;;; 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 @@ 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 @@ -966,8 +966,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-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 @@ 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 @@ -1035,12 +1051,6 @@ For more details, see Info node `(cl)Loop Facility'. (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 @@ For more details, see Info node `(cl)Loop Facility'. ;; (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 @@ For more details, see Info node `(cl)Loop Facility'. (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 @@ For more details, see Info node `(cl)Loop Facility'. (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 @@ For more details, see Info node `(cl)Loop Facility'. ((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 @@ For more details, see Info node `(cl)Loop Facility'. (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 @@ For more details, see Info node `(cl)Loop Facility'. 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 @@ For more details, see Info node `(cl)Loop Facility'. (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 @@ For more details, see Info node `(cl)Loop Facility'. (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 @@ For more details, see Info node `(cl)Loop Facility'. 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)))) From caf155c4638d4704b2a099657153c9abc115720b Mon Sep 17 00:00:00 2001 From: Noam Postavsky Date: Thu, 30 Apr 2020 19:33:50 -0400 Subject: [PATCH 2/4] Revert "cl-loop: Add missing guard condition" Don't merge to master. This is a safe-for-release fix for Bug#40727. --- 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 cda25d186fd..00f34d3fb60 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -897,7 +897,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-guard-cond) +(defvar cl--loop-symbol-macs) (defun cl--loop-set-iterator-function (kind iterator) (if cl--loop-iterator-function @@ -966,7 +966,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-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 @@ 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) - (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 @@ For more details, see Info node `(cl)Loop Facility'. ,(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--"))) From de1b33f5a8c6ceee9be59285f70370c3cb2efd34 Mon Sep 17 00:00:00 2001 From: Noam Postavsky Date: Thu, 30 Apr 2020 19:33:51 -0400 Subject: [PATCH 3/4] Revert "cl-loop: Calculate the array length just once" Don't merge to master. This is a safe-for-release fix for Bug#40727. --- 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 00f34d3fb60..78d083fcc63 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -1322,13 +1322,11 @@ For more details, see Info node `(cl)Loop Facility'. ((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 @@ For more details, see Info node `(cl)Loop Facility'. (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 @@ For more details, see Info node `(cl)Loop Facility'. (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) From 1e09364d677b0fb57efd18369c55e8c2d0e826f5 Mon Sep 17 00:00:00 2001 From: Noam Postavsky 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. Don't merge to master. The mentioned reverts are a safe-for-release fix for Bug#40727. --- 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 9ca84f156a0..c357ecde951 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -498,6 +498,7 @@ collection clause." (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 @@ collection clause." (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