From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED!not-for-mail From: npostavs@users.sourceforge.net Newsgroups: gmane.emacs.bugs Subject: bug#24923: 25.1; Lisp watchpoints Date: Sat, 12 Nov 2016 19:54:01 -0500 Message-ID: <87fumwmc7q.fsf@users.sourceforge.net> References: <87vavun235.fsf@users.sourceforge.net> <83eg2ie3lp.fsf@gnu.org> <87pom1mi3q.fsf@users.sourceforge.net> <83r36hcghy.fsf@gnu.org> NNTP-Posting-Host: blaine.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: blaine.gmane.org 1478998510 16119 195.159.176.226 (13 Nov 2016 00:55:10 GMT) X-Complaints-To: usenet@blaine.gmane.org NNTP-Posting-Date: Sun, 13 Nov 2016 00:55:10 +0000 (UTC) User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/25.1 (gnu/linux) Cc: 24923@debbugs.gnu.org To: Eli Zaretskii Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Sun Nov 13 01:55:03 2016 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by blaine.gmane.org with esmtp (Exim 4.84_2) (envelope-from ) id 1c5j3p-0005rf-2P for geb-bug-gnu-emacs@m.gmane.org; Sun, 13 Nov 2016 01:54:17 +0100 Original-Received: from localhost ([::1]:60151 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1c5j3r-0008Sl-Nu for geb-bug-gnu-emacs@m.gmane.org; Sat, 12 Nov 2016 19:54:19 -0500 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:56578) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1c5j3f-0008Sa-7e for bug-gnu-emacs@gnu.org; Sat, 12 Nov 2016 19:54:11 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1c5j3a-00051J-Qz for bug-gnu-emacs@gnu.org; Sat, 12 Nov 2016 19:54:07 -0500 Original-Received: from debbugs.gnu.org ([208.118.235.43]:39866) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1c5j3a-000519-Mw for bug-gnu-emacs@gnu.org; Sat, 12 Nov 2016 19:54:02 -0500 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1c5j3a-0003AI-D4 for bug-gnu-emacs@gnu.org; Sat, 12 Nov 2016 19:54:02 -0500 X-Loop: help-debbugs@gnu.org Resent-From: npostavs@users.sourceforge.net Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Sun, 13 Nov 2016 00:54:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 24923 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch Original-Received: via spool by 24923-submit@debbugs.gnu.org id=B24923.147899840412111 (code B ref 24923); Sun, 13 Nov 2016 00:54:02 +0000 Original-Received: (at 24923) by debbugs.gnu.org; 13 Nov 2016 00:53:24 +0000 Original-Received: from localhost ([127.0.0.1]:55265 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1c5j2w-00039E-Ft for submit@debbugs.gnu.org; Sat, 12 Nov 2016 19:53:24 -0500 Original-Received: from mail-it0-f49.google.com ([209.85.214.49]:37355) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1c5j2u-000390-6b for 24923@debbugs.gnu.org; Sat, 12 Nov 2016 19:53:21 -0500 Original-Received: by mail-it0-f49.google.com with SMTP id u205so45881907itc.0 for <24923@debbugs.gnu.org>; Sat, 12 Nov 2016 16:53:20 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20120113; h=sender:from:to:cc:subject:references:date:in-reply-to:message-id :user-agent:mime-version; bh=qUI5nAXZpxf9iEmocC7bAddcPT7kzJ4a+jlehAI2Dtw=; b=zbk9iJFMyhrYSQHv9fL/95I3gZyY9GtUDcJIkFR1bZ2yhjqOQDoc4PH7oQXgEu5K5Y vc1OznRv+/oe/SeMnKgMHRmzf+up6MciH2JxrveTm5JOs6VHdkafEaV8gZJkMSFzTo00 YzqaNgP1vandES7FlRJlkNQlLGW03zDCSYo7HsmeoPGMml4be52YZSkhDBuN5sgRkGkv pUaUil3xB2HQ+8uvj6u7fXpwWWlCTklkBhXzbC9RKJrzCV65LL7nXQdN12YpcaClo9vW XGyzuj6O6LDYJN/2UiGiz7ywXEZWbgeHStDoBlhsGw45Zwd1/0asbp6CUbJLCKN29ZFa DLXw== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20130820; h=x-gm-message-state:sender:from:to:cc:subject:references:date :in-reply-to:message-id:user-agent:mime-version; bh=qUI5nAXZpxf9iEmocC7bAddcPT7kzJ4a+jlehAI2Dtw=; b=XSsLoKwna+WhaQTYP30vr6tPr5U9ZjgIaeokkPOUcZRtX8edtgW/up00OAFVIDe/OE rn/zUZnC9NB71COjxpLC8YmXU1yUENr3qEYZIbSXmPCV3ZfJk8ey3UKHYznHNdoH5VZK vHeJx/2oHF/UN670UL4/xs0KRhryYOeNnEiS3D9x1dZEM+y+HUiFqs+Bajh9YW+slP9f eK1GqDfrSGSzrwuRnmuctyZUGk7BXk6RrWj5B+cpvFzKIvg3u2CE2AdEdRbG9LlJvZmu W43jIV7YbYuj6PFc3ysRvwePG0GG57TQam2MBRCt2aHtTJ1QDxF/cY+4au59blau9Ddo Gu/A== X-Gm-Message-State: ABUngvel9nRY1sbIQZ9M/6sdzQ6GLsjeH1w06XQxs/1OxfOdyHA0Q1WN0N9qeN6APc+dnQ== X-Received: by 10.107.1.138 with SMTP id 132mr17985728iob.72.1478998394378; Sat, 12 Nov 2016 16:53:14 -0800 (PST) Original-Received: from zony ([45.2.7.65]) by smtp.googlemail.com with ESMTPSA id p20sm12766875itc.2.2016.11.12.16.53.12 (version=TLS1_2 cipher=ECDHE-RSA-CHACHA20-POLY1305 bits=256/256); Sat, 12 Nov 2016 16:53:13 -0800 (PST) In-Reply-To: <83r36hcghy.fsf@gnu.org> (Eli Zaretskii's message of "Sat, 12 Nov 2016 09:19:21 +0200") X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 208.118.235.43 X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Original-Sender: "bug-gnu-emacs" Xref: news.gmane.org gmane.emacs.bugs:125649 Archived-At: --=-=-= Content-Type: text/plain Eli Zaretskii writes: >> From: npostavs@users.sourceforge.net >> Cc: 24923@debbugs.gnu.org >> Date: Fri, 11 Nov 2016 23:34:33 -0500 >> >> >> + (_ (format "watchpoint triggered %S" (cdr args)))) >> > >> > Can you give a couple of examples of this, with %S shown explicitly? >> > I'm not sure whether the result will be self-explanatory. >> >> You mean examples of this this clause being used? It was meant more as >> a catchall in case some watch types were missed by the previous clauses. >> It shouldn't really ever happen unless the debugger and watchpoint code >> get out of sync. Do you think it would be better to just signal an >> error? (although would signalling an error while the debugger is >> invoked cause trouble?) > > Either signal an error, or include something like "(please submit a > bug report)" in the text. Here is the updated patch, created with -b. I went with a call to `error'. And actually, I had missed a couple of watchpoint types. --=-=-= Content-Type: text/plain Content-Disposition: attachment; filename=v5-b-0001-Add-lisp-watchpoints.patch Content-Description: patch >From dc2e844f824e558711befebd97fb6535e8f47bc2 Mon Sep 17 00:00:00 2001 From: Noam Postavsky Date: Thu, 19 Nov 2015 19:50:06 -0500 Subject: [PATCH v5 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): (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 | 168 ++++++++++++++++++++++++++++-------------------------- src/font.c | 6 +- src/lisp.h | 54 +++++++++++++++--- src/lread.c | 6 +- 8 files changed, 322 insertions(+), 117 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..a071261 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 +Rmove 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..93a320f 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,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: @@ -2758,36 +2793,6 @@ DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0, emacs_abort (); } } - } - 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 @@ -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 --=-=-= Content-Type: text/plain Content-Disposition: attachment; filename=v5-b-0002-Add-function-to-trigger-debugger-on-variable-writ.patch Content-Description: patch >From 76719cfbdeed48028c008c423caa81dd18dabb2e Mon Sep 17 00:00:00 2001 From: Noam Postavsky Date: Sat, 21 Nov 2015 16:03:06 -0500 Subject: [PATCH v5 2/5] Add function to trigger debugger on variable write * lisp/emacs-lisp/debug.el (debug-on-variable-change): (debug--variable-list): (cancel-debug-on-variable-change): New functions. (debugger-setup-buffer): Add watchpoint clause. --- lisp/emacs-lisp/debug.el | 91 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 91 insertions(+) diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 7d27380..0fefc54 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -306,6 +306,24 @@ debugger-setup-buffer (delete-char 1) (insert ? ) (beginning-of-line)) + ;; Watchpoint triggered. + ((and `watchpoint (let `(,symbol ,newval . ,details) (cdr args))) + (insert + "--" + (pcase details + (`(makunbound nil) (format "making %s void" symbol)) + (`(makunbound ,buffer) (format "killing local value of %s in buffer %s" + symbol buffer)) + (`(defvaralias ,_) (format "aliasing %s to %s" symbol newval)) + (`(let ,_) (format "let-binding %s to %S" symbol newval)) + (`(unlet ,_) (format "ending let-binding of %s" symbol)) + (`(set nil) (format "setting %s to %S" symbol newval)) + (`(set ,buffer) (format "setting %s in buffer %s to %S" + symbol buffer newval)) + (_ (error "unrecognized watchpoint triggered %S" (cdr args)))) + ": ") + (setq pos (point)) + (insert ?\n)) ;; Debugger entered for an error. (`error (insert "--Lisp error: ") @@ -850,6 +868,79 @@ debugger-list-functions (princ "Note: if you have redefined a function, then it may no longer\n") (princ "be set to debug on entry, even if it is in the list.")))))) +(defun debug--implement-debug-watch (symbol newval op where) + "Conditionally call the debugger. +This function is called when SYMBOL's value is modified." + (if (or inhibit-debug-on-entry debugger-jumping-flag) + nil + (let ((inhibit-debug-on-entry t)) + (funcall debugger 'watchpoint symbol newval op where)))) + +;;;###autoload +(defun debug-on-variable-change (variable) + "Trigger a debugger invocation when VARIABLE is changed. + +When called interactively, prompt for VARIABLE in the minibuffer. + +This works by calling `add-variable-watch' on VARIABLE. If you +quit from the debugger, this will abort the change (unless the +change is caused by the termination of a let-binding). + +The watchpoint may be circumvented by C code that changes the +variable directly (i.e., not via `set'). Changing the value of +the variable (e.g., `setcar' on a list variable) will not trigger +watchpoint. + +Use \\[cancel-debug-on-variable-change] to cancel the effect of +this command. Uninterning VARIABLE or making it an alias of +another symbol also cancels it." + (interactive + (let* ((var-at-point (variable-at-point)) + (var (and (symbolp var-at-point) var-at-point)) + (val (completing-read + (concat "Debug when setting variable" + (if var (format " (default %s): " var) ": ")) + obarray #'boundp + t nil nil (and var (symbol-name var))))) + (list (if (equal val "") var (intern val))))) + (add-variable-watcher variable #'debug--implement-debug-watch)) + +;;;###autoload +(defalias 'debug-watch #'debug-on-variable-change) + + +(defun debug--variable-list () + "List of variables currently set for debug on set." + (let ((vars '())) + (mapatoms + (lambda (s) + (when (memq #'debug--implement-debug-watch + (get s 'watchers)) + (push s vars)))) + vars)) + +;;;###autoload +(defun cancel-debug-on-variable-change (&optional variable) + "Undo effect of \\[debug-on-entry] on VARIABLE. +If VARIABLE is nil, cancel debug-on-variable-change for all variables. +When called interactively, prompt for VARIABLE in the minibuffer. +To specify a nil argument interactively, exit with an empty minibuffer." + (interactive + (list (let ((name + (completing-read + "Cancel debug on set for variable (default all variables): " + (mapcar #'symbol-name (debug--variable-list)) nil t))) + (when name + (unless (string= name "") + (intern name)))))) + (if variable + (remove-variable-watcher variable #'debug--implement-debug-watch) + (message "Canceling debug-watch for all variables") + (mapc #'cancel-debug-watch (debug--variable-list)))) + +;;;###autoload +(defalias 'cancel-debug-watch #'cancel-debug-on-variable-change) + (provide 'debug) ;;; debug.el ends here -- 2.9.3 --=-=-= Content-Type: text/plain Content-Disposition: attachment; filename=v5-b-0003-Ensure-redisplay-using-variable-watcher.patch Content-Description: patch >From 0e4dd8a5bce95e88e924effa683f085499e9bf31 Mon Sep 17 00:00:00 2001 From: Noam Postavsky Date: Sat, 21 Nov 2015 17:02:42 -0500 Subject: [PATCH v5 3/5] Ensure redisplay using variable watcher Instead of looking up the variable name in redisplay--variables when setting. * lisp/frame.el: Replace redisplay--variables with add-variable-watcher calls. * src/xdisp.c (Fset_buffer_redisplay): Rename from maybe_set_redisplay, set the redisplay flag unconditionally. (Vredisplay__variables): Remove it. * src/data.c (set_internal): Remove maybe_set_redisplay call. --- lisp/frame.el | 3 +-- src/data.c | 2 -- src/window.h | 1 - src/xdisp.c | 17 +++++++---------- 4 files changed, 8 insertions(+), 15 deletions(-) diff --git a/lisp/frame.el b/lisp/frame.el index a584567..1dffc6c 100644 --- a/lisp/frame.el +++ b/lisp/frame.el @@ -2249,9 +2249,8 @@ 'automatic-hscrolling 'window-system-version "it does not give useful information." "24.3") ;; Variables which should trigger redisplay of the current buffer. -(setq redisplay--variables (make-hash-table :test 'eq :size 10)) (mapc (lambda (var) - (puthash var 1 redisplay--variables)) + (add-variable-watcher var (symbol-function 'set-buffer-redisplay))) '(line-spacing overline-margin line-prefix diff --git a/src/data.c b/src/data.c index a071261..527c770 100644 --- a/src/data.c +++ b/src/data.c @@ -1275,8 +1275,6 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where, default: emacs_abort (); } - maybe_set_redisplay (symbol); - start: switch (sym->redirect) { diff --git a/src/window.h b/src/window.h index a124b33..4a102f2 100644 --- a/src/window.h +++ b/src/window.h @@ -1063,7 +1063,6 @@ void set_window_buffer (Lisp_Object window, Lisp_Object buffer, extern void fset_redisplay (struct frame *f); extern void bset_redisplay (struct buffer *b); extern void bset_update_mode_line (struct buffer *b); -extern void maybe_set_redisplay (Lisp_Object); /* Call this to tell redisplay to look for other windows than selected-window that need to be redisplayed. Calling one of the *set_redisplay functions above already does it, so it's only needed in unusual cases. */ diff --git a/src/xdisp.c b/src/xdisp.c index 6e8af8a..9d36ab6 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -622,15 +622,15 @@ bset_update_mode_line (struct buffer *b) b->text->redisplay = true; } -void -maybe_set_redisplay (Lisp_Object symbol) +DEFUN ("set-buffer-redisplay", Fset_buffer_redisplay, + Sset_buffer_redisplay, 4, 4, 0, + doc: /* Mark the current buffer for redisplay. +This function may be passed to `add-variable-watcher'. */) + (Lisp_Object symbol, Lisp_Object newval, Lisp_Object op, Lisp_Object where) { - if (HASH_TABLE_P (Vredisplay__variables) - && hash_lookup (XHASH_TABLE (Vredisplay__variables), symbol, NULL) >= 0) - { bset_update_mode_line (current_buffer); current_buffer->prevent_redisplay_optimizations_p = true; - } + return Qnil; } #ifdef GLYPH_DEBUG @@ -31319,6 +31319,7 @@ syms_of_xdisp (void) message_dolog_marker3 = Fmake_marker (); staticpro (&message_dolog_marker3); + defsubr (&Sset_buffer_redisplay); #ifdef GLYPH_DEBUG defsubr (&Sdump_frame_glyph_matrix); defsubr (&Sdump_glyph_matrix); @@ -31988,10 +31989,6 @@ or t (meaning all windows). */); doc: /* */); Vredisplay__mode_lines_cause = Fmake_hash_table (0, NULL); - DEFVAR_LISP ("redisplay--variables", Vredisplay__variables, - doc: /* A hash-table of variables changing which triggers a thorough redisplay. */); - Vredisplay__variables = Qnil; - DEFVAR_BOOL ("redisplay--inhibit-bidi", redisplay__inhibit_bidi, doc: /* Non-nil means it is not safe to attempt bidi reordering for display. */); /* Initialize to t, since we need to disable reordering until -- 2.9.3 --=-=-= Content-Type: text/plain Content-Disposition: attachment; filename=v5-b-0004-Add-tests-for-watchpoints.patch Content-Description: patch >From e2b702ac03022b01f2f174522f03c89687c97909 Mon Sep 17 00:00:00 2001 From: Noam Postavsky Date: Sat, 12 Dec 2015 23:10:15 -0500 Subject: [PATCH v5 4/5] Add tests for watchpoints * test/src/data-tests.el (data-tests-variable-watchers): (data-tests-local-variable-watchers): New tests. --- test/src/data-tests.el | 115 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 115 insertions(+) diff --git a/test/src/data-tests.el b/test/src/data-tests.el index 0a29233..4c2ea54 100644 --- a/test/src/data-tests.el +++ b/test/src/data-tests.el @@ -255,3 +255,118 @@ test-bool-vector-binop (v2 (test-bool-vector-bv-from-hex-string "0000C")) (v3 (bool-vector-not v1))) (should (equal v2 v3)))) + +(ert-deftest data-tests-variable-watchers () + (defvar data-tests-var 0) + (let* ((watch-data nil) + (collect-watch-data + (lambda (&rest args) (push args watch-data)))) + (cl-flet ((should-have-watch-data (data) + (should (equal (pop watch-data) data)) + (should (null watch-data)))) + (add-variable-watcher 'data-tests-var collect-watch-data) + (setq data-tests-var 1) + (should-have-watch-data '(data-tests-var 1 set nil)) + (let ((data-tests-var 2)) + (should-have-watch-data '(data-tests-var 2 let nil)) + (setq data-tests-var 3) + (should-have-watch-data '(data-tests-var 3 set nil))) + (should-have-watch-data '(data-tests-var 1 unlet nil)) + ;; `setq-default' on non-local variable is same as `setq'. + (setq-default data-tests-var 4) + (should-have-watch-data '(data-tests-var 4 set nil)) + (makunbound 'data-tests-var) + (should-have-watch-data '(data-tests-var nil makunbound nil)) + (setq data-tests-var 5) + (should-have-watch-data '(data-tests-var 5 set nil)) + (remove-variable-watcher 'data-tests-var collect-watch-data) + (setq data-tests-var 6) + (should (null watch-data))))) + +(ert-deftest data-tests-varalias-watchers () + (defvar data-tests-var0 0) + (defvar data-tests-var1 0) + (defvar data-tests-var2 0) + (defvar data-tests-var3 0) + (let* ((watch-data nil) + (collect-watch-data + (lambda (&rest args) (push args watch-data)))) + (cl-flet ((should-have-watch-data (data) + (should (equal (pop watch-data) data)) + (should (null watch-data)))) + ;; Watch var0, then alias it. + (add-variable-watcher 'data-tests-var0 collect-watch-data) + (defvaralias 'data-tests-var0-alias 'data-tests-var0) + (setq data-tests-var0 1) + (should-have-watch-data '(data-tests-var0 1 set nil)) + (setq data-tests-var0-alias 2) + (should-have-watch-data '(data-tests-var0 2 set nil)) + ;; Alias var1, then watch var1-alias. + (defvaralias 'data-tests-var1-alias 'data-tests-var1) + (add-variable-watcher 'data-tests-var1-alias collect-watch-data) + (setq data-tests-var1 1) + (should-have-watch-data '(data-tests-var1 1 set nil)) + (setq data-tests-var1-alias 2) + (should-have-watch-data '(data-tests-var1 2 set nil)) + ;; Alias var2, then watch it. + (defvaralias 'data-tests-var2-alias 'data-tests-var2) + (add-variable-watcher 'data-tests-var2 collect-watch-data) + (setq data-tests-var2 1) + (should-have-watch-data '(data-tests-var2 1 set nil)) + (setq data-tests-var2-alias 2) + (should-have-watch-data '(data-tests-var2 2 set nil)) + ;; Watch var3-alias, then make it alias var3 (this removes the + ;; watcher flag). + (defvar data-tests-var3-alias 0) + (add-variable-watcher 'data-tests-var3-alias collect-watch-data) + (defvaralias 'data-tests-var3-alias 'data-tests-var3) + (should-have-watch-data '(data-tests-var3-alias + data-tests-var3 defvaralias nil)) + (setq data-tests-var3 1) + (setq data-tests-var3-alias 2) + (should (null watch-data))))) + +(ert-deftest data-tests-local-variable-watchers () + (defvar-local data-tests-lvar 0) + (let* ((buf1 (current-buffer)) + (buf2 nil) + (watch-data nil) + (collect-watch-data + (lambda (&rest args) (push args watch-data)))) + (cl-flet ((should-have-watch-data (data) + (should (equal (pop watch-data) data)) + (should (null watch-data)))) + (add-variable-watcher 'data-tests-lvar collect-watch-data) + (setq data-tests-lvar 1) + (should-have-watch-data `(data-tests-lvar 1 set ,buf1)) + (let ((data-tests-lvar 2)) + (should-have-watch-data `(data-tests-lvar 2 let ,buf1)) + (setq data-tests-lvar 3) + (should-have-watch-data `(data-tests-lvar 3 set ,buf1))) + (should-have-watch-data `(data-tests-lvar 1 unlet ,buf1)) + (setq-default data-tests-lvar 4) + (should-have-watch-data `(data-tests-lvar 4 set nil)) + (with-temp-buffer + (setq buf2 (current-buffer)) + (setq data-tests-lvar 1) + (should-have-watch-data `(data-tests-lvar 1 set ,buf2)) + (let ((data-tests-lvar 2)) + (should-have-watch-data `(data-tests-lvar 2 let ,buf2)) + (setq data-tests-lvar 3) + (should-have-watch-data `(data-tests-lvar 3 set ,buf2))) + (should-have-watch-data `(data-tests-lvar 1 unlet ,buf2)) + (kill-local-variable 'data-tests-lvar) + (should-have-watch-data `(data-tests-lvar nil makunbound ,buf2)) + (setq data-tests-lvar 3.5) + (should-have-watch-data `(data-tests-lvar 3.5 set ,buf2)) + (kill-all-local-variables) + (should-have-watch-data `(data-tests-lvar nil makunbound ,buf2))) + (setq-default data-tests-lvar 4) + (should-have-watch-data `(data-tests-lvar 4 set nil)) + (makunbound 'data-tests-lvar) + (should-have-watch-data '(data-tests-lvar nil makunbound nil)) + (setq data-tests-lvar 5) + (should-have-watch-data `(data-tests-lvar 5 set ,buf1)) + (remove-variable-watcher 'data-tests-lvar collect-watch-data) + (setq data-tests-lvar 6) + (should (null watch-data))))) -- 2.9.3 --=-=-= Content-Type: text/plain Content-Disposition: attachment; filename=v5-b-0005-etc-NEWS-Add-entry-for-watchpoints.patch Content-Description: patch >From 2b8818979d097cf0d6d975f5b5cdd2b0e6673f8a Mon Sep 17 00:00:00 2001 From: Noam Postavsky Date: Sun, 13 Dec 2015 14:47:58 -0500 Subject: [PATCH v5 5/5] * etc/NEWS: Add entry for watchpoints --- etc/NEWS | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/etc/NEWS b/etc/NEWS index e29dfe2..bc3b284 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -626,6 +626,10 @@ two objects are 'eq' ('eql'), then the result of 'sxhash-eq' consistency with the new functions. For compatibility, 'sxhash' remains as an alias to 'sxhash-equal'. +** New function `add-variable-watcher' can be used to call a function +when a symbol's value is changed. This is used to implement the new +debugger command `debug-watch'. + +++ ** Time conversion functions that accept a time zone rule argument now allow it to be OFFSET or a list (OFFSET ABBR), where the integer -- 2.9.3 --=-=-= Content-Type: text/plain For the manual, do you think I should document just the debugging commands, or should there additionally be a section in the "Variables" chapter about the watchpoint mechanism? --=-=-=--