From: Stefan Monnier Date: Tue, 13 Nov 2012 03:00:09 +0000 (-0500) Subject: * lisp/emacs-lisp/cl.el (dolist, dotimes, declare): Use advice-add to X-Git-Tag: emacs-24.3.90~173^2~18^2~126 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=413d4689c0c3f616856615ac7b8bb047c5f2febd;p=emacs.git * 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. --- diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 6ab2880f09f..92f3343db64 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,19 @@ +2012-11-13 Stefan Monnier + + * 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 * emacs-lisp/gv.el (gv-define-simple-setter): One more fix (bug#12871). diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index bf99af2f7e6..eb58d17c02e 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -267,7 +267,7 @@ including `cl-block' and `cl-eval-when'. ;;;;;; 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" "\ diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index b28f8f7f9e9..3c46c40242d 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -1547,9 +1547,9 @@ An implicit nil block is established around the loop. \(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 @@ nil. \(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) diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index 016967bc713..40d12358b17 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -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 diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 020a2f89bdb..ca1ebf3cad2 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -230,23 +230,49 @@ of the piece of advice." (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 @@ is defined as a macro, alias, command, ..." ;; 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 @@ of the piece of advice." 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 @@ of the piece of advice." ;; (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) diff --git a/lisp/subr.el b/lisp/subr.el index ebfcfbc0930..b0ac2dd2106 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -195,11 +195,6 @@ value of last one, or nil if there are none. (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 @@ The possible values of SPECS are specified by `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. diff --git a/test/automated/advice-tests.el b/test/automated/advice-tests.el index cac10e9602f..9f9719fdcfc 100644 --- a/test/automated/advice-tests.el +++ b/test/automated/advice-tests.el @@ -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 ()