Commit 413d4689 authored by Stefan Monnier's avatar Stefan Monnier
Browse files

* 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.
parent f78ee6af
2012-11-13 Stefan Monnier <monnier@iro.umontreal.ca>
* 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 <monnier@iro.umontreal.ca>
 
* emacs-lisp/gv.el (gv-define-simple-setter): One more fix (bug#12871).
......
......@@ -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" "\
......
......@@ -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)
......
......@@ -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
......
......@@ -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)
......
......@@ -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.
......
......@@ -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 ()
......
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