From: Philip Kaludercic <philipk@posteo.net>
To: 57907@debbugs.gnu.org
Subject: bug#57907: Acknowledgement (29.0.50; Using keywords with cl-loop)
Date: Sun, 18 Sep 2022 20:12:26 +0000 [thread overview]
Message-ID: <87wna08ms5.fsf__40086.9307502703$1663531999$gmane$org@posteo.net> (raw)
In-Reply-To: <87pmfsdg1l.fsf@posteo.net> (Philip Kaludercic's message of "Sun, 18 Sep 2022 14:26:46 +0200")
[-- Attachment #1: Type: text/plain, Size: 306 bytes --]
Philip Kaludercic <philipk@posteo.net> writes:
> It seems it isn't that difficult to do this (though the patch is longer
> than it ought to be because of indentation changes)
It turned out to be a bit more difficult than I had assumed at first,
but this patch should address the remaining issues I had:
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Have-cl-loop-handle-keyword-symbols.patch --]
[-- Type: text/x-patch, Size: 49879 bytes --]
From a15a3d33b3ae4e2e8608da04978ed91b7c01187f Mon Sep 17 00:00:00 2001
From: Philip Kaludercic <philipk@posteo.net>
Date: Sun, 18 Sep 2022 14:25:29 +0200
Subject: [PATCH] Have 'cl-loop' handle keyword symbols
* lisp/emacs-lisp/cl-macs.el (cl-loop): Add keywords to the edebug
spec.
(cl--parse-loop-clause): Handle keyword symbols by converting them
into regular symbols.
* doc/misc/cl.texi (Loop Basics): Mention that keywords are handled.
* etc/NEWS: Mention it.
(Bug#57907)
---
doc/misc/cl.texi | 13 +-
etc/NEWS | 3 +
lisp/emacs-lisp/cl-macs.el | 964 +++++++++++++++++++------------------
3 files changed, 510 insertions(+), 470 deletions(-)
diff --git a/doc/misc/cl.texi b/doc/misc/cl.texi
index a6747b1096..2f64aa3f1e 100644
--- a/doc/misc/cl.texi
+++ b/doc/misc/cl.texi
@@ -1700,12 +1700,13 @@ Loop Basics
@defmac cl-loop clauses@dots{}
A loop construct consists of a series of @var{clause}s, each
-introduced by a symbol like @code{for} or @code{do}. Clauses
-are simply strung together in the argument list of @code{cl-loop},
-with minimal extra parentheses. The various types of clauses
-specify initializations, such as the binding of temporary
-variables, actions to be taken in the loop, stepping actions,
-and final cleanup.
+introduced by a symbol like @code{for} or @code{do}. Clauses are
+simply strung together in the argument list of @code{cl-loop}, with
+minimal extra parentheses. The various types of clauses specify
+initializations, such as the binding of temporary variables, actions
+to be taken in the loop, stepping actions, and final cleanup.
+@code{cl-loop} can also handle keyword symbols, such as @code{:for} or
+@code{:do}, in the same way as it would handle non-keyword symbols.
Common Lisp specifies a certain general order of clauses in a
loop:
diff --git a/etc/NEWS b/etc/NEWS
index e5d9b1ca23..b6862276f1 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -3801,6 +3801,9 @@ the same but works by modifying LIST destructively.
---
** 'string-split' is now an alias for 'split-string'.
++++
+** 'cl-loop' now handles keyword symbols.
+
\f
* Changes in Emacs 29.1 on Non-Free Operating Systems
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 5d330f32d6..74d0878689 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -946,6 +946,9 @@ cl-loop
do EXPRS...
[finally] return EXPR
+All cl-loop keywords may also be written using keyword
+symbols (e.g. `:for' is the same as `for').
+
For more details, see Info node `(cl)Loop Facility'.
\(fn CLAUSE...)"
@@ -953,22 +956,24 @@ cl-loop
;; These are usually followed by a symbol, but it can
;; actually be any destructuring-bind pattern, which
;; would erroneously match `form'.
- [[&or "for" "as" "with" "and"] sexp]
+ [[&or "for" ":for" "as" ":as" "with" ":with" "and" ":and"] sexp]
;; These are followed by expressions which could
;; erroneously match `symbolp'.
- [[&or "from" "upfrom" "downfrom" "to" "upto" "downto"
- "above" "below" "by" "in" "on" "=" "across"
- "repeat" "while" "until" "always" "never"
- "thereis" "collect" "append" "nconc" "sum"
- "count" "maximize" "minimize"
- "if" "when" "unless"
- "return"]
+ [[&or "from" ":from" "upfrom" ":upfrom" "downfrom" ":downfrom" "to"
+ ":to" "upto" ":upto" "downto" ":downto" "above" ":above"
+ "below" ":below" "by" ":by" "in" ":in" "on" ":on" "=" ":="
+ "across" ":across" "repeat" ":repeat" "while" ":while" "until"
+ ":until" "always" ":always" "never" ":never" "thereis"
+ ":thereis" "collect" ":collect" "append" ":append" "nconc"
+ ":nconc" "sum" ":sum" "count" ":count" "maximize" ":maximize"
+ "minimize" ":minimize" "if" ":if" "when" ":when" "unless"
+ ":unless" "return" ":return" ]
form]
["using" (symbolp symbolp)]
;; Simple default, which covers 99% of the cases.
symbolp form)))
(if (not (memq t (mapcar #'symbolp
- (delq nil (delq t (cl-copy-list loop-args))))))
+ (delq nil (remq t loop-args)))))
`(cl-block nil (while t ,@loop-args))
(let ((cl--loop-args loop-args) (cl--loop-name nil) (cl--loop-bindings nil)
(cl--loop-body nil) (cl--loop-steps nil)
@@ -1204,465 +1209,496 @@ cl--push-clause-loop-body
;; '(&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))
- (key-types '(key-code key-codes key-seq key-seqs
- key-binding key-bindings)))
- (cond
+ (cl-flet
+ ;; The following local functions are added to automatically
+ ;; convert loop-keywords that use keyword symbols to
+ ;; non-keyword symbols. E.g. we want
+ ;;
+ ;; (cl-loop :repeat foo :collect :bar)
+ ;;
+ ;; to do the same as
+ ;;
+ ;; (cl-loop repeat foo collect :bar)
+ ;;
+ ;; We can't generically replace all keyword symbols with
+ ;; non-keyword symbols because that could break things when we
+ ;; actually intend to have a keyword symbol. Instead the local
+ ;; functions are used whenever we want to query the next
+ ;; loop-keyword.
+ ((next ()
+ (let ((word (pop cl--loop-args)))
+ (if (keywordp word)
+ (intern (substring (symbol-name word) 1))
+ word)))
+ (next-2 () ;double-step `next'
+ (let ((word (cl--pop2 cl--loop-args)))
+ (if (keywordp word)
+ (intern (substring (symbol-name word) 1))
+ word)))
+ (peek ()
+ (let ((word (car cl--loop-args)))
+ (if (keywordp word)
+ (intern (substring (symbol-name word) 1))
+ word))))
+ (let ((word (next))
+ (hash-types '(hash-key hash-keys hash-value hash-values))
+ (key-types '(key-code key-codes key-seq key-seqs
+ key-binding key-bindings)))
+ (cond
+
+ ((null cl--loop-args)
+ (error "Malformed `cl-loop' macro"))
+
+ ((eq word 'named)
+ (setq cl--loop-name (pop cl--loop-args)))
+
+ ((eq word 'initially)
+ (if (memq (peek) '(do doing)) (next))
+ (or (consp (peek))
+ (error "Syntax error on `initially' clause"))
+ (while (consp (peek))
+ (push (pop cl--loop-args) cl--loop-initially)))
+
+ ((eq word 'finally)
+ (if (eq (peek) 'return)
+ (setq cl--loop-result-explicit
+ (or (cl--pop2 cl--loop-args) '(quote nil)))
+ (if (memq (peek) '(do doing)) (next))
+ (or (consp (peek))
+ (error "Syntax error on `finally' clause"))
+ (if (and (eq (caar cl--loop-args) 'return) (null cl--loop-name))
+ (setq cl--loop-result-explicit
+ (or (nth 1 (pop cl--loop-args)) '(quote nil)))
+ (while (consp (peek))
+ (push (pop cl--loop-args) cl--loop-finally)))))
+
+ ((memq word '(for as))
+ (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil)
+ (ands nil))
+ (while
+ ;; Use `cl-gensym' rather than `make-symbol'. It's important that
+ ;; (not (eq (symbol-name var1) (symbol-name var2))) because
+ ;; these vars get added to the macro-environment.
+ (let ((var (or (pop cl--loop-args) (cl-gensym "--cl-var--"))))
+ (setq word (next))
+ (if (eq word 'being) (setq word (next)))
+ (if (memq word '(the each)) (setq word (next)))
+ (if (memq word '(buffer buffers))
+ (setq word 'in
+ cl--loop-args (cons '(buffer-list) cl--loop-args)))
+ (cond
- ((null cl--loop-args)
- (error "Malformed `cl-loop' macro"))
-
- ((eq word 'named)
- (setq cl--loop-name (pop cl--loop-args)))
-
- ((eq word 'initially)
- (if (memq (car cl--loop-args) '(do doing)) (pop cl--loop-args))
- (or (consp (car cl--loop-args))
- (error "Syntax error on `initially' clause"))
- (while (consp (car cl--loop-args))
- (push (pop cl--loop-args) cl--loop-initially)))
-
- ((eq word 'finally)
- (if (eq (car cl--loop-args) 'return)
- (setq cl--loop-result-explicit
- (or (cl--pop2 cl--loop-args) '(quote nil)))
- (if (memq (car cl--loop-args) '(do doing)) (pop cl--loop-args))
- (or (consp (car cl--loop-args))
- (error "Syntax error on `finally' clause"))
- (if (and (eq (caar cl--loop-args) 'return) (null cl--loop-name))
- (setq cl--loop-result-explicit
- (or (nth 1 (pop cl--loop-args)) '(quote nil)))
- (while (consp (car cl--loop-args))
- (push (pop cl--loop-args) cl--loop-finally)))))
-
- ((memq word '(for as))
- (let ((loop-for-bindings nil) (loop-for-sets nil) (loop-for-steps nil)
- (ands nil))
- (while
- ;; Use `cl-gensym' rather than `make-symbol'. It's important that
- ;; (not (eq (symbol-name var1) (symbol-name var2))) because
- ;; these vars get added to the macro-environment.
- (let ((var (or (pop cl--loop-args) (cl-gensym "--cl-var--"))))
- (setq word (pop cl--loop-args))
- (if (eq word 'being) (setq word (pop cl--loop-args)))
- (if (memq word '(the each)) (setq word (pop cl--loop-args)))
- (if (memq word '(buffer buffers))
- (setq word 'in
- cl--loop-args (cons '(buffer-list) cl--loop-args)))
- (cond
-
- ((memq word '(from downfrom upfrom to downto upto
- above below by))
- (push word cl--loop-args)
- (if (memq (car cl--loop-args) '(downto above))
- (error "Must specify `from' value for downward cl-loop"))
- (let* ((down (or (eq (car cl--loop-args) 'downfrom)
- (memq (nth 2 cl--loop-args)
- '(downto above))))
- (excl (or (memq (car cl--loop-args) '(above below))
- (memq (nth 2 cl--loop-args)
- '(above below))))
- (start (and (memq (car cl--loop-args)
- '(from upfrom downfrom))
- (cl--pop2 cl--loop-args)))
- (end (and (memq (car cl--loop-args)
- '(to upto downto above below))
- (cl--pop2 cl--loop-args)))
- (step (and (eq (car cl--loop-args) 'by)
- (cl--pop2 cl--loop-args)))
- (end-var (and (not (macroexp-const-p end))
- (make-symbol "--cl-var--")))
- (step-var (and (not (macroexp-const-p step))
- (make-symbol "--cl-var--"))))
- (and step (numberp step) (<= step 0)
- (error "Loop `by' value is not positive: %s" step))
- (push (list var (or start 0)) loop-for-bindings)
- (if end-var (push (list end-var end) loop-for-bindings))
- (if step-var (push (list step-var step)
- loop-for-bindings))
- (when end
+ ((memq word '(from downfrom upfrom to downto upto
+ above below by))
+ (push word cl--loop-args)
+ (if (memq (peek) '(downto above))
+ (error "Must specify `from' value for downward cl-loop"))
+ (let* ((down (or (eq (peek) 'downfrom)
+ (memq (nth 2 cl--loop-args)
+ '(downto above))))
+ (excl (or (memq (peek) '(above below))
+ (memq (nth 2 cl--loop-args)
+ '(above below))))
+ (start (and (memq (peek)
+ '(from upfrom downfrom))
+ (next-2)))
+ (end (and (memq (peek)
+ '(to upto downto above below))
+ (next-2)))
+ (step (and (eq (peek) 'by)
+ (next-2)))
+ (end-var (and (not (macroexp-const-p end))
+ (make-symbol "--cl-var--")))
+ (step-var (and (not (macroexp-const-p step))
+ (make-symbol "--cl-var--"))))
+ (and step (numberp step) (<= step 0)
+ (error "Loop `by' value is not positive: %s" step))
+ (push (list var (or start 0)) loop-for-bindings)
+ (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))))
+ (push (list var (list (if down '- '+) var
+ (or step-var step 1)))
+ loop-for-steps)))
+
+ ((memq word '(in in-ref on))
+ (let* ((on (eq word 'on))
+ (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))
+ (if (eq word 'in-ref)
+ (push (list var `(car ,temp)) cl--loop-symbol-macs)
+ (or (eq temp var)
+ (progn
+ (push (list var nil) loop-for-bindings)
+ (push (list var (if on temp `(car ,temp)))
+ loop-for-sets))))
+ (push (list temp
+ (if (eq (peek) 'by)
+ (let ((step (cl--pop2 cl--loop-args)))
+ (if (and (memq (car-safe step)
+ '(quote function
+ cl-function))
+ (symbolp (nth 1 step)))
+ (list (nth 1 step) temp)
+ `(funcall ,step ,temp)))
+ `(cdr ,temp)))
+ loop-for-steps)))
+
+ ((eq word '=)
+ (let* ((start (next))
+ (then (if (eq (peek) 'then)
+ (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 (peek) '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 (if (eq start then)
+ `(,var ,then)
+ `(,var (if ,first-assign ,start ,then)))
+ loop-for-sets))))
+
+ ((memq word '(across across-ref))
+ (let ((temp-vec (make-symbol "--cl-vec--"))
+ (temp-idx (make-symbol "--cl-idx--")))
+ (push (list temp-vec (pop cl--loop-args)) loop-for-bindings)
+ (push (list temp-idx -1) loop-for-bindings)
+ (push `(setq ,temp-idx (1+ ,temp-idx)) cl--loop-body)
(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)))
-
- ((memq word '(in in-ref on))
- (let* ((on (eq word 'on))
- (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))
- (if (eq word 'in-ref)
- (push (list var `(car ,temp)) cl--loop-symbol-macs)
- (or (eq temp var)
- (progn
- (push (list var nil) loop-for-bindings)
- (push (list var (if on temp `(car ,temp)))
- loop-for-sets))))
- (push (list temp
- (if (eq (car cl--loop-args) 'by)
- (let ((step (cl--pop2 cl--loop-args)))
- (if (and (memq (car-safe step)
- '(quote function
- cl-function))
- (symbolp (nth 1 step)))
- (list (nth 1 step) temp)
- `(funcall ,step ,temp)))
- `(cdr ,temp)))
- loop-for-steps)))
-
- ((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--")))))
- (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 (if (eq start then)
- `(,var ,then)
- `(,var (if ,first-assign ,start ,then)))
- loop-for-sets))))
-
- ((memq word '(across across-ref))
- (let ((temp-vec (make-symbol "--cl-vec--"))
- (temp-idx (make-symbol "--cl-idx--")))
- (push (list temp-vec (pop cl--loop-args)) loop-for-bindings)
- (push (list temp-idx -1) loop-for-bindings)
- (push `(setq ,temp-idx (1+ ,temp-idx)) cl--loop-body)
- (cl--push-clause-loop-body
- `(< ,temp-idx (length ,temp-vec)))
- (if (eq word 'across-ref)
- (push (list var `(aref ,temp-vec ,temp-idx))
- cl--loop-symbol-macs)
- (push (list var nil) loop-for-bindings)
- (push (list var `(aref ,temp-vec ,temp-idx))
- loop-for-sets))))
-
- ((memq word '(element elements))
- (let ((ref (or (memq (car cl--loop-args) '(in-ref of-ref))
- (and (not (memq (car cl--loop-args) '(in of)))
- (error "Expected `of'"))))
- (seq (cl--pop2 cl--loop-args))
- (temp-seq (make-symbol "--cl-seq--"))
- (temp-idx
- (if (eq (car cl--loop-args) 'using)
- (if (and (= (length (cadr cl--loop-args)) 2)
- (eq (caadr cl--loop-args) 'index))
- (cadr (cl--pop2 cl--loop-args))
- (error "Bad `using' clause"))
- (make-symbol "--cl-idx--"))))
- (push (list temp-seq seq) loop-for-bindings)
- (push (list temp-idx 0) loop-for-bindings)
- (if ref
- (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)
- (cl--push-clause-loop-body `(< ,temp-idx ,temp-len)))
- (push (list var nil) loop-for-bindings)
- (cl--push-clause-loop-body `(and ,temp-seq
- (or (consp ,temp-seq)
- (< ,temp-idx (length ,temp-seq)))))
- (push (list var `(if (consp ,temp-seq)
- (pop ,temp-seq)
- (aref ,temp-seq ,temp-idx)))
- loop-for-sets))
- (push (list temp-idx `(1+ ,temp-idx))
- loop-for-steps)))
-
- ((memq word hash-types)
- (or (memq (car cl--loop-args) '(in of))
- (error "Expected `of'"))
- (let* ((table (cl--pop2 cl--loop-args))
- (other
- (if (eq (car cl--loop-args) 'using)
- (if (and (= (length (cadr cl--loop-args)) 2)
- (memq (caadr cl--loop-args) hash-types)
- (not (eq (caadr cl--loop-args) word)))
- (cadr (cl--pop2 cl--loop-args))
- (error "Bad `using' clause"))
- (make-symbol "--cl-var--"))))
- (if (memq word '(hash-value hash-values))
- (setq var (prog1 other (setq other var))))
- (cl--loop-set-iterator-function
- 'hash-tables (lambda (body)
- `(maphash (lambda (,var ,other) . ,body)
- ,table)))))
-
- ((memq word '(symbol present-symbol external-symbol
- symbols present-symbols external-symbols))
- (let ((ob (and (memq (car cl--loop-args) '(in of))
- (cl--pop2 cl--loop-args))))
- (cl--loop-set-iterator-function
- 'symbols (lambda (body)
- `(mapatoms (lambda (,var) . ,body) ,ob)))))
-
- ((memq word '(overlay overlays extent extents))
- (let ((buf nil) (from nil) (to nil))
- (while (memq (car cl--loop-args) '(in of from to))
- (cond ((eq (car cl--loop-args) 'from)
- (setq from (cl--pop2 cl--loop-args)))
- ((eq (car cl--loop-args) 'to)
- (setq to (cl--pop2 cl--loop-args)))
- (t (setq buf (cl--pop2 cl--loop-args)))))
- (cl--loop-set-iterator-function
- 'overlays (lambda (body)
- `(cl--map-overlays
- (lambda (,var ,(make-symbol "--cl-var--"))
- (progn . ,body) nil)
- ,buf ,from ,to)))))
-
- ((memq word '(interval intervals))
- (let ((buf nil) (prop nil) (from nil) (to nil)
- (var1 (make-symbol "--cl-var1--"))
- (var2 (make-symbol "--cl-var2--")))
- (while (memq (car cl--loop-args) '(in of property from to))
- (cond ((eq (car cl--loop-args) 'from)
- (setq from (cl--pop2 cl--loop-args)))
- ((eq (car cl--loop-args) 'to)
- (setq to (cl--pop2 cl--loop-args)))
- ((eq (car cl--loop-args) 'property)
- (setq prop (cl--pop2 cl--loop-args)))
- (t (setq buf (cl--pop2 cl--loop-args)))))
- (if (and (consp var) (symbolp (car var)) (symbolp (cdr var)))
- (setq var1 (car var) var2 (cdr var))
- (push (list var `(cons ,var1 ,var2)) loop-for-sets))
- (cl--loop-set-iterator-function
- 'intervals (lambda (body)
- `(cl--map-intervals
- (lambda (,var1 ,var2) . ,body)
- ,buf ,prop ,from ,to)))))
-
- ((memq word key-types)
- (or (memq (car cl--loop-args) '(in of))
- (error "Expected `of'"))
- (let ((cl-map (cl--pop2 cl--loop-args))
- (other
- (if (eq (car cl--loop-args) 'using)
- (if (and (= (length (cadr cl--loop-args)) 2)
- (memq (caadr cl--loop-args) key-types)
- (not (eq (caadr cl--loop-args) word)))
- (cadr (cl--pop2 cl--loop-args))
- (error "Bad `using' clause"))
- (make-symbol "--cl-var--"))))
- (if (memq word '(key-binding key-bindings))
- (setq var (prog1 other (setq other var))))
- (cl--loop-set-iterator-function
- 'keys (lambda (body)
- `(,(if (memq word '(key-seq key-seqs))
- 'cl--map-keymap-recursively 'map-keymap)
- (lambda (,var ,other) . ,body) ,cl-map)))))
-
- ((memq word '(frame frames screen screens))
- (let ((temp (make-symbol "--cl-var--")))
- (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 (list var `(next-frame ,var))
- loop-for-steps)))
-
- ((memq word '(window windows))
- (let ((scr (and (memq (car cl--loop-args) '(in of))
- (cl--pop2 cl--loop-args)))
- (temp (make-symbol "--cl-var--"))
- (minip (make-symbol "--cl-minip--")))
- (push (list var (if scr
- `(frame-selected-window ,scr)
- '(selected-window)))
- loop-for-bindings)
- ;; If we started in the minibuffer, we need to
- ;; ensure that next-window will bring us back there
- ;; at some point. (Bug#7492).
- ;; (Consider using walk-windows instead of cl-loop if
- ;; you care about such things.)
- (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 (list var `(next-window ,var ,minip))
- loop-for-steps)))
-
- (t
- ;; This is an advertised interface: (info "(cl)Other Clauses").
- (let ((handler (and (symbolp word)
- (get word 'cl-loop-for-handler))))
- (if handler
- (funcall handler var)
- (error "Expected a `for' preposition, found %s" word)))))
- (eq (car cl--loop-args) 'and))
- (setq ands t)
- (pop cl--loop-args))
- (if (and ands loop-for-bindings)
- (push (nreverse loop-for-bindings) cl--loop-bindings)
- (setq cl--loop-bindings (nconc (mapcar #'list loop-for-bindings)
- cl--loop-bindings)))
- (if loop-for-sets
- (push `(progn
- ,(cl--loop-let (nreverse loop-for-sets) 'setq ands)
+ `(< ,temp-idx (length ,temp-vec)))
+ (if (eq word 'across-ref)
+ (push (list var `(aref ,temp-vec ,temp-idx))
+ cl--loop-symbol-macs)
+ (push (list var nil) loop-for-bindings)
+ (push (list var `(aref ,temp-vec ,temp-idx))
+ loop-for-sets))))
+
+ ((memq word '(element elements))
+ (let ((ref (or (memq (peek) '(in-ref of-ref))
+ (and (not (memq (peek) '(in of)))
+ (error "Expected `of'"))))
+ (seq (cl--pop2 cl--loop-args))
+ (temp-seq (make-symbol "--cl-seq--"))
+ (temp-idx
+ (if (eq (peek) 'using)
+ (if (and (= (length (cadr cl--loop-args)) 2)
+ (eq (caadr cl--loop-args) 'index))
+ (cadr (cl--pop2 cl--loop-args))
+ (error "Bad `using' clause"))
+ (make-symbol "--cl-idx--"))))
+ (push (list temp-seq seq) loop-for-bindings)
+ (push (list temp-idx 0) loop-for-bindings)
+ (if ref
+ (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)
+ (cl--push-clause-loop-body `(< ,temp-idx ,temp-len)))
+ (push (list var nil) loop-for-bindings)
+ (cl--push-clause-loop-body `(and ,temp-seq
+ (or (consp ,temp-seq)
+ (< ,temp-idx (length ,temp-seq)))))
+ (push (list var `(if (consp ,temp-seq)
+ (pop ,temp-seq)
+ (aref ,temp-seq ,temp-idx)))
+ loop-for-sets))
+ (push (list temp-idx `(1+ ,temp-idx))
+ loop-for-steps)))
+
+ ((memq word hash-types)
+ (or (memq (peek) '(in of))
+ (error "Expected `of'"))
+ (let* ((table (cl--pop2 cl--loop-args))
+ (other
+ (if (eq (peek) 'using)
+ (if (and (= (length (cadr cl--loop-args)) 2)
+ (memq (caadr cl--loop-args) hash-types)
+ (not (eq (caadr cl--loop-args) word)))
+ (cadr (cl--pop2 cl--loop-args))
+ (error "Bad `using' clause"))
+ (make-symbol "--cl-var--"))))
+ (if (memq word '(hash-value hash-values))
+ (setq var (prog1 other (setq other var))))
+ (cl--loop-set-iterator-function
+ 'hash-tables (lambda (body)
+ `(maphash (lambda (,var ,other) . ,body)
+ ,table)))))
+
+ ((memq word '(symbol present-symbol external-symbol
+ symbols present-symbols external-symbols))
+ (let ((ob (and (memq (peek) '(in of))
+ (cl--pop2 cl--loop-args))))
+ (cl--loop-set-iterator-function
+ 'symbols (lambda (body)
+ `(mapatoms (lambda (,var) . ,body) ,ob)))))
+
+ ((memq word '(overlay overlays extent extents))
+ (let ((buf nil) (from nil) (to nil))
+ (while (memq (peek) '(in of from to))
+ (cond ((eq (peek) 'from)
+ (setq from (cl--pop2 cl--loop-args)))
+ ((eq (peek) 'to)
+ (setq to (cl--pop2 cl--loop-args)))
+ (t (setq buf (cl--pop2 cl--loop-args)))))
+ (cl--loop-set-iterator-function
+ 'overlays (lambda (body)
+ `(cl--map-overlays
+ (lambda (,var ,(make-symbol "--cl-var--"))
+ (progn . ,body) nil)
+ ,buf ,from ,to)))))
+
+ ((memq word '(interval intervals))
+ (let ((buf nil) (prop nil) (from nil) (to nil)
+ (var1 (make-symbol "--cl-var1--"))
+ (var2 (make-symbol "--cl-var2--")))
+ (while (memq (peek) '(in of property from to))
+ (cond ((eq (peek) 'from)
+ (setq from (cl--pop2 cl--loop-args)))
+ ((eq (peek) 'to)
+ (setq to (cl--pop2 cl--loop-args)))
+ ((eq (peek) 'property)
+ (setq prop (cl--pop2 cl--loop-args)))
+ (t (setq buf (cl--pop2 cl--loop-args)))))
+ (if (and (consp var) (symbolp (car var)) (symbolp (cdr var)))
+ (setq var1 (car var) var2 (cdr var))
+ (push (list var `(cons ,var1 ,var2)) loop-for-sets))
+ (cl--loop-set-iterator-function
+ 'intervals (lambda (body)
+ `(cl--map-intervals
+ (lambda (,var1 ,var2) . ,body)
+ ,buf ,prop ,from ,to)))))
+
+ ((memq word key-types)
+ (or (memq (peek) '(in of))
+ (error "Expected `of'"))
+ (let ((cl-map (cl--pop2 cl--loop-args))
+ (other
+ (if (eq (peek) 'using)
+ (if (and (= (length (cadr cl--loop-args)) 2)
+ (memq (caadr cl--loop-args) key-types)
+ (not (eq (caadr cl--loop-args) word)))
+ (cadr (cl--pop2 cl--loop-args))
+ (error "Bad `using' clause"))
+ (make-symbol "--cl-var--"))))
+ (if (memq word '(key-binding key-bindings))
+ (setq var (prog1 other (setq other var))))
+ (cl--loop-set-iterator-function
+ 'keys (lambda (body)
+ `(,(if (memq word '(key-seq key-seqs))
+ 'cl--map-keymap-recursively 'map-keymap)
+ (lambda (,var ,other) . ,body) ,cl-map)))))
+
+ ((memq word '(frame frames screen screens))
+ (let ((temp (make-symbol "--cl-var--")))
+ (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 (list var `(next-frame ,var))
+ loop-for-steps)))
+
+ ((memq word '(window windows))
+ (let ((scr (and (memq (peek) '(in of))
+ (cl--pop2 cl--loop-args)))
+ (temp (make-symbol "--cl-var--"))
+ (minip (make-symbol "--cl-minip--")))
+ (push (list var (if scr
+ `(frame-selected-window ,scr)
+ '(selected-window)))
+ loop-for-bindings)
+ ;; If we started in the minibuffer, we need to
+ ;; ensure that next-window will bring us back there
+ ;; at some point. (Bug#7492).
+ ;; (Consider using walk-windows instead of cl-loop if
+ ;; you care about such things.)
+ (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 (list var `(next-window ,var ,minip))
+ loop-for-steps)))
+
+ (t
+ ;; This is an advertised interface: (info "(cl)Other Clauses").
+ (let ((handler (and (symbolp word)
+ (get word 'cl-loop-for-handler))))
+ (if handler
+ (funcall handler var)
+ (error "Expected a `for' preposition, found %s" word)))))
+ (eq (peek) 'and))
+ (setq ands t)
+ (pop cl--loop-args))
+ (if (and ands loop-for-bindings)
+ (push (nreverse loop-for-bindings) cl--loop-bindings)
+ (setq cl--loop-bindings (nconc (mapcar #'list loop-for-bindings)
+ cl--loop-bindings)))
+ (if loop-for-sets
+ (push `(progn
+ ,(cl--loop-let (nreverse loop-for-sets) 'setq ands)
+ t)
+ cl--loop-body))
+ (when 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--")))
+ (push (list (list temp (pop cl--loop-args))) cl--loop-bindings)
+ (push `(>= (setq ,temp (1- ,temp)) 0) cl--loop-body)))
+
+ ((memq word '(collect collecting))
+ (let ((what (pop cl--loop-args))
+ (var (cl--loop-handle-accum nil 'nreverse)))
+ (if (eq var cl--loop-accum-var)
+ (push `(progn (push ,what ,var) t) cl--loop-body)
+ (push `(progn
+ (setq ,var (nconc ,var (list ,what)))
t)
- cl--loop-body))
- (when 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--")))
- (push (list (list temp (pop cl--loop-args))) cl--loop-bindings)
- (push `(>= (setq ,temp (1- ,temp)) 0) cl--loop-body)))
-
- ((memq word '(collect collecting))
- (let ((what (pop cl--loop-args))
- (var (cl--loop-handle-accum nil 'nreverse)))
- (if (eq var cl--loop-accum-var)
- (push `(progn (push ,what ,var) t) cl--loop-body)
- (push `(progn
- (setq ,var (nconc ,var (list ,what)))
+ cl--loop-body))))
+
+ ((memq word '(nconc nconcing append appending))
+ (let ((what (pop cl--loop-args))
+ (var (cl--loop-handle-accum nil 'nreverse)))
+ (push `(progn
+ (setq ,var
+ ,(if (eq var cl--loop-accum-var)
+ `(nconc
+ (,(if (memq word '(nconc nconcing))
+ #'nreverse #'reverse)
+ ,what)
+ ,var)
+ `(,(if (memq word '(nconc nconcing))
+ #'nconc #'append)
+ ,var ,what)))
t)
- cl--loop-body))))
-
- ((memq word '(nconc nconcing append appending))
- (let ((what (pop cl--loop-args))
- (var (cl--loop-handle-accum nil 'nreverse)))
- (push `(progn
- (setq ,var
- ,(if (eq var cl--loop-accum-var)
- `(nconc
- (,(if (memq word '(nconc nconcing))
- #'nreverse #'reverse)
- ,what)
- ,var)
- `(,(if (memq word '(nconc nconcing))
- #'nconc #'append)
- ,var ,what)))
- t)
- cl--loop-body)))
-
- ((memq word '(concat concating))
- (let ((what (pop cl--loop-args))
- (var (cl--loop-handle-accum "")))
- (push `(progn (cl-callf concat ,var ,what) t) cl--loop-body)))
-
- ((memq word '(vconcat vconcating))
- (let ((what (pop cl--loop-args))
- (var (cl--loop-handle-accum [])))
- (push `(progn (cl-callf vconcat ,var ,what) t) cl--loop-body)))
-
- ((memq word '(sum summing))
- (let ((what (pop cl--loop-args))
- (var (cl--loop-handle-accum 0)))
- (push `(progn (cl-incf ,var ,what) t) cl--loop-body)))
-
- ((memq word '(count counting))
- (let ((what (pop cl--loop-args))
- (var (cl--loop-handle-accum 0)))
- (push `(progn (if ,what (cl-incf ,var)) t) cl--loop-body)))
-
- ((memq word '(minimize minimizing maximize maximizing))
- (push `(progn ,(macroexp-let2 macroexp-copyable-p temp
- (pop cl--loop-args)
- (let* ((var (cl--loop-handle-accum nil))
- (func (intern (substring (symbol-name word)
- 0 3))))
- `(setq ,var (if ,var (,func ,var ,temp) ,temp))))
- t)
- cl--loop-body))
-
- ((eq word 'with)
- (let ((bindings nil))
- (while (progn (push (list (pop cl--loop-args)
- (and (eq (car cl--loop-args) '=)
- (cl--pop2 cl--loop-args)))
- bindings)
- (eq (car cl--loop-args) 'and))
- (pop cl--loop-args))
- (push (nreverse bindings) cl--loop-bindings)))
-
- ((eq word 'while)
- (push (pop cl--loop-args) cl--loop-body))
-
- ((eq word 'until)
- (push `(not ,(pop cl--loop-args)) cl--loop-body))
-
- ((eq word 'always)
- (or cl--loop-finish-flag
- (setq cl--loop-finish-flag (make-symbol "--cl-flag--")))
- (push `(setq ,cl--loop-finish-flag ,(pop cl--loop-args)) cl--loop-body)
- (setq cl--loop-result t))
-
- ((eq word 'never)
- (or cl--loop-finish-flag
- (setq cl--loop-finish-flag (make-symbol "--cl-flag--")))
- (push `(setq ,cl--loop-finish-flag (not ,(pop cl--loop-args)))
- cl--loop-body)
- (setq cl--loop-result t))
-
- ((eq word 'thereis)
- (or cl--loop-finish-flag
- (setq cl--loop-finish-flag (make-symbol "--cl-flag--")))
- (or cl--loop-result-var
- (setq cl--loop-result-var (make-symbol "--cl-var--")))
- (push `(setq ,cl--loop-finish-flag
- (not (setq ,cl--loop-result-var ,(pop cl--loop-args))))
- cl--loop-body))
-
- ((memq word '(if when unless))
- (let* ((cond (pop cl--loop-args))
- (then (let ((cl--loop-body nil))
- (cl--parse-loop-clause)
- (cl--loop-build-ands (nreverse cl--loop-body))))
- (else (let ((cl--loop-body nil))
- (if (eq (car cl--loop-args) 'else)
- (progn (pop cl--loop-args) (cl--parse-loop-clause)))
- (cl--loop-build-ands (nreverse cl--loop-body))))
- (simple (and (eq (car then) t) (eq (car else) t))))
- (if (eq (car cl--loop-args) 'end) (pop cl--loop-args))
- (if (eq word 'unless) (setq then (prog1 else (setq else then))))
- (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then))
- (if simple (nth 1 else) (list (nth 2 else))))))
- (setq form (if (cl--expr-contains form 'it)
- `(let ((it ,cond)) (if it ,@form))
- `(if ,cond ,@form)))
- (push (if simple `(progn ,form t) form) cl--loop-body))))
-
- ((memq word '(do doing))
- (let ((body nil))
- (or (consp (car cl--loop-args)) (error "Syntax error on `do' clause"))
- (while (consp (car cl--loop-args)) (push (pop cl--loop-args) body))
- (push (cons 'progn (nreverse (cons t body))) cl--loop-body)))
-
- ((eq word 'return)
- (or cl--loop-finish-flag
- (setq cl--loop-finish-flag (make-symbol "--cl-var--")))
- (or cl--loop-result-var
- (setq cl--loop-result-var (make-symbol "--cl-var--")))
- (push `(setq ,cl--loop-result-var ,(pop cl--loop-args)
- ,cl--loop-finish-flag nil)
- cl--loop-body))
-
- (t
- ;; This is an advertised interface: (info "(cl)Other Clauses").
- (let ((handler (and (symbolp word) (get word 'cl-loop-handler))))
- (or handler (error "Expected a cl-loop keyword, found %s" word))
- (funcall handler))))
- (if (eq (car cl--loop-args) 'and)
- (progn (pop cl--loop-args) (cl--parse-loop-clause)))))
+ cl--loop-body)))
+
+ ((memq word '(concat concating))
+ (let ((what (pop cl--loop-args))
+ (var (cl--loop-handle-accum "")))
+ (push `(progn (cl-callf concat ,var ,what) t) cl--loop-body)))
+
+ ((memq word '(vconcat vconcating))
+ (let ((what (pop cl--loop-args))
+ (var (cl--loop-handle-accum [])))
+ (push `(progn (cl-callf vconcat ,var ,what) t) cl--loop-body)))
+
+ ((memq word '(sum summing))
+ (let ((what (pop cl--loop-args))
+ (var (cl--loop-handle-accum 0)))
+ (push `(progn (cl-incf ,var ,what) t) cl--loop-body)))
+
+ ((memq word '(count counting))
+ (let ((what (pop cl--loop-args))
+ (var (cl--loop-handle-accum 0)))
+ (push `(progn (if ,what (cl-incf ,var)) t) cl--loop-body)))
+
+ ((memq word '(minimize minimizing maximize maximizing))
+ (push `(progn ,(macroexp-let2 macroexp-copyable-p temp
+ (pop cl--loop-args)
+ (let* ((var (cl--loop-handle-accum nil))
+ (func (intern (substring (symbol-name word)
+ 0 3))))
+ `(setq ,var (if ,var (,func ,var ,temp) ,temp))))
+ t)
+ cl--loop-body))
+
+ ((eq word 'with)
+ (let ((bindings nil))
+ (while (progn (push (list (pop cl--loop-args)
+ (and (eq (peek) '=)
+ (cl--pop2 cl--loop-args)))
+ bindings)
+ (eq (peek) 'and))
+ (pop cl--loop-args))
+ (push (nreverse bindings) cl--loop-bindings)))
+
+ ((eq word 'while)
+ (push (pop cl--loop-args) cl--loop-body))
+
+ ((eq word 'until)
+ (push `(not ,(pop cl--loop-args)) cl--loop-body))
+
+ ((eq word 'always)
+ (or cl--loop-finish-flag
+ (setq cl--loop-finish-flag (make-symbol "--cl-flag--")))
+ (push `(setq ,cl--loop-finish-flag ,(pop cl--loop-args)) cl--loop-body)
+ (setq cl--loop-result t))
+
+ ((eq word 'never)
+ (or cl--loop-finish-flag
+ (setq cl--loop-finish-flag (make-symbol "--cl-flag--")))
+ (push `(setq ,cl--loop-finish-flag (not ,(pop cl--loop-args)))
+ cl--loop-body)
+ (setq cl--loop-result t))
+
+ ((eq word 'thereis)
+ (or cl--loop-finish-flag
+ (setq cl--loop-finish-flag (make-symbol "--cl-flag--")))
+ (or cl--loop-result-var
+ (setq cl--loop-result-var (make-symbol "--cl-var--")))
+ (push `(setq ,cl--loop-finish-flag
+ (not (setq ,cl--loop-result-var ,(pop cl--loop-args))))
+ cl--loop-body))
+
+ ((memq word '(if when unless))
+ (let* ((cond (pop cl--loop-args))
+ (then (let ((cl--loop-body nil))
+ (cl--parse-loop-clause)
+ (cl--loop-build-ands (nreverse cl--loop-body))))
+ (else (let ((cl--loop-body nil))
+ (if (eq (peek) 'else)
+ (progn (pop cl--loop-args) (cl--parse-loop-clause)))
+ (cl--loop-build-ands (nreverse cl--loop-body))))
+ (simple (and (eq (car then) t) (eq (car else) t))))
+ (if (eq (peek) 'end) (pop cl--loop-args))
+ (if (eq word 'unless) (setq then (prog1 else (setq else then))))
+ (let ((form (cons (if simple (cons 'progn (nth 1 then)) (nth 2 then))
+ (if simple (nth 1 else) (list (nth 2 else))))))
+ (setq form (if (cl--expr-contains form 'it)
+ `(let ((it ,cond)) (if it ,@form))
+ `(if ,cond ,@form)))
+ (push (if simple `(progn ,form t) form) cl--loop-body))))
+
+ ((memq word '(do doing))
+ (let ((body nil))
+ (or (consp (peek)) (error "Syntax error on `do' clause"))
+ (while (consp (peek)) (push (pop cl--loop-args) body))
+ (push (cons 'progn (nreverse (cons t body))) cl--loop-body)))
+
+ ((eq word 'return)
+ (or cl--loop-finish-flag
+ (setq cl--loop-finish-flag (make-symbol "--cl-var--")))
+ (or cl--loop-result-var
+ (setq cl--loop-result-var (make-symbol "--cl-var--")))
+ (push `(setq ,cl--loop-result-var ,(pop cl--loop-args)
+ ,cl--loop-finish-flag nil)
+ cl--loop-body))
+
+ (t
+ ;; This is an advertised interface: (info "(cl)Other Clauses").
+ (let ((handler (and (symbolp word) (get word 'cl-loop-handler))))
+ (or handler (error "Expected a cl-loop keyword, found %s" word))
+ (funcall handler))))
+ (if (eq (peek) 'and)
+ (progn (pop cl--loop-args) (cl--parse-loop-clause))))))
(defun cl--unused-var-p (sym)
(or (null sym) (eq ?_ (aref (symbol-name sym) 0))))
--
2.37.3
next prev parent reply other threads:[~2022-09-18 20:12 UTC|newest]
Thread overview: 13+ messages / expand[flat|nested] mbox.gz Atom feed top
2022-09-18 12:03 bug#57907: 29.0.50; Using keywords with cl-loop Philip Kaludercic
2022-09-18 12:20 ` Lars Ingebrigtsen
2022-09-18 12:28 ` Philip Kaludercic
2022-09-18 12:37 ` Lars Ingebrigtsen
2022-09-18 12:46 ` Philip Kaludercic
2022-09-19 8:06 ` Lars Ingebrigtsen
2022-09-19 10:16 ` Philip Kaludercic
2022-09-19 12:52 ` Lars Ingebrigtsen
[not found] ` <handler.57907.B.166350264228653.ack@debbugs.gnu.org>
2022-09-18 12:26 ` bug#57907: Acknowledgement (29.0.50; Using keywords with cl-loop) Philip Kaludercic
2022-09-18 20:12 ` Philip Kaludercic [this message]
2022-09-18 12:38 ` bug#57907: 29.0.50; Using keywords with cl-loop Gerd Möllmann
2022-09-18 12:52 ` Philip Kaludercic
2022-09-18 13:01 ` Gerd Möllmann
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
List information: https://www.gnu.org/software/emacs/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to='87wna08ms5.fsf__40086.9307502703$1663531999$gmane$org@posteo.net' \
--to=philipk@posteo.net \
--cc=57907@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 public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).