[Emacs-diffs] /srv/bzr/emacs/trunk r110877: * lisp/emacs-lisp/cl.el (dolist, dotimes, declare): Use advice-add to

[Stefan Monnier]

------------------------------------------------------------
revno: 110877
committer: Stefan Monnier <address@hidden>
branch nick: trunk
timestamp: Mon 2012-11-12 22:00:09 -0500
message:
  * lisp/emacs-lisp/cl.el (dolist, dotimes, declare): Use advice-add to
  override the default.
  * lisp/emacs-lisp/cl-macs.el (cl-dolist, cl-dotimes): Rewrite without using
  cl--dotimes/dolist.
  * lisp/subr.el (dolist, dotimes, declare): Redefine them normally, even when
  `cl' is loaded.
  
  * lisp/emacs-lisp/nadvice.el (advice--normalize): New function, extracted
  from add-advice.
  (advice--strip-macro): New function.
  (advice--defalias-fset): Use them to handle macros.
  (advice-add): Use them.
  (advice-member-p): Correctly handle macros.
modified:
  lisp/ChangeLog
  lisp/emacs-lisp/cl-loaddefs.el
  lisp/emacs-lisp/cl-macs.el
  lisp/emacs-lisp/cl.el
  lisp/emacs-lisp/nadvice.el
  lisp/subr.el
  test/automated/advice-tests.el

=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog    2012-11-13 02:25:59 +0000
+++ b/lisp/ChangeLog    2012-11-13 03:00:09 +0000
@@ -1,5 +1,21 @@
 2012-11-13  Stefan Monnier  <address@hidden>
 
+       * emacs-lisp/cl.el (dolist, dotimes, declare): Use advice-add to
+       override the default.
+       * emacs-lisp/cl-macs.el (cl-dolist, cl-dotimes): Rewrite without using
+       cl--dotimes/dolist.
+       * subr.el (dolist, dotimes, declare): Redefine them normally, even when
+       `cl' is loaded.
+
+       * emacs-lisp/nadvice.el (advice--normalize): New function, extracted
+       from add-advice.
+       (advice--strip-macro): New function.
+       (advice--defalias-fset): Use them to handle macros.
+       (advice-add): Use them.
+       (advice-member-p): Correctly handle macros.
+
+2012-11-13  Stefan Monnier  <address@hidden>
+
        * emacs-lisp/gv.el (gv-define-simple-setter): One more fix (bug#12871).
 
 2012-11-13  Wolfgang Jenkner  <address@hidden>

=== modified file 'lisp/emacs-lisp/cl-loaddefs.el'
--- a/lisp/emacs-lisp/cl-loaddefs.el    2012-11-11 11:22:06 +0000
+++ b/lisp/emacs-lisp/cl-loaddefs.el    2012-11-13 03:00:09 +0000
@@ -267,7 +267,7 @@
 ;;;;;;  cl-typecase cl-ecase cl-case cl-load-time-value cl-eval-when
 ;;;;;;  cl-destructuring-bind cl-function cl-defmacro cl-defun cl-gentemp
 ;;;;;;  cl-gensym cl--compiler-macro-cXXr cl--compiler-macro-list*)
-;;;;;;  "cl-macs" "cl-macs.el" "a7228877484d2b39e1c2bee40b011734")
+;;;;;;  "cl-macs" "cl-macs.el" "c7ad09a74a1d2969406e7e2aaf3812fc")
 ;;; Generated autoloads from cl-macs.el
 
 (autoload 'cl--compiler-macro-list* "cl-macs" "\

=== modified file 'lisp/emacs-lisp/cl-macs.el'
--- a/lisp/emacs-lisp/cl-macs.el        2012-11-05 08:29:12 +0000
+++ b/lisp/emacs-lisp/cl-macs.el        2012-11-13 03:00:09 +0000
@@ -1547,9 +1547,9 @@
 \(fn (VAR LIST [RESULT]) BODY...)"
   (declare (debug ((symbolp form &optional form) cl-declarations body))
            (indent 1))
-  `(cl-block nil
-     (,(if (eq 'cl-dolist (symbol-function 'dolist)) 'cl--dolist 'dolist)
-      ,spec ,@body)))
+  (let ((loop `(dolist ,spec ,@body)))
+    (if (advice-member-p #'cl--wrap-in-nil-block 'dolist)
+        loop `(cl-block nil ,loop))))
 
 ;;;###autoload
 (defmacro cl-dotimes (spec &rest body)
@@ -1560,9 +1560,9 @@
 
 \(fn (VAR COUNT [RESULT]) BODY...)"
   (declare (debug cl-dolist) (indent 1))
-  `(cl-block nil
-     (,(if (eq 'cl-dotimes (symbol-function 'dotimes)) 'cl--dotimes 'dotimes)
-      ,spec ,@body)))
+  (let ((loop `(dotimes ,spec ,@body)))
+    (if (advice-member-p #'cl--wrap-in-nil-block 'dotimes)
+        loop `(cl-block nil ,loop))))
 
 ;;;###autoload
 (defmacro cl-do-symbols (spec &rest body)

=== modified file 'lisp/emacs-lisp/cl.el'
--- a/lisp/emacs-lisp/cl.el     2012-11-07 08:56:16 +0000
+++ b/lisp/emacs-lisp/cl.el     2012-11-13 03:00:09 +0000
@@ -107,14 +107,6 @@
                ))
   (defvaralias var (intern (format "cl-%s" var))))
 
-;; Before overwriting subr.el's `dotimes' and `dolist', let's remember
-;; them under a different name, so we can use them in our implementation
-;; of `dotimes' and `dolist'.
-(unless (fboundp 'cl--dotimes)
-  (defalias 'cl--dotimes (symbol-function 'dotimes) "The non-CL `dotimes'."))
-(unless (fboundp 'cl--dolist)
-  (defalias 'cl--dolist (symbol-function 'dolist) "The non-CL `dolist'."))
-
 (dolist (fun '(
                (get* . cl-get)
                (random* . cl-random)
@@ -228,7 +220,6 @@
                remf
                psetf
                (define-setf-method . define-setf-expander)
-               declare
                the
                locally
                multiple-value-setq
@@ -239,8 +230,6 @@
                psetq
                do-all-symbols
                do-symbols
-               dotimes
-               dolist
                do*
                do
                loop
@@ -322,6 +311,15 @@
                (intern (format "cl-%s" fun)))))
     (defalias fun new)))
 
+(defun cl--wrap-in-nil-block (fun &rest args)
+  `(cl-block nil ,(apply fun args)))
+(advice-add 'dolist :around #'cl--wrap-in-nil-block)
+(advice-add 'dotimes :around #'cl--wrap-in-nil-block)
+
+(defun cl--pass-args-to-cl-declare (&rest specs)
+   (macroexpand `(cl-declare ,@specs)))
+(advice-add 'declare :after #'cl--pass-args-to-cl-declare)
+
 ;;; Features provided a bit differently in Elisp.
 
 ;; First, the old lexical-let is now better served by `lexical-binding', tho

=== modified file 'lisp/emacs-lisp/nadvice.el'
--- a/lisp/emacs-lisp/nadvice.el        2012-11-12 20:43:43 +0000
+++ b/lisp/emacs-lisp/nadvice.el        2012-11-13 03:00:09 +0000
@@ -230,23 +230,49 @@
         (advice--make-1 (aref old 1) (aref old 3)
                         first nrest props)))))
 
+(defun advice--normalize (symbol def)
+  (cond
+   ((special-form-p def)
+    ;; Not worth the trouble trying to handle this, I think.
+    (error "add-advice failure: %S is a special form" symbol))
+   ((and (symbolp def)
+        (eq 'macro (car-safe (ignore-errors (indirect-function def)))))
+    (let ((newval (cons 'macro (cdr (indirect-function def)))))
+      (put symbol 'advice--saved-rewrite (cons def newval))
+      newval))
+   ;; `f' might be a pure (hence read-only) cons!
+   ((and (eq 'macro (car-safe def))
+        (not (ignore-errors (setcdr def (cdr def)) t)))
+    (cons 'macro (cdr def)))
+   (t def)))
+
+(defsubst advice--strip-macro (x)
+  (if (eq 'macro (car-safe x)) (cdr x) x))
+
 (defun advice--defalias-fset (fsetfun symbol newdef)
-  (let* ((olddef (if (fboundp symbol) (symbol-function symbol)))
+  (when (get symbol 'advice--saved-rewrite)
+    (put symbol 'advice--saved-rewrite nil))
+  (setq newdef (advice--normalize symbol newdef))
+  (let* ((olddef (advice--strip-macro
+                 (if (fboundp symbol) (symbol-function symbol))))
          (oldadv
           (cond
-             ((null (get symbol 'advice--pending))
-              (or olddef
-                  (progn
-                    (message "Delayed advice activation failed for %s: no data"
-                             symbol)
-                    nil)))
-             ((or (not olddef) (autoloadp olddef))
-              (prog1 (get symbol 'advice--pending)
-                (put symbol 'advice--pending nil)))
+          ((null (get symbol 'advice--pending))
+           (or olddef
+               (progn
+                 (message "Delayed advice activation failed for %s: no data"
+                          symbol)
+                 nil)))
+          ((or (not olddef) (autoloadp olddef))
+           (prog1 (get symbol 'advice--pending)
+             (put symbol 'advice--pending nil)))
            (t (message "Dropping left-over advice--pending for %s" symbol)
               (put symbol 'advice--pending nil)
               olddef))))
-    (funcall (or fsetfun #'fset) symbol (advice--subst-main oldadv newdef))))
+    (let* ((snewdef (advice--strip-macro newdef))
+          (snewadv (advice--subst-main oldadv snewdef)))
+      (funcall (or fsetfun #'fset) symbol
+              (if (eq snewdef newdef) snewadv (cons 'macro snewadv))))))
     
 
 ;;;###autoload
@@ -269,29 +295,18 @@
   ;;   simplest way is to make advice.el build one ad-Advice-foo function for
   ;;   each advised function which is advice-added/removed whenever ad-activate
   ;;   ad-deactivate is called.
-  (let ((f (and (fboundp symbol) (symbol-function symbol))))
-    (cond
-     ((special-form-p f)
-      ;; Not worth the trouble trying to handle this, I think.
-      (error "add-advice failure: %S is a special form" symbol))
-     ((and (symbolp f)
-           (eq 'macro (car-safe (ignore-errors (indirect-function f)))))
-      (let ((newval (cons 'macro (cdr (indirect-function f)))))
-        (put symbol 'advice--saved-rewrite (cons f newval))
-        (fset symbol newval)))
-     ;; `f' might be a pure (hence read-only) cons!
-     ((and (eq 'macro (car-safe f)) (not (ignore-errors (setcdr f (cdr f)) t)))
-      (fset symbol (cons 'macro (cdr f))))
-     ))
-  (let ((f (and (fboundp symbol) (symbol-function symbol))))
+  (let* ((f (and (fboundp symbol) (symbol-function symbol)))
+        (nf (advice--normalize symbol f)))
+    (unless (eq f nf) ;; Most importantly, if nf == nil!
+      (fset symbol nf))
     (add-function where (cond
-                         ((eq (car-safe f) 'macro) (cdr f))
+                         ((eq (car-safe nf) 'macro) (cdr nf))
                          ;; If the function is not yet defined, we can't yet
                          ;; install the advice.
                          ;; FIXME: If it's an autoloaded command, we also
                          ;; have a problem because we need to load the
                          ;; command to build the interactive-form.
-                         ((or (not f) (and (autoloadp f))) ;; (commandp f)
+                         ((or (not nf) (and (autoloadp nf))) ;; (commandp nf)
                           (get symbol 'advice--pending))
                          (t (symbol-function symbol)))
                   function props)
@@ -316,7 +331,7 @@
                        function)
       (unless (advice--p
                (if (eq (car-safe f) 'macro) (cdr f) (symbol-function symbol)))
-        ;; Not adviced any more.
+        ;; Not advised any more.
         (remove-function (get symbol 'defalias-fset-function)
                          #'advice--defalias-fset)
         (if (eq (symbol-function symbol)
@@ -335,13 +350,15 @@
 ;;       (setq def (advice--cdr def)))))
 
 ;;;###autoload
-(defun advice-member-p (function symbol)
-  "Return non-nil if advice FUNCTION has been added to function SYMBOL.
-Instead of FUNCTION being the actual function, it can also be the `name'
+(defun advice-member-p (advice function-name)
+  "Return non-nil if ADVICE has been added to FUNCTION-NAME.
+Instead of ADVICE being the actual function, it can also be the `name'
 of the piece of advice."
-  (advice--member-p function
-                    (or (get symbol 'advice--pending)
-                        (if (fboundp symbol) (symbol-function symbol)))))
+  (advice--member-p advice
+                    (or (get function-name 'advice--pending)
+                       (advice--strip-macro
+                        (if (fboundp function-name)
+                            (symbol-function function-name))))))
 
 
 (provide 'nadvice)

=== modified file 'lisp/subr.el'
--- a/lisp/subr.el      2012-11-12 20:43:43 +0000
+++ b/lisp/subr.el      2012-11-13 03:00:09 +0000
@@ -195,11 +195,6 @@
   (declare (indent 1) (debug t))
   (cons 'if (cons cond (cons nil body))))
 
-(if (null (featurep 'cl))
-    (progn
-  ;; If we reload subr.el after having loaded CL, be careful not to
-  ;; overwrite CL's extended definition of `dolist', `dotimes', `declare'.
-
 (defmacro dolist (spec &rest body)
   "Loop over a list.
 Evaluate BODY with VAR bound to each car from LIST, in turn.
@@ -279,7 +274,6 @@
 `defun-declarations-alist' and `macro-declarations-alist'."
   ;; FIXME: edebug spec should pay attention to defun-declarations-alist.
   nil)
-))
 
 (defmacro ignore-errors (&rest body)
   "Execute BODY; if an error occurs, return nil.

=== modified file 'test/automated/advice-tests.el'
--- a/test/automated/advice-tests.el    2012-11-12 20:43:43 +0000
+++ b/test/automated/advice-tests.el    2012-11-13 03:00:09 +0000
@@ -50,6 +50,13 @@
     ((ad-activate 'sm-test2)
      (sm-test2 6) 20)
     ((null (get 'sm-test2 'defalias-fset-function)) t)
+
+    ((advice-add 'sm-test3 :around
+                (lambda (f &rest args) `(toto ,(apply f args)))
+                '((name . wrap-with-toto)))
+     (defmacro sm-test3 (x) `(call-test3 ,x))
+     (macroexpand '(sm-test3 56)) (toto (call-test3 56)))
+
     ))
 
 (ert-deftest advice-tests ()