Commit 3b7b2692 authored by Stefan Monnier's avatar Stefan Monnier
Browse files

* 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
parent 529fb53f
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)))))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment