From 671d5c16547d16bef2efa056705bd35b5feacc29 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sun, 4 Aug 2013 16:18:11 -0400 Subject: [PATCH] * 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. --- etc/NEWS | 2 +- lisp/ChangeLog | 25 +++++++++++++++++++++++++ lisp/apropos.el | 13 +------------ lisp/emacs-lisp/advice.el | 30 +++++++++++------------------- lisp/emacs-lisp/edebug.el | 15 +-------------- lisp/emacs-lisp/nadvice.el | 23 ++++------------------- lisp/emacs-lisp/pcase.el | 31 +++++++++++++++++++++---------- lisp/eshell/esh-cmd.el | 10 +--------- lisp/subr.el | 24 ++++++++++++++++++------ test/ChangeLog | 6 ++++++ test/automated/advice-tests.el | 17 +++++++++++++++++ 11 files changed, 106 insertions(+), 90 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 60a846b459..507cd04aa1 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -691,7 +691,7 @@ These attributes are only meaningful for coding-systems of type with the same interpretation as the returned value of `visited-file-modtime'. ** time-to-seconds is not obsolete any more. -** New function special-form-p. +** New functions special-form-p and macrop. ** Docstrings can be made dynamic by adding a `dynamic-docstring-function' text-property on the first char. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index dc1fa09b31..66bf7422b0 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,28 @@ +2013-08-04 Stefan Monnier + + * 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. + + * 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. + + * 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. + + * emacs-lisp/edebug.el (edebug-lookup-function): Remove function. + (edebug-macrop): Remove. Use `macrop' instead. + * emacs-lisp/advice.el (ad-subr-p): Remove. Use `subrp' instead. + (ad-macro-p): + * eshell/esh-cmd.el (eshell-macrop): + * apropos.el (apropos-macrop): Remove. Use `macrop' instead. + 2013-08-04 Stefan Monnier * emacs-lisp/nadvice.el (advice-function-mapc): Rename from advice-mapc. diff --git a/lisp/apropos.el b/lisp/apropos.el index 000d2d87d0..7a1a6f6a75 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -1121,7 +1121,7 @@ If non-nil TEXT is a string that will be printed as a heading." (apropos-print-doc 2 (if (commandp symbol) 'apropos-command - (if (apropos-macrop symbol) + (if (macrop symbol) 'apropos-macro 'apropos-function)) (not nosubst)) @@ -1139,17 +1139,6 @@ If non-nil TEXT is a string that will be printed as a heading." (prog1 apropos-accumulator (setq apropos-accumulator ()))) ; permit gc -(defun apropos-macrop (symbol) - "Return t if SYMBOL is a Lisp macro." - (and (fboundp symbol) - (consp (setq symbol - (symbol-function symbol))) - (or (eq (car symbol) 'macro) - (if (autoloadp symbol) - (memq (nth 4 symbol) - '(macro t)))))) - - (defun apropos-print-doc (i type do-keys) (let ((doc (nth i apropos-item))) (when (stringp doc) diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index eb1d63e788..861054e777 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -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 diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index ae20e5270e..ac7e5f12a1 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -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))) diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 660eb0365a..576e72088e 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -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) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 50c92518b0..eb2c7f002e 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -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)) diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el index 69dc6c76b4..ef8a53f3c0 100644 --- a/lisp/eshell/esh-cmd.el +++ b/lisp/eshell/esh-cmd.el @@ -993,14 +993,6 @@ at the moment are: ,@commands (eshell-debug-command ,(concat "done " (eval tag)) form)))) -(defsubst eshell-macrop (object) - "Return t if OBJECT is a macro or nil otherwise." - (and (symbolp object) (fboundp object) - (setq object (indirect-function object)) - (listp object) - (eq 'macro (car object)) - (functionp (cdr object)))) - (defun eshell-do-eval (form &optional synchronous-p) "Evaluate form, simplifying it as we go. Unless SYNCHRONOUS-P is non-nil, throws `eshell-defer' if it needs to @@ -1016,7 +1008,7 @@ be finished later after the completion of an asynchronous subprocess." (setq form (cadr (cadr form)))) ;; expand any macros directly into the form. This is done so that ;; we can modify any `let' forms to evaluate only once. - (if (eshell-macrop (car form)) + (if (macrop (car form)) (let ((exp (eshell-copy-tree (macroexpand form)))) (eshell-manipulate (format "expanding macro `%s'" (symbol-name (car form))) diff --git a/lisp/subr.el b/lisp/subr.el index 3b85a9bedb..bdeee67747 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -2750,6 +2750,13 @@ Otherwise, return nil." (setq object (indirect-function object t))) (and (subrp object) (eq (cdr (subr-arity object)) 'unevalled))) +(defun macrop (object) + "Non-nil if and only if OBJECT is a macro." + (let ((def (indirect-function object t))) + (when (consp def) + (or (eq 'macro (car def)) + (and (eq 'autoload (car def)) (memq (nth 4 def) '(macro t))))))) + (defun field-at-pos (pos) "Return the field at position POS, taking stickiness etc into account." (let ((raw-field (get-char-property (field-beginning pos) 'field))) @@ -4050,10 +4057,14 @@ backwards ARG times if negative." ;;;; Text clones -(defun text-clone-maintain (ol1 after beg end &optional _len) +(defvar text-clone--maintaining nil) + +(defun text-clone--maintain (ol1 after beg end &optional _len) "Propagate the changes made under the overlay OL1 to the other clones. This is used on the `modification-hooks' property of text clones." - (when (and after (not undo-in-progress) (overlay-start ol1)) + (when (and after (not undo-in-progress) + (not text-clone--maintaining) + (overlay-start ol1)) (let ((margin (if (overlay-get ol1 'text-clone-spreadp) 1 0))) (setq beg (max beg (+ (overlay-start ol1) margin))) (setq end (min end (- (overlay-end ol1) margin))) @@ -4084,7 +4095,7 @@ This is used on the `modification-hooks' property of text clones." (tail (- (overlay-end ol1) end)) (str (buffer-substring beg end)) (nothing-left t) - (inhibit-modification-hooks t)) + (text-clone--maintaining t)) (dolist (ol2 (overlay-get ol1 'text-clones)) (let ((oe (overlay-end ol2))) (unless (or (eq ol1 ol2) (null oe)) @@ -4095,7 +4106,7 @@ This is used on the `modification-hooks' property of text clones." (unless (> mod-beg (point)) (save-excursion (insert str)) (delete-region mod-beg (point))) - ;;(overlay-put ol2 'modification-hooks '(text-clone-maintain)) + ;;(overlay-put ol2 'modification-hooks '(text-clone--maintain)) )))) (if nothing-left (delete-overlay ol1)))))))) @@ -4126,17 +4137,18 @@ clone should be incorporated in the clone." (>= pt-end (point-max)) (>= start (point-max))) 0 1)) + ;; FIXME: Reuse overlays at point to extend dups! (ol1 (make-overlay (- start start-margin) (+ end end-margin) nil t)) (ol2 (make-overlay (- (point) start-margin) (+ pt-end end-margin) nil t)) (dups (list ol1 ol2))) - (overlay-put ol1 'modification-hooks '(text-clone-maintain)) + (overlay-put ol1 'modification-hooks '(text-clone--maintain)) (when spreadp (overlay-put ol1 'text-clone-spreadp t)) (when syntax (overlay-put ol1 'text-clone-syntax syntax)) ;;(overlay-put ol1 'face 'underline) (overlay-put ol1 'evaporate t) (overlay-put ol1 'text-clones dups) ;; - (overlay-put ol2 'modification-hooks '(text-clone-maintain)) + (overlay-put ol2 'modification-hooks '(text-clone--maintain)) (when spreadp (overlay-put ol2 'text-clone-spreadp t)) (when syntax (overlay-put ol2 'text-clone-syntax syntax)) ;;(overlay-put ol2 'face 'underline) diff --git a/test/ChangeLog b/test/ChangeLog index 32fc077459..d744a5c788 100644 --- a/test/ChangeLog +++ b/test/ChangeLog @@ -1,3 +1,9 @@ +2013-08-04 Stefan Monnier + + * automated/advice-tests.el (advice-tests-nadvice): Test removal + before definition. + (advice-tests-macroaliases): New test. + 2013-08-04 Glenn Morris * automated/ert-tests.el: Disable failing test that no-one seems diff --git a/test/automated/advice-tests.el b/test/automated/advice-tests.el index 69c15e34ed..424f447ae4 100644 --- a/test/automated/advice-tests.el +++ b/test/automated/advice-tests.el @@ -25,7 +25,12 @@ (ert-deftest advice-tests-nadvice () "Test nadvice code." + (advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 5))) + (advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 2))) + (advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 5))) (defun sm-test1 (x) (+ x 4)) + (should (equal (sm-test1 6) 20)) + (advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 2))) (should (equal (sm-test1 6) 10)) (advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 5))) (should (equal (sm-test1 6) 50)) @@ -42,6 +47,18 @@ (defmacro sm-test3 (x) `(call-test3 ,x)) (should (equal (macroexpand '(sm-test3 56)) '(toto (call-test3 56))))) +(ert-deftest advice-tests-macroaliases () + "Test nadvice code on aliases to macros." + (defmacro sm-test1 (a) `(list ',a)) + (defalias 'sm-test1-alias 'sm-test1) + (should (equal (macroexpand '(sm-test1-alias 5)) '(list '5))) + (advice-add 'sm-test1-alias :around + (lambda (f &rest args) `(cons 1 ,(apply f args)))) + (should (equal (macroexpand '(sm-test1-alias 5)) '(cons 1 (list '5)))) + (defmacro sm-test1 (a) `(list 0 ',a)) + (should (equal (macroexpand '(sm-test1-alias 5)) '(cons 1 (list 0 '5))))) + + (ert-deftest advice-tests-advice () "Test advice code." (defun sm-test2 (x) (+ x 4)) -- 2.20.1