* lisp/subr.el (macrop): New function.
(text-clone--maintaining): New var. (text-clone--maintain): Rename from text-clone-maintain. Use it instead of inhibit-modification-hooks. * lisp/emacs-lisp/nadvice.el (advice--normalize): For aliases to macros, use a proxy, so as handle autoloads and redefinitions of the target. (advice--defalias-fset, advice-remove): Use advice--symbol-function. * lisp/emacs-lisp/pcase.el (pcase-mutually-exclusive-predicates): Remove bogus (arrayp . stringp) pair. Add entries for `vectorp'. (pcase--mutually-exclusive-p): New function. (pcase--split-consp): Use it. (pcase--split-pred): Use it. Optimize the case where `pat' is a qpat mutually exclusive with the current predicate. * test/automated/advice-tests.el (advice-tests-nadvice): Test removal before definition. (advice-tests-macroaliases): New test. * lisp/emacs-lisp/edebug.el (edebug-lookup-function): Remove function. (edebug-macrop): Remove. Use `macrop' instead. * lisp/emacs-lisp/advice.el (ad-subr-p): Remove. Use `subrp' instead. (ad-macro-p): * lisp/eshell/esh-cmd.el (eshell-macrop): * lisp/apropos.el (apropos-macrop): Remove. Use `macrop' instead.
This commit is contained in:
Stefan Monnier
parent
e443729d65
commit
671d5c1654
11 changed files with 106 additions and 90 deletions
|
|
@ -2140,14 +2140,6 @@ See Info node `(elisp)Computed Advice' for detailed documentation."
|
|||
"Take a macro function DEFINITION and make a lambda out of it."
|
||||
`(cdr ,definition))
|
||||
|
||||
(defmacro ad-subr-p (definition)
|
||||
;;"non-nil if DEFINITION is a subr."
|
||||
(list 'subrp definition))
|
||||
|
||||
(defmacro ad-macro-p (definition)
|
||||
;;"non-nil if DEFINITION is a macro."
|
||||
`(eq (car-safe ,definition) 'macro))
|
||||
|
||||
(defmacro ad-lambda-p (definition)
|
||||
;;"non-nil if DEFINITION is a lambda expression."
|
||||
`(eq (car-safe ,definition) 'lambda))
|
||||
|
|
@ -2160,12 +2152,12 @@ See Info node `(elisp)Computed Advice' for detailed documentation."
|
|||
(defmacro ad-compiled-p (definition)
|
||||
"Return non-nil if DEFINITION is a compiled byte-code object."
|
||||
`(or (byte-code-function-p ,definition)
|
||||
(and (ad-macro-p ,definition)
|
||||
(byte-code-function-p (ad-lambdafy ,definition)))))
|
||||
(and (macrop ,definition)
|
||||
(byte-code-function-p (ad-lambdafy ,definition)))))
|
||||
|
||||
(defmacro ad-compiled-code (compiled-definition)
|
||||
"Return the byte-code object of a COMPILED-DEFINITION."
|
||||
`(if (ad-macro-p ,compiled-definition)
|
||||
`(if (macrop ,compiled-definition)
|
||||
(ad-lambdafy ,compiled-definition)
|
||||
,compiled-definition))
|
||||
|
||||
|
|
@ -2173,7 +2165,7 @@ See Info node `(elisp)Computed Advice' for detailed documentation."
|
|||
"Return the lambda expression of a function/macro/advice DEFINITION."
|
||||
(cond ((ad-lambda-p definition)
|
||||
definition)
|
||||
((ad-macro-p definition)
|
||||
((macrop definition)
|
||||
(ad-lambdafy definition))
|
||||
((ad-advice-p definition)
|
||||
(cdr definition))
|
||||
|
|
@ -2183,7 +2175,7 @@ See Info node `(elisp)Computed Advice' for detailed documentation."
|
|||
"Return the argument list of DEFINITION."
|
||||
(require 'help-fns)
|
||||
(help-function-arglist
|
||||
(if (or (ad-macro-p definition) (ad-advice-p definition))
|
||||
(if (or (macrop definition) (ad-advice-p definition))
|
||||
(cdr definition)
|
||||
definition)
|
||||
'preserve-names))
|
||||
|
|
@ -2229,7 +2221,7 @@ definition (see the code for `documentation')."
|
|||
(defun ad-advised-definition-p (definition)
|
||||
"Return non-nil if DEFINITION was generated from advice information."
|
||||
(if (or (ad-lambda-p definition)
|
||||
(ad-macro-p definition)
|
||||
(macrop definition)
|
||||
(ad-compiled-p definition))
|
||||
(let ((docstring (ad-docstring definition)))
|
||||
(and (stringp docstring)
|
||||
|
|
@ -2242,8 +2234,8 @@ definition (see the code for `documentation')."
|
|||
;; representations, so cache entries preactivated with version
|
||||
;; 1 can't be used.
|
||||
(cond
|
||||
((ad-macro-p definition) 'macro2)
|
||||
((ad-subr-p definition) 'subr2)
|
||||
((macrop definition) 'macro2)
|
||||
((subrp definition) 'subr2)
|
||||
((or (ad-lambda-p definition) (ad-compiled-p definition)) 'fun2)
|
||||
((ad-advice-p definition) 'advice2))) ;; FIXME: Can this ever happen?
|
||||
|
||||
|
|
@ -2273,7 +2265,7 @@ For that it has to be fbound with a non-autoload definition."
|
|||
"True if FUNCTION has an interpreted definition that can be compiled."
|
||||
(and (ad-has-proper-definition function)
|
||||
(or (ad-lambda-p (symbol-function function))
|
||||
(ad-macro-p (symbol-function function)))
|
||||
(macrop (symbol-function function)))
|
||||
(not (ad-compiled-p (symbol-function function)))))
|
||||
|
||||
(defvar warning-suppress-types) ;From warnings.el.
|
||||
|
|
@ -2902,7 +2894,7 @@ If COMPILE is nil then the result depends on the value of
|
|||
((eq ad-default-compilation-action 'never) nil)
|
||||
((eq ad-default-compilation-action 'always) t)
|
||||
((eq ad-default-compilation-action 'like-original)
|
||||
(or (ad-subr-p (ad-get-orig-definition function))
|
||||
(or (subrp (ad-get-orig-definition function))
|
||||
(ad-compiled-p (ad-get-orig-definition function))))
|
||||
;; everything else means `maybe':
|
||||
(t (featurep 'byte-compile))))
|
||||
|
|
@ -3249,7 +3241,7 @@ usage: (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...)
|
|||
`((ad-set-cache
|
||||
',function
|
||||
;; the function will get compiled:
|
||||
,(cond ((ad-macro-p (car preactivation))
|
||||
,(cond ((macrop (car preactivation))
|
||||
`(ad-macrofy
|
||||
(function
|
||||
,(ad-lambdafy
|
||||
|
|
|
|||
|
|
@ -295,19 +295,6 @@ A lambda list keyword is a symbol that starts with `&'."
|
|||
(eq (selected-window)
|
||||
(next-window (next-window (selected-window))))))
|
||||
|
||||
(defsubst edebug-lookup-function (object)
|
||||
(while (and (symbolp object) (fboundp object))
|
||||
(setq object (symbol-function object)))
|
||||
object)
|
||||
|
||||
(defun edebug-macrop (object)
|
||||
"Return the macro named by OBJECT, or nil if it is not a macro."
|
||||
(setq object (edebug-lookup-function object))
|
||||
(if (and (listp object)
|
||||
(eq 'macro (car object))
|
||||
(functionp (cdr object)))
|
||||
object))
|
||||
|
||||
(defun edebug-sort-alist (alist function)
|
||||
;; Return the ALIST sorted with comparison function FUNCTION.
|
||||
;; This uses 'sort so the sorting is destructive.
|
||||
|
|
@ -1416,7 +1403,7 @@ expressions; a `progn' form will be returned enclosing these forms."
|
|||
; but leave it in for compatibility.
|
||||
))
|
||||
;; No edebug-form-spec provided.
|
||||
((edebug-macrop head)
|
||||
((macrop head)
|
||||
(if edebug-eval-macro-args
|
||||
(edebug-forms cursor)
|
||||
(edebug-sexps cursor)))
|
||||
|
|
|
|||
|
|
@ -314,9 +314,8 @@ of the piece of advice."
|
|||
((special-form-p def)
|
||||
;; Not worth the trouble trying to handle this, I think.
|
||||
(error "Advice impossible: %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)))))
|
||||
((and (symbolp def) (macrop def))
|
||||
(let ((newval `(macro . ,(lambda (&rest r) (macroexpand `(,def . ,r))))))
|
||||
(put symbol 'advice--saved-rewrite (cons def (cdr newval)))
|
||||
newval))
|
||||
;; `f' might be a pure (hence read-only) cons!
|
||||
|
|
@ -351,19 +350,7 @@ of the piece of advice."
|
|||
(when (get symbol 'advice--saved-rewrite)
|
||||
(put symbol 'advice--saved-rewrite nil))
|
||||
(setq newdef (advice--normalize symbol newdef))
|
||||
(let* ((olddef (advice--strip-macro (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))
|
||||
(get symbol 'advice--pending))
|
||||
(t (message "Dropping left-over advice--pending for %s" symbol)
|
||||
olddef))))
|
||||
(let ((oldadv (advice--symbol-function symbol)))
|
||||
(if (and newdef (not (autoloadp newdef)))
|
||||
(let* ((snewdef (advice--strip-macro newdef))
|
||||
(snewadv (advice--subst-main oldadv snewdef)))
|
||||
|
|
@ -383,7 +370,6 @@ is defined as a macro, alias, command, ..."
|
|||
;; TODO:
|
||||
;; - record the advice location, to display in describe-function.
|
||||
;; - change all defadvice in lisp/**/*.el.
|
||||
;; - rewrite advice.el on top of this.
|
||||
;; - obsolete advice.el.
|
||||
(let* ((f (symbol-function symbol))
|
||||
(nf (advice--normalize symbol f)))
|
||||
|
|
@ -420,8 +406,7 @@ of the piece of advice."
|
|||
((eq (car-safe f) 'macro) (cdr f))
|
||||
(t (symbol-function symbol)))
|
||||
function)
|
||||
(unless (advice--p
|
||||
(if (eq (car-safe f) 'macro) (cdr f) (symbol-function symbol)))
|
||||
(unless (advice--p (advice--symbol-function symbol))
|
||||
;; Not advised any more.
|
||||
(remove-function (get symbol 'defalias-fset-function)
|
||||
#'advice--defalias-fset)
|
||||
|
|
|
|||
|
|
@ -353,23 +353,34 @@ MATCH is the pattern that needs to be matched, of the form:
|
|||
(symbolp . numberp)
|
||||
(symbolp . consp)
|
||||
(symbolp . arrayp)
|
||||
(symbolp . vectorp)
|
||||
(symbolp . stringp)
|
||||
(symbolp . byte-code-function-p)
|
||||
(integerp . consp)
|
||||
(integerp . arrayp)
|
||||
(integerp . vectorp)
|
||||
(integerp . stringp)
|
||||
(integerp . byte-code-function-p)
|
||||
(numberp . consp)
|
||||
(numberp . arrayp)
|
||||
(numberp . vectorp)
|
||||
(numberp . stringp)
|
||||
(numberp . byte-code-function-p)
|
||||
(consp . arrayp)
|
||||
(consp . vectorp)
|
||||
(consp . stringp)
|
||||
(consp . byte-code-function-p)
|
||||
(arrayp . stringp)
|
||||
(arrayp . byte-code-function-p)
|
||||
(vectorp . byte-code-function-p)
|
||||
(stringp . vectorp)
|
||||
(stringp . byte-code-function-p)))
|
||||
|
||||
(defun pcase--mutually-exclusive-p (pred1 pred2)
|
||||
(or (member (cons pred1 pred2)
|
||||
pcase-mutually-exclusive-predicates)
|
||||
(member (cons pred2 pred1)
|
||||
pcase-mutually-exclusive-predicates)))
|
||||
|
||||
(defun pcase--split-match (sym splitter match)
|
||||
(cond
|
||||
((eq (car match) 'match)
|
||||
|
|
@ -433,10 +444,7 @@ MATCH is the pattern that needs to be matched, of the form:
|
|||
;; A QPattern but not for a cons, can only go to the `else' side.
|
||||
((eq (car-safe pat) '\`) '(:pcase--fail . nil))
|
||||
((and (eq (car-safe pat) 'pred)
|
||||
(or (member (cons 'consp (cadr pat))
|
||||
pcase-mutually-exclusive-predicates)
|
||||
(member (cons (cadr pat) 'consp)
|
||||
pcase-mutually-exclusive-predicates)))
|
||||
(pcase--mutually-exclusive-p #'consp (cadr pat)))
|
||||
'(:pcase--fail . nil))))
|
||||
|
||||
(defun pcase--split-equal (elem pat)
|
||||
|
|
@ -496,11 +504,14 @@ MATCH is the pattern that needs to be matched, of the form:
|
|||
(not (pcase--fgrep (mapcar #'car vars) (cadr upat)))))
|
||||
'(:pcase--succeed . :pcase--fail))
|
||||
((and (eq 'pred (car upat))
|
||||
(eq 'pred (car-safe pat))
|
||||
(or (member (cons (cadr upat) (cadr pat))
|
||||
pcase-mutually-exclusive-predicates)
|
||||
(member (cons (cadr pat) (cadr upat))
|
||||
pcase-mutually-exclusive-predicates)))
|
||||
(let ((otherpred
|
||||
(cond ((eq 'pred (car-safe pat)) (cadr pat))
|
||||
((not (eq '\` (car-safe pat))) nil)
|
||||
((consp (cadr pat)) #'consp)
|
||||
((vectorp (cadr pat)) #'vectorp)
|
||||
((byte-code-function-p (cadr pat))
|
||||
#'byte-code-function-p))))
|
||||
(pcase--mutually-exclusive-p (cadr upat) otherpred)))
|
||||
'(:pcase--fail . nil))
|
||||
((and (eq 'pred (car upat))
|
||||
(eq '\` (car-safe pat))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue