Fix some of the problems in defsubst* (bug#5728).

* emacs-lisp/cl-macs.el (defsubst*): Don't substitute non-trivial args.
(cl-defsubst-expand): Do the substitutions simultaneously (bug#5728).

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 6cdaaf2255b85391ded791ee7a1cf023862dffac..ba042245fd67611a310c56ce77f6a3383abe5994 100644 (file)
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,7 +1,13 @@
+2010-04-08  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+       Fix some of the problems in defsubst* (bug#5728).
+       * emacs-lisp/cl-macs.el (defsubst*): Don't substitute non-trivial args.
+       (cl-defsubst-expand): Do the substitutions simultaneously (bug#5728).
+
 2010-04-07  Sam Steingold  <sds@gnu.org>
 
-       * progmodes/compile.el (compilation-save-buffers-predicate): New
-       custom variable.
+       * progmodes/compile.el (compilation-save-buffers-predicate):
+       New custom variable.
        (compile, recompile): Pass it to `save-some-buffers'.
 
 2010-04-07  Jan Djärv  <jan.h.d@swipnet.se>

diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 8a60ffdf1fe536d4e4f29880e5f59f9111c3556b..7d8108bcd8792b7230c1c25703044db1bc6cd66b 100644 (file)
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -128,6 +128,12 @@
   (and (eq (cl-const-expr-p x) t) (if (consp x) (nth 1 x) x)))
 
 (defun cl-expr-access-order (x v)
+  ;; This apparently tries to return nil iff the expression X evaluates
+  ;; the variables V in the same order as they appear in V (so as to
+  ;; be able to replace those vars with the expressions they're bound
+  ;; to).
+  ;; FIXME: This is very naive, it doesn't even check to see if those
+  ;; variables appear more than once.
   (if (cl-const-expr-p x) v
     (if (consp x)
        (progn
@@ -2616,21 +2622,36 @@ surrounded by (block NAME ...).
                    (cons '&cl-quote args))
                  (list* 'cl-defsubst-expand (list 'quote argns)
                         (list 'quote (list* 'block name body))
-                        (not (or unsafe (cl-expr-access-order pbody argns)))
+                         ;; We used to pass `simple' as
+                         ;; (not (or unsafe (cl-expr-access-order pbody argns)))
+                         ;; But this is much too simplistic since it
+                         ;; does not pay attention to the argvs (and
+                         ;; cl-expr-access-order itself is also too naive).
+                        nil
                         (and (memq '&key args) 'cl-whole) unsafe argns)))
          (list* 'defun* name args body))))
 
 (defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs)
   (if (and whole (not (cl-safe-expr-p (cons 'progn argvs)))) whole
     (if (cl-simple-exprs-p argvs) (setq simple t))
-    (let ((lets (delq nil
-                     (mapcar* (function
-                               (lambda (argn argv)
-                                 (if (or simple (cl-const-expr-p argv))
-                                     (progn (setq body (subst argv argn body))
-                                            (and unsafe (list argn argv)))
-                                   (list argn argv))))
-                              argns argvs))))
+    (let* ((substs ())
+           (lets (delq nil
+                       (mapcar* (function
+                                 (lambda (argn argv)
+                                   (if (or simple (cl-const-expr-p argv))
+                                       (progn (push (cons argn argv) substs)
+                                              (and unsafe (list argn argv)))
+                                     (list argn argv))))
+                                argns argvs))))
+      ;; FIXME: `sublis/subst' will happily substitute the symbol
+      ;; `argn' in places where it's not used as a reference
+      ;; to a variable.
+      ;; FIXME: `sublis/subst' will happily copy `argv' to a different
+      ;; scope, leading to name capture.
+      (setq body (cond ((null substs) body)
+                       ((null (cdr substs))
+                        (subst (cdar substs) (caar substs) body))
+                       (t (sublis substs body))))
       (if lets (list 'let lets body) body))))