From 32e5c58ca969ec30d31520da52c9866cafa62927 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 9 Nov 2012 17:20:47 -0500 Subject: [PATCH] Provide new `defalias-fset-function' symbol property. * src/lisp.h (AUTOLOADP): New macro. * src/eval.c (Fautoload): Don't attach to loadhist, call Fdefalias instead. * src/data.c (Ffset): Remove special ad-advice-info handling. (Fdefalias): Handle autoload definitions and new Qdefalias_fset_function. (Fsubr_arity): CSE. (Finteractive_form): Simplify. (Fquo): Don't insist on having at least 2 arguments. (Qdefalias_fset_function): New var. * lisp/emacs-lisp/advice.el (ad-set-advice-info): Set defalias-fset-function. (ad--defalias-fset): New function. (ad-safe-fset): Remove. (ad-make-freeze-definition): Use cl-letf*. --- etc/NEWS | 3 + lisp/ChangeLog | 7 ++ lisp/emacs-lisp/advice.el | 150 +++++++++++++++++--------------------- src/ChangeLog | 13 +++- src/data.c | 71 +++++++++--------- src/eval.c | 21 ++---- src/lisp.h | 2 + 7 files changed, 134 insertions(+), 133 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 177f91066a..dd8ad72ba9 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -38,6 +38,9 @@ spurious warnings about an unused var. ** Docstrings can be made dynamic by adding a `dynamic-docstring-function' text-property on the first char. +** The `defalias-fset-function' property lets you catch calls to defalias +and redirect them to your own function instead of `fset'. + * Changes in Emacs 24.4 on non-free operating systems diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 6f10e311ea..a07749e4f1 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,10 @@ +2012-11-09 Stefan Monnier + + * emacs-lisp/advice.el (ad-set-advice-info): Set defalias-fset-function. + (ad--defalias-fset): New function. + (ad-safe-fset): Remove. + (ad-make-freeze-definition): Use cl-letf*. + 2012-11-09 Stefan Monnier * subr.el (dolist): Don't bind VAR in RESULT. diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 92becb8bea..42c25a4613 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -1846,8 +1846,12 @@ On each iteration VAR will be bound to the name of an advised function (defmacro ad-get-advice-info-macro (function) `(get ,function 'ad-advice-info)) -(defmacro ad-set-advice-info (function advice-info) - `(put ,function 'ad-advice-info ,advice-info)) +(defsubst ad-set-advice-info (function advice-info) + (cond + (advice-info (put function 'defalias-fset-function #'ad--defalias-fset)) + ((get function 'defalias-fset-function) + (put function 'defalias-fset-function nil))) + (put function 'ad-advice-info advice-info)) (defmacro ad-copy-advice-info (function) `(copy-tree (get ,function 'ad-advice-info))) @@ -1954,18 +1958,10 @@ Redefining advices affect the construction of an advised definition." ;; @@ Dealing with automatic advice activation via `fset/defalias': ;; ================================================================ -;; Since Emacs 19.26 the built-in versions of `fset' and `defalias' -;; take care of automatic advice activation, hence, we don't have to -;; hack it anymore by advising `fset/defun/defmacro/byte-code/etc'. +;; Automatic activation happens when a function gets defined via `defalias', +;; which calls the `defalias-fset-function' (which we set to +;; `ad--defalias-fset') instead of `fset', if non-nil. -;; The functionality of the new `fset' is as follows: -;; -;; fset(sym,newdef) -;; assign NEWDEF to SYM -;; if (get SYM 'ad-advice-info) -;; ad-activate-internal(SYM, nil) -;; return (symbol-function SYM) -;; ;; Whether advised definitions created by automatic activations will be ;; compiled depends on the value of `ad-default-compilation-action'. @@ -1977,6 +1973,10 @@ Redefining advices affect the construction of an advised definition." ;; to `ad-activate' by using `ad-with-auto-activation-disabled' where ;; appropriate, especially in a safe version of `fset'. +(defun ad--defalias-fset (function definition) + (fset function definition) + (ad-activate-internal function nil)) + ;; For now define `ad-activate-internal' to the dummy definition: (defun ad-activate-internal (_function &optional _compile) "Automatic advice activation is disabled. `ad-start-advice' enables it." @@ -1994,12 +1994,6 @@ Redefining advices affect the construction of an advised definition." `(let ((ad-activate-on-top-level nil)) ,@body)) -(defun ad-safe-fset (symbol definition) - "A safe `fset' which will never call `ad-activate-internal' recursively." - (ad-with-auto-activation-disabled - (fset symbol definition))) - - ;; @@ Access functions for original definitions: ;; ============================================ ;; The advice-info of an advised function contains its `origname' which is @@ -2019,8 +2013,7 @@ Redefining advices affect the construction of an advised definition." (symbol-function origname)))) (defmacro ad-set-orig-definition (function definition) - `(ad-safe-fset - (ad-get-advice-info-field ,function 'origname) ,definition)) + `(fset (ad-get-advice-info-field ,function 'origname) ,definition)) (defmacro ad-clear-orig-definition (function) `(fmakunbound (ad-get-advice-info-field ,function 'origname))) @@ -3151,7 +3144,7 @@ advised definition from scratch." (ad-set-advice-info function old-advice-info) ;; Don't `fset' function to nil if it was previously unbound: (if function-defined-p - (ad-safe-fset function old-definition) + (fset function old-definition) (fmakunbound function))))) @@ -3182,61 +3175,54 @@ advised definition from scratch." (error "ad-make-freeze-definition: `%s' is not yet defined" function)) - (let* ((name (ad-advice-name advice)) - ;; With a unique origname we can have multiple freeze advices - ;; for the same function, each overloading the previous one: - (unique-origname - (intern (format "%s-%s-%s" (ad-make-origname function) class name))) - (orig-definition - ;; If FUNCTION is already advised, we'll use its current origdef - ;; as the original definition of the frozen advice: - (or (ad-get-orig-definition function) - (symbol-function function))) - (old-advice-info - (if (ad-is-advised function) - (ad-copy-advice-info function))) - (real-docstring-fn - (symbol-function 'ad-make-advised-definition-docstring)) - (real-origname-fn - (symbol-function 'ad-make-origname)) - (frozen-definition - (unwind-protect - (progn - ;; Make sure we construct a proper docstring: - (ad-safe-fset 'ad-make-advised-definition-docstring - 'ad-make-freeze-docstring) - ;; Make sure `unique-origname' is used as the origname: - (ad-safe-fset 'ad-make-origname (lambda (_x) unique-origname)) - ;; No we reset all current advice information to nil and - ;; generate an advised definition that's solely determined - ;; by ADVICE and the current origdef of FUNCTION: - (ad-set-advice-info function nil) - (ad-add-advice function advice class position) - ;; The following will provide proper real docstrings as - ;; well as a definition that will make the compiler happy: - (ad-set-orig-definition function orig-definition) - (ad-make-advised-definition function)) - ;; Restore the old advice state: - (ad-set-advice-info function old-advice-info) - ;; Restore functions: - (ad-safe-fset - 'ad-make-advised-definition-docstring real-docstring-fn) - (ad-safe-fset 'ad-make-origname real-origname-fn)))) + (cl-letf* + ((name (ad-advice-name advice)) + ;; With a unique origname we can have multiple freeze advices + ;; for the same function, each overloading the previous one: + (unique-origname + (intern (format "%s-%s-%s" (ad-make-origname function) class name))) + (orig-definition + ;; If FUNCTION is already advised, we'll use its current origdef + ;; as the original definition of the frozen advice: + (or (ad-get-orig-definition function) + (symbol-function function))) + (old-advice-info + (if (ad-is-advised function) + (ad-copy-advice-info function))) + ;; Make sure we construct a proper docstring: + ((symbol-function 'ad-make-advised-definition-docstring) + #'ad-make-freeze-docstring) + ;; Make sure `unique-origname' is used as the origname: + ((symbol-function 'ad-make-origname) (lambda (_x) unique-origname)) + (frozen-definition + (unwind-protect + (progn + ;; No we reset all current advice information to nil and + ;; generate an advised definition that's solely determined + ;; by ADVICE and the current origdef of FUNCTION: + (ad-set-advice-info function nil) + (ad-add-advice function advice class position) + ;; The following will provide proper real docstrings as + ;; well as a definition that will make the compiler happy: + (ad-set-orig-definition function orig-definition) + (ad-make-advised-definition function)) + ;; Restore the old advice state: + (ad-set-advice-info function old-advice-info)))) (if frozen-definition (let* ((macro-p (ad-macro-p frozen-definition)) (body (cdr (if macro-p (ad-lambdafy frozen-definition) - frozen-definition)))) + frozen-definition)))) `(progn - (if (not (fboundp ',unique-origname)) - (fset ',unique-origname - ;; avoid infinite recursion in case the function - ;; we want to freeze is already advised: - (or (ad-get-orig-definition ',function) - (symbol-function ',function)))) - (,(if macro-p 'defmacro 'defun) - ,function - ,@body)))))) + (if (not (fboundp ',unique-origname)) + (fset ',unique-origname + ;; avoid infinite recursion in case the function + ;; we want to freeze is already advised: + (or (ad-get-orig-definition ',function) + (symbol-function ',function)))) + (,(if macro-p 'defmacro 'defun) + ,function + ,@body)))))) ;; @@ Activation and definition handling: @@ -3269,7 +3255,7 @@ The current definition and its cache-id will be put into the cache." (let ((verified-cached-definition (if (ad-verify-cache-id function) (ad-get-cache-definition function)))) - (ad-safe-fset function + (fset function (or verified-cached-definition (ad-make-advised-definition function))) (if (ad-should-compile function compile) @@ -3311,7 +3297,7 @@ the value of `ad-redefinition-action' and de/activate again." (error "ad-handle-definition (see its doc): `%s' %s" function "invalidly redefined") (if (eq ad-redefinition-action 'discard) - (ad-safe-fset function original-definition) + (fset function original-definition) (ad-set-orig-definition function current-definition) (if (eq ad-redefinition-action 'warn) (message "ad-handle-definition: `%s' got redefined" @@ -3386,7 +3372,7 @@ a call to `ad-activate'." (if (not (ad-get-orig-definition function)) (error "ad-deactivate: `%s' has no original definition" function) - (ad-safe-fset function (ad-get-orig-definition function)) + (fset function (ad-get-orig-definition function)) (ad-set-advice-info-field function 'active nil) (eval (ad-make-hook-form function 'deactivation)) function))))) @@ -3424,7 +3410,7 @@ Use in emergencies." (completing-read "Recover advised function: " obarray nil t)))) (cond ((ad-is-advised function) (cond ((ad-get-orig-definition function) - (ad-safe-fset function (ad-get-orig-definition function)) + (fset function (ad-get-orig-definition function)) (ad-clear-orig-definition function))) (ad-set-advice-info function nil) (ad-pop-advised-function function)))) @@ -3658,8 +3644,7 @@ undone on exit of this macro." (setq index -1) (mapcar (lambda (function) (setq index (1+ index)) - `(ad-safe-fset - ',function + `(fset ',function (or (ad-get-orig-definition ',function) ,(car (nth index current-bindings))))) functions)) @@ -3670,8 +3655,7 @@ undone on exit of this macro." (setq index -1) (mapcar (lambda (function) (setq index (1+ index)) - `(ad-safe-fset - ',function + `(fset ',function ,(car (nth index current-bindings)))) functions)))))) @@ -3684,7 +3668,7 @@ undone on exit of this macro." (interactive) ;; Advising `ad-activate-internal' means death!! (ad-set-advice-info 'ad-activate-internal nil) - (ad-safe-fset 'ad-activate-internal 'ad-activate)) + (fset 'ad-activate-internal 'ad-activate)) (defun ad-stop-advice () "Stop the automatic advice handling magic. @@ -3692,7 +3676,7 @@ You should only need this in case of Advice-related emergencies." (interactive) ;; Advising `ad-activate-internal' means death!! (ad-set-advice-info 'ad-activate-internal nil) - (ad-safe-fset 'ad-activate-internal 'ad-activate-internal-off)) + (fset 'ad-activate-internal 'ad-activate-internal-off)) (defun ad-recover-normality () "Undo all advice related redefinitions and unadvises everything. @@ -3700,7 +3684,7 @@ Use only in REAL emergencies." (interactive) ;; Advising `ad-activate-internal' means death!! (ad-set-advice-info 'ad-activate-internal nil) - (ad-safe-fset 'ad-activate-internal 'ad-activate-internal-off) + (fset 'ad-activate-internal 'ad-activate-internal-off) (ad-recover-all) (ad-do-advised-functions (function) (message "Oops! Left over advised function %S" function) diff --git a/src/ChangeLog b/src/ChangeLog index 43d60936d7..da3e96bbcc 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,14 @@ +2012-11-09 Stefan Monnier + + * lisp.h (AUTOLOADP): New macro. + * eval.c (Fautoload): Don't attach to loadhist, call Fdefalias instead. + * data.c (Ffset): Remove special ad-advice-info handling. + (Fdefalias): Handle autoload definitions and new Qdefalias_fset_function. + (Fsubr_arity): CSE. + (Finteractive_form): Simplify. + (Fquo): Don't insist on having at least 2 arguments. + (Qdefalias_fset_function): New var. + 2012-11-09 Jan Djärv * image.c (xpm_make_color_table_h): Change to hashtest_equal. @@ -26,7 +37,7 @@ 2012-11-09 Jan Djärv - * nsfont.m (ns_descriptor_to_entity): Qcondesed and Qexpanded has + * nsfont.m (ns_descriptor_to_entity): Qcondensed and Qexpanded has been removed, so remove them here also. 2012-11-09 Stefan Monnier diff --git a/src/data.c b/src/data.c index abcdd4dca0..663e25e706 100644 --- a/src/data.c +++ b/src/data.c @@ -80,7 +80,7 @@ static Lisp_Object Qsubrp, Qmany, Qunevalled; Lisp_Object Qfont_spec, Qfont_entity, Qfont_object; static Lisp_Object Qdefun; -Lisp_Object Qinteractive_form; +Lisp_Object Qinteractive_form, Qdefalias_fset_function; static void swap_in_symval_forwarding (struct Lisp_Symbol *, struct Lisp_Buffer_Local_Value *); @@ -444,7 +444,7 @@ DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0, } -/* Extract and set components of lists */ +/* Extract and set components of lists. */ DEFUN ("car", Fcar, Scar, 1, 1, 0, doc: /* Return the car of LIST. If arg is nil, return nil. @@ -608,27 +608,18 @@ DEFUN ("fset", Ffset, Sfset, 2, 2, 0, (register Lisp_Object symbol, Lisp_Object definition) { register Lisp_Object function; - CHECK_SYMBOL (symbol); - if (NILP (symbol) || EQ (symbol, Qt)) - xsignal1 (Qsetting_constant, symbol); function = XSYMBOL (symbol)->function; if (!NILP (Vautoload_queue) && !EQ (function, Qunbound)) Vautoload_queue = Fcons (Fcons (symbol, function), Vautoload_queue); - if (CONSP (function) && EQ (XCAR (function), Qautoload)) + if (AUTOLOADP (function)) Fput (symbol, Qautoload, XCDR (function)); set_symbol_function (symbol, definition); - /* Handle automatic advice activation. */ - if (CONSP (XSYMBOL (symbol)->plist) - && !NILP (Fget (symbol, Qad_advice_info))) - { - call2 (Qad_activate_internal, symbol, Qnil); - definition = XSYMBOL (symbol)->function; - } + return definition; } @@ -642,15 +633,32 @@ The return value is undefined. */) (register Lisp_Object symbol, Lisp_Object definition, Lisp_Object docstring) { CHECK_SYMBOL (symbol); - if (CONSP (XSYMBOL (symbol)->function) - && EQ (XCAR (XSYMBOL (symbol)->function), Qautoload)) - LOADHIST_ATTACH (Fcons (Qt, symbol)); if (!NILP (Vpurify_flag) /* If `definition' is a keymap, immutable (and copying) is wrong. */ && !KEYMAPP (definition)) definition = Fpurecopy (definition); - definition = Ffset (symbol, definition); - LOADHIST_ATTACH (Fcons (Qdefun, symbol)); + + { + bool autoload = AUTOLOADP (definition); + if (NILP (Vpurify_flag) || !autoload) + { /* Only add autoload entries after dumping, because the ones before are + not useful and else we get loads of them from the loaddefs.el. */ + + if (AUTOLOADP (XSYMBOL (symbol)->function)) + /* Remember that the function was already an autoload. */ + LOADHIST_ATTACH (Fcons (Qt, symbol)); + LOADHIST_ATTACH (Fcons (autoload ? Qautoload : Qdefun, symbol)); + } + } + + { /* Handle automatic advice activation. */ + Lisp_Object hook = Fget (symbol, Qdefalias_fset_function); + if (!NILP (hook)) + call2 (hook, symbol, definition); + else + Ffset (symbol, definition); + } + if (!NILP (docstring)) Fput (symbol, Qfunction_documentation, docstring); /* We used to return `definition', but now that `defun' and `defmacro' expand @@ -680,12 +688,10 @@ function with `&rest' args, or `unevalled' for a special form. */) CHECK_SUBR (subr); minargs = XSUBR (subr)->min_args; maxargs = XSUBR (subr)->max_args; - if (maxargs == MANY) - return Fcons (make_number (minargs), Qmany); - else if (maxargs == UNEVALLED) - return Fcons (make_number (minargs), Qunevalled); - else - return Fcons (make_number (minargs), make_number (maxargs)); + return Fcons (make_number (minargs), + maxargs == MANY ? Qmany + : maxargs == UNEVALLED ? Qunevalled + : make_number (maxargs)); } DEFUN ("subr-name", Fsubr_name, Ssubr_name, 1, 1, 0, @@ -711,7 +717,7 @@ Value, if non-nil, is a list \(interactive SPEC). */) return Qnil; /* Use an `interactive-form' property if present, analogous to the - function-documentation property. */ + function-documentation property. */ fun = cmd; while (SYMBOLP (fun)) { @@ -735,6 +741,8 @@ Value, if non-nil, is a list \(interactive SPEC). */) if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) > COMPILED_INTERACTIVE) return list2 (Qinteractive, AREF (fun, COMPILED_INTERACTIVE)); } + else if (AUTOLOADP (fun)) + return Finteractive_form (Fautoload_do_load (fun, cmd, Qnil)); else if (CONSP (fun)) { Lisp_Object funcar = XCAR (fun); @@ -742,14 +750,6 @@ Value, if non-nil, is a list \(interactive SPEC). */) return Fassq (Qinteractive, Fcdr (Fcdr (XCDR (fun)))); else if (EQ (funcar, Qlambda)) return Fassq (Qinteractive, Fcdr (XCDR (fun))); - else if (EQ (funcar, Qautoload)) - { - struct gcpro gcpro1; - GCPRO1 (cmd); - Fautoload_do_load (fun, cmd, Qnil); - UNGCPRO; - return Finteractive_form (cmd); - } } return Qnil; } @@ -2695,10 +2695,10 @@ usage: (* &rest NUMBERS-OR-MARKERS) */) return arith_driver (Amult, nargs, args); } -DEFUN ("/", Fquo, Squo, 2, MANY, 0, +DEFUN ("/", Fquo, Squo, 1, MANY, 0, doc: /* Return first argument divided by all the remaining arguments. The arguments must be numbers or markers. -usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */) +usage: (/ DIVIDEND &rest DIVISORS) */) (ptrdiff_t nargs, Lisp_Object *args) { ptrdiff_t argnum; @@ -3063,6 +3063,7 @@ syms_of_data (void) DEFSYM (Qfont_object, "font-object"); DEFSYM (Qinteractive_form, "interactive-form"); + DEFSYM (Qdefalias_fset_function, "defalias-fset-function"); defsubr (&Sindirect_variable); defsubr (&Sinteractive_form); diff --git a/src/eval.c b/src/eval.c index 975204da01..dcd48cb725 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1876,26 +1876,19 @@ this does nothing and returns nil. */) CHECK_STRING (file); /* If function is defined and not as an autoload, don't override. */ - if ((CONSP (XSYMBOL (function)->function) - && EQ (XCAR (XSYMBOL (function)->function), Qautoload))) - /* Remember that the function was already an autoload. */ - LOADHIST_ATTACH (Fcons (Qt, function)); - else if (!EQ (XSYMBOL (function)->function, Qunbound)) + if (!EQ (XSYMBOL (function)->function, Qunbound) + && !AUTOLOADP (XSYMBOL (function)->function)) return Qnil; - if (NILP (Vpurify_flag)) - /* Only add entries after dumping, because the ones before are - not useful and else we get loads of them from the loaddefs.el. */ - LOADHIST_ATTACH (Fcons (Qautoload, function)); - else if (EQ (docstring, make_number (0))) + if (!NILP (Vpurify_flag) && EQ (docstring, make_number (0))) /* `read1' in lread.c has found the docstring starting with "\ and assumed the docstring will be provided by Snarf-documentation, so it passed us 0 instead. But that leads to accidental sharing in purecopy's hash-consing, so we use a (hopefully) unique integer instead. */ - docstring = make_number (XUNTAG (function, Lisp_Symbol)); - return Ffset (function, - Fpurecopy (list5 (Qautoload, file, docstring, - interactive, type))); + docstring = make_number (XHASH (function)); + return Fdefalias (function, + list5 (Qautoload, file, docstring, interactive, type), + Qnil); } Lisp_Object diff --git a/src/lisp.h b/src/lisp.h index e2c1cc0e16..72e38fa465 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -1694,6 +1694,8 @@ typedef struct { #define MARKERP(x) (MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Marker) #define SAVE_VALUEP(x) (MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Save_Value) +#define AUTOLOADP(x) (CONSP (x) && EQ (Qautoload, XCAR (x))) + #define INTFWDP(x) (XFWDTYPE (x) == Lisp_Fwd_Int) #define BOOLFWDP(x) (XFWDTYPE (x) == Lisp_Fwd_Bool) #define OBJFWDP(x) (XFWDTYPE (x) == Lisp_Fwd_Obj) -- 2.20.1