all messages for Emacs-related lists mirrored at yhetil.org
 help / color / mirror / code / Atom feed
From: dick.r.chiang@gmail.com
To: 29799@debbugs.gnu.org
Subject: bug#29799: 24.5; cl-loop guard clause missing
Date: Sun, 27 Oct 2019 23:59:41 -0400	[thread overview]
Message-ID: <87a79lseoi.fsf@dick> (raw)
In-Reply-To: <87d138beur.fsf@gmail.com> (Tino Calancha's message of "Thu, 21 Dec 2017 18:38:20 +0900")

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


  parent reply	other threads:[~2019-10-28  3:59 UTC|newest]

Thread overview: 11+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2017-12-21  9:38 bug#29799: 24.5; cl-loop guard clause missing Tino Calancha
2018-01-01 21:46 ` Noam Postavsky
2018-01-01 22:58   ` Noam Postavsky
2018-01-03 10:34     ` Tino Calancha
2018-01-06 13:43       ` Noam Postavsky
2018-01-08 10:20         ` Tino Calancha
2019-10-28  3:59 ` dick.r.chiang [this message]
2019-11-21 23:25 ` dick.r.chiang
2019-11-22 12:55   ` Lars Ingebrigtsen
2019-11-22 13:51     ` dick.r.chiang
2019-11-22 14:53       ` Lars Ingebrigtsen

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

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=87a79lseoi.fsf@dick \
    --to=dick.r.chiang@gmail.com \
    --cc=29799@debbugs.gnu.org \
    /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 external index

	https://git.savannah.gnu.org/cgit/emacs.git
	https://git.savannah.gnu.org/cgit/emacs/org-mode.git

This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.