* lisp/emacs-lisp/cl-macs.el:
(cl--loop-destr-temps): Remove. (cl--loop-iterator-function): Rename from cl--loop-map-form and change its convention. (cl--loop-set-iterator-function): New function. (cl-loop): Adjust accordingly, so as not to use cl-subst. (cl--parse-loop-clause): Adjust all uses of cl--loop-map-form. Bind `it' with `let' instead of substituting it with `cl-subst'. (cl--unused-var-p): New function. (cl--loop-let): Don't use the cl--loop-destr-temps hack any more. Eliminate some unused variable warnings. Fixes: debbugs:15326
This commit is contained in:
Stefan Monnier
parent
529fb53f7e
commit
3b7b269256
2 changed files with 129 additions and 68 deletions
|
|
@ -1,3 +1,17 @@
|
|||
2013-09-28 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* emacs-lisp/cl-macs.el:
|
||||
(cl--loop-destr-temps): Remove.
|
||||
(cl--loop-iterator-function): Rename from cl--loop-map-form and change
|
||||
its convention.
|
||||
(cl--loop-set-iterator-function): New function.
|
||||
(cl-loop): Adjust accordingly, so as not to use cl-subst.
|
||||
(cl--parse-loop-clause): Adjust all uses of cl--loop-map-form.
|
||||
Bind `it' with `let' instead of substituting it with `cl-subst'.
|
||||
(cl--unused-var-p): New function.
|
||||
(cl--loop-let): Don't use the cl--loop-destr-temps hack any more.
|
||||
Eliminate some unused variable warnings (bug#15326).
|
||||
|
||||
2013-09-27 Tassilo Horn <tsdh@gnu.org>
|
||||
|
||||
* doc-view.el (doc-view-scale-reset): Rename from
|
||||
|
|
|
|||
|
|
@ -756,14 +756,22 @@ 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-destr-temps)
|
||||
(defvar cl--loop-finally) (defvar cl--loop-finish-flag)
|
||||
(defvar cl--loop-bindings) (defvar cl--loop-body)
|
||||
(defvar cl--loop-finally)
|
||||
(defvar cl--loop-finish-flag) ;Symbol set to nil to exit the loop?
|
||||
(defvar cl--loop-first-flag)
|
||||
(defvar cl--loop-initially) (defvar cl--loop-map-form) (defvar cl--loop-name)
|
||||
(defvar cl--loop-initially) (defvar cl--loop-iterator-function)
|
||||
(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)
|
||||
|
||||
(defun cl--loop-set-iterator-function (kind iterator)
|
||||
(if cl--loop-iterator-function
|
||||
;; FIXME: Of course, we could make it work, but why bother.
|
||||
(error "Iteration on %S does not support this combination" kind)
|
||||
(setq cl--loop-iterator-function iterator)))
|
||||
|
||||
;;;###autoload
|
||||
(defmacro cl-loop (&rest loop-args)
|
||||
"The Common Lisp `loop' macro.
|
||||
|
|
@ -817,13 +825,35 @@ For more details, see Info node `(cl)Loop Facility'.
|
|||
(delq nil (delq t (cl-copy-list 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)
|
||||
(cl--loop-result nil) (cl--loop-result-explicit nil)
|
||||
(cl--loop-result-var nil) (cl--loop-finish-flag nil)
|
||||
(cl--loop-body nil) (cl--loop-steps nil)
|
||||
(cl--loop-result nil) (cl--loop-result-explicit nil)
|
||||
(cl--loop-result-var nil) (cl--loop-finish-flag nil)
|
||||
(cl--loop-accum-var nil) (cl--loop-accum-vars nil)
|
||||
(cl--loop-initially nil) (cl--loop-finally nil)
|
||||
(cl--loop-map-form nil) (cl--loop-first-flag nil)
|
||||
(cl--loop-destr-temps nil) (cl--loop-symbol-macs nil))
|
||||
(cl--loop-iterator-function nil) (cl--loop-first-flag nil)
|
||||
(cl--loop-symbol-macs nil))
|
||||
;; Here is more or less how those dynbind vars are used after looping
|
||||
;; over cl--parse-loop-clause:
|
||||
;;
|
||||
;; (cl-block ,cl--loop-name
|
||||
;; (cl-symbol-macrolet ,cl--loop-symbol-macs
|
||||
;; (foldl #'cl--loop-let
|
||||
;; `((,cl--loop-result-var)
|
||||
;; ((,cl--loop-first-flag t))
|
||||
;; ((,cl--loop-finish-flag t))
|
||||
;; ,@cl--loop-bindings)
|
||||
;; ,@(nreverse cl--loop-initially)
|
||||
;; (while ;(well: cl--loop-iterator-function)
|
||||
;; ,(car (cl--loop-build-ands (nreverse cl--loop-body)))
|
||||
;; ,@(cadr (cl--loop-build-ands (nreverse cl--loop-body)))
|
||||
;; ,@(nreverse cl--loop-steps)
|
||||
;; (setq ,cl--loop-first-flag nil))
|
||||
;; (if (not ,cl--loop-finish-flag) ;FIXME: Why `if' vs `progn'?
|
||||
;; ,cl--loop-result-var
|
||||
;; ,@(nreverse cl--loop-finally)
|
||||
;; ,(or cl--loop-result-explicit
|
||||
;; cl--loop-result)))))
|
||||
;;
|
||||
(setq cl--loop-args (append cl--loop-args '(cl-end-loop)))
|
||||
(while (not (eq (car cl--loop-args) 'cl-end-loop))
|
||||
(cl--parse-loop-clause))
|
||||
|
|
@ -839,15 +869,15 @@ For more details, see Info node `(cl)Loop Facility'.
|
|||
(while-body (nconc (cadr ands) (nreverse cl--loop-steps)))
|
||||
(body (append
|
||||
(nreverse cl--loop-initially)
|
||||
(list (if cl--loop-map-form
|
||||
(list (if cl--loop-iterator-function
|
||||
`(cl-block --cl-finish--
|
||||
,(cl-subst
|
||||
(if (eq (car ands) t) while-body
|
||||
(cons `(or ,(car ands)
|
||||
(cl-return-from --cl-finish--
|
||||
nil))
|
||||
while-body))
|
||||
'--cl-map cl--loop-map-form))
|
||||
,(funcall cl--loop-iterator-function
|
||||
(if (eq (car ands) t) while-body
|
||||
(cons `(or ,(car ands)
|
||||
(cl-return-from
|
||||
--cl-finish--
|
||||
nil))
|
||||
while-body))))
|
||||
`(while ,(car ands) ,@while-body)))
|
||||
(if cl--loop-finish-flag
|
||||
(if (equal epilogue '(nil)) (list cl--loop-result-var)
|
||||
|
|
@ -1216,15 +1246,18 @@ For more details, see Info node `(cl)Loop Facility'.
|
|||
(make-symbol "--cl-var--"))))
|
||||
(if (memq word '(hash-value hash-values))
|
||||
(setq var (prog1 other (setq other var))))
|
||||
(setq cl--loop-map-form
|
||||
`(maphash (lambda (,var ,other) . --cl-map) ,table))))
|
||||
(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))))
|
||||
(setq cl--loop-map-form
|
||||
`(mapatoms (lambda (,var) . --cl-map) ,ob))))
|
||||
(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))
|
||||
|
|
@ -1234,11 +1267,12 @@ For more details, see Info node `(cl)Loop Facility'.
|
|||
((eq (car cl--loop-args) 'to)
|
||||
(setq to (cl--pop2 cl--loop-args)))
|
||||
(t (setq buf (cl--pop2 cl--loop-args)))))
|
||||
(setq cl--loop-map-form
|
||||
`(cl--map-overlays
|
||||
(lambda (,var ,(make-symbol "--cl-var--"))
|
||||
(progn . --cl-map) nil)
|
||||
,buf ,from ,to))))
|
||||
(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)
|
||||
|
|
@ -1255,10 +1289,11 @@ For more details, see Info node `(cl)Loop Facility'.
|
|||
(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))
|
||||
(setq cl--loop-map-form
|
||||
`(cl--map-intervals
|
||||
(lambda (,var1 ,var2) . --cl-map)
|
||||
,buf ,prop ,from ,to))))
|
||||
(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))
|
||||
|
|
@ -1274,10 +1309,11 @@ For more details, see Info node `(cl)Loop Facility'.
|
|||
(make-symbol "--cl-var--"))))
|
||||
(if (memq word '(key-binding key-bindings))
|
||||
(setq var (prog1 other (setq other var))))
|
||||
(setq cl--loop-map-form
|
||||
`(,(if (memq word '(key-seq key-seqs))
|
||||
'cl--map-keymap-recursively 'map-keymap)
|
||||
(lambda (,var ,other) . --cl-map) ,cl-map))))
|
||||
(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--")))
|
||||
|
|
@ -1448,12 +1484,9 @@ For more details, see Info node `(cl)Loop Facility'.
|
|||
(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))))))
|
||||
(if (cl--expr-contains form 'it)
|
||||
(let ((temp (make-symbol "--cl-var--")))
|
||||
(push (list temp) cl--loop-bindings)
|
||||
(setq form `(if (setq ,temp ,cond)
|
||||
,@(cl-subst temp 'it form))))
|
||||
(setq form `(if ,cond ,@form)))
|
||||
(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))
|
||||
|
|
@ -1478,36 +1511,50 @@ For more details, see Info node `(cl)Loop Facility'.
|
|||
(if (eq (car cl--loop-args) 'and)
|
||||
(progn (pop cl--loop-args) (cl--parse-loop-clause)))))
|
||||
|
||||
(defun cl--loop-let (specs body par) ; uses loop-*
|
||||
(let ((p specs) (temps nil) (new nil))
|
||||
(while (and p (or (symbolp (car-safe (car p))) (null (cl-cadar p))))
|
||||
(setq p (cdr p)))
|
||||
(and par p
|
||||
(progn
|
||||
(setq par nil p specs)
|
||||
(while p
|
||||
(or (macroexp-const-p (cl-cadar p))
|
||||
(let ((temp (make-symbol "--cl-var--")))
|
||||
(push (list temp (cl-cadar p)) temps)
|
||||
(setcar (cdar p) temp)))
|
||||
(setq p (cdr p)))))
|
||||
(defun cl--unused-var-p (sym)
|
||||
(or (null sym) (eq ?_ (aref (symbol-name sym) 0))))
|
||||
|
||||
(defun cl--loop-let (specs body par) ; modifies cl--loop-bindings
|
||||
"Build an expression equivalent to (let SPECS BODY).
|
||||
SPECS can include bindings using `cl-loop's destructuring (not to be
|
||||
confused with the patterns of `cl-destructuring-bind').
|
||||
If PAR is nil, do the bindings step by step, like `let*'.
|
||||
If BODY is `setq', then use SPECS for assignments rather than for bindings."
|
||||
(let ((temps nil) (new nil))
|
||||
(when par
|
||||
(let ((p specs))
|
||||
(while (and p (or (symbolp (car-safe (car p))) (null (cl-cadar p))))
|
||||
(setq p (cdr p)))
|
||||
(when p
|
||||
(setq par nil)
|
||||
(dolist (spec specs)
|
||||
(or (macroexp-const-p (cadr spec))
|
||||
(let ((temp (make-symbol "--cl-var--")))
|
||||
(push (list temp (cadr spec)) temps)
|
||||
(setcar (cdr spec) temp)))))))
|
||||
(while specs
|
||||
(if (and (consp (car specs)) (listp (caar specs)))
|
||||
(let* ((spec (caar specs)) (nspecs nil)
|
||||
(expr (cadr (pop specs)))
|
||||
(temp
|
||||
(cdr (or (assq spec cl--loop-destr-temps)
|
||||
(car (push (cons spec
|
||||
(or (last spec 0)
|
||||
(make-symbol "--cl-var--")))
|
||||
cl--loop-destr-temps))))))
|
||||
(push (list temp expr) new)
|
||||
(while (consp spec)
|
||||
(push (list (pop spec)
|
||||
(and expr (list (if spec 'pop 'car) temp)))
|
||||
nspecs))
|
||||
(setq specs (nconc (nreverse nspecs) specs)))
|
||||
(push (pop specs) new)))
|
||||
(let* ((binding (pop specs))
|
||||
(spec (car-safe binding)))
|
||||
(if (and (consp binding) (or (consp spec) (cl--unused-var-p spec)))
|
||||
(let* ((nspecs nil)
|
||||
(expr (car (cdr-safe binding)))
|
||||
(temp (last spec 0)))
|
||||
(if (and (cl--unused-var-p temp) (null expr))
|
||||
nil ;; Don't bother declaring/setting `temp' since it won't
|
||||
;; be used when `expr' is nil, anyway.
|
||||
(when (and (eq body 'setq) (cl--unused-var-p temp))
|
||||
;; Prefer a fresh uninterned symbol over "_to", to avoid
|
||||
;; warnings that we set an unused variable.
|
||||
(setq temp (make-symbol "--cl-var--"))
|
||||
;; Make sure this temp variable is locally declared.
|
||||
(push (list (list temp)) cl--loop-bindings))
|
||||
(push (list temp expr) new))
|
||||
(while (consp spec)
|
||||
(push (list (pop spec)
|
||||
(and expr (list (if spec 'pop 'car) temp)))
|
||||
nspecs))
|
||||
(setq specs (nconc (nreverse nspecs) specs)))
|
||||
(push binding new))))
|
||||
(if (eq body 'setq)
|
||||
(let ((set (cons (if par 'cl-psetq 'setq)
|
||||
(apply 'nconc (nreverse new)))))
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue