[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: bug#57907: Acknowledgement (29.0.50; Using keywords with cl-loop)
|
From: |
Philip Kaludercic |
|
Subject: |
Re: bug#57907: Acknowledgement (29.0.50; Using keywords with cl-loop) |
|
Date: |
Sun, 18 Sep 2022 12:26:46 +0000 |
It seems it isn't that difficult to do this (though the patch is longer
than it ought to be because of indentation changes):
>From d98dc3e0905d41305061708a601d63659fa7ce81 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.
---
lisp/emacs-lisp/cl-macs.el | 938 +++++++++++++++++++------------------
1 file changed, 474 insertions(+), 464 deletions(-)
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index f8fdc50251..2df91701e2 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -926,6 +926,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...)"
@@ -933,22 +936,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)
@@ -1184,465 +1189,470 @@ 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 ((next ()
+ (let ((word (pop 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 (next)))
+
+ ((eq word 'initially)
+ (if (memq (car cl--loop-args) '(do doing)) (next))
+ (or (consp (car cl--loop-args))
+ (error "Syntax error on `initially' clause"))
+ (while (consp (car cl--loop-args))
+ (push (next) 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)) (next))
+ (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 (next)) '(quote nil)))
+ (while (consp (car cl--loop-args))
+ (push (next) 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 (next) (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 (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
+ (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 (next)) 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 (next))
+ (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 (next)) 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 (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)
+ (next))
+ (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 (next))) cl--loop-bindings)
+ (push `(>= (setq ,temp (1- ,temp)) 0) cl--loop-body)))
+
+ ((memq word '(collect collecting))
+ (let ((what (next))
+ (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 (next))
+ (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 (next))
+ (var (cl--loop-handle-accum "")))
+ (push `(progn (cl-callf concat ,var ,what) t) cl--loop-body)))
+
+ ((memq word '(vconcat vconcating))
+ (let ((what (next))
+ (var (cl--loop-handle-accum [])))
+ (push `(progn (cl-callf vconcat ,var ,what) t) cl--loop-body)))
+
+ ((memq word '(sum summing))
+ (let ((what (next))
+ (var (cl--loop-handle-accum 0)))
+ (push `(progn (cl-incf ,var ,what) t) cl--loop-body)))
+
+ ((memq word '(count counting))
+ (let ((what (next))
+ (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
+ (next)
+ (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 (next)
+ (and (eq (car cl--loop-args) '=)
+ (cl--pop2 cl--loop-args)))
+ bindings)
+ (eq (car cl--loop-args) 'and))
+ (next))
+ (push (nreverse bindings) cl--loop-bindings)))
+
+ ((eq word 'while)
+ (push (next) cl--loop-body))
+
+ ((eq word 'until)
+ (push `(not ,(next)) 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 ,(next)) 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 ,(next)))
+ 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 ,(next))))
+ cl--loop-body))
+
+ ((memq word '(if when unless))
+ (let* ((cond (next))
+ (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 (next) (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) (next))
+ (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 (next) 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 ,(next)
+ ,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 (next) (cl--parse-loop-clause))))))
(defun cl--unused-var-p (sym)
(or (null sym) (eq ?_ (aref (symbol-name sym) 0))))
--
2.37.3
Perhaps I could pull the cl-flet out and replace each (next) with a
(cl--loop-parse-next)?
- Re: bug#57907: Acknowledgement (29.0.50; Using keywords with cl-loop),
Philip Kaludercic <=