>From c318be2dc401d2f3b958ceb3b48e466a3019091e Mon Sep 17 00:00:00 2001 From: Noam Postavsky Date: Thu, 19 Nov 2015 19:50:06 -0500 Subject: [PATCH v6 1/6] Add lisp watchpoints This allows to call a function whenever a symbol-value is changed. * src/lisp.h (lisp_h_SYMBOL_TRAPPED_WRITE_P): (SYMBOL_TRAPPED_WRITE_P): New function/macro. (lisp_h_SYMBOL_CONSTANT_P): Check for SYMBOL_NOWRITE specifically. (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, restore_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 | 22 +++++-- src/bytecode.c | 4 +- src/data.c | 177 ++++++++++++++++++++++++++++++++++++++++++++++++++++----- src/eval.c | 172 +++++++++++++++++++++++++++++-------------------------- src/font.c | 6 +- src/lisp.h | 54 +++++++++++++++--- src/lread.c | 6 +- 8 files changed, 324 insertions(+), 119 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,9 +984,13 @@ 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))) + { + 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; @@ -1010,7 +1014,12 @@ reset_buffer_local_variables (struct buffer *b, bool permanent_too) || !NILP (Fget (elt, Qpermanent_local_hook))) newlist = Fcons (elt, newlist); } - XSETCDR (XCAR (tmp), Fnreverse (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. */ @@ -1018,6 +1027,11 @@ reset_buffer_local_variables (struct buffer *b, bool permanent_too) 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..18eaf9f 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..8954b42 100644 --- a/src/data.c +++ b/src/data.c @@ -1225,7 +1225,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 +1233,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 +1251,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); else /* 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) @@ -1386,6 +1400,111 @@ 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 +restore_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. +All writes to aliases of SYMBOL will call WATCH-FUNCTION too. */) + (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'. +Remove WATCH-FUNCTION from the list of functions to be called when +SYMBOL (or its aliases) are set. */) + (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); + + ptrdiff_t count = SPECPDL_INDEX (); + record_unwind_protect (restore_symbol_trapped_write, symbol); + /* Avoid recursion. */ + set_symbol_trapped_write (symbol, SYMBOL_UNTRAPPED_WRITE); + + 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. */ /* Return the default value of SYMBOL, but don't check for voidness. @@ -1471,16 +1590,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))) + || !EQ (value, Fsymbol_value (symbol))) xsignal1 (Qsetting_constant, symbol); else /* 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 +1781,7 @@ DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local, default: emacs_abort (); } - if (sym->constant) + if (SYMBOL_CONSTANT_P (variable)) error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable))); if (!blv) @@ -1726,7 +1856,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 +1968,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 +2053,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 +3604,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 +3684,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 +3866,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..c5c6fa9 100644 --- a/src/eval.c +++ b/src/eval.c @@ -593,12 +593,12 @@ DEFUN ("defvaralias", Fdefvaralias, Sdefvaralias, 2, 3, 0, CHECK_SYMBOL (new_alias); CHECK_SYMBOL (base_variable); - sym = XSYMBOL (new_alias); - - if (sym->constant) - /* Not sure why, but why not? */ + if (SYMBOL_CONSTANT_P (new_alias)) + /* Making it an alias effectively changes its value. */ error ("Cannot make a constant an alias"); + sym = XSYMBOL (new_alias); + switch (sym->redirect) { case SYMBOL_FORWARDED: @@ -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,76 +2680,110 @@ DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0, fun = indirect_function (fun); if (SUBRP (fun)) + val = funcall_subr (XSUBR (fun), numargs, args + 1); + else if (COMPILEDP (fun)) + val = funcall_lambda (fun, numargs, args + 1); + else { - if (numargs < XSUBR (fun)->min_args - || (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs)) + if (NILP (fun)) + xsignal1 (Qvoid_function, original_fun); + if (!CONSP (fun)) + xsignal1 (Qinvalid_function, original_fun); + funcar = XCAR (fun); + if (!SYMBOLP (funcar)) + xsignal1 (Qinvalid_function, original_fun); + if (EQ (funcar, Qlambda) + || EQ (funcar, Qclosure)) + val = funcall_lambda (fun, numargs, args + 1); + else if (EQ (funcar, Qautoload)) { - XSETFASTINT (lisp_numargs, numargs); - xsignal2 (Qwrong_number_of_arguments, original_fun, lisp_numargs); + Fautoload_do_load (fun, original_fun, Qnil); + check_cons_list (); + goto retry; } - - else if (XSUBR (fun)->max_args == UNEVALLED) + else xsignal1 (Qinvalid_function, original_fun); + } + check_cons_list (); + lisp_eval_depth--; + if (backtrace_debug_on_exit (specpdl + count)) + val = call_debugger (list2 (Qexit, val)); + specpdl_ptr--; + return val; +} - else if (XSUBR (fun)->max_args == MANY) - val = (XSUBR (fun)->function.aMANY) (numargs, args + 1); + +/* 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]; - if (XSUBR (fun)->max_args > numargs) + Lisp_Object *internal_args; + if (subr->max_args > numargs) { - eassert (XSUBR (fun)->max_args <= ARRAYELTS (internal_argbuf)); + eassert (subr->max_args <= ARRAYELTS (internal_argbuf)); internal_args = internal_argbuf; - memcpy (internal_args, args + 1, numargs * word_size); + memcpy (internal_args, args, numargs * word_size); memclear (internal_args + numargs, - (XSUBR (fun)->max_args - numargs) * word_size); + (subr->max_args - numargs) * word_size); } else - internal_args = args + 1; - switch (XSUBR (fun)->max_args) + internal_args = args; + switch (subr->max_args) { case 0: - val = (XSUBR (fun)->function.a0 ()); - break; + return (subr->function.a0 ()); case 1: - val = (XSUBR (fun)->function.a1 (internal_args[0])); - break; + return (subr->function.a1 (internal_args[0])); case 2: - val = (XSUBR (fun)->function.a2 + return (subr->function.a2 (internal_args[0], internal_args[1])); - break; case 3: - val = (XSUBR (fun)->function.a3 + return (subr->function.a3 (internal_args[0], internal_args[1], internal_args[2])); - break; case 4: - val = (XSUBR (fun)->function.a4 + return (subr->function.a4 (internal_args[0], internal_args[1], internal_args[2], internal_args[3])); - break; case 5: - val = (XSUBR (fun)->function.a5 + return (subr->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 + return (subr->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 + 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])); - break; - case 8: - val = (XSUBR (fun)->function.a8 + 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])); - break; default: @@ -2759,36 +2794,6 @@ DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0, } } } - else if (COMPILEDP (fun)) - val = funcall_lambda (fun, numargs, args + 1); - else - { - if (NILP (fun)) - xsignal1 (Qvoid_function, original_fun); - if (!CONSP (fun)) - xsignal1 (Qinvalid_function, original_fun); - funcar = XCAR (fun); - if (!SYMBOLP (funcar)) - xsignal1 (Qinvalid_function, original_fun); - if (EQ (funcar, Qlambda) - || EQ (funcar, Qclosure)) - val = funcall_lambda (fun, numargs, args + 1); - else if (EQ (funcar, Qautoload)) - { - Fautoload_do_load (fun, original_fun, Qnil); - check_cons_list (); - goto retry; - } - else - xsignal1 (Qinvalid_function, original_fun); - } - check_cons_list (); - lisp_eval_depth--; - if (backtrace_debug_on_exit (specpdl + count)) - val = call_debugger (list2 (Qexit, val)); - specpdl_ptr--; - return val; -} 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..701ee9c 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -320,7 +320,8 @@ 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_CONSTANT_P(sym) (XSYMBOL (sym)->trapped_write == SYMBOL_NOWRITE) +#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) @@ -375,6 +376,7 @@ DEFINE_GDB_SYMBOL_END (USE_LSB_TAG) # 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 +604,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 +637,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 +655,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,9 +1862,20 @@ 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_TRAPPED_WRITE_P) (Lisp_Object sym) +{ + return lisp_h_SYMBOL_TRAPPED_WRITE_P (sym); +} + +/* Value is non-zero if symbol cannot be changed at all, i.e. it's a + constant (e.g. nil, t, :keywords). Code that actually wants to + write to SYM, should also check whether there are any watching + functions. */ INLINE int (SYMBOL_CONSTANT_P) (Lisp_Object sym) @@ -3289,6 +3312,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 +3426,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 +3915,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