Commit 32e5c58c authored by Stefan Monnier's avatar Stefan Monnier
Browse files

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*.
parent da03ef8a
......@@ -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
......
2012-11-09 Stefan Monnier <monnier@iro.umontreal.ca>
* 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 <monnier@iro.umontreal.ca>
* subr.el (dolist): Don't bind VAR in RESULT.
......
......@@ -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)
......
2012-11-09 Stefan Monnier <monnier@iro.umontreal.ca>
* 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 <jan.h.d@swipnet.se>
* image.c (xpm_make_color_table_h): Change to hashtest_equal.
......@@ -26,7 +37,7 @@
2012-11-09 Jan Djärv <jan.h.d@swipnet.se>
* 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 <monnier@iro.umontreal.ca>
......
......@@ -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);
......
......@@ -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
......
......@@ -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)
......
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