mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2026-02-04 06:31:13 -08:00
Code Issues Projects Releases Wiki Activity

Add lisp watchpoints

Browse source 
This allows calling 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.
This commit is contained in:
Noam Postavsky 2015-11-19 19:50:06 -05:00
parent 0fc4761ca8
commit 227213164e
8 changed files with 381 additions and 176 deletions
Download patch file Download diff file Expand all files Collapse all files

2
src/alloc.c
View file

@ -3567,7 +3567,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;
}

82
src/buffer.c
View file

@ -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)
@ -5541,7 +5555,7 @@ file I/O and the behavior of various editing commands.
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,

4
src/bytecode.c
View file

@ -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;

197
src/data.c
View file

@ -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);
|| !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 +1399,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. */
@ -1471,16 +1590,27 @@ for this variable. */)
struct Lisp_Symbol *sym;
CHECK_SYMBOL (symbol);
if (SYMBOL_CONSTANT_P (symbol))
{
if (NILP (Fkeywordp (symbol))
|| !EQ (value, Fdefault_value (symbol)))
xsignal1 (Qsetting_constant, symbol);
else
/* Allow setting keywords to their own value. */
return value;
}
sym = XSYMBOL (symbol);
switch (sym->trapped_write)
{
case SYMBOL_NOWRITE:
if (NILP (Fkeywordp (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 ();
}
start:
switch (sym->redirect)
@ -1651,7 +1781,7 @@ The function `default-value' gets the default value and `set-default' sets it.
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 @@ Instead, use `add-hook' and specify t for the LOCAL argument. */)
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 @@ From now on the default value will apply in this buffer. Return 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 @@ frame-local bindings). */)
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);
@ -3465,6 +3598,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");
@ -3543,6 +3678,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,
@ -3721,10 +3860,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);
}

206
src/eval.c
View file

@ -593,12 +593,12 @@ The return value is BASE-VARIABLE. */)
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 @@ The return value is BASE-VARIABLE. */)
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 @@ The return value is BASE-VARIABLE. */)
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);
@ -2645,9 +2648,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
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;
@ -2680,86 +2681,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
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
@ -2791,6 +2713,89 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
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)
{
@ -3171,10 +3176,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)
@ -3214,7 +3219,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 ();
@ -3341,14 +3346,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
@ -3371,7 +3378,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;
}
@ -3596,7 +3603,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;
@ -3940,6 +3947,7 @@ alist of active lexical bindings. */);
defsubr (&Sset_default_toplevel_value);
defsubr (&Sdefvar);
defsubr (&Sdefvaralias);
DEFSYM (Qdefvaralias, "defvaralias");
defsubr (&Sdefconst);
defsubr (&Smake_var_non_special);
defsubr (&Slet);

6
src/font.c
View file

@ -5415,19 +5415,19 @@ Each element has the form:
[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);

54
src/lisp.h
View file

@ -320,7 +320,8 @@ error !;
#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 @@ error !;
# 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)
@ -600,6 +602,9 @@ extern void char_table_set (Lisp_Object, int, 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);
#ifdef CANNOT_DUMP
enum { might_dump = false };
@ -632,6 +637,13 @@ enum symbol_redirect
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 @@ struct Lisp_Symbol
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)
@ -3286,6 +3309,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
@ -3394,7 +3423,13 @@ extern _Noreturn void args_out_of_range (Lisp_Object, Lisp_Object);
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 *);
@ -3877,6 +3912,7 @@ extern _Noreturn void xsignal2 (Lisp_Object, Lisp_Object, Lisp_Object);
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);

6
src/lread.c
View file

@ -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. */