mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2025-01-07 15:21:46 +00:00
Refix conditional step clauses in cl-loop
* 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 (bug#29799).
This commit is contained in:
dickmao
Lars Ingebrigtsen
parent
f373cec7f5
commit
045cfbef09
@ -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-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 @@ 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,8 @@ 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)
|
||||
(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 @@ 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
|
||||
@ -1051,6 +1035,12 @@ 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
|
||||
@ -1201,8 +1191,6 @@ 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))
|
||||
@ -1281,11 +1269,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))
|
||||
(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 @@ 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)
|
||||
(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 @@ 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)))
|
||||
(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 @@ 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)
|
||||
(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 @@ For more details, see Info node `(cl)Loop Facility'.
|
||||
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 @@ For more details, see Info node `(cl)Loop Facility'.
|
||||
(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 @@ 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)
|
||||
(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 @@ 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))))
|
||||
|
||||
@ -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 @@ collection clause."
|
||||
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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user