>From 0507854b885681c2e57bb1c6cb97f898417bd99c Mon Sep 17 00:00:00 2001 From: Noam Postavsky Date: Thu, 19 Nov 2015 19:50:06 -0500 Subject: [PATCH v4 1/5] Add lisp watchpoints This allows to call a function whenever a symbol-value is changed. * src/lisp.h (lisp_h_SYMBOL_TRAPPED_WRITE_P): Rename from lisp_h_SYMBOL_CONSTANT_P. (SYMBOL_TRAPPED_WRITE_P): Rename from SYMBOL_CONSTANT_P. (enum symbol_trapped_write): New enumeration. (struct Lisp_Symbol): Rename field constant to trapped_write. (make_symbol_constant): New function. * src/data.c (Fadd_variable_watcher, Fremove_variable_watcher): (set_symbol_trapped_write, reset_symbol_trapped_write): (harmonize_variable_watchers, notify_variable_watchers): New functions. * src/data.c (Fset_default): Call `notify_variable_watchers' for trapped symbols. (set_internal): Change bool argument BIND to 3-value enum and call `notify_variable_watchers' for trapped symbols. * src/data.c (syms_of_data): * src/data.c (syms_of_data): * src/font.c (syms_of_font): * src/lread.c (intern_sym, init_obarray): * src/buffer.c (syms_of_buffer): Use make_symbol_constant. * src/alloc.c (init_symbol): * src/bytecode.c (exec_byte_code): Use SYMBOL_TRAPPED_WRITE_P. * src/data.c (Fmake_variable_buffer_local, Fmake_local_variable): (Fmake_variable_frame_local): * src/eval.c (Fdefvaralias, specbind): Refer to Lisp_Symbol's trapped_write instead of constant. (Ffuncall): Move subr calling code into separate function. (funcall_subr): New function. --- src/alloc.c | 2 +- src/buffer.c | 82 +++++++++++++---------- src/bytecode.c | 4 +- src/data.c | 192 +++++++++++++++++++++++++++++++++++++++++++++++------- src/eval.c | 202 ++++++++++++++++++++++++++++++--------------------------- src/font.c | 6 +- src/lisp.h | 47 ++++++++++---- src/lread.c | 6 +- 8 files changed, 365 insertions(+), 176 deletions(-) diff --git a/src/alloc.c b/src/alloc.c index a58dc13..f373f6d 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3562,7 +3562,7 @@ init_symbol (Lisp_Object val, Lisp_Object name) set_symbol_next (val, NULL); p->gcmarkbit = false; p->interned = SYMBOL_UNINTERNED; - p->constant = 0; + p->trapped_write = SYMBOL_UNTRAPPED_WRITE; p->declared_special = false; p->pinned = false; } diff --git a/src/buffer.c b/src/buffer.c index 3d205bb..cc75cdb 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -984,40 +984,54 @@ reset_buffer_local_variables (struct buffer *b, bool permanent_too) bset_local_var_alist (b, Qnil); else { - Lisp_Object tmp, prop, last = Qnil; + Lisp_Object tmp, last = Qnil; for (tmp = BVAR (b, local_var_alist); CONSP (tmp); tmp = XCDR (tmp)) - if (!NILP (prop = Fget (XCAR (XCAR (tmp)), Qpermanent_local))) - { - /* If permanent-local, keep it. */ - last = tmp; - if (EQ (prop, Qpermanent_local_hook)) - { - /* This is a partially permanent hook variable. - Preserve only the elements that want to be preserved. */ - Lisp_Object list, newlist; - list = XCDR (XCAR (tmp)); - if (!CONSP (list)) - newlist = list; - else - for (newlist = Qnil; CONSP (list); list = XCDR (list)) - { - Lisp_Object elt = XCAR (list); - /* Preserve element ELT if it's t, - if it is a function with a `permanent-local-hook' property, - or if it's not a symbol. */ - if (! SYMBOLP (elt) - || EQ (elt, Qt) - || !NILP (Fget (elt, Qpermanent_local_hook))) - newlist = Fcons (elt, newlist); - } - XSETCDR (XCAR (tmp), Fnreverse (newlist)); - } - } - /* Delete this local variable. */ - else if (NILP (last)) - bset_local_var_alist (b, XCDR (tmp)); - else - XSETCDR (last, XCDR (tmp)); + { + Lisp_Object local_var = XCAR (XCAR (tmp)); + Lisp_Object prop = Fget (local_var, Qpermanent_local); + + if (!NILP (prop)) + { + /* If permanent-local, keep it. */ + last = tmp; + if (EQ (prop, Qpermanent_local_hook)) + { + /* This is a partially permanent hook variable. + Preserve only the elements that want to be preserved. */ + Lisp_Object list, newlist; + list = XCDR (XCAR (tmp)); + if (!CONSP (list)) + newlist = list; + else + for (newlist = Qnil; CONSP (list); list = XCDR (list)) + { + Lisp_Object elt = XCAR (list); + /* Preserve element ELT if it's t, + if it is a function with a `permanent-local-hook' property, + or if it's not a symbol. */ + if (! SYMBOLP (elt) + || EQ (elt, Qt) + || !NILP (Fget (elt, Qpermanent_local_hook))) + newlist = Fcons (elt, newlist); + } + newlist = Fnreverse (newlist); + if (XSYMBOL (local_var)->trapped_write == SYMBOL_TRAPPED_WRITE) + notify_variable_watchers (local_var, newlist, + Qmakunbound, Fcurrent_buffer ()); + XSETCDR (XCAR (tmp), newlist); + continue; /* Don't do variable write trapping twice. */ + } + } + /* Delete this local variable. */ + else if (NILP (last)) + bset_local_var_alist (b, XCDR (tmp)); + else + XSETCDR (last, XCDR (tmp)); + + if (XSYMBOL (local_var)->trapped_write == SYMBOL_TRAPPED_WRITE) + notify_variable_watchers (local_var, Qnil, + Qmakunbound, Fcurrent_buffer ()); + } } for (i = 0; i < last_per_buffer_idx; ++i) @@ -5682,7 +5696,7 @@ syms_of_buffer (void) This variable is buffer-local but you cannot set it directly; use the function `set-buffer-multibyte' to change a buffer's representation. See also Info node `(elisp)Text Representations'. */); - XSYMBOL (intern_c_string ("enable-multibyte-characters"))->constant = 1; + make_symbol_constant (intern_c_string ("enable-multibyte-characters")); DEFVAR_PER_BUFFER ("buffer-file-coding-system", &BVAR (current_buffer, buffer_file_coding_system), Qnil, diff --git a/src/bytecode.c b/src/bytecode.c index e2d8ab7..edfc9c5 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -569,10 +569,10 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, if (SYMBOLP (sym) && !EQ (val, Qunbound) && !XSYMBOL (sym)->redirect - && !SYMBOL_CONSTANT_P (sym)) + && !SYMBOL_TRAPPED_WRITE_P (sym)) SET_SYMBOL_VAL (XSYMBOL (sym), val); else - set_internal (sym, val, Qnil, false); + set_internal (sym, val, Qnil, SET_INTERNAL_SET); } NEXT; diff --git a/src/data.c b/src/data.c index d221db4..44a08e6 100644 --- a/src/data.c +++ b/src/data.c @@ -649,9 +649,10 @@ DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0, (register Lisp_Object symbol) { CHECK_SYMBOL (symbol); - if (SYMBOL_CONSTANT_P (symbol)) + if (XSYMBOL (symbol)->trapped_write == SYMBOL_NOWRITE) xsignal1 (Qsetting_constant, symbol); - Fset (symbol, Qunbound); + else + Fset (symbol, Qunbound); return symbol; } @@ -1225,7 +1226,7 @@ DEFUN ("set", Fset, Sset, 2, 2, 0, doc: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */) (register Lisp_Object symbol, Lisp_Object newval) { - set_internal (symbol, newval, Qnil, 0); + set_internal (symbol, newval, Qnil, SET_INTERNAL_SET); return newval; } @@ -1233,13 +1234,14 @@ DEFUN ("set", Fset, Sset, 2, 2, 0, If buffer/frame-locality is an issue, WHERE specifies which context to use. (nil stands for the current buffer/frame). - If BINDFLAG is false, then if this symbol is supposed to become - local in every buffer where it is set, then we make it local. - If BINDFLAG is true, we don't do that. */ + If BINDFLAG is SET_INTERNAL_SET, then if this symbol is supposed to + become local in every buffer where it is set, then we make it + local. If BINDFLAG is SET_INTERNAL_BIND or SET_INTERNAL_UNBIND, we + don't do that. */ void set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where, - bool bindflag) + enum Set_Internal_Bind bindflag) { bool voide = EQ (newval, Qunbound); struct Lisp_Symbol *sym; @@ -1250,18 +1252,31 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where, return; */ CHECK_SYMBOL (symbol); - if (SYMBOL_CONSTANT_P (symbol)) + sym = XSYMBOL (symbol); + switch (sym->trapped_write) { + case SYMBOL_NOWRITE: if (NILP (Fkeywordp (symbol)) - || !EQ (newval, Fsymbol_value (symbol))) - xsignal1 (Qsetting_constant, symbol); + || !EQ (newval, Fsymbol_value (symbol))) + xsignal1 (Qsetting_constant, symbol); else - /* Allow setting keywords to their own value. */ - return; + /* Allow setting keywords to their own value. */ + return; + + case SYMBOL_TRAPPED_WRITE: + notify_variable_watchers (symbol, voide? Qnil : newval, + (bindflag == SET_INTERNAL_BIND? Qlet : + bindflag == SET_INTERNAL_UNBIND? Qunlet : + voide? Qmakunbound : Qset), + where); + /* FALLTHROUGH! */ + case SYMBOL_UNTRAPPED_WRITE: + break; + + default: emacs_abort (); } maybe_set_redisplay (symbol); - sym = XSYMBOL (symbol); start: switch (sym->redirect) @@ -1385,6 +1400,107 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where, } return; } + +static void +set_symbol_trapped_write (Lisp_Object symbol, enum symbol_trapped_write trap) +{ + struct Lisp_Symbol* sym = XSYMBOL (symbol); + if (sym->trapped_write == SYMBOL_NOWRITE) + xsignal1 (Qtrapping_constant, symbol); + else if (sym->redirect == SYMBOL_LOCALIZED && + SYMBOL_BLV (sym)->frame_local) + xsignal1 (Qtrapping_frame_local, symbol); + sym->trapped_write = trap; +} + +static void +reset_symbol_trapped_write (Lisp_Object symbol) +{ + set_symbol_trapped_write (symbol, SYMBOL_TRAPPED_WRITE); +} + +static void +harmonize_variable_watchers (Lisp_Object alias, Lisp_Object base_variable) +{ + if (!EQ (base_variable, alias) && + EQ (base_variable, Findirect_variable (alias))) + set_symbol_trapped_write + (alias, XSYMBOL (base_variable)->trapped_write); +} + +DEFUN ("add-variable-watcher", Fadd_variable_watcher, Sadd_variable_watcher, + 2, 2, 0, + doc: /* Cause WATCH-FUNCTION to be called when SYMBOL is set. */) + (Lisp_Object symbol, Lisp_Object watch_function) +{ + symbol = Findirect_variable (symbol); + set_symbol_trapped_write (symbol, SYMBOL_TRAPPED_WRITE); + map_obarray (Vobarray, harmonize_variable_watchers, symbol); + + Lisp_Object watchers = Fget (symbol, Qwatchers); + Lisp_Object member = Fmember (watch_function, watchers); + if (NILP (member)) + Fput (symbol, Qwatchers, Fcons (watch_function, watchers)); + return Qnil; +} + +DEFUN ("remove-variable-watcher", Fremove_variable_watcher, Sremove_variable_watcher, + 2, 2, 0, + doc: /* Undo the effect of `add-variable-watcher'. */) + (Lisp_Object symbol, Lisp_Object watch_function) +{ + symbol = Findirect_variable (symbol); + Lisp_Object watchers = Fget (symbol, Qwatchers); + watchers = Fdelete (watch_function, watchers); + if (NILP (watchers)) + { + set_symbol_trapped_write (symbol, SYMBOL_UNTRAPPED_WRITE); + map_obarray (Vobarray, harmonize_variable_watchers, symbol); + } + Fput (symbol, Qwatchers, watchers); + return Qnil; +} + +void +notify_variable_watchers (Lisp_Object symbol, + Lisp_Object newval, + Lisp_Object operation, + Lisp_Object where) +{ + symbol = Findirect_variable (symbol); + /* Avoid recursion. */ + set_symbol_trapped_write (symbol, SYMBOL_UNTRAPPED_WRITE); + ptrdiff_t count = SPECPDL_INDEX (); + record_unwind_protect (reset_symbol_trapped_write, symbol); + + if (NILP (where) && + !EQ (operation, Qset_default) && !EQ (operation, Qmakunbound) && + !NILP (Flocal_variable_if_set_p (symbol, Fcurrent_buffer ()))) + { + XSETBUFFER (where, current_buffer); + } + + if (EQ (operation, Qset_default)) + operation = Qset; + + for (Lisp_Object watchers = Fget (symbol, Qwatchers); + CONSP (watchers); + watchers = XCDR (watchers)) + { + Lisp_Object watcher = XCAR (watchers); + /* Call subr directly to avoid gc. */ + if (SUBRP (watcher)) + { + Lisp_Object args[] = { symbol, newval, operation, where }; + funcall_subr (XSUBR (watcher), ARRAYELTS (args), args); + } + else + CALLN (Ffuncall, watcher, symbol, newval, operation, where); + } + + unbind_to (count, Qnil); +} + /* Access or set a buffer-local symbol's default value. */ @@ -1471,16 +1587,27 @@ DEFUN ("set-default", Fset_default, Sset_default, 2, 2, 0, struct Lisp_Symbol *sym; CHECK_SYMBOL (symbol); - if (SYMBOL_CONSTANT_P (symbol)) + sym = XSYMBOL (symbol); + switch (sym->trapped_write) { + case SYMBOL_NOWRITE: if (NILP (Fkeywordp (symbol)) - || !EQ (value, Fdefault_value (symbol))) - xsignal1 (Qsetting_constant, symbol); + || !EQ (value, Fsymbol_value (symbol))) + xsignal1 (Qsetting_constant, symbol); else - /* Allow setting keywords to their own value. */ - return value; + /* Allow setting keywords to their own value. */ + return value; + + case SYMBOL_TRAPPED_WRITE: + /* Don't notify here if we're going to call Fset anyway. */ + if (sym->redirect != SYMBOL_PLAINVAL) + notify_variable_watchers (symbol, value, Qset_default, Qnil); + /* FALLTHROUGH! */ + case SYMBOL_UNTRAPPED_WRITE: + break; + + default: emacs_abort (); } - sym = XSYMBOL (symbol); start: switch (sym->redirect) @@ -1651,7 +1778,7 @@ DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local, default: emacs_abort (); } - if (sym->constant) + if (sym->trapped_write == SYMBOL_NOWRITE) error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable))); if (!blv) @@ -1726,7 +1853,7 @@ DEFUN ("make-local-variable", Fmake_local_variable, Smake_local_variable, default: emacs_abort (); } - if (sym->constant) + if (sym->trapped_write == SYMBOL_NOWRITE) error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable))); @@ -1838,6 +1965,9 @@ DEFUN ("kill-local-variable", Fkill_local_variable, Skill_local_variable, default: emacs_abort (); } + if (sym->trapped_write == SYMBOL_TRAPPED_WRITE) + notify_variable_watchers (variable, Qnil, Qmakunbound, Fcurrent_buffer ()); + /* Get rid of this buffer's alist element, if any. */ XSETSYMBOL (variable, sym); /* Propagate variable indirection. */ tem = Fassq (variable, BVAR (current_buffer, local_var_alist)); @@ -1920,7 +2050,7 @@ DEFUN ("make-variable-frame-local", Fmake_variable_frame_local, Smake_variable_f default: emacs_abort (); } - if (sym->constant) + if (SYMBOL_TRAPPED_WRITE_P (variable)) error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable))); blv = make_blv (sym, forwarded, valcontents); @@ -3471,6 +3601,8 @@ syms_of_data (void) DEFSYM (Qcyclic_variable_indirection, "cyclic-variable-indirection"); DEFSYM (Qvoid_variable, "void-variable"); DEFSYM (Qsetting_constant, "setting-constant"); + DEFSYM (Qtrapping_constant, "trapping-constant"); + DEFSYM (Qtrapping_frame_local, "trapping-frame-local"); DEFSYM (Qinvalid_read_syntax, "invalid-read-syntax"); DEFSYM (Qinvalid_function, "invalid-function"); @@ -3549,6 +3681,10 @@ syms_of_data (void) PUT_ERROR (Qvoid_variable, error_tail, "Symbol's value as variable is void"); PUT_ERROR (Qsetting_constant, error_tail, "Attempt to set a constant symbol"); + PUT_ERROR (Qtrapping_constant, error_tail, + "Attempt to trap writes to a constant symbol"); + PUT_ERROR (Qtrapping_frame_local, error_tail, + "Attempt to trap writes to a frame local variable"); PUT_ERROR (Qinvalid_read_syntax, error_tail, "Invalid read syntax"); PUT_ERROR (Qinvalid_function, error_tail, "Invalid function"); PUT_ERROR (Qwrong_number_of_arguments, error_tail, @@ -3727,10 +3863,18 @@ syms_of_data (void) DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum, doc: /* The largest value that is representable in a Lisp integer. */); Vmost_positive_fixnum = make_number (MOST_POSITIVE_FIXNUM); - XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant = 1; + make_symbol_constant (intern_c_string ("most-positive-fixnum")); DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum, doc: /* The smallest value that is representable in a Lisp integer. */); Vmost_negative_fixnum = make_number (MOST_NEGATIVE_FIXNUM); - XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant = 1; + make_symbol_constant (intern_c_string ("most-negative-fixnum")); + + DEFSYM (Qwatchers, "watchers"); + DEFSYM (Qmakunbound, "makunbound"); + DEFSYM (Qunlet, "unlet"); + DEFSYM (Qset, "set"); + DEFSYM (Qset_default, "set-default"); + defsubr (&Sadd_variable_watcher); + defsubr (&Sremove_variable_watcher); } diff --git a/src/eval.c b/src/eval.c index a9bad24..7c66a46 100644 --- a/src/eval.c +++ b/src/eval.c @@ -595,8 +595,8 @@ DEFUN ("defvaralias", Fdefvaralias, Sdefvaralias, 2, 3, 0, sym = XSYMBOL (new_alias); - if (sym->constant) - /* Not sure why, but why not? */ + if (sym->trapped_write == SYMBOL_NOWRITE) + /* Making it an alias effectively changes its value. */ error ("Cannot make a constant an alias"); switch (sym->redirect) @@ -617,8 +617,8 @@ DEFUN ("defvaralias", Fdefvaralias, Sdefvaralias, 2, 3, 0, so that old-code that affects n_a before the aliasing is setup still works. */ if (NILP (Fboundp (base_variable))) - set_internal (base_variable, find_symbol_value (new_alias), Qnil, 1); - + set_internal (base_variable, find_symbol_value (new_alias), + Qnil, SET_INTERNAL_BIND); { union specbinding *p; @@ -628,11 +628,14 @@ DEFUN ("defvaralias", Fdefvaralias, Sdefvaralias, 2, 3, 0, error ("Don't know how to make a let-bound variable an alias"); } + if (sym->trapped_write == SYMBOL_TRAPPED_WRITE) + notify_variable_watchers (new_alias, base_variable, Qdefvaralias, Qnil); + sym->declared_special = 1; XSYMBOL (base_variable)->declared_special = 1; sym->redirect = SYMBOL_VARALIAS; SET_SYMBOL_ALIAS (sym, XSYMBOL (base_variable)); - sym->constant = SYMBOL_CONSTANT_P (base_variable); + sym->trapped_write = XSYMBOL (base_variable)->trapped_write; LOADHIST_ATTACH (new_alias); /* Even if docstring is nil: remove old docstring. */ Fput (new_alias, Qvariable_documentation, docstring); @@ -2644,9 +2647,7 @@ DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0, Lisp_Object fun, original_fun; Lisp_Object funcar; ptrdiff_t numargs = nargs - 1; - Lisp_Object lisp_numargs; Lisp_Object val; - Lisp_Object *internal_args; ptrdiff_t count; QUIT; @@ -2679,86 +2680,7 @@ DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0, fun = indirect_function (fun); if (SUBRP (fun)) - { - if (numargs < XSUBR (fun)->min_args - || (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs)) - { - XSETFASTINT (lisp_numargs, numargs); - xsignal2 (Qwrong_number_of_arguments, original_fun, lisp_numargs); - } - - else if (XSUBR (fun)->max_args == UNEVALLED) - xsignal1 (Qinvalid_function, original_fun); - - else if (XSUBR (fun)->max_args == MANY) - val = (XSUBR (fun)->function.aMANY) (numargs, args + 1); - else - { - Lisp_Object internal_argbuf[8]; - if (XSUBR (fun)->max_args > numargs) - { - eassert (XSUBR (fun)->max_args <= ARRAYELTS (internal_argbuf)); - internal_args = internal_argbuf; - memcpy (internal_args, args + 1, numargs * word_size); - memclear (internal_args + numargs, - (XSUBR (fun)->max_args - numargs) * word_size); - } - else - internal_args = args + 1; - switch (XSUBR (fun)->max_args) - { - case 0: - val = (XSUBR (fun)->function.a0 ()); - break; - case 1: - val = (XSUBR (fun)->function.a1 (internal_args[0])); - break; - case 2: - val = (XSUBR (fun)->function.a2 - (internal_args[0], internal_args[1])); - break; - case 3: - val = (XSUBR (fun)->function.a3 - (internal_args[0], internal_args[1], internal_args[2])); - break; - case 4: - val = (XSUBR (fun)->function.a4 - (internal_args[0], internal_args[1], internal_args[2], - internal_args[3])); - break; - case 5: - val = (XSUBR (fun)->function.a5 - (internal_args[0], internal_args[1], internal_args[2], - internal_args[3], internal_args[4])); - break; - case 6: - val = (XSUBR (fun)->function.a6 - (internal_args[0], internal_args[1], internal_args[2], - internal_args[3], internal_args[4], internal_args[5])); - break; - case 7: - val = (XSUBR (fun)->function.a7 - (internal_args[0], internal_args[1], internal_args[2], - internal_args[3], internal_args[4], internal_args[5], - internal_args[6])); - break; - - case 8: - val = (XSUBR (fun)->function.a8 - (internal_args[0], internal_args[1], internal_args[2], - internal_args[3], internal_args[4], internal_args[5], - internal_args[6], internal_args[7])); - break; - - default: - - /* If a subr takes more than 8 arguments without using MANY - or UNEVALLED, we need to extend this function to support it. - Until this is done, there is no way to call the function. */ - emacs_abort (); - } - } - } + val = funcall_subr (XSUBR (fun), numargs, args + 1); else if (COMPILEDP (fun)) val = funcall_lambda (fun, numargs, args + 1); else @@ -2790,6 +2712,89 @@ DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0, return val; } + +/* Apply a C subroutine SUBR to the NUMARGS evaluated arguments in ARG_VECTOR + and return the result of evaluation. */ + +Lisp_Object +funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *args) +{ + if (numargs < subr->min_args + || (subr->max_args >= 0 && subr->max_args < numargs)) + { + Lisp_Object fun; + XSETSUBR (fun, subr); + xsignal2 (Qwrong_number_of_arguments, fun, make_number (numargs)); + } + + else if (subr->max_args == UNEVALLED) + { + Lisp_Object fun; + XSETSUBR (fun, subr); + xsignal1 (Qinvalid_function, fun); + } + + else if (subr->max_args == MANY) + return (subr->function.aMANY) (numargs, args); + else + { + Lisp_Object internal_argbuf[8]; + Lisp_Object *internal_args; + if (subr->max_args > numargs) + { + eassert (subr->max_args <= ARRAYELTS (internal_argbuf)); + internal_args = internal_argbuf; + memcpy (internal_args, args, numargs * word_size); + memclear (internal_args + numargs, + (subr->max_args - numargs) * word_size); + } + else + internal_args = args; + switch (subr->max_args) + { + case 0: + return (subr->function.a0 ()); + case 1: + return (subr->function.a1 (internal_args[0])); + case 2: + return (subr->function.a2 + (internal_args[0], internal_args[1])); + case 3: + return (subr->function.a3 + (internal_args[0], internal_args[1], internal_args[2])); + case 4: + return (subr->function.a4 + (internal_args[0], internal_args[1], internal_args[2], + internal_args[3])); + case 5: + return (subr->function.a5 + (internal_args[0], internal_args[1], internal_args[2], + internal_args[3], internal_args[4])); + case 6: + return (subr->function.a6 + (internal_args[0], internal_args[1], internal_args[2], + internal_args[3], internal_args[4], internal_args[5])); + case 7: + return (subr->function.a7 + (internal_args[0], internal_args[1], internal_args[2], + internal_args[3], internal_args[4], internal_args[5], + internal_args[6])); + case 8: + return (subr->function.a8 + (internal_args[0], internal_args[1], internal_args[2], + internal_args[3], internal_args[4], internal_args[5], + internal_args[6], internal_args[7])); + + default: + + /* If a subr takes more than 8 arguments without using MANY + or UNEVALLED, we need to extend this function to support it. + Until this is done, there is no way to call the function. */ + emacs_abort (); + } + } +} + static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args, ptrdiff_t count) { @@ -3158,10 +3163,10 @@ specbind (Lisp_Object symbol, Lisp_Object value) specpdl_ptr->let.symbol = symbol; specpdl_ptr->let.old_value = SYMBOL_VAL (sym); grow_specpdl (); - if (!sym->constant) + if (!sym->trapped_write) SET_SYMBOL_VAL (sym, value); else - set_internal (symbol, value, Qnil, 1); + set_internal (symbol, value, Qnil, SET_INTERNAL_BIND); break; case SYMBOL_LOCALIZED: if (SYMBOL_BLV (sym)->frame_local) @@ -3201,7 +3206,7 @@ specbind (Lisp_Object symbol, Lisp_Object value) specpdl_ptr->let.kind = SPECPDL_LET; grow_specpdl (); - set_internal (symbol, value, Qnil, 1); + set_internal (symbol, value, Qnil, SET_INTERNAL_BIND); break; } default: emacs_abort (); @@ -3328,14 +3333,16 @@ unbind_to (ptrdiff_t count, Lisp_Object value) case SPECPDL_BACKTRACE: break; case SPECPDL_LET: - { /* If variable has a trivial value (no forwarding), we can - just set it. No need to check for constant symbols here, - since that was already done by specbind. */ + { /* If variable has a trivial value (no forwarding), and + isn't trapped, we can just set it. */ Lisp_Object sym = specpdl_symbol (specpdl_ptr); if (SYMBOLP (sym) && XSYMBOL (sym)->redirect == SYMBOL_PLAINVAL) { - SET_SYMBOL_VAL (XSYMBOL (sym), - specpdl_old_value (specpdl_ptr)); + if (XSYMBOL (sym)->trapped_write == SYMBOL_UNTRAPPED_WRITE) + SET_SYMBOL_VAL (XSYMBOL (sym), specpdl_old_value (specpdl_ptr)); + else + set_internal (sym, specpdl_old_value (specpdl_ptr), + Qnil, SET_INTERNAL_UNBIND); break; } else @@ -3358,7 +3365,7 @@ unbind_to (ptrdiff_t count, Lisp_Object value) /* If this was a local binding, reset the value in the appropriate buffer, but only if that buffer's binding still exists. */ if (!NILP (Flocal_variable_p (symbol, where))) - set_internal (symbol, old_value, where, 1); + set_internal (symbol, old_value, where, SET_INTERNAL_UNBIND); } break; } @@ -3583,7 +3590,7 @@ backtrace_eval_unrewind (int distance) { set_specpdl_old_value (tmp, Fbuffer_local_value (symbol, where)); - set_internal (symbol, old_value, where, 1); + set_internal (symbol, old_value, where, SET_INTERNAL_UNBIND); } } break; @@ -3927,6 +3934,7 @@ syms_of_eval (void) defsubr (&Sset_default_toplevel_value); defsubr (&Sdefvar); defsubr (&Sdefvaralias); + DEFSYM (Qdefvaralias, "defvaralias"); defsubr (&Sdefconst); defsubr (&Smake_var_non_special); defsubr (&Slet); diff --git a/src/font.c b/src/font.c index ce63233..3b821a4 100644 --- a/src/font.c +++ b/src/font.c @@ -5417,19 +5417,19 @@ syms_of_font (void) [NUMERIC-VALUE SYMBOLIC-NAME ALIAS-NAME ...] NUMERIC-VALUE is an integer, and SYMBOLIC-NAME and ALIAS-NAME are symbols. */); Vfont_weight_table = BUILD_STYLE_TABLE (weight_table); - XSYMBOL (intern_c_string ("font-weight-table"))->constant = 1; + make_symbol_constant (intern_c_string ("font-weight-table")); DEFVAR_LISP_NOPRO ("font-slant-table", Vfont_slant_table, doc: /* Vector of font slant symbols vs the corresponding numeric values. See `font-weight-table' for the format of the vector. */); Vfont_slant_table = BUILD_STYLE_TABLE (slant_table); - XSYMBOL (intern_c_string ("font-slant-table"))->constant = 1; + make_symbol_constant (intern_c_string ("font-slant-table")); DEFVAR_LISP_NOPRO ("font-width-table", Vfont_width_table, doc: /* Alist of font width symbols vs the corresponding numeric values. See `font-weight-table' for the format of the vector. */); Vfont_width_table = BUILD_STYLE_TABLE (width_table); - XSYMBOL (intern_c_string ("font-width-table"))->constant = 1; + make_symbol_constant (intern_c_string ("font-width-table")); staticpro (&font_style_table); font_style_table = make_uninit_vector (3); diff --git a/src/lisp.h b/src/lisp.h index 2e46592..c1483fa 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -320,7 +320,7 @@ DEFINE_GDB_SYMBOL_END (USE_LSB_TAG) #define lisp_h_NILP(x) EQ (x, Qnil) #define lisp_h_SET_SYMBOL_VAL(sym, v) \ (eassert ((sym)->redirect == SYMBOL_PLAINVAL), (sym)->val.value = (v)) -#define lisp_h_SYMBOL_CONSTANT_P(sym) (XSYMBOL (sym)->constant) +#define lisp_h_SYMBOL_TRAPPED_WRITE_P(sym) (XSYMBOL (sym)->trapped_write) #define lisp_h_SYMBOL_VAL(sym) \ (eassert ((sym)->redirect == SYMBOL_PLAINVAL), (sym)->val.value) #define lisp_h_SYMBOLP(x) (XTYPE (x) == Lisp_Symbol) @@ -374,7 +374,7 @@ DEFINE_GDB_SYMBOL_END (USE_LSB_TAG) # define MISCP(x) lisp_h_MISCP (x) # define NILP(x) lisp_h_NILP (x) # define SET_SYMBOL_VAL(sym, v) lisp_h_SET_SYMBOL_VAL (sym, v) -# define SYMBOL_CONSTANT_P(sym) lisp_h_SYMBOL_CONSTANT_P (sym) +# define SYMBOL_TRAPPED_WRITE_P(sym) lisp_h_SYMBOL_TRAPPED_WRITE_P (sym) # define SYMBOL_VAL(sym) lisp_h_SYMBOL_VAL (sym) # define SYMBOLP(x) lisp_h_SYMBOLP (x) # define VECTORLIKEP(x) lisp_h_VECTORLIKEP (x) @@ -602,6 +602,9 @@ INLINE bool (VECTORLIKEP) (Lisp_Object); /* Defined in data.c. */ extern _Noreturn Lisp_Object wrong_type_argument (Lisp_Object, Lisp_Object); extern _Noreturn void wrong_choice (Lisp_Object, Lisp_Object); +extern void notify_variable_watchers (Lisp_Object symbol, Lisp_Object newval, + Lisp_Object operation, Lisp_Object where); + /* Defined in emacs.c. */ #ifdef DOUG_LEA_MALLOC @@ -632,6 +635,13 @@ INLINE bool (VECTORLIKEP) (Lisp_Object); SYMBOL_FORWARDED = 3 }; +enum symbol_trapped_write +{ + SYMBOL_UNTRAPPED_WRITE = 0, + SYMBOL_NOWRITE = 1, + SYMBOL_TRAPPED_WRITE = 2 +}; + struct Lisp_Symbol { bool_bf gcmarkbit : 1; @@ -643,10 +653,10 @@ INLINE bool (VECTORLIKEP) (Lisp_Object); 3 : it's a forwarding variable, the value is in `forward'. */ ENUM_BF (symbol_redirect) redirect : 3; - /* Non-zero means symbol is constant, i.e. changing its value - should signal an error. If the value is 3, then the var - can be changed, but only by `defconst'. */ - unsigned constant : 2; + /* 0 : normal case, just set the value + 1 : constant, cannot set, e.g. nil, t, :keywords. + 2 : trap the write, call watcher functions. */ + ENUM_BF (symbol_trapped_write) trapped_write : 2; /* Interned state of the symbol. This is an enumerator from enum symbol_interned. */ @@ -1850,14 +1860,14 @@ SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (Lisp_Object sym) return XSYMBOL (sym)->interned == SYMBOL_INTERNED_IN_INITIAL_OBARRAY; } -/* Value is non-zero if symbol is considered a constant, i.e. its - value cannot be changed (there is an exception for keyword symbols, - whose value can be set to the keyword symbol itself). */ +/* Value is non-zero if symbol cannot be changed through a simple set, + i.e. it's a constant (e.g. nil, t, :keywords), or it has some + watching functions. */ INLINE int -(SYMBOL_CONSTANT_P) (Lisp_Object sym) +(SYMBOL_TRAPPED_WRITE_P) (Lisp_Object sym) { - return lisp_h_SYMBOL_CONSTANT_P (sym); + return lisp_h_SYMBOL_TRAPPED_WRITE_P (sym); } /* Placeholder for make-docfile to process. The actual symbol @@ -3289,6 +3299,12 @@ set_symbol_next (Lisp_Object sym, struct Lisp_Symbol *next) XSYMBOL (sym)->next = next; } +INLINE void +make_symbol_constant (Lisp_Object sym) +{ + XSYMBOL (sym)->trapped_write = SYMBOL_NOWRITE; +} + /* Buffer-local (also frame-local) variable access functions. */ INLINE int @@ -3397,7 +3413,13 @@ set_sub_char_table_contents (Lisp_Object table, ptrdiff_t idx, Lisp_Object val) extern _Noreturn void args_out_of_range_3 (Lisp_Object, Lisp_Object, Lisp_Object); extern Lisp_Object do_symval_forwarding (union Lisp_Fwd *); -extern void set_internal (Lisp_Object, Lisp_Object, Lisp_Object, bool); +enum Set_Internal_Bind { + SET_INTERNAL_SET, + SET_INTERNAL_BIND, + SET_INTERNAL_UNBIND +}; +extern void set_internal (Lisp_Object, Lisp_Object, Lisp_Object, + enum Set_Internal_Bind); extern void syms_of_data (void); extern void swap_in_global_binding (struct Lisp_Symbol *); @@ -3880,6 +3902,7 @@ xsignal (Lisp_Object error_symbol, Lisp_Object data) extern _Noreturn void xsignal3 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); extern _Noreturn void signal_error (const char *, Lisp_Object); +extern Lisp_Object funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *arg_vector); extern Lisp_Object eval_sub (Lisp_Object form); extern Lisp_Object apply1 (Lisp_Object, Lisp_Object); extern Lisp_Object call0 (Lisp_Object); diff --git a/src/lread.c b/src/lread.c index 58d518c..7e74703 100644 --- a/src/lread.c +++ b/src/lread.c @@ -3833,7 +3833,7 @@ intern_sym (Lisp_Object sym, Lisp_Object obarray, Lisp_Object index) if (SREF (SYMBOL_NAME (sym), 0) == ':' && EQ (obarray, initial_obarray)) { - XSYMBOL (sym)->constant = 1; + make_symbol_constant (sym); XSYMBOL (sym)->redirect = SYMBOL_PLAINVAL; SET_SYMBOL_VAL (XSYMBOL (sym), sym); } @@ -4120,12 +4120,12 @@ init_obarray (void) DEFSYM (Qnil, "nil"); SET_SYMBOL_VAL (XSYMBOL (Qnil), Qnil); - XSYMBOL (Qnil)->constant = 1; + make_symbol_constant (Qnil); XSYMBOL (Qnil)->declared_special = true; DEFSYM (Qt, "t"); SET_SYMBOL_VAL (XSYMBOL (Qt), Qt); - XSYMBOL (Qt)->constant = 1; + make_symbol_constant (Qt); XSYMBOL (Qt)->declared_special = true; /* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */ -- 2.9.3