* 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

2 files changed, 129 insertions, 68 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 21bcfc0d9fb..7e1561b03fd 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -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
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 031bf5553d0..60fdc09c053 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -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)))))